diff options
| author | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2021-01-08 19:52:33 +0100 |
|---|---|---|
| committer | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2021-01-08 19:52:33 +0100 |
| commit | 2ffb97de37f8c5b22d379298739755ca4e18ceff (patch) | |
| tree | 5c42bd1e2bf68e62746a10ab83891ea2279f7dcc | |
| parent | 9bfc8b9943bf32b49e48b4a8f00f6b5db6d870b4 (diff) | |
| parent | 69b1b44c0b7761e0cb44cad747b36e12e5277cc1 (diff) | |
| download | compcert-kvx-2ffb97de37f8c5b22d379298739755ca4e18ceff.tar.gz compcert-kvx-2ffb97de37f8c5b22d379298739755ca4e18ceff.zip | |
Merge remote-tracking branch 'origin/kvx-work' into kvx-work-ssa
Not yet compilation fixed for aarch64
317 files changed, 31764 insertions, 7959 deletions
@@ -21,6 +21,7 @@ # Emacs saves *~ # Executables and configuration +/tools/compiler_expand /ccomp /ccomp.byte /ccomp.prof @@ -31,11 +32,13 @@ /Makefile.config /.merlin /_CoqProject +/compile.pl # Generated files /.depend /.depend.extr /midend/SSA/.depend /compcert.ini +/compcert.config /x86/ConstpropOp.v /x86/SelectOp.v /x86/SelectLong.v @@ -74,6 +77,7 @@ /lib/Responsefile.ml /driver/Version.ml /driver/Compiler.v +/extraction/extraction.v # Documentation /doc/coq2html /doc/coq2html.ml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c503c394..7f992502 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,7 +3,7 @@ stages: check-admitted: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - eval `opam config env` - opam update @@ -22,7 +22,7 @@ check-admitted: build_x86_64: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - eval `opam config env` - opam update @@ -43,7 +43,7 @@ build_x86_64: build_ia32: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-multilib @@ -66,7 +66,7 @@ build_ia32: build_aarch64: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user @@ -89,7 +89,7 @@ build_aarch64: build_arm: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-arm-linux-gnueabi qemu-user @@ -113,7 +113,7 @@ build_arm: build_armhf: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user @@ -136,7 +136,7 @@ build_armhf: build_ppc: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user @@ -157,7 +157,7 @@ build_ppc: build_ppc64: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-powerpc64-linux-gnu @@ -178,7 +178,7 @@ build_ppc64: build_rv64: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user @@ -201,7 +201,7 @@ build_rv64: build_rv32: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user @@ -222,7 +222,7 @@ build_rv32: build_kvx: stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install sshpass openssh-client libzip4 lttng-tools liblttng-ctl-dev liblttng-ust-dev babeltrace @@ -249,12 +249,12 @@ build_kvx: pages: # TODO: change to "deploy" when "build" succeeds (or integrate with "build_kvx" above ?) stage: build - image: coqorg/coq:8.11.2-ocaml-4.09.1-flambda + image: coqorg/coq:8.12.2-ocaml-4.11.1-flambda before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install sshpass openssh-client libzip4 lttng-tools liblttng-ctl-dev liblttng-ust-dev babeltrace - ./.download_from_Kalray.sh - - rm -f download/*dkms*.deb download/*eclipse*.deb download/*llvm*.deb download/*board-mgmt* download/*oce-host* download/*pocl* + - rm -f download/*dkms*.deb download/*eclipse*.deb download/*llvm*.deb download/*board-mgmt* download/*oce-host* download/*pocl* download/*flash-util* download/*barebox* - sudo dpkg -i download/*.deb - rm -rf download - eval `opam config env` @@ -1,3 +1,54 @@ +Release 3.8, 2020-11-16 +======================= + +New features: +- Support `_Static_assert` from ISO C11. +- Support `__builtin_constant_p` from GCC and Clang. +- New port: x86 64 bits Windows with the Cygwin 64 environment. + (configure with target `x86_64-cygwin`). +- The following built-in functions are now available for all ports: + `__builtin_sqrt`, `__builtin_fabsf`, and all variants of + `__builtin_clz` and `__builtin_ctz`. +- Added `__builtin_fmin` and `__builtin_fmax` for AArch64. + +Removed features: +- The x86 32 bits port is no longer supported under macOS. + +Compiler internals: +- Simpler translation of CompCert C casts used for their effects but + not for their values. +- Known builtins whose results are unused are eliminated earlier. +- Improved error reporting for `++` and `--` applied to pointers to + incomplete types. +- Improved error reporting for redefinitions and implicit definitions + of built-in functions. +- Added formal semantics for some PowerPC built-ins. + +The clightgen tool: +- New `-canonical-idents` mode, selected by default, to change the way + C identifiers are encoded as CompCert idents (positive numbers). + In `-canonical-idents` mode, a fixed one-to-one encoding is used + so that the same identifier occurring in different compilation units + encodes to the same number. +- The `-short-idents` flag restores the previous encoding where + C identifiers are consecutively numbered in order of appearance, + causing the same identifier to have different numbers in different + compilation units. +- Removed the automatic translation of annotation builtins to Coq + logical assertions, which was never used and possibly confusing. + +Coq and OCaml development: +- Compatibility with Coq 8.12.1, 8.12.0, 8.11.2, 8.11.1. +- Can use already-installed Flocq and MenhirLib libraries instead of their + local copies (options `-use-external-Flocq` and `-use-external-MenhirLib` + to the `configure` script). +- Automatically build to OCaml bytecode on platforms where OCaml + native-code compilation is not available. +- Install the `compcert.config` summary of configuration choices + in the same directory as the Coq development. +- Updated the list of dual-licensed source files. + + Release 3.7, 2020-03-31 ======================= @@ -46,8 +46,8 @@ option) any later version: all files in the exportclight/ directory - the Archi.v, CBuiltins.ml, and extractionMachdep.v files - in directories arm, powerpc, riscV, x86, x86_32, x86_64 + the Archi.v, Builtins1.v, CBuiltins.ml, and extractionMachdep.v files + in directories aarch64, arm, powerpc, riscV, x86, x86_32, x86_64 extraction/extraction.v @@ -14,6 +14,12 @@ ####################################################################### include Makefile.config +include VERSION + +BUILDVERSION ?= $(version) +BUILDNR ?= $(buildnr) +TAG ?= $(tag) +BRANCH ?= $(branch) ifeq ($(wildcard $(ARCH)_$(BITSIZE)),) ARCHDIRS?=$(ARCH) @@ -23,20 +29,36 @@ endif BACKENDLIB?=Asmgenproof0.v Asmgenproof1.v -DIRS=lib common $(ARCHDIRS) backend \ - midend midend/libSSA \ - cfrontend driver \ - flocq/Core flocq/Prop flocq/Calc flocq/IEEE754 \ - exportclight MenhirLib cparser +DIRS := lib lib/Impure common $(ARCHDIRS) scheduling backend \ + midend midend/libSSA \ + cfrontend driver \ + exportclight cparser + +RECDIRS:=lib common $(ARCHDIRS) scheduling backend \ + midend \ + cfrontend driver flocq exportclight \ + cparser -RECDIRS=lib common $(ARCHDIRS) backend \ - midend \ - cfrontend driver flocq exportclight \ - MenhirLib cparser +COQINCLUDES := $(foreach d, $(DIRS), -R $(d) compcert.$(subst /,.,$d)) + +ifeq ($(LIBRARY_FLOCQ),local) +DIRS += flocq/Core flocq/Prop flocq/Calc flocq/IEEE754 +RECDIRS += flocq +COQINCLUDES += -R flocq Flocq +endif -COQINCLUDES=$(foreach d, $(RECDIRS), -R $(d) $(subst /,.,compcert.$(d))) +ifeq ($(LIBRARY_MENHIRLIB),local) +DIRS += MenhirLib +RECDIRS += MenhirLib +COQINCLUDES += -R MenhirLib MenhirLib +MENHIRLIB=Alphabet.v Automaton.v Grammar.v Interpreter_complete.v \ + Interpreter_correct.v Interpreter.v Main.v Validator_complete.v \ + Validator_safe.v Validator_classes.v +else +MENHIRLIB= +endif -COQCOPTS ?= -w -undeclared-scope +COQCOPTS ?= -w -undeclared-scope -w -omega-is-deprecated COQC="$(COQBIN)coqc" -q $(COQINCLUDES) $(COQCOPTS) COQDEP="$(COQBIN)coqdep" $(COQINCLUDES) COQDOC="$(COQBIN)coqdoc" @@ -50,6 +72,7 @@ GPATH=$(DIRS) # Flocq +ifeq ($(LIBRARY_FLOCQ),local) FLOCQ=\ Raux.v Zaux.v Defs.v Digits.v Float_prop.v FIX.v FLT.v FLX.v FTZ.v \ Generic_fmt.v Round_pred.v Round_NE.v Ulp.v Core.v \ @@ -57,6 +80,9 @@ FLOCQ=\ Div_sqrt_error.v Mult_error.v Plus_error.v \ Relative.v Sterbenz.v Round_odd.v Double_rounding.v \ Binary.v Bits.v +else +FLOCQ= +endif # General-purpose libraries (in lib/) @@ -64,7 +90,9 @@ VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ HashedSet.v \ Iteration.v Zbits.v Integers.v Archi.v IEEE754_extra.v Floats.v \ Parmov.v UnionFind.v Wfsimpl.v \ - Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v + Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v \ + ImpConfig.v ImpExtern.v ImpIO.v ImpMonads.v \ + ImpCore.v ImpHCons.v ImpLoops.v ImpPrelude.v # General-purpose libraries for the SSA midend (in midend/libSSA) @@ -140,6 +168,13 @@ MIDEND=\ RTLpar.v RTLpargen.v RTLparproof.v RTLparcleanup.v \ RTLdpar.v RTLdparspec.v RTLdparproof.v +SCHEDULING= \ + RTLpathLivegenproof.v RTLpathSE_simu_specs.v \ + RTLpathLivegen.v RTLpathSE_impl.v \ + RTLpathproof.v RTLpathSE_theory.v \ + RTLpathSchedulerproof.v RTLpath.v \ + RTLpathScheduler.v + # C front-end modules (in cfrontend/) CFRONTEND=Ctypes.v Cop.v Csyntax.v Csem.v Ctyping.v Cstrategy.v Cexec.v \ @@ -155,9 +190,13 @@ PARSER=Cabs.v Parser.v # MenhirLib +ifeq ($(LIBRARY_MENHIRLIB),local) MENHIRLIB=Alphabet.v Automaton.v Grammar.v Interpreter_complete.v \ Interpreter_correct.v Interpreter.v Main.v Validator_complete.v \ Validator_safe.v Validator_classes.v +else +MENHIRLIB= +endif # Putting everything together (in driver/) @@ -165,10 +204,7 @@ DRIVER=Compopts.v Compiler.v Complements.v # All source files -FILES=$(VLIB) $(VLIB2) \ - $(COMMON) $(BACKEND) \ - $(MIDEND) \ - $(CFRONTEND) $(DRIVER) $(FLOCQ) \ +FILES=$(VLIB) $(COMMON) $(BACKEND) $(SCHEDULING) $(MIDEND) $(CFRONTEND) $(DRIVER) $(FLOCQ) \ $(MENHIRLIB) $(PARSER) # Generated source files @@ -190,6 +226,9 @@ endif ifeq ($(CLIGHTGEN),true) $(MAKE) clightgen endif +ifeq ($(INSTALL_COQDEV),true) + $(MAKE) compcert.config +endif proof: $(FILES:.v=.vo) @@ -211,6 +250,10 @@ ccomp: .depend.extr compcert.ini driver/Version.ml FORCE ccomp.byte: .depend.extr compcert.ini driver/Version.ml FORCE $(MAKE) -f Makefile.extr ccomp.byte +# DM force compilation without checking dependencies +ccomp.force: .depend.extr compcert.ini driver/Version.ml FORCE + $(MAKE) -f Makefile.extr ccomp.force + clightgen: .depend.extr compcert.ini exportclight/Clightdefs.vo driver/Version.ml FORCE $(MAKE) -f Makefile.extr clightgen clightgen.byte: .depend.extr compcert.ini exportclight/Clightdefs.vo driver/Version.ml FORCE @@ -230,11 +273,25 @@ documentation: $(FILES) $(filter-out doc/coq2html cparser/Parser.v, $^) tools/ndfun: tools/ndfun.ml +ifeq ($(OCAML_NATIVE_COMP),true) ocamlopt -o tools/ndfun str.cmxa tools/ndfun.ml -tools/modorder: tools/modorder.ml - ocamlopt -o tools/modorder str.cmxa tools/modorder.ml +else + ocamlc -o tools/ndfun str.cma tools/ndfun.ml +endif + tools/compiler_expand: tools/compiler_expand.ml +ifeq ($(OCAML_NATIVE_COMP),true) ocamlopt -o $@ $+ +else + ocamlc -o $@ $+ +endif + +tools/modorder: tools/modorder.ml +ifeq ($(OCAML_NATIVE_COMP),true) + ocamlopt -o tools/modorder str.cmxa tools/modorder.ml +else + ocamlc -o tools/modorder str.cma tools/modorder.ml +endif latexdoc: cd doc; $(COQDOC) --latex -o doc/doc.tex -g $(FILES) @@ -250,6 +307,15 @@ latexdoc: @tools/ndfun $*.vp > $*.v || { rm -f $*.v; exit 2; } @chmod a-w $*.v +# this trick aims to allow extraction to depend on the target processor +# (currently: export extra Coq-functions for OCaml code, depending on the target) +extraction/extraction.v: Makefile extraction/extraction.vexpand + (echo "(* WARNING: this file is generated from extraction.vexpand *)"; \ + echo "(* by the Makefile -- target \"extraction/extraction.v\" *)\n"; \ + cat extraction/extraction.vexpand; \ + echo "$(EXTRA_EXTRACTION)"; \ + echo ".") > extraction/extraction.v + driver/Compiler.v: driver/Compiler.vexpand tools/compiler_expand tools/compiler_expand driver/Compiler.vexpand $@ @@ -272,14 +338,29 @@ compcert.ini: Makefile.config echo "response_file_style=$(RESPONSEFILE)";) \ > compcert.ini +compcert.config: Makefile.config + (echo "# CompCert configuration parameters"; \ + echo "COMPCERT_ARCH=$(ARCH)"; \ + echo "COMPCERT_MODEL=$(MODEL)"; \ + echo "COMPCERT_ABI=$(ABI)"; \ + echo "COMPCERT_ENDIANNESS=$(ENDIANNESS)"; \ + echo "COMPCERT_BITSIZE=$(BITSIZE)"; \ + echo "COMPCERT_SYSTEM=$(SYSTEM)"; \ + echo "COMPCERT_VERSION=$(BUILDVERSION)"; \ + echo "COMPCERT_BUILDNR=$(BUILDNR)"; \ + echo "COMPCERT_TAG=$(TAG)"; \ + echo "COMPCERT_BRANCH=$(BRANCH)" \ + ) > compcert.config + driver/Version.ml: VERSION - cat VERSION \ - | sed -e 's|\(.*\)=\(.*\)|let \1 = \"\2\"|g' \ - >driver/Version.ml + (echo 'let version = "$(BUILDVERSION)"'; \ + echo 'let buildnr = "$(BUILDNR)"'; \ + echo 'let tag = "$(TAG)"'; \ + echo 'let branch = "$(BRANCH)"') > driver/Version.ml cparser/Parser.v: cparser/Parser.vy @rm -f $@ - $(MENHIR) --coq --coq-lib-path compcert.MenhirLib --coq-no-version-check cparser/Parser.vy + $(MENHIR) --coq --coq-no-version-check cparser/Parser.vy @chmod a-w $@ depend: $(GENERATED) depend1 @@ -306,6 +387,7 @@ ifeq ($(INSTALL_COQDEV),true) install -m 0644 $$d/*.vo $(DESTDIR)$(COQDEVDIR)/$$d/; \ done install -m 0644 ./VERSION $(DESTDIR)$(COQDEVDIR) + install -m 0644 ./compcert.config $(DESTDIR)$(COQDEVDIR) @(echo "To use, pass the following to coq_makefile or add the following to _CoqProject:"; echo "-R $(COQDEVDIR) compcert") > $(DESTDIR)$(COQDEVDIR)/README endif @@ -315,10 +397,10 @@ clean: rm -f $(patsubst %, %/.*.aux, $(DIRS)) rm -f $(patsubst %, %/*~, $(DIRS)) rm -rf doc/html doc/*.glob - rm -f driver/Version.ml - rm -f compcert.ini - rm -f extraction/STAMP extraction/*.ml extraction/*.mli .depend.extr - rm -f tools/ndfun tools/modorder tools/*.cm? tools/*.o + rm -f driver/Version.ml driver/Compiler.v + rm -f compcert.ini compcert.config + rm -f extraction/STAMP extraction/*.ml extraction/*.mli .depend.extr extraction/extraction.v + rm -f tools/ndfun tools/modorder tools/compiler_expand tools/*.cm? tools/*.o rm -f $(GENERATED) .depend rm -f .lia.cache $(MAKE) -f Makefile.extr clean @@ -351,6 +433,9 @@ check-proof: $(FILES) print-includes: @echo $(COQINCLUDES) +CoqProject: + @echo $(COQINCLUDES) > _CoqProject + -include .depend FORCE: diff --git a/Makefile.extr b/Makefile.extr index f3e984f5..5ec43ced 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -19,7 +19,8 @@ include Makefile.config # # Variables from Makefile.config: -# -OCAML_OPT_COMP: can we use the native version +# -OCAML_NATIVE_COMP: native-code compilation is supported +# -OCAML_OPT_COMP: can we use the natively-compiled compilers # -COMPFLAGS: compile options # -LINK_OPT: additional linker flags for the native binary # @@ -42,20 +43,30 @@ cparser/pre_parser_messages.ml: # Directories containing plain Caml code DIRS=extraction \ - lib common $(ARCH) backend midend/SSA midend cfrontend cparser driver \ - exportclight debug kvx/unittest kvx/abstractbb/Impure/ocaml + lib common $(ARCH) scheduling backend midend/SSA midend \ + cfrontend cparser driver \ + exportclight debug kvx/unittest lib/Impure/ocaml INCLUDES=$(patsubst %,-I %, $(DIRS)) # Control of warnings: -WARNINGS=-w +a-4-9-27-42 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03 +# WARNINGS=-w +a-4-9-27-42 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03 +WARNINGS=-w +a-4-9-27-42 + extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 cparser/pre_parser.cmx: WARNINGS += -w -41 cparser/pre_parser.cmo: WARNINGS += -w -41 -COMPFLAGS+=-g $(INCLUDES) -I "$(MENHIR_DIR)" $(WARNINGS) +# Turn warnings into errors, but not for released tarballs +ifeq ($(wildcard .git),.git) +WARN_ERRORS=-warn-error +a +else +WARN_ERRORS= +endif + +COMPFLAGS+=-g -strict-sequence -safe-string $(INCLUDES) -I "$(MENHIR_DIR)" $(WARNINGS) $(WARN_ERRORS) # Using .opt compilers if available @@ -71,6 +82,7 @@ OCAMLDEP=ocamldep$(DOTOPT) -slash $(INCLUDES) OCAMLLEX=ocamllex -q MODORDER=tools/modorder .depend.extr +COPY=cp PARSERS=cparser/pre_parser.mly LEXERS=cparser/Lexer.mll lib/Tokenize.mll \ @@ -88,19 +100,35 @@ ifeq ($(wildcard .depend.extr),.depend.extr) CCOMP_OBJS:=$(shell $(MODORDER) driver/Driver.cmx) +ifeq ($(OCAML_NATIVE_COMP),true) ccomp: $(CCOMP_OBJS) @echo "Linking $@" @$(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $+ +else +ccomp: ccomp.byte + @echo "Copying to $@" + @$(COPY) $+ $@ +endif +# DM force compilation without checking dependencies +ccomp.force: + $(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $(CCOMP_OBJS) + ccomp.byte: $(CCOMP_OBJS:.cmx=.cmo) @echo "Linking $@" @$(OCAMLC) -o $@ $(LIBS_BYTE) $+ CLIGHTGEN_OBJS:=$(shell $(MODORDER) exportclight/Clightgen.cmx) +ifeq ($(OCAML_NATIVE_COMP),true) clightgen: $(CLIGHTGEN_OBJS) @echo "Linking $@" @$(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $+ +else +clightgen: clightgen.byte + @echo "Copying to $@" + @$(COPY) $+ $@ +endif clightgen.byte: $(CLIGHTGEN_OBJS:.cmx=.cmo) @echo "Linking $@" diff --git a/MenhirLib/Alphabet.v b/MenhirLib/Alphabet.v index 29070e3d..530e3b4a 100644 --- a/MenhirLib/Alphabet.v +++ b/MenhirLib/Alphabet.v @@ -11,7 +11,8 @@ (* *) (****************************************************************************) -From Coq Require Import Omega List Syntax Relations RelationClasses. +From Coq Require Import Omega List Relations RelationClasses. +Import ListNotations. Local Obligation Tactic := intros. diff --git a/MenhirLib/Grammar.v b/MenhirLib/Grammar.v index a371318b..9be374e8 100644 --- a/MenhirLib/Grammar.v +++ b/MenhirLib/Grammar.v @@ -11,7 +11,8 @@ (* *) (****************************************************************************) -From Coq Require Import List Syntax Orders. +From Coq Require Import List Orders. +Import ListNotations. Require Import Alphabet. (** The terminal non-terminal alphabets of the grammar. **) diff --git a/MenhirLib/Interpreter.v b/MenhirLib/Interpreter.v index 568597ba..07aeae5a 100644 --- a/MenhirLib/Interpreter.v +++ b/MenhirLib/Interpreter.v @@ -12,6 +12,7 @@ (****************************************************************************) From Coq Require Import List Syntax. +Import ListNotations. From Coq.ssr Require Import ssreflect. Require Automaton. Require Import Alphabet Grammar Validator_safe. diff --git a/MenhirLib/Interpreter_complete.v b/MenhirLib/Interpreter_complete.v index ec69592b..51f2524b 100644 --- a/MenhirLib/Interpreter_complete.v +++ b/MenhirLib/Interpreter_complete.v @@ -11,7 +11,8 @@ (* *) (****************************************************************************) -From Coq Require Import List Syntax Arith. +From Coq Require Import List Arith. +Import ListNotations. From Coq.ssr Require Import ssreflect. Require Import Alphabet Grammar. Require Automaton Interpreter Validator_complete. diff --git a/MenhirLib/Interpreter_correct.v b/MenhirLib/Interpreter_correct.v index 1325f610..083be5b7 100644 --- a/MenhirLib/Interpreter_correct.v +++ b/MenhirLib/Interpreter_correct.v @@ -11,7 +11,8 @@ (* *) (****************************************************************************) -From Coq Require Import List Syntax. +From Coq Require Import List. +Import ListNotations. Require Import Alphabet. Require Grammar Automaton Interpreter. From Coq.ssr Require Import ssreflect. diff --git a/MenhirLib/Validator_complete.v b/MenhirLib/Validator_complete.v index ebb74500..9ba3e53c 100644 --- a/MenhirLib/Validator_complete.v +++ b/MenhirLib/Validator_complete.v @@ -13,6 +13,7 @@ From Coq Require Import List Syntax Derive. From Coq.ssr Require Import ssreflect. +Import ListNotations. Require Automaton. Require Import Alphabet Validator_classes. diff --git a/MenhirLib/Validator_safe.v b/MenhirLib/Validator_safe.v index 628d2009..e7a54b47 100644 --- a/MenhirLib/Validator_safe.v +++ b/MenhirLib/Validator_safe.v @@ -12,6 +12,7 @@ (****************************************************************************) From Coq Require Import List Syntax Derive. +Import ListNotations. From Coq.ssr Require Import ssreflect. Require Automaton. Require Import Alphabet Validator_classes. @@ -1,5 +1,5 @@ # CompCert -The verified C compiler. +The formally-verified C compiler. ## Overview The CompCert C verified compiler is a compiler for a large subset of the @@ -13,8 +13,8 @@ source C code. For more information on CompCert (supported platforms, supported C features, installation instructions, using the compiler, etc), please -refer to the [Web site](http://compcert.inria.fr/) and especially -the [user's manual](http://compcert.inria.fr/man/). +refer to the [Web site](https://compcert.org/) and especially +the [user's manual](https://compcert.org/man/). ## Verimag-Kalray version This is a special version with additions from Verimag and Kalray : @@ -54,7 +54,7 @@ Pichardie, Léo Stefanesco. CompCert is not free software. This non-commercial release can only be used for evaluation, research, educational and personal purposes. A commercial version of CompCert, without this restriction and with -professional support, can be purchased from +professional support and extra features, can be purchased from [AbsInt](https://www.absint.com). See the file `LICENSE` for more information. @@ -1,3 +1,4 @@ -version=3.7 +version=3.8 buildnr= tag= +branch= diff --git a/aarch64/Archi.v b/aarch64/Archi.v index 7d7b6887..7f39d1fa 100644 --- a/aarch64/Archi.v +++ b/aarch64/Archi.v @@ -6,15 +6,17 @@ (* *) (* 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. *) (* *) (* *********************************************************************) (** Architecture-dependent parameters for AArch64 *) +From Flocq Require Import Binary Bits. Require Import ZArith List. -(*From Flocq*) -Require Import Binary Bits. Definition ptr64 := true. diff --git a/aarch64/Asm.v b/aarch64/Asm.v index 47cd3051..dc1f025f 100644 --- a/aarch64/Asm.v +++ b/aarch64/Asm.v @@ -10,13 +10,20 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for AArch64 assembly language *) +(** Abstract syntax and semantics for AArch64 assembly language + +W.r.t Asmblock, this is a "flat" syntax and semantics of "aarch64" assembly: + - without the basic block structure + - without the hierarchy of instructions. + +*) Require Import Coqlib Zbits Maps. Require Import AST Integers Floats. Require Import Values Memory Events Globalenvs Smallstep. Require Import Locations Conventions. Require Stacklayout. +Require Import OptionMonad. (** * Abstract syntax *) @@ -43,6 +50,9 @@ Coercion RR1: ireg >-> iregsp. Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. Proof. decide equality. Defined. +Lemma iregsp_eq: forall (x y: iregsp), {x=y} + {x<>y}. +Proof. decide equality; apply ireg_eq. Defined. + (** In assembly files, [Dn] denotes the low 64-bit of a vector register, and [Sn] the low 32 bits. *) @@ -66,21 +76,29 @@ Inductive crbit: Type := Lemma crbit_eq: forall (x y: crbit), {x=y} + {x<>y}. Proof. decide equality. Defined. +Inductive dreg : Type := + | IR: iregsp -> dreg (**r 64- or 32-bit integer registers *) + | FR: freg -> dreg. (**r double- or single-precision float registers *) + (** We model the following registers of the ARM architecture. *) Inductive preg: Type := - | IR: ireg -> preg (**r 64- or 32-bit integer registers *) - | FR: freg -> preg (**r double- or single-precision float registers *) - | CR: crbit -> preg (**r bits in the condition register *) - | SP: preg (**r register X31 used as stack pointer *) - | PC: preg. (**r program counter *) - -Coercion IR: ireg >-> preg. -Coercion FR: freg >-> preg. + | DR: dreg -> preg (** see dreg **) + | CR: crbit -> preg (**r bits in the condition register *) + | PC: preg. (**r program counter *) + +(* XXX: ireg no longer coerces to preg *) +Coercion IR: iregsp >-> dreg. +Coercion FR: freg >-> dreg. +Coercion DR: dreg >-> preg. +Definition SP:preg := XSP. Coercion CR: crbit >-> preg. +Lemma dreg_eq: forall (x y: dreg), {x=y} + {x<>y}. +Proof. decide equality. apply iregsp_eq. apply freg_eq. Defined. + Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. apply crbit_eq. Defined. +Proof. decide equality. apply dreg_eq. apply crbit_eq. Defined. Module PregEq. Definition t := preg. @@ -92,8 +110,6 @@ Module Pregmap := EMap(PregEq). Definition preg_of_iregsp (r: iregsp) : preg := match r with RR1 r => IR r | XSP => SP end. -Coercion preg_of_iregsp: iregsp >-> preg. - (** Conventional name for return address ([RA]) *) Notation "'RA'" := X30 (only parsing) : asm. @@ -177,14 +193,16 @@ Inductive instruction: Type := | Pldrsh (sz: isize) (rd: ireg) (a: addressing) (**r load int16, sign-extend *) | Pldrzw (rd: ireg) (a: addressing) (**r load int32, zero-extend to int64 *) | Pldrsw (rd: ireg) (a: addressing) (**r load int32, sign-extend to int64 *) - | Pldp (rd1 rd2: ireg) (a: addressing) (**r load two int64 *) + | Pldpw (rd1 rd2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r load two int32 *) + | Pldpx (rd1 rd2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r load two int64 *) | Pstrw (rs: ireg) (a: addressing) (**r store int32 *) | Pstrw_a (rs: ireg) (a: addressing) (**r store int32 as any32 *) | Pstrx (rs: ireg) (a: addressing) (**r store int64 *) | Pstrx_a (rs: ireg) (a: addressing) (**r store int64 as any64 *) | Pstrb (rs: ireg) (a: addressing) (**r store int8 *) | Pstrh (rs: ireg) (a: addressing) (**r store int16 *) - | Pstp (rs1 rs2: ireg) (a: addressing) (**r store two int64 *) + | Pstpw (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) + | Pstpx (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) (** Integer arithmetic, immediate *) | Paddimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r addition *) | Psubimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r subtraction *) @@ -237,6 +255,7 @@ Inductive instruction: Type := | Pclz (sz: isize) (rd r1: ireg) (**r count leading zero bits *) | Prev (sz: isize) (rd r1: ireg) (**r reverse bytes *) | Prev16 (sz: isize) (rd r1: ireg) (**r reverse bytes in each 16-bit word *) + | Prbit (sz: isize) (rd r1: ireg) (**r reverse bits *) (** Conditional data processing *) | Pcsel (rd: ireg) (r1 r2: ireg) (c: testcond) (**r int conditional move *) | Pcset (rd: ireg) (c: testcond) (**r set to 1/0 if cond is true/false *) @@ -282,6 +301,8 @@ Inductive instruction: Type := | Pfmsub (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = r3 - r1 * r2] *) | Pfnmadd (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = - r3 - r1 * r2] *) | Pfnmsub (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = - r3 + r1 * r2] *) + | Pfmax (sz: fsize) (rd r1 r2: freg) (**r maximum *) + | Pfmin (sz: fsize) (rd r1 r2: freg) (**r minimum *) (** Floating-point comparison *) | Pfcmp (sz: fsize) (r1 r2: freg) (**r compare [r1] and [r2] *) | Pfcmp0 (sz: fsize) (r1: freg) (**r compare [r1] and [+0.0] *) @@ -307,9 +328,30 @@ Definition code := list instruction. Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. Definition fundef := AST.fundef function. Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +(** The two functions below axiomatize how the linker processes + symbolic references [symbol + offset]. It computes the + difference between the address and the PC, and splits it into: + - 12 low bits usable as an offset in an addressing mode; + - 21 high bits usable as argument to the ADRP instruction. + + In CompCert's model, we cannot really describe PC-relative addressing, + but we can claim that the address of [symbol + offset] decomposes + as the sum of + - a low part, usable as an offset in an addressing mode; + - a high part, usable as argument to the ADRP instruction. *) + +Parameter symbol_low: genv -> ident -> ptrofs -> val. +Parameter symbol_high: genv -> ident -> ptrofs -> val. + +Axiom symbol_high_low: + forall (ge: genv) (id: ident) (ofs: ptrofs), + Val.addl (symbol_high ge id ofs) (symbol_low ge id ofs) = Genv.symbol_address ge id ofs. (** * Operational semantics *) + (** The semantics operates over a single mapping from registers (type [preg]) to values. We maintain (but do not enforce) the convention that integer registers are mapped to values of @@ -317,22 +359,19 @@ Definition program := AST.program fundef unit. and condition bits to either [Vzero] or [Vone]. *) Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef unit. (** The value of an [ireg0] is either the value of the integer register, or 0. *) -Definition ir0w (rs: regset) (r: ireg0) : val := - match r with RR0 r => rs (IR r) | XZR => Vint Int.zero end. -Definition ir0x (rs: regset) (r: ireg0) : val := - match r with RR0 r => rs (IR r) | XZR => Vlong Int64.zero end. +Definition ir0 (is:isize) (rs: regset) (r: ireg0) : val := + match r with RR0 r => rs (IR r) | XZR => if is (* is W *) then Vint Int.zero else Vlong Int64.zero end. (** Concise notations for accessing and updating the values of registers. *) Notation "a # b" := (a b) (at level 1, only parsing) : asm. Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. -Notation "a ## b" := (ir0w a b) (at level 1, only parsing) : asm. -Notation "a ### b" := (ir0x a b) (at level 1, only parsing) : asm. +Notation "a ## b" := (ir0 W a b) (at level 1, only parsing) : asm. +Notation "a ### b" := (ir0 X a b) (at level 1, only parsing) : asm. Open Scope asm. @@ -366,84 +405,16 @@ Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) end. -(** The two functions below axiomatize how the linker processes - symbolic references [symbol + offset]. It computes the - difference between the address and the PC, and splits it into: - - 12 low bits usable as an offset in an addressing mode; - - 21 high bits usable as argument to the ADRP instruction. - - In CompCert's model, we cannot really describe PC-relative addressing, - but we can claim that the address of [symbol + offset] decomposes - as the sum of - - a low part, usable as an offset in an addressing mode; - - a high part, usable as argument to the ADRP instruction. *) - -Parameter symbol_low: genv -> ident -> ptrofs -> val. -Parameter symbol_high: genv -> ident -> ptrofs -> val. - -Axiom symbol_high_low: - forall (ge: genv) (id: ident) (ofs: ptrofs), - Val.addl (symbol_high ge id ofs) (symbol_low ge id ofs) = Genv.symbol_address ge id ofs. - -Section RELSEM. - -Variable ge: genv. - -(** Looking up instructions in a code sequence by position. *) - -Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := - match c with - | nil => None - | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il - end. - -(** Position corresponding to a label *) - -Definition is_label (lbl: label) (instr: instruction) : bool := - match instr with - | Plabel lbl' => if peq lbl lbl' then true else false - | _ => false - end. - -Lemma is_label_correct: - forall lbl instr, - if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. -Proof. - intros. destruct instr; simpl; try discriminate. destruct (peq lbl lbl0); congruence. -Qed. - -Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' - end. - (** The semantics is purely small-step and defined as a function from the current state (a register set + a memory state) to either [Next rs' m'] where [rs'] and [m'] are the updated register set and memory state after execution of the instruction at [rs#PC], or [Stuck] if the processor is stuck. *) -Inductive outcome: Type := - | Next: regset -> mem -> outcome - | Stuck: outcome. - -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextinstr]) or branching to a label ([goto_label]). *) - -Definition nextinstr (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). - -Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := - match label_pos lbl 0 (fn_code f) with - | None => Stuck - | Some pos => - match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m - | _ => Stuck - end - end. +Record state: Type := State { _rs: regset; _m: mem }. +Definition outcome := option state. +Definition Next rs m: outcome := Some (State rs m). +Definition Stuck: outcome := None. (** Testing a condition *) @@ -513,10 +484,10 @@ Definition eval_testcond (c: testcond) (rs: regset) : option bool := (** Integer "is zero?" test *) -Definition eval_testzero (sz: isize) (v: val) (m: mem): option bool := +Definition eval_testzero (sz: isize) (v: val): option bool := match sz with - | W => Val.cmpu_bool (Mem.valid_pointer m) Ceq v (Vint Int.zero) - | X => Val.cmplu_bool (Mem.valid_pointer m) Ceq v (Vlong Int64.zero) + | W => Val.mxcmpu_bool Ceq v (Vint Int.zero) + | X => Val.mxcmplu_bool Ceq v (Vlong Int64.zero) end. (** Integer "bit is set?" test *) @@ -527,48 +498,19 @@ Definition eval_testbit (sz: isize) (v: val) (n: int): option bool := | X => Val.cmpl_bool Cne (Val.andl v (Vlong (Int64.shl' Int64.one n))) (Vlong Int64.zero) end. -(** Evaluating an addressing mode *) - -Definition eval_addressing (a: addressing) (rs: regset): val := - match a with - | ADimm base n => Val.addl rs#base (Vlong n) - | ADreg base r => Val.addl rs#base rs#r - | ADlsl base r n => Val.addl rs#base (Val.shll rs#r (Vint n)) - | ADsxt base r n => Val.addl rs#base (Val.shll (Val.longofint rs#r) (Vint n)) - | ADuxt base r n => Val.addl rs#base (Val.shll (Val.longofintu rs#r) (Vint n)) - | ADadr base id ofs => Val.addl rs#base (symbol_low ge id ofs) - | ADpostincr base n => Vundef (* not modeled yet *) - end. - -(** Auxiliaries for memory accesses *) - -Definition exec_load (chunk: memory_chunk) (transf: val -> val) - (a: addressing) (r: preg) (rs: regset) (m: mem) := - match Mem.loadv chunk m (eval_addressing a rs) with - | None => Stuck - | Some v => Next (nextinstr (rs#r <- (transf v))) m - end. - -Definition exec_store (chunk: memory_chunk) - (a: addressing) (v: val) - (rs: regset) (m: mem) := - match Mem.storev chunk m (eval_addressing a rs) v with - | None => Stuck - | Some m' => Next (nextinstr rs) m' - end. (** Comparisons *) -Definition compare_int (rs: regset) (v1 v2: val) (m: mem) := +Definition compare_int (rs: regset) (v1 v2: val) := rs#CN <- (Val.negative (Val.sub v1 v2)) - #CZ <- (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) - #CC <- (Val.cmpu (Mem.valid_pointer m) Cge v1 v2) + #CZ <- (Val.mxcmpu Ceq v1 v2) + #CC <- (Val.mxcmpu Cge v1 v2) #CV <- (Val.sub_overflow v1 v2). -Definition compare_long (rs: regset) (v1 v2: val) (m: mem) := +Definition compare_long (rs: regset) (v1 v2: val) := rs#CN <- (Val.negativel (Val.subl v1 v2)) - #CZ <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2)) - #CC <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cge v1 v2)) + #CZ <- (Val.mxcmplu Ceq v1 v2) + #CC <- (Val.mxcmplu Cge v1 v2) #CV <- (Val.subl_overflow v1 v2). (** Semantics of [fcmp] instructions: @@ -669,19 +611,230 @@ Definition float64_of_bits (v: val): val := | _ => Vundef end. -(** Execution of a single instruction [i] in initial state - [rs] and [m]. Return updated state. For instructions - that correspond to actual AArch64 instructions, the cases are - straightforward transliterations of the informal descriptions - given in the ARMv8 reference manuals. For pseudo-instructions, - refer to the informal descriptions given above. - - Note that we set to [Vundef] the registers used as temporaries by - the expansions of the pseudo-instructions, so that the code we - generate cannot use those registers to hold values that must - survive the execution of the pseudo-instruction. +(* Recognition of FP numbers that are supported by the fmov #imm instructions: + "a normalized binary floating point encoding with 1 sign bit, + 4 bits of fraction and a 3-bit exponent" *) +Definition is_immediate_float64 (f: float): bool := + let bits := Float.to_bits f in + let exp := + Int64.sub + (Int64.and (Int64.shr' bits (Int.repr 52)) + (Int64.repr 2047)) (Int64.repr 1023) in + let mant := + Int64.and bits (Int64.repr 4503599627370495) in + andb (Int64.cmp Cge exp (Int64.repr (-3))) + (andb (Int64.cmp Cle exp (Int64.repr 4)) + (Int64.eq + (Int64.and mant + (Int64.repr 4222124650659840)) mant)). + +Definition is_immediate_float32 (f: float32): bool := + let bits := Float32.to_bits f in + let exp := + Int.sub + (Int.and (Int.shr bits (Int.repr 23)) + (Int.repr 255)) (Int.repr 127) in + let mant := + Int.and bits (Int.repr 8388607) in + andb (Int.cmp Cge exp (Int.repr (-3))) + (andb (Int.cmp Cle exp (Int.repr 4)) + (Int.eq + (Int.and mant + (Int.repr 7864320)) mant)). + +(** Translation of the LTL/Linear/Mach view of machine registers + to the AArch64 view. Note that no LTL register maps to [X16], + [X18], nor [X30]. + [X18] is reserved as the platform register and never used by the + code generated by CompCert. + [X30] is used for the return address, and can also be used as temporary. + [X16] can be used as temporary. *) + +Definition dreg_of (r: mreg) : dreg := + match r with + | R0 => X0 | R1 => X1 | R2 => X2 | R3 => X3 + | R4 => X4 | R5 => X5 | R6 => X6 | R7 => X7 + | R8 => X8 | R9 => X9 | R10 => X10 | R11 => X11 + | R12 => X12 | R13 => X13 | R14 => X14 | R15 => X15 + | R17 => X17 | R19 => X19 + | R20 => X20 | R21 => X21 | R22 => X22 | R23 => X23 + | R24 => X24 | R25 => X25 | R26 => X26 | R27 => X27 + | R28 => X28 | R29 => X29 + | F0 => D0 | F1 => D1 | F2 => D2 | F3 => D3 + | F4 => D4 | F5 => D5 | F6 => D6 | F7 => D7 + | F8 => D8 | F9 => D9 | F10 => D10 | F11 => D11 + | F12 => D12 | F13 => D13 | F14 => D14 | F15 => D15 + | F16 => D16 | F17 => D17 | F18 => D18 | F19 => D19 + | F20 => D20 | F21 => D21 | F22 => D22 | F23 => D23 + | F24 => D24 | F25 => D25 | F26 => D26 | F27 => D27 + | F28 => D28 | F29 => D29 | F30 => D30 | F31 => D31 + end. + +Definition preg_of (r: mreg) : preg := + dreg_of r. + +(** Undefine all registers except SP and callee-save registers *) + +Definition undef_caller_save_regs (rs: regset) : regset := + fun r => + if preg_eq r SP + || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) + then rs r + else Vundef. + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use AArch64 registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (preg_of r)) + | extcall_arg_stack: forall ofs ty bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv (chunk_of_type ty) m + (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> + extcall_arg rs m (Locations.S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). + +(** Looking up instructions in a code sequence by position. *) + +Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := + match c with + | nil => None + | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il + end. + +(** Position corresponding to a label *) + +Definition is_label (lbl: label) (instr: instruction) : bool := + match instr with + | Plabel lbl' => if peq lbl lbl' then true else false + | _ => false + end. + +Lemma is_label_correct: + forall lbl instr, + if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. +Proof. + intros. destruct instr; simpl; try discriminate. destruct (peq lbl lbl0); congruence. +Qed. + +Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some pos else label_pos lbl (pos + 1) c' + end. + +Definition nextinstr (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := + match label_pos lbl 0 (fn_code f) with + | None => Stuck + | Some pos => + match rs#PC with + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m + | _ => Stuck + end + end. + +Section RELSEM. + +Variable ge: genv. + +(** Evaluating an addressing mode *) + +Definition eval_addressing (a: addressing) (rs: regset): val := + match a with + | ADimm base n => Val.addl rs#base (Vlong n) + | ADreg base r => Val.addl rs#base rs#r + | ADlsl base r n => Val.addl rs#base (Val.shll rs#r (Vint n)) + | ADsxt base r n => Val.addl rs#base (Val.shll (Val.longofint rs#r) (Vint n)) + | ADuxt base r n => Val.addl rs#base (Val.shll (Val.longofintu rs#r) (Vint n)) + | ADadr base id ofs => Val.addl rs#base (symbol_low ge id ofs) + | ADpostincr base n => Vundef + end. + +Definition is_pair_addressing_mode_correct (a: addressing): bool := + match a with + | ADimm _ _ => true + | _ => false + end. + +Definition get_offset_addr (a: addressing) (ofs: Z) : addressing := + match a with + | ADimm base n => (ADimm base (Int64.add n (Int64.repr ofs))) + | _ => a + end. + +(** Auxiliaries for memory accesses *) + +Definition exec_load (chunk: memory_chunk) (transf: val -> val) + (a: addressing) (r: preg) (rs: regset) (m: mem) := + match Mem.loadv chunk m (eval_addressing a rs) with + | None => Stuck + | Some v => Next (nextinstr (rs#r <- (transf v))) m + end. + +Definition exec_load_double (chk1 chk2: memory_chunk) (transf: val -> val) + (a: addressing) (rd1 rd2: preg) (rs: regset) (m: mem) := + if is_pair_addressing_mode_correct a then + let addr := (eval_addressing a rs) in + let ofs := match chk1 with | Mint32 | Many32 => 4 | _ => 8 end in + let addr' := (eval_addressing (get_offset_addr a ofs) rs) in + match Mem.loadv chk1 m addr with + | None => Stuck + | Some v1 => + match Mem.loadv chk2 m addr' with + | None => Stuck + | Some v2 => + Next (nextinstr ((rs#rd1 <- (transf v1))#rd2 <- (transf v2))) m + end + end + else Stuck. + +Definition exec_store (chunk: memory_chunk) + (a: addressing) (v: val) + (rs: regset) (m: mem) := + match Mem.storev chunk m (eval_addressing a rs) v with + | None => Stuck + | Some m' => Next (nextinstr rs) m' + end. + +Definition exec_store_double (chk1 chk2: memory_chunk) + (a: addressing) (v1 v2: val) + (rs: regset) (m: mem) := + if is_pair_addressing_mode_correct a then + let addr := (eval_addressing a rs) in + let ofs := match chk1 with | Mint32 | Many32 => 4 | _ => 8 end in + let addr' := (eval_addressing (get_offset_addr a ofs) rs) in + match Mem.storev chk1 m addr v1 with + | None => Stuck + | Some m' => match Mem.storev chk2 m' addr' v2 with + | None => Stuck + | Some m'' => Next (nextinstr rs) m'' + end + end + else Stuck. + Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := match i with (** Branches *) @@ -704,13 +857,13 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pret r => Next (rs#PC <- (rs#r)) m | Pcbnz sz r lbl => - match eval_testzero sz rs#r m with + match eval_testzero sz rs#r with | Some true => Next (nextinstr rs) m | Some false => goto_label f lbl rs m | None => Stuck end | Pcbz sz r lbl => - match eval_testzero sz rs#r m with + match eval_testzero sz rs#r with | Some true => goto_label f lbl rs m | Some false => Next (nextinstr rs) m | None => Stuck @@ -778,13 +931,13 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Psubimm X rd r1 n => Next (nextinstr (rs#rd <- (Val.subl rs#r1 (Vlong (Int64.repr n))))) m | Pcmpimm W r1 n => - Next (nextinstr (compare_int rs rs#r1 (Vint (Int.repr n)) m)) m + Next (nextinstr (compare_int rs rs#r1 (Vint (Int.repr n)))) m | Pcmpimm X r1 n => - Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.repr n)) m)) m + Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.repr n)))) m | Pcmnimm W r1 n => - Next (nextinstr (compare_int rs rs#r1 (Vint (Int.neg (Int.repr n))) m)) m + Next (nextinstr (compare_int rs rs#r1 (Vint (Int.neg (Int.repr n))))) m | Pcmnimm X r1 n => - Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.neg (Int64.repr n))) m)) m + Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.neg (Int64.repr n))))) m (** Move integer register *) | Pmov rd r1 => Next (nextinstr (rs#rd <- (rs#r1))) m @@ -802,9 +955,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Porrimm X rd r1 n => Next (nextinstr (rs#rd <- (Val.orl rs###r1 (Vlong (Int64.repr n))))) m | Ptstimm W r1 n => - Next (nextinstr (compare_int rs (Val.and rs#r1 (Vint (Int.repr n))) (Vint Int.zero) m)) m + Next (nextinstr (compare_int rs (Val.and rs#r1 (Vint (Int.repr n))) (Vint Int.zero))) m | Ptstimm X r1 n => - Next (nextinstr (compare_long rs (Val.andl rs#r1 (Vlong (Int64.repr n))) (Vlong Int64.zero) m)) m + Next (nextinstr (compare_long rs (Val.andl rs#r1 (Vlong (Int64.repr n))) (Vlong Int64.zero))) m (** Move wide immediate *) | Pmovz W rd n pos => Next (nextinstr (rs#rd <- (Vint (Int.repr (Z.shiftl n pos))))) m @@ -850,22 +1003,22 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Psub X rd r1 r2 s => Next (nextinstr (rs#rd <- (Val.subl rs###r1 (eval_shift_op_long rs#r2 s)))) m | Pcmp W r1 r2 s => - Next (nextinstr (compare_int rs rs##r1 (eval_shift_op_int rs#r2 s) m)) m + Next (nextinstr (compare_int rs rs##r1 (eval_shift_op_int rs#r2 s))) m | Pcmp X r1 r2 s => - Next (nextinstr (compare_long rs rs###r1 (eval_shift_op_long rs#r2 s) m)) m + Next (nextinstr (compare_long rs rs###r1 (eval_shift_op_long rs#r2 s))) m | Pcmn W r1 r2 s => - Next (nextinstr (compare_int rs rs##r1 (Val.neg (eval_shift_op_int rs#r2 s)) m)) m + Next (nextinstr (compare_int rs rs##r1 (Val.neg (eval_shift_op_int rs#r2 s)))) m | Pcmn X r1 r2 s => - Next (nextinstr (compare_long rs rs###r1 (Val.negl (eval_shift_op_long rs#r2 s)) m)) m + Next (nextinstr (compare_long rs rs###r1 (Val.negl (eval_shift_op_long rs#r2 s)))) m (** Integer arithmetic, extending register *) | Paddext rd r1 r2 x => Next (nextinstr (rs#rd <- (Val.addl rs#r1 (eval_extend rs#r2 x)))) m | Psubext rd r1 r2 x => Next (nextinstr (rs#rd <- (Val.subl rs#r1 (eval_extend rs#r2 x)))) m | Pcmpext r1 r2 x => - Next (nextinstr (compare_long rs rs#r1 (eval_extend rs#r2 x) m)) m + Next (nextinstr (compare_long rs rs#r1 (eval_extend rs#r2 x))) m | Pcmnext r1 r2 x => - Next (nextinstr (compare_long rs rs#r1 (Val.negl (eval_extend rs#r2 x)) m)) m + Next (nextinstr (compare_long rs rs#r1 (Val.negl (eval_extend rs#r2 x)))) m (** Logical, shifted register *) | Pand W rd r1 r2 s => Next (nextinstr (rs#rd <- (Val.and rs##r1 (eval_shift_op_int rs#r2 s)))) m @@ -892,9 +1045,9 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Porn X rd r1 r2 s => Next (nextinstr (rs#rd <- (Val.orl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m | Ptst W r1 r2 s => - Next (nextinstr (compare_int rs (Val.and rs##r1 (eval_shift_op_int rs#r2 s)) (Vint Int.zero) m)) m + Next (nextinstr (compare_int rs (Val.and rs##r1 (eval_shift_op_int rs#r2 s)) (Vint Int.zero))) m | Ptst X r1 r2 s => - Next (nextinstr (compare_long rs (Val.andl rs###r1 (eval_shift_op_long rs#r2 s)) (Vlong Int64.zero) m)) m + Next (nextinstr (compare_long rs (Val.andl rs###r1 (eval_shift_op_long rs#r2 s)) (Vlong Int64.zero))) m (** Variable shifts *) | Pasrv W rd r1 r2 => Next (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2))) m @@ -966,10 +1119,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Floating-point move *) | Pfmov rd r1 => Next (nextinstr (rs#rd <- (rs#r1))) m - | Pfmovimms rd f => - Next (nextinstr (rs#rd <- (Vsingle f))) m + | Pfmovimms rd f => + if is_immediate_float32 f then + Next (nextinstr (rs#rd <- (Vsingle f))) m + else + Next (nextinstr ((rs#rd <- (Vsingle f))#X16 <- Vundef)) m | Pfmovimmd rd f => - Next (nextinstr (rs#rd <- (Vfloat f))) m + if is_immediate_float64 f then + Next (nextinstr (rs#rd <- (Vfloat f))) m + else + Next (nextinstr ((rs#rd <- (Vfloat f))#X16 <- Vundef)) m | Pfmovi S rd r1 => Next (nextinstr (rs#rd <- (float32_of_bits rs##r1))) m | Pfmovi D rd r1 => @@ -1094,104 +1253,42 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Vint n => match list_nth_z tbl (Int.unsigned n) with | None => Stuck - | Some lbl => goto_label f lbl (rs#X16 <- Vundef #X17 <- Vundef) m + | Some lbl => goto_label f lbl (rs#X16 <- Vundef) m end | _ => Stuck end | Pbuiltin ef args res => Stuck (**r treated specially below *) (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) - | Pldp _ _ _ - | Pstp _ _ _ + | Pldpw rd1 rd2 chk1 chk2 a => + exec_load_double chk1 chk2 (fun v => v) a rd1 rd2 rs m + | Pldpx rd1 rd2 chk1 chk2 a => + exec_load_double chk1 chk2 (fun v => v) a rd1 rd2 rs m + | Pnop => Next (nextinstr rs) m + | Pstpw rs1 rs2 chk1 chk2 a => + exec_store_double chk1 chk2 a rs#rs1 rs#rs2 rs m + | Pstpx rs1 rs2 chk1 chk2 a => + exec_store_double chk1 chk2 a rs#rs1 rs#rs2 rs m | Pcls _ _ _ | Pclz _ _ _ | Prev _ _ _ | Prev16 _ _ _ + | Prbit _ _ _ | Pfsqrt _ _ _ | Pfmadd _ _ _ _ _ | Pfmsub _ _ _ _ _ | Pfnmadd _ _ _ _ _ | Pfnmsub _ _ _ _ _ - | Pnop + | Pfmax _ _ _ _ + | Pfmin _ _ _ _ | Pcfi_adjust _ | Pcfi_rel_offset _ => Stuck end. -(** Translation of the LTL/Linear/Mach view of machine registers - to the AArch64 view. Note that no LTL register maps to [X16], - [X18], nor [X30]. - [X18] is reserved as the platform register and never used by the - code generated by CompCert. - [X30] is used for the return address, and can also be used as temporary. - [X16] can be used as temporary. *) - -Definition preg_of (r: mreg) : preg := - match r with - | R0 => X0 | R1 => X1 | R2 => X2 | R3 => X3 - | R4 => X4 | R5 => X5 | R6 => X6 | R7 => X7 - | R8 => X8 | R9 => X9 | R10 => X10 | R11 => X11 - | R12 => X12 | R13 => X13 | R14 => X14 | R15 => X15 - | R17 => X17 | R19 => X19 - | R20 => X20 | R21 => X21 | R22 => X22 | R23 => X23 - | R24 => X24 | R25 => X25 | R26 => X26 | R27 => X27 - | R28 => X28 | R29 => X29 - | F0 => D0 | F1 => D1 | F2 => D2 | F3 => D3 - | F4 => D4 | F5 => D5 | F6 => D6 | F7 => D7 - | F8 => D8 | F9 => D9 | F10 => D10 | F11 => D11 - | F12 => D12 | F13 => D13 | F14 => D14 | F15 => D15 - | F16 => D16 | F17 => D17 | F18 => D18 | F19 => D19 - | F20 => D20 | F21 => D21 | F22 => D22 | F23 => D23 - | F24 => D24 | F25 => D25 | F26 => D26 | F27 => D27 - | F28 => D28 | F29 => D29 | F30 => D30 | F31 => D31 - end. - -(** Undefine all registers except SP and callee-save registers *) - -Definition undef_caller_save_regs (rs: regset) : regset := - fun r => - if preg_eq r SP - || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) - then rs r - else Vundef. - -(** Extract the values of the arguments of an external call. - We exploit the calling conventions from module [Conventions], except that - we use AArch64 registers instead of locations. *) - -Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := - | extcall_arg_reg: forall r, - extcall_arg rs m (R r) (rs (preg_of r)) - | extcall_arg_stack: forall ofs ty bofs v, - bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> - Mem.loadv (chunk_of_type ty) m - (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> - extcall_arg rs m (Locations.S Outgoing ofs ty) v. - -Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := - | extcall_arg_one: forall l v, - extcall_arg rs m l v -> - extcall_arg_pair rs m (One l) v - | extcall_arg_twolong: forall hi lo vhi vlo, - extcall_arg rs m hi vhi -> - extcall_arg rs m lo vlo -> - extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. - -Definition loc_external_result (sg: signature) : rpair preg := - map_rpair preg_of (loc_result sg). - -(** Execution of the instruction at [rs#PC]. *) - -Inductive state: Type := - | State: regset -> mem -> state. - Inductive step: state -> trace -> state -> Prop := | exec_step_internal: - forall b ofs f i rs m rs' m', + forall b ofs (f:function) i rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i -> @@ -1206,7 +1303,7 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge vargs m t vres m' -> rs' = nextinstr (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + (undef_regs (DR X16 :: DR X30 :: map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', @@ -1302,11 +1399,11 @@ Qed. Definition data_preg (r: preg) : bool := match r with - | IR X16 => false - | IR X30 => false - | IR _ => true - | FR _ => true + | DR (IR X16) => false + | DR (IR X30) => false + | DR (IR _) => true + | DR (FR _) => true | CR _ => false - | SP => true + (* | SP => true; subsumed by IR (iregsp) *) | PC => false end. diff --git a/aarch64/Asmblock.v b/aarch64/Asmblock.v new file mode 100644 index 00000000..ed84b7d8 --- /dev/null +++ b/aarch64/Asmblock.v @@ -0,0 +1,1044 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Justus Fasse UGA, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + + +(* Asmblock language for aarch64 + +WORK IN PROGRESS: we want to define an Asmblock syntax, with an Asmblock semantics +(e.g. we don't need the parallel semantics of Asmvliw) + + +NOTE: this file is inspired from + - aarch64/Asm.v + - kvx/Asmvliw.v (only the Asmblock syntax) + - kvx/Asmblock.v +*) + + +(** Abstract syntax and semantics for AArch64 assembly language *) + +Require Import Coqlib Zbits Maps. +Require Import AST Integers Floats. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Locations Conventions. +Require Stacklayout. +Require Import OptionMonad Asm. +Require Export Asm. + +Local Open Scope option_monad_scope. + +Notation regset := Asm.regset. + +(** * Abstract syntax *) + +(* First task: splitting the big [instruction] type below into CFI and basic instructions. + Actually a finer splitting in order to regroup "similar" instructions could be much better for automation of the scheduler proof! + e.g. "similar" means identical "interface" w.r.t. pseudo-registers when translated to AbstractBB, + or with a "similar" semantics. + + see example of loads below. +*) + +(** Control Flow instructions + +*) +Inductive cf_instruction : Type := + | Pb (lbl: label) (**r branch *) + | Pbc (c: testcond) (lbl: label) (**r conditional branch *) + | Pbl (id: ident) (sg: signature) (**r jump to function and link *) + | Pbs (id: ident) (sg: signature) (**r jump to function *) + | Pblr (r: ireg) (sg: signature) (**r indirect jump and link *) + | Pbr (r: ireg) (sg: signature) (**r indirect jump *) + | Pret (r: ireg) (**r return *) + | Pcbnz (sz: isize) (r: ireg) (lbl: label) (**r branch if not zero *) + | Pcbz (sz: isize) (r: ireg) (lbl: label) (**r branch if zero *) + | Ptbnz (sz: isize) (r: ireg) (n: int) (lbl: label) (**r branch if bit n is not zero *) + | Ptbz (sz: isize) (r: ireg) (n: int) (lbl: label) (**r branch if bit n is zero *) + (** Pseudo-instructions *) + | Pbtbl (r1: ireg) (tbl: list label) (**r N-way branch through a jump table *) + . + +(* +A builtin is considered as a control-flow instruction, because it could emit a trace (cf. Machblock semantics). +Here, we do not need to have builtins alone in basic-blocks (on the contrary to KVX bundles). +*) + +Inductive control: Type := + | PCtlFlow (i: cf_instruction) + (** Pseudo-instructions *) + | Pbuiltin (ef: external_function) + (args: list (builtin_arg dreg)) (res: builtin_res dreg) (**r built-in function (pseudo) *) + . + +(** Basic instructions *) + +(* Loads waiting for (rd: dreg) (a: addressing) + * XXX Use dreg because exec_load is defined in terms of it, thus allowing us to + * treat integer and floating point loads the same. *) +Inductive load_rd_a: Type := + (* Integer load *) + | Pldrw (**r load int32 *) + | Pldrw_a (**r load int32 as any32 *) + | Pldrx (**r load int64 *) + | Pldrx_a (**r load int64 as any64 *) + | Pldrb (sz: isize) (**r load int8, zero-extend *) + | Pldrsb (sz: isize) (**r load int8, sign-extend *) + | Pldrh (sz: isize) (**r load int16, zero-extend *) + | Pldrsh (sz: isize) (**r load int16, sign-extend *) + | Pldrzw (**r load int32, zero-extend to int64 *) + | Pldrsw (**r load int32, sign-extend to int64 *) + (* Floating-point load *) + | Pldrs (**r load float32 (single precision) *) + | Pldrd (**r load float64 (double precision) *) + | Pldrd_a (**r load float64 as any64 *) + . + +Inductive load_rd1_rd2_a: Type := + | Pldpw + | Pldpx + . + +Inductive ld_instruction: Type := + | PLd_rd_a (ld: load_rd_a) (rd: dreg) (a: addressing) + | Pldp (ld: load_rd1_rd2_a) (rd1 rd2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r load two int64 *) + . + +Inductive store_rs_a : Type := + (* Integer store *) + | Pstrw (**r store int32 *) + | Pstrw_a (**r store int32 as any32 *) + | Pstrx (**r store int64 *) + | Pstrx_a (**r store int64 as any64 *) + | Pstrb (**r store int8 *) + | Pstrh (**r store int16 *) + (* Floating-point store *) + | Pstrs (**r store float32 *) + | Pstrd (**r store float64 *) + | Pstrd_a (**r store float64 as any64 *) + . + +Inductive store_rs1_rs2_a : Type := + | Pstpw + | Pstpx + . + +Inductive st_instruction : Type := + | PSt_rs_a (st: store_rs_a) (rs: dreg) (a: addressing) + | Pstp (st: store_rs1_rs2_a) (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) + . + +Inductive arith_p : Type := + (** PC-relative addressing *) + | Padrp (id: ident) (ofs: ptrofs) (**r set [rd] to high address of [id + ofs] *) + (** Move wide immediate *) + | Pmovz (sz: isize) (n: Z) (pos: Z) (**r move [n << pos] to [rd] *) + | Pmovn (sz: isize) (n: Z) (pos: Z) (**r move [NOT(n << pos)] to [rd] *) + (** Floating-point move *) + | Pfmovimms (f: float32) (**r load float32 constant *) + | Pfmovimmd (f: float) (**r load float64 constant *) +. + +Inductive arith_comparison_p : Type := + (** Floating-point comparison *) + | Pfcmp0 (sz: fsize) (**r compare [r1] and [+0.0] *) + (** Integer arithmetic, immediate *) + | Pcmpimm (sz: isize) (n: Z) (**r compare *) + | Pcmnimm (sz: isize) (n: Z) (**r compare negative *) + (** Logical, immediate *) + | Ptstimm (sz: isize) (n: Z) (**r and, then set flags *) +. + +Inductive arith_pp : Type := + (** Move integer register *) + | Pmov + (** Move wide immediate *) + (* XXX: has to have the same register supplied both times *) + | Pmovk (sz: isize) (n: Z) (pos: Z) (**r insert 16 bits of [n] at [pos] in rd *) + (** PC-relative addressing *) + | Paddadr (id: ident) (ofs: ptrofs) (**r add the low address of [id + ofs] *) + (** Bit-field operations *) + | Psbfiz (sz: isize) (r: int) (s: Z) (**r sign extend and shift left *) + | Psbfx (sz: isize) (r: int) (s: Z) (**r shift right and sign extend *) + | Pubfiz (sz: isize) (r: int) (s: Z) (**r zero extend and shift left *) + | Pubfx (sz: isize) (r: int) (s: Z) (**r shift right and zero extend *) +(* Bit operations are not used in the aarch64/asm semantics + (** Bit operations *) + | Pcls (sz: isize) (**r count leading sign bits *) + | Pclz (sz: isize) (**r count leading zero bits *) + | Prev (sz: isize) (**r reverse bytes *) + | Prev16 (sz: isize) (**r reverse bytes in each 16-bit word *) +*) + (** Floating-point move *) + | Pfmov + (** Floating-point conversions *) + | Pfcvtds (**r convert float32 to float64 *) + | Pfcvtsd (**r convert float64 to float32 *) + (** Floating-point arithmetic *) + | Pfabs (sz: fsize) (**r absolute value *) + | Pfneg (sz: fsize) (**r negation *) + (* Pfsqrt is not used in the semantics of aarch64/asm + | Pfsqrt (sz: fsize) (**r square root *) *) + (** Floating-point conversions *) + | Pscvtf (fsz: fsize) (isz: isize) (**r convert signed int to float *) + | Pucvtf (fsz: fsize) (isz: isize) (**r convert unsigned int to float *) + | Pfcvtzs (isz: isize) (fsz: fsize) (**r convert float to signed int *) + | Pfcvtzu (isz: isize) (fsz: fsize) (**r convert float to unsigned int *) + (** Integer arithmetic, immediate *) + | Paddimm (sz: isize) (n: Z) (**r addition *) + | Psubimm (sz: isize) (n: Z) (**r subtraction *) +. + +Inductive arith_comparison_r0r : Type := + (** Integer arithmetic, shifted register *) + | Pcmp (is:isize) (s: shift_op) (**r compare *) + | Pcmn (is:isize) (s: shift_op) (**r compare negative *) + (** Logical, shifted register *) + | Ptst (is:isize) (s: shift_op) (**r and, then set flags *) +. + +Inductive arith_comparison_pp : Type := + (** Integer arithmetic, extending register *) + | Pcmpext (x: extend_op) (**r int64-int32 cmp *) + | Pcmnext (x: extend_op) (**r int64-int32 cmn *) + (** Floating-point comparison *) + | Pfcmp (sz: fsize) (**r compare [r1] and [r2] *) +. + +Inductive arith_ppp : Type := + (** Variable shifts *) + | Pasrv (sz: isize) (**r arithmetic right shift *) + | Plslv (sz: isize) (**r left shift *) + | Plsrv (sz: isize) (**r logical right shift *) + | Prorv (sz: isize) (**r rotate right *) + (** Integer multiply/divide *) + | Psmulh (**r signed multiply high *) + | Pumulh (**r unsigned multiply high *) + | Psdiv (sz: isize) (**r signed division *) + | Pudiv (sz: isize) (**r unsigned division *) + (** Integer arithmetic, extending register *) + | Paddext (x: extend_op) (**r int64-int32 add *) + | Psubext (x: extend_op) (**r int64-int32 sub *) + (** Floating-point arithmetic *) + | Pfadd (sz: fsize) (**r addition *) + | Pfdiv (sz: fsize) (**r division *) + | Pfmul (sz: fsize) (**r multiplication *) + | Pfsub (sz: fsize) (**r subtraction *) +. + +Inductive arith_rr0r : Type := + (** Integer arithmetic, shifted register *) + | Padd (sz:isize) (s: shift_op) (**r addition *) + | Psub (sz:isize) (s: shift_op) (**r subtraction *) + (** Logical, shifted register *) + | Pand (sz:isize) (s: shift_op) (**r and *) + | Pbic (sz:isize) (s: shift_op) (**r and-not *) + | Peon (sz:isize) (s: shift_op) (**r xor-not *) + | Peor (sz:isize) (s: shift_op) (**r xor *) + | Porr (sz:isize) (s: shift_op) (**r or *) + | Porn (sz:isize) (s: shift_op) (**r or-not *) +. + + +Inductive arith_rr0 : Type := + (** Logical, immediate *) + | Pandimm (sz: isize) (n: Z) (**r and *) + | Peorimm (sz: isize) (n: Z) (**r xor *) + | Porrimm (sz: isize) (n: Z) (**r or *) +. + +Inductive arith_arrrr0 : Type := + (** Integer multiply/divide *) + | Pmadd (sz: isize) (**r multiply-add *) + | Pmsub (sz: isize) (**r multiply-sub *) +. + +(* Currently not used by the semantics of aarch64/Asm + * Inductive arith_apppp : Type := + * (** Floating-point arithmetic *) + * | Pfmadd (sz: fsize) (**r [rd = r3 + r1 * r2] *) + * | Pfmsub (sz: fsize) (**r [rd = r3 - r1 * r2] *) + * . + + * Inductive arith_aapppp : Type := + * (** Floating-point arithmetic *) + * | Pfnmadd (sz: fsize) (**r [rd = - r3 - r1 * r2] *) + * | Pfnmsub (sz: fsize) (**r [rd = - r3 + r1 * r2] *) + * . *) + +(* Notes on the naming scheme used here: + * R: ireg + * R0: ireg0 + * Rsp: iregsp + * F: freg + * W/X: Occur in conjunction with R0, says whether an ireg0 should be evaluated + * as W regsiter (32 bit) or X register (64 bit) + * S/D: Used for completeness sake. Only used for copying an integer register + * to a floating point register. Could be removed. + * A: These instructions perform an additional arithmetic operation + XXX Does this interpretation match the use in kvx/Asmvliw? + * Comparison: For these instructions the first register is not the target. + * Instead, the condition register is mutated. + *) +Inductive ar_instruction : Type := + | PArithP (i : arith_p) (rd : dreg) + | PArithPP (i : arith_pp) (rd rs : dreg) + | PArithPPP (i : arith_ppp) (rd r1 r2 : dreg) + | PArithRR0R (i : arith_rr0r) (rd : ireg) (r1 : ireg0) (r2 : ireg) + | PArithRR0 (i : arith_rr0) (rd : ireg) (r1 : ireg0) + | PArithARRRR0 (i : arith_arrrr0) (rd r1 r2 : ireg) (r3 : ireg0) + (* Pfmadd and Pfmsub are currently not used by the semantics of aarch64/Asm + | PArithAPPPP (i : arith_apppp) (rd r1 r2 r3 : preg) *) + (* Pfnmadd and Pfnmsub are currently not used by the semantics of aarch64/Asm + | PArithAAPPPP (i : arith_aapppp) (rd r1 r2 r3 : preg) *) + | PArithComparisonPP (i : arith_comparison_pp) (r1 r2 : dreg) + | PArithComparisonR0R (i : arith_comparison_r0r) (r1 : ireg0) (r2 : ireg) + | PArithComparisonP (i : arith_comparison_p) (r1 : dreg) + (* Instructions without indirection sine they would be the only ones *) + (* PArithCP: Pcsetm is commented out by aarch64/Asm, so Pcset is alone *) + | Pcset (rd : ireg) (c : testcond) (**r set to 1/0 if cond is true/false *) + (* PArithFR0 *) + | Pfmovi (fsz : fsize) (rd : freg) (r1 : ireg0) (**r copy int reg to FP reg *) + (* PArithCPPP *) + | Pcsel (rd r1 r2 : dreg) (c : testcond) (**r int/float conditional move *) + (* PArithAFFF *) + | Pfnmul (fsz : fsize) (rd r1 r2 : freg) (**r multiply-negate *) +. + +Inductive basic : Type := + | PArith (i: ar_instruction) + | PLoad (ld: ld_instruction) + | PStore (st: st_instruction) + | Pallocframe (sz: Z) (linkofs: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (linkofs: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Ploadsymbol (rd: ireg) (id: ident) (**r load the address of [id] *) + | Pcvtsw2x (rd: ireg) (r1: ireg) (**r sign-extend 32-bit int to 64-bit *) + | Pcvtuw2x (rd: ireg) (r1: ireg) (**r zero-extend 32-bit int to 64-bit *) + | Pcvtx2w (rd: ireg) (**r retype a 64-bit int as a 32-bit int *) + | Pnop (**r no operation *) +(* NOT USED IN THE SEMANTICS ! + | Pcfi_adjust (ofs: int) (**r .cfi_adjust debug directive *) + | Pcfi_rel_offset (ofs: int) (**r .cfi_rel_offset debug directive *) +*) +. + +Coercion PCtlFlow: cf_instruction >-> control. +Coercion PLoad: ld_instruction >-> basic. +Coercion PStore : st_instruction >-> basic. +Coercion PArithP: arith_p >-> Funclass. +Coercion PArithPP: arith_pp >-> Funclass. +Coercion PArithPPP: arith_ppp >-> Funclass. +Coercion PArithRR0: arith_rr0 >-> Funclass. +Coercion PArithRR0R: arith_rr0r >-> Funclass. +Coercion PArithARRRR0: arith_arrrr0 >-> Funclass. +Coercion PArithComparisonP: arith_comparison_p >-> Funclass. +Coercion PArithComparisonPP: arith_comparison_pp >-> Funclass. +Coercion PArithComparisonR0R: arith_comparison_r0r >-> Funclass. +Coercion PArith: ar_instruction >-> basic. + + +(* Not used in Coq, declared in ocaml directly in PostpassSchedulingOracle.ml +Inductive instruction : Type := + | PBasic (i: basic) + | PControl (i: control). + +Coercion PBasic: basic >-> instruction. +Coercion PControl: control >-> instruction. *) + +(** * Definition of a bblock + +A bblock must contain at least one instruction. + +This choice simplifies the definition of [find_bblock] below: +indeed, each address of a code block identifies at most one bblock. +*) + +Definition non_empty_body (body: list basic): bool := + match body with + | nil => false + | _ => true + end. + +Definition non_empty_exit (exit: option control): bool := + match exit with + | None => false + | _ => true + end. + +Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. + +(** A bblock is well-formed if he contains at least one instruction. *) + +Record bblock := mk_bblock { + header: list label; + body: list basic; + exit: option control; + correct: Is_true (non_empty_bblockb body exit) +}. + +(* FIXME? redundant with definition in Machblock *) +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; cbn. assumption. +Defined. + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; cbn. assumption. +Defined. + +(* This notion of size induces the notion of "valid" code address given by [find_bblock] + + The result is in Z to be compatible with operations on PC. +*) +Definition size (b:bblock): Z := Z.of_nat (length (header b) + length (body b) + length_opt (exit b)). + +Definition bblocks := list bblock. + +Fixpoint size_blocks (l: bblocks): Z := + match l with + | nil => 0 + | b :: l => + (size b) + (size_blocks l) + end + . + +Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. +Proof. + intros. destruct z; auto. + - contradict H. cbn. apply gt_irrefl. + - apply Zgt_pos_0. + - contradict H. cbn. apply gt_irrefl. +Qed. + +Lemma size_positive (b:bblock): size b > 0. +Proof. + unfold size. destruct b as [hd bdy ex cor]. cbn. + destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; cbn; omega); + unfold non_empty_bblockb in cor; simpl in cor. + inversion cor. +Qed. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +(** * Operational semantics *) + +(** See "Parameters" of the same names in Asm.v *) +Record aarch64_linker: Type := { + symbol_low: ident -> ptrofs -> val; + symbol_high: ident -> ptrofs -> val +}. + +Definition genv := Genv.t fundef unit. + +Section RELSEM. + +Variable lk: aarch64_linker. +Variable ge: genv. + +(** Evaluating an addressing mode *) + +Definition eval_addressing (a: addressing) (rs: regset): val := + match a with + | ADimm base n => Val.addl rs#base (Vlong n) + | ADreg base r => Val.addl rs#base rs#r + | ADlsl base r n => Val.addl rs#base (Val.shll rs#r (Vint n)) + | ADsxt base r n => Val.addl rs#base (Val.shll (Val.longofint rs#r) (Vint n)) + | ADuxt base r n => Val.addl rs#base (Val.shll (Val.longofintu rs#r) (Vint n)) + | ADadr base id ofs => Val.addl rs#base (symbol_low lk id ofs) + | ADpostincr base n => Vundef + end. + +(** Auxiliaries for memory accesses *) + +Definition exec_load_rd_a (chunk: memory_chunk) (transf: val -> val) + (a: addressing) (r: dreg) (rs: regset) (m: mem) := + SOME v <- Mem.loadv chunk m (eval_addressing a rs) IN + Next (rs#r <- (transf v)) m. + +Definition exec_load_double (chk1 chk2: memory_chunk) (transf: val -> val) + (a: addressing) (rd1 rd2: dreg) (rs: regset) (m: mem) := + if is_pair_addressing_mode_correct a then + let addr := (eval_addressing a rs) in + let ofs := match chk1 with | Mint32 | Many32 => 4 | _ => 8 end in + let addr' := (eval_addressing (get_offset_addr a ofs) rs) in + match Mem.loadv chk1 m addr with + | None => Stuck + | Some v1 => + match Mem.loadv chk2 m addr' with + | None => Stuck + | Some v2 => + Next ((rs#rd1 <- (transf v1))#rd2 <- (transf v2)) m + end + end + else Stuck. + +Definition exec_store_rs_a (chunk: memory_chunk) + (a: addressing) (v: val) + (rs: regset) (m: mem) := + SOME m' <- Mem.storev chunk m (eval_addressing a rs) v IN + Next rs m'. + +Definition exec_store_double (chk1 chk2: memory_chunk) + (a: addressing) (v1 v2: val) + (rs: regset) (m: mem) := + if is_pair_addressing_mode_correct a then + let addr := (eval_addressing a rs) in + let ofs := match chk1 with | Mint32 | Many32 => 4 | _ => 8 end in + let addr' := (eval_addressing (get_offset_addr a ofs) rs) in + match Mem.storev chk1 m addr v1 with + | None => Stuck + | Some m' => match Mem.storev chk2 m' addr' v2 with + | None => Stuck + | Some m'' => Next rs m'' + end + end + else Stuck. + +(** execution of loads +*) + +Definition chunk_load (ld: load_rd_a): memory_chunk := + match ld with + | Pldrw => Mint32 + | Pldrw_a => Many32 + | Pldrx => Mint64 + | Pldrx_a => Many64 + | Pldrb _ => Mint8unsigned + | Pldrsb _ => Mint8signed + | Pldrh _ => Mint16unsigned + | Pldrsh _ => Mint16signed + | Pldrzw => Mint32 + | Pldrsw => Mint32 + | Pldrs => Mfloat32 + | Pldrd => Mfloat64 + | Pldrd_a => Many64 + end. + +Definition chunk_store (st: store_rs_a) : memory_chunk := + match st with + | Pstrw => Mint32 + | Pstrw_a => Many32 + | Pstrx => Mint64 + | Pstrx_a => Many64 + | Pstrb => Mint8unsigned + | Pstrh => Mint16unsigned + | Pstrs => Mfloat32 + | Pstrd => Mfloat64 + | Pstrd_a => Many64 + end. + +Definition interp_load (ld: load_rd_a): val -> val := + match ld with + | Pldrb X => Val.longofintu + | Pldrsb X => Val.longofint + | Pldrh X => Val.longofintu + | Pldrsh X => Val.longofint + | Pldrzw => Val.longofintu + | Pldrsw => Val.longofint + (* Changed to exhaustive list because I tend to forgot all the places I need + * to check when changing things. *) + | Pldrb W | Pldrsb W | Pldrh W | Pldrsh W + | Pldrw | Pldrw_a | Pldrx + | Pldrx_a | Pldrs | Pldrd + | Pldrd_a => fun v => v + end. + +Definition exec_load (ldi: ld_instruction) (rs: regset) (m: mem) := + match ldi with + | PLd_rd_a ld rd a => exec_load_rd_a (chunk_load ld) (interp_load ld) a rd rs m + | Pldp ld rd1 rd2 chk1 chk2 a => exec_load_double chk1 chk2 (fun v => v) a rd1 rd2 rs m + end. + +Definition exec_store (sti: st_instruction) (rs: regset) (m: mem) := + match sti with + | PSt_rs_a st rsr a => exec_store_rs_a (chunk_store st) a rs#rsr rs m + | Pstp st rs1 rs2 chk1 chk2 a => exec_store_double chk1 chk2 a rs#rs1 rs#rs2 rs m + end. + +(** TODO: redundant w.r.t Machblock ?? *) +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + +(** Note: copy-paste from Machblock *) +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +(** convert a label into a position in the code *) +Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := + match lb with + | nil => None + | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' + end. + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := + SOME pos <- label_pos lbl 0 (fn_blocks f) IN + match rs#PC with + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m + | _ => Stuck + end. + +(** Evaluating a branch + +Warning: PC is assumed to be already pointing on the next instruction ! + +*) + +Definition eval_branch (f: function) (lbl: label) (rs: regset) (m: mem) (ores: option bool) := + SOME res <- ores IN + if res then goto_label f lbl rs m else Next rs m. + +Definition eval_neg_branch (f: function) (lbl: label) (rs: regset) (m: mem) (ores: option bool) := + SOME res <- ores IN + if res then Next rs m else goto_label f lbl rs m. + +Definition exec_cfi (f: function) (cfi: cf_instruction) (rs: regset) (m: mem) : outcome := + match cfi with + (** Branches *) + | Pb lbl => + goto_label f lbl rs m + | Pbc cond lbl => + eval_branch f lbl rs m (eval_testcond cond rs) + | Pbl id sg => + Next (rs#RA <- (rs#PC) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m + | Pbs id sg => + Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m + | Pblr r sg => + Next (rs#RA <- (rs#PC) #PC <- (rs#r)) m + | Pbr r sg => + Next (rs#PC <- (rs#r)) m + | Pret r => + Next (rs#PC <- (rs#r)) m + | Pcbnz sz r lbl => + eval_neg_branch f lbl rs m (eval_testzero sz rs#r) + | Pcbz sz r lbl => + eval_branch f lbl rs m (eval_testzero sz rs#r) + | Ptbnz sz r n lbl => + eval_branch f lbl rs m (eval_testbit sz rs#r n) + | Ptbz sz r n lbl => + eval_neg_branch f lbl rs m (eval_testbit sz rs#r n) + (** Pseudo-instructions *) + | Pbtbl r tbl => + match (rs#X16 <- Vundef)#r with + | Vint n => + SOME lbl <- list_nth_z tbl (Int.unsigned n) IN + goto_label f lbl (rs#X16 <- Vundef) m + | _ => Stuck + end + end. + +Definition arith_eval_p (i : arith_p) : val := + match i with + | Padrp id ofs => symbol_high lk id ofs + (** Move wide immediate *) + | Pmovz W n pos => Vint (Int.repr (Z.shiftl n pos)) + | Pmovz X n pos => Vlong (Int64.repr (Z.shiftl n pos)) + | Pmovn W n pos => Vint (Int.repr (Z.lnot (Z.shiftl n pos))) + | Pmovn X n pos => Vlong (Int64.repr (Z.lnot (Z.shiftl n pos))) + (** Floating-point move *) + | Pfmovimms f => Vsingle f + | Pfmovimmd f => Vfloat f + end. + +Definition destroy_X16 (i : arith_p) : bool := + match i with + | Pfmovimms d => negb (is_immediate_float32 d) + | Pfmovimmd d => negb (is_immediate_float64 d) + | _ => false + end. + +Definition if_opt_bool_val (c: option bool) v1 v2: val := + match c with + | Some true => v1 + | Some false => v2 + | None => Vundef + end. + +Definition arith_eval_pp i v := + match i with + | Pmov => v + | Pmovk W n pos => insert_in_int v n pos 16 + | Pmovk X n pos => insert_in_long v n pos 16 + | Paddadr id ofs => Val.addl v (symbol_low lk id ofs) + | Psbfiz W r s => Val.shl (Val.sign_ext s v) (Vint r) + | Psbfiz X r s => Val.shll (Val.sign_ext_l s v) (Vint r) + | Psbfx W r s => Val.sign_ext s (Val.shr v (Vint r)) + | Psbfx X r s => Val.sign_ext_l s (Val.shrl v (Vint r)) + | Pubfiz W r s => Val.shl (Val.zero_ext s v) (Vint r) + | Pubfiz X r s => Val.shll (Val.zero_ext_l s v) (Vint r) + | Pubfx W r s => Val.zero_ext s (Val.shru v (Vint r)) + | Pubfx X r s => Val.zero_ext_l s (Val.shrlu v (Vint r)) + | Pfmov => v + | Pfcvtds => Val.floatofsingle v + | Pfcvtsd => Val.singleoffloat v + | Pfabs S => Val.absfs v + | Pfabs D => Val.absf v + | Pfneg S => Val.negfs v + | Pfneg D => Val.negf v + | Pfcvtzs W S => Val.maketotal (Val.intofsingle v) + | Pfcvtzs W D => Val.maketotal (Val.intoffloat v) + | Pfcvtzs X S => Val.maketotal (Val.longofsingle v) + | Pfcvtzs X D => Val.maketotal (Val.longoffloat v) + | Pfcvtzu W S => Val.maketotal (Val.intuofsingle v) + | Pfcvtzu W D => Val.maketotal (Val.intuoffloat v) + | Pfcvtzu X S => Val.maketotal (Val.longuofsingle v) + | Pfcvtzu X D => Val.maketotal (Val.longuoffloat v) + | Paddimm W n => Val.add v (Vint (Int.repr n)) + | Paddimm X n => Val.addl v (Vlong (Int64.repr n)) + | Psubimm W n => Val.sub v (Vint (Int.repr n)) + | Psubimm X n => Val.subl v (Vlong (Int64.repr n)) + | Pscvtf S W => Val.maketotal (Val.singleofint v) + | Pscvtf D W => Val.maketotal (Val.floatofint v) + | Pscvtf S X => Val.maketotal (Val.singleoflong v) + | Pscvtf D X => Val.maketotal (Val.floatoflong v) + | Pucvtf S W => Val.maketotal (Val.singleofintu v) + | Pucvtf D W => Val.maketotal (Val.floatofintu v) + | Pucvtf S X => Val.maketotal (Val.singleoflongu v) + | Pucvtf D X => Val.maketotal (Val.floatoflongu v) + end. + +Definition arith_eval_ppp i v1 v2 := + match i with + | Pasrv W => Val.shr v1 v2 + | Pasrv X => Val.shrl v1 v2 + | Plslv W => Val.shl v1 v2 + | Plslv X => Val.shll v1 v2 + | Plsrv W => Val.shru v1 v2 + | Plsrv X => Val.shrlu v1 v2 + | Prorv W => Val.ror v1 v2 + | Prorv X => Val.rorl v1 v2 + | Psmulh => Val.mullhs v1 v2 + | Pumulh => Val.mullhu v1 v2 + | Psdiv W => Val.maketotal (Val.divs v1 v2) + | Psdiv X => Val.maketotal (Val.divls v1 v2) + | Pudiv W => Val.maketotal (Val.divu v1 v2) + | Pudiv X => Val.maketotal (Val.divlu v1 v2) + | Paddext x => Val.addl v1 (eval_extend v2 x) + | Psubext x => Val.subl v1 (eval_extend v2 x) + | Pfadd S => Val.addfs v1 v2 + | Pfadd D => Val.addf v1 v2 + | Pfdiv S => Val.divfs v1 v2 + | Pfdiv D => Val.divf v1 v2 + | Pfmul S => Val.mulfs v1 v2 + | Pfmul D => Val.mulf v1 v2 + | Pfsub S => Val.subfs v1 v2 + | Pfsub D => Val.subf v1 v2 + end. + +Definition arith_rr0r_isize (i: arith_rr0r) := + match i with + | Padd is _ => is + | Psub is _ => is + | Pand is _ => is + | Pbic is _ => is + | Peon is _ => is + | Peor is _ => is + | Porr is _ => is + | Porn is _ => is + end. + +(* obtain v1 by [ir0 (arith_rr0r_isize i) rs s1] *) +Definition arith_eval_rr0r i v1 v2 := + match i with + | Padd W s => Val.add v1 (eval_shift_op_int v2 s) + | Padd X s => Val.addl v1 (eval_shift_op_long v2 s) + | Psub W s => Val.sub v1 (eval_shift_op_int v2 s) + | Psub X s => Val.subl v1 (eval_shift_op_long v2 s) + | Pand W s => Val.and v1 (eval_shift_op_int v2 s) + | Pand X s => Val.andl v1 (eval_shift_op_long v2 s) + | Pbic W s => Val.and v1 (Val.notint (eval_shift_op_int v2 s)) + | Pbic X s => Val.andl v1 (Val.notl (eval_shift_op_long v2 s)) + | Peon W s => Val.xor v1 (Val.notint (eval_shift_op_int v2 s)) + | Peon X s => Val.xorl v1 (Val.notl (eval_shift_op_long v2 s)) + | Peor W s => Val.xor v1 (eval_shift_op_int v2 s) + | Peor X s => Val.xorl v1 (eval_shift_op_long v2 s) + | Porr W s => Val.or v1 (eval_shift_op_int v2 s) + | Porr X s => Val.orl v1 (eval_shift_op_long v2 s) + | Porn W s => Val.or v1 (Val.notint (eval_shift_op_int v2 s)) + | Porn X s => Val.orl v1 (Val.notl (eval_shift_op_long v2 s)) + end. + +Definition arith_rr0_isize (i : arith_rr0) := + match i with + | Pandimm is _ | Peorimm is _ | Porrimm is _ => is + end. + +(* obtain v by [ir0 (arith_rr0_isize i) rs s] *) +Definition arith_eval_rr0 i v := + match i with + | Pandimm W n => Val.and v (Vint (Int.repr n)) + | Pandimm X n => Val.andl v (Vlong (Int64.repr n)) + | Peorimm W n => Val.xor v (Vint (Int.repr n)) + | Peorimm X n => Val.xorl v (Vlong (Int64.repr n)) + | Porrimm W n => Val.or v (Vint (Int.repr n)) + | Porrimm X n => Val.orl v (Vlong (Int64.repr n)) + end. + +Definition arith_arrrr0_isize (i : arith_arrrr0) := + match i with + | Pmadd is | Pmsub is => is + end. + +(* obtain v3 by [ir0 (arith_arrrr0_isize i) rs s3] *) +Definition arith_eval_arrrr0 i v1 v2 v3 := + match i with + | Pmadd W => Val.add v3 (Val.mul v1 v2) + | Pmadd X => Val.addl v3 (Val.mull v1 v2) + | Pmsub W => Val.sub v3 (Val.mul v1 v2) + | Pmsub X => Val.subl v3 (Val.mull v1 v2) + end. + +Definition arith_prepare_comparison_pp i (v1 v2 : val) := + match i with + | Pcmpext x => (v1, (eval_extend v2 x)) + | Pcmnext x => (v1, (Val.negl (eval_extend v2 x))) + | Pfcmp _ => (v1, v2) + end. + +Definition arith_comparison_r0r_isize i := + match i with + | Pcmp is _ => is + | Pcmn is _ => is + | Ptst is _ => is + end. + +Definition arith_prepare_comparison_r0r i v1 v2 := + match i with + | Pcmp W s => (v1, (eval_shift_op_int v2 s)) + | Pcmp X s => (v1, (eval_shift_op_long v2 s)) + | Pcmn W s => (v1, (Val.neg (eval_shift_op_int v2 s))) + | Pcmn X s => (v1, (Val.negl (eval_shift_op_long v2 s))) + | Ptst W s => ((Val.and v1 (eval_shift_op_int v2 s)), (Vint Int.zero)) + | Ptst X s => ((Val.andl v1 (eval_shift_op_long v2 s)), (Vlong Int64.zero)) + end. + +Definition arith_prepare_comparison_p i v := + match i with + | Pcmpimm W n => (v, (Vint (Int.repr n))) + | Pcmpimm X n => (v, (Vlong (Int64.repr n))) + | Pcmnimm W n => (v, (Vint (Int.neg (Int.repr n)))) + | Pcmnimm X n => (v, (Vlong (Int64.neg (Int64.repr n)))) + | Ptstimm W n => ((Val.and v (Vint (Int.repr n))), (Vint Int.zero)) + | Ptstimm X n => ((Val.andl v (Vlong (Int64.repr n))), (Vlong Int64.zero)) + | Pfcmp0 S => (v, (Vsingle Float32.zero)) + | Pfcmp0 D => (v, (Vfloat Float.zero)) + end. + +Definition arith_comparison_pp_compare i := + match i with + | Pcmpext _ | Pcmnext _ => compare_long + | Pfcmp S => compare_single + | Pfcmp D => compare_float + end. + +Definition arith_comparison_p_compare i := + match i with + | Pcmpimm W _ | Pcmnimm W _ | Ptstimm W _ => compare_int + | Pcmpimm X _ | Pcmnimm X _ | Ptstimm X _ => compare_long + | Pfcmp0 S => compare_single + | Pfcmp0 D => compare_float + end. + +Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := + match ai with + | PArithP i d => + let rs' := rs#d <- (arith_eval_p i) in + if destroy_X16 i then rs'#X16 <- Vundef else rs' + | PArithPP i d s => rs#d <- (arith_eval_pp i rs#s) + | PArithPPP i d s1 s2 => rs#d <- (arith_eval_ppp i rs#s1 rs#s2) + + | PArithRR0R i d s1 s2 => rs#d <- (arith_eval_rr0r i (ir0 (arith_rr0r_isize i) rs s1) rs#s2) + + | PArithRR0 i d s => rs#d <- (arith_eval_rr0 i (ir0 (arith_rr0_isize i) rs s)) + + | PArithARRRR0 i d s1 s2 s3 => + rs#d <- (arith_eval_arrrr0 i rs#s1 rs#s2 (ir0 (arith_arrrr0_isize i) rs s3)) + + | PArithComparisonPP i s1 s2 => + let (v1, v2) := arith_prepare_comparison_pp i rs#s1 rs#s2 in + arith_comparison_pp_compare i rs v1 v2 + | PArithComparisonR0R i s1 s2 => + let is := arith_comparison_r0r_isize i in + let (v1, v2) := arith_prepare_comparison_r0r i (ir0 is rs s1) rs#s2 in + (if is (* is W *) then compare_int else compare_long) rs v1 v2 + | PArithComparisonP i s => + let (v1, v2) := arith_prepare_comparison_p i rs#s in + arith_comparison_p_compare i rs v1 v2 + | Pcset d c => rs#d <- (if_opt_bool_val (eval_testcond c rs) (Vint Int.one) (Vint Int.zero)) + | Pfmovi S d s => rs#d <- (float32_of_bits rs##s) + | Pfmovi D d s => rs#d <- (float64_of_bits rs###s) + | Pcsel d s1 s2 c => rs#d <- (if_opt_bool_val (eval_testcond c rs) (rs#s1) (rs#s2)) + | Pfnmul S d s1 s2 => rs#d <- (Val.negfs (Val.mulfs rs#s1 rs#s2)) + | Pfnmul D d s1 s2 => rs#d <- (Val.negf (Val.mulf rs#s1 rs#s2)) + end. + +(* basic exec *) +Definition exec_basic (b: basic) (rs: regset) (m: mem): outcome := + match b with + | PArith ai => Next (exec_arith_instr ai rs) m + | PLoad ldi => exec_load ldi rs m + | PStore sti => exec_store sti rs m + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + SOME m2 <- Mem.storev Mint64 m1 (Val.offset_ptr sp pos) rs#SP IN + Next (rs #X29 <- (rs#SP) #SP <- sp #X16 <- Vundef) m2 + | Pfreeframe sz pos => + SOME v <- Mem.loadv Mint64 m (Val.offset_ptr rs#SP pos) IN + match rs#SP with + | Vptr stk ofs => + SOME m' <- Mem.free m stk 0 sz IN + Next (rs#SP <- v #X16 <- Vundef) m' + | _ => Stuck + end + | Ploadsymbol rd id => + Next (rs#rd <- (Genv.symbol_address ge id Ptrofs.zero)) m + | Pcvtsw2x rd r1 => + Next (rs#rd <- (Val.longofint rs#r1)) m + | Pcvtuw2x rd r1 => + Next (rs#rd <- (Val.longofintu rs#r1)) m + | Pcvtx2w rd => + Next (rs#rd <- (Val.loword rs#rd)) m + | Pnop => Next rs m + end. + +(** execution of the body of a bblock *) +Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := + match body with + | nil => Next rs m + | bi::body' => + SOME o <- exec_basic bi rs m IN + exec_body body' (_rs o) (_m o) + end. + +Definition incrPC size_b (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC size_b). + +Definition estep (f: function) oc size_b (rs: regset) (m: mem) := + match oc with + | Some (PCtlFlow cfi) => exec_cfi f cfi (incrPC size_b rs) m + | Some (Pbuiltin ef args res) => Next (incrPC size_b rs) m + | None => Next (incrPC size_b rs) m + end. + +(** execution of the exit instruction of a bblock *) +Inductive exec_exit (f: function) size_b (rs: regset) (m: mem): (option control) -> trace -> regset -> mem -> Prop := + | none_step: + exec_exit f size_b rs m None E0 (incrPC size_b rs) m + | cfi_step (cfi: cf_instruction) rs' m': + exec_cfi f cfi (incrPC size_b rs) m = Next rs' m' -> + exec_exit f size_b rs m (Some (PCtlFlow cfi)) E0 rs' m' + | builtin_step ef args res vargs t vres rs' m': + eval_builtin_args ge (fun (r: dreg) => rs r) rs#SP m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = incrPC size_b + (set_res (map_builtin_res DR res) vres + (undef_regs (DR (IR X16) :: DR (IR X30) :: map preg_of (destroyed_by_builtin ef)) rs)) -> + exec_exit f size_b rs m (Some (Pbuiltin ef args res)) t rs' m' + . + +(*Definition bbstep f cfi size_b bdy rs m :=*) + (*match exec_body bdy rs m with*) + (*| Some (State rs' m') => estep f cfi size_b rs' m'*) + (*| Stuck => Stuck*) + (*end.*) + +Definition bbstep f bb rs m := + match exec_body (body bb) rs m with + | Some (State rs' m') => estep f (exit bb) (Ptrofs.repr (size bb)) rs' m' + | Stuck => Stuck + end. + +Definition exec_bblock (f: function) (b: bblock) (rs: regset) (m: mem) (t:trace) (rs':regset) (m':mem): Prop + := exists rs1 m1, exec_body (body b) rs m = Next rs1 m1 /\ exec_exit f (Ptrofs.repr (size b)) rs1 m1 (exit b) t rs' m'. + +Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := + match lb with + | nil => None + | b :: il => + if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) + else if zeq pos 0 then Some b + else find_bblock (pos - (size b)) il + end. + +(** Execution of the instruction at [rs PC]. *) + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f bi rs m t rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> + exec_bblock f bi rs m t rs' m' -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> + step (State rs m) t (State rs' m') + . + + +End RELSEM. + + +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + Genv.init_mem p = Some m0 -> + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # RA <- Vnullptr + # SP <- Vnullptr in + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs#PC = Vnullptr -> + rs#X0 = Vint r -> + final_state (State rs m) r. + +Definition semantics (lk: aarch64_linker) (p: program) := + Semantics (step lk) (initial_state p) final_state (Genv.globalenv p). diff --git a/aarch64/Asmblockdeps.v b/aarch64/Asmblockdeps.v new file mode 100644 index 00000000..e1d591df --- /dev/null +++ b/aarch64/Asmblockdeps.v @@ -0,0 +1,2665 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Translation from [Asmblock] to [AbstractBB] *) + +(** We define a specific instance [L] of [AbstractBB] and translate [bblocks] from [Asmblock] into [L]. + [AbstractBB] will then define a sequential semantics for [L]. + We prove a bisimulation between the sequential semantics of [L] and [Asmblock]. + Then, the checker on [Asmblock] is deduced from those of [L]. + *) + +Require Import AST. +Require Import Asm Asmblock. +Require Import Asmblockprops. +Require Import Values. +Require Import Globalenvs. +Require Import Memory. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import ZArith. +Require Import Coqlib. +Require Import ImpSimuTest. +Require Import Axioms. +Require Import Permutation. +Require Import Events. + +Require Import Lia. + +Import ListNotations. +Local Open Scope list_scope. + +Open Scope impure. +(** auxiliary treatments of builtins *) + +Definition is_builtin(ex: option control): bool := + match ex with + | Some (Pbuiltin _ _ _) => true + | _ => false + end. + +Definition has_builtin(bb: bblock): bool := + is_builtin (exit bb). + +Remark builtin_arg_eq_dreg: forall (a b: builtin_arg dreg), {a=b} + {a<>b}. +Proof. + intros. + apply (builtin_arg_eq dreg_eq). +Qed. + +Remark builtin_res_eq_dreg: forall (a b: builtin_res dreg), {a=b} + {a<>b}. +Proof. + intros. + apply (builtin_res_eq dreg_eq). +Qed. + +Definition assert_same_builtin (bb1 bb2: bblock): ?? unit := + match exit bb1 with + | Some (Pbuiltin ef1 lbar1 brr1) => + match exit bb2 with + | Some (Pbuiltin ef2 lbar2 brr2) => + if (external_function_eq ef1 ef2) then + if (list_eq_dec builtin_arg_eq_dreg lbar1 lbar2) then + if (builtin_res_eq_dreg brr1 brr2) then RET tt + else FAILWITH "Different brr in Pbuiltin" + else FAILWITH "Different lbar in Pbuiltin" + else FAILWITH "Different ef in Pbuiltin" + | _ => FAILWITH "Expected a builtin: found something else" (* XXX: on peut raffiner le message d'erreur si nécessaire *) + end + | _ => match exit bb2 with + | Some (Pbuiltin ef2 lbar2 brr2) => FAILWITH "Expected a something else: found a builtin" + | _ => RET tt (* ok *) + end + end. + +Lemma assert_same_builtin_correct (bb1 bb2: bblock): + WHEN assert_same_builtin bb1 bb2 ~> _ THEN + has_builtin bb1 = true \/ has_builtin bb2 = true -> exit bb1 = exit bb2. +Proof. + unfold assert_same_builtin, has_builtin. + destruct (exit bb1) as [[]|]; simpl; + destruct (exit bb2) as [[]|]; wlp_simplify; try congruence. +Qed. +Global Opaque assert_same_builtin. +Local Hint Resolve assert_same_builtin_correct: wlp. + +(** Definition of [L] *) + +Module P<: ImpParam. +Module R := Pos. + +Section IMPPARAM. + +Definition env := Genv.t fundef unit. + +Record genv_wrap := { _genv: env; _fn: function; _lk: aarch64_linker }. +Definition genv := genv_wrap. + +Variable Ge: genv. + +Inductive value_wrap := + | Val (v: val) + | Memstate (m: mem) + | Bool (b: bool) +. + +Definition value := value_wrap. + +Record CRflags := { _CN: val; _CZ:val; _CC: val; _CV: val }. + +Inductive control_op := + | Ob (l: label) + | Obc (c: testcond) (l: label) + | Obl (id: ident) + | Obs (id: ident) + | Ocbnz (sz: isize) (l: label) + | Ocbz (sz: isize) (l: label) + | Otbnz (sz: isize) (n: int) (l: label) + | Otbz (sz: isize) (n: int) (l: label) + | Obtbl (l: list label) + | OError + | OIncremPC (sz: Z) +. + +Inductive arith_op := + | OArithP (n: arith_p) + | OArithPP (n: arith_pp) + | OArithPPP (n: arith_ppp) + | OArithRR0R (n: arith_rr0r) + | OArithRR0R_XZR (n: arith_rr0r) (vz: val) + | OArithRR0 (n: arith_rr0) + | OArithRR0_XZR (n: arith_rr0) (vz: val) + | OArithARRRR0 (n: arith_arrrr0) + | OArithARRRR0_XZR (n: arith_arrrr0) (vz: val) + | OArithComparisonPP_CN (n: arith_comparison_pp) + | OArithComparisonPP_CZ (n: arith_comparison_pp) + | OArithComparisonPP_CC (n: arith_comparison_pp) + | OArithComparisonPP_CV (n: arith_comparison_pp) + | OArithComparisonR0R_CN (n: arith_comparison_r0r) (is: isize) + | OArithComparisonR0R_CZ (n: arith_comparison_r0r) (is: isize) + | OArithComparisonR0R_CC (n: arith_comparison_r0r) (is: isize) + | OArithComparisonR0R_CV (n: arith_comparison_r0r) (is: isize) + | OArithComparisonR0R_CN_XZR (n: arith_comparison_r0r) (is: isize) (vz: val) + | OArithComparisonR0R_CZ_XZR (n: arith_comparison_r0r) (is: isize) (vz: val) + | OArithComparisonR0R_CC_XZR (n: arith_comparison_r0r) (is: isize) (vz: val) + | OArithComparisonR0R_CV_XZR (n: arith_comparison_r0r) (is: isize) (vz: val) + | OArithComparisonP_CN (n: arith_comparison_p) + | OArithComparisonP_CZ (n: arith_comparison_p) + | OArithComparisonP_CC (n: arith_comparison_p) + | OArithComparisonP_CV (n: arith_comparison_p) + | Ocset (c: testcond) + | Ofmovi (fsz: fsize) + | Ofmovi_XZR (fsz: fsize) + | Ocsel (c: testcond) + | Ofnmul (fsz: fsize) +. + +Inductive store_op := + | Ostore1 (st: store_rs_a) (chunk: memory_chunk) (a: addressing) + | Ostore2 (st: store_rs_a) (chunk: memory_chunk) (a: addressing) + | OstoreU (st: store_rs_a) (chunk: memory_chunk) (a: addressing) +. + +Inductive load_op := + | Oload1 (ld: load_rd_a) (chunk: memory_chunk) (a: addressing) + | Oload2 (ld: load_rd_a) (chunk: memory_chunk) (a: addressing) + | OloadU (ld: load_rd_a) (chunk: memory_chunk) (a: addressing) +. + +Inductive allocf_op := + | OAllocf_SP (sz: Z) (linkofs: ptrofs) + | OAllocf_Mem (sz: Z) (linkofs: ptrofs) +. + +Inductive freef_op := + | OFreef_SP (sz: Z) (linkofs: ptrofs) + | OFreef_Mem (sz: Z) (linkofs: ptrofs) +. + +Inductive op_wrap := + (* arithmetic operation *) + | Arith (op: arith_op) + | Load (ld: load_op) + | Store (st: store_op) + | Allocframe (al: allocf_op) + | Freeframe (fr: freef_op) + | Loadsymbol (id: ident) + | Cvtsw2x + | Cvtuw2x + | Cvtx2w + | Control (co: control_op) + | Constant (v: val) +. + +Definition op:=op_wrap. + +Coercion Arith: arith_op >-> op_wrap. +Coercion Control: control_op >-> op_wrap. + +Definition v_compare_int (v1 v2: val) : CRflags := + {| _CN := (Val.negative (Val.sub v1 v2)); + _CZ := (Val.mxcmpu Ceq v1 v2); + _CC := (Val.mxcmpu Cge v1 v2); + _CV := (Val.sub_overflow v1 v2) |}. + +Definition v_compare_long (v1 v2: val) : CRflags := + {| _CN := (Val.negativel (Val.subl v1 v2)); + _CZ := (Val.mxcmplu Ceq v1 v2); + _CC := (Val.mxcmplu Cge v1 v2); + _CV := (Val.subl_overflow v1 v2) |}. + +Definition v_compare_float (v1 v2: val) : CRflags := + match v1, v2 with + | Vfloat f1, Vfloat f2 => + {| _CN := (Val.of_bool (Float.cmp Clt f1 f2)); + _CZ := (Val.of_bool (Float.cmp Ceq f1 f2)); + _CC := (Val.of_bool (negb (Float.cmp Clt f1 f2))); + _CV := (Val.of_bool (negb (Float.ordered f1 f2))) |} + | _, _ => + {| _CN := Vundef; + _CZ := Vundef; + _CC := Vundef; + _CV := Vundef |} + end. + +Definition v_compare_single (v1 v2: val) : CRflags := + match v1, v2 with + | Vsingle f1, Vsingle f2 => + {| _CN := (Val.of_bool (Float32.cmp Clt f1 f2)); + _CZ := (Val.of_bool (Float32.cmp Ceq f1 f2)); + _CC := (Val.of_bool (negb (Float32.cmp Clt f1 f2))); + _CV := (Val.of_bool (negb (Float32.ordered f1 f2))) |} + | _, _ => + {| _CN := Vundef; + _CZ := Vundef; + _CC := Vundef; + _CV := Vundef |} + end. + +Definition arith_eval_comparison_pp (n: arith_comparison_pp) (v1 v2: val) := + let (v1',v2') := arith_prepare_comparison_pp n v1 v2 in + match n with + | Pcmpext _ | Pcmnext _ => v_compare_long v1' v2' + | Pfcmp S => v_compare_single v1' v2' + | Pfcmp D => v_compare_float v1' v2' + end. + +Definition arith_eval_comparison_p (n: arith_comparison_p) (v: val) := + let (v1',v2') := arith_prepare_comparison_p n v in + match n with + | Pcmpimm W _ | Pcmnimm W _ | Ptstimm W _ => v_compare_int v1' v2' + | Pcmpimm X _ | Pcmnimm X _ | Ptstimm X _ => v_compare_long v1' v2' + | Pfcmp0 S => v_compare_single v1' v2' + | Pfcmp0 D => v_compare_float v1' v2' + end. + +Definition arith_eval_comparison_r0r (n: arith_comparison_r0r) (v1 v2: val) (is: isize) := + let (v1',v2') := arith_prepare_comparison_r0r n v1 v2 in + if is then v_compare_int v1' v2' else v_compare_long v1' v2'. + +Definition flags_testcond_value (c: testcond) (vCN vCZ vCC vCV: val) := + match c with + | TCeq => (**r equal *) + match vCZ with + | Vint n => Some (Int.eq n Int.one) + | _ => None + end + | TCne => (**r not equal *) + match vCZ with + | Vint n => Some (Int.eq n Int.zero) + | _ => None + end + | TClo => (**r unsigned less than *) + match vCC with + | Vint n => Some (Int.eq n Int.zero) + | _ => None + end + | TCls => (**r unsigned less or equal *) + match vCC, vCZ with + | Vint c, Vint z => Some (Int.eq c Int.zero || Int.eq z Int.one) + | _, _ => None + end + | TChs => (**r unsigned greater or equal *) + match vCC with + | Vint n => Some (Int.eq n Int.one) + | _ => None + end + | TChi => (**r unsigned greater *) + match vCC, vCZ with + | Vint c, Vint z => Some (Int.eq c Int.one && Int.eq z Int.zero) + | _, _ => None + end + | TClt => (**r signed less than *) + match vCV, vCN with + | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.one) + | _, _ => None + end + | TCle => (**r signed less or equal *) + match vCV, vCN, vCZ with + | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.one || Int.eq z Int.one) + | _, _, _ => None + end + | TCge => (**r signed greater or equal *) + match vCV, vCN with + | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.zero) + | _, _ => None + end + | TCgt => (**r signed greater *) + match vCV, vCN, vCZ with + | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.zero && Int.eq z Int.zero) + | _, _, _ => None + end + | TCpl => (**r positive *) + match vCN with + | Vint n => Some (Int.eq n Int.zero) + | _ => None + end + | TCmi => (**r negative *) + match vCN with + | Vint n => Some (Int.eq n Int.one) + | _ => None + end + end. + +(* The is argument is used to identify the source inst and avoid rewriting some code + 0 -> Ocset + 1 -> Ocsel + 2 -> Obc *) +Definition cond_eval_is (c: testcond) (v1 v2 vCN vCZ vCC vCV: val) (is: Z) := + let res := flags_testcond_value c vCN vCZ vCC vCV in + match is, res with + | 0, res => Some (Val (if_opt_bool_val res (Vint Int.one) (Vint Int.zero))) + | 1, res => Some (Val (if_opt_bool_val res v1 v2)) + | 2, Some b => Some (Bool (b)) + | _, _ => None + end. + +Definition fmovi_eval (fsz: fsize) (v: val) := + match fsz with + | S => float32_of_bits v + | D => float64_of_bits v + end. + +Definition fmovi_eval_xzr (fsz: fsize) := + match fsz with + | S => float32_of_bits (Vint Int.zero) + | D => float64_of_bits (Vlong Int64.zero) + end. + +Definition fnmul_eval (fsz: fsize) (v1 v2: val) := + match fsz with + | S => Val.negfs (Val.mulfs v1 v2) + | D => Val.negf (Val.mulf v1 v2) + end. + +Definition cflags_eval (c: testcond) (l: list value) (v1 v2: val) (is: Z) := + match c, l with + | TCeq, [Val vCZ] => cond_eval_is TCeq v1 v2 Vundef vCZ Vundef Vundef is + | TCne, [Val vCZ] => cond_eval_is TCne v1 v2 Vundef vCZ Vundef Vundef is + | TChs, [Val vCC] => cond_eval_is TChs v1 v2 Vundef Vundef vCC Vundef is + | TClo, [Val vCC] => cond_eval_is TClo v1 v2 Vundef Vundef vCC Vundef is + | TCmi, [Val vCN] => cond_eval_is TCmi v1 v2 vCN Vundef Vundef Vundef is + | TCpl, [Val vCN] => cond_eval_is TCpl v1 v2 vCN Vundef Vundef Vundef is + | TChi, [Val vCZ; Val vCC] => cond_eval_is TChi v1 v2 Vundef vCZ vCC Vundef is + | TCls, [Val vCZ; Val vCC] => cond_eval_is TCls v1 v2 Vundef vCZ vCC Vundef is + | TCge, [Val vCN; Val vCV] => cond_eval_is TCge v1 v2 vCN Vundef Vundef vCV is + | TClt, [Val vCN; Val vCV] => cond_eval_is TClt v1 v2 vCN Vundef Vundef vCV is + | TCgt, [Val vCN; Val vCZ; Val vCV] => cond_eval_is TCgt v1 v2 vCN vCZ Vundef vCV is + | TCle, [Val vCN; Val vCZ; Val vCV] => cond_eval_is TCle v1 v2 vCN vCZ Vundef vCV is + | _, _ => None + end. + +Definition arith_op_eval (op: arith_op) (l: list value) := + match op, l with + | OArithP n, [] => Some (Val (arith_eval_p Ge.(_lk) n)) + | OArithPP n, [Val v] => Some (Val (arith_eval_pp Ge.(_lk) n v)) + | OArithPPP n, [Val v1; Val v2] => Some (Val (arith_eval_ppp n v1 v2)) + | OArithRR0R n, [Val v1; Val v2] => Some (Val (arith_eval_rr0r n v1 v2)) + | OArithRR0R_XZR n vz, [Val v] => Some (Val (arith_eval_rr0r n vz v)) + | OArithRR0 n, [Val v] => Some (Val (arith_eval_rr0 n v)) + | OArithRR0_XZR n vz, [] => Some (Val (arith_eval_rr0 n vz)) + | OArithARRRR0 n, [Val v1; Val v2; Val v3] => Some (Val (arith_eval_arrrr0 n v1 v2 v3)) + | OArithARRRR0_XZR n vz, [Val v1; Val v2] => Some (Val (arith_eval_arrrr0 n v1 v2 vz)) + | OArithComparisonPP_CN n, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_pp n v1 v2).(_CN))) + | OArithComparisonPP_CZ n, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_pp n v1 v2).(_CZ))) + | OArithComparisonPP_CC n, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_pp n v1 v2).(_CC))) + | OArithComparisonPP_CV n, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_pp n v1 v2).(_CV))) + | OArithComparisonR0R_CN n is, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_r0r n v1 v2 is).(_CN))) + | OArithComparisonR0R_CZ n is, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_r0r n v1 v2 is).(_CZ))) + | OArithComparisonR0R_CC n is, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_r0r n v1 v2 is).(_CC))) + | OArithComparisonR0R_CV n is, [Val v1; Val v2] => Some (Val ((arith_eval_comparison_r0r n v1 v2 is).(_CV))) + | OArithComparisonR0R_CN_XZR n is vz, [Val v2] => Some (Val ((arith_eval_comparison_r0r n vz v2 is).(_CN))) + | OArithComparisonR0R_CZ_XZR n is vz, [Val v2] => Some (Val ((arith_eval_comparison_r0r n vz v2 is).(_CZ))) + | OArithComparisonR0R_CC_XZR n is vz, [Val v2] => Some (Val ((arith_eval_comparison_r0r n vz v2 is).(_CC))) + | OArithComparisonR0R_CV_XZR n is vz, [Val v2] => Some (Val ((arith_eval_comparison_r0r n vz v2 is).(_CV))) + | OArithComparisonP_CN n, [Val v] => Some (Val ((arith_eval_comparison_p n v).(_CN))) + | OArithComparisonP_CZ n, [Val v] => Some (Val ((arith_eval_comparison_p n v).(_CZ))) + | OArithComparisonP_CC n, [Val v] => Some (Val ((arith_eval_comparison_p n v).(_CC))) + | OArithComparisonP_CV n, [Val v] => Some (Val ((arith_eval_comparison_p n v).(_CV))) + | Ocset c, l => cflags_eval c l Vundef Vundef 0 + | Ofmovi fsz, [Val v] => Some (Val (fmovi_eval fsz v)) + | Ofmovi_XZR fsz, [] => Some (Val (fmovi_eval_xzr fsz)) + | Ocsel c, Val v1 :: Val v2 :: l' => cflags_eval c l' v1 v2 1 + | Ofnmul fsz, [Val v1; Val v2] => Some (Val (fnmul_eval fsz v1 v2)) + | _, _ => None + end. + +Definition call_ll_storev (c: memory_chunk) (m: mem) (v: option val) (vs: val) := + match v with + | Some va => match Mem.storev c m va vs with + | Some m' => Some (Memstate m') + | None => None + end + | None => None (* should never occurs *) + end. + +Definition exec_store1 (n: store_rs_a) (m: mem) (chunk: memory_chunk) (a: addressing) (vr vs: val) := + let v := + match a with + | ADimm _ n => Some (Val.addl vs (Vlong n)) + | ADadr _ id ofs => Some (Val.addl vs (symbol_low Ge.(_lk) id ofs)) + | _ => None + end in + call_ll_storev chunk m v vr. + +Definition exec_store2 (n: store_rs_a) (m: mem) (chunk: memory_chunk) (a: addressing) (vr vs1 vs2: val) := + let v := + match a with + | ADreg _ _ => Some (Val.addl vs1 vs2) + | ADlsl _ _ n => Some (Val.addl vs1 (Val.shll vs2 (Vint n))) + | ADsxt _ _ n => Some (Val.addl vs1 (Val.shll (Val.longofint vs2) (Vint n))) + | ADuxt _ _ n => Some (Val.addl vs1 (Val.shll (Val.longofintu vs2) (Vint n))) + | _ => None + end in + call_ll_storev chunk m v vr. + +Definition exec_storeU (n: store_rs_a) (m: mem) (chunk: memory_chunk) (a: addressing) (vr: val) := + call_ll_storev chunk m None vr. + +Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := + match label_pos lbl 0 (fn_blocks f) with + | None => None + | Some pos => + match vpc with + | Vptr b ofs => Some (Val (Vptr b (Ptrofs.repr pos))) + | _ => None + end + end. + +Definition control_eval (o: control_op) (l: list value) := + let (ge, fn, lk) := Ge in + match o, l with + | Ob lbl, [Val vpc] => goto_label_deps fn lbl vpc + | Obc c lbl, Val vpc :: l' => match cflags_eval c l' Vundef Vundef 2 with + | Some (Bool true) => goto_label_deps fn lbl vpc + | Some (Bool false) => Some (Val vpc) + | _ => None + end + | Obl id, [] => Some (Val (Genv.symbol_address Ge.(_genv) id Ptrofs.zero)) + | Obs id, [] => Some (Val (Genv.symbol_address Ge.(_genv) id Ptrofs.zero)) + | Ocbnz sz lbl, [Val v; Val vpc] => match eval_testzero sz v with + | Some (true) => Some (Val vpc) + | Some (false) => goto_label_deps fn lbl vpc + | None => None + end + | Ocbz sz lbl, [Val v; Val vpc] => match eval_testzero sz v with + | Some (true) => goto_label_deps fn lbl vpc + | Some (false) => Some (Val vpc) + | None => None + end + | Otbnz sz n lbl, [Val v; Val vpc] => match eval_testbit sz v n with + | Some (true) => goto_label_deps fn lbl vpc + | Some (false) => Some (Val vpc) + | None => None + end + | Otbz sz n lbl, [Val v; Val vpc] => match eval_testbit sz v n with + | Some (true) => Some (Val vpc) + | Some (false) => goto_label_deps fn lbl vpc + | None => None + end + | Obtbl tbl, [Val index; Val vpc] => match index with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => None + | Some lbl => goto_label_deps fn lbl vpc + end + | _ => None + end + | OIncremPC sz, [Val vpc] => Some (Val (Val.offset_ptr vpc (Ptrofs.repr sz))) + | OError, _ => None + | _, _ => None + end. + +Definition store_eval (o: store_op) (l: list value) := + match o, l with + | Ostore1 st chunk a, [Val vr; Val vs; Memstate m] => exec_store1 st m chunk a vr vs + | Ostore2 st chunk a, [Val vr; Val vs1; Val vs2; Memstate m] => exec_store2 st m chunk a vr vs1 vs2 + | OstoreU st chunk a, [Val vr; Memstate m] => exec_storeU st m chunk a vr + | _, _ => None + end. + +Definition call_ll_loadv (c: memory_chunk) (transf: val -> val) (m: mem) (v: option val) := + match v with + | Some va => match Mem.loadv c m va with + | Some v' => Some (Val (transf v')) + | None => None + end + | None => None (* should never occurs *) + end. + +Definition exec_load1 (ld: load_rd_a) (m: mem) (chunk: memory_chunk) (a: addressing) (vl: val) := + let v := + match a with + | ADimm _ n => Some (Val.addl vl (Vlong n)) + | ADadr _ id ofs => Some (Val.addl vl (symbol_low Ge.(_lk) id ofs)) + | _ => None + end in + call_ll_loadv chunk (interp_load ld) m v. + +Definition exec_load2 (ld: load_rd_a) (m: mem) (chunk: memory_chunk) (a: addressing) (vl1 vl2: val) := + let v := + match a with + | ADreg _ _ => Some (Val.addl vl1 vl2) + | ADlsl _ _ n => Some (Val.addl vl1 (Val.shll vl2 (Vint n))) + | ADsxt _ _ n => Some (Val.addl vl1 (Val.shll (Val.longofint vl2) (Vint n))) + | ADuxt _ _ n => Some (Val.addl vl1 (Val.shll (Val.longofintu vl2) (Vint n))) + | _ => None + end in + call_ll_loadv chunk (interp_load ld) m v. + +Definition exec_loadU (n: load_rd_a) (m: mem) (chunk: memory_chunk) (a: addressing) := + call_ll_loadv chunk (interp_load n) m None. + +Definition load_eval (o: load_op) (l: list value) := + match o, l with + | Oload1 ld chunk a, [Val vs; Memstate m] => exec_load1 ld m chunk a vs + | Oload2 ld chunk a, [Val vs1; Val vs2; Memstate m] => exec_load2 ld m chunk a vs1 vs2 + | OloadU st chunk a, [Memstate m] => exec_loadU st m chunk a + | _, _ => None + end. + +Definition eval_allocf (o: allocf_op) (l: list value) := + match o, l with + | OAllocf_Mem sz linkofs, [Val spv; Memstate m] => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + call_ll_storev Mint64 m1 (Some (Val.offset_ptr sp linkofs)) spv + | OAllocf_SP sz linkofs, [Val spv; Memstate m] => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match call_ll_storev Mint64 m1 (Some (Val.offset_ptr sp linkofs)) spv with + | None => None + | Some ms => Some (Val sp) + end + | _, _ => None + end. + +Definition eval_freef (o: freef_op) (l: list value) := + match o, l with + | OFreef_Mem sz linkofs, [Val spv; Memstate m] => + match call_ll_loadv Mint64 (fun v => v) m (Some (Val.offset_ptr spv linkofs)) with + | None => None + | Some v => + match spv with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => None + | Some m' => Some (Memstate m') + end + | _ => None + end + end + | OFreef_SP sz linkofs, [Val spv; Memstate m] => + match call_ll_loadv Mint64 (fun v => v) m (Some (Val.offset_ptr spv linkofs)) with + | None => None + | Some v => + match spv with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => None + | Some m' => Some (v) + end + | _ => None + end + end + | _, _ => None + end. + +Definition op_eval (op: op) (l:list value) := + match op, l with + | Arith op, l => arith_op_eval op l + | Load o, l => load_eval o l + | Store o, l => store_eval o l + | Allocframe o, l => eval_allocf o l + | Freeframe o, l => eval_freef o l + | Loadsymbol id, [] => Some (Val (Genv.symbol_address Ge.(_genv) id Ptrofs.zero)) + | Cvtsw2x, [Val v] => Some (Val (Val.longofint v)) + | Cvtuw2x, [Val v] => Some (Val (Val.longofintu v)) + | Cvtx2w, [Val v] => Some (Val (Val.loword v)) + | Control o, l => control_eval o l + | Constant v, [] => Some (Val v) + | _, _ => None + end. + +Definition vz_eq (vz1 vz2: val) : ?? bool := + RET (match vz1 with + | Vint i1 => match vz2 with + | Vint i2 => Int.eq i1 i2 + | _ => false + end + | Vlong l1 => match vz2 with + | Vlong l2 => Int64.eq l1 l2 + | _ => false + end + | _ => false + end). + +Lemma vz_eq_correct vz1 vz2: + WHEN vz_eq vz1 vz2 ~> b THEN b = true -> vz1 = vz2. +Proof. + wlp_simplify. + destruct vz1; destruct vz2; trivial; try discriminate. + - eapply f_equal; apply Int.same_if_eq; auto. + - eapply f_equal. apply Int64.same_if_eq; auto. +Qed. +Hint Resolve vz_eq_correct: wlp. + +Definition is_eq (is1 is2: isize) : ?? bool := + RET (match is1 with + | W => match is2 with + | W => true + | _ => false + end + | X => match is2 with + | X => true + | _ => false + end + end). + +Lemma is_eq_correct is1 is2: + WHEN is_eq is1 is2 ~> b THEN b = true -> is1 = is2. +Proof. + wlp_simplify; destruct is1; destruct is2; trivial; try discriminate. +Qed. +Hint Resolve is_eq_correct: wlp. + +Definition arith_op_eq (o1 o2: arith_op): ?? bool := + match o1 with + | OArithP n1 => + match o2 with OArithP n2 => phys_eq n1 n2 | _ => RET false end + | OArithPP n1 => + match o2 with OArithPP n2 => phys_eq n1 n2 | _ => RET false end + | OArithPPP n1 => + match o2 with OArithPPP n2 => phys_eq n1 n2 | _ => RET false end + | OArithRR0R n1 => + match o2 with OArithRR0R n2 => phys_eq n1 n2 | _ => RET false end + | OArithRR0R_XZR n1 vz1 => + match o2 with OArithRR0R_XZR n2 vz2 => iandb (phys_eq n1 n2) (vz_eq vz1 vz2) | _ => RET false end + | OArithRR0 n1 => + match o2 with OArithRR0 n2 => phys_eq n1 n2 | _ => RET false end + | OArithRR0_XZR n1 vz1 => + match o2 with OArithRR0_XZR n2 vz2 => iandb (phys_eq n1 n2) (vz_eq vz1 vz2) | _ => RET false end + | OArithARRRR0 n1 => + match o2 with OArithARRRR0 n2 => phys_eq n1 n2 | _ => RET false end + | OArithARRRR0_XZR n1 vz1 => + match o2 with OArithARRRR0_XZR n2 vz2 => iandb (phys_eq n1 n2) (vz_eq vz1 vz2) | _ => RET false end + | OArithComparisonPP_CN n1 => + match o2 with OArithComparisonPP_CN n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonPP_CZ n1 => + match o2 with OArithComparisonPP_CZ n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonPP_CC n1 => + match o2 with OArithComparisonPP_CC n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonPP_CV n1 => + match o2 with OArithComparisonPP_CV n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonR0R_CN n1 is1 => + match o2 with OArithComparisonR0R_CN n2 is2 => iandb (phys_eq n1 n2) (is_eq is1 is2) | _ => RET false end + | OArithComparisonR0R_CZ n1 is1 => + match o2 with OArithComparisonR0R_CZ n2 is2 => iandb (phys_eq n1 n2) (is_eq is1 is2) | _ => RET false end + | OArithComparisonR0R_CC n1 is1 => + match o2 with OArithComparisonR0R_CC n2 is2 => iandb (phys_eq n1 n2) (is_eq is1 is2) | _ => RET false end + | OArithComparisonR0R_CV n1 is1 => + match o2 with OArithComparisonR0R_CV n2 is2 => iandb (phys_eq n1 n2) (is_eq is1 is2) | _ => RET false end + | OArithComparisonR0R_CN_XZR n1 is1 vz1 => + match o2 with OArithComparisonR0R_CN_XZR n2 is2 vz2 => iandb (vz_eq vz1 vz2) (iandb (phys_eq n1 n2) (is_eq is1 is2)) | _ => RET false end + | OArithComparisonR0R_CZ_XZR n1 is1 vz1 => + match o2 with OArithComparisonR0R_CZ_XZR n2 is2 vz2 => iandb (vz_eq vz1 vz2) (iandb (phys_eq n1 n2) (is_eq is1 is2)) | _ => RET false end + | OArithComparisonR0R_CC_XZR n1 is1 vz1 => + match o2 with OArithComparisonR0R_CC_XZR n2 is2 vz2 => iandb (vz_eq vz1 vz2) (iandb (phys_eq n1 n2) (is_eq is1 is2)) | _ => RET false end + | OArithComparisonR0R_CV_XZR n1 is1 vz1 => + match o2 with OArithComparisonR0R_CV_XZR n2 is2 vz2 => iandb (vz_eq vz1 vz2) (iandb (phys_eq n1 n2) (is_eq is1 is2)) | _ => RET false end + | OArithComparisonP_CN n1 => + match o2 with OArithComparisonP_CN n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonP_CZ n1 => + match o2 with OArithComparisonP_CZ n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonP_CC n1 => + match o2 with OArithComparisonP_CC n2 => phys_eq n1 n2 | _ => RET false end + | OArithComparisonP_CV n1 => + match o2 with OArithComparisonP_CV n2 => phys_eq n1 n2 | _ => RET false end + | Ocset c1 => + match o2 with Ocset c2 => struct_eq c1 c2 | _ => RET false end + | Ofmovi fsz1 => + match o2 with Ofmovi fsz2 => phys_eq fsz1 fsz2 | _ => RET false end + | Ofmovi_XZR fsz1 => + match o2 with Ofmovi_XZR fsz2 => phys_eq fsz1 fsz2 | _ => RET false end + | Ocsel c1 => + match o2 with Ocsel c2 => struct_eq c1 c2 | _ => RET false end + | Ofnmul fsz1 => + match o2 with Ofnmul fsz2 => phys_eq fsz1 fsz2 | _ => RET false end + end. + +Ltac my_wlp_simplify := wlp_xsimplify ltac:(intros; subst; simpl in * |- *; congruence || intuition eauto with wlp). + +Lemma arith_op_eq_correct o1 o2: + WHEN arith_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. +Proof. + destruct o1, o2; my_wlp_simplify; try congruence; + try (destruct vz; destruct vz0); try (destruct is; destruct is0); + repeat apply f_equal; try congruence; + try apply Int.same_if_eq; try apply Int64.same_if_eq; try auto. +Qed. +Hint Resolve arith_op_eq_correct: wlp. +Opaque arith_op_eq_correct. + +Definition control_op_eq (c1 c2: control_op): ?? bool := + match c1 with + | Ob lbl1 => + match c2 with Ob lbl2 => phys_eq lbl1 lbl2 | _ => RET false end + | Obc c1 lbl1 => + match c2 with Obc c2 lbl2 => iandb (struct_eq c1 c2) (phys_eq lbl1 lbl2) | _ => RET false end + | Obl id1 => + match c2 with Obl id2 => phys_eq id1 id2 | _ => RET false end + | Obs id1 => + match c2 with Obs id2 => phys_eq id1 id2 | _ => RET false end + | Ocbnz sz1 lbl1 => + match c2 with Ocbnz sz2 lbl2 => iandb (phys_eq sz1 sz2) (phys_eq lbl1 lbl2) | _ => RET false end + | Ocbz sz1 lbl1 => + match c2 with Ocbz sz2 lbl2 => iandb (phys_eq sz1 sz2) (phys_eq lbl1 lbl2) | _ => RET false end + | Otbnz sz1 n1 lbl1 => + match c2 with Otbnz sz2 n2 lbl2 => iandb (RET (Int.eq n1 n2)) (iandb (phys_eq sz1 sz2) (phys_eq lbl1 lbl2)) | _ => RET false end + | Otbz sz1 n1 lbl1 => + match c2 with Otbz sz2 n2 lbl2 => iandb (RET (Int.eq n1 n2)) (iandb (phys_eq sz1 sz2) (phys_eq lbl1 lbl2)) | _ => RET false end + | Obtbl tbl1 => + match c2 with Obtbl tbl2 => (phys_eq tbl1 tbl2) | _ => RET false end + | OIncremPC sz1 => + match c2 with OIncremPC sz2 => RET (Z.eqb sz1 sz2) | _ => RET false end + | OError => + match c2 with OError => RET true | _ => RET false end + end. + +Lemma control_op_eq_correct c1 c2: + WHEN control_op_eq c1 c2 ~> b THEN b = true -> c1 = c2. +Proof. + destruct c1, c2; wlp_simplify; try rewrite Z.eqb_eq in * |-; try congruence; + try apply Int.same_if_eq in H; try congruence. +Qed. +Hint Resolve control_op_eq_correct: wlp. +Opaque control_op_eq_correct. + +Definition store_op_eq (s1 s2: store_op): ?? bool := + match s1 with + | Ostore1 st1 chk1 a1 => + match s2 with Ostore1 st2 chk2 a2 => iandb (struct_eq chk1 chk2) (iandb (struct_eq st1 st2) (struct_eq a1 a2)) | _ => RET false end + | Ostore2 st1 chk1 a1 => + match s2 with Ostore2 st2 chk2 a2 => iandb (struct_eq chk1 chk2) (iandb (struct_eq st1 st2) (struct_eq a1 a2)) | _ => RET false end + | OstoreU st1 chk1 a1 => + match s2 with OstoreU st2 chk2 a2 => iandb (struct_eq chk1 chk2) (iandb (struct_eq st1 st2) (struct_eq a1 a2)) | _ => RET false end + end. + +Lemma store_op_eq_correct s1 s2: + WHEN store_op_eq s1 s2 ~> b THEN b = true -> s1 = s2. +Proof. + destruct s1, s2; wlp_simplify; try congruence. + all: rewrite H1 in H0; rewrite H0, H; reflexivity. +Qed. +Hint Resolve store_op_eq_correct: wlp. +Opaque store_op_eq_correct. + +Definition load_op_eq (l1 l2: load_op): ?? bool := + match l1 with + | Oload1 ld1 chk1 a1 => + match l2 with Oload1 ld2 chk2 a2 => iandb (struct_eq chk1 chk2) (iandb (struct_eq ld1 ld2) (struct_eq a1 a2)) | _ => RET false end + | Oload2 ld1 chk1 a1 => + match l2 with Oload2 ld2 chk2 a2 => iandb (struct_eq chk1 chk2) (iandb (struct_eq ld1 ld2) (struct_eq a1 a2)) | _ => RET false end + | OloadU ld1 chk1 a1 => + match l2 with OloadU ld2 chk2 a2 => iandb (struct_eq chk1 chk2) (iandb (struct_eq ld1 ld2) (struct_eq a1 a2)) | _ => RET false end + end. + +Lemma load_op_eq_correct l1 l2: + WHEN load_op_eq l1 l2 ~> b THEN b = true -> l1 = l2. +Proof. + destruct l1, l2; wlp_simplify; try congruence. + all: rewrite H1 in H0; rewrite H, H0; reflexivity. +Qed. +Hint Resolve load_op_eq_correct: wlp. +Opaque load_op_eq_correct. + +Definition allocf_op_eq (al1 al2: allocf_op): ?? bool := + match al1 with + | OAllocf_SP sz1 linkofs1 => + match al2 with OAllocf_SP sz2 linkofs2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq linkofs1 linkofs2) | _ => RET false end + | OAllocf_Mem sz1 linkofs1 => + match al2 with OAllocf_Mem sz2 linkofs2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq linkofs1 linkofs2) | _ => RET false end + end. + +Lemma allocf_op_eq_correct al1 al2: + WHEN allocf_op_eq al1 al2 ~> b THEN b = true -> al1 = al2. +Proof. + destruct al1, al2; wlp_simplify; try congruence. + all: rewrite H2; rewrite Z.eqb_eq in H; rewrite H; reflexivity. +Qed. +Hint Resolve allocf_op_eq_correct: wlp. +Opaque allocf_op_eq_correct. + +Definition freef_op_eq (fr1 fr2: freef_op): ?? bool := + match fr1 with + | OFreef_SP sz1 linkofs1 => + match fr2 with OFreef_SP sz2 linkofs2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq linkofs1 linkofs2) | _ => RET false end + | OFreef_Mem sz1 linkofs1 => + match fr2 with OFreef_Mem sz2 linkofs2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq linkofs1 linkofs2) | _ => RET false end + end. + +Lemma freef_op_eq_correct fr1 fr2: + WHEN freef_op_eq fr1 fr2 ~> b THEN b = true -> fr1 = fr2. +Proof. + destruct fr1, fr2; wlp_simplify; try congruence. + all: rewrite H2; rewrite Z.eqb_eq in H; rewrite H; reflexivity. +Qed. +Hint Resolve freef_op_eq_correct: wlp. +Opaque freef_op_eq_correct. + +Definition op_eq (o1 o2: op): ?? bool := + match o1 with + | Arith i1 => + match o2 with Arith i2 => arith_op_eq i1 i2 | _ => RET false end + | Control i1 => + match o2 with Control i2 => control_op_eq i1 i2 | _ => RET false end + | Load i1 => + match o2 with Load i2 => load_op_eq i1 i2 | _ => RET false end + | Store i1 => + match o2 with Store i2 => store_op_eq i1 i2 | _ => RET false end + | Allocframe i1 => + match o2 with Allocframe i2 => allocf_op_eq i1 i2 | _ => RET false end + | Freeframe i1 => + match o2 with Freeframe i2 => freef_op_eq i1 i2 | _ => RET false end + | Loadsymbol id1 => + match o2 with Loadsymbol id2 => phys_eq id1 id2 | _ => RET false end + | Cvtsw2x => + match o2 with Cvtsw2x => RET true | _ => RET false end + | Cvtuw2x => + match o2 with Cvtuw2x => RET true | _ => RET false end + | Cvtx2w => + match o2 with Cvtx2w => RET true | _ => RET false end + | Constant c1 => + match o2 with Constant c2 => phys_eq c1 c2 | _ => RET false end + end. + +Lemma op_eq_correct o1 o2: + WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; congruence. +Qed. + +End IMPPARAM. + +End P. + +Module L <: ISeqLanguage with Module LP:=P. + +Module LP:=P. + +Include MkSeqLanguage P. + +End L. + +Module IST := ImpSimu L ImpPosDict. + +Import L. +Import P. + +(** Compilation from [Asmblock] to [L] *) + +Local Open Scope positive_scope. + +Definition pmem : R.t := 1. + +Definition ireg_to_pos (ir: ireg) : R.t := + match ir with + | X0 => 8 | X1 => 9 | X2 => 10 | X3 => 11 | X4 => 12 | X5 => 13 | X6 => 14 | X7 => 15 + | X8 => 16 | X9 => 17 | X10 => 18 | X11 => 19 | X12 => 20 | X13 => 21 | X14 => 22 | X15 => 23 + | X16 => 24 | X17 => 25 | X18 => 26 | X19 => 27 | X20 => 28 | X21 => 29 | X22 => 30 | X23 => 31 + | X24 => 32 | X25 => 33 | X26 => 34 | X27 => 35 | X28 => 36 | X29 => 37 | X30 => 38 + end +. + +Definition freg_to_pos (fr: freg) : R.t := + match fr with + | D0 => 39 | D1 => 40 | D2 => 41 | D3 => 42 | D4 => 43 | D5 => 44 | D6 => 45 | D7 => 46 + | D8 => 47 | D9 => 48 | D10 => 49 | D11 => 50 | D12 => 51 | D13 => 52 | D14 => 53 | D15 => 54 + | D16 => 55 | D17 => 56 | D18 => 57 | D19 => 58 | D20 => 59 | D21 => 60 | D22 => 61 | D23 => 62 + | D24 => 63 | D25 => 64 | D26 => 65 | D27 => 66 | D28 => 67 | D29 => 68 | D30 => 69 | D31 => 70 + end +. + +Lemma ireg_to_pos_discr: forall r r', r <> r' -> ireg_to_pos r <> ireg_to_pos r'. +Proof. + destruct r; destruct r'; try contradiction; discriminate. +Qed. + +Lemma freg_to_pos_discr: forall r r', r <> r' -> freg_to_pos r <> freg_to_pos r'. +Proof. + destruct r; destruct r'; try contradiction; discriminate. +Qed. + +Definition ppos (r: preg) : R.t := + match r with + | CR c => match c with + | CN => 2 + | CZ => 3 + | CC => 4 + | CV => 5 + end + | PC => 6 + | DR d => match d with + | IR i => match i with + | XSP => 7 + | RR1 ir => ireg_to_pos ir + end + | FR fr => freg_to_pos fr + end + end +. + +Notation "# r" := (ppos r) (at level 100, right associativity). + +Lemma not_eq_add: + forall k n n', n <> n' -> k + n <> k + n'. +Proof. + intros k n n' H1 H2. apply H1; clear H1. eapply Pos.add_reg_l; eauto. +Qed. + +Lemma ppos_equal: forall r r', r = r' <-> ppos r = ppos r'. +Proof. + destruct r as [dr|cr|]; destruct r' as [dr'|cr'|]; + try destruct dr as [ir|fr]; try destruct dr' as [ir'|fr']; + try destruct ir as [irr|]; try destruct ir' as [irr'|]. + all: split; intros; try rewrite H; try discriminate; try contradiction; simpl; eauto; + try destruct irr; try destruct irr'; + try destruct fr; try destruct fr'; + try destruct cr; try destruct cr'; + simpl; try discriminate; try reflexivity. +Qed. + +Lemma ppos_discr: forall r r', r <> r' <-> ppos r <> ppos r'. +Proof. + split; unfold not; try intros; try apply ppos_equal in H0; try discriminate; try contradiction. +Qed. + +Lemma ppos_pmem_discr: forall r, pmem <> ppos r. +Proof. + intros. destruct r as [dr|cr|]. + - destruct dr as [ir|fr]; try destruct ir as [irr|]; try destruct irr; try destruct fr; + unfold ppos; unfold pmem; discriminate. + - unfold ppos; unfold pmem; destruct cr; discriminate. + - unfold ppos; unfold pmem; discriminate. +Qed. + +(** Inversion functions, used for debug traces *) + +Definition pos_to_ireg (p: R.t) : option ireg := + match p with + | 8 => Some (X0) | 9 => Some (X1) | 10 => Some (X2) | 11 => Some (X3) | 12 => Some (X4) | 13 => Some (X5) | 14 => Some (X6) | 15 => Some (X7) + | 16 => Some (X8) | 17 => Some (X9) | 18 => Some (X10) | 19 => Some (X11) | 20 => Some (X12) | 21 => Some (X13) | 22 => Some (X14) | 23 => Some (X15) + | 24 => Some (X16) | 25 => Some (X17) | 26 => Some (X18) | 27 => Some (X19) | 28 => Some (X20) | 29 => Some (X21) | 30 => Some (X22) | 31 => Some (X23) + | 32 => Some (X24) | 33 => Some (X25) | 34 => Some (X26) | 35 => Some (X27) | 36 => Some (X28) | 37 => Some (X29) | 38 => Some (X30) | _ => None + end. + +Definition pos_to_freg (p: R.t) : option freg := + match p with + | 39 => Some(D0) | 40 => Some(D1) | 41 => Some(D2) | 42 => Some(D3) | 43 => Some(D4) | 44 => Some(D5) | 45 => Some(D6) | 46 => Some(D7) + | 47 => Some(D8) | 48 => Some(D9) | 49 => Some(D10) | 50 => Some(D11) | 51 => Some(D12) | 52 => Some(D13) | 53 => Some(D14) | 54 => Some(D15) + | 55 => Some(D16) | 56 => Some(D17) | 57 => Some(D18) | 58 => Some(D19) | 59 => Some(D20) | 60 => Some(D21) | 61 => Some(D22) | 62 => Some(D23) + | 63 => Some(D24) | 64 => Some(D25) | 65 => Some(D26) | 66 => Some(D27) | 67 => Some(D28) | 68 => Some(D29) | 69 => Some(D30) | 70 => Some(D31) | _ => None + end. + +Definition inv_ppos (p: R.t) : option preg := + match p with + | 1 => None + | 2 => Some (CR CN) + | 3 => Some (CR CZ) + | 4 => Some (CR CC) + | 5 => Some (CR CV) + | 6 => Some (PC) + | 7 => Some (DR (IR XSP)) + | n => match pos_to_ireg n with + | None => match pos_to_freg n with + | None => None + | Some fr => Some (DR (FR fr)) + end + | Some ir => Some (DR (IR ir)) + end + end. + +Notation "a @ b" := (Econs a b) (at level 102, right associativity). + +(** Translations of instructions *) + +Definition get_testcond_rlocs (c: testcond) := + match c with + | TCeq => (PReg(#CZ) @ Enil) + | TCne => (PReg(#CZ) @ Enil) + | TChs => (PReg(#CC) @ Enil) + | TClo => (PReg(#CC) @ Enil) + | TCmi => (PReg(#CN) @ Enil) + | TCpl => (PReg(#CN) @ Enil) + | TChi => (PReg(#CZ) @ PReg(#CC) @ Enil) + | TCls => (PReg(#CZ) @ PReg(#CC) @ Enil) + | TCge => (PReg(#CN) @ PReg(#CV) @ Enil) + | TClt => (PReg(#CN) @ PReg(#CV) @ Enil) + | TCgt => (PReg(#CN) @ PReg(#CZ) @ PReg(#CV) @ Enil) + | TCle => (PReg(#CN) @ PReg(#CZ) @ PReg(#CV) @ Enil) + end. + +Definition trans_control (ctl: control) : inst := + match ctl with + | Pb lbl => [(#PC, Op (Control (Ob lbl)) (PReg(#PC) @ Enil))] + | Pbc c lbl => + let lr := get_testcond_rlocs c in + [(#PC, Op (Control (Obc c lbl)) (PReg(#PC) @ lr))] + | Pbl id sg => [(#RA, PReg(#PC)); + (#PC, Op (Control (Obl id)) Enil)] + | Pbs id sg => [(#PC, Op (Control (Obs id)) Enil)] + | Pblr r sg => [(#RA, PReg(#PC)); + (#PC, Old (PReg(#r)))] + | Pbr r sg => [(#PC, PReg(#r))] + | Pret r => [(#PC, PReg(#r))] + | Pcbnz sz r lbl => [(#PC, Op (Control (Ocbnz sz lbl)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Pcbz sz r lbl => [(#PC, Op (Control (Ocbz sz lbl)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Ptbnz sz r n lbl => [(#PC, Op (Control (Otbnz sz n lbl)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Ptbz sz r n lbl => [(#PC, Op (Control (Otbz sz n lbl)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Pbtbl r tbl => [(#X16, Op (Constant Vundef) Enil); + (#PC, Op (Control (Obtbl tbl)) (PReg(#r) @ PReg(#PC) @ Enil)); + (#X16, Op (Constant Vundef) Enil)] + | Pbuiltin ef args res => [] + end. + +Definition trans_exit (ex: option control) : L.inst := + match ex with + | None => [] + | Some ctl => trans_control ctl + end +. + +Definition trans_arith (ai: ar_instruction) : inst := + match ai with + | PArithP n rd => + if destroy_X16 n then [(#rd, Op(Arith (OArithP n)) Enil); (#X16, Op (Constant Vundef) Enil)] + else [(#rd, Op(Arith (OArithP n)) Enil)] + | PArithPP n rd r1 => [(#rd, Op(Arith (OArithPP n)) (PReg(#r1) @ Enil))] + | PArithPPP n rd r1 r2 => [(#rd, Op(Arith (OArithPPP n)) (PReg(#r1) @ PReg(#r2) @ Enil))] + | PArithRR0R n rd r1 r2 => + let lr := match r1 with + | RR0 r1' => Op(Arith (OArithRR0R n)) (PReg(#r1') @ PReg(#r2) @ Enil) + | XZR => let vz := if arith_rr0r_isize n then Vint Int.zero else Vlong Int64.zero in + Op(Arith (OArithRR0R_XZR n vz)) (PReg(#r2) @ Enil) + end in + [(#rd, lr)] + | PArithRR0 n rd r1 => + let lr := match r1 with + | RR0 r1' => Op(Arith (OArithRR0 n)) (PReg(#r1') @ Enil) + | XZR => let vz := if arith_rr0_isize n then Vint Int.zero else Vlong Int64.zero in + Op(Arith (OArithRR0_XZR n vz)) (Enil) + end in + [(#rd, lr)] + | PArithARRRR0 n rd r1 r2 r3 => + let lr := match r3 with + | RR0 r3' => Op(Arith (OArithARRRR0 n)) (PReg(#r1) @ PReg (#r2) @ PReg(#r3') @ Enil) + | XZR => let vz := if arith_arrrr0_isize n then Vint Int.zero else Vlong Int64.zero in + Op(Arith (OArithARRRR0_XZR n vz)) (PReg(#r1) @ PReg(#r2) @ Enil) + end in + [(#rd, lr)] + | PArithComparisonPP n r1 r2 => + [(#CN, Op(Arith (OArithComparisonPP_CN n)) (PReg(#r1) @ PReg(#r2) @ Enil)); + (#CZ, Op(Arith (OArithComparisonPP_CZ n)) (PReg(#r1) @ PReg(#r2) @ Enil)); + (#CC, Op(Arith (OArithComparisonPP_CC n)) (PReg(#r1) @ PReg(#r2) @ Enil)); + (#CV, Op(Arith (OArithComparisonPP_CV n)) (PReg(#r1) @ PReg(#r2) @ Enil))] + | PArithComparisonR0R n r1 r2 => + let is := arith_comparison_r0r_isize n in + match r1 with + | RR0 r1' => [(#CN, Op(Arith (OArithComparisonR0R_CN n is)) (PReg(#r1') @ PReg(#r2) @ Enil)); + (#CZ, Op(Arith (OArithComparisonR0R_CZ n is)) (PReg(#r1') @ PReg(#r2) @ Enil)); + (#CC, Op(Arith (OArithComparisonR0R_CC n is)) (PReg(#r1') @ PReg(#r2) @ Enil)); + (#CV, Op(Arith (OArithComparisonR0R_CV n is)) (PReg(#r1') @ PReg(#r2) @ Enil))] + | XZR => let vz := if is then Vint Int.zero else Vlong Int64.zero in + [(#CN, Op(Arith (OArithComparisonR0R_CN_XZR n is vz)) (PReg(#r2) @ Enil)); + (#CZ, Op(Arith (OArithComparisonR0R_CZ_XZR n is vz)) (PReg(#r2) @ Enil)); + (#CC, Op(Arith (OArithComparisonR0R_CC_XZR n is vz)) (PReg(#r2) @ Enil)); + (#CV, Op(Arith (OArithComparisonR0R_CV_XZR n is vz)) (PReg(#r2) @ Enil))] + end + | PArithComparisonP n r1 => + [(#CN, Op(Arith (OArithComparisonP_CN n)) (PReg(#r1) @ Enil)); + (#CZ, Op(Arith (OArithComparisonP_CZ n)) (PReg(#r1) @ Enil)); + (#CC, Op(Arith (OArithComparisonP_CC n)) (PReg(#r1) @ Enil)); + (#CV, Op(Arith (OArithComparisonP_CV n)) (PReg(#r1) @ Enil))] + | Pcset rd c => + let lr := get_testcond_rlocs c in + [(#rd, Op(Arith (Ocset c)) lr)] + | Pfmovi fsz rd r1 => + let lr := match r1 with + | RR0 r1' => Op(Arith (Ofmovi fsz)) (PReg(#r1') @ Enil) + | XZR => Op(Arith (Ofmovi_XZR fsz)) Enil + end in + [(#rd, lr)] + | Pcsel rd r1 r2 c => + let lr := get_testcond_rlocs c in + [(#rd, Op(Arith (Ocsel c)) (PReg(#r1) @ PReg (#r2) @ lr))] + | Pfnmul fsz rd r1 r2 => [(#rd, Op(Arith (Ofnmul fsz)) (PReg(#r1) @ PReg(#r2) @ Enil))] + end. + +Definition eval_addressing_rlocs_st (st: store_rs_a) (chunk: memory_chunk) (rs: dreg) (a: addressing) := + match a with + | ADimm base n => Op (Store (Ostore1 st chunk a)) (PReg (#rs) @ PReg (#base) @ PReg (pmem) @ Enil) + | ADreg base r => Op (Store (Ostore2 st chunk a)) (PReg (#rs) @ PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADlsl base r n => Op (Store (Ostore2 st chunk a)) (PReg (#rs) @ PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADsxt base r n => Op (Store (Ostore2 st chunk a)) (PReg (#rs) @ PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADuxt base r n => Op (Store (Ostore2 st chunk a)) (PReg (#rs) @ PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADadr base id ofs => Op (Store (Ostore1 st chunk a)) (PReg (#rs) @ PReg (#base) @ PReg (pmem) @ Enil) + | ADpostincr base n => Op (Store (OstoreU st chunk a)) (PReg (#rs) @ PReg (pmem) @ Enil) (* not modeled yet *) + end. + +Definition eval_addressing_rlocs_ld (ld: load_rd_a) (chunk: memory_chunk) (a: addressing) := + match a with + | ADimm base n => Op (Load (Oload1 ld chunk a)) (PReg (#base) @ PReg (pmem) @ Enil) + | ADreg base r => Op (Load (Oload2 ld chunk a)) (PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADlsl base r n => Op (Load (Oload2 ld chunk a)) (PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADsxt base r n => Op (Load (Oload2 ld chunk a)) (PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADuxt base r n => Op (Load (Oload2 ld chunk a)) (PReg (#base) @ PReg(#r) @ PReg (pmem) @ Enil) + | ADadr base id ofs => Op (Load (Oload1 ld chunk a)) (PReg (#base) @ PReg (pmem) @ Enil) + | ADpostincr base n => Op (Load (Oload1 ld chunk a)) (PReg (#base) @ PReg (pmem) @ Enil) + end. + +Definition trans_ldp_chunk (chunk: memory_chunk): load_rd_a := + match chunk with + | Many32 => Pldrw_a + | Mint64 => Pldrx + | Many64 => Pldrx_a + | _ => Pldrw + end. + +Definition trans_stp_chunk (chunk: memory_chunk): store_rs_a := + match chunk with + | Many32 => Pstrw_a + | Mint64 => Pstrx + | Many64 => Pstrx_a + | _ => Pstrw + end. + +Definition trans_load (ldi: ld_instruction) := + match ldi with + | PLd_rd_a ld r a => + let lr := eval_addressing_rlocs_ld ld (chunk_load ld) a in [(#r, lr)] + | Pldp ld r1 r2 chk1 chk2 a => + let ldi1 := trans_ldp_chunk chk1 in + let ldi2 := trans_ldp_chunk chk2 in + let lr := eval_addressing_rlocs_ld ldi1 chk1 a in + let ofs := match chk1 with | Mint32 | Many32 => 4%Z | _ => 8%Z end in + match a with + | ADimm base n => + let a' := (get_offset_addr a ofs) in + [(#r1, lr); + (#r2, Op (Load (Oload1 ldi2 chk2 a')) + (Old(PReg (#base)) @ PReg (pmem) @ Enil))] + | _ => [(#PC, (Op (OError)) Enil)] + end + end. + +Definition trans_store (sti: st_instruction) := + match sti with + | PSt_rs_a st r a => + let lr := eval_addressing_rlocs_st st (chunk_store st) r a in [(pmem, lr)] + | Pstp st r1 r2 chk1 chk2 a => + let sti1 := trans_stp_chunk chk1 in + let sti2 := trans_stp_chunk chk2 in + let lr := eval_addressing_rlocs_st sti1 chk1 r1 a in + let ofs := match chk1 with | Mint32 | Many32 => 4%Z | _ => 8%Z end in + match a with + | ADimm base n => + let a' := (get_offset_addr a ofs) in + [(pmem, lr); + (pmem, Op (Store (Ostore1 sti2 chk2 a')) + (PReg (#r2) @ Old(PReg (#base)) @ PReg (pmem) @ Enil))] + | _ => [(#PC, (Op (OError)) Enil)] + end + end. + +Definition trans_basic (b: basic) : inst := + match b with + | PArith ai => trans_arith ai + | PLoad ld => trans_load ld + | PStore st => trans_store st + | Pallocframe sz linkofs => + [(#X29, PReg(#SP)); + (#SP, Op (Allocframe (OAllocf_SP sz linkofs)) (PReg (#SP) @ PReg pmem @ Enil)); + (#X16, Op (Constant Vundef) Enil); + (pmem, Op (Allocframe (OAllocf_Mem sz linkofs)) (Old(PReg(#SP)) @ PReg pmem @ Enil))] + | Pfreeframe sz linkofs => + [(pmem, Op (Freeframe (OFreef_Mem sz linkofs)) (PReg (#SP) @ PReg pmem @ Enil)); + (#SP, Op (Freeframe (OFreef_SP sz linkofs)) (PReg (#SP) @ Old (PReg pmem) @ Enil)); + (#X16, Op (Constant Vundef) Enil)] + | Ploadsymbol rd id => [(#rd, Op (Loadsymbol id) Enil)] + | Pcvtsw2x rd r1 => [(#rd, Op (Cvtsw2x) (PReg (#r1) @ Enil))] + | Pcvtuw2x rd r1 => [(#rd, Op (Cvtuw2x) (PReg (#r1) @ Enil))] + | Pcvtx2w rd => [(#rd, Op (Cvtx2w) (PReg (#rd) @ Enil))] + | Pnop => [] + end. + +Fixpoint trans_body (b: list basic) : list L.inst := + match b with + | nil => nil + | b :: lb => (trans_basic b) :: (trans_body lb) + end. + +Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (PReg(#PC) @ Enil)) :: k. + +Definition trans_block (b: Asmblock.bblock) : L.bblock := + trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). + +(*Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb.*) +(*Proof.*) + (*intros. destruct bb as [hd bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity.*) +(*Qed.*) + +(*Theorem trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb.*) +(*Proof.*) + (*intros. destruct bb as [hdr bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity.*) +(*Qed.*) + +(** Lemmas on the translation *) + +Definition state := L.mem. +Definition exec := L.run. + +Definition match_states (s: Asm.state) (s': state) := + let (rs, m) := s in + s' pmem = Memstate m + /\ forall r, s' (#r) = Val (rs r). + +Definition match_outcome (o:outcome) (s: option state) := + match o with + | Some n => exists s', s=Some s' /\ match_states n s' + | None => s=None + end. + +Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). + +Definition trans_state (s: Asm.state) : state := + let (rs, m) := s in + fun x => if (Pos.eq_dec x pmem) then Memstate m + else match (inv_ppos x) with + | Some r => Val (rs r) + | None => Val Vundef + end. + +Lemma not_eq_IR: + forall r r', r <> r' -> IR r <> IR r'. +Proof. + intros. congruence. +Qed. + +Lemma ireg_pos_ppos: forall r, + ireg_to_pos r = # r. +Proof. + intros. simpl. reflexivity. +Qed. + +Lemma freg_pos_ppos: forall r, + freg_to_pos r = # r. +Proof. + intros. simpl. reflexivity. +Qed. + +Lemma ireg_not_pc: forall r, + (#PC) <> ireg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma ireg_not_pmem: forall r, + ireg_to_pos r <> pmem. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma ireg_not_CN: forall r, + 2 <> ireg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma ireg_not_CZ: forall r, + 3 <> ireg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma ireg_not_CC: forall r, + 4 <> ireg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma ireg_not_CV: forall r, + 5 <> ireg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma freg_not_pmem: forall r, + freg_to_pos r <> pmem. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma freg_not_CN: forall r, + 2 <> freg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma freg_not_CZ: forall r, + 3 <> freg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma freg_not_CC: forall r, + 4 <> freg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Lemma freg_not_CV: forall r, + 5 <> freg_to_pos r. +Proof. + intros; destruct r; discriminate. +Qed. + +Ltac DPRM pr := + destruct pr as [drDPRF|crDPRF|]; + [destruct drDPRF as [irDPRF|frDPRF]; [destruct irDPRF |] + | destruct crDPRF|]. + +Ltac DPRF pr := + destruct pr as [drDPRF|crDPRF|]; + [destruct drDPRF as [irDPRF|frDPRF]; [destruct irDPRF as [irrDPRF|]; [destruct irrDPRF|] + | destruct frDPRF] + | destruct crDPRF|]. + +Lemma preg_not_pmem: forall r, + pmem <> # r. +Proof. + intros. DPRF r; simpl; discriminate. +Qed. + +Ltac DIRN1 ir := destruct ir as [irrDIRN1|]; subst; try destruct irrDIRN1; simpl. + +Lemma dreg_not_CN: forall (r: dreg), + 2 <> (#r). +Proof. + intros; DIRN1 r; [ apply ireg_not_CN | discriminate | apply freg_not_CN]. +Qed. + +Lemma dreg_not_CZ: forall (r: dreg), + 3 <> (#r). +Proof. + intros; DIRN1 r; [ apply ireg_not_CZ | discriminate | apply freg_not_CZ]. +Qed. + +Lemma dreg_not_CC: forall (r: dreg), + 4 <> (#r). +Proof. + intros; DIRN1 r; [ apply ireg_not_CC | discriminate | apply freg_not_CC]. +Qed. + +Lemma dreg_not_CV: forall (r: dreg), + 5 <> (#r). +Proof. + intros; DIRN1 r; [ apply ireg_not_CV | discriminate | apply freg_not_CV]. +Qed. + +Lemma sr_update_both: forall sr rsr r1 rr v + (HEQV: forall r : preg, sr (# r) = Val (rsr r)), + (sr <[ (#r1) <- Val (v) ]>) (#rr) = + Val (rsr # r1 <- v rr). +Proof. + intros. unfold assign. + destruct (R.eq_dec (#r1) (#rr)); subst. + - apply ppos_equal in e; subst; rewrite Pregmap.gss; reflexivity. + - rewrite Pregmap.gso; eapply ppos_discr in n; auto. +Qed. + +Lemma sr_gss: forall sr pos v, + (sr <[ pos <- v ]>) pos = v. +Proof. + intros. unfold assign. + destruct (R.eq_dec pos pos) eqn:REQ; try reflexivity; try congruence. +Qed. + +Lemma sr_update_overwrite: forall sr pos v1 v2, + (sr <[ pos <- v1 ]>) <[ pos <- v2 ]> = (sr <[ pos <- v2 ]>). +Proof. + intros. + unfold assign. apply functional_extensionality; intros x. + destruct (R.eq_dec pos x); reflexivity. +Qed. + +Ltac sr_val_rwrt := + repeat match goal with + | [H: forall r: preg, ?sr (# r) = Val (?rsr r) |- _ ] + => rewrite H + end. + +Ltac sr_memstate_rwrt := + repeat match goal with + | [H: ?sr pmem = Memstate ?mr |- _ ] + => rewrite <- H + end. + +Ltac replace_ppos := + try erewrite !ireg_pos_ppos; + try erewrite !freg_pos_ppos; + try replace (7) with (#XSP) by eauto; + try replace (24) with (#X16) by auto. + +Ltac DDRM dr := + destruct dr as [irsDDRF|frDDRF]; + [destruct irsDDRF + | idtac ]. + +(* Ltac DDRF dr := + destruct dr as [irsDDRF|frDDRF]; + [destruct irsDDRF as [irsDDRF|]; [destruct irsDDRF|] + | destruct frDDRF]. *) + +(* Ltac DPRI pr := + destruct pr as [drDPRI|crDPRI|]; + [destruct drDPRI as [irDPRI|frDPRI]; [destruct irDPRI as [irrDPRI|]; [destruct irrDPRI|]|] + | idtac + | idtac ]. *) + +Ltac discriminate_ppos := + try apply ireg_not_pmem; + try apply ireg_not_pc; + try apply freg_not_pmem; + try apply ireg_not_CN; + try apply ireg_not_CZ; + try apply ireg_not_CC; + try apply ireg_not_CV; + try apply freg_not_CN; + try apply freg_not_CZ; + try apply freg_not_CC; + try apply freg_not_CV; + try apply dreg_not_CN; + try apply dreg_not_CZ; + try apply dreg_not_CC; + try apply dreg_not_CV; + try(simpl; discriminate). + +Ltac replace_pc := try replace (6) with (#PC) by eauto. + +Ltac replace_regs_pos sr := + try replace (sr 7) with (sr (ppos XSP)) by eauto; + try replace (sr 6) with (sr (ppos PC)) by eauto; + try replace (sr 2) with (sr (ppos CN)) by eauto; + try replace (sr 3) with (sr (ppos CZ)) by eauto; + try replace (sr 4) with (sr (ppos CC)) by eauto; + try replace (sr 5) with (sr (ppos CV)) by eauto. + +Ltac Simpl_exists sr := + replace_ppos; + replace_regs_pos sr; + try sr_val_rwrt; + try (eexists; split; [| split]); eauto; + try (sr_memstate_rwrt; rewrite assign_diff; + try reflexivity; + discriminate_ppos + ). + +Ltac Simpl_rep sr := + replace_ppos; + replace_regs_pos sr; + try sr_val_rwrt; + try (sr_memstate_rwrt; rewrite assign_diff; + try reflexivity; + discriminate_ppos + ). + +Ltac Simpl_update := + try eapply sr_update_both; eauto. + +Ltac Simpl sr := Simpl_exists sr; try (intros rr(* ; try rewrite sr_update_overwrite; replace_regs_pos sr; DPRM rr *)); Simpl_update. + +Ltac destruct_res_flag rsr := try (rewrite Pregmap.gso; discriminate_ppos); destruct (rsr _); simpl; try reflexivity. + +(* Ltac discriminate_preg_flags := rewrite !assign_diff; try rewrite !Pregmap.gso; discriminate_ppos; sr_val_rwrt; reflexivity. *) + +(* Ltac destruct_reg_neq r1 r2 := + destruct (PregEq.eq r1 r2); subst; + [ rewrite sr_gss; rewrite Pregmap.gss; reflexivity | + rewrite assign_diff; try rewrite Pregmap.gso; fold (ppos r1); try apply ppos_discr; auto]. *) + +Lemma reg_update_overwrite: forall rsr sr r rd v1 v2 + (HEQV: forall r : preg, sr (# r) = Val (rsr r)), + ((sr <[ # rd <- Val (v1) ]>) <[ # rd <- Val (v2) ]>) (# r) = + Val ((rsr # rd <- v1) # rd <- v2 r). +Proof. + intros. + unfold Pregmap.set; destruct (PregEq.eq r rd). + - rewrite e; apply sr_gss; reflexivity. + - rewrite sr_update_overwrite. rewrite assign_diff; eauto. + unfold not; intros. apply ppos_equal in H. congruence. +Qed. + +Ltac replace_regs_cond_force := + try replace (5) with (#CV) in * by auto; + try replace (4) with (#CC) in * by auto; + try replace (3) with (#CZ) in * by auto; + try replace (2) with (#CN) in * by auto. + +Ltac validate_crbit_flags rr v1 v2 := + destruct (R.eq_dec 5 (#rr)) as [e0|n0]; + destruct (R.eq_dec 4 (#rr)) as [e1|n1]; + destruct (R.eq_dec 3 (#rr)) as [e2|n2]; + destruct (R.eq_dec 2 (#rr)) as [e3|n3]; + replace_regs_cond_force; + try apply ppos_equal in e0; + try apply ppos_equal in e1; + try apply ppos_equal in e2; + try apply ppos_equal in e3; + try apply ppos_discr in n0; + try apply ppos_discr in n1; + try apply ppos_discr in n2; + try apply ppos_discr in n3; + subst. + +Ltac Simpl_flags := + try (rewrite Pregmap.gss; reflexivity); + try (rewrite Pregmap.gso, Pregmap.gss; [reflexivity|]; try auto); + try (rewrite Pregmap.gso; try auto); + try (rewrite !Pregmap.gso; try auto). + +Lemma compare_single_res: forall sr mr rsr rr v1 v2 + (HMEM: sr pmem = Memstate mr) + (HEQV: forall r : preg, sr (# r) = Val (rsr r)), + ((((sr <[ 2 <- Val (_CN (v_compare_single v1 v2)) ]>) <[ 3 <- + Val (_CZ (v_compare_single v1 v2)) ]>) <[ 4 <- + Val (_CC (v_compare_single v1 v2)) ]>) <[ 5 <- + Val (_CV (v_compare_single v1 v2)) ]>) (# rr) = +Val + ((compare_single rsr v1 v2) rr). +Proof. + intros. unfold v_compare_single, compare_single, assign. + validate_crbit_flags rr v1 v2. + all: destruct v1; destruct v2; Simpl_flags. +Qed. + +Lemma compare_float_res: forall sr mr rsr rr v1 v2 + (HMEM: sr pmem = Memstate mr) + (HEQV: forall r : preg, sr (# r) = Val (rsr r)), + ((((sr <[ 2 <- Val (_CN (v_compare_float v1 v2)) ]>) <[ 3 <- + Val (_CZ (v_compare_float v1 v2)) ]>) <[ 4 <- + Val (_CC (v_compare_float v1 v2)) ]>) <[ 5 <- + Val (_CV (v_compare_float v1 v2)) ]>) (# rr) = +Val + ((compare_float rsr v1 v2) rr). +Proof. + intros. unfold v_compare_float, compare_float, assign. + validate_crbit_flags rr v1 v2. + all: destruct v1; destruct v2; Simpl_flags. +Qed. + +Lemma compare_long_res: forall sr mr rsr rr v1 v2 + (HMEM: sr pmem = Memstate mr) + (HEQV: forall r : preg, sr (# r) = Val (rsr r)), + ((((sr <[ 2 <- Val (_CN (v_compare_long v1 v2)) ]>) <[ 3 <- + Val (_CZ (v_compare_long v1 v2)) ]>) <[ 4 <- + Val (_CC (v_compare_long v1 v2)) ]>) <[ 5 <- + Val (_CV (v_compare_long v1 v2)) ]>) (# rr) = +Val + ((compare_long rsr v1 v2) rr). +Proof. + intros. unfold v_compare_long, compare_long, assign. + validate_crbit_flags rr v1 v2. + all: Simpl_flags. +Qed. + +Lemma compare_int_res: forall sr mr rsr rr v1 v2 + (HMEM: sr pmem = Memstate mr) + (HEQV: forall r : preg, sr (# r) = Val (rsr r)), + ((((sr <[ 2 <- Val (_CN (v_compare_int v1 v2)) ]>) <[ 3 <- + Val (_CZ (v_compare_int v1 v2)) ]>) <[ 4 <- + Val (_CC (v_compare_int v1 v2)) ]>) <[ 5 <- + Val (_CV (v_compare_int v1 v2)) ]>) (# rr) = +Val + ((compare_int rsr v1 v2) rr). +Proof. + intros. unfold v_compare_int, compare_int, assign. + validate_crbit_flags rr v1 v2. + all: Simpl_flags. +Qed. + +Section SECT_SEQ. + +Variable Ge: genv. + +Lemma trans_arith_correct rsr mr sr rsw' old i: + match_states (State rsr mr) sr -> + exec_arith_instr Ge.(_lk) i rsr = rsw' -> + exists sw, + inst_run Ge (trans_arith i) sr old = Some sw + /\ match_states (State rsw' mr) sw. +Proof. + induction i. + all: intros MS EARITH; subst; inv MS; unfold exec_arith_instr. + - (* PArithP *) + destruct i. + 1,2,3: DIRN1 rd; Simpl sr. + (* Special case for Pmovimms/Pmovimmd *) + all: simpl; + try(destruct (negb (is_immediate_float32 _))); + try(destruct (negb (is_immediate_float64 _))); + DIRN1 rd; Simpl sr; + try (rewrite assign_diff; discriminate_ppos; reflexivity); + try (intros rr'; Simpl_update). + - (* PArithPP *) + DIRN1 rs; DIRN1 rd; Simpl sr. + - (* PArithPPP *) + DIRN1 r1; DIRN1 r2; DIRN1 rd; Simpl sr. + - (* PArithRR0R *) + simpl. destruct r1. + + (* OArithRR0R *) simpl; Simpl sr. + + (* OArithRR0R_XZR *) simpl; destruct (arith_rr0r_isize _); Simpl sr. + - (* PArithRR0 *) + simpl. destruct r1. + + (* OArithRR0 *) simpl; Simpl sr. + + (* OArithRR0_XZR *) simpl; destruct (arith_rr0_isize _); Simpl sr. + - (* PArithARRRR0 *) + simpl. destruct r3. + + (* OArithARRRR0 *) simpl; Simpl sr. + + (* OArithARRRR0_XZR *) simpl; destruct (arith_arrrr0_isize _); Simpl sr. + - (* PArithComparisonPP *) + simpl; destruct i; + unfold arith_eval_comparison_pp, arith_prepare_comparison_pp; simpl; + fold (ppos r2); fold(ppos r1); try rewrite !H0; repeat Simpl_rep sr; + Simpl sr; + try destruct sz; + try (eapply compare_single_res; eauto); + try (eapply compare_long_res; eauto); + try (eapply compare_float_res; eauto). + - (* PArithComparisonR0R *) + simpl; destruct r1; simpl; destruct i; + repeat (replace_regs_cond_force; try fold (ppos r); try fold(ppos r2); + try rewrite !assign_diff; discriminate_ppos; try rewrite !H0); + Simpl sr; unfold arith_eval_comparison_r0r, arith_comparison_r0r_isize; + destruct arith_prepare_comparison_r0r; destruct is; + try (eapply compare_long_res; eauto); + try (eapply compare_int_res; eauto). + - (* PArithComparisonP *) + simpl; destruct i; + unfold arith_eval_comparison_p, arith_prepare_comparison_p; simpl; + fold(ppos r1); try rewrite !H0; repeat Simpl_rep sr; + Simpl sr; + try destruct sz; + try (eapply compare_int_res; eauto); + try (eapply compare_single_res; eauto); + try (eapply compare_long_res; eauto); + try (eapply compare_float_res; eauto). + - (* Pcset *) + simpl; unfold eval_testcond, get_testcond_rlocs, cflags_eval; + unfold cond_eval_is; unfold flags_testcond_value, list_exp_eval; destruct c; simpl; + repeat Simpl_rep sr; Simpl_exists sr; + destruct_res_flag rsr; + Simpl sr. + - (* Pfmovi *) + simpl; destruct r1; simpl; destruct fsz; Simpl sr. + - (* Pcsel *) + destruct c; simpl; DIRN1 rd; fold (ppos r2); fold (ppos r1); Simpl sr. + - (* Pfnmul *) + simpl; destruct fsz; Simpl sr. +Qed. + +Lemma sp_xsp: + SP = XSP. +Proof. + econstructor. +Qed. + +Lemma load_chunk_neutral: forall chk v, + interp_load (trans_ldp_chunk chk) v = v. +Proof. + intros; destruct chk; simpl; reflexivity. +Qed. + +Theorem bisimu_basic rsr mr sr bi: + match_states (State rsr mr) sr -> + match_outcome (exec_basic Ge.(_lk) Ge.(_genv) bi rsr mr) (inst_run Ge (trans_basic bi) sr sr). +Proof. +(* a little tactic to automate reasoning on preg_eq *) +Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. +Local Ltac preg_eq_discr r rd := + destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto); + rewrite (assign_diff _ (#rd) (#r) _); auto; + rewrite Pregmap.gso; auto. + + intros MS; inversion MS as (H & H0). + destruct bi; simpl. + (* Loadsymbol / Cvtsw2x / Cvtuw2x / Cvtx2w *) + 6,7,8,9: Simpl sr. + - (* Arith *) + exploit trans_arith_correct; eauto. + - (* Load *) + destruct ld. + + unfold exec_load, exec_load_rd_a, eval_addressing_rlocs_ld, exp_eval; + destruct ld; destruct a; simpl; + try fold (ppos base); try fold (ppos r); + erewrite !H0, H; simpl; + unfold exec_load1, exec_load2, chunk_load; unfold call_ll_loadv; + try destruct (Mem.loadv _ _ _); simpl; auto. + all: try (fold (ppos rd); Simpl_exists sr; auto; intros rr; Simpl_update). + + + unfold exec_load, exec_load_double, eval_addressing_rlocs_ld, exp_eval; + destruct ld; destruct a; simpl; unfold control_eval; destruct Ge; auto; + try fold (ppos base); + try erewrite !H0, H; simpl; + unfold exec_load1, exec_load2; unfold call_ll_loadv; + destruct (Mem.loadv _ _ _); simpl; auto; + fold (ppos rd1); rewrite assign_diff; discriminate_ppos; rewrite H; + try destruct (Mem.loadv _ _ _); simpl; auto; Simpl_exists sr; + rewrite !load_chunk_neutral; + try (rewrite !assign_diff; discriminate_ppos; reflexivity); + try (destruct base; discriminate_ppos); + repeat (try fold (ppos r); intros; Simpl_update). + - (* Store *) + destruct st. + + unfold exec_store, exec_store_rs_a, eval_addressing_rlocs_st, exp_eval; + destruct st; destruct a; simpl; + try fold (ppos base); try fold (ppos rs); try fold (ppos r); + erewrite !H0, H; simpl; + unfold exec_store1, exec_store2, chunk_store; unfold call_ll_storev; + try destruct (Mem.storev _ _ _ _); simpl; auto. + all: eexists; split; [| split]; eauto; + intros rr; rewrite assign_diff; try rewrite H0; auto; discriminate_ppos. + + unfold exec_store, exec_store_double, eval_addressing_rlocs_st, exp_eval; + destruct st; destruct a; simpl; unfold control_eval; destruct Ge; auto; + try fold (ppos base); try fold (ppos rs1); + erewrite !H0, H; simpl; + unfold exec_store1, exec_store2; unfold call_ll_storev; + try destruct (Mem.storev _ _ _ _); simpl; auto; + fold (ppos rs2); rewrite assign_diff; try congruence; try rewrite H0; simpl; + try destruct (Mem.storev _ _ _ _); simpl; auto. + all: eexists; split; [| split]; eauto; + repeat (try intros rr; rewrite assign_diff; try rewrite H0; auto; discriminate_ppos). + - (* Alloc *) + destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. + + eexists; repeat split. + * rewrite !assign_diff; try discriminate_ppos; Simpl_exists sr; + rewrite H; destruct (Mem.alloc _ _ _) eqn:MEMAL2; + injection MEMAL; intros Hm Hb; try rewrite Hm, Hb; + rewrite sp_xsp in MEMS; rewrite MEMS. + rewrite !assign_diff; try discriminate_ppos; Simpl_exists sr; rewrite H; + destruct (Mem.alloc _ _ _) eqn:MEMAL3; + injection MEMAL2; intros Hm2 Hb2; try rewrite Hm2, Hb2; + rewrite Hm, Hb; rewrite MEMS; reflexivity. + * eauto. + * intros rr. rewrite assign_diff; try apply preg_not_pmem; try rewrite sp_xsp. + replace 37 with (#X29) by auto; repeat (Simpl_update; intros). + + simpl; repeat Simpl_exists sr. erewrite H. destruct (Mem.alloc _ _ _) eqn:HMEMAL2. + injection MEMAL; intros Hm Hb. + try rewrite Hm, Hb; clear Hm Hb. + try rewrite sp_xsp in MEMS; rewrite MEMS. reflexivity. + - (* Free *) + destruct (Mem.loadv _ _ _) eqn:MLOAD; simpl; auto; + repeat Simpl_exists sr; rewrite H; simpl. + + destruct (rsr SP) eqn:EQSP; simpl; rewrite <- sp_xsp; rewrite EQSP; rewrite MLOAD; try reflexivity. + destruct (Mem.free _ _ _) eqn:EQFREE; try reflexivity. rewrite assign_diff; discriminate_ppos. + replace_regs_pos sr; sr_val_rwrt. rewrite <- sp_xsp; rewrite EQSP; rewrite MLOAD. rewrite EQFREE. + replace 24 with (#X16) by auto; rewrite sp_xsp; Simpl sr. + intros rr'; destruct (PregEq.eq XSP rr'). + * rewrite e; rewrite Pregmap.gss, sr_gss; auto. + * rewrite Pregmap.gso, !assign_diff; auto; apply ppos_discr in n; auto. + + rewrite <- sp_xsp; rewrite MLOAD; reflexivity. + - (* Nop *) + Simpl sr. +Qed. + +Theorem bisimu_body: + forall bdy rsr mr sr, + match_states (State rsr mr) sr -> + match_outcome (exec_body Ge.(_lk) Ge.(_genv) bdy rsr mr) (exec Ge (trans_body bdy) sr). +Proof. + induction bdy as [|i bdy]; simpl; eauto. + intros. + exploit (bisimu_basic rsr mr sr i); eauto. + destruct (exec_basic _ _ _ _ _); simpl. + - intros (s' & X1 & X2). + rewrite X1; simpl; eauto. eapply IHbdy; eauto; simpl. + unfold match_states in *. destruct s. unfold Asm._m. eauto. + - intros X; rewrite X; simpl; auto. +Qed. + +Theorem bisimu_control ex sz rsr mr sr: + match_states (State rsr mr) sr -> + match_outcome (exec_cfi Ge.(_genv) Ge.(_fn) ex (incrPC (Ptrofs.repr sz) rsr) mr) (inst_run Ge (trans_pcincr sz (trans_exit (Some (PCtlFlow ex)))) sr sr). +Proof. + intros MS. + simpl in *. inv MS. + destruct ex. + (* Obr / Oret *) + 6,7: unfold control_eval, incrPC; simpl; destruct Ge; + replace_pc; rewrite (H0 PC); + repeat Simpl_rep sr; Simpl_exists sr; + intros rr; destruct (preg_eq rr PC); [ + rewrite e; rewrite sr_gss; rewrite Pregmap.gss; + try rewrite Pregmap.gso; discriminate_ppos; fold (ppos r); auto | + repeat Simpl_rep sr; try rewrite !Pregmap.gso; auto; apply ppos_discr in n; auto ]. + (* Ocbnz / Ocbz *) + 6,7,8,9: unfold control_eval; destruct Ge; simpl; + replace_pc; rewrite (H0 PC); + unfold eval_branch, eval_neg_branch, eval_testzero, eval_testbit, + incrPC, goto_label_deps, goto_label; + destruct (PregEq.eq r PC); + [ rewrite e; destruct sz0; simpl; Simpl sr | + destruct sz0; simpl; replace_pc; rewrite Pregmap.gso; auto; repeat Simpl_rep sr; try rewrite H0; + try (destruct (Val.mxcmpu_bool _ _ _) eqn:EQCMP; try reflexivity; destruct b); + try (destruct (Val.mxcmplu_bool _ _ _) eqn:EQCMP; try reflexivity; destruct b); + try (destruct (Val.cmp_bool _ _ _) eqn:EQCMP; try reflexivity; destruct b); + try (destruct (Val.cmpl_bool _ _ _) eqn:EQCMP; try reflexivity; destruct b); + try (simpl; rewrite sr_update_overwrite; replace_pc; Simpl sr); + destruct (label_pos _ _ _); try reflexivity; rewrite Pregmap.gss; + destruct Val.offset_ptr; try reflexivity; rewrite sr_update_overwrite; + simpl; Simpl sr; (destruct (PregEq.eq rr PC); subst; + [ rewrite sr_gss, Pregmap.gss; reflexivity | + rewrite !assign_diff, !Pregmap.gso; replace_pc; auto; apply ppos_discr; auto]) ]. + - (* Ob *) + replace_pc. rewrite (H0 PC). simpl. + unfold goto_label, control_eval. destruct Ge. + unfold goto_label_deps. destruct (label_pos _ _ _); auto. + + unfold incrPC. rewrite Pregmap.gss; eauto. destruct (Val.offset_ptr _ _); auto; + try (rewrite sr_gss; unfold Stuck; reflexivity). + simpl. eexists; split; split. + * rewrite sr_update_overwrite. unfold pmem, assign in *. simpl. rewrite H; reflexivity. + * intros. rewrite sr_update_overwrite. unfold Pregmap.set, assign. + destruct r as [dr|cr|]; try destruct dr as [ir|fr]; try destruct ir as [irr|]; + try destruct irr; try destruct fr; try destruct cr; simpl; try rewrite <- H0; eauto. + + rewrite sr_gss; reflexivity. + - (* Obc *) + replace_pc. rewrite (H0 PC). simpl. + unfold eval_branch, goto_label, control_eval. destruct Ge. + unfold goto_label_deps, cflags_eval, eval_testcond, list_exp_eval. + destruct c; simpl; unfold incrPC; + repeat (replace_ppos; replace_pc; replace_regs_pos sr; sr_val_rwrt; try rewrite !assign_diff; discriminate_ppos). + 1,2,3,4,5,6: destruct_res_flag rsr. + 7,8,9,10: do 2 (destruct_res_flag rsr). + 11,12 : do 3 (destruct_res_flag rsr). + 1,2,3,4,5,6,9,10: destruct (Int.eq _ _); [| simpl; rewrite sr_update_overwrite; replace_pc; Simpl sr ]; + destruct (label_pos _ _ _); [| reflexivity]; replace_pc; + rewrite !Pregmap.gss; destruct Val.offset_ptr; + try (unfold Stuck; reflexivity); Simpl_exists sr; intros rr; + apply reg_update_overwrite; eauto. + 1,3: destruct (andb); [| simpl; rewrite sr_update_overwrite; replace_pc; Simpl sr ]; + destruct (label_pos _ _ _); [| reflexivity]; replace_pc; rewrite !Pregmap.gss; + destruct Val.offset_ptr; try (unfold Stuck; reflexivity); Simpl_exists sr; + intros rr; apply reg_update_overwrite; eauto. + 1,2: destruct (orb); [| simpl; rewrite sr_update_overwrite; replace_pc; Simpl sr ]; + destruct (label_pos _ _ _); [| reflexivity]; replace_pc; rewrite !Pregmap.gss; + destruct Val.offset_ptr; try (unfold Stuck; reflexivity); Simpl_exists sr; + intros rr; apply reg_update_overwrite; eauto. + - (* Obl *) + replace_pc. rewrite (H0 PC). simpl. + unfold control_eval. destruct Ge. + rewrite sr_gss. Simpl sr. + replace_pc; try replace (38) with (#X30) by eauto; unfold incrPC. Simpl_update. + repeat (intros; Simpl_update). + - (* Obs *) + unfold control_eval. destruct Ge. replace_pc. rewrite (H0 PC). simpl; unfold incrPC. + replace_pc; Simpl_exists sr; intros rr; apply reg_update_overwrite; eauto. + - (* Oblr *) + replace_pc. rewrite (H0 PC). + unfold control_eval. destruct Ge. simpl. unfold incrPC. + try (eexists; split; [ | split ]); eauto. + intros rr; destruct (PregEq.eq PC rr). + + replace_pc; rewrite e; rewrite !Pregmap.gss, !sr_gss; + rewrite Pregmap.gso; fold (ppos r); try rewrite H0; auto. + rewrite <- e; destruct r; discriminate. + + replace_pc; rewrite Pregmap.gso, assign_diff; auto; apply ppos_discr in n; auto; + rewrite Pregmap.gss, sr_gss. destruct (PregEq.eq X30 rr); replace 38 with (#X30) by auto. + * rewrite e; rewrite Pregmap.gss, sr_gss; auto. + * replace_pc; rewrite !Pregmap.gso, !assign_diff; auto; apply ppos_discr in n0; auto; + apply ppos_discr; eauto. + - (* Obtbl *) + replace_pc; rewrite (H0 PC); + unfold control_eval; destruct Ge; simpl; unfold incrPC. + destruct (PregEq.eq X16 r1). + + fold (ppos r1); rewrite <- e; rewrite Pregmap.gss, sr_gss; reflexivity. + + rewrite !Pregmap.gso; auto; rewrite ppos_discr in n; + fold (ppos r1); replace 24 with (#X16) by auto; try rewrite !assign_diff; auto; + discriminate_ppos; rewrite H0; destruct (rsr r1) eqn:EQR; + try (try rewrite EQR; reflexivity). + try destruct (list_nth_z _ _); try reflexivity; + unfold goto_label, goto_label_deps; destruct (label_pos _ _ _); + try rewrite 2Pregmap.gso, Pregmap.gss; destruct (Val.offset_ptr (rsr PC) (Ptrofs.repr sz)); + try reflexivity; discriminate_ppos. Simpl sr. + destruct (PregEq.eq X16 rr); [ subst; Simpl_update |]; + destruct (PregEq.eq PC rr); [ subst; Simpl_update |]. + rewrite !Pregmap.gso; auto; + apply ppos_discr in n0; apply ppos_discr in n1; + rewrite !assign_diff; auto. +Qed. + +Theorem bisimu_exit ex sz rsr mr sr: + match_states (State rsr mr) sr -> + (*is_builtin ex = false ->*) + match_outcome (estep Ge.(_genv) Ge.(_fn) ex (Ptrofs.repr sz) rsr mr) (inst_run Ge (trans_pcincr sz (trans_exit ex)) sr sr). +Proof. + intros MS; unfold estep. + destruct ex. + - destruct c. + + exploit (bisimu_control i sz rsr mr sr); eauto. + + simpl. inv MS. eexists; split; [| split]. + unfold control_eval; destruct Ge. + replace_pc; rewrite (H0 PC); eauto. + rewrite assign_diff; auto. + intros rr. unfold incrPC. destruct (PregEq.eq rr PC); subst. + * rewrite sr_gss, Pregmap.gss. reflexivity. + * rewrite assign_diff, Pregmap.gso; try rewrite H0; + auto; try rewrite ppos_discr in n; auto. + - simpl. inv MS. eexists; split; [| split]. + + unfold control_eval; destruct Ge. + replace_pc; rewrite (H0 PC); eauto. + + rewrite assign_diff; auto. + + intros rr. unfold incrPC. destruct (PregEq.eq rr PC); subst. + * rewrite sr_gss, Pregmap.gss. reflexivity. + * rewrite assign_diff, Pregmap.gso; try rewrite H0; auto; try rewrite ppos_discr in n; auto. +Qed. + +(* Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). *) + +Theorem bisimu rsr mr sr bb: + match_states (State rsr mr) sr -> + match_outcome (bbstep Ge.(_lk) Ge.(_genv) Ge.(_fn) bb rsr mr) (exec Ge (trans_block bb) sr). +Proof. + intros MS. unfold bbstep, trans_block. + exploit (bisimu_body (body bb) rsr mr sr); eauto. + destruct (exec_body _ _ _ _ _); simpl. + - unfold match_states in *. intros (s' & X1 & X2). destruct s. + erewrite run_app_Some; eauto. + exploit (bisimu_exit (exit bb) (size bb) _rs _m s'); eauto. + destruct Ge; simpl. destruct MS as (Y1 & Y2). destruct X2 as (X2 & X3). + replace_pc. erewrite !X3; simpl. + destruct (inst_run _ _ _ _); simpl; auto. + - intros X; erewrite run_app_None; eauto. +Qed. + +Theorem trans_state_match: forall S, match_states S (trans_state S). +Proof. + intros. destruct S as (rs & m). simpl. + split. reflexivity. + intro. destruct r as [dr|cr|]; try destruct dr as [ir|fr]; try destruct cr; + try destruct ir as [irr|]; try destruct irr; try destruct fr; try reflexivity. +Qed. + +Lemma state_eq_decomp: + forall rs1 m1 rs2 m2, rs1 = rs2 -> m1 = m2 -> State rs1 m1 = State rs2 m2. +Proof. + intros. congruence. +Qed. + +Theorem state_equiv S1 S2 S': match_states S1 S' -> match_states S2 S' -> S1 = S2. +Proof. + unfold match_states; intros H0 H1. destruct S1 as (rs1 & m1). destruct S2 as (rs2 & m2). inv H0. inv H1. + apply state_eq_decomp. + - apply functional_extensionality. intros. assert (Val (rs1 x) = Val (rs2 x)) by congruence. congruence. + - congruence. +Qed. + +End SECT_SEQ. + +Section SECT_BBLOCK_EQUIV. + +Variable Ge: genv. + +Local Hint Resolve trans_state_match: core. + +Lemma bblock_simu_reduce_aux: + forall p1 p2, + L.bblock_simu Ge (trans_block p1) (trans_block p2) -> + Asmblockprops.bblock_simu_aux Ge.(_lk) Ge.(_genv) Ge.(_fn) p1 p2. +Proof. + intros p1 p2 H0 rs m EBB. + generalize (H0 (trans_state (State rs m))); clear H0. + intro H0. + exploit (bisimu Ge rs m (trans_state (State rs m)) p1); eauto. + exploit (bisimu Ge rs m (trans_state (State rs m)) p2); eauto. + destruct (bbstep Ge.(_lk) Ge.(_genv) Ge.(_fn) p1 rs m); try (unfold Stuck in EBB; congruence). + intros H1 (s2' & exp2 & MS'). unfold exec in exp2, H1. rewrite exp2 in H0. + destruct H0 as (m2' & H0 & H2). discriminate. rewrite H0 in H1. + destruct (bbstep Ge.(_lk) Ge.(_genv) Ge.(_fn) p2 rs m); simpl in H1. + * unfold match_states in H1, MS'. destruct s, s0. + destruct H1 as (s' & H1 & H3 & H4). inv H1. inv MS'. + replace (_rs0) with (_rs). + - replace (_m0) with (_m); auto. congruence. + - apply functional_extensionality. intros r. + generalize (H1 r). intros Hr. congruence. + * discriminate. +Qed. + +Lemma incrPC_set_res_commut res: forall d vres rs, + incrPC d (set_res (map_builtin_res DR res) vres rs) = + set_res (map_builtin_res DR res) vres (incrPC d rs). +Proof. + induction res; simpl; auto. + - intros; apply functional_extensionality. + unfold incrPC; intros x0. + destruct (PregEq.eq x0 PC). + + subst; rewrite! Pregmap.gss; auto. + + rewrite Pregmap.gso; auto. + destruct (PregEq.eq x x0). + * subst; rewrite! Pregmap.gss; auto. + * rewrite !Pregmap.gso; auto. + - intros; rewrite IHres2. f_equal. auto. +Qed. + +Lemma incrPC_undef_regs_commut l : forall d rs, + incrPC d (undef_regs l rs) = undef_regs l (incrPC d rs). +Proof. + induction l; simpl; auto. + intros. rewrite IHl. unfold incrPC. + destruct (PregEq.eq a PC). + - rewrite e. rewrite Pregmap.gss. + simpl. apply f_equal. unfold Pregmap.set. + apply functional_extensionality. intros x. + destruct (PregEq.eq x PC); auto. + - rewrite Pregmap.gso; auto. + apply f_equal. unfold Pregmap.set. + apply functional_extensionality. intros x. + destruct (PregEq.eq x PC). + + subst. destruct a; simpl; auto. congruence. + + auto. +Qed. + +Lemma bblock_simu_reduce: + forall p1 p2, + L.bblock_simu Ge (trans_block p1) (trans_block p2) -> + (has_builtin p1 = true \/ has_builtin p2 = true -> exit p1 = exit p2) -> + Asmblockprops.bblock_simu Ge.(_lk) Ge.(_genv) Ge.(_fn) p1 p2. +Proof. + unfold bblock_simu. intros p1 p2 H0 BLT rs m EBB. + unfold exec_bblock. + generalize (bblock_simu_reduce_aux p1 p2 H0). + unfold bblock_simu_aux. clear H0. + unfold exec_bblock, bbstep. intros H0 m' t0 (rs1 & m1 & H1 & H2). + assert ((has_builtin p1 = false /\ has_builtin p2 = false) \/ (has_builtin p1 = true \/ has_builtin p2 = true)). { repeat destruct (has_builtin _); simpl; intuition. } + destruct H as [[X1 X2]|H]. + - (* Not a builtin *) + exploit (H0); eauto; erewrite H1; simpl; (*gen*) + unfold estep; unfold has_builtin in *. + { destruct (exit p1) as [[]|] eqn: EQEX1; try discriminate; simpl in *. + inversion H2; subst. rewrite H3; discriminate. } + destruct (exit p1) as [[]|] eqn: EQEX1; try discriminate; simpl in *. + { inversion H2; subst. rewrite H3. + destruct (exec_body _ _ (body p2) _ _) as [[rs2 m2]|]; try discriminate. + intros H4. eexists; eexists; split; try reflexivity. + destruct (exit p2) as [[]|] eqn:EQEX2; simpl in *; try discriminate; try econstructor; eauto. + inversion H4. econstructor. } + { inversion H2; subst. + destruct (exec_body _ _ (body p2) _ _) as [[rs2 m2]|]; try discriminate. +intros H4. eexists; eexists; split; try reflexivity. + destruct (exit p2) as [[]|] eqn:EQEX2; simpl in *; try discriminate; try econstructor; eauto. + inversion H4. rewrite H3. econstructor. } + - (* Builtin *) + exploit (BLT); eauto. + intros EXIT. + unfold has_builtin in H. + assert (is_builtin (exit p1) = true). { rewrite <- EXIT in H; intuition. } + clear H. + generalize (H0 rs m); eauto; erewrite H1; simpl; + unfold estep. destruct (exit p1) as [[]|] eqn:EQEX1; try discriminate. + rewrite <- EXIT. + intros CONTRA. + exploit (CONTRA); try discriminate. + destruct (exec_body _ _ (body p2) _ _) as [[rs2 m2]|]; try discriminate. + intros H4. eexists; eexists; split; try reflexivity. + inversion H2; subst. inversion H4; subst. + econstructor; eauto. + + unfold incrPC in H5. + replace (rs2 SP) with (rs1 SP). + replace (fun r : dreg => rs2 r) with (fun r : dreg => rs1 r); auto. + * apply functional_extensionality. + intros r; destruct (PregEq.eq r PC); try discriminate. + replace (rs1 r) with (rs1 # PC <- (Val.offset_ptr (rs1 PC) (Ptrofs.repr (size p1))) r) by auto. + rewrite H5; rewrite Pregmap.gso; auto. + * replace (rs1 SP) with (rs1 # PC <- (Val.offset_ptr (rs1 PC) (Ptrofs.repr (size p1))) SP) by auto. + rewrite H5; rewrite Pregmap.gso; auto; try discriminate. + + rewrite !incrPC_set_res_commut. + rewrite !incrPC_undef_regs_commut. + rewrite H5. + reflexivity. +Qed. + +(** Used for debug traces *) + +Definition ireg_name (ir: ireg) : pstring := + match ir with + | X0 => Str ("X0") | X1 => Str ("X1") | X2 => Str ("X2") | X3 => Str ("X3") | X4 => Str ("X4") | X5 => Str ("X5") | X6 => Str ("X6") | X7 => Str ("X7") + | X8 => Str ("X8") | X9 => Str ("X9") | X10 => Str ("X10") | X11 => Str ("X11") | X12 => Str ("X12") | X13 => Str ("X13") | X14 => Str ("X14") | X15 => Str ("X15") + | X16 => Str ("X16") | X17 => Str ("X17") | X18 => Str ("X18") | X19 => Str ("X19") | X20 => Str ("X20") | X21 => Str ("X21") | X22 => Str ("X22") | X23 => Str ("X23") + | X24 => Str ("X24") | X25 => Str ("X25") | X26 => Str ("X26") | X27 => Str ("X27") | X28 => Str ("X28") | X29 => Str ("X29") | X30 => Str ("X30") + end +. + +Definition freg_name (fr: freg) : pstring := + match fr with + | D0 => Str ("D0") | D1 => Str ("D1") | D2 => Str ("D2") | D3 => Str ("D3") | D4 => Str ("D4") | D5 => Str ("D5") | D6 => Str ("D6") | D7 => Str ("D7") + | D8 => Str ("D8") | D9 => Str ("D9") | D10 => Str ("D10") | D11 => Str ("D11") | D12 => Str ("D12") | D13 => Str ("D13") | D14 => Str ("D14") | D15 => Str ("D15") + | D16 => Str ("D16") | D17 => Str ("D17") | D18 => Str ("D18") | D19 => Str ("D19") | D20 => Str ("D20") | D21 => Str ("D21") | D22 => Str ("D22") | D23 => Str ("D23") + | D24 => Str ("D24") | D25 => Str ("D25") | D26 => Str ("D26") | D27 => Str ("D27") | D28 => Str ("D28") | D29 => Str ("D29") | D30 => Str ("D30") | D31 => Str ("D31") + end +. + +Definition iregsp_name (irsp: iregsp) : pstring := + match irsp with + | RR1 ir => ireg_name ir + | XSP => Str ("XSP") + end. + +Definition dreg_name (dr: dreg) : ?? pstring := + match dr with + | IR ir => match ir with + | XSP => RET (Str ("XSP")) + | RR1 irr => RET (ireg_name irr) + end + | FR fr => RET (freg_name fr) + end. + +Definition string_of_name (x: P.R.t): ?? pstring := + if (Pos.eqb x pmem) then + RET (Str "MEM") + else + match inv_ppos x with + | Some (CR cr) => match cr with + | CN => RET (Str ("CN")) + | CZ => RET (Str ("CZ")) + | CC => RET (Str ("CC")) + | CV => RET (Str ("CV")) + end + | Some (PC) => RET (Str ("PC")) + | Some (DR dr) => dreg_name dr + | _ => RET (Str ("UNDEFINED")) + end. + +Definition string_of_name_ArithP (n: arith_p) : pstring := + match n with + | Padrp _ _ => "Padrp" + | Pmovz _ _ _ => "Pmov" + | Pmovn _ _ _ => "Pmov" + | Pfmovimms _ => "Pfmovimm" + | Pfmovimmd _ => "Pfmovimm" + end. + +Definition string_of_name_ArithPP (n: arith_pp) : pstring := + match n with + | Pmov => "Pmov" + | Pmovk _ _ _ => "Pmovk" + | Paddadr _ _ => "Paddadr" + | Psbfiz _ _ _ => "Psbfiz" + | Psbfx _ _ _ => "Psbfx" + | Pubfiz _ _ _ => "Pubfiz" + | Pubfx _ _ _ => "Pubfx" + | Pfmov => "Pfmov" + | Pfcvtds => "Pfcvtds" + | Pfcvtsd => "Pfcvtsd" + | Pfabs _ => "Pfabs" + | Pfneg _ => "Pfneg" + | Pscvtf _ _ => "Pscvtf" + | Pucvtf _ _ => "Pucvtf" + | Pfcvtzs _ _ => "Pfcvtzs" + | Pfcvtzu _ _ => "Pfcvtzu" + | Paddimm _ _ => "Paddimm" + | Psubimm _ _ => "Psubimm" + end. + +Definition string_of_name_ArithPPP (n: arith_ppp) : pstring := + match n with + | Pasrv _ => "Pasrv" + | Plslv _ => "Plslv" + | Plsrv _ => "Plsrv" + | Prorv _ => "Prorv" + | Psmulh => "Psmulh" + | Pumulh => "Pumulh" + | Psdiv _ => "Psdiv" + | Pudiv _ => "Pudiv" + | Paddext _ => "Paddext" + | Psubext _ => "Psubext" + | Pfadd _ => "Pfadd" + | Pfdiv _ => "Pfdiv" + | Pfmul _ => "Pfmul" + | Pfsub _ => "Pfsub" + end. + +Definition string_of_name_ArithRR0R (n: arith_rr0r) : pstring := + match n with + | Padd _ _ => "ArithRR0R=>Padd" + | Psub _ _ => "ArithRR0R=>Psub" + | Pand _ _ => "ArithRR0R=>Pand" + | Pbic _ _ => "ArithRR0R=>Pbic" + | Peon _ _ => "ArithRR0R=>Peon" + | Peor _ _ => "ArithRR0R=>Peor" + | Porr _ _ => "ArithRR0R=>Porr" + | Porn _ _ => "ArithRR0R=>Porn" + end. + +Definition string_of_name_ArithRR0R_XZR (n: arith_rr0r) : pstring := + match n with + | Padd _ _ => "ArithRR0R_XZR=>Padd" + | Psub _ _ => "ArithRR0R_XZR=>Psub" + | Pand _ _ => "ArithRR0R_XZR=>Pand" + | Pbic _ _ => "ArithRR0R_XZR=>Pbic" + | Peon _ _ => "ArithRR0R_XZR=>Peon" + | Peor _ _ => "ArithRR0R_XZR=>Peor" + | Porr _ _ => "ArithRR0R_XZR=>Porr" + | Porn _ _ => "ArithRR0R_XZR=>Porn" + end. + +Definition string_of_name_ArithRR0 (n: arith_rr0) : pstring := + match n with + | Pandimm _ _ => "ArithRR0=>Pandimm" + | Peorimm _ _ => "ArithRR0=>Peorimm" + | Porrimm _ _ => "ArithRR0=>Porrimm" + end. + +Definition string_of_name_ArithRR0_XZR (n: arith_rr0) : pstring := +match n with + | Pandimm _ _ => "ArithRR0_XZR=>Pandimm" + | Peorimm _ _ => "ArithRR0_XZR=>Peorimm" + | Porrimm _ _ => "ArithRR0_XZR=>Porrimm" + end. + +Definition string_of_name_ArithARRRR0 (n: arith_arrrr0) : pstring := + match n with + | Pmadd _ => "ArithARRRR0=>Pmadd" + | Pmsub _ => "ArithARRRR0=>Pmsub" + end. + +Definition string_of_name_ArithARRRR0_XZR (n: arith_arrrr0) : pstring := + match n with + | Pmadd _ => "ArithARRRR0_XZR=>Pmadd" + | Pmsub _ => "ArithARRRR0_XZR=>Pmsub" + end. + +Definition string_of_name_ArithComparisonPP_CN (n: arith_comparison_pp) : pstring := + match n with + | Pcmpext _ => "ArithComparisonPP_CN=>Pcmpext" + | Pcmnext _ => "ArithComparisonPP_CN=>Pcmnext" + | Pfcmp _ => "ArithComparisonPP_CN=>Pfcmp" + end. + +Definition string_of_name_ArithComparisonPP_CZ (n: arith_comparison_pp) : pstring := + match n with + | Pcmpext _ => "ArithComparisonPP_CZ=>Pcmpext" + | Pcmnext _ => "ArithComparisonPP_CZ=>Pcmnext" + | Pfcmp _ => "ArithComparisonPP_CZ=>Pfcmp" + end. + +Definition string_of_name_ArithComparisonPP_CC (n: arith_comparison_pp) : pstring := +match n with + | Pcmpext _ => "ArithComparisonPP_CC=>Pcmpext" + | Pcmnext _ => "ArithComparisonPP_CC=>Pcmnext" + | Pfcmp _ => "ArithComparisonPP_CC=>Pfcmp" + end. + +Definition string_of_name_ArithComparisonPP_CV (n: arith_comparison_pp) : pstring := +match n with + | Pcmpext _ => "ArithComparisonPP_CV=>Pcmpext" + | Pcmnext _ => "ArithComparisonPP_CV=>Pcmnext" + | Pfcmp _ => "ArithComparisonPP_CV=>Pfcmp" + end. + +Definition string_of_name_ArithComparisonR0R_CN (n: arith_comparison_r0r) : pstring := + match n with + | Pcmp _ _ => "ArithComparisonR0R_CN=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CN=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CN=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CZ (n: arith_comparison_r0r) : pstring := + match n with + | Pcmp _ _ => "ArithComparisonR0R_CZ=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CZ=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CZ=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CC (n: arith_comparison_r0r) : pstring := + match n with + | Pcmp _ _ => "ArithComparisonR0R_CC=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CC=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CC=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CV (n: arith_comparison_r0r) : pstring := + match n with + | Pcmp _ _ => "ArithComparisonR0R_CV=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CV=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CV=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CN_XZR (n: arith_comparison_r0r) : pstring := + match n with + | Pcmp _ _ => "ArithComparisonR0R_CN_XZR=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CN_XZR=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CN_XZR=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CZ_XZR (n: arith_comparison_r0r) : pstring := + match n with + | Pcmp _ _ => "ArithComparisonR0R_CZ_XZR=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CZ_XZR=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CZ_XZR=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CC_XZR (n: arith_comparison_r0r) : pstring := +match n with + | Pcmp _ _ => "ArithComparisonR0R_CC_XZR=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CC_XZR=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CC_XZR=>Ptst" + end. + +Definition string_of_name_ArithComparisonR0R_CV_XZR (n: arith_comparison_r0r) : pstring := +match n with + | Pcmp _ _ => "ArithComparisonR0R_CV_XZR=>Pcmp" + | Pcmn _ _ => "ArithComparisonR0R_CV_XZR=>Pcmn" + | Ptst _ _ => "ArithComparisonR0R_CV_XZR=>Ptst" + end. + +Definition string_of_name_ArithComparisonP_CN (n: arith_comparison_p) : pstring := + match n with + | Pfcmp0 _ => "ArithComparisonP_CN=>Pfcmp0" + | Pcmpimm _ _ => "ArithComparisonP_CN=>Pcmpimm" + | Pcmnimm _ _ => "ArithComparisonP_CN=>Pcmnimm" + | Ptstimm _ _ => "ArithComparisonP_CN=>Ptstimm" + end. + +Definition string_of_name_ArithComparisonP_CZ (n: arith_comparison_p) : pstring := + match n with + | Pfcmp0 _ => "ArithComparisonP_CZ=>Pfcmp0" + | Pcmpimm _ _ => "ArithComparisonP_CZ=>Pcmpimm" + | Pcmnimm _ _ => "ArithComparisonP_CZ=>Pcmnimm" + | Ptstimm _ _ => "ArithComparisonP_CZ=>Ptstimm" + end. + +Definition string_of_name_ArithComparisonP_CC (n: arith_comparison_p) : pstring := + match n with + | Pfcmp0 _ => "ArithComparisonP_CC=>Pfcmp0" + | Pcmpimm _ _ => "ArithComparisonP_CC=>Pcmpimm" + | Pcmnimm _ _ => "ArithComparisonP_CC=>Pcmnimm" + | Ptstimm _ _ => "ArithComparisonP_CC=>Ptstimm" + end. + +Definition string_of_name_ArithComparisonP_CV (n: arith_comparison_p) : pstring := + match n with + | Pfcmp0 _ => "ArithComparisonP_CV=>Pfcmp0" + | Pcmpimm _ _ => "ArithComparisonP_CV=>Pcmpimm" + | Pcmnimm _ _ => "ArithComparisonP_CV=>Pcmnimm" + | Ptstimm _ _ => "ArithComparisonP_CV=>Ptstimm" + end. + +Definition string_of_name_cset (c: testcond) : pstring := + match c with + | TCeq => "Cset=>TCeq" + | TCne => "Cset=>TCne" + | TChs => "Cset=>TChs" + | TClo => "Cset=>TClo" + | TCmi => "Cset=>TCmi" + | TCpl => "Cset=>TCpl" + | TChi => "Cset=>TChi" + | TCls => "Cset=>TCls" + | TCge => "Cset=>TCge" + | TClt => "Cset=>TClt" + | TCgt => "Cset=>TCgt" + | TCle => "Cset=>TCle" + end. + +Definition string_of_arith (op: arith_op): pstring := + match op with + | OArithP n => string_of_name_ArithP n + | OArithPP n => string_of_name_ArithPP n + | OArithPPP n => string_of_name_ArithPPP n + | OArithRR0R n => string_of_name_ArithRR0R n + | OArithRR0R_XZR n _ => string_of_name_ArithRR0R_XZR n + | OArithRR0 n => string_of_name_ArithRR0 n + | OArithRR0_XZR n _ => string_of_name_ArithRR0_XZR n + | OArithARRRR0 n => string_of_name_ArithARRRR0 n + | OArithARRRR0_XZR n _ => string_of_name_ArithARRRR0_XZR n + | OArithComparisonPP_CN n => string_of_name_ArithComparisonPP_CN n + | OArithComparisonPP_CZ n => string_of_name_ArithComparisonPP_CZ n + | OArithComparisonPP_CC n => string_of_name_ArithComparisonPP_CC n + | OArithComparisonPP_CV n => string_of_name_ArithComparisonPP_CV n + | OArithComparisonR0R_CN n _ => string_of_name_ArithComparisonR0R_CN n + | OArithComparisonR0R_CZ n _ => string_of_name_ArithComparisonR0R_CZ n + | OArithComparisonR0R_CC n _ => string_of_name_ArithComparisonR0R_CC n + | OArithComparisonR0R_CV n _ => string_of_name_ArithComparisonR0R_CV n + | OArithComparisonR0R_CN_XZR n _ _ => string_of_name_ArithComparisonR0R_CN_XZR n + | OArithComparisonR0R_CZ_XZR n _ _ => string_of_name_ArithComparisonR0R_CZ_XZR n + | OArithComparisonR0R_CC_XZR n _ _ => string_of_name_ArithComparisonR0R_CC_XZR n + | OArithComparisonR0R_CV_XZR n _ _ => string_of_name_ArithComparisonR0R_CV_XZR n + | OArithComparisonP_CN n => string_of_name_ArithComparisonP_CN n + | OArithComparisonP_CZ n => string_of_name_ArithComparisonP_CZ n + | OArithComparisonP_CC n => string_of_name_ArithComparisonP_CC n + | OArithComparisonP_CV n => string_of_name_ArithComparisonP_CV n + | Ocset c => string_of_name_cset c + | Ofmovi _ => "Ofmovi" + | Ofmovi_XZR _ => "Ofmovi_XZR" + | Ocsel _ => "Ocsel" + | Ofnmul _ => "Ofnmul" + end. + +Definition string_of_ofs (ofs: ptrofs) : ?? pstring := + (string_of_Z (Ptrofs.signed ofs)). + +Definition string_of_int (n: int) : ?? pstring := + (string_of_Z (Int.signed n)). + +Definition string_of_int64 (n: int64) : ?? pstring := + (string_of_Z (Int64.signed n)). + +Notation "x +; y" := (Concat x y). + +Definition string_of_addressing (a: addressing) : ?? pstring := + match a with + | ADimm base n => + DO n' <~ string_of_int64 n;; + RET ((Str "[ADimm ") +; (iregsp_name base) +; " " +; n' +; "]") + | ADreg base r => + RET ((Str "[ADreg ") +; (iregsp_name base) +; " " +; (ireg_name r) +; "]") + | ADlsl base r n => + DO n' <~ string_of_int n;; + RET ((Str "[ADlsl ") +; (iregsp_name base) +; " " +; (ireg_name r) +; " " +; n' +; "]") + | ADsxt base r n => + DO n' <~ string_of_int n;; + RET ((Str "[ADsxt ") +; (iregsp_name base) +; " " +; (ireg_name r) +; " " +; n' +; "]") + | ADuxt base r n => + DO n' <~ string_of_int n;; + RET ((Str "[ADuxt ") +; (iregsp_name base) +; " " +; (ireg_name r) +; " " +; n' +; "]") + | ADadr base id ofs => + DO id' <~ string_of_Z (Zpos id);; + DO ofs' <~ string_of_ofs ofs;; + RET ((Str "[ADadr ") +; (iregsp_name base) +; " " +; id' +; " " +; ofs' +; "]") + | ADpostincr base n => + DO n' <~ string_of_int64 n;; + RET ((Str "[ADpostincr ") +; (iregsp_name base) +; " " +; n' +; "]") + end. + +Definition string_of_ld_rd_a (ld: load_rd_a) : pstring := + match ld with + | Pldrw => Str "Pldrw" + | Pldrw_a => Str "Pldrw_a" + | Pldrx => Str "Pldrx" + | Pldrx_a => Str "Pldrx_a" + | Pldrb _ => Str "Pldrb" + | Pldrsb _ => Str "Pldrsb" + | Pldrh _ => Str "Pldrh" + | Pldrsh _ => Str "Pldrsh" + | Pldrzw => Str "Pldrzw" + | Pldrsw => Str "Pldrsw" + | Pldrs => Str "Pldrs" + | Pldrd => Str "Pldrd" + | Pldrd_a => Str "Pldrd_a" + end. + +Definition string_of_ldi (ldi: ld_instruction) : ?? pstring:= + match ldi with + | PLd_rd_a ld rd a => + DO a' <~ string_of_addressing a;; + DO rd' <~ dreg_name rd;; + RET (Str "PLd_rd_a (" +; (string_of_ld_rd_a ld) +; " " +; rd' +; " " +; a' +; ")") + | Pldp _ _ _ _ _ a => + DO a' <~ string_of_addressing a;; + RET (Str "Pldp (" +; a' +; ")") + end. + +Definition string_of_load (op: load_op) : ?? pstring := + match op with + | Oload1 ld _ a => + DO a' <~ string_of_addressing a;; + (*DO ld' <~ string_of_ldi ld;;*) + RET((Str "Oload1 ") +; " " +; string_of_ld_rd_a ld +; " " +; a' +; " ") + | Oload2 ld _ a => + DO a' <~ string_of_addressing a;; + (*DO ld' <~ string_of_ldi ld;;*) + RET((Str "Oload2 ") +; " " +; string_of_ld_rd_a ld +; " " +; a' +; " ") + | OloadU _ _ _ => RET (Str "OloadU") + end. + +Definition string_of_st_rs_a (st: store_rs_a) : pstring := + match st with + | Pstrw => Str "Pstrw" + | Pstrw_a => Str "Pstrw_a" + | Pstrx => Str "Pstrx" + | Pstrx_a => Str "Pstrx_a" + | Pstrb => Str "Pstrb" + | Pstrh => Str "Pstrh" + | Pstrs => Str "Pstrs" + | Pstrd => Str "Pstrd" + | Pstrd_a => Str "Pstrd_a" + end. + +Definition string_of_sti (sti: st_instruction) : ?? pstring:= + match sti with + | PSt_rs_a st rs a => + DO a' <~ string_of_addressing a;; + DO rs' <~ dreg_name rs;; + RET (Str "PSt_rs_a (" +; (string_of_st_rs_a st) +; " " +; rs' +; " " +; a' +; ")") + | Pstp _ _ _ _ _ a => + DO a' <~ string_of_addressing a;; + RET (Str "Pstp (" +; a' +; ")") + end. + +Definition string_of_store (op: store_op) : ?? pstring := + match op with + | Ostore1 st _ a => + DO a' <~ string_of_addressing a;; + (*DO st' <~ string_of_sti st;;*) + RET((Str "Ostore1 ") +; " " +; string_of_st_rs_a st +; " " +; a' +; " ") + | Ostore2 st _ a => + DO a' <~ string_of_addressing a;; + (*DO st' <~ string_of_sti st;;*) + RET((Str "Ostore2 ") +; " " +; string_of_st_rs_a st +; " " +; a' +; " ") + | OstoreU _ _ _ => RET (Str "OstoreU") + end. + +Definition string_of_control (op: control_op) : pstring := + match op with + | Ob _ => "Ob" + | Obc _ _ => "Obc" + | Obl _ => "Obl" + | Obs _ => "Obs" + | Ocbnz _ _ => "Ocbnz" + | Ocbz _ _ => "Ocbz" + | Otbnz _ _ _ => "Otbnz" + | Otbz _ _ _ => "Otbz" + | Obtbl _ => "Obtbl" + | OIncremPC _ => "OIncremPC" + | OError => "OError" + end. + +Definition string_of_allocf (op: allocf_op) : pstring := + match op with + | OAllocf_SP _ _ => "OAllocf_SP" + | OAllocf_Mem _ _ => "OAllocf_Mem" + end. + +Definition string_of_freef (op: freef_op) : pstring := + match op with + | OFreef_SP _ _ => "OFreef_SP" + | OFreef_Mem _ _ => "OFreef_Mem" + end. + +Definition string_of_op (op: P.op): ?? pstring := + match op with + | Arith op => RET (string_of_arith op) + | Load op => string_of_load op + | Store op => string_of_store op + | Control op => RET (string_of_control op) + | Allocframe op => RET (string_of_allocf op) + | Freeframe op => RET (string_of_freef op) + | Loadsymbol _ => RET (Str "Loadsymbol") + | Constant _ => RET (Str "Constant") + | Cvtsw2x => RET (Str "Cvtsw2x") + | Cvtuw2x => RET (Str "Cvtuw2x") + | Cvtx2w => RET (Str "Cvtx2w") + (*| Fail => RET (Str "Fail")*) + end. +End SECT_BBLOCK_EQUIV. + +(** REWRITE RULES *) + +Definition is_constant (o: op): bool := + match o with + | OArithP _ | OArithRR0_XZR _ _ | Ofmovi_XZR _ | Loadsymbol _ | Constant _ | Obl _ | Obs _ => true + | _ => false + end. + +Lemma is_constant_correct ge o: is_constant o = true -> op_eval ge o [] <> None. +Proof. + destruct o; simpl in * |- *; try congruence. + destruct op0; simpl in * |- *; try congruence. + destruct co; simpl in * |- *; try congruence; + unfold control_eval; destruct ge; simpl in * |- *; try congruence. +Qed. + +Definition main_reduce (t: Terms.term):= RET (Terms.nofail is_constant t). + +Local Hint Resolve is_constant_correct: wlp. + +Lemma main_reduce_correct t: + WHEN main_reduce t ~> pt THEN Terms.match_pt t pt. +Proof. + wlp_simplify. +Qed. + +Definition reduce := {| Terms.result := main_reduce; Terms.result_correct := main_reduce_correct |}. + +Definition bblock_simu_test (verb: bool) (p1 p2: Asmblock.bblock) : ?? bool := + assert_same_builtin p1 p2;; + if verb then + IST.verb_bblock_simu_test reduce string_of_name string_of_op (trans_block p1) (trans_block p2) + else + IST.bblock_simu_test reduce (trans_block p1) (trans_block p2). + +Local Hint Resolve IST.bblock_simu_test_correct IST.verb_bblock_simu_test_correct: wlp. + +(** Main simulation (Impure) theorem *) +Theorem bblock_simu_test_correct verb p1 p2 : + WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn lk, Asmblockprops.bblock_simu lk ge fn p1 p2. +Proof. + wlp_simplify; eapply bblock_simu_reduce with (Ge:={| _genv := ge; _fn := fn; _lk := lk |}); eauto; + intros; destruct H; auto. +Qed. + +Hint Resolve bblock_simu_test_correct: wlp. + +(** ** Coerce bblock_simu_test into a pure function (this is a little unsafe like all oracles in CompCert). *) + +Import UnsafeImpure. + +Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmblock.bblock): bool := + match unsafe_coerce (bblock_simu_test verb p1 p2) with + | Some b => b + | None => false + end. + +Theorem pure_bblock_simu_test_correct verb p1 p2 lk ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu lk ge fn p1 p2. +Proof. + unfold pure_bblock_simu_test. + destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. + intros; subst. eapply bblock_simu_test_correct; eauto. + apply unsafe_coerce_not_really_correct; eauto. +Qed. + +Definition bblock_simub: Asmblock.bblock -> Asmblock.bblock -> bool := pure_bblock_simu_test true. + +Lemma bblock_simub_correct p1 p2 lk ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu lk ge fn p1 p2. +Proof. + eapply (pure_bblock_simu_test_correct true). +Qed. diff --git a/aarch64/Asmblockgen.v b/aarch64/Asmblockgen.v new file mode 100644 index 00000000..acb5a1e6 --- /dev/null +++ b/aarch64/Asmblockgen.v @@ -0,0 +1,1252 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Léo Gourdin UGA, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Translation from Machblock to AArch64 assembly block language (Asmblock) + Inspired from the Mach->Asm pass of original Leroy's backend, but adapted to the block structure like the KVX backend. *) + +Require Import Recdef Coqlib Zwf Zbits. +Require Import Errors AST Integers Floats Op. +Require Import Locations Machblock Asm Asmblock. + +Local Open Scope string_scope. +Local Open Scope list_scope. +Local Open Scope error_monad_scope. + +(** Extracting integer or float registers. *) + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with + | IR irs => match irs with + | RR1 mr => OK mr + | _ => Error(msg "Asmgenblock.ireg_of") + end + | _ => Error(msg "Asmgenblock.iregsp_of") + end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. + +(** Recognition of immediate arguments for logical integer operations.*) + +(** Valid immediate arguments are repetitions of a bit pattern [B] + of length [e] = 2, 4, 8, 16, 32 or 64. + The bit pattern [B] must be of the form [0*1*0*] or [1*0*1*] + but must not be all zeros or all ones. *) + +(** The following automaton recognizes [0*1*0*|1*0*1*]. +<< + 0 1 0 + / \ / \ / \ + \ / \ / \ / + -0--> [B] --1--> [D] --0--> [F] + / + [A] + \ + -1--> [C] --0--> [E] --1--> [G] + / \ / \ / \ + \ / \ / \ / + 1 0 1 +>> +*) + +Module Automaton. + +Inductive state : Type := SA | SB | SC | SD | SE | SF | SG | Sbad. + +Definition start := SA. + +Definition next (s: state) (b: bool) := + match s, b with + | SA,false => SB | SA,true => SC + | SB,false => SB | SB,true => SD + | SC,false => SE | SC,true => SC + | SD,false => SF | SD,true => SD + | SE,false => SE | SE,true => SG + | SF,false => SF | SF,true => Sbad + | SG,false => Sbad | SG,true => SG + | Sbad,_ => Sbad + end. + +Definition accepting (s: state) := + match s with + | SA | SB | SC | SD | SE | SF | SG => true + | Sbad => false + end. + +Fixpoint run (len: nat) (s: state) (x: Z) : bool := + match len with + | Datatypes.O => accepting s + | Datatypes.S len => run len (next s (Z.odd x)) (Z.div2 x) + end. + +End Automaton. + +(** The following function determines the candidate length [e], + ensuring that [x] is a repetition [BB...B] + of a bit pattern [B] of length [e]. *) + +Definition logical_imm_length (x: Z) (sixtyfour: bool) : nat := + (** [test n] checks that the low [2n] bits of [x] are of the + form [BB], that is, two occurrences of the same [n] bits *) + let test (n: Z) : bool := + Z.eqb (Zzero_ext n x) (Zzero_ext n (Z.shiftr x n)) in + (** If [test n] fails, we know that the candidate length [e] is + at least [2n]. Hence we test with decreasing values of [n]: + 32, 16, 8, 4, 2. *) + if sixtyfour && negb (test 32) then 64%nat + else if negb (test 16) then 32%nat + else if negb (test 8) then 16%nat + else if negb (test 4) then 8%nat + else if negb (test 2) then 4%nat + else 2%nat. + +(** A valid logical immediate is +- neither [0] nor [-1]; +- composed of a repetition [BBBBB] of a bit-pattern [B] of length [e] +- the low [e] bits of the number, that is, [B], match [0*1*0*] or [1*0*1*]. +*) + +Definition is_logical_imm32 (x: int) : bool := + negb (Int.eq x Int.zero) && negb (Int.eq x Int.mone) && + Automaton.run (logical_imm_length (Int.unsigned x) false) + Automaton.start (Int.unsigned x). + +Definition is_logical_imm64 (x: int64) : bool := + negb (Int64.eq x Int64.zero) && negb (Int64.eq x Int64.mone) && + Automaton.run (logical_imm_length (Int64.unsigned x) true) + Automaton.start (Int64.unsigned x). + +(** Arithmetic immediates are 12-bit unsigned numbers, possibly shifted left 12 bits *) + +Definition is_arith_imm32 (x: int) : bool := + Int.eq x (Int.zero_ext 12 x) + || Int.eq x (Int.shl (Int.zero_ext 12 (Int.shru x (Int.repr 12))) (Int.repr 12)). + +Definition is_arith_imm64 (x: int64) : bool := + Int64.eq x (Int64.zero_ext 12 x) + || Int64.eq x (Int64.shl (Int64.zero_ext 12 (Int64.shru x (Int64.repr 12))) (Int64.repr 12)). + +Definition bcode := list basic. + +Program Definition single_basic (bi: basic): bblock := + {| header := nil; body:= bi::nil; exit := None |}. + +(* insert [bi] at the head of [k] *) +Program Definition insert_basic (bi: basic) (k:bblocks): bblocks := + match k with + | bb::k' => + match bb.(header) with + | nil => {| header := nil; body := bi :: (body bb); exit := exit bb |}::k' + | _ => (single_basic bi)::k + end + | _ => (single_basic bi)::k + end. + +Notation "bi ::b k" := (insert_basic bi k) (at level 49, right associativity). + +(* NB: this notation helps the Coq typechecker to infer coercion [PArith] in [bcode] expressions *) +(** Alignment check for symbols *) +Notation "i ::bi k" := (cons (A:=basic) i k) (at level 49, right associativity). +Notation "a @@ b" := (app a b) (at level 49, right associativity). + +(* The pop_bc and push_bc functions are used to adapt the output of some definitions + in bblocks format and avoid some redefinitions. *) + +(* pop_bc takes the body of the first bblock in the list if it does not have a header. *) +Definition pop_bc (k: bblocks): bcode := + match k with + | bb :: k' => match bb.(header) with + | nil => (body bb) + | _ => nil + end + | _ => nil + end. + +(* push_bc tries to overwrite code in the first bblock if it does not have a header, + otherwise, a new bblock is created and appended to the list. *) +Program Definition push_bc (bc: bcode) (k:bblocks): bblocks := + match bc with + | bi :: bc' => match k with + | bb :: k' => match bb.(header) with + | nil => {| header := nil; body := bc; exit := exit bb |} :: k' + | _ => {| header := nil; body := bc; exit := None |} :: k + end + | _ => {| header := nil; body := bc; exit := None |} :: nil + end + | nil => k + end. +Next Obligation. + simpl; auto. +Qed. +Next Obligation. + simpl; auto. +Qed. +Next Obligation. + simpl; auto. +Qed. + +Parameter symbol_is_aligned : ident -> Z -> bool. +(** [symbol_is_aligned id sz] checks whether the symbol [id] is [sz] aligned *) + +(***************************************************************************************) + +(** Decompose integer literals into 16-bit fragments *) + +Fixpoint decompose_int (N: nat) (n p: Z) {struct N} : list (Z * Z) := + match N with + | Datatypes.O => nil + | Datatypes.S N => + let frag := Zzero_ext 16 (Z.shiftr n p) in + if Z.eqb frag 0 then + decompose_int N n (p + 16) + else + (frag, p) :: decompose_int N (Z.ldiff n (Z.shiftl 65535 p)) (p + 16) + end. + +Definition negate_decomposition (l: list (Z * Z)) := + List.map (fun np => (Z.lxor (fst np) 65535, snd np)) l. + +Definition loadimm_k (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: bcode) : bcode := + List.fold_right (fun np k => Pmovk sz (fst np) (snd np) rd rd ::bi k) k l. + +Definition loadimm_z (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: bcode) : bcode := + match l with + | nil => Pmovz sz 0 0 rd ::bi k + | (n1, p1) :: l => (Pmovz sz n1 p1 rd) ::bi loadimm_k sz rd l k + end. + +Definition loadimm_n (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: bcode) : bcode := + match l with + | nil => Pmovn sz 0 0 rd ::bi k + | (n1, p1) :: l => Pmovn sz n1 p1 rd ::bi loadimm_k sz rd (negate_decomposition l) k + end. + +Definition loadimm (sz: isize) (rd: ireg) (n: Z) (k: bcode) : bcode := + let N := match sz with W => 2%nat | X => 4%nat end in + let dz := decompose_int N n 0 in + let dn := decompose_int N (Z.lnot n) 0 in + if Nat.leb (List.length dz) (List.length dn) + then loadimm_z sz rd dz k + else loadimm_n sz rd dn k. + +Definition loadimm32 (rd: ireg) (n: int) (k: bcode) : bcode := + if is_logical_imm32 n + then Porrimm W (Int.unsigned n) rd XZR ::bi k + else loadimm W rd (Int.unsigned n) k. + +Definition loadimm64 (rd: ireg) (n: int64) (k: bcode) : bcode := + if is_logical_imm64 n + then Porrimm X (Int64.unsigned n) rd XZR ::bi k + else loadimm X rd (Int64.unsigned n) k. + +Definition offset_representable (sz: Z) (ofs: int64) : bool := + let isz := Int64.repr sz in + (** either unscaled 9-bit signed *) + Int64.eq ofs (Int64.sign_ext 9 ofs) || + (** or scaled 12-bit unsigned *) + (Int64.eq (Int64.modu ofs isz) Int64.zero + && Int64.ltu ofs (Int64.shl isz (Int64.repr 12))). + +Definition indexed_memory_access_bc (insn: addressing -> basic) + (sz: Z) (base: iregsp) (ofs: ptrofs) (k: bcode) : bcode := + let ofs := Ptrofs.to_int64 ofs in + if offset_representable sz ofs + then insn (ADimm base ofs) :: k + else loadimm64 X16 ofs (insn (ADreg base X16) :: k). + +Definition loadind (base: iregsp) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := + match ty, preg_of dst with + | Tint, IR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrw rd) 4 base ofs k) + | Tlong, IR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrx rd) 8 base ofs k) + | Tsingle, FR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrs rd) 4 base ofs k) + | Tfloat, FR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrd rd) 8 base ofs k) + | Tany32, IR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrw_a rd) 4 base ofs k) + | Tany64, IR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrx_a rd) 8 base ofs k) + | Tany64, FR rd => OK (indexed_memory_access_bc (PLd_rd_a Pldrd_a rd) 8 base ofs k) + | _, _ => Error (msg "Asmgen.loadind") + end. + +Definition storeind (src: mreg) (base: iregsp) (ofs: ptrofs) (ty: typ) (k: bcode) := + match ty, preg_of src with + | Tint, IR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrw rd) 4 base ofs k) + | Tlong, IR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrx rd) 8 base ofs k) + | Tsingle, FR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrs rd) 4 base ofs k) + | Tfloat, FR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrd rd) 8 base ofs k) + | Tany32, IR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrw_a rd) 4 base ofs k) + | Tany64, IR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrx_a rd) 8 base ofs k) + | Tany64, FR rd => OK (indexed_memory_access_bc (PSt_rs_a Pstrd_a rd) 8 base ofs k) + | _, _ => Error (msg "Asmgen.storeind") + end. + +Definition loadptr_bc (base: iregsp) (ofs: ptrofs) (dst: ireg) (k: bcode): bcode := + indexed_memory_access_bc (PLd_rd_a Pldrx dst) 8 base ofs k. + +Definition storeptr_bc (src: ireg) (base: iregsp) (ofs: ptrofs) (k: bcode): bcode := + indexed_memory_access_bc (PSt_rs_a Pstrx src) 8 base ofs k. + +(** Function epilogue *) + +Definition make_epilogue (f: Machblock.function) : bcode := + loadptr_bc XSP f.(fn_retaddr_ofs) RA + (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs)::nil). + +(** Add immediate *) + +Definition addimm_aux (insn: Z -> arith_pp) + (rd r1: iregsp) (n: Z) (k: bcode) := + let nlo := Zzero_ext 12 n in + let nhi := n - nlo in + if Z.eqb nhi 0 then + insn nlo rd r1 ::bi k + else if Z.eqb nlo 0 then + insn nhi rd r1 ::bi k + else + insn nhi rd r1 ::bi insn nlo rd rd ::bi k. + +Definition addimm32 (rd r1: ireg) (n: int) (k: bcode) : bcode := + let m := Int.neg n in + if Int.eq n (Int.zero_ext 24 n) then + addimm_aux (Paddimm W) rd r1 (Int.unsigned n) k + else if Int.eq m (Int.zero_ext 24 m) then + addimm_aux (Psubimm W) rd r1 (Int.unsigned m) k + else if Int.lt n Int.zero then + loadimm32 X16 m (Psub W SOnone rd r1 X16 ::bi k) + else + loadimm32 X16 n (Padd W SOnone rd r1 X16 ::bi k). + +Definition addimm64 (rd r1: iregsp) (n: int64) (k: bcode) : bcode := + let m := Int64.neg n in + if Int64.eq n (Int64.zero_ext 24 n) then + addimm_aux (Paddimm X) rd r1 (Int64.unsigned n) k + else if Int64.eq m (Int64.zero_ext 24 m) then + addimm_aux (Psubimm X) rd r1 (Int64.unsigned m) k + else if Int64.lt n Int64.zero then + loadimm64 X16 m (Psubext (EOuxtx Int.zero) rd r1 X16 ::bi k) + else + loadimm64 X16 n (Paddext (EOuxtx Int.zero) rd r1 X16 ::bi k). + +(** Logical immediate *) + +Definition logicalimm32 + (insn1: Z -> arith_rr0) + (insn2: shift_op -> arith_rr0r) + (rd r1: ireg) (n: int) (k: bcode) : bcode := + if is_logical_imm32 n + then insn1 (Int.unsigned n) rd r1 ::bi k + else loadimm32 X16 n (insn2 SOnone rd r1 X16 ::bi k). + +Definition logicalimm64 + (insn1: Z -> arith_rr0) + (insn2: shift_op -> arith_rr0r) + (rd r1: ireg) (n: int64) (k: bcode) : bcode := + if is_logical_imm64 n + then insn1 (Int64.unsigned n) rd r1 ::bi k + else loadimm64 X16 n (insn2 SOnone rd r1 X16 ::bi k). + +(** Sign- or zero-extended arithmetic *) + +Definition transl_extension (ex: extension) (a: int) : extend_op := + match ex with Xsgn32 => EOsxtw a | Xuns32 => EOuxtw a end. + +Definition move_extended_base + (rd: ireg) (r1: ireg) (ex: extension) (k: bcode) : bcode := + match ex with + | Xsgn32 => Pcvtsw2x rd r1 ::bi k + | Xuns32 => Pcvtuw2x rd r1 ::bi k + end. + +Definition move_extended + (rd: ireg) (r1: ireg) (ex: extension) (a: int) (k: bcode) : bcode := + if Int.eq a Int.zero then + move_extended_base rd r1 ex k + else + move_extended_base rd r1 ex (Padd X (SOlsl a) rd XZR rd ::bi k). + +Definition arith_extended + (insnX: extend_op -> arith_ppp) + (insnS: shift_op -> arith_rr0r) + (rd r1 r2: ireg) (ex: extension) (a: int) (k: bcode) : bcode := + if Int.ltu a (Int.repr 5) then + insnX (transl_extension ex a) rd r1 r2 ::bi k + else + move_extended_base X16 r2 ex (insnS (SOlsl a) rd r1 X16 ::bi k). + +(** Extended right shift *) + +Definition shrx32 (rd r1: ireg) (n: int) (k: bcode) : bcode := + if Int.eq n Int.zero then + Pmov rd r1 ::bi k + else + Porr W (SOasr (Int.repr 31)) X16 XZR r1 ::bi + Padd W (SOlsr (Int.sub Int.iwordsize n)) X16 r1 X16 ::bi + Porr W (SOasr n) rd XZR X16 ::bi k. + +Definition shrx64 (rd r1: ireg) (n: int) (k: bcode) : bcode := + if Int.eq n Int.zero then + Pmov rd r1 ::bi k + else + Porr X (SOasr (Int.repr 63)) X16 XZR r1 ::bi + Padd X (SOlsr (Int.sub Int64.iwordsize' n)) X16 r1 X16 ::bi + Porr X (SOasr n) rd XZR X16 ::bi k. + +(** Load the address [id + ofs] in [rd] *) + +Definition loadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (k: bcode) : bcode := + if Archi.pic_code tt then + if Ptrofs.eq ofs Ptrofs.zero then + Ploadsymbol rd id ::bi k + else + Ploadsymbol rd id :: addimm64 rd rd (Ptrofs.to_int64 ofs) k + else + Padrp id ofs rd ::bi Paddadr id ofs rd rd ::bi k. + +(** Translate a shifted operand *) + +Definition transl_shift (s: Op.shift) (a: int): Asm.shift_op := + match s with + | Slsl => SOlsl a + | Slsr => SOlsr a + | Sasr => SOasr a + | Sror => SOror a + end. + +(** Translation of a condition. Prepends to [k] the instructions + that evaluate the condition and leave its boolean result in one of + the bits of the condition register. The bit in question is + determined by the [crbit_for_cond] function. *) + +Definition transl_cond + (cond: condition) (args: list mreg) (k: bcode) := + match cond, args with + | (Ccomp c | Ccompu c), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp W SOnone r1 r2 ::bi k) + | (Ccompshift c s a | Ccompushift c s a), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp W (transl_shift s a) r1 r2 ::bi k) + | (Ccompimm c n | Ccompuimm c n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_arith_imm32 n then + Pcmpimm W (Int.unsigned n) r1 ::bi k + else if is_arith_imm32 (Int.neg n) then + Pcmnimm W (Int.unsigned (Int.neg n)) r1 ::bi k + else + loadimm32 X16 n (Pcmp W SOnone r1 X16 ::bi k)) + | (Cmaskzero n | Cmasknotzero n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_logical_imm32 n then + Ptstimm W (Int.unsigned n) r1 ::bi k + else + loadimm32 X16 n (Ptst W SOnone r1 X16 ::bi k)) + | (Ccompl c | Ccomplu c), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp X SOnone r1 r2 ::bi k) + | (Ccomplshift c s a | Ccomplushift c s a), a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pcmp X (transl_shift s a) r1 r2 ::bi k) + | (Ccomplimm c n | Ccompluimm c n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_arith_imm64 n then + Pcmpimm X (Int64.unsigned n) r1 ::bi k + else if is_arith_imm64 (Int64.neg n) then + Pcmnimm X (Int64.unsigned (Int64.neg n)) r1 ::bi k + else + loadimm64 X16 n (Pcmp X SOnone r1 X16 ::bi k)) + | (Cmasklzero n | Cmasklnotzero n), a1 :: nil => + do r1 <- ireg_of a1; + OK (if is_logical_imm64 n then + Ptstimm X (Int64.unsigned n) r1 ::bi k + else + loadimm64 X16 n (Ptst X SOnone r1 X16 ::bi k)) + | Ccompf cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp D r1 r2 ::bi k) + | Cnotcompf cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp D r1 r2 ::bi k) + | Ccompfzero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 D r1 ::bi k) + | Cnotcompfzero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 D r1 ::bi k) + | Ccompfs cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp S r1 r2 ::bi k) + | Cnotcompfs cmp, a1 :: a2 :: nil => + do r1 <- freg_of a1; do r2 <- freg_of a2; + OK (Pfcmp S r1 r2 ::bi k) + | Ccompfszero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 S r1 ::bi k) + | Cnotcompfszero cmp, a1 :: nil => + do r1 <- freg_of a1; + OK (Pfcmp0 S r1 ::bi k) + | _, _ => + Error(msg "Asmgenblock.transl_cond") + end. + +Definition cond_for_signed_cmp (cmp: comparison) := + match cmp with + | Ceq => TCeq + | Cne => TCne + | Clt => TClt + | Cle => TCle + | Cgt => TCgt + | Cge => TCge + end. + +Definition cond_for_unsigned_cmp (cmp: comparison) := + match cmp with + | Ceq => TCeq + | Cne => TCne + | Clt => TClo + | Cle => TCls + | Cgt => TChi + | Cge => TChs + end. + +Definition cond_for_float_cmp (cmp: comparison) := + match cmp with + | Ceq => TCeq + | Cne => TCne + | Clt => TCmi + | Cle => TCls + | Cgt => TCgt + | Cge => TCge + end. + +Definition cond_for_float_not_cmp (cmp: comparison) := + match cmp with + | Ceq => TCne + | Cne => TCeq + | Clt => TCpl + | Cle => TChi + | Cgt => TCle + | Cge => TClt + end. + +Definition cond_for_cond (cond: condition) := + match cond with + | Ccomp cmp => cond_for_signed_cmp cmp + | Ccompu cmp => cond_for_unsigned_cmp cmp + | Ccompshift cmp s a => cond_for_signed_cmp cmp + | Ccompushift cmp s a => cond_for_unsigned_cmp cmp + | Ccompimm cmp n => cond_for_signed_cmp cmp + | Ccompuimm cmp n => cond_for_unsigned_cmp cmp + | Cmaskzero n => TCeq + | Cmasknotzero n => TCne + | Ccompl cmp => cond_for_signed_cmp cmp + | Ccomplu cmp => cond_for_unsigned_cmp cmp + | Ccomplshift cmp s a => cond_for_signed_cmp cmp + | Ccomplushift cmp s a => cond_for_unsigned_cmp cmp + | Ccomplimm cmp n => cond_for_signed_cmp cmp + | Ccompluimm cmp n => cond_for_unsigned_cmp cmp + | Cmasklzero n => TCeq + | Cmasklnotzero n => TCne + | Ccompf cmp => cond_for_float_cmp cmp + | Cnotcompf cmp => cond_for_float_not_cmp cmp + | Ccompfzero cmp => cond_for_float_cmp cmp + | Cnotcompfzero cmp => cond_for_float_not_cmp cmp + | Ccompfs cmp => cond_for_float_cmp cmp + | Cnotcompfs cmp => cond_for_float_not_cmp cmp + | Ccompfszero cmp => cond_for_float_cmp cmp + | Cnotcompfszero cmp => cond_for_float_not_cmp cmp + end. + +(** Translation of a conditional branch. Prepends to [k] the instructions + that evaluate the condition and ranch to [lbl] if it holds. + We recognize some conditional branches that can be implemented + without setting then testing condition flags. *) + +Definition transl_cond_branch_default + (c: condition) (args: list mreg) (lbl: label) (k: bcode) : res (bcode*cf_instruction) := + do ccode <- transl_cond c args k; + OK(ccode, Pbc (cond_for_cond c) lbl). + +Definition transl_cond_branch + (c: condition) (args: list mreg) (lbl: label) (k: bcode) : res (bcode*cf_instruction) := + match args, c with + | a1 :: nil, (Ccompimm Cne n | Ccompuimm Cne n) => + if Int.eq n Int.zero + then (do r1 <- ireg_of a1; OK (k, Pcbnz W r1 lbl)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, (Ccompimm Ceq n | Ccompuimm Ceq n) => + if Int.eq n Int.zero + then (do r1 <- ireg_of a1; OK (k, Pcbz W r1 lbl)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, (Ccomplimm Cne n | Ccompluimm Cne n) => + if Int64.eq n Int64.zero + then (do r1 <- ireg_of a1; OK (k, Pcbnz X r1 lbl)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, (Ccomplimm Ceq n | Ccompluimm Ceq n) => + if Int64.eq n Int64.zero + then (do r1 <- ireg_of a1; OK (k, Pcbz X r1 lbl)) + else transl_cond_branch_default c args lbl k + | a1 :: nil, Cmaskzero n => + match Int.is_power2 n with + | Some bit => do r1 <- ireg_of a1; OK (k, Ptbz W r1 bit lbl) + | None => transl_cond_branch_default c args lbl k + end + | a1 :: nil, Cmasknotzero n => + match Int.is_power2 n with + | Some bit => do r1 <- ireg_of a1; OK (k, Ptbnz W r1 bit lbl) + | None => transl_cond_branch_default c args lbl k + end + | a1 :: nil, Cmasklzero n => + match Int64.is_power2' n with + | Some bit => do r1 <- ireg_of a1; OK (k, Ptbz X r1 bit lbl) + | None => transl_cond_branch_default c args lbl k + end + | a1 :: nil, Cmasklnotzero n => + match Int64.is_power2' n with + | Some bit => do r1 <- ireg_of a1; OK (k, Ptbnz X r1 bit lbl) + | None => transl_cond_branch_default c args lbl k + end + | _, _ => + transl_cond_branch_default c args lbl k + end. + +(** Translation of the arithmetic operation [r <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (res: mreg) (k: bcode) := + match op, args with + | Omove, a1 :: nil => + match preg_of res, preg_of a1 with + | IR r, IR a => OK (Pmov r a ::bi k) + | FR r, FR a => OK (Pfmov r a ::bi k) + | _ , _ => Error(msg "Asmgenblock.Omove") + end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n k) + | Ofloatconst f, nil => + do rd <- freg_of res; + OK (if Float.eq_dec f Float.zero + then Pfmovi D rd XZR ::bi k + else Pfmovimmd f rd ::bi k) + | Osingleconst f, nil => + do rd <- freg_of res; + OK (if Float32.eq_dec f Float32.zero + then Pfmovi S rd XZR ::bi k + else Pfmovimms f rd ::bi k) + | Oaddrsymbol id ofs, nil => + do rd <- ireg_of res; + OK (loadsymbol rd id ofs k) + | Oaddrstack ofs, nil => + do rd <- ireg_of res; + OK (addimm64 rd XSP (Ptrofs.to_int64 ofs) k) + (** 32-bit integer arithmetic *) + | Oshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porr W (transl_shift s a) rd XZR r1 ::bi k) + | Oadd, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd W SOnone rd r1 r2 ::bi k) + | Oaddshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd W (transl_shift s a) rd r1 r2 ::bi k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm32 rd rs n k) + | Oneg, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub W SOnone rd XZR r1 ::bi k) + | Onegshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub W (transl_shift s a) rd XZR r1 ::bi k) + | Osub, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub W SOnone rd r1 r2 ::bi k) + | Osubshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub W (transl_shift s a) rd r1 r2 ::bi k) + | Omul, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmadd W rd rs1 rs2 XZR ::bi k) + | Omuladd, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmadd W rd r2 r3 r1 ::bi k) + | Omulsub, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmsub W rd r2 r3 r1 ::bi k) + | Odiv, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psdiv W rd r1 r2 ::bi k) + | Odivu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pudiv W rd r1 r2 ::bi k) + | Oand, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand W SOnone rd r1 r2 ::bi k) + | Oandshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand W (transl_shift s a) rd r1 r2 ::bi k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm32 (Pandimm W) (Pand W) rd r1 n k) + | Oor, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr W SOnone rd r1 r2 ::bi k) + | Oorshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr W (transl_shift s a) rd r1 r2 ::bi k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm32 (Porrimm W) (Porr W) rd r1 n k) + | Oxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor W SOnone rd r1 r2 ::bi k) + | Oxorshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor W (transl_shift s a) rd r1 r2 ::bi k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm32 (Peorimm W) (Peor W) rd r1 n k) + | Onot, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn W SOnone rd XZR r1 ::bi k) + | Onotshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn W (transl_shift s a) rd XZR r1 ::bi k) + | Obic, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic W SOnone rd r1 r2 ::bi k) + | Obicshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic W (transl_shift s a) rd r1 r2 ::bi k) + | Oorn, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn W SOnone rd r1 r2 ::bi k) + | Oornshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn W (transl_shift s a) rd r1 r2 ::bi k) + | Oeqv, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon W SOnone rd r1 r2 ::bi k) + | Oeqvshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon W (transl_shift s a) rd r1 r2 ::bi k) + | Oshl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plslv W rd r1 r2 ::bi k) + | Oshr, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pasrv W rd r1 r2 ::bi k) + | Oshru, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plsrv W rd r1 r2 ::bi k) + | Oshrximm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (shrx32 rd r1 n k) + | Ozext s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz W Int.zero s rd r1 ::bi k) + | Osext s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz W Int.zero s rd r1 ::bi k) + | Oshlzext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz W a (Z.min s (Int.zwordsize - Int.unsigned a)) rd r1 ::bi k) + | Oshlsext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz W a (Z.min s (Int.zwordsize - Int.unsigned a)) rd r1 ::bi k) + | Ozextshr a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfx W a (Z.min s (Int.zwordsize - Int.unsigned a)) rd r1 ::bi k) + | Osextshr a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfx W a (Z.min s (Int.zwordsize - Int.unsigned a)) rd r1 ::bi k) + (** 64-bit integer arithmetic *) + | Oshiftl s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porr X (transl_shift s a) rd XZR r1 ::bi k) + | Oextend x a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (move_extended rd r1 x a k) + (* [Omakelong] and [Ohighlong] should not occur *) + | Olowlong, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + assertion (ireg_eq rd r1); + OK (Pcvtx2w rd ::bi k) + | Oaddl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd X SOnone rd r1 r2 ::bi k) + | Oaddlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Padd X (transl_shift s a) rd r1 r2 ::bi k) + | Oaddlext x a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (arith_extended Paddext (Padd X) rd r1 r2 x a k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (addimm64 rd r1 n k) + | Onegl, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub X SOnone rd XZR r1 ::bi k) + | Oneglshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psub X (transl_shift s a) rd XZR r1 ::bi k) + | Osubl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub X SOnone rd r1 r2 ::bi k) + | Osublshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psub X (transl_shift s a) rd r1 r2 ::bi k) + | Osublext x a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (arith_extended Psubext (Psub X) rd r1 r2 x a k) + | Omull, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pmadd X rd r1 r2 XZR ::bi k) + | Omulladd, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmadd X rd r2 r3 r1 ::bi k) + | Omullsub, a1 :: a2 :: a3 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; + OK (Pmsub X rd r2 r3 r1 ::bi k) + | Omullhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psmulh rd r1 r2 ::bi k) + | Omullhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pumulh rd r1 r2 ::bi k) + | Odivl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Psdiv X rd r1 r2 ::bi k) + | Odivlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pudiv X rd r1 r2 ::bi k) + | Oandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand X SOnone rd r1 r2 ::bi k) + | Oandlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pand X (transl_shift s a) rd r1 r2 ::bi k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm64 (Pandimm X) (Pand X) rd r1 n k) + | Oorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr X SOnone rd r1 r2 ::bi k) + | Oorlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porr X (transl_shift s a) rd r1 r2 ::bi k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm64 (Porrimm X) (Porr X) rd r1 n k) + | Oxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor X SOnone rd r1 r2 ::bi k) + | Oxorlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peor X (transl_shift s a) rd r1 r2 ::bi k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (logicalimm64 (Peorimm X) (Peor X) rd r1 n k) + | Onotl, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn X SOnone rd XZR r1 ::bi k) + | Onotlshift s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Porn X (transl_shift s a) rd XZR r1 ::bi k) + | Obicl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic X SOnone rd r1 r2 ::bi k) + | Obiclshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pbic X (transl_shift s a) rd r1 r2 ::bi k) + | Oornl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn X SOnone rd r1 r2 ::bi k) + | Oornlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Porn X (transl_shift s a) rd r1 r2 ::bi k) + | Oeqvl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon X SOnone rd r1 r2 ::bi k) + | Oeqvlshift s a, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Peon X (transl_shift s a) rd r1 r2 ::bi k) + | Oshll, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plslv X rd r1 r2 ::bi k) + | Oshrl, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Pasrv X rd r1 r2 ::bi k) + | Oshrlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (Plsrv X rd r1 r2 ::bi k) + | Oshrlximm n, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (shrx64 rd r1 n k) + | Ozextl s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz X Int.zero s rd r1 ::bi k) + | Osextl s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz X Int.zero s rd r1 ::bi k) + | Oshllzext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfiz X a (Z.min s (Int64.zwordsize - Int.unsigned a)) rd r1 ::bi k) + | Oshllsext s a, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfiz X a (Z.min s (Int64.zwordsize - Int.unsigned a)) rd r1 ::bi k) + | Ozextshrl a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Pubfx X a (Z.min s (Int64.zwordsize - Int.unsigned a)) rd r1 ::bi k) + | Osextshrl a s, a1 :: nil => + do rd <- ireg_of res; do r1 <- ireg_of a1; + OK (Psbfx X a (Z.min s (Int64.zwordsize - Int.unsigned a)) rd r1 ::bi k) + (** 64-bit floating-point arithmetic *) + | Onegf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfneg D rd rs ::bi k) + | Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabs D rd rs ::bi k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadd D rd rs1 rs2 ::bi k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsub D rd rs1 rs2 ::bi k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmul D rd rs1 rs2 ::bi k) + | Odivf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdiv D rd rs1 rs2 ::bi k) + (** 32-bit floating-point arithmetic *) + | Onegfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfneg S rd rs ::bi k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabs S rd rs ::bi k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadd S rd rs1 rs2 ::bi k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsub S rd rs1 rs2 ::bi k) + | Omulfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmul S rd rs1 rs2 ::bi k) + | Odivfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdiv S rd rs1 rs2 ::bi k) + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtsd rd rs ::bi k) + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtds rd rs ::bi k) + (** Conversions between int and float *) + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs W D rd rs ::bi k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu W D rd rs ::bi k) + | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf D W rd rs ::bi k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf D W rd rs ::bi k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs W S rd rs ::bi k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu W S rd rs ::bi k) + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf S W rd rs ::bi k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf S W rd rs ::bi k) + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs X D rd rs ::bi k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu X D rd rs ::bi k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf D X rd rs ::bi k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf D X rd rs ::bi k) + | Olongofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzs X S rd rs ::bi k) + | Olonguofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtzu X S rd rs ::bi k) + | Osingleoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pscvtf S X rd rs ::bi k) + | Osingleoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pucvtf S X rd rs ::bi k) + (** Boolean tests *) + | Ocmp c, _ => + do rd <- ireg_of res; + transl_cond c args (Pcset rd (cond_for_cond c) ::bi k) + (** Conditional move *) + | Osel cmp ty, a1 :: a2 :: args => + match preg_of res with + | IR r => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + transl_cond cmp args (Pcsel r r1 r2 (cond_for_cond cmp) ::bi k) + | FR r => + do r1 <- freg_of a1; do r2 <- freg_of a2; + transl_cond cmp args (Pcsel r r1 r2 (cond_for_cond cmp) ::bi k) + | _ => + Error(msg "Asmgenblock.Osel") + end + | _, _ => Error(msg "Asmgenblock.transl_op") + end. + +(** Translation of addressing modes *) + +Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg) + (insn: Asm.addressing -> basic) (k: bcode) : res bcode := + match addr, args with + | Aindexed ofs, a1 :: nil => + do r1 <- ireg_of a1; + if offset_representable sz ofs then + OK (insn (ADimm r1 ofs) ::bi k) + else + OK (loadimm64 X16 ofs (insn (ADreg r1 X16) ::bi k)) + | Aindexed2, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (insn (ADreg r1 r2) ::bi k) + | Aindexed2shift a, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + if Int.eq a Int.zero then + OK (insn (ADreg r1 r2) ::bi k) + else if Int.eq (Int.shl Int.one a) (Int.repr sz) then + OK (insn (ADlsl r1 r2 a) ::bi k) + else + OK (Padd X (SOlsl a) X16 r1 r2 ::bi insn (ADimm X16 Int64.zero) ::bi k) + | Aindexed2ext x a, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + if Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz) then + OK (insn (match x with Xsgn32 => ADsxt r1 r2 a + | Xuns32 => ADuxt r1 r2 a end) ::bi k) + else + OK (arith_extended Paddext (Padd X) X16 r1 r2 x a + (insn (ADimm X16 Int64.zero) ::bi k)) + | Aglobal id ofs, nil => + assertion (negb (Archi.pic_code tt)); + if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz + then OK (Padrp id ofs X16 ::bi insn (ADadr X16 id ofs) ::bi k) + else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) ::bi k)) + | Ainstack ofs, nil => + let ofs := Ptrofs.to_int64 ofs in + if offset_representable sz ofs then + OK (insn (ADimm XSP ofs) ::bi k) + else + OK (loadimm64 X16 ofs (insn (ADreg XSP X16) ::bi k)) + | _, _ => + Error(msg "Asmgen.transl_addressing") + end. + +(** Translation of loads and stores *) + +Definition transl_load (chunk: memory_chunk) (addr: Op.addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + match chunk with + | Mint8unsigned => + do rd <- ireg_of dst; transl_addressing 1 addr args (PLd_rd_a (Pldrb W) rd) k + | Mint8signed => + do rd <- ireg_of dst; transl_addressing 1 addr args (PLd_rd_a (Pldrsb W) rd) k + | Mint16unsigned => + do rd <- ireg_of dst; transl_addressing 2 addr args (PLd_rd_a (Pldrh W) rd) k + | Mint16signed => + do rd <- ireg_of dst; transl_addressing 2 addr args (PLd_rd_a (Pldrsh W) rd) k + | Mint32 => + do rd <- ireg_of dst; transl_addressing 4 addr args (PLd_rd_a Pldrw rd) k + | Mint64 => + do rd <- ireg_of dst; transl_addressing 8 addr args (PLd_rd_a Pldrx rd) k + | Mfloat32 => + do rd <- freg_of dst; transl_addressing 4 addr args (PLd_rd_a Pldrs rd) k + | Mfloat64 => + do rd <- freg_of dst; transl_addressing 8 addr args (PLd_rd_a Pldrd rd) k + | Many32 => + do rd <- ireg_of dst; transl_addressing 4 addr args (PLd_rd_a Pldrw_a rd) k + | Many64 => + do rd <- ireg_of dst; transl_addressing 8 addr args (PLd_rd_a Pldrx_a rd) k + end. + +Definition transl_store (chunk: memory_chunk) (addr: Op.addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + match chunk with + | Mint8unsigned | Mint8signed => + do r1 <- ireg_of src; transl_addressing 1 addr args (PSt_rs_a Pstrb r1) k + | Mint16unsigned | Mint16signed => + do r1 <- ireg_of src; transl_addressing 2 addr args (PSt_rs_a Pstrh r1) k + | Mint32 => + do r1 <- ireg_of src; transl_addressing 4 addr args (PSt_rs_a Pstrw r1) k + | Mint64 => + do r1 <- ireg_of src; transl_addressing 8 addr args (PSt_rs_a Pstrx r1) k + | Mfloat32 => + do r1 <- freg_of src; transl_addressing 4 addr args (PSt_rs_a Pstrs r1) k + | Mfloat64 => + do r1 <- freg_of src; transl_addressing 8 addr args (PSt_rs_a Pstrd r1) k + | Many32 => + do r1 <- ireg_of src; transl_addressing 4 addr args (PSt_rs_a Pstrw_a r1) k + | Many64 => + do r1 <- ireg_of src; transl_addressing 8 addr args (PSt_rs_a Pstrx_a r1) k + end. + +(** Translation of a Machblock instruction. *) + +Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) + (ep: bool) (k: bcode) := + match i with + | MBgetstack ofs ty dst => + loadind XSP ofs ty dst k + | MBsetstack src ofs ty => + storeind src XSP ofs ty k + | MBgetparam ofs ty dst => + do c <- loadind X29 ofs ty dst k; + OK (if ep then c else loadptr_bc XSP f.(fn_link_ofs) X29 c) + | MBop op args res => + transl_op op args res k + | MBload t chunk addr args dst => + match t with + | TRAP => transl_load chunk addr args dst k + | NOTRAP => Error(msg "Asmgenblock.transl_instr_basic: NOTRAP load not supported in aarch64.") + end + | MBstore chunk addr args src => + transl_store chunk addr args src k + end. + +(** Translation of a code sequence *) + +Definition it1_is_parent (before: bool) (i: Machblock.basic_inst) : bool := + match i with + (*| MBgetstack ofs ty dst => before && negb (mreg_eq dst R29)*) + | MBsetstack src ofs ty => before + | MBgetparam ofs ty dst => negb (mreg_eq dst R29) + | MBop op args res => before && negb (mreg_eq res R29) + (*| MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst R29)*) + | _ => false + end. + +Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + match il with + | nil => OK (nil) + | i1 :: il' => + do k1 <- transl_basic_code f il' (it1_is_parent it1p i1); + transl_instr_basic f i1 it1p k1 + end. + +Program Definition cons_bblocks (ll: list label) (bdy: list basic) (ex: option control): bblocks := + match ex with + | None => + match bdy with + | nil => {| header := ll; body:= Pnop::nil; exit := None |} :: nil + | _ => {| header := ll; body:= bdy; exit := None |} :: nil + end + | _ => + match bdy with + | nil => {| header := ll; body:= nil; exit := ex |} :: nil + | _ => {| header := ll; body:= bdy; exit := ex |} :: nil + end + end. +Next Obligation. + induction bdy. congruence. + simpl. auto. +Qed. +Next Obligation. + destruct ex. simpl. auto. + congruence. +Qed. +Next Obligation. + induction bdy. congruence. + simpl. auto. +Qed. + +Definition transl_control (f: Machblock.function) (ctl: control_flow_inst) : res (bcode*control) := + match ctl with + | MBcall sig (inl r) => do r1 <- ireg_of r; + OK (nil, PCtlFlow (Pblr r1 sig)) + | MBcall sig (inr symb) => OK (nil, PCtlFlow (Pbl symb sig)) + | MBtailcall sig (inr symb) => OK(make_epilogue f, PCtlFlow (Pbs symb sig)) + | MBtailcall sig (inl r) => do r1 <- ireg_of r; + OK (make_epilogue f, PCtlFlow (Pbr r1 sig)) + | MBbuiltin ef args res => OK (nil, Pbuiltin ef (List.map (map_builtin_arg dreg_of) args) (map_builtin_res dreg_of res)) + | MBgoto lbl => OK (nil, PCtlFlow (Pb lbl)) + | MBcond cond args lbl => do (bc, c) <- transl_cond_branch cond args lbl nil; OK (bc, PCtlFlow c) + | MBreturn => OK (make_epilogue f, PCtlFlow (Pret RA)) + | MBjumptable arg tbl => do r <- ireg_of arg; + OK (nil, PCtlFlow (Pbtbl r tbl)) + end. + +Definition transl_exit (f: Machblock.function) (ext: option control_flow_inst) : res (bcode*option control) := + match ext with + Some ctl => do (b,c) <- transl_control f ctl; OK (b, Some c) + | None => OK (nil, None) + end. + +Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := + do (bdy2, ex) <- transl_exit f fb.(Machblock.exit); + do bdy1 <- transl_basic_code f fb.(Machblock.body) ep; + OK (cons_bblocks fb.(Machblock.header) (bdy1 @@ bdy2) ex) + . + +Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := + match lmb with + | nil => OK nil + | mb :: lmb => + do lb <- transl_block f mb (if Machblock.header mb then ep else false); + do lb' <- transl_blocks f lmb false; + OK (lb @@ lb') + end +. + +Program Definition make_prologue (f: Machblock.function) (k:bblocks) := + {| header := nil; body := Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::bi + ((PSt_rs_a Pstrx RA) (ADimm XSP (Ptrofs.to_int64 (f.(fn_retaddr_ofs))))) ::bi nil; + exit := None |} :: k. + +Definition transl_function (f: Machblock.function) : res Asmblock.function := + do lb <- transl_blocks f f.(Machblock.fn_code) true; + OK (mkfunction f.(Machblock.fn_sig) + (make_prologue f lb)). + +Definition transf_function (f: Machblock.function) : res Asmblock.function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Machblock.program) : res Asmblock.program := + transform_partial_program transf_fundef p. + diff --git a/aarch64/Asmblockgenproof.v b/aarch64/Asmblockgenproof.v new file mode 100644 index 00000000..6f7d39fa --- /dev/null +++ b/aarch64/Asmblockgenproof.v @@ -0,0 +1,1546 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock IterList. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. + +Module MB := Machblock. +Module AB := Asmblock. + +Definition match_prog (p: MB.program) (tp: AB.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable lk: aarch64_linker. +Variable prog: Machblock.program. +Variable tprog: Asmblock.program. +Hypothesis TRANSF: match_prog prog tprog. +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 (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + +Hypothesis symbol_high_low: forall (id: ident) (ofs: ptrofs), + Val.addl (symbol_high lk id ofs) (symbol_low lk id ofs) = Genv.symbol_address tge id ofs. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using a complex simulation diagram + of the following form. +<< + MB.step + ----------------------------------------> + header body exit + st1 -----> st2 -----> st3 ------------------> st4 + | | | | + | (A) | (B) | (C) | + match_codestate | | | | + | header | body1 | body2 | match_states + cs1 -----> cs2 -----> cs3 ------> cs4 | + | / \ exit | + match_asmstate | --------------- --->--- | + | / match_asmstate \ | + st'1 ---------------------------------------> st'2 + AB.step * +>> + The invariant between each MB.step/AB.step is the [match_states] predicate below. + However, we also need to introduce an intermediary state [Codestate] which allows + us to reason on a finer grain, executing header, body and exit separately. + + This [Codestate] consists in a state like [Asmblock.State], except that the + code is directly stored in the state, much like [Machblock.State]. It also features + additional useful elements to keep track of while executing a bblock. +*) + +Inductive match_states: Machblock.state -> Asm.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#X29 = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asm.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asm.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asm.State rs m'). + +Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) + +Lemma cons_bblocks_label: + forall hd bdy ex tbb tc, + cons_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros CONSB. unfold cons_bblocks in CONSB. + destruct ex; try destruct bdy; try destruct c; try destruct i. + all: inv CONSB; simpl; auto. +Qed. + +Lemma cons_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + cons_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros CONSB. unfold cons_bblocks in CONSB. + destruct ex; try destruct bdy; try destruct c; try destruct i. + all: inv CONSB; simpl; auto. +Qed. + +Remark in_dec_transl: + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply cons_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply cons_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold cons_bblocks. + destruct x0; try destruct (x1 @@ x); try destruct c0; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold cons_bblocks in H0. + destruct x0; try destruct (x1 @@ x); try destruct c0; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + +Theorem transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Machblock code translates to a valid ``go to'' + transition in the generated Asmblock code. *) + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. + exists x; exists true; split; auto. + repeat constructor. +- exact transf_function_no_overflow. +Qed. + +(* Useful for dealing with the many cases in some proofs *) +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + +(** Some translation properties *) + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. + intros until ep. intros TLBS. + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + unfold transl_block. + rewrite EQ0; simpl. + simpl in EQ; rewrite EQ; simpl. + unfold cons_bblocks in *. simpl in EQ0. + destruct ex. + - simpl in *. monadInv EQ0. + destruct (x3 @@ x1) eqn: CBDY; inv H0; inv EQ1; auto. + - simpl in *. inv EQ0. destruct (x3 @@ nil) eqn: CBDY; inv H0; inv EQ1; auto. +Qed. + +Lemma cons_bblocks_decomp: + forall thd tbdy tex tbb, + (tbdy <> nil \/ tex <> None) -> + cons_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy + /\ exit tbb = tex. +Proof. + intros until tbb. intros Hnonil CONSB. unfold cons_bblocks in CONSB. + destruct (tex) eqn:ECTL. + - destruct tbdy; inv CONSB; simpl; auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; [ contradiction H; auto | inv CONSB; auto]. + + contradict H; simpl; auto. +Qed. + +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. + intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold cons_bblocks. + destruct (x2); + destruct (x3 @@ x1); simpl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + +Record codestate := + Codestate { pstate: state; (**r projection to Asmblock.state *) + pheader: list label; + pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) + pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) + pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) + ep: bool; (**r reflects the [ep] variable used in the translation *) + rem: list AB.bblock; (**r remaining bblocks to execute *) + cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *) + }. + +(* The part that deals with Machblock <-> Codestate agreement + * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc1 tbc2 ex + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc1) + (TIC: transl_exit f (MB.exit bb) = OK (tbc2, ex)) + (TBLS: transl_blocks f c false = OK tc) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#X29 = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asm.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc1; + pbody2 := tbc2; + pctl := ex; + ep := ep; + rem := tc; + cur := tbb + |} +. + +(* The part ensuring that the code in Codestate actually resides at [rs PC] *) +Inductive match_asmstate fb: codestate -> Asm.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy1 tbdy2 tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) + , + match_asmstate fb + {| pstate := (Asm.State rs m); + pheader := lhd; + pbody1 := tbdy1; + pbody2 := tbdy2; + pctl := tex; + ep := ep; + rem := tc; + cur := tbb |} + (Asm.State rs m) +. + +Lemma indexed_memory_access_nonil: forall f ofs r i k, + indexed_memory_access_bc f ofs r i k <> nil. +Proof. + intros. + unfold indexed_memory_access_bc, loadimm64, loadimm, loadimm_z, loadimm_n; + desif; try congruence. + all: destruct decompose_int; try destruct p; try congruence. +Qed. + +Lemma loadimm_nonil: forall sz x n k, + loadimm sz x n k <> nil. +Proof. + intros. + unfold loadimm. desif; + unfold loadimm_n, loadimm_z. + all: destruct decompose_int; try destruct p; try congruence. +Qed. + +Lemma loadimm32_nonil: forall sz x n, + loadimm32 sz x n <> nil. +Proof. + intros. + unfold loadimm32. desif; try congruence. + apply loadimm_nonil. +Qed. + +Lemma loadimm64_nonil: forall sz x n, + loadimm64 sz x n <> nil. +Proof. + intros. + unfold loadimm64. desif; try congruence. + apply loadimm_nonil. +Qed. + +Lemma loadsymbol_nonil: forall sz x n k, + loadsymbol sz x n k <> nil. +Proof. + intros. + unfold loadsymbol. desif; try congruence. +Qed. + +Lemma move_extended_nonil: forall x0 x1 x2 a k, + move_extended x1 x2 x0 a k <> nil. +Proof. + intros. unfold move_extended, move_extended_base. + desif; try congruence. +Qed. + +Lemma arith_extended_nonil: forall insnX insnS x0 x1 x2 x3 a k, + arith_extended insnX insnS x1 x2 x3 x0 a k <> nil. +Proof. + intros. unfold arith_extended, move_extended_base. + desif; try congruence. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB; + exploreInst; try discriminate; apply indexed_memory_access_nonil. + - simpl in TIB. unfold storeind in TIB; + exploreInst; try discriminate; apply indexed_memory_access_nonil. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate; + unfold loadptr_bc; apply indexed_memory_access_nonil. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate; + unfold addimm32, addimm64, shrx32, shrx64, + logicalimm32, logicalimm64, addimm_aux. + all: desif; try congruence; + try apply loadimm32_nonil; try apply loadimm64_nonil; try apply loadsymbol_nonil; + try apply move_extended_nonil; try apply arith_extended_nonil. + all: unfold transl_cond in *; exploreInst; try discriminate; + try apply loadimm32_nonil; try apply loadimm64_nonil. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate; + unfold transl_addressing in *; exploreInst; try discriminate. + all: try apply loadimm64_nonil; try apply arith_extended_nonil; try apply loadsymbol_nonil. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate; + unfold transl_addressing in *; exploreInst; try discriminate. + all: try apply loadimm64_nonil; try apply arith_extended_nonil; try apply loadsymbol_nonil. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_exit_nonil: + forall ex f bdy x, + ex <> None -> + transl_exit f ex = OK(bdy, x) -> + x <> None. +Proof. + intros ex f bdy x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; try monadInv TIC; exploreInst; discriminate). + - contradict Hnonil; auto. +Qed. + +Theorem app_nonil: forall A (l1 l2: list A), + l1 <> nil -> + l1 @@ l2 <> nil. +Proof. + induction l2. + - intros; rewrite app_nil_r; auto. + - intros. unfold not. intros. symmetry in H0. + generalize (app_cons_not_nil); intros. unfold not in H1. + generalize (H0). apply H1. +Qed. + +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs + /\ cur cs = tbb /\ rem cs = tc + /\ pstate cs = abs. +Proof. + intros until m. intros Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit cons_bblocks_decomp; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. apply app_nonil. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_exit_nonil; eauto. } + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x1; pbody2 := x; + pctl := x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Lemma exec_straight_body: + forall c c' rs1 m1 rs2 m2, + exec_straight tge lk c rs1 m1 c' rs2 m2 -> + exists l, + c = l ++ c' + /\ exec_body lk tge l rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES. inv EXES. + - exists (a :: nil). repeat (split; simpl; auto). rewrite H6. auto. + - eapply IHc in H7; eauto. destruct H7 as (l' & Hc & EXECB). subst. + exists (a :: l'). repeat (split; simpl; auto). + rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight tge lk c rs1 m1 c' rs2 m2 -> + exists body, + exec_body lk tge body rs1 m1 = Next rs2 m2 + /\ body ++ c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge lk c rs1 m1 c' rs2 m2 -> + exists body, + exec_body lk tge body rs1 m1 = Next rs2 m2 + /\ body ++ c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma PC_not_data_preg: forall r , + data_preg r = true -> + r <> PC. +Proof. + intros. destruct (PregEq.eq r PC); [ rewrite e in H; simpl in H; discriminate | auto ]. +Qed. + +Lemma X30_not_data_preg: forall r , + data_preg r = true -> + r <> X30. +Proof. + intros. destruct (PregEq.eq r X30); [ rewrite e in H; simpl in H; discriminate | auto ]. +Qed. + +Lemma X16_not_data_preg: forall r , + data_preg r = true -> + r <> X16. +Proof. + intros. destruct (PregEq.eq r X16); [ rewrite e in H; simpl in H; discriminate | auto ]. +Qed. + +Lemma undef_regs_other_2': + forall r rl rs, + data_preg r = true -> + preg_notin r rl -> + undef_regs (DR (IR X16) :: DR (IR X30) :: map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. simpl in H1. + destruct H1 as [HX16 | [HX30 | HDES]]; subst. + apply X16_not_data_preg; auto. apply X30_not_data_preg; auto. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H0. auto. +Qed. + +Ltac Simpl := + rewrite Pregmap.gso; try apply PC_not_data_preg; try apply X30_not_data_preg. + +(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are + unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by + yourself the steps *) +Theorem step_simu_control: + forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, + MB.body bb' = nil -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + cur cs2 = tbb -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (State rs1 m1) -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> + (exists rs3 m3 rs4 m4, + exec_body lk tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_exit tge fn (Ptrofs.repr (size tbb)) rs3 m3 tex t rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. + inv Hpstate. + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H1. + * (* Indirect call *) + monadInv H1. monadInv EQ. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H12. destruct (ms' rf); try discriminate. + revert H12; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + econstructor; eauto. econstructor. + econstructor; eauto. econstructor; eauto. + eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. + unfold incrPC; repeat Simpl; auto. + simpl. unfold incrPC; rewrite Pregmap.gso; auto; try discriminate. + rewrite !Pregmap.gss. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + econstructor; eauto. econstructor. + econstructor; eauto. econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. + unfold incrPC; repeat Simpl; auto. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H12. rewrite H12. auto. + unfold incrPC; simpl; rewrite Pregmap.gso; try discriminate. rewrite !Pregmap.gss. + subst. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H13. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H11. + * monadInv H1. monadInv EQ. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H11. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H12. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + intros (l & MKEPI & EXEB). + repeat eexists. rewrite app_nil_r in MKEPI. + rewrite <- MKEPI in EXEB. + eauto. econstructor. simpl. unfold incrPC. + rewrite !Pregmap.gso; try discriminate. eauto. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + rewrite Pregmap.gss. rewrite Z; auto; try discriminate. + eapply ireg_of_not_X30''; eauto. + eapply ireg_of_not_X16''; eauto. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H12. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + intros (l & MKEPI & EXEB). + repeat eexists. inv EQ. rewrite app_nil_r in MKEPI. + rewrite <- MKEPI in EXEB. + eauto. inv EQ. econstructor. simpl. unfold incrPC. + eauto. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { rewrite Pregmap.gss. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H11. auto. } + + (* MBbuiltin *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + + monadInv TBC. monadInv TIC. inv H0. + + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + + repeat eexists. econstructor. erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. eauto. + econstructor; eauto. + unfold incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other. unfold Val.offset_ptr. rewrite PCeq. + eauto. + intros; simpl in *; destruct H as [HX16 | [HX30 | HDES]]; subst; try discriminate; + exploit list_in_map_inv; eauto; intros [mr [E F]]; subst; discriminate. + auto with asmgen. apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2'; auto. + intros. discriminate. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H9. + remember (incrPC (Ptrofs.repr (size tbb)) rs2) as rs2'. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold incrPC. rewrite Pregmap.gss. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold incrPC in INV. + rewrite Heqrs2' in GOTO; simpl; eauto. + econstructor; eauto. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. rewrite Heqrs2' in INV. + rewrite INV; unfold incrPC; try rewrite Pregmap.gso; auto. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. monadInv H1. monadInv EQ. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_1; eauto. intros (rs', H). + destruct H as [ES [ECFI]]. + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv ES; auto. erewrite <- exec_straight_pc. 2: eapply H0. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H14. 1-2: eauto. instantiate (2 := (incrPC (Ptrofs.repr (size tbb)) rs')). + unfold incrPC, Val.offset_ptr. rewrite PCeq. rewrite Pregmap.gss. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite <- BTC. simpl. rewrite app_nil_r. eauto. + rewrite <- BTC. simpl. econstructor. rewrite ECFI. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. rewrite Hrs3; unfold incrPC. Simpl. rewrite H. all: auto. apply PC_not_data_preg; auto. } + intros. discriminate. + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. monadInv H1. monadInv EQ. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_1; eauto. intros (rs', H). + destruct H as [ES [ECFI]]. + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv ES; auto. erewrite <- exec_straight_pc. 2: eapply H0. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite <- BTC. simpl. rewrite app_nil_r. eauto. + rewrite <- BTC. simpl. econstructor. rewrite ECFI. eauto. + + econstructor; eauto. + unfold incrPC. rewrite Pregmap.gss. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. unfold incrPC. Simpl. rewrite H. all: auto. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. monadInv EQ. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H14. 1-2: eauto. instantiate (2 := (incrPC (Ptrofs.repr (size tbb)) rs2) # X16 <- Vundef). + unfold incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. discriminate. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H11. intros LD; inv LD. + + repeat eexists. econstructor. simpl. Simpl. 2: { eapply ireg_of_not_X16''; eauto. } + unfold incrPC. rewrite Pregmap.gso; try discriminate. rewrite <- H1. + simpl. unfold Mach.label in H12. unfold label. rewrite H12. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { unfold incrPC. repeat Simpl; auto. apply X16_not_data_preg; auto. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. destruct EXEB as [l [MKEPI EXEB]]. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite app_nil_r in MKEPI. rewrite <- MKEPI in EXEB. eauto. + econstructor. simpl. reflexivity. + econstructor; eauto. + unfold incrPC. repeat apply agree_set_other; auto with asmgen. + + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. + destruct bb' as [hd' bdy' ex']; simpl in *. subst. + monadInv TBC. monadInv TIC. simpl in *. + simpl. repeat eexists. + econstructor. econstructor. 4: instantiate (3 := false). all:eauto. + unfold incrPC. rewrite Pregmap.gss. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. unfold incrPC; Simpl; auto. + discriminate. +Qed. + +(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) +Theorem step_simu_basic: + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := it1_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} + /\ tbdy = l ++ tbdy' + /\ exec_body lk tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + destruct EXECS as (l & Hlbi & EXECB). + exists rs2, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + subst. simpl in Hheadereq. + + eapply match_codestate_intro; eauto. + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. discriminate. + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + destruct P as (l & ll & EXECB). + exists rs', m2', l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + destruct ep0 eqn:EPeq. + + (* X29 contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. discriminate. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + destruct P as (l & ll & EXECB). + exists rs2, m1, l. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + subst. + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. unfold preg_of. + apply preg_of_not_X29; auto. + + (* X29 does not contain parent *) + + rewrite chunk_of_Tptr in A. + exploit loadptr_correct. eexact A. discriminate. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + discriminate. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + destruct EXES as (l & ll & EXECB). + exists rs3, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#X29 <- (rs3#X29)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' X29). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_X29; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + destruct P as (l & ll & EXECB). + exists rs2, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_X29; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; try discriminate. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (Op.eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. destruct trap; try discriminate. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + destruct P as (l & ll & EXECB). + exists rs2, m1, l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. discriminate. + - (* MBload notrap1 *) + simpl in EQ0. unfold transl_load in EQ0. discriminate. + - (* MBload notrap2 *) + simpl in EQ0. unfold transl_load in EQ0. discriminate. + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (Op.eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + destruct P as (l & ll & EXECB). + exists rs2, m2', l. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_undef_regs; eauto with asmgen. + intro Hep. simpl in Hep. discriminate. +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body lk tge l rs0 m0 = Next rs1 m1 -> + exec_body lk tge l' rs1 m1 = Next rs2 m2 -> + exec_body lk tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. induction l'. intros. + + simpl in *. congruence. + + intros. inv H. auto. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Lemma exec_body_control: + forall b t rs1 m1 rs2 m2 rs3 m3 fn, + exec_body lk tge (body b) rs1 m1 = Next rs2 m2 -> + exec_exit tge fn (Ptrofs.repr (size b)) rs2 m2 (exit b) t rs3 m3 -> + exec_bblock lk tge fn b rs1 m1 t rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; + cur := cur cs1 |}. + +(* Theorem (A) in the diagram, the easiest of all *) +Theorem step_simu_header: + forall bb s fb sp c ms m rs1 m1 cs1, + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) +Theorem step_simu_body: + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} + /\ exec_body lk tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader BSTEP Hpstate MCS. + inv BSTEP. + exists rs1, m1, cs1, (ep cs1). + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. eapply H6. 2: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) +(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) +Lemma step_simulation_bblock': + forall t sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') t s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus (step lk) tge S1 t S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. + + eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. + eexists; eexists; split; eauto. + econstructor. + + econstructor. + 1,2,3: eauto. + * + unfold incrPC. rewrite Pregmap.gss. + unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + { eapply transf_function_no_overflow; eauto. } + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + * + eapply agree_exten; eauto. intros. unfold incrPC. rewrite Pregmap.gso; auto. + unfold data_preg in H2. destruct r; try congruence. + * + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 2: eapply BSTEP. + 3: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 8: eapply MCS'. all: simpl. + 9: eapply ESTEP. + all: simpl; eauto. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. eauto. + intros EXECB. (* inv EXECB. *) + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. + eapply find_bblock_tail; eauto. +Qed. + +Theorem step_simulation_bblock: + forall t sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus (step lk) tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + +(* Measure to prove finite stuttering, see the other backends *) +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + +(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs + for the internal and external function cases *) +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus (step lk) tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) + monadInv EQ0. + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#X29 <- (parent_sp s) #SP <- sp #X16 <- Vundef). + exploit (storeptr_correct lk tge XSP (fn_retaddr_ofs f) RA nil m2' m3' rs2). + { rewrite chunk_of_Tptr in P. + assert (rs0 X30 = rs2 RA) by auto. + rewrite <- H3. + rewrite ATLR. + change (rs2 XSP) with sp. eexact P. } + 1-2: discriminate. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge lk tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> r <> X16 -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. + assert (Archi.ptr64 = true) as SF; auto. + + unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. + assert (Mptr = Mint64) by auto. rewrite H3 in F. simpl in F. rewrite F. simpl. + unfold exec_store_rs_a. repeat Simpl; try discriminate. + exists rs2. exists m3'. split. + * unfold eval_addressing. Simpl; try discriminate. rewrite Pregmap.gss. + rewrite chunk_of_Tptr in P. rewrite H3 in P. + unfold Val.addl. unfold Val.offset_ptr in P. + destruct sp; simpl; try discriminate. rewrite SF; simpl. + rewrite Ptrofs.of_int64_to_int64. unfold Mem.storev in P. rewrite ATLR. + rewrite P. simpl. apply next_sep; eauto. apply SF. + * econstructor. + + eauto. + - intros. unfold incrPC. + rewrite Pregmap.gso; auto. rewrite V; auto. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. auto. + assert (r' <> X29). { contradict H3; rewrite H3; unfold data_preg; auto. } auto. + unfold sp; congruence. + + intros. + + rewrite Heqrs3'. rewrite V. 2-5: try apply X16_not_data_preg; try apply PC_not_data_preg; auto. + auto. + intros. rewrite Heqrs3'; try discriminate. rewrite V by auto with asmgen. reflexivity. +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Lemma transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (AB.semantics lk tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. diff --git a/aarch64/Asmblockgenproof0.v b/aarch64/Asmblockgenproof0.v new file mode 100644 index 00000000..03d863a3 --- /dev/null +++ b/aarch64/Asmblockgenproof0.v @@ -0,0 +1,884 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * "block" version of Asmgenproof0 + + This module is largely adapted from Asmgenproof0.v of the other backends + It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends + It has similar definitions than Asmgenproof0, but adapted to this new structure *) + +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. +Require Import Conventions1. +Require Import Axioms. +Require Import Asmblockprops. + +Module MB:=Machblock. +Module AB:=Asmblock. + +(** * Agreement between Mach registers and processor registers *) + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma ireg_of_eq: + forall r r', ireg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold ireg_of; intros. destruct (preg_of r) as [[[rr1|]|]|xsp|]; inv H; auto. +Qed. + +Lemma freg_of_eq: + forall r r', freg_of r = OK r' -> preg_of r = FR r'. +Proof. + unfold freg_of; intros. destruct (preg_of r) as [[fr|]|xsp|]; inv H; auto. +Qed. + +Lemma ireg_of_eq': + forall r r', ireg_of r = OK r' -> dreg_of r = IR r'. +Proof. + unfold ireg_of; intros. destruct r; simpl in *; inv H; auto. +Qed. + +Lemma freg_of_eq': + forall r r', freg_of r = OK r' -> dreg_of r = FR r'. +Proof. + unfold freg_of; intros. destruct r; simpl in *; inv H; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma preg_of_not_X29: forall dst, + negb (mreg_eq dst R29) = true -> + DR (IR X29) <> preg_of dst. +Proof. + intros. destruct dst; try discriminate. +Qed. + +Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (incrPC (Ptrofs.repr (size b)) rs). +Proof. + intros. unfold incrPC. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. + - apply agree_set_mreg_parallel; auto. + - apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (set_res (map_builtin_res DR (map_builtin_res dreg_of res)) v' rs). +Proof. + induction res; simpl; intros. + - eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. + - auto. + - apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree ms sp rs -> + (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.undef_regs rl ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite <- agree_sp0. apply H0; auto. + rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. + intros. destruct (In_dec mreg_eq r rl). + rewrite Mach.undef_regs_same; auto. + rewrite Mach.undef_regs_other; auto. rewrite H0; auto. + apply preg_of_data. + rewrite preg_notin_charact. intros; red; intros. elim n. + exploit preg_of_injective; eauto. congruence. +Qed. + +Lemma agree_set_undef_mreg: + forall ms sp rs r v rl rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. + - unfold proj_sumbool; rewrite dec_eq_true. auto. + - auto. + - intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. + + apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. + + destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (dreg_of r)) sp m a v -> + eval_builtin_arg ge (fun r => rs (DR r)) sp m (map_builtin_arg dreg_of a) v. +Proof. + induction 1; simpl; eauto with barg. econstructor. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge (fun r => rs (DR r)) sp m' (map (map_builtin_arg dreg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + - exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. + - exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res DR (map_builtin_res dreg_of res)) v rs r = rs r. +Proof. + induction res; simpl; intros. + - apply Pregmap.gso. red; intros; subst r. rewrite dreg_of_data in H; discriminate. + - auto. + - rewrite IHres2, IHres1; auto. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + +Local Hint Resolve code_tail_0 code_tail_S: core. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next: core. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. destruct (transf_function f) as [tf|] eqn:TF. + + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +Qed. + +End RETADDR_EXISTS. + +(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points + within the Asmblock code generated by translating Machblock function [f], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable lk: aarch64_linker. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list basic -> regset -> mem -> + list basic -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic lk ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight (i1 :: c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic lk ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight (i :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_basic lk ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic lk ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic lk ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic lk ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic lk ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +Inductive exec_straight_opt: list basic -> regset -> mem -> list basic -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Remark exec_straight_opt_right: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma exec_straight_opt_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic lk ge i rs1 m1 = Next rs2 m2 -> + exec_straight_opt c rs2 m2 c' rs3 m3 -> + exec_straight (i :: c) rs1 m1 c' rs3 m3. +Proof. + intros. inv H0. + - apply exec_straight_one; auto. + - eapply exec_straight_step; eauto. +Qed. + +Lemma exec_straight_opt_step_opt: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic lk ge i rs1 m1 = Next rs2 m2 -> + exec_straight_opt c rs2 m2 c' rs3 m3 -> + exec_straight_opt (i :: c) rs1 m1 c' rs3 m3. +Proof. + intros. apply exec_straight_opt_intro. eapply exec_straight_opt_step; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock lk ge fn b1 rs1 m1 E0 rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock lk ge fn b rs1 m1 E0 rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + eapply exec_straight_blocks_step; eauto. + eapply exec_straight_blocks_step; eauto. +Qed. + +(** Linking exec_straight with exec_straight_blocks *) + +Lemma exec_straight_pc: + forall c c' rs1 m1 rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body lk ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic _ _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + destruct s. + erewrite exec_basic_instr_pc; eauto. +Qed. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus (step lk) ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. diff --git a/aarch64/Asmblockgenproof1.v b/aarch64/Asmblockgenproof1.v new file mode 100644 index 00000000..61d77881 --- /dev/null +++ b/aarch64/Asmblockgenproof1.v @@ -0,0 +1,1955 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Proof of correctness for individual instructions *) + +Require Import Coqlib Errors Maps Zbits. +Require Import AST Integers Floats Values Memory Globalenvs Linking. +Require Import Op Locations Machblock Conventions Lia. +Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. + +Module MB := Machblock. +Module AB := Asmblock. + +Section CONSTRUCTORS. + +Variable lk: aarch64_linker. +Variable ge: genv. +Variable fn: function. + +Hypothesis symbol_high_low: forall (id: ident) (ofs: ptrofs), + Val.addl (symbol_high lk id ofs) (symbol_low lk id ofs) = Genv.symbol_address ge id ofs. + +Ltac Simplif := + ((rewrite Pregmap.gss) + || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Ltac ArgsInv := + repeat (match goal with + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args + | [ H: bind _ _ = OK _ |- _ ] => monadInv H + | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + end); + subst; + repeat (match goal with + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * + | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * + end). + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inversion H; subst + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; reflexivity + | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ]. + +Ltac TranslOpSimplN := + econstructor; split; + try apply exec_straight_one; try reflexivity; try split; try apply Val.lessdef_same; + Simpl; simpl; try destruct negb; Simpl; try intros; Simpl; simpl; try destruct negb; Simpl. + +Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC. +Proof. + destruct r; simpl; try discriminate. +Qed. +Hint Resolve preg_of_iregsp_not_PC: asmgen. + +Lemma preg_of_not_X16: forall r, preg_of r <> X16. +Proof. + destruct r; simpl; try discriminate. +Qed. + +Lemma preg_of_not_X30: forall r, preg_of r <> X30. +Proof. + destruct r; simpl; try discriminate. +Qed. + +Lemma ireg_of_not_X16: forall r x, ireg_of r = OK x -> x <> X16. +Proof. + unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H. + red; intros; subst x. elim (preg_of_not_X16 r); auto. + destruct d. destruct i. inv H1; auto. + all: discriminate. +Qed. + +Lemma ireg_of_not_X16': forall r x, ireg_of r = OK x -> IR x <> IR X16. +Proof. + intros. apply ireg_of_not_X16 in H. congruence. +Qed. + +Lemma ireg_of_not_X16'': forall r x, ireg_of r = OK x -> DR (IR x) <> DR (IR X16). +Proof. + intros. apply ireg_of_not_X16 in H. congruence. +Qed. + +Lemma ireg_of_not_X30: forall r x, ireg_of r = OK x -> x <> X30. +Proof. + unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H. + red; intros; subst x. elim (preg_of_not_X30 r); auto. + destruct d. destruct i. inv H1; auto. + all: discriminate. +Qed. + +Lemma ireg_of_not_X30': forall r x, ireg_of r = OK x -> IR x <> IR X30. +Proof. + intros. apply ireg_of_not_X30 in H. congruence. +Qed. + +Lemma ireg_of_not_X30'': forall r x, ireg_of r = OK x -> DR (IR x) <> DR (IR X30). +Proof. + intros. apply ireg_of_not_X30 in H. congruence. +Qed. + +Hint Resolve preg_of_not_X16 ireg_of_not_X16 ireg_of_not_X16' ireg_of_not_X16'': asmgen. +Hint Resolve preg_of_not_X30 ireg_of_not_X30 ireg_of_not_X30' ireg_of_not_X30'': asmgen. + +Inductive wf_decomposition: list (Z * Z) -> Prop := + | wf_decomp_nil: + wf_decomposition nil + | wf_decomp_cons: forall m n p l, + n = Zzero_ext 16 m -> 0 <= p -> wf_decomposition l -> + wf_decomposition ((n, p) :: l). + +Lemma decompose_int_wf: + forall N n p, 0 <= p -> wf_decomposition (decompose_int N n p). +Proof. +Local Opaque Zzero_ext. + induction N as [ | N]; simpl; intros. + - constructor. + - set (frag := Zzero_ext 16 (Z.shiftr n p)) in *. destruct (Z.eqb frag 0). + + apply IHN. lia. + + econstructor. reflexivity. lia. apply IHN; lia. +Qed. + +Fixpoint recompose_int (accu: Z) (l: list (Z * Z)) : Z := + match l with + | nil => accu + | (n, p) :: l => recompose_int (Zinsert accu n p 16) l + end. + +Lemma decompose_int_correct: + forall N n p accu, + 0 <= p -> + (forall i, p <= i -> Z.testbit accu i = false) -> + (forall i, 0 <= i < p + Z.of_nat N * 16 -> + Z.testbit (recompose_int accu (decompose_int N n p)) i = + if zlt i p then Z.testbit accu i else Z.testbit n i). +Proof. + induction N as [ | N]; intros until accu; intros PPOS ABOVE i RANGE. + - simpl. rewrite zlt_true; auto. lia. + - rewrite inj_S in RANGE. simpl. + set (frag := Zzero_ext 16 (Z.shiftr n p)). + assert (FRAG: forall i, p <= i < p + 16 -> Z.testbit n i = Z.testbit frag (i - p)). + { unfold frag; intros. rewrite Zzero_ext_spec by lia. rewrite zlt_true by lia. + rewrite Z.shiftr_spec by lia. f_equal; lia. } + destruct (Z.eqb_spec frag 0). + + rewrite IHN. + * destruct (zlt i p). rewrite zlt_true by lia. auto. + destruct (zlt i (p + 16)); auto. + rewrite ABOVE by lia. rewrite FRAG by lia. rewrite e, Z.testbit_0_l. auto. + * lia. + * intros; apply ABOVE; lia. + * lia. + + simpl. rewrite IHN. + * destruct (zlt i (p + 16)). + ** rewrite Zinsert_spec by lia. unfold proj_sumbool. + rewrite zlt_true by lia. + destruct (zlt i p). + rewrite zle_false by lia. auto. + rewrite zle_true by lia. simpl. symmetry; apply FRAG; lia. + ** rewrite Z.ldiff_spec, Z.shiftl_spec by lia. + change 65535 with (two_p 16 - 1). rewrite Ztestbit_two_p_m1 by lia. + rewrite zlt_false by lia. rewrite zlt_false by lia. apply andb_true_r. + * lia. + * intros. rewrite Zinsert_spec by lia. unfold proj_sumbool. + rewrite zle_true by lia. rewrite zlt_false by lia. simpl. + apply ABOVE. lia. + * lia. +Qed. + +Corollary decompose_int_eqmod: forall N n, + eqmod (two_power_nat (N * 16)%nat) (recompose_int 0 (decompose_int N n 0)) n. +Proof. + intros; apply eqmod_same_bits; intros. + rewrite decompose_int_correct. apply zlt_false; lia. + lia. intros; apply Z.testbit_0_l. lia. +Qed. + +Corollary decompose_notint_eqmod: forall N n, + eqmod (two_power_nat (N * 16)%nat) + (Z.lnot (recompose_int 0 (decompose_int N (Z.lnot n) 0))) n. +Proof. + intros; apply eqmod_same_bits; intros. + rewrite Z.lnot_spec, decompose_int_correct. + rewrite zlt_false by lia. rewrite Z.lnot_spec by lia. apply negb_involutive. + lia. intros; apply Z.testbit_0_l. lia. lia. +Qed. + +Lemma negate_decomposition_wf: + forall l, wf_decomposition l -> wf_decomposition (negate_decomposition l). +Proof. + induction 1; simpl; econstructor; auto. + instantiate (1 := (Z.lnot m)). + apply equal_same_bits; intros. + rewrite H. change 65535 with (two_p 16 - 1). + rewrite Z.lxor_spec, !Zzero_ext_spec, Z.lnot_spec, Ztestbit_two_p_m1 by lia. + destruct (zlt i 16). + apply xorb_true_r. + auto. +Qed. + +Lemma Zinsert_eqmod: + forall n x1 x2 y p l, 0 <= p -> 0 <= l -> + eqmod (two_power_nat n) x1 x2 -> + eqmod (two_power_nat n) (Zinsert x1 y p l) (Zinsert x2 y p l). +Proof. + intros. apply eqmod_same_bits; intros. rewrite ! Zinsert_spec by lia. + destruct (zle p i && zlt i (p + l)); auto. + apply same_bits_eqmod with n; auto. +Qed. + +Lemma Zinsert_0_l: + forall y p l, + 0 <= p -> 0 <= l -> + Z.shiftl (Zzero_ext l y) p = Zinsert 0 (Zzero_ext l y) p l. +Proof. + intros. apply equal_same_bits; intros. + rewrite Zinsert_spec by lia. unfold proj_sumbool. + destruct (zlt i p); [rewrite zle_false by lia|rewrite zle_true by lia]; simpl. + - rewrite Z.testbit_0_l, Z.shiftl_spec_low by auto. auto. + - rewrite Z.shiftl_spec by lia. + destruct (zlt i (p + l)); auto. + rewrite Zzero_ext_spec, zlt_false, Z.testbit_0_l by lia. auto. +Qed. + +Lemma recompose_int_negated: + forall l, wf_decomposition l -> + forall accu, recompose_int (Z.lnot accu) (negate_decomposition l) = Z.lnot (recompose_int accu l). +Proof. + induction 1; intros accu; simpl. + - auto. + - rewrite <- IHwf_decomposition. f_equal. apply equal_same_bits; intros. + rewrite Z.lnot_spec, ! Zinsert_spec, Z.lxor_spec, Z.lnot_spec by lia. + unfold proj_sumbool. + destruct (zle p i); simpl; auto. + destruct (zlt i (p + 16)); simpl; auto. + change 65535 with (two_p 16 - 1). + rewrite Ztestbit_two_p_m1 by lia. rewrite zlt_true by lia. + apply xorb_true_r. +Qed. + +Lemma exec_loadimm_k_w: + forall (rd: ireg) k m l, + wf_decomposition l -> + forall (rs: regset) accu, + rs#rd = Vint (Int.repr accu) -> + exists rs', + exec_straight_opt ge lk (loadimm_k W rd l k) rs m k rs' m + /\ rs'#rd = Vint (Int.repr (recompose_int accu l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + induction 1; intros rs accu ACCU; simpl. + - exists rs; split. apply exec_straight_opt_refl. auto. + - destruct (IHwf_decomposition + ((rs#rd <- (insert_in_int rs#rd n p 16))) + (Zinsert accu n p 16)) + as (rs' & P & Q & R). + Simpl. rewrite ACCU. simpl. f_equal. apply Int.eqm_samerepr. + apply Zinsert_eqmod. auto. lia. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + exists rs'; split. + eapply exec_straight_opt_step_opt. simpl. eauto. auto. + split. exact Q. intros; Simpl. rewrite R by auto. Simpl. +Qed. + +Lemma exec_loadimm_z_w: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge lk (loadimm_z W rd l k) rs m k rs' m + /\ rs'#rd = Vint (Int.repr (recompose_int 0 l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_z; destruct 1. + - econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. + - set (accu0 := Zinsert 0 n p 16). + set (rs1 := rs#rd <- (Vint (Int.repr accu0))). + destruct (exec_loadimm_k_w rd k m l H1 rs1 accu0) as (rs2 & P & Q & R); auto. + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; lia. + split. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm_n_w: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge lk (loadimm_n W rd l k) rs m k rs' m + /\ rs'#rd = Vint (Int.repr (Z.lnot (recompose_int 0 l))) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_n; destruct 1. + - econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. + - set (accu0 := Z.lnot (Zinsert 0 n p 16)). + set (rs1 := rs#rd <- (Vint (Int.repr accu0))). + destruct (exec_loadimm_k_w rd k m (negate_decomposition l) + (negate_decomposition_wf l H1) + rs1 accu0) as (rs2 & P & Q & R). + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. + unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; lia. + split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm32: + forall rd n k rs m, + exists rs', + exec_straight ge lk (loadimm32 rd n k) rs m k rs' m + /\ rs'#rd = Vint n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm32, loadimm; intros. + destruct (is_logical_imm32 n). + - econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite Int.repr_unsigned, Int.or_zero_l; auto. + intros; Simpl. + - set (dz := decompose_int 2%nat (Int.unsigned n) 0). + set (dn := decompose_int 2%nat (Z.lnot (Int.unsigned n)) 0). + assert (A: Int.repr (recompose_int 0 dz) = n). + { transitivity (Int.repr (Int.unsigned n)). + apply Int.eqm_samerepr. apply decompose_int_eqmod. + apply Int.repr_unsigned. } + assert (B: Int.repr (Z.lnot (recompose_int 0 dn)) = n). + { transitivity (Int.repr (Int.unsigned n)). + apply Int.eqm_samerepr. apply decompose_notint_eqmod. + apply Int.repr_unsigned. } + destruct Nat.leb. + + rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; lia. + + rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; lia. +Qed. + +Lemma exec_loadimm_k_x: + forall (rd: ireg) k m l, + wf_decomposition l -> + forall (rs: regset) accu, + rs#rd = Vlong (Int64.repr accu) -> + exists rs', + exec_straight_opt ge lk (loadimm_k X rd l k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.repr (recompose_int accu l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + induction 1; intros rs accu ACCU; simpl. + - exists rs; split. apply exec_straight_opt_refl. auto. + - destruct (IHwf_decomposition + (rs#rd <- (insert_in_long rs#rd n p 16)) + (Zinsert accu n p 16)) + as (rs' & P & Q & R). + Simpl. rewrite ACCU. simpl. f_equal. apply Int64.eqm_samerepr. + apply Zinsert_eqmod. auto. lia. apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr. + exists rs'; split. + eapply exec_straight_opt_step_opt. simpl; eauto. auto. + split. exact Q. intros; Simpl. rewrite R by auto. Simpl. +Qed. + +Lemma exec_loadimm_z_x: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge lk (loadimm_z X rd l k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.repr (recompose_int 0 l)) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_z; destruct 1. + - econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. + - set (accu0 := Zinsert 0 n p 16). + set (rs1 := rs#rd <- (Vlong (Int64.repr accu0))). + destruct (exec_loadimm_k_x rd k m l H1 rs1 accu0) as (rs2 & P & Q & R); auto. + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; lia. + split. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm_n_x: + forall rd l k rs m, + wf_decomposition l -> + exists rs', + exec_straight ge lk (loadimm_n X rd l k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.repr (Z.lnot (recompose_int 0 l))) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm_n; destruct 1. + - econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. + - set (accu0 := Z.lnot (Zinsert 0 n p 16)). + set (rs1 := rs#rd <- (Vlong (Int64.repr accu0))). + destruct (exec_loadimm_k_x rd k m (negate_decomposition l) + (negate_decomposition_wf l H1) + rs1 accu0) as (rs2 & P & Q & R). + unfold rs1; Simpl. + exists rs2; split. + eapply exec_straight_opt_step; eauto. + simpl. unfold rs1. do 5 f_equal. + unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; lia. + split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. + intros. rewrite R by auto. unfold rs1; Simpl. +Qed. + +Lemma exec_loadimm64: + forall rd n k rs m, + exists rs', + exec_straight ge lk (loadimm64 rd n k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm64, loadimm; intros. + destruct (is_logical_imm64 n). + - econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite Int64.repr_unsigned, Int64.or_zero_l; auto. + intros; Simpl. + - set (dz := decompose_int 4%nat (Int64.unsigned n) 0). + set (dn := decompose_int 4%nat (Z.lnot (Int64.unsigned n)) 0). + assert (A: Int64.repr (recompose_int 0 dz) = n). + { transitivity (Int64.repr (Int64.unsigned n)). + apply Int64.eqm_samerepr. apply decompose_int_eqmod. + apply Int64.repr_unsigned. } + assert (B: Int64.repr (Z.lnot (recompose_int 0 dn)) = n). + { transitivity (Int64.repr (Int64.unsigned n)). + apply Int64.eqm_samerepr. apply decompose_notint_eqmod. + apply Int64.repr_unsigned. } + destruct Nat.leb. + + rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; lia. + + rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; lia. +Qed. + +(** Add immediate *) + +Lemma exec_addimm_aux_32: + forall (insn: Z -> arith_pp) (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_basic lk ge (PArith (PArithPP (insn n) rd r1)) rs m = + Next (rs#rd <- (sem rs#r1 (Vint (Int.repr n)))) m) -> + (forall v n1 n2, sem (sem v (Vint n1)) (Vint n2) = sem v (Vint (Int.add n1 n2))) -> + forall rd r1 n k rs m, + exists rs', + exec_straight ge lk (addimm_aux insn rd r1 (Int.unsigned n) k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vint n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros insn sem SEM ASSOC; intros. unfold addimm_aux. + set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo). + assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; lia). + rewrite <- (Int.repr_unsigned n). + destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. + - econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; lia. + intros; Simpl. + - econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; lia. + intros; Simpl. + - econstructor; split. eapply exec_straight_two. + apply SEM. apply SEM. simpl. Simpl. + split. Simpl. simpl. rewrite ASSOC. do 2 f_equal. apply Int.eqm_samerepr. + rewrite E. auto with ints. + intros; Simpl. +Qed. + +Lemma exec_addimm32: + forall (rd r1: ireg) n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge lk (addimm32 rd r1 n k) rs m k rs' m + /\ rs'#rd = Val.add rs#r1 (Vint n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros. unfold addimm32. set (nn := Int.neg n). + destruct (Int.eq n (Int.zero_ext 24 n)); [| destruct (Int.eq nn (Int.zero_ext 24 nn))]. + - apply exec_addimm_aux_32 with (sem := Val.add). auto. intros; apply Val.add_assoc. + - rewrite <- Val.sub_opp_add. + apply exec_addimm_aux_32 with (sem := Val.sub). auto. + intros. rewrite ! Val.sub_add_opp, Val.add_assoc. rewrite Int.neg_add_distr. auto. + - destruct (Int.lt n Int.zero). + + rewrite <- Val.sub_opp_add; fold nn. + edestruct (exec_loadimm32 X16 nn) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite B, C; eauto with asmgen. + intros; Simpl. + + edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. + split. Simpl. rewrite B, C; eauto with asmgen. + intros; Simpl. +Qed. + +Lemma exec_addimm_aux_64: + forall (insn: Z -> arith_pp) (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_basic lk ge (PArith (PArithPP (insn n) rd r1)) rs m = + Next (rs#rd <- (sem rs#r1 (Vlong (Int64.repr n)))) m) -> + (forall v n1 n2, sem (sem v (Vlong n1)) (Vlong n2) = sem v (Vlong (Int64.add n1 n2))) -> + forall rd r1 n k rs m, + exists rs', + exec_straight ge lk (addimm_aux insn rd r1 (Int64.unsigned n) k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros insn sem SEM ASSOC; intros. unfold addimm_aux. + set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo). + assert (E: Int64.unsigned n = nhi + nlo) by (unfold nhi; lia). + rewrite <- (Int64.repr_unsigned n). + destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. + - econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; lia. + intros; Simpl. + - econstructor; split. apply exec_straight_one. apply SEM. Simpl. + split. Simpl. do 3 f_equal; lia. + intros; Simpl. + - econstructor; split. eapply exec_straight_two. + apply SEM. apply SEM. Simpl. Simpl. + split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int64.eqm_samerepr. + rewrite E. auto with ints. + intros; Simpl. +Qed. + +Lemma exec_addimm64: + forall (rd r1: iregsp) n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge lk (addimm64 rd r1 n k) rs m k rs' m + /\ rs'#rd = Val.addl rs#r1 (Vlong n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros. + unfold addimm64. set (nn := Int64.neg n). + destruct (Int64.eq n (Int64.zero_ext 24 n)); [| destruct (Int64.eq nn (Int64.zero_ext 24 nn))]. + - apply exec_addimm_aux_64 with (sem := Val.addl). auto. intros; apply Val.addl_assoc. + - rewrite <- Val.subl_opp_addl. + apply exec_addimm_aux_64 with (sem := Val.subl). auto. + intros. rewrite ! Val.subl_addl_opp, Val.addl_assoc. rewrite Int64.neg_add_distr. auto. + - destruct (Int64.lt n Int64.zero). + + rewrite <- Val.subl_opp_addl; fold nn. + edestruct (exec_loadimm64 X16 nn) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. + split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. + intros; Simpl. + + edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. + split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. + intros; Simpl. +Qed. + +(** Logical immediate *) + +Lemma exec_logicalimm32: + forall (insn1: Z -> arith_rr0) + (insn2: shift_op -> arith_rr0r) + (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_basic lk ge (PArith (PArithRR0 (insn1 n) rd r1)) rs m = + Next (rs#rd <- (sem rs##r1 (Vint (Int.repr n)))) m) -> + (forall rd r1 r2 s rs m, + exec_basic lk ge (PArith (PArithRR0R (insn2 s) rd r1 r2)) rs m = + Next (rs#rd <- (sem rs##r1 (eval_shift_op_int rs#r2 s))) m) -> + forall rd r1 n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge lk (logicalimm32 insn1 insn2 rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vint n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros until sem; intros SEM1 SEM2; intros. unfold logicalimm32. + destruct (is_logical_imm32 n). + - econstructor; split. + apply exec_straight_one. apply SEM1. + split. Simpl. rewrite Int.repr_unsigned; auto. intros; Simpl. + - edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. apply SEM2. + split. Simpl. f_equal; auto. apply C; auto with asmgen. + intros; Simpl. +Qed. + +Lemma exec_logicalimm64: + forall (insn1: Z -> arith_rr0) + (insn2: shift_op -> arith_rr0r) + (sem: val -> val -> val), + (forall rd r1 n rs m, + exec_basic lk ge (PArith (PArithRR0 (insn1 n) rd r1)) rs m = + Next (rs#rd <- (sem rs###r1 (Vlong (Int64.repr n)))) m) -> + (forall rd r1 r2 s rs m, + exec_basic lk ge (PArith (PArithRR0R (insn2 s) rd r1 r2)) rs m = + Next (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s))) m) -> + forall rd r1 n k rs m, + r1 <> X16 -> + exists rs', + exec_straight ge lk (logicalimm64 insn1 insn2 rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros until sem; intros SEM1 SEM2; intros. unfold logicalimm64. + destruct (is_logical_imm64 n). + - econstructor; split. + apply exec_straight_one. apply SEM1. + split. Simpl. rewrite Int64.repr_unsigned. auto. intros; Simpl. + - edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. apply SEM2. + split. Simpl. f_equal; auto. apply C; auto with asmgen. + intros; Simpl. +Qed. + +(** Load address of symbol *) + +Lemma exec_loadsymbol: forall rd s ofs k rs m, + rd <> X16 \/ Archi.pic_code tt = false -> + exists rs', + exec_straight ge lk (loadsymbol rd s ofs k) rs m k rs' m + /\ rs'#rd = Genv.symbol_address ge s ofs + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadsymbol; intros. destruct (Archi.pic_code tt). + - predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. + + subst ofs. econstructor; split. + apply exec_straight_one. simpl; eauto. + split. Simpl. intros; Simpl. + + exploit exec_addimm64. instantiate (1 := rd). simpl. destruct H; congruence. + intros (rs1 & A & B & C). + econstructor; split. + econstructor. simpl; eauto. auto. eexact A. + split. simpl in B; rewrite B. Simpl. + rewrite <- Genv.shift_symbol_address_64 by auto. + rewrite Ptrofs.add_zero_l, Ptrofs.of_int64_to_int64 by auto. auto. + intros. rewrite C by auto. Simpl. + - econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. + intros; Simpl. +Qed. + +(** Shifted operands *) + +Remark transl_shift_not_none: + forall s a, transl_shift s a <> SOnone. +Proof. + destruct s; intros; simpl; congruence. +Qed. + +Remark or_zero_eval_shift_op_int: + forall v s, s <> SOnone -> Val.or (Vint Int.zero) (eval_shift_op_int v s) = eval_shift_op_int v s. +Proof. + intros; destruct s; try congruence; destruct v; auto; simpl; + destruct (Int.ltu n Int.iwordsize); auto; rewrite Int.or_zero_l; auto. +Qed. + +Remark or_zero_eval_shift_op_long: + forall v s, s <> SOnone -> Val.orl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s. +Proof. + intros; destruct s; try congruence; destruct v; auto; simpl; + destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.or_zero_l; auto. +Qed. + +Remark add_zero_eval_shift_op_long: + forall v s, s <> SOnone -> Val.addl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s. +Proof. + intros; destruct s; try congruence; destruct v; auto; simpl; + destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.add_zero_l; auto. +Qed. + +Lemma transl_eval_shift: forall s v (a: amount32), + eval_shift_op_int v (transl_shift s a) = eval_shift s v a. +Proof. + intros. destruct s; simpl; auto. +Qed. + +Lemma transl_eval_shift': forall s v (a: amount32), + Val.or (Vint Int.zero) (eval_shift_op_int v (transl_shift s a)) = eval_shift s v a. +Proof. + intros. rewrite or_zero_eval_shift_op_int by (apply transl_shift_not_none). + apply transl_eval_shift. +Qed. + +Lemma transl_eval_shiftl: forall s v (a: amount64), + eval_shift_op_long v (transl_shift s a) = eval_shiftl s v a. +Proof. + intros. destruct s; simpl; auto. +Qed. + +Lemma transl_eval_shiftl': forall s v (a: amount64), + Val.orl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a. +Proof. + intros. rewrite or_zero_eval_shift_op_long by (apply transl_shift_not_none). + apply transl_eval_shiftl. +Qed. + +Lemma transl_eval_shiftl'': forall s v (a: amount64), + Val.addl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a. +Proof. + intros. rewrite add_zero_eval_shift_op_long by (apply transl_shift_not_none). + apply transl_eval_shiftl. +Qed. + +(** Zero- and Sign- extensions *) + +Lemma exec_move_extended_base: forall rd r1 ex k rs m, + exists rs', + exec_straight ge lk (move_extended_base rd r1 ex k) rs m k rs' m + /\ rs' rd = match ex with Xsgn32 => Val.longofint rs#r1 | Xuns32 => Val.longofintu rs#r1 end + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold move_extended_base; destruct ex; econstructor; + (split; [apply exec_straight_one; simpl; eauto | split; [Simpl|intros;Simpl]]). +Qed. + +Lemma exec_move_extended: forall rd r1 ex (a: amount64) k rs m, + exists rs', + exec_straight ge lk (move_extended rd r1 ex a k) rs m k rs' m + /\ rs' rd = Op.eval_extend ex rs#r1 a + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold move_extended; intros. predSpec Int.eq Int.eq_spec a Int.zero. + - exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C). + exists rs'; split. eexact A. split. unfold Op.eval_extend. rewrite H. rewrite B. + destruct ex, (rs r1); simpl; auto; rewrite Int64.shl'_zero; auto. + auto. + - Local Opaque Val.addl. + exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + change (SOlsl a) with (transl_shift Slsl a). rewrite transl_eval_shiftl''. eauto. auto. + split. Simpl. rewrite B. auto. + intros; Simpl. +Qed. + +Lemma exec_arith_extended: + forall (sem: val -> val -> val) + (insnX: extend_op -> arith_ppp) + (insnS: shift_op -> arith_rr0r), + (forall rd r1 r2 x rs m, + exec_basic lk ge (PArith (PArithPPP (insnX x) rd r1 r2)) rs m = + Next (rs#rd <- (sem rs#r1 (eval_extend rs#r2 x))) m) -> + (forall rd r1 r2 s rs m, + exec_basic lk ge (PArith (PArithRR0R (insnS s) rd r1 r2)) rs m = + Next (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s))) m) -> + forall (rd r1 r2: ireg) (ex: extension) (a: amount64) (k: bcode) rs m, + r1 <> X16 -> + exists rs', + exec_straight ge lk (arith_extended insnX insnS rd r1 r2 ex a k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Op.eval_extend ex rs#r2 a) + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + intros sem insnX insnS EX ES; intros. unfold arith_extended. destruct (Int.ltu a (Int.repr 5)). + - econstructor; split. + apply exec_straight_one. rewrite EX; eauto. auto. + split. Simpl. f_equal. destruct ex; auto. + intros; Simpl. + - exploit (exec_move_extended_base X16 r2 ex). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite ES. eauto. auto. + split. Simpl. unfold ir0. rewrite C by eauto with asmgen. f_equal. + rewrite B. destruct ex; auto. + intros; Simpl. +Qed. + +(** Extended right shift *) + +Lemma exec_shrx32: forall (rd r1: ireg) (n: int) k v (rs: regset) m, + Val.shrx rs#r1 (Vint n) = Some v -> + r1 <> X16 -> + exists rs', + exec_straight ge lk (shrx32 rd r1 n k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + unfold shrx32; intros. apply Val.shrx_shr_2 in H. + destruct (Int.eq n Int.zero) eqn:E0. + - econstructor; split. apply exec_straight_one; simpl; eauto. + split. Simpl. subst v; auto. intros; Simpl. + - econstructor; split. eapply exec_straight_three. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_int by congruence. eauto. + simpl; eauto. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_int by congruence. eauto. + split. subst v; Simpl. intros; Simpl. +Qed. + +Lemma exec_shrx32_none: forall (rd r1: ireg) (n: int) k x (rs: regset) m, + Val.shrx rs#r1 (Vint n) = None -> + r1 <> X16 -> + exists rs', + exec_straight ge lk (shrx32 rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal None) (rs' x) + /\ forall r, data_preg r = true -> r <> rd -> preg_notin r (destroyed_by_op (Oshrximm n)) -> rs'#r = rs#r. +Proof. + unfold shrx32; intros. + destruct (Int.eq n Int.zero) eqn:E0. + - econstructor; split. apply exec_straight_one; simpl; eauto. + split. Simpl. auto. intros; Simpl. + - econstructor; split. eapply exec_straight_three. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_int by congruence. eauto. + simpl; eauto. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_int by congruence. eauto. + split. Simpl. intros; Simpl. +Qed. + +Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m, + Val.shrxl rs#r1 (Vint n) = Some v -> + r1 <> X16 -> + exists rs', + exec_straight ge lk (shrx64 rd r1 n k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r. +Proof. + unfold shrx64; intros. apply Val.shrxl_shrl_2 in H. + destruct (Int.eq n Int.zero) eqn:E. + - econstructor; split. apply exec_straight_one; simpl; eauto. + split. Simpl. subst v; auto. intros; Simpl. + - econstructor; split. eapply exec_straight_three. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_long by congruence. eauto. + simpl; eauto. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_long by congruence. eauto. + split. subst v; Simpl. intros; Simpl. +Qed. + +Lemma exec_shrx64_none: forall (rd r1: ireg) (n: int) k x (rs: regset) m, + Val.shrxl rs#r1 (Vint n) = None -> + r1 <> X16 -> + exists rs', + exec_straight ge lk (shrx64 rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal None) (rs' x) + /\ forall r, data_preg r = true -> r <> rd -> preg_notin r (destroyed_by_op (Oshrximm n)) -> rs'#r = rs#r. +Proof. + unfold shrx64; intros. + destruct (Int.eq n Int.zero) eqn:E. + - econstructor; split. apply exec_straight_one; simpl; eauto. + split. Simpl. auto. intros; Simpl. + - econstructor; split. eapply exec_straight_three. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_long by congruence. eauto. + simpl; eauto. + unfold exec_basic, exec_arith_instr, arith_eval_rr0r. + rewrite or_zero_eval_shift_op_long by congruence. eauto. + split. Simpl. intros; Simpl. +Qed. + +Ltac TranslOpBase := + econstructor; split; + [ apply exec_straight_one; [simpl; eauto ] + | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; Simpl + | intros; Simpl; fail ] ]. + +(** Condition bits *) + +Lemma compare_int_spec: forall rs v1 v2, + let rs' := compare_int rs v1 v2 in + rs'#CN = (Val.negative (Val.sub v1 v2)) + /\ rs'#CZ = (Val.mxcmpu Ceq v1 v2) + /\ rs'#CC = (Val.mxcmpu Cge v1 v2) + /\ rs'#CV = (Val.sub_overflow v1 v2). +Proof. + intros; unfold rs'; auto. +Qed. + +Lemma eval_testcond_compare_sint: forall c v1 v2 b rs, + Val.cmp_bool c v1 v2 = Some b -> + eval_testcond (cond_for_signed_cmp c) (compare_int rs v1 v2) = Some b. +Proof. + intros. generalize (compare_int_spec rs v1 v2). + set (rs' := compare_int rs v1 v2). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. + destruct v1; try discriminate; destruct v2; try discriminate. + simpl in H; inv H. + unfold Val.mxcmpu; simpl. destruct c; simpl. + - destruct (Int.eq i i0); auto. + - destruct (Int.eq i i0); auto. + - rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto. + - rewrite Int.lt_sub_overflow, Int.not_lt. + destruct (Int.eq i i0), (Int.lt i i0); auto. + - rewrite Int.lt_sub_overflow, (Int.lt_not i). + destruct (Int.eq i i0), (Int.lt i i0); auto. + - rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto. +Qed. + +Lemma eval_testcond_compare_uint: forall c v1 v2 b rs, + Val.mxcmpu_bool c v1 v2 = Some b -> + eval_testcond (cond_for_unsigned_cmp c) (compare_int rs v1 v2) = Some b. +Proof. + intros. generalize (compare_int_spec rs v1 v2). + set (rs' := compare_int rs v1 v2). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. + destruct v1; try discriminate; destruct v2; try discriminate. + simpl in H; inv H. + unfold Val.mxcmpu; simpl. destruct c; simpl. + - destruct (Int.eq i i0); auto. + - destruct (Int.eq i i0); auto. + - destruct (Int.ltu i i0); auto. + - rewrite (Int.not_ltu i). destruct (Int.eq i i0), (Int.ltu i i0); auto. + - rewrite (Int.ltu_not i). destruct (Int.eq i i0), (Int.ltu i i0); auto. + - destruct (Int.ltu i i0); auto. +Qed. + +Lemma compare_long_spec: forall rs v1 v2, + let rs' := compare_long rs v1 v2 in + rs'#CN = (Val.negativel (Val.subl v1 v2)) + /\ rs'#CZ = (Val.mxcmplu Ceq v1 v2) + /\ rs'#CC = (Val.mxcmplu Cge v1 v2) + /\ rs'#CV = (Val.subl_overflow v1 v2). +Proof. + intros; unfold rs'; auto. +Qed. + +Remark int64_sub_overflow: + forall x y, + Int.xor (Int.repr (Int64.unsigned (Int64.sub_overflow x y Int64.zero))) + (Int.repr (Int64.unsigned (Int64.negative (Int64.sub x y)))) = + (if Int64.lt x y then Int.one else Int.zero). +Proof. + intros. + transitivity (Int.repr (Int64.unsigned (if Int64.lt x y then Int64.one else Int64.zero))). + rewrite <- (Int64.lt_sub_overflow x y). + unfold Int64.sub_overflow, Int64.negative. + set (s := Int64.signed x - Int64.signed y - Int64.signed Int64.zero). + destruct (zle Int64.min_signed s && zle s Int64.max_signed); + destruct (Int64.lt (Int64.sub x y) Int64.zero); + auto. + destruct (Int64.lt x y); auto. +Qed. + +Lemma eval_testcond_compare_slong: forall c v1 v2 b rs, + Val.cmpl_bool c v1 v2 = Some b -> + eval_testcond (cond_for_signed_cmp c) (compare_long rs v1 v2) = Some b. +Proof. + intros. generalize (compare_long_spec rs v1 v2). + set (rs' := compare_long rs v1 v2). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. + destruct v1; try discriminate; destruct v2; try discriminate. + simpl in H; inv H. + unfold Val.mxcmplu; simpl. destruct c; simpl. + - destruct (Int64.eq i i0); auto. + - destruct (Int64.eq i i0); auto. + - rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto. + - rewrite int64_sub_overflow, Int64.not_lt. + destruct (Int64.eq i i0), (Int64.lt i i0); auto. + - rewrite int64_sub_overflow, (Int64.lt_not i). + destruct (Int64.eq i i0), (Int64.lt i i0); auto. + - rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto. +Qed. + +Lemma eval_testcond_compare_ulong: forall c v1 v2 b rs, + Val.mxcmplu_bool c v1 v2 = Some b -> + eval_testcond (cond_for_unsigned_cmp c) (compare_long rs v1 v2) = Some b. +Proof. + intros. generalize (compare_long_spec rs v1 v2). + set (rs' := compare_long rs v1 v2). intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E; unfold Val.mxcmplu. + destruct v1; try discriminate; destruct v2; try discriminate; simpl in H. + - (* int-int *) + inv H. destruct c; simpl. + + destruct (Int64.eq i i0); auto. + + destruct (Int64.eq i i0); auto. + + destruct (Int64.ltu i i0); auto. + + rewrite (Int64.not_ltu i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto. + + rewrite (Int64.ltu_not i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto. + + destruct (Int64.ltu i i0); auto. + - (* int-ptr *) + simpl. + destruct (Archi.ptr64); simpl; try discriminate. + destruct (Int64.eq i Int64.zero); simpl; try discriminate. + destruct c; simpl in H; inv H; reflexivity. + - (* ptr-int *) + simpl. + destruct (Archi.ptr64); simpl; try discriminate. + destruct (Int64.eq i0 Int64.zero); try discriminate. + destruct c; simpl in H; inv H; reflexivity. + - (* ptr-ptr *) + simpl. + destruct (eq_block b0 b1). + destruct (Archi.ptr64); simpl; try discriminate. + inv H. + destruct c; simpl. + * destruct (Ptrofs.eq i i0); auto. + * destruct (Ptrofs.eq i i0); auto. + * destruct (Ptrofs.ltu i i0); auto. + * rewrite (Ptrofs.not_ltu i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto. + * rewrite (Ptrofs.ltu_not i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto. + * destruct (Ptrofs.ltu i i0); auto. + * destruct c; simpl in H; inv H; reflexivity. +Qed. + +Lemma compare_float_spec: forall rs f1 f2, + let rs' := compare_float rs (Vfloat f1) (Vfloat f2) in + rs'#CN = (Val.of_bool (Float.cmp Clt f1 f2)) + /\ rs'#CZ = (Val.of_bool (Float.cmp Ceq f1 f2)) + /\ rs'#CC = (Val.of_bool (negb (Float.cmp Clt f1 f2))) + /\ rs'#CV = (Val.of_bool (negb (Float.ordered f1 f2))). +Proof. + intros; auto. +Qed. + +Lemma eval_testcond_compare_float: forall c v1 v2 b rs, + Val.cmpf_bool c v1 v2 = Some b -> + eval_testcond (cond_for_float_cmp c) (compare_float rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_float_spec rs f f0). + set (rs' := compare_float rs (Vfloat f) (Vfloat f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float.cmp Float.ordered. + unfold Float.cmp, Float.ordered; + destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity. +Qed. + +Lemma eval_testcond_compare_not_float: forall c v1 v2 b rs, + option_map negb (Val.cmpf_bool c v1 v2) = Some b -> + eval_testcond (cond_for_float_not_cmp c) (compare_float rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_float_spec rs f f0). + set (rs' := compare_float rs (Vfloat f) (Vfloat f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float.cmp Float.ordered. + unfold Float.cmp, Float.ordered; + destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity. +Qed. + +Lemma compare_single_spec: forall rs f1 f2, + let rs' := compare_single rs (Vsingle f1) (Vsingle f2) in + rs'#CN = (Val.of_bool (Float32.cmp Clt f1 f2)) + /\ rs'#CZ = (Val.of_bool (Float32.cmp Ceq f1 f2)) + /\ rs'#CC = (Val.of_bool (negb (Float32.cmp Clt f1 f2))) + /\ rs'#CV = (Val.of_bool (negb (Float32.ordered f1 f2))). +Proof. + intros; auto. +Qed. + +Lemma eval_testcond_compare_single: forall c v1 v2 b rs, + Val.cmpfs_bool c v1 v2 = Some b -> + eval_testcond (cond_for_float_cmp c) (compare_single rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_single_spec rs f f0). + set (rs' := compare_single rs (Vsingle f) (Vsingle f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float32.cmp Float32.ordered. + unfold Float32.cmp, Float32.ordered; + destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity. +Qed. + +Lemma eval_testcond_compare_not_single: forall c v1 v2 b rs, + option_map negb (Val.cmpfs_bool c v1 v2) = Some b -> + eval_testcond (cond_for_float_not_cmp c) (compare_single rs v1 v2) = Some b. +Proof. + intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. + generalize (compare_single_spec rs f f0). + set (rs' := compare_single rs (Vsingle f) (Vsingle f0)). + intros (B & C & D & E). + unfold eval_testcond; rewrite B, C, D, E. +Local Transparent Float32.cmp Float32.ordered. + unfold Float32.cmp, Float32.ordered; + destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity. +Qed. + +Remark compare_float_inv: forall rs v1 v2 r, + match r with CR _ => False | _ => True end -> + (compare_float rs v1 v2)#r = rs#r. +Proof. + intros; unfold compare_float. + destruct r; try contradiction; destruct v1; auto; destruct v2; auto. +Qed. + +Remark compare_single_inv: forall rs v1 v2 r, + match r with CR _ => False | _ => True end -> + (compare_single rs v1 v2)#r = rs#r. +Proof. + intros; unfold compare_single. + destruct r; try contradiction; destruct v1; auto; destruct v2; auto. +Qed. + +Lemma transl_cond_correct: + forall cond args k c rs m, + transl_cond cond args k = OK c -> + exists rs', + exec_straight ge lk c rs m k rs' m + /\ (forall b, + eval_condition cond (map rs (map preg_of args)) m = Some b -> + eval_testcond (cond_for_cond cond) rs' = Some b) + /\ forall r, data_preg r = true -> rs'#r = rs#r. +Proof. + intros until m; intros TR. destruct cond; simpl in TR; ArgsInv. + - (* Ccomp *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. + - (* Ccompu *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. + - (* Ccompimm *) + destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. + + econstructor; split. + apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. + split; intros. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. + split; intros. apply eval_testcond_compare_sint; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Ccompuimm *) + destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. + + econstructor; split. + apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. + split; intros. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply eval_testcond_compare_uint; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Ccompshift *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_sint; auto. + destruct r; reflexivity || discriminate. + - (* Ccompushift *) + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_uint; auto. + destruct r; reflexivity || discriminate. + - (* Cmaskzero *) + destruct (is_logical_imm32 n). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Ceq); auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply (eval_testcond_compare_sint Ceq); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Cmasknotzero *) + destruct (is_logical_imm32 n). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Cne); auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm32 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply (eval_testcond_compare_sint Cne); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Ccompl *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. + - (* Ccomplu *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_ulong; auto. + erewrite Val.mxcmplu_bool_correct; eauto. + destruct r; reflexivity || discriminate. + - (* Ccomplimm *) + destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. + + econstructor; split. + apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. + split; intros. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. auto. + split; intros. apply eval_testcond_compare_slong; auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Ccompluimm *) + destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_ulong; auto. + erewrite Val.mxcmplu_bool_correct; eauto. + destruct r; reflexivity || discriminate. + + econstructor; split. + apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. + split; intros. apply eval_testcond_compare_ulong; auto. + erewrite Val.mxcmplu_bool_correct; eauto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + simpl. rewrite B, C by eauto with asmgen. eauto. + split; intros. apply eval_testcond_compare_ulong; auto. + erewrite Val.mxcmplu_bool_correct; eauto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Ccomplshift *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_slong; auto. + destruct r; reflexivity || discriminate. + - (* Ccomplushift *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_ulong; auto. + erewrite Val.mxcmplu_bool_correct; eauto. + destruct r; reflexivity || discriminate. + - (* Cmasklzero *) + destruct (is_logical_imm64 n). + + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Ceq); auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. + split; intros. apply (eval_testcond_compare_slong Ceq); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Cmasknotzero *) + destruct (is_logical_imm64 n). + + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Cne); auto. + destruct r; reflexivity || discriminate. + + exploit (exec_loadimm64 X16 n). intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. + apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. + split; intros. apply (eval_testcond_compare_slong Cne); auto. + transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. + - (* Ccompf *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. + - (* Cnotcompf *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_not_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. + - (* Ccompfzero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. + - (* Cnotcompfzero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_not_float; auto. + destruct r; discriminate || rewrite compare_float_inv; auto. + - (* Ccompfs *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. + - (* Cnotcompfs *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_not_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. + - (* Ccompfszero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. + - (* Cnotcompfszero *) + econstructor; split. apply exec_straight_one. simpl; eauto. + split; intros. apply eval_testcond_compare_not_single; auto. + destruct r; discriminate || rewrite compare_single_inv; auto. +Qed. + +Lemma transl_cond_correct': + forall cond args k c tbb rs m, + transl_cond cond args k = OK c -> + exists rs', + exec_straight ge lk c rs m k rs' m + /\ (forall b, + eval_condition cond (map rs (map preg_of args)) m = Some b -> + eval_testcond (cond_for_cond cond) (incrPC (Ptrofs.repr (size tbb)) rs') = Some b) + /\ forall r, data_preg r = true -> rs'#r = rs#r. +Proof. + intros until m; intros TR. + eapply transl_cond_correct; eauto. +Qed. + +Lemma transl_cbranch_correct_1: + forall cond args lbl c k b m rs tbb bdy, + transl_cond_branch cond args lbl k = OK (bdy,c) -> + eval_condition cond (map rs (map preg_of args)) m = Some b -> + exists rs', + exec_straight_opt ge lk bdy rs m k rs' m + /\ exec_cfi ge fn c (incrPC (Ptrofs.repr (size tbb)) rs') m = + (if b then goto_label fn lbl (incrPC (Ptrofs.repr (size tbb)) rs') m else + Next (incrPC (Ptrofs.repr (size tbb)) rs') m) + /\ forall r, data_preg r = true -> rs'#r = rs#r. +Proof. +intros until bdy; intros TR EV. + assert (Archi.ptr64 = true) as SF; auto. + assert (DFL: + transl_cond_branch_default cond args lbl k = OK (bdy,c) -> + exists rs', + exec_straight_opt ge lk bdy rs m k rs' m + /\ exec_cfi ge fn c (incrPC (Ptrofs.repr (size tbb)) rs') m = eval_branch fn lbl (incrPC (Ptrofs.repr (size tbb)) rs') m (Some b) + /\ forall r, data_preg r = true -> rs'#r = rs#r). + { + unfold transl_cond_branch_default; intros. monadInv H. + exploit transl_cond_correct'; eauto. intros (rs' & A & B & C). + eexists; split. + apply exec_straight_opt_intro. eexact A. + split; auto. simpl. rewrite (B b) by auto. auto. + } +Local Opaque transl_cond transl_cond_branch_default. + destruct args as [ | a1 args]; simpl in TR; auto. + destruct args as [ | a2 args]; simpl in TR; auto. + destruct cond; simpl in TR; auto. + - (* Ccompimm *) + destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto; + apply Int.same_if_eq in N0; subst n; ArgsInv. + + (* Ccompimm Cne 0 *) + econstructor; split. econstructor. + split; auto. simpl. destruct (rs x) eqn:EQRSX; simpl in EV; inv EV. + unfold incrPC. Simpl. rewrite EQRSX. simpl. auto. + + (* Ccompimm Ceq 0 *) + econstructor; split. econstructor. + split; auto. simpl. destruct (rs x) eqn:EQRSX; simpl in EV; inv EV. simpl. + unfold incrPC. Simpl. rewrite EQRSX. simpl. + destruct (Int.eq i Int.zero); auto. + - (* Ccompuimm *) + destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto. + apply Int.same_if_eq in N0; subst n; ArgsInv. + + (* Ccompuimm Cne 0 *) + econstructor; split. econstructor. + split; auto. simpl. apply Val.mxcmpu_bool_correct in EV. + unfold incrPC. Simpl. rewrite EV. auto. + + (* Ccompuimm Ceq 0 *) + monadInv TR. ArgsInv. simpl in *. + econstructor; split. econstructor. + split; auto. simpl. unfold incrPC. Simpl. + apply Int.same_if_eq in N0; subst. + rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cne), EV. + destruct b; auto. + - (* Cmaskzero *) + destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv. + econstructor; split. econstructor. + split; auto. simpl. + erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto. + unfold incrPC. Simpl. + rewrite (Val.negate_cmp_bool Ceq), EV. destruct b; auto. + - (* Cmasknotzero *) + destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv. + econstructor; split. econstructor. + split; auto. simpl. + erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto. + unfold incrPC. Simpl. + rewrite EV. auto. + - (* Ccomplimm *) + destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto; + apply Int64.same_if_eq in N0; subst n; ArgsInv. + + (* Ccomplimm Cne 0 *) + econstructor; split. econstructor. + split; auto. simpl. destruct (rs x) eqn:EQRSX; simpl in EV; inv EV. + unfold incrPC. Simpl. rewrite EQRSX. simpl. auto. + + (* Ccomplimm Ceq 0 *) + econstructor; split. econstructor. + split; auto. simpl. destruct (rs x) eqn:EQRSX; simpl in EV; inv EV. simpl. + unfold incrPC. Simpl. rewrite EQRSX. simpl. + destruct (Int64.eq i Int64.zero); auto. + - (* Ccompluimm *) + destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto; + apply Int64.same_if_eq in N0; subst n; ArgsInv. + + (* Ccompluimm Cne 0 *) + econstructor; split. econstructor. + split; auto. simpl. apply Val.mxcmplu_bool_correct in EV. + unfold incrPC. Simpl. rewrite EV. auto. + + (* Ccompluimm Ceq 0 *) + econstructor; split. econstructor. + split; auto. simpl. destruct (rs x) eqn:EQRSX; simpl in EV; inv EV. simpl. + unfold incrPC. Simpl. rewrite EQRSX. simpl. + destruct (Int64.eq i Int64.zero); auto. + unfold incrPC. Simpl. rewrite EQRSX. simpl. + rewrite SF in *; simpl in *. + rewrite Int64.eq_true in *. + destruct ((Mem.valid_pointer m b0 (Ptrofs.unsigned i) || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))); simpl in *. + assert (b = true). { destruct b; try congruence. } + rewrite H; auto. discriminate. + - (* Cmasklzero *) + destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv. + econstructor; split. econstructor. + split; auto. + erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto. + unfold incrPC. Simpl. + rewrite (Val.negate_cmpl_bool Ceq), EV. destruct b; auto. + - (* Cmasklnotzero *) + destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv. + econstructor; split. econstructor. + split; auto. + erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto. + unfold incrPC. Simpl. + rewrite EV. auto. +Qed. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge lk c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. + (* assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } *) +Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl; + try (rewrite <- transl_eval_shift; TranslOpSimpl). + - (* move *) + destruct (preg_of res), (preg_of m0); try destruct d; try destruct d0; inv TR; TranslOpSimpl. + - (* intconst *) + exploit exec_loadimm32. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. + - (* longconst *) + exploit exec_loadimm64. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. intros; auto with asmgen. + - (* floatconst *) + destruct (Float.eq_dec n Float.zero). + + subst n. TranslOpSimpl. + + TranslOpSimplN. + - (* singleconst *) + destruct (Float32.eq_dec n Float32.zero). + + subst n. TranslOpSimpl. + + TranslOpSimplN. + - (* loadsymbol *) + exploit (exec_loadsymbol x id ofs). eauto with asmgen. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* addrstack *) + exploit (exec_addimm64 x XSP (Ptrofs.to_int64 ofs)); try discriminate. simpl; eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. replace (DR XSP) with (SP) in B by auto. rewrite B. + Local Transparent Val.addl. + destruct (rs SP); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto. + auto. + - (* shift *) + rewrite <- transl_eval_shift'. TranslOpSimpl. + - (* addimm *) + exploit (exec_addimm32 x x0 n). eauto with asmgen. intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* mul *) + TranslOpBase. + Local Transparent Val.add. + destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int.add_zero_l; auto. + - (* andimm *) + exploit (exec_logicalimm32 (Pandimm W) (Pand W)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* orimm *) + exploit (exec_logicalimm32 (Porrimm W) (Porr W)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* xorimm *) + exploit (exec_logicalimm32 (Peorimm W) (Peor W)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* not *) + TranslOpBase. + destruct (rs x0); auto. simpl. rewrite Int.or_zero_l; auto. + - (* notshift *) + TranslOpBase. + destruct (eval_shift s (rs x0) a); auto. simpl. rewrite Int.or_zero_l; auto. + - (* shrx *) + assert (Val.maketotal (Val.shrx (rs x0) (Vint n)) = Val.maketotal (Val.shrx (rs x0) (Vint n))) by eauto. + destruct (Val.shrx) eqn:E. + + exploit (exec_shrx32 x x0 n); eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. + + exploit (exec_shrx32_none x x0 n); eauto with asmgen. + - (* zero-ext *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. + - (* sign-ext *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. + - (* shlzext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int.shl_zero_ext_min; auto using a32_range. + - (* shlsext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int.shl_sign_ext_min; auto using a32_range. + - (* zextshr *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.zero_ext_shru_min; auto using a32_range. + - (* sextshr *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.sign_ext_shr_min; auto using a32_range. + - (* shiftl *) + rewrite <- transl_eval_shiftl'. TranslOpSimpl. + - (* extend *) + exploit (exec_move_extended x0 x1 x a k). intros (rs' & A & B & C). + econstructor; split. eexact A. + split. rewrite B; auto. eauto with asmgen. + - (* addlshift *) + TranslOpBase. + - (* addext *) + exploit (exec_arith_extended Val.addl Paddext (Padd X)). + auto. auto. instantiate (1 := x1). eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. + - (* addlimm *) + exploit (exec_addimm64 x x0 n). simpl. generalize (ireg_of_not_X16 _ _ EQ1). congruence. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. simpl in B; rewrite B; auto. auto. + - (* neglshift *) + TranslOpBase. + - (* sublshift *) + TranslOpBase. + - (* subext *) + exploit (exec_arith_extended Val.subl Psubext (Psub X)). + auto. auto. instantiate (1 := x1). eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. + - (* mull *) + TranslOpBase. + destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int64.add_zero_l; auto. + - (* andlshift *) + TranslOpBase. + - (* andlimm *) + exploit (exec_logicalimm64 (Pandimm X) (Pand X)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* orlshift *) + TranslOpBase. + - (* orlimm *) + exploit (exec_logicalimm64 (Porrimm X) (Porr X)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* orlshift *) + TranslOpBase. + - (* xorlimm *) + exploit (exec_logicalimm64 (Peorimm X) (Peor X)). + intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; split. eexact A. split. rewrite B; auto. auto. + - (* notl *) + TranslOpBase. + destruct (rs x0); auto. simpl. rewrite Int64.or_zero_l; auto. + - (* notlshift *) + TranslOpBase. + destruct (eval_shiftl s (rs x0) a); auto. simpl. rewrite Int64.or_zero_l; auto. + - (* biclshift *) + TranslOpBase. + - (* ornlshift *) + TranslOpBase. + - (* eqvlshift *) + TranslOpBase. + - (* shrx *) + assert (Val.maketotal (Val.shrxl (rs x0) (Vint n)) = Val.maketotal (Val.shrxl (rs x0) (Vint n))) by eauto. + destruct (Val.shrxl) eqn:E. + + exploit (exec_shrx64 x x0 n); eauto with asmgen. intros (rs' & A & B & C). + econstructor; split. eexact A. split. rewrite B; auto. auto. + + exploit (exec_shrx64_none x x0 n); eauto with asmgen. + - (* zero-ext-l *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto. + - (* sign-ext-l *) + TranslOpBase. + destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto. + - (* shllzext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_zero_ext_min; auto using a64_range. + - (* shllsext *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_sign_ext_min; auto using a64_range. + - (* zextshrl *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.zero_ext_shru'_min; auto using a64_range. + - (* sextshrl *) + TranslOpBase. + destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.sign_ext_shr'_min; auto using a64_range. + - (* condition *) + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. + rewrite (B b) by auto. auto. + auto. + intros; Simpl. + - (* select *) + destruct (preg_of res) as [[ir|fr]|cr|] eqn:RES; monadInv TR. + + (* integer *) + generalize (ireg_of_eq _ _ EQ) (ireg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. + split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. + rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. + rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. + auto. + intros; Simpl. + + (* FP *) + generalize (freg_of_eq _ _ EQ) (freg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. + exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. + split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. + rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. + rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. + auto. + intros; Simpl. +Qed. + +(** Translation of addressing modes, loads, stores *) + +Lemma transl_addressing_correct: + forall sz addr args (insn: Asm.addressing -> basic) k (rs: regset) m c b o, + transl_addressing sz addr args insn k = OK c -> + Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some (Vptr b o) -> + exists ad rs', + exec_straight_opt ge lk c rs m (insn ad :: k) rs' m + /\ eval_addressing lk ad rs' = Vptr b o + /\ forall r, data_preg r = true -> rs' r = rs r. +Proof. + intros until o; intros TR EV. + unfold transl_addressing in TR; destruct addr; ArgsInv; SimplEval EV. + - (* Aindexed *) + destruct (offset_representable sz ofs); inv EQ0. + + econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. + + exploit (exec_loadimm64 X16 ofs). intros (rs' & A & B & C). + econstructor; exists rs'; split. apply exec_straight_opt_intro; eexact A. + split. simpl. rewrite B, C by eauto with asmgen. auto. + eauto with asmgen. + - (* Aindexed2 *) + econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. + - (* Aindexed2shift *) + destruct (Int.eq a Int.zero) eqn:E; [|destruct (Int.eq (Int.shl Int.one a) (Int.repr sz))]; inv EQ2. + + apply Int.same_if_eq in E. rewrite E. + econstructor; econstructor; split. apply exec_straight_opt_refl. + split; auto. simpl. + rewrite Val.addl_commut in H0. destruct (rs x0); try discriminate. + unfold Val.shll. rewrite Int64.shl'_zero. auto. + + econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. + + econstructor; econstructor; split. + apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. + split. simpl. Simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero. auto. + intros; Simpl. + - (* Aindexed2ext *) + destruct (Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz)); inv EQ2. + + econstructor; econstructor; split. apply exec_straight_opt_refl. + split; auto. destruct x; auto. + + exploit (exec_arith_extended Val.addl Paddext (Padd X)); auto. + instantiate (1 := x0). eauto with asmgen. + intros (rs' & A & B & C). + econstructor; exists rs'; split. + apply exec_straight_opt_intro. eexact A. + split. simpl. rewrite B. rewrite Val.addl_assoc. f_equal. + unfold Op.eval_extend; destruct x, (rs x1); simpl; auto; rewrite ! a64_range; + simpl; rewrite Int64.add_zero; auto. + intros. apply C; eauto with asmgen. + - (* Aglobal *) + destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz); inv TR. + + econstructor; econstructor; split. + apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. + split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence. + intros; Simpl. + + exploit (exec_loadsymbol X16 id ofs). auto. intros (rs' & A & B & C). + econstructor; exists rs'; split. + apply exec_straight_opt_intro. eexact A. + split. simpl. + rewrite B. rewrite <- Genv.shift_symbol_address_64, Ptrofs.add_zero by auto. + simpl in EV. congruence. + auto with asmgen. + - (* Ainstrack *) + assert (E: Val.addl (rs SP) (Vlong (Ptrofs.to_int64 ofs)) = Vptr b o). + { simpl in EV. inv EV. destruct (rs SP); simpl in H1; inv H1. simpl. + rewrite Ptrofs.of_int64_to_int64 by auto. auto. } + destruct (offset_representable sz (Ptrofs.to_int64 ofs)); inv TR. + + econstructor; econstructor; split. apply exec_straight_opt_refl. + auto. + + exploit (exec_loadimm64 X16 (Ptrofs.to_int64 ofs)). intros (rs' & A & B & C). + econstructor; exists rs'; split. + apply exec_straight_opt_intro. eexact A. + split. simpl. rewrite B, C by eauto with asmgen. auto. + auto with asmgen. +Qed. + +Lemma transl_load_correct: + forall chunk addr args dst k c (rs: regset) m vaddr v, + transl_load chunk addr args dst k = OK c -> + Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr -> + Mem.loadv chunk m vaddr = Some v -> + exists rs', + exec_straight ge lk c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r. +Proof. + intros. destruct vaddr; try discriminate. + assert (A: exists sz insn, + transl_addressing sz addr args insn k = OK c + /\ (forall ad rs', exec_basic lk ge (insn ad) rs' m = + exec_load_rd_a lk chunk (fun v => v) ad (dreg_of dst) rs' m)). + { + destruct chunk; monadInv H; + try rewrite (ireg_of_eq' _ _ EQ); try rewrite (freg_of_eq' _ _ EQ); + do 2 econstructor; (split; [eassumption|auto]). + } + destruct A as (sz & insn & B & C). + exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R). + assert (X: exec_load_rd_a lk chunk (fun v => v) ad (dreg_of dst) rs' m = + Next (rs'#(preg_of dst) <- v) m). + { unfold exec_load_rd_a. rewrite Q, H1. auto. } + econstructor; split. + eapply exec_straight_opt_right. eexact P. + apply exec_straight_one. rewrite C, X; eauto. Simpl. + split. auto. intros; Simpl. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m vaddr m', + transl_store chunk addr args src k = OK c -> + Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr -> + Mem.storev chunk m vaddr rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge lk c rs m k rs' m' + /\ forall r, data_preg r = true -> rs' r = rs r. +Proof. + intros. destruct vaddr; try discriminate. + set (chunk' := match chunk with Mint8signed => Mint8unsigned + | Mint16signed => Mint16unsigned + | _ => chunk end). + assert (A: exists sz insn, + transl_addressing sz addr args insn k = OK c + /\ (forall ad rs', exec_basic lk ge (insn ad) rs' m = + exec_store_rs_a lk chunk' ad rs'#(preg_of src) rs' m)). + { + unfold chunk'; destruct chunk; monadInv H; + try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ); + do 2 econstructor; (split; [eassumption|auto]). + } + destruct A as (sz & insn & B & C). + exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R). + assert (X: Mem.storev chunk' m (Vptr b i) rs#(preg_of src) = Some m'). + { rewrite <- H1. unfold chunk'. destruct chunk; auto; simpl; symmetry. + apply Mem.store_signed_unsigned_8. + apply Mem.store_signed_unsigned_16. } + assert (Y: exec_store_rs_a lk chunk' ad rs'#(preg_of src) rs' m = + Next rs' m'). + { unfold exec_store_rs_a. rewrite Q, R, X by auto with asmgen. auto. } + econstructor; split. + eapply exec_straight_opt_right. eexact P. + apply exec_straight_one. rewrite C, Y; eauto. + intros; Simpl. rewrite R; auto. +Qed. + +(** Memory accesses *) + +Lemma indexed_memory_access_correct: forall insn sz (base: iregsp) ofs k (rs: regset) m b i, + preg_of_iregsp base <> X16 -> + Val.offset_ptr rs#base ofs = Vptr b i -> + exists ad rs', + exec_straight_opt ge lk (indexed_memory_access_bc insn sz base ofs k) rs m (insn ad :: k) rs' m + /\ eval_addressing lk ad rs' = Vptr b i + /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r. +Proof. + unfold indexed_memory_access_bc; intros. + assert (Val.addl rs#base (Vlong (Ptrofs.to_int64 ofs)) = Vptr b i). + { destruct (rs base); try discriminate. simpl in *. rewrite Ptrofs.of_int64_to_int64 by auto. auto. } + destruct offset_representable. + - econstructor; econstructor; split. apply exec_straight_opt_refl. auto. + - exploit (exec_loadimm64 X16); eauto. intros (rs' & A & B & C). + econstructor; econstructor; split. apply exec_straight_opt_intro; eexact A. + split. simpl. rewrite B, C; eauto; try discriminate. + unfold preg_of_iregsp in H. destruct base; auto. auto. +Qed. + +Lemma loadptr_correct: forall (base: iregsp) ofs dst k m v (rs: regset), + Mem.loadv Mint64 m (Val.offset_ptr rs#base ofs) = Some v -> + preg_of_iregsp base <> IR X16 -> + exists rs', + exec_straight ge lk (loadptr_bc base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> X16 -> r <> dst -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. simpl. unfold exec_load_rd_a. rewrite B, H. eauto. + split. Simpl. intros; Simpl. +Qed. + +Lemma storeptr_correct: forall (base: iregsp) ofs (src: ireg) k m m' (rs: regset), + Mem.storev Mint64 m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + preg_of_iregsp base <> IR X16 -> + (DR (IR (RR1 src))) <> (DR (IR (RR1 X16))) -> + exists rs', + exec_straight ge lk (storeptr_bc src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. simpl. unfold exec_store_rs_a. rewrite B, C, H. eauto. + discriminate. auto. + intros; Simpl. rewrite C; auto. +Qed. + +Lemma loadind_correct: + forall (base: iregsp) ofs ty dst k c (rs: regset) m v, + loadind base ofs ty dst k = OK c -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> + preg_of_iregsp base <> IR X16 -> + exists rs', + exec_straight ge lk c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + assert (X: exists sz (insn: addressing -> ld_instruction), + c = indexed_memory_access_bc insn sz base ofs k + /\ (forall ad rs', exec_basic lk ge (insn ad) rs' m = + exec_load_rd_a lk (chunk_of_type ty) (fun v => v) ad (dreg_of dst) rs' m)). + { + unfold loadind in H; destruct ty; destruct (dst); inv H; + do 2 econstructor; split; eauto. + } + destruct X as (sz & insn & EQ & SEM). subst c. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. rewrite SEM. unfold exec_load. + unfold exec_load_rd_a. rewrite B, H0. eauto. Simpl. + split. auto. intros; Simpl. +Qed. + +Lemma storeind_correct: forall (base: iregsp) ofs ty src k c (rs: regset) m m', + storeind src base ofs ty k = OK c -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> + preg_of_iregsp base <> IR X16 -> + exists rs', + exec_straight ge lk c rs m k rs' m' + /\ forall r, data_preg r = true -> rs' r = rs r. +Proof. + intros. + destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. + assert (X: exists sz (insn: addressing -> st_instruction), + c = indexed_memory_access_bc insn sz base ofs k + /\ (forall ad rs', exec_basic lk ge (insn ad) rs' m = + exec_store_rs_a lk (chunk_of_type ty) ad rs'#(preg_of src) rs' m)). + { + unfold storeind in H; destruct ty; destruct (preg_of src) as [[ir|fr]|cr|]; inv H; do 2 econstructor; split; eauto. + } + destruct X as (sz & insn & EQ & SEM). subst c. + exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. + apply exec_straight_one. rewrite SEM. + unfold exec_store. unfold exec_store_rs_a. + rewrite B, C, H0 by eauto with asmgen. eauto. + intros; Simpl. unfold data_preg in H2. destruct r as [[[ir|]|fr]|cr|]. + all: rewrite C; auto; try discriminate; + destruct ir; try discriminate. +Qed. + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs tm, + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge lk (make_epilogue f) rs tm nil rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> SP -> r <> X30 -> r <> X16 -> rs'#r = rs#r). +Proof. + assert (Archi.ptr64 = true) as SF; auto. + intros until tm; intros LP LRA FREE AG MEXT MCS. + exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). + exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). + exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. + exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. + exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). + unfold make_epilogue. + rewrite chunk_of_Tptr in *. unfold Mptr in *. rewrite SF in *. + + exploit (loadptr_correct XSP (fn_retaddr_ofs f)). + instantiate (2 := rs). simpl. + replace (rs XSP) with (rs SP) by auto. + rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; discriminate. + + intros (rs1 & A1 & B1 & C1). + econstructor; econstructor; split. + eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. + simpl; rewrite (C1 SP) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. + rewrite FREE'. eauto. + split. apply agree_set_other; auto. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. intros; apply C1; auto with asmgen. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. + split. Simpl. + intros. Simpl. +Qed. + +End CONSTRUCTORS. diff --git a/aarch64/Asmblockprops.v b/aarch64/Asmblockprops.v new file mode 100644 index 00000000..38fbd6d3 --- /dev/null +++ b/aarch64/Asmblockprops.v @@ -0,0 +1,119 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Common definition and proofs on Asmblock required by various modules *) + +Require Import Coqlib. +Require Import Integers. +Require Import Memory. +Require Import Globalenvs. +Require Import Values. +Require Import Asmblock. +Require Import Axioms. + +Definition bblock_simu (lk: aarch64_linker) (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + forall rs m rs' m' t, + exec_bblock lk ge f bb rs m t rs' m' -> exec_bblock lk ge f bb' rs m t rs' m'. + +Definition bblock_simu_aux (lk: aarch64_linker) (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + forall rs m, + bbstep lk ge f bb rs m <> Stuck -> + bbstep lk ge f bb rs m = bbstep lk ge f bb' rs m. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma preg_of_data: + forall r, data_preg (preg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. + +Lemma dreg_of_data: + forall r, data_preg (dreg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. +Hint Resolve preg_of_data dreg_of_data: asmgen. + +Lemma data_diff: + forall r r', + data_preg r = true -> data_preg r' = false -> r <> r'. +Proof. + congruence. +Qed. +Hint Resolve data_diff: asmgen. + +Lemma preg_of_not_PC: + forall r, preg_of r <> PC. +Proof. + intros. apply data_diff; auto with asmgen. +Qed. + +Lemma preg_of_not_SP: + forall r, preg_of r <> SP. +Proof. + intros. unfold preg_of; destruct r; simpl; try discriminate. +Qed. + +Ltac desif := + repeat match goal with + | [ |- context[ if ?f then _ else _ ] ] => destruct f + end. + +Ltac decomp := + repeat match goal with + | [ |- context[ match (?rs ?r) with | _ => _ end ] ] => destruct (rs r) + end. + +Ltac Simplif := + ((desif) + || (try unfold compare_long) + || (try unfold compare_int) + || (try unfold compare_float) + || (try unfold compare_single) + || decomp + || (rewrite Pregmap.gss) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Section EPC. + +Variable lk: aarch64_linker. + +(* For Asmblockgenproof0 *) + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic lk ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i; try destruct ld; try destruct ld; + try destruct st; try destruct st; try destruct a. + all: try (inv H; simpl in *; auto; Simpl). + all: try (try unfold exec_load_rd_a in H1; try destruct (Mem.loadv _ _ _); inv H1; Simpl). + all: try (try unfold exec_load_double in H0; destruct (Mem.loadv _ _ _); simpl in *; + try destruct (Mem.loadv _ _ _); simpl in *; inv H0; Simpl). + all: try (try unfold exec_store_rs_a in H0; try destruct (Mem.storev _ _ _); inv H0; auto; Simpl). + all: try (try unfold exec_store_double in H1; destruct (Mem.storev _ _ _); simpl in *; + try destruct (Mem.storev _ _ _); simpl in *; inv H1; auto; Simpl). + - (* alloc *) + destruct (Mem.alloc _ _ _); destruct (Mem.store _ _ _); inv H1; auto; Simpl. + - (* free *) + destruct (rs1 SP); try discriminate; destruct (Mem.free _ _ _ _); inv H1; Simpl. +Qed. + +End EPC. diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index b0787d0a..8187e077 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -34,13 +34,13 @@ let _m1 = Z.of_sint (-1) (* Emit instruction sequences that set or offset a register by a constant. *) let expand_loadimm32 (dst: ireg) n = - List.iter emit (Asmgen.loadimm32 dst n []) + List.iter emit (Asmgen.Asmgen_expand.loadimm32 dst n []) let expand_addimm64 (dst: iregsp) (src: iregsp) n = - List.iter emit (Asmgen.addimm64 dst src n []) + List.iter emit (Asmgen.Asmgen_expand.addimm64 dst src n []) let expand_storeptr (src: ireg) (base: iregsp) ofs = - List.iter emit (Asmgen.storeptr src base ofs []) + List.iter emit (Asmgen.Asmgen_expand.storeptr src base ofs []) (* Handling of varargs *) @@ -73,8 +73,8 @@ let save_parameter_registers ir fr = while !i < 8 do let pos = 8*16 + !i*8 in if !i land 1 = 0 then begin - emit (Pstp(int_param_regs.(!i), int_param_regs.(!i + 1), - ADimm(XSP, Z.of_uint pos))); + emit (Pstpx(int_param_regs.(!i), int_param_regs.(!i + 1), + Mint64, Mint64, ADimm(XSP, Z.of_uint pos))); i := !i + 2 end else begin emit (Pstrx(int_param_regs.(!i), ADimm(XSP, Z.of_uint pos))); @@ -132,9 +132,9 @@ let expand_builtin_va_start r = let expand_annot_val kind txt targ args res = emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); match args, res with - | [BA(IR src)], BR(IR dst) -> - if dst <> src then emit (Pmov (RR1 dst, RR1 src)) - | [BA(FR src)], BR(FR dst) -> + | [BA(DR(IR src))], BR(DR(IR dst)) -> + if dst <> src then emit (Pmov (dst, src)) + | [BA(DR(FR src))], BR(DR(FR dst)) -> if dst <> src then emit (Pfmov (dst, src)) | _, _ -> raise (Error "ill-formed __builtin_annot_val") @@ -152,8 +152,8 @@ let offset_in_range ofs = let memcpy_small_arg sz arg tmp = match arg with - | BA (IR r) -> - (RR1 r, _0) + | BA (DR(IR r)) -> + (r, _0) | BA_addrstack ofs -> if offset_in_range ofs && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) @@ -164,13 +164,13 @@ let memcpy_small_arg sz arg tmp = let expand_builtin_memcpy_small sz al src dst = let (tsrc, tdst) = - if dst <> BA (IR X17) then (X17, X29) else (X29, X17) in + if dst <> BA (DR(IR(RR1 X17))) then (X17, X29) else (X29, X17) in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in let rec copy osrc odst sz = if sz >= 16 then begin - emit (Pldp(X16, X30, ADimm(rsrc, osrc))); - emit (Pstp(X16, X30, ADimm(rdst, odst))); + emit (Pldpx(X16, X30, Mint64, Mint64, ADimm(rsrc, osrc))); + emit (Pstpx(X16, X30, Mint64, Mint64, ADimm(rdst, odst))); copy (Ptrofs.add osrc _16) (Ptrofs.add odst _16) (sz - 16) end else if sz >= 8 then begin @@ -197,7 +197,7 @@ let expand_builtin_memcpy_small sz al src dst = let memcpy_big_arg arg tmp = match arg with - | BA (IR r) -> emit (Pmov(RR1 tmp, RR1 r)) + | BA (DR(IR r)) -> emit (Pmov(RR1 tmp, r)) | BA_addrstack ofs -> expand_addimm64 (RR1 tmp) XSP ofs | _ -> assert false @@ -208,8 +208,8 @@ let expand_builtin_memcpy_big sz al src dst = let lbl = new_label () in expand_loadimm32 X15 (Z.of_uint (sz / 16)); emit (Plabel lbl); - emit (Pldp(X16, X17, ADpostincr(RR1 X30, _16))); - emit (Pstp(X16, X17, ADpostincr(RR1 X29, _16))); + emit (Pldpx(X16, X17, Mint64, Mint64, ADpostincr(RR1 X30, _16))); + emit (Pstpx(X16, X17, Mint64, Mint64, ADpostincr(RR1 X29, _16))); emit (Psubimm(W, RR1 X15, RR1 X15, _1)); emit (Pcbnz(W, X15, lbl)); if sz mod 16 >= 8 then begin @@ -241,29 +241,29 @@ let expand_builtin_memcpy sz al args = let expand_builtin_vload_common chunk base ofs res = let addr = ADimm(base, ofs) in match chunk, res with - | Mint8unsigned, BR(IR res) -> + | Mint8unsigned, BR(DR(IR(RR1 res))) -> emit (Pldrb(W, res, addr)) - | Mint8signed, BR(IR res) -> + | Mint8signed, BR(DR(IR(RR1 res))) -> emit (Pldrsb(W, res, addr)) - | Mint16unsigned, BR(IR res) -> + | Mint16unsigned, BR(DR(IR(RR1 res))) -> emit (Pldrh(W, res, addr)) - | Mint16signed, BR(IR res) -> + | Mint16signed, BR(DR(IR(RR1 res))) -> emit (Pldrsh(W, res, addr)) - | Mint32, BR(IR res) -> + | Mint32, BR(DR(IR(RR1 res))) -> emit (Pldrw(res, addr)) - | Mint64, BR(IR res) -> + | Mint64, BR(DR(IR(RR1 res))) -> emit (Pldrx(res, addr)) - | Mfloat32, BR(FR res) -> + | Mfloat32, BR(DR(FR res)) -> emit (Pldrs(res, addr)) - | Mfloat64, BR(FR res) -> + | Mfloat64, BR(DR(FR res)) -> emit (Pldrd(res, addr)) | _ -> assert false let expand_builtin_vload chunk args res = match args with - | [BA(IR addr)] -> - expand_builtin_vload_common chunk (RR1 addr) _0 res + | [BA(DR(IR addr))] -> + expand_builtin_vload_common chunk addr _0 res | [BA_addrstack ofs] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vload_common chunk XSP ofs res @@ -271,11 +271,11 @@ let expand_builtin_vload chunk args res = expand_addimm64 (RR1 X16) XSP ofs; (* X16 <- SP + ofs *) expand_builtin_vload_common chunk (RR1 X16) _0 res end - | [BA_addptr(BA(IR addr), BA_long ofs)] -> + | [BA_addptr(BA(DR(IR addr)), BA_long ofs)] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vload_common chunk (RR1 addr) ofs res + expand_builtin_vload_common chunk addr ofs res else begin - expand_addimm64 (RR1 X16) (RR1 addr) ofs; (* X16 <- addr + ofs *) + expand_addimm64 (RR1 X16) addr ofs; (* X16 <- addr + ofs *) expand_builtin_vload_common chunk (RR1 X16) _0 res end | _ -> @@ -284,25 +284,25 @@ let expand_builtin_vload chunk args res = let expand_builtin_vstore_common chunk base ofs src = let addr = ADimm(base, ofs) in match chunk, src with - | (Mint8signed | Mint8unsigned), BA(IR src) -> + | (Mint8signed | Mint8unsigned), BA(DR(IR(RR1 src))) -> emit (Pstrb(src, addr)) - | (Mint16signed | Mint16unsigned), BA(IR src) -> + | (Mint16signed | Mint16unsigned), BA(DR(IR(RR1 src))) -> emit (Pstrh(src, addr)) - | Mint32, BA(IR src) -> + | Mint32, BA(DR(IR(RR1 src))) -> emit (Pstrw(src, addr)) - | Mint64, BA(IR src) -> + | Mint64, BA(DR(IR(RR1 src))) -> emit (Pstrx(src, addr)) - | Mfloat32, BA(FR src) -> + | Mfloat32, BA(DR(FR src)) -> emit (Pstrs(src, addr)) - | Mfloat64, BA(FR src) -> + | Mfloat64, BA(DR(FR src)) -> emit (Pstrd(src, addr)) | _ -> assert false let expand_builtin_vstore chunk args = match args with - | [BA(IR addr); src] -> - expand_builtin_vstore_common chunk (RR1 addr) _0 src + | [BA(DR(IR addr)); src] -> + expand_builtin_vstore_common chunk addr _0 src | [BA_addrstack ofs; src] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then expand_builtin_vstore_common chunk XSP ofs src @@ -310,11 +310,11 @@ let expand_builtin_vstore chunk args = expand_addimm64 (RR1 X16) XSP ofs; (* X16 <- SP + ofs *) expand_builtin_vstore_common chunk (RR1 X16) _0 src end - | [BA_addptr(BA(IR addr), BA_long ofs); src] -> + | [BA_addptr(BA(DR(IR addr)), BA_long ofs); src] -> if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then - expand_builtin_vstore_common chunk (RR1 addr) ofs src + expand_builtin_vstore_common chunk addr ofs src else begin - expand_addimm64 (RR1 X16) (RR1 addr) ofs; (* X16 <- addr + ofs *) + expand_addimm64 (RR1 X16) addr ofs; (* X16 <- addr + ofs *) expand_builtin_vstore_common chunk (RR1 X16) _0 src end | _ -> @@ -330,37 +330,47 @@ let expand_builtin_inline name args res = | "__builtin_nop", [], _ -> emit Pnop (* Byte swap *) - | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> + | ("__builtin_bswap" | "__builtin_bswap32"), [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Prev(W, res, a1)) - | "__builtin_bswap64", [BA(IR a1)], BR(IR res) -> + | "__builtin_bswap64", [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Prev(X, res, a1)) - | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + | "__builtin_bswap16", [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Prev16(W, res, a1)); emit (Pandimm(W, res, RR0 res, Z.of_uint 0xFFFF)) - (* Count leading zeros and leading sign bits *) - | "__builtin_clz", [BA(IR a1)], BR(IR res) -> + (* Count leading zeros, leading sign bits, trailing zeros *) + | "__builtin_clz", [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Pclz(W, res, a1)) - | ("__builtin_clzl" | "__builtin_clzll"), [BA(IR a1)], BR(IR res) -> + | ("__builtin_clzl" | "__builtin_clzll"), [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Pclz(X, res, a1)) - | "__builtin_cls", [BA(IR a1)], BR(IR res) -> + | "__builtin_cls", [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Pcls(W, res, a1)) - | ("__builtin_clsl" | "__builtin_clsll"), [BA(IR a1)], BR(IR res) -> + | ("__builtin_clsl" | "__builtin_clsll"), [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> emit (Pcls(X, res, a1)) + | "__builtin_ctz", [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> + emit (Prbit(W, res, a1)); + emit (Pclz(W, res, res)) + | ("__builtin_ctzl" | "__builtin_ctzll"), [BA(DR(IR(RR1 a1)))], BR(DR(IR(RR1 res))) -> + emit (Prbit(X, res, a1)); + emit (Pclz(X, res, res)) (* Float arithmetic *) - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> + | "__builtin_fabs", [BA(DR(FR a1))], BR(DR(FR res)) -> emit (Pfabs(D, res, a1)) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + | ("__builtin_fsqrt" | "__builtin_sqrt"), [BA(DR(FR a1))], BR(DR(FR res)) -> emit (Pfsqrt(D, res, a1)) - | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + | "__builtin_fmadd", [BA(DR(FR a1)); BA(DR(FR a2)); BA(DR(FR a3))], BR(DR(FR res)) -> emit (Pfmadd(D, res, a1, a2, a3)) - | "__builtin_fmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + | "__builtin_fmsub", [BA(DR(FR a1)); BA(DR(FR a2)); BA(DR(FR a3))], BR(DR(FR res)) -> emit (Pfmsub(D, res, a1, a2, a3)) - | "__builtin_fnmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + | "__builtin_fnmadd", [BA(DR(FR a1)); BA(DR(FR a2)); BA(DR(FR a3))], BR(DR(FR res)) -> emit (Pfnmadd(D, res, a1, a2, a3)) - | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> + | "__builtin_fnmsub", [BA(DR(FR a1)); BA(DR(FR a2)); BA(DR(FR a3))], BR(DR(FR res)) -> emit (Pfnmsub(D, res, a1, a2, a3)) + | "__builtin_fmax", [BA(DR(FR a1)); BA(DR(FR a2))], BR(DR(FR res)) -> + emit (Pfmax (D, res, a1, a2)) + | "__builtin_fmin", [BA(DR(FR a1)); BA(DR(FR a2))], BR(DR(FR res)) -> + emit (Pfmin (D, res, a1, a2)) (* Vararg *) - | "__builtin_va_start", [BA(IR a)], _ -> + | "__builtin_va_start", [BA(DR(IR(RR1 a)))], _ -> expand_builtin_va_start a (* Catch-all *) | _ -> @@ -427,9 +437,9 @@ let float_reg_to_dwarf = function | D30 -> 94 | D31 -> 95 let preg_to_dwarf = function - | IR r -> int_reg_to_dwarf r - | FR r -> float_reg_to_dwarf r - | SP -> 31 + | DR(IR(RR1 r)) -> int_reg_to_dwarf r + | DR(FR r) -> float_reg_to_dwarf r + | DR(IR(XSP)) -> 31 | _ -> assert false let expand_function id fn = diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v index 024c9a17..a720c11c 100644 --- a/aarch64/Asmgen.v +++ b/aarch64/Asmgen.v @@ -1,167 +1,47 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, Collège de France and INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Translation from Mach to AArch64. *) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Justus Fasse UGA, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Recdef Coqlib Zwf Zbits. Require Import Errors AST Integers Floats Op. -Require Import Locations Mach Asm. - -Local Open Scope string_scope. -Local Open Scope list_scope. -Local Open Scope error_monad_scope. - -(** Alignment check for symbols *) - -Parameter symbol_is_aligned : ident -> Z -> bool. -(** [symbol_is_aligned id sz] checks whether the symbol [id] is [sz] aligned *) - -(** Extracting integer or float registers. *) - -Definition ireg_of (r: mreg) : res ireg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. - -Definition freg_of (r: mreg) : res freg := - match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. - -(** Recognition of immediate arguments for logical integer operations.*) - -(** Valid immediate arguments are repetitions of a bit pattern [B] - of length [e] = 2, 4, 8, 16, 32 or 64. - The bit pattern [B] must be of the form [0*1*0*] or [1*0*1*] - but must not be all zeros or all ones. *) - -(** The following automaton recognizes [0*1*0*|1*0*1*]. -<< - 0 1 0 - / \ / \ / \ - \ / \ / \ / - -0--> [B] --1--> [D] --0--> [F] - / - [A] - \ - -1--> [C] --0--> [E] --1--> [G] - / \ / \ / \ - \ / \ / \ / - 1 0 1 ->> -*) - -Module Automaton. - -Inductive state : Type := SA | SB | SC | SD | SE | SF | SG | Sbad. - -Definition start := SA. - -Definition next (s: state) (b: bool) := - match s, b with - | SA,false => SB | SA,true => SC - | SB,false => SB | SB,true => SD - | SC,false => SE | SC,true => SC - | SD,false => SF | SD,true => SD - | SE,false => SE | SE,true => SG - | SF,false => SF | SF,true => Sbad - | SG,false => Sbad | SG,true => SG - | Sbad,_ => Sbad - end. - -Definition accepting (s: state) := - match s with - | SA | SB | SC | SD | SE | SF | SG => true - | Sbad => false - end. - -Fixpoint run (len: nat) (s: state) (x: Z) : bool := - match len with - | Datatypes.O => accepting s - | Datatypes.S len => run len (next s (Z.odd x)) (Z.div2 x) - end. - -End Automaton. - -(** The following function determines the candidate length [e], - ensuring that [x] is a repetition [BB...B] - of a bit pattern [B] of length [e]. *) - -Definition logical_imm_length (x: Z) (sixtyfour: bool) : nat := - (** [test n] checks that the low [2n] bits of [x] are of the - form [BB], that is, two occurrences of the same [n] bits *) - let test (n: Z) : bool := - Z.eqb (Zzero_ext n x) (Zzero_ext n (Z.shiftr x n)) in - (** If [test n] fails, we know that the candidate length [e] is - at least [2n]. Hence we test with decreasing values of [n]: - 32, 16, 8, 4, 2. *) - if sixtyfour && negb (test 32) then 64%nat - else if negb (test 16) then 32%nat - else if negb (test 8) then 16%nat - else if negb (test 4) then 8%nat - else if negb (test 2) then 4%nat - else 2%nat. - -(** A valid logical immediate is -- neither [0] nor [-1]; -- composed of a repetition [BBBBB] of a bit-pattern [B] of length [e] -- the low [e] bits of the number, that is, [B], match [0*1*0*] or [1*0*1*]. -*) - -Definition is_logical_imm32 (x: int) : bool := - negb (Int.eq x Int.zero) && negb (Int.eq x Int.mone) && - Automaton.run (logical_imm_length (Int.unsigned x) false) - Automaton.start (Int.unsigned x). - -Definition is_logical_imm64 (x: int64) : bool := - negb (Int64.eq x Int64.zero) && negb (Int64.eq x Int64.mone) && - Automaton.run (logical_imm_length (Int64.unsigned x) true) - Automaton.start (Int64.unsigned x). +Require Import Locations Compopts. +Require Import Mach Asm Asmblock Asmblockgen Machblockgen PostpassScheduling. -(** Arithmetic immediates are 12-bit unsigned numbers, possibly shifted left 12 bits *) -Definition is_arith_imm32 (x: int) : bool := - Int.eq x (Int.zero_ext 12 x) - || Int.eq x (Int.shl (Int.zero_ext 12 (Int.shru x (Int.repr 12))) (Int.repr 12)). - -Definition is_arith_imm64 (x: int64) : bool := - Int64.eq x (Int64.zero_ext 12 x) - || Int64.eq x (Int64.shl (Int64.zero_ext 12 (Int64.shru x (Int64.repr 12))) (Int64.repr 12)). +Local Open Scope error_monad_scope. -(** Decompose integer literals into 16-bit fragments *) +(** Functions called by the Asmexpand ocaml file, inspired and adapted from Asmblockgen.v *) -Fixpoint decompose_int (N: nat) (n p: Z) {struct N} : list (Z * Z) := - match N with - | Datatypes.O => nil - | Datatypes.S N => - let frag := Zzero_ext 16 (Z.shiftr n p) in - if Z.eqb frag 0 then - decompose_int N n (p + 16) - else - (frag, p) :: decompose_int N (Z.ldiff n (Z.shiftl 65535 p)) (p + 16) - end. +Module Asmgen_expand. -Definition negate_decomposition (l: list (Z * Z)) := - List.map (fun np => (Z.lxor (fst np) 65535, snd np)) l. +(* Load immediate *) Definition loadimm_k (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code := - List.fold_right (fun np k => Pmovk sz rd (fst np) (snd np) :: k) k l. + List.fold_right (fun np k => Asm.Pmovk sz rd (fst np) (snd np) :: k) k l. Definition loadimm_z (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code := match l with - | nil => Pmovz sz rd 0 0 :: k - | (n1, p1) :: l => Pmovz sz rd n1 p1 :: loadimm_k sz rd l k + | nil => Asm.Pmovz sz rd 0 0 :: k + | (n1, p1) :: l => Asm.Pmovz sz rd n1 p1 :: loadimm_k sz rd l k end. Definition loadimm_n (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code := match l with - | nil => Pmovn sz rd 0 0 :: k - | (n1, p1) :: l => Pmovn sz rd n1 p1 :: loadimm_k sz rd (negate_decomposition l) k + | nil => Asm.Pmovn sz rd 0 0 :: k + | (n1, p1) :: l => Asm.Pmovn sz rd n1 p1 :: loadimm_k sz rd (negate_decomposition l) k end. Definition loadimm (sz: isize) (rd: ireg) (n: Z) (k: code) : code := @@ -174,15 +54,15 @@ Definition loadimm (sz: isize) (rd: ireg) (n: Z) (k: code) : code := Definition loadimm32 (rd: ireg) (n: int) (k: code) : code := if is_logical_imm32 n - then Porrimm W rd XZR (Int.unsigned n) :: k + then Asm.Porrimm W rd XZR (Int.unsigned n) :: k else loadimm W rd (Int.unsigned n) k. Definition loadimm64 (rd: ireg) (n: int64) (k: code) : code := if is_logical_imm64 n - then Porrimm X rd XZR (Int64.unsigned n) :: k + then Asm.Porrimm X rd XZR (Int64.unsigned n) :: k else loadimm X rd (Int64.unsigned n) k. -(** Add immediate *) +(* Add immediate *) Definition addimm_aux (insn: iregsp -> iregsp -> Z -> instruction) (rd r1: iregsp) (n: Z) (k: code) := @@ -195,978 +75,381 @@ Definition addimm_aux (insn: iregsp -> iregsp -> Z -> instruction) else insn rd r1 nhi :: insn rd rd nlo :: k. -Definition addimm32 (rd r1: ireg) (n: int) (k: code) : code := - let m := Int.neg n in - if Int.eq n (Int.zero_ext 24 n) then - addimm_aux (Paddimm W) rd r1 (Int.unsigned n) k - else if Int.eq m (Int.zero_ext 24 m) then - addimm_aux (Psubimm W) rd r1 (Int.unsigned m) k - else if Int.lt n Int.zero then - loadimm32 X16 m (Psub W rd r1 X16 SOnone :: k) - else - loadimm32 X16 n (Padd W rd r1 X16 SOnone :: k). - Definition addimm64 (rd r1: iregsp) (n: int64) (k: code) : code := let m := Int64.neg n in if Int64.eq n (Int64.zero_ext 24 n) then - addimm_aux (Paddimm X) rd r1 (Int64.unsigned n) k + addimm_aux (Asm.Paddimm X) rd r1 (Int64.unsigned n) k else if Int64.eq m (Int64.zero_ext 24 m) then - addimm_aux (Psubimm X) rd r1 (Int64.unsigned m) k + addimm_aux (Asm.Psubimm X) rd r1 (Int64.unsigned m) k else if Int64.lt n Int64.zero then - loadimm64 X16 m (Psubext rd r1 X16 (EOuxtx Int.zero) :: k) + loadimm64 X16 m (Asm.Psubext rd r1 X16 (EOuxtx Int.zero) :: k) else - loadimm64 X16 n (Paddext rd r1 X16 (EOuxtx Int.zero) :: k). - -(** Logical immediate *) + loadimm64 X16 n (Asm.Paddext rd r1 X16 (EOuxtx Int.zero) :: k). -Definition logicalimm32 - (insn1: ireg -> ireg0 -> Z -> instruction) - (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) - (rd r1: ireg) (n: int) (k: code) : code := - if is_logical_imm32 n - then insn1 rd r1 (Int.unsigned n) :: k - else loadimm32 X16 n (insn2 rd r1 X16 SOnone :: k). - -Definition logicalimm64 - (insn1: ireg -> ireg0 -> Z -> instruction) - (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) - (rd r1: ireg) (n: int64) (k: code) : code := - if is_logical_imm64 n - then insn1 rd r1 (Int64.unsigned n) :: k - else loadimm64 X16 n (insn2 rd r1 X16 SOnone :: k). - -(** Sign- or zero-extended arithmetic *) - -Definition transl_extension (ex: extension) (a: int) : extend_op := - match ex with Xsgn32 => EOsxtw a | Xuns32 => EOuxtw a end. - -Definition move_extended_base - (rd: ireg) (r1: ireg) (ex: extension) (k: code) : code := - match ex with - | Xsgn32 => Pcvtsw2x rd r1 :: k - | Xuns32 => Pcvtuw2x rd r1 :: k - end. +(** Register-indexed stores *) -Definition move_extended - (rd: ireg) (r1: ireg) (ex: extension) (a: int) (k: code) : code := - if Int.eq a Int.zero then - move_extended_base rd r1 ex k - else - move_extended_base rd r1 ex (Padd X rd XZR rd (SOlsl a) :: k). - -Definition arith_extended - (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction) - (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction) - (rd r1 r2: ireg) (ex: extension) (a: int) (k: code) : code := - if Int.ltu a (Int.repr 5) then - insnX rd r1 r2 (transl_extension ex a) :: k - else - move_extended_base X16 r2 ex (insnS rd r1 X16 (SOlsl a) :: k). - -(** Extended right shift *) - -Definition shrx32 (rd r1: ireg) (n: int) (k: code) : code := - if Int.eq n Int.zero then - Pmov rd r1 :: k - else if Int.eq n Int.one then - Padd W X16 r1 r1 (SOlsr (Int.repr 31)) :: - Porr W rd XZR X16 (SOasr n) :: k - else - Porr W X16 XZR r1 (SOasr (Int.repr 31)) :: - Padd W X16 r1 X16 (SOlsr (Int.sub Int.iwordsize n)) :: - Porr W rd XZR X16 (SOasr n) :: k. - -Definition shrx64 (rd r1: ireg) (n: int) (k: code) : code := - if Int.eq n Int.zero then - Pmov rd r1 :: k - else if Int.eq n Int.one then - Padd X X16 r1 r1 (SOlsr (Int.repr 63)) :: - Porr X rd XZR X16 (SOasr n) :: k - else - Porr X X16 XZR r1 (SOasr (Int.repr 63)) :: - Padd X X16 r1 X16 (SOlsr (Int.sub Int64.iwordsize' n)) :: - Porr X rd XZR X16 (SOasr n) :: k. - -(** Load the address [id + ofs] in [rd] *) - -Definition loadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (k: code) : code := - if Archi.pic_code tt then - if Ptrofs.eq ofs Ptrofs.zero then - Ploadsymbol rd id :: k - else - Ploadsymbol rd id :: addimm64 rd rd (Ptrofs.to_int64 ofs) k - else - Padrp rd id ofs :: Paddadr rd rd id ofs :: k. - -(** Translate a shifted operand *) - -Definition transl_shift (s: Op.shift) (a: int): Asm.shift_op := - match s with - | Slsl => SOlsl a - | Slsr => SOlsr a - | Sasr => SOasr a - | Sror => SOror a - end. +Definition indexed_memory_access (insn: Asm.addressing -> instruction) + (sz: Z) (base: iregsp) (ofs: ptrofs) (k: code) := + let ofs := Ptrofs.to_int64 ofs in + if offset_representable sz ofs + then insn (ADimm base ofs) :: k + else loadimm64 X16 ofs (insn (ADreg base X16) :: k). -(** Translation of a condition. Prepends to [k] the instructions - that evaluate the condition and leave its boolean result in one of - the bits of the condition register. The bit in question is - determined by the [crbit_for_cond] function. *) +Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) := + indexed_memory_access (Asm.Pstrx src) 8 base ofs k. -Definition transl_cond - (cond: condition) (args: list mreg) (k: code) := - match cond, args with - | (Ccomp c | Ccompu c), a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pcmp W r1 r2 SOnone :: k) - | (Ccompshift c s a | Ccompushift c s a), a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pcmp W r1 r2 (transl_shift s a) :: k) - | (Ccompimm c n | Ccompuimm c n), a1 :: nil => - do r1 <- ireg_of a1; - OK (if is_arith_imm32 n then - Pcmpimm W r1 (Int.unsigned n) :: k - else if is_arith_imm32 (Int.neg n) then - Pcmnimm W r1 (Int.unsigned (Int.neg n)) :: k - else - loadimm32 X16 n (Pcmp W r1 X16 SOnone :: k)) - | (Cmaskzero n | Cmasknotzero n), a1 :: nil => - do r1 <- ireg_of a1; - OK (if is_logical_imm32 n then - Ptstimm W r1 (Int.unsigned n) :: k - else - loadimm32 X16 n (Ptst W r1 X16 SOnone :: k)) - | (Ccompl c | Ccomplu c), a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pcmp X r1 r2 SOnone :: k) - | (Ccomplshift c s a | Ccomplushift c s a), a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pcmp X r1 r2 (transl_shift s a) :: k) - | (Ccomplimm c n | Ccompluimm c n), a1 :: nil => - do r1 <- ireg_of a1; - OK (if is_arith_imm64 n then - Pcmpimm X r1 (Int64.unsigned n) :: k - else if is_arith_imm64 (Int64.neg n) then - Pcmnimm X r1 (Int64.unsigned (Int64.neg n)) :: k - else - loadimm64 X16 n (Pcmp X r1 X16 SOnone :: k)) - | (Cmasklzero n | Cmasklnotzero n), a1 :: nil => - do r1 <- ireg_of a1; - OK (if is_logical_imm64 n then - Ptstimm X r1 (Int64.unsigned n) :: k - else - loadimm64 X16 n (Ptst X r1 X16 SOnone :: k)) - | Ccompf cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; - OK (Pfcmp D r1 r2 :: k) - | Cnotcompf cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; - OK (Pfcmp D r1 r2 :: k) - | Ccompfzero cmp, a1 :: nil => - do r1 <- freg_of a1; - OK (Pfcmp0 D r1 :: k) - | Cnotcompfzero cmp, a1 :: nil => - do r1 <- freg_of a1; - OK (Pfcmp0 D r1 :: k) - | Ccompfs cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; - OK (Pfcmp S r1 r2 :: k) - | Cnotcompfs cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; - OK (Pfcmp S r1 r2 :: k) - | Ccompfszero cmp, a1 :: nil => - do r1 <- freg_of a1; - OK (Pfcmp0 S r1 :: k) - | Cnotcompfszero cmp, a1 :: nil => - do r1 <- freg_of a1; - OK (Pfcmp0 S r1 :: k) - | _, _ => - Error(msg "Asmgen.transl_cond") - end. +End Asmgen_expand. -Definition cond_for_signed_cmp (cmp: comparison) := - match cmp with - | Ceq => TCeq - | Cne => TCne - | Clt => TClt - | Cle => TCle - | Cgt => TCgt - | Cge => TCge - end. +(** * Translation from Asmblock to assembly language + Inspired from the KVX backend (see kvx/Asm.v and kvx/Asmgen.v) *) -Definition cond_for_unsigned_cmp (cmp: comparison) := - match cmp with - | Ceq => TCeq - | Cne => TCne - | Clt => TClo - | Cle => TCls - | Cgt => TChi - | Cge => TChs - end. +Module Asmblock_TRANSF. +(* STUB *) -Definition cond_for_float_cmp (cmp: comparison) := - match cmp with - | Ceq => TCeq - | Cne => TCne - | Clt => TCmi - | Cle => TCls - | Cgt => TCgt - | Cge => TCge +Definition ireg_of_preg (p : Asm.preg) : res ireg := + match p with + | DR (IR (RR1 r)) => OK r + | _ => Error (msg "Asmgen.ireg_of_preg") end. -Definition cond_for_float_not_cmp (cmp: comparison) := - match cmp with - | Ceq => TCne - | Cne => TCeq - | Clt => TCpl - | Cle => TChi - | Cgt => TCle - | Cge => TClt +Definition freg_of_preg (p : Asm.preg) : res freg := + match p with + | DR (FR r) => OK r + | _ => Error (msg "Asmgen.freg_of_preg") end. -Definition cond_for_cond (cond: condition) := - match cond with - | Ccomp cmp => cond_for_signed_cmp cmp - | Ccompu cmp => cond_for_unsigned_cmp cmp - | Ccompshift cmp s a => cond_for_signed_cmp cmp - | Ccompushift cmp s a => cond_for_unsigned_cmp cmp - | Ccompimm cmp n => cond_for_signed_cmp cmp - | Ccompuimm cmp n => cond_for_unsigned_cmp cmp - | Cmaskzero n => TCeq - | Cmasknotzero n => TCne - | Ccompl cmp => cond_for_signed_cmp cmp - | Ccomplu cmp => cond_for_unsigned_cmp cmp - | Ccomplshift cmp s a => cond_for_signed_cmp cmp - | Ccomplushift cmp s a => cond_for_unsigned_cmp cmp - | Ccomplimm cmp n => cond_for_signed_cmp cmp - | Ccompluimm cmp n => cond_for_unsigned_cmp cmp - | Cmasklzero n => TCeq - | Cmasklnotzero n => TCne - | Ccompf cmp => cond_for_float_cmp cmp - | Cnotcompf cmp => cond_for_float_not_cmp cmp - | Ccompfzero cmp => cond_for_float_cmp cmp - | Cnotcompfzero cmp => cond_for_float_not_cmp cmp - | Ccompfs cmp => cond_for_float_cmp cmp - | Cnotcompfs cmp => cond_for_float_not_cmp cmp - | Ccompfszero cmp => cond_for_float_cmp cmp - | Cnotcompfszero cmp => cond_for_float_not_cmp cmp +Definition iregsp_of_preg (p : Asm.preg) : res iregsp := + match p with + | DR (IR r) => OK r + | _ => Error (msg "Asmgen.iregsp_of_preg") end. -(** Translation of a conditional branch. Prepends to [k] the instructions - that evaluate the condition and ranch to [lbl] if it holds. - We recognize some conditional branches that can be implemented - without setting then testing condition flags. *) - -Definition transl_cond_branch_default - (c: condition) (args: list mreg) (lbl: label) (k: code) := - transl_cond c args (Pbc (cond_for_cond c) lbl :: k). - -Definition transl_cond_branch - (c: condition) (args: list mreg) (lbl: label) (k: code) := - match args, c with - | a1 :: nil, (Ccompimm Cne n | Ccompuimm Cne n) => - if Int.eq n Int.zero - then (do r1 <- ireg_of a1; OK (Pcbnz W r1 lbl :: k)) - else transl_cond_branch_default c args lbl k - | a1 :: nil, (Ccompimm Ceq n | Ccompuimm Ceq n) => - if Int.eq n Int.zero - then (do r1 <- ireg_of a1; OK (Pcbz W r1 lbl :: k)) - else transl_cond_branch_default c args lbl k - | a1 :: nil, (Ccomplimm Cne n | Ccompluimm Cne n) => - if Int64.eq n Int64.zero - then (do r1 <- ireg_of a1; OK (Pcbnz X r1 lbl :: k)) - else transl_cond_branch_default c args lbl k - | a1 :: nil, (Ccomplimm Ceq n | Ccompluimm Ceq n) => - if Int64.eq n Int64.zero - then (do r1 <- ireg_of a1; OK (Pcbz X r1 lbl :: k)) - else transl_cond_branch_default c args lbl k - | a1 :: nil, Cmaskzero n => - match Int.is_power2 n with - | Some bit => do r1 <- ireg_of a1; OK (Ptbz W r1 bit lbl :: k) - | None => transl_cond_branch_default c args lbl k - end - | a1 :: nil, Cmasknotzero n => - match Int.is_power2 n with - | Some bit => do r1 <- ireg_of a1; OK (Ptbnz W r1 bit lbl :: k) - | None => transl_cond_branch_default c args lbl k - end - | a1 :: nil, Cmasklzero n => - match Int64.is_power2' n with - | Some bit => do r1 <- ireg_of a1; OK (Ptbz X r1 bit lbl :: k) - | None => transl_cond_branch_default c args lbl k +Definition basic_to_instruction (b: basic) : res Asm.instruction := + match b with + (* Aithmetic instructions *) + | PArith (PArithP (Padrp id ofs) rd) => do rd' <- ireg_of_preg rd; + OK (Asm.Padrp rd' id ofs) + | PArith (PArithP (Pmovz sz n pos) rd) => do rd' <- ireg_of_preg rd; + OK (Asm.Pmovz sz rd' n pos) + | PArith (PArithP (Pmovn sz n pos) rd) => do rd' <- ireg_of_preg rd; + OK (Asm.Pmovn sz rd' n pos) + | PArith (PArithP (Pfmovimms f) rd) => do rd' <- freg_of_preg rd; + OK (Asm.Pfmovimms rd' f) + | PArith (PArithP (Pfmovimmd f) rd) => do rd' <- freg_of_preg rd; + OK (Asm.Pfmovimmd rd' f) + + | PArith (PArithPP (Pmovk sz n pos) rd rs) => + if (Asm.preg_eq rd rs) then ( + do rd' <- ireg_of_preg rd; + OK (Asm.Pmovk sz rd' n pos) + ) else + Error (msg "Asmgen.basic_to_instruction: Pmovk uses a single register as both source and target") + | PArith (PArithPP Pmov rd rs) => do rd' <- iregsp_of_preg rd; + do rs' <- iregsp_of_preg rs; + OK (Asm.Pmov rd' rs') + | PArith (PArithPP (Paddadr id ofs) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Paddadr rd' rs' id ofs) + | PArith (PArithPP (Psbfiz sz r s) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Psbfiz sz rd' rs' r s) + | PArith (PArithPP (Psbfx sz r s) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Psbfx sz rd' rs' r s) + | PArith (PArithPP (Pubfiz sz r s) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Pubfiz sz rd' rs' r s) + | PArith (PArithPP (Pubfx sz r s) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Pubfx sz rd' rs' r s) + | PArith (PArithPP Pfmov rd rs) => do rd' <- freg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfmov rd' rs') + | PArith (PArithPP Pfcvtds rd rs) => do rd' <- freg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfcvtds rd' rs') + | PArith (PArithPP Pfcvtsd rd rs) => do rd' <- freg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfcvtsd rd' rs') + | PArith (PArithPP (Pfabs sz) rd rs) => do rd' <- freg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfabs sz rd' rs') + | PArith (PArithPP (Pfneg sz) rd rs) => do rd' <- freg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfneg sz rd' rs') + | PArith (PArithPP (Pscvtf fsz isz) rd rs) => do rd' <- freg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Pscvtf fsz isz rd' rs') + | PArith (PArithPP (Pucvtf fsz isz) rd rs) => do rd' <- freg_of_preg rd; + do rs' <- ireg_of_preg rs; + OK (Asm.Pucvtf fsz isz rd' rs') + | PArith (PArithPP (Pfcvtzs isz fsz) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfcvtzs isz fsz rd' rs') + | PArith (PArithPP (Pfcvtzu isz fsz) rd rs) => do rd' <- ireg_of_preg rd; + do rs' <- freg_of_preg rs; + OK (Asm.Pfcvtzu isz fsz rd' rs') + | PArith (PArithPP (Paddimm sz n) rd rs) => do rd' <- iregsp_of_preg rd; + do rs' <- iregsp_of_preg rs; + OK (Asm.Paddimm sz rd' rs' n) + | PArith (PArithPP (Psubimm sz n) rd rs) => do rd' <- iregsp_of_preg rd; + do rs' <- iregsp_of_preg rs; + OK (Asm.Psubimm sz rd' rs' n) + + | PArith (PArithPPP (Pasrv sz) rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Pasrv sz rd' r1' r2') + | PArith (PArithPPP (Plslv sz) rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Plslv sz rd' r1' r2') + | PArith (PArithPPP (Plsrv sz) rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Plsrv sz rd' r1' r2') + | PArith (PArithPPP (Prorv sz) rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Prorv sz rd' r1' r2') + | PArith (PArithPPP Psmulh rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Psmulh rd' r1' r2') + | PArith (PArithPPP Pumulh rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Pumulh rd' r1' r2') + | PArith (PArithPPP (Psdiv sz) rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Psdiv sz rd' r1' r2') + | PArith (PArithPPP (Pudiv sz) rd r1 r2) => do rd' <- ireg_of_preg rd; + do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Pudiv sz rd' r1' r2') + | PArith (PArithPPP (Paddext x) rd r1 r2) => do rd' <- iregsp_of_preg rd; + do r1' <- iregsp_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Paddext rd' r1' r2' x) + | PArith (PArithPPP (Psubext x) rd r1 r2) => do rd' <- iregsp_of_preg rd; + do r1' <- iregsp_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Psubext rd' r1' r2' x) + | PArith (PArithPPP (Pfadd sz) rd r1 r2) => do rd' <- freg_of_preg rd; + do r1' <- freg_of_preg r1; + do r2' <- freg_of_preg r2; + OK (Asm.Pfadd sz rd' r1' r2') + | PArith (PArithPPP (Pfdiv sz) rd r1 r2) => do rd' <- freg_of_preg rd; + do r1' <- freg_of_preg r1; + do r2' <- freg_of_preg r2; + OK (Asm.Pfdiv sz rd' r1' r2') + | PArith (PArithPPP (Pfmul sz) rd r1 r2) => do rd' <- freg_of_preg rd; + do r1' <- freg_of_preg r1; + do r2' <- freg_of_preg r2; + OK (Asm.Pfmul sz rd' r1' r2') + | PArith (PArithPPP (Pfsub sz) rd r1 r2) => do rd' <- freg_of_preg rd; + do r1' <- freg_of_preg r1; + do r2' <- freg_of_preg r2; + OK (Asm.Pfsub sz rd' r1' r2') + + | PArith (PArithRR0 (Pandimm sz n) rd r1) => OK (Asm.Pandimm sz rd r1 n) + | PArith (PArithRR0 (Peorimm sz n) rd r1) => OK (Asm.Peorimm sz rd r1 n) + | PArith (PArithRR0 (Porrimm sz n) rd r1) => OK (Asm.Porrimm sz rd r1 n) + + + | PArith (PArithRR0R (Padd sz s) rd r1 r2) => OK (Asm.Padd sz rd r1 r2 s) + | PArith (PArithRR0R (Psub sz s) rd r1 r2) => OK (Asm.Psub sz rd r1 r2 s) + | PArith (PArithRR0R (Pand sz s) rd r1 r2) => OK (Asm.Pand sz rd r1 r2 s) + | PArith (PArithRR0R (Pbic sz s) rd r1 r2) => OK (Asm.Pbic sz rd r1 r2 s) + | PArith (PArithRR0R (Peon sz s) rd r1 r2) => OK (Asm.Peon sz rd r1 r2 s) + | PArith (PArithRR0R (Peor sz s) rd r1 r2) => OK (Asm.Peor sz rd r1 r2 s) + | PArith (PArithRR0R (Porr sz s) rd r1 r2) => OK (Asm.Porr sz rd r1 r2 s) + | PArith (PArithRR0R (Porn sz s) rd r1 r2) => OK (Asm.Porn sz rd r1 r2 s) + + | PArith (PArithARRRR0 (Pmadd sz) rd r1 r2 r3) => OK (Asm.Pmadd sz rd r1 r2 r3) + | PArith (PArithARRRR0 (Pmsub sz) rd r1 r2 r3) => OK (Asm.Pmsub sz rd r1 r2 r3) + + | PArith (PArithComparisonPP (Pcmpext x) r1 r2) => do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Pcmpext r1' r2' x) + | PArith (PArithComparisonPP (Pcmnext x) r1 r2) => do r1' <- ireg_of_preg r1; + do r2' <- ireg_of_preg r2; + OK (Asm.Pcmnext r1' r2' x) + | PArith (PArithComparisonPP (Pfcmp sz) r1 r2) => do r1' <- freg_of_preg r1; + do r2' <- freg_of_preg r2; + OK (Asm.Pfcmp sz r1' r2') + + | PArith (PArithComparisonR0R (Pcmp is s) r1 r2) => OK (Asm.Pcmp is r1 r2 s) + | PArith (PArithComparisonR0R (Pcmn is s) r1 r2) => OK (Asm.Pcmn is r1 r2 s) + | PArith (PArithComparisonR0R (Ptst is s) r1 r2) => OK (Asm.Ptst is r1 r2 s) + + | PArith (PArithComparisonP (Pcmpimm sz n) r1) => do r1' <- ireg_of_preg r1; + OK (Asm.Pcmpimm sz r1' n) + | PArith (PArithComparisonP (Pcmnimm sz n) r1) => do r1' <- ireg_of_preg r1; + OK (Asm.Pcmnimm sz r1' n) + | PArith (PArithComparisonP (Ptstimm sz n) r1) => do r1' <- ireg_of_preg r1; + OK (Asm.Ptstimm sz r1' n) + | PArith (PArithComparisonP (Pfcmp0 sz) r1) => do r1' <- freg_of_preg r1; + OK (Asm.Pfcmp0 sz r1') + + | PArith (Pcset rd c) => OK (Asm.Pcset rd c) + | PArith (Pfmovi fsz rd r1) => OK (Asm.Pfmovi fsz rd r1) + | PArith (Pcsel rd r1 r2 c) => + match r1, r2 with + | IR r1', IR r2' => do rd' <- ireg_of_preg rd; + do r1'' <- ireg_of_preg r1'; + do r2'' <- ireg_of_preg r2'; + OK (Asm.Pcsel rd' r1'' r2'' c) + | FR r1', FR r2' => do rd' <- freg_of_preg rd; + do r1'' <- freg_of_preg r1'; + do r2'' <- freg_of_preg r2'; + OK (Asm.Pfsel rd' r1'' r2'' c) + | _, _ => Error (msg "Asmgen.basic_to_instruction: Pcsel is only defind on iregs and fregs.") end - | a1 :: nil, Cmasklnotzero n => - match Int64.is_power2' n with - | Some bit => do r1 <- ireg_of a1; OK (Ptbnz X r1 bit lbl :: k) - | None => transl_cond_branch_default c args lbl k - end - | _, _ => - transl_cond_branch_default c args lbl k - end. - -(** Translation of the arithmetic operation [res <- op(args)]. - The corresponding instructions are prepended to [k]. *) - -Definition transl_op - (op: operation) (args: list mreg) (res: mreg) (k: code) := - match op, args with - | Omove, a1 :: nil => - match preg_of res, preg_of a1 with - | IR r, IR a => OK (Pmov r a :: k) - | FR r, FR a => OK (Pfmov r a :: k) - | _ , _ => Error(msg "Asmgen.Omove") - end - | Ointconst n, nil => - do rd <- ireg_of res; - OK (loadimm32 rd n k) - | Olongconst n, nil => - do rd <- ireg_of res; - OK (loadimm64 rd n k) - | Ofloatconst f, nil => - do rd <- freg_of res; - OK (if Float.eq_dec f Float.zero - then Pfmovi D rd XZR :: k - else Pfmovimmd rd f :: k) - | Osingleconst f, nil => - do rd <- freg_of res; - OK (if Float32.eq_dec f Float32.zero - then Pfmovi S rd XZR :: k - else Pfmovimms rd f :: k) - | Oaddrsymbol id ofs, nil => - do rd <- ireg_of res; - OK (loadsymbol rd id ofs k) - | Oaddrstack ofs, nil => - do rd <- ireg_of res; - OK (addimm64 rd XSP (Ptrofs.to_int64 ofs) k) -(** 32-bit integer arithmetic *) - | Oshift s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Porr W rd XZR r1 (transl_shift s a) :: k) - | Oadd, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Padd W rd r1 r2 SOnone :: k) - | Oaddshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Padd W rd r1 r2 (transl_shift s a) :: k) - | Oaddimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (addimm32 rd r1 n k) - | Oneg, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psub W rd XZR r1 SOnone :: k) - | Onegshift s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psub W rd XZR r1 (transl_shift s a) :: k) - | Osub, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psub W rd r1 r2 SOnone :: k) - | Osubshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psub W rd r1 r2 (transl_shift s a) :: k) - | Omul, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pmadd W rd r1 r2 XZR :: k) - | Omuladd, a1 :: a2 :: a3 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; - OK (Pmadd W rd r2 r3 r1 :: k) - | Omulsub, a1 :: a2 :: a3 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; - OK (Pmsub W rd r2 r3 r1 :: k) - | Odiv, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psdiv W rd r1 r2 :: k) - | Odivu, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pudiv W rd r1 r2 :: k) - | Oand, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pand W rd r1 r2 SOnone :: k) - | Oandshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pand W rd r1 r2 (transl_shift s a) :: k) - | Oandimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (logicalimm32 (Pandimm W) (Pand W) rd r1 n k) - | Oor, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porr W rd r1 r2 SOnone :: k) - | Oorshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porr W rd r1 r2 (transl_shift s a) :: k) - | Oorimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (logicalimm32 (Porrimm W) (Porr W) rd r1 n k) - | Oxor, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peor W rd r1 r2 SOnone :: k) - | Oxorshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peor W rd r1 r2 (transl_shift s a) :: k) - | Oxorimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (logicalimm32 (Peorimm W) (Peor W) rd r1 n k) - | Onot, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Porn W rd XZR r1 SOnone :: k) - | Onotshift s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Porn W rd XZR r1 (transl_shift s a) :: k) - | Obic, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pbic W rd r1 r2 SOnone :: k) - | Obicshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pbic W rd r1 r2 (transl_shift s a) :: k) - | Oorn, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porn W rd r1 r2 SOnone :: k) - | Oornshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porn W rd r1 r2 (transl_shift s a) :: k) - | Oeqv, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peon W rd r1 r2 SOnone :: k) - | Oeqvshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peon W rd r1 r2 (transl_shift s a) :: k) - | Oshl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Plslv W rd r1 r2 :: k) - | Oshr, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pasrv W rd r1 r2 :: k) - | Oshru, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Plsrv W rd r1 r2 :: k) - | Oshrximm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (shrx32 rd r1 n k) - | Ozext s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Pubfiz W rd r1 Int.zero s :: k) - | Osext s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psbfiz W rd r1 Int.zero s :: k) - | Oshlzext s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Pubfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) - | Oshlsext s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psbfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) - | Ozextshr a s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Pubfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) - | Osextshr a s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psbfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k) -(** 64-bit integer arithmetic *) - | Oshiftl s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Porr X rd XZR r1 (transl_shift s a) :: k) - | Oextend x a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (move_extended rd r1 x a k) - (* [Omakelong] and [Ohighlong] should not occur *) - | Olowlong, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - assertion (ireg_eq rd r1); - OK (Pcvtx2w rd :: k) - | Oaddl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Padd X rd r1 r2 SOnone :: k) - | Oaddlshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Padd X rd r1 r2 (transl_shift s a) :: k) - | Oaddlext x a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (arith_extended Paddext (Padd X) rd r1 r2 x a k) - | Oaddlimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (addimm64 rd r1 n k) - | Onegl, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psub X rd XZR r1 SOnone :: k) - | Oneglshift s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psub X rd XZR r1 (transl_shift s a) :: k) - | Osubl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psub X rd r1 r2 SOnone :: k) - | Osublshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psub X rd r1 r2 (transl_shift s a) :: k) - | Osublext x a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (arith_extended Psubext (Psub X) rd r1 r2 x a k) - | Omull, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pmadd X rd r1 r2 XZR :: k) - | Omulladd, a1 :: a2 :: a3 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; - OK (Pmadd X rd r2 r3 r1 :: k) - | Omullsub, a1 :: a2 :: a3 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3; - OK (Pmsub X rd r2 r3 r1 :: k) - | Omullhs, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psmulh rd r1 r2 :: k) - | Omullhu, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pumulh rd r1 r2 :: k) - | Odivl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Psdiv X rd r1 r2 :: k) - | Odivlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pudiv X rd r1 r2 :: k) - | Oandl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pand X rd r1 r2 SOnone :: k) - | Oandlshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pand X rd r1 r2 (transl_shift s a) :: k) - | Oandlimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (logicalimm64 (Pandimm X) (Pand X) rd r1 n k) - | Oorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porr X rd r1 r2 SOnone :: k) - | Oorlshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porr X rd r1 r2 (transl_shift s a) :: k) - | Oorlimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (logicalimm64 (Porrimm X) (Porr X) rd r1 n k) - | Oxorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peor X rd r1 r2 SOnone :: k) - | Oxorlshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peor X rd r1 r2 (transl_shift s a) :: k) - | Oxorlimm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (logicalimm64 (Peorimm X) (Peor X) rd r1 n k) - | Onotl, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Porn X rd XZR r1 SOnone :: k) - | Onotlshift s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Porn X rd XZR r1 (transl_shift s a) :: k) - | Obicl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pbic X rd r1 r2 SOnone :: k) - | Obiclshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pbic X rd r1 r2 (transl_shift s a) :: k) - | Oornl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porn X rd r1 r2 SOnone :: k) - | Oornlshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Porn X rd r1 r2 (transl_shift s a) :: k) - | Oeqvl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peon X rd r1 r2 SOnone :: k) - | Oeqvlshift s a, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Peon X rd r1 r2 (transl_shift s a) :: k) - | Oshll, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Plslv X rd r1 r2 :: k) - | Oshrl, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Pasrv X rd r1 r2 :: k) - | Oshrlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (Plsrv X rd r1 r2 :: k) - | Oshrlximm n, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (shrx64 rd r1 n k) - | Ozextl s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Pubfiz X rd r1 Int.zero s :: k) - | Osextl s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psbfiz X rd r1 Int.zero s :: k) - | Oshllzext s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Pubfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) - | Oshllsext s a, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psbfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) - | Ozextshrl a s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Pubfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) - | Osextshrl a s, a1 :: nil => - do rd <- ireg_of res; do r1 <- ireg_of a1; - OK (Psbfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k) -(** 64-bit floating-point arithmetic *) - | Onegf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfneg D rd rs :: k) - | Oabsf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabs D rd rs :: k) - | Oaddf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfadd D rd rs1 rs2 :: k) - | Osubf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsub D rd rs1 rs2 :: k) - | Omulf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmul D rd rs1 rs2 :: k) - | Odivf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfdiv D rd rs1 rs2 :: k) -(** 32-bit floating-point arithmetic *) - | Onegfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfneg S rd rs :: k) - | Oabsfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabs S rd rs :: k) - | Oaddfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfadd S rd rs1 rs2 :: k) - | Osubfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsub S rd rs1 rs2 :: k) - | Omulfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmul S rd rs1 rs2 :: k) - | Odivfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfdiv S rd rs1 rs2 :: k) - | Osingleoffloat, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfcvtsd rd rs :: k) - | Ofloatofsingle, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfcvtds rd rs :: k) -(** Conversions between int and float *) - | Ointoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzs W D rd rs :: k) - | Ointuoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzu W D rd rs :: k) - | Ofloatofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pscvtf D W rd rs :: k) - | Ofloatofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pucvtf D W rd rs :: k) - | Ointofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzs W S rd rs :: k) - | Ointuofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzu W S rd rs :: k) - | Osingleofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pscvtf S W rd rs :: k) - | Osingleofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pucvtf S W rd rs :: k) - | Olongoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzs X D rd rs :: k) - | Olonguoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzu X D rd rs :: k) - | Ofloatoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pscvtf D X rd rs :: k) - | Ofloatoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pucvtf D X rd rs :: k) - | Olongofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzs X S rd rs :: k) - | Olonguofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfcvtzu X S rd rs :: k) - | Osingleoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pscvtf S X rd rs :: k) - | Osingleoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pucvtf S X rd rs :: k) -(** Boolean tests *) - | Ocmp c, _ => - do rd <- ireg_of res; - transl_cond c args (Pcset rd (cond_for_cond c) :: k) -(** Conditional move *) - | Osel cmp ty, a1 :: a2 :: args => - match preg_of res with - | IR r => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - transl_cond cmp args (Pcsel r r1 r2 (cond_for_cond cmp) :: k) - | FR r => - do r1 <- freg_of a1; do r2 <- freg_of a2; - transl_cond cmp args (Pfsel r r1 r2 (cond_for_cond cmp) :: k) - | _ => - Error(msg "Asmgen.Osel") - end - | _, _ => - Error(msg "Asmgen.transl_op") - end. - -(** Translation of addressing modes *) - -Definition offset_representable (sz: Z) (ofs: int64) : bool := - let isz := Int64.repr sz in - (** either unscaled 9-bit signed *) - Int64.eq ofs (Int64.sign_ext 9 ofs) || - (** or scaled 12-bit unsigned *) - (Int64.eq (Int64.modu ofs isz) Int64.zero - && Int64.ltu ofs (Int64.shl isz (Int64.repr 12))). - -Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg) - (insn: Asm.addressing -> instruction) (k: code) : res code := - match addr, args with - | Aindexed ofs, a1 :: nil => - do r1 <- ireg_of a1; - if offset_representable sz ofs then - OK (insn (ADimm r1 ofs) :: k) - else - OK (loadimm64 X16 ofs (insn (ADreg r1 X16) :: k)) - | Aindexed2, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (insn (ADreg r1 r2) :: k) - | Aindexed2shift a, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - if Int.eq a Int.zero then - OK (insn (ADreg r1 r2) :: k) - else if Int.eq (Int.shl Int.one a) (Int.repr sz) then - OK (insn (ADlsl r1 r2 a) :: k) - else - OK (Padd X X16 r1 r2 (SOlsl a) :: insn (ADimm X16 Int64.zero) :: k) - | Aindexed2ext x a, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - if Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz) then - OK (insn (match x with Xsgn32 => ADsxt r1 r2 a - | Xuns32 => ADuxt r1 r2 a end) :: k) - else - OK (arith_extended Paddext (Padd X) X16 r1 r2 x a - (insn (ADimm X16 Int64.zero) :: k)) - | Aglobal id ofs, nil => - assertion (negb (Archi.pic_code tt)); - if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz - then OK (Padrp X16 id ofs :: insn (ADadr X16 id ofs) :: k) - else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) :: k)) - | Ainstack ofs, nil => - let ofs := Ptrofs.to_int64 ofs in - if offset_representable sz ofs then - OK (insn (ADimm XSP ofs) :: k) - else - OK (loadimm64 X16 ofs (insn (ADreg XSP X16) :: k)) - | _, _ => - Error(msg "Asmgen.transl_addressing") - end. - -(** Translation of loads and stores *) - -Definition transl_load (trap: trapping_mode) - (chunk: memory_chunk) (addr: Op.addressing) - (args: list mreg) (dst: mreg) (k: code) : res code := - match trap with - | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on aarch64") - | TRAP => - match chunk with - | Mint8unsigned => - do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrb W rd) k - | Mint8signed => - do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrsb W rd) k - | Mint16unsigned => - do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrh W rd) k - | Mint16signed => - do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrsh W rd) k - | Mint32 => - do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw rd) k - | Mint64 => - do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx rd) k - | Mfloat32 => - do rd <- freg_of dst; transl_addressing 4 addr args (Pldrs rd) k - | Mfloat64 => - do rd <- freg_of dst; transl_addressing 8 addr args (Pldrd rd) k - | Many32 => - do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw_a rd) k - | Many64 => - do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx_a rd) k - end - end. - -Definition transl_store (chunk: memory_chunk) (addr: Op.addressing) - (args: list mreg) (src: mreg) (k: code) : res code := - match chunk with - | Mint8unsigned | Mint8signed => - do r1 <- ireg_of src; transl_addressing 1 addr args (Pstrb r1) k - | Mint16unsigned | Mint16signed => - do r1 <- ireg_of src; transl_addressing 2 addr args (Pstrh r1) k - | Mint32 => - do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw r1) k - | Mint64 => - do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx r1) k - | Mfloat32 => - do r1 <- freg_of src; transl_addressing 4 addr args (Pstrs r1) k - | Mfloat64 => - do r1 <- freg_of src; transl_addressing 8 addr args (Pstrd r1) k - | Many32 => - do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw_a r1) k - | Many64 => - do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx_a r1) k + | PArith (Pfnmul fsz rd r1 r2) => OK (Asm.Pfnmul fsz rd r1 r2) + + | PLoad (PLd_rd_a Pldrw rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrw rd' a) + | PLoad (PLd_rd_a Pldrw_a rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrw_a rd' a) + | PLoad (PLd_rd_a Pldrx rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrx rd' a) + | PLoad (PLd_rd_a Pldrx_a rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrx_a rd' a) + | PLoad (PLd_rd_a (Pldrb sz) rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrb sz rd' a) + | PLoad (PLd_rd_a (Pldrsb sz) rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrsb sz rd' a) + | PLoad (PLd_rd_a (Pldrh sz) rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrh sz rd' a) + | PLoad (PLd_rd_a (Pldrsh sz) rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrsh sz rd' a) + | PLoad (PLd_rd_a Pldrzw rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrzw rd' a) + | PLoad (PLd_rd_a Pldrsw rd a) => do rd' <- ireg_of_preg rd; OK (Asm.Pldrsw rd' a) + + | PLoad (PLd_rd_a Pldrs rd a) => do rd' <- freg_of_preg rd; OK (Asm.Pldrs rd' a) + | PLoad (PLd_rd_a Pldrd rd a) => do rd' <- freg_of_preg rd; OK (Asm.Pldrd rd' a) + | PLoad (PLd_rd_a Pldrd_a rd a) => do rd' <- freg_of_preg rd; OK (Asm.Pldrd_a rd' a) + + | PLoad (Pldp Pldpw rd1 rd2 chk1 chk2 a) => do rd1' <- ireg_of_preg rd1; + do rd2' <- ireg_of_preg rd2; + OK (Asm.Pldpw rd1 rd2 chk1 chk2 a) + | PLoad (Pldp Pldpx rd1 rd2 chk1 chk2 a) => do rd1' <- ireg_of_preg rd1; + do rd2' <- ireg_of_preg rd2; + OK (Asm.Pldpx rd1 rd2 chk1 chk2 a) + + | PStore (PSt_rs_a Pstrw r a) => do r' <- ireg_of_preg r; OK (Asm.Pstrw r' a) + | PStore (PSt_rs_a Pstrw_a r a) => do r' <- ireg_of_preg r; OK (Asm.Pstrw_a r' a) + | PStore (PSt_rs_a Pstrx r a) => do r' <- ireg_of_preg r; OK (Asm.Pstrx r' a) + | PStore (PSt_rs_a Pstrx_a r a) => do r' <- ireg_of_preg r; OK (Asm.Pstrx_a r' a) + | PStore (PSt_rs_a Pstrb r a) => do r' <- ireg_of_preg r; OK (Asm.Pstrb r' a) + | PStore (PSt_rs_a Pstrh r a) => do r' <- ireg_of_preg r; OK (Asm.Pstrh r' a) + + | PStore (PSt_rs_a Pstrs r a) => do r' <- freg_of_preg r; OK (Asm.Pstrs r' a) + | PStore (PSt_rs_a Pstrd r a) => do r' <- freg_of_preg r; OK (Asm.Pstrd r' a) + | PStore (PSt_rs_a Pstrd_a r a) => do r' <- freg_of_preg r; OK (Asm.Pstrd_a r' a) + + | PStore (Pstp Pstpw rs1 rs2 chk1 chk2 a) => do rs1' <- ireg_of_preg rs1; + do rs2' <- ireg_of_preg rs2; + OK (Asm.Pstpw rs1 rs2 chk1 chk2 a) + | PStore (Pstp Pstpx rs1 rs2 chk1 chk2 a) => do rs1' <- ireg_of_preg rs1; + do rs2' <- ireg_of_preg rs2; + OK (Asm.Pstpx rs1 rs2 chk1 chk2 a) + + | Pallocframe sz linkofs => OK (Asm.Pallocframe sz linkofs) + | Pfreeframe sz linkofs => OK (Asm.Pfreeframe sz linkofs) + + | Ploadsymbol rd id => OK (Asm.Ploadsymbol rd id) + + | Pcvtsw2x rd r1 => OK (Asm.Pcvtsw2x rd r1) + + | Pcvtuw2x rd r1 => OK (Asm.Pcvtuw2x rd r1) + + | Pcvtx2w rd => OK (Asm.Pcvtx2w rd) + | Pnop => OK (Asm.Pnop) end. -(** Register-indexed loads and stores *) - -Definition indexed_memory_access (insn: Asm.addressing -> instruction) - (sz: Z) (base: iregsp) (ofs: ptrofs) (k: code) := - let ofs := Ptrofs.to_int64 ofs in - if offset_representable sz ofs - then insn (ADimm base ofs) :: k - else loadimm64 X16 ofs (insn (ADreg base X16) :: k). - -Definition loadind (base: iregsp) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := - match ty, preg_of dst with - | Tint, IR rd => OK (indexed_memory_access (Pldrw rd) 4 base ofs k) - | Tlong, IR rd => OK (indexed_memory_access (Pldrx rd) 8 base ofs k) - | Tsingle, FR rd => OK (indexed_memory_access (Pldrs rd) 4 base ofs k) - | Tfloat, FR rd => OK (indexed_memory_access (Pldrd rd) 8 base ofs k) - | Tany32, IR rd => OK (indexed_memory_access (Pldrw_a rd) 4 base ofs k) - | Tany64, IR rd => OK (indexed_memory_access (Pldrx_a rd) 8 base ofs k) - | Tany64, FR rd => OK (indexed_memory_access (Pldrd_a rd) 8 base ofs k) - | _, _ => Error (msg "Asmgen.loadind") +Definition cf_instruction_to_instruction (cfi: cf_instruction) : Asm.instruction := + match cfi with + | Pb l => Asm.Pb l + | Pbc c lbl => Asm.Pbc c lbl + | Pbl id sg => Asm.Pbl id sg + | Pbs id sg => Asm.Pbs id sg + | Pblr r sg => Asm.Pblr r sg + | Pbr r sg => Asm.Pbr r sg + | Pret r => Asm.Pret r + | Pcbnz sz r lbl => Asm.Pcbnz sz r lbl + | Pcbz sz r lbl => Asm.Pcbz sz r lbl + | Ptbnz sz r n lbl => Asm.Ptbnz sz r n lbl + | Ptbz sz r n lbl => Asm.Ptbz sz r n lbl + | Pbtbl r1 tbl => Asm.Pbtbl r1 tbl end. -Definition storeind (src: mreg) (base: iregsp) (ofs: ptrofs) (ty: typ) (k: code) := - match ty, preg_of src with - | Tint, IR rd => OK (indexed_memory_access (Pstrw rd) 4 base ofs k) - | Tlong, IR rd => OK (indexed_memory_access (Pstrx rd) 8 base ofs k) - | Tsingle, FR rd => OK (indexed_memory_access (Pstrs rd) 4 base ofs k) - | Tfloat, FR rd => OK (indexed_memory_access (Pstrd rd) 8 base ofs k) - | Tany32, IR rd => OK (indexed_memory_access (Pstrw_a rd) 4 base ofs k) - | Tany64, IR rd => OK (indexed_memory_access (Pstrx_a rd) 8 base ofs k) - | Tany64, FR rd => OK (indexed_memory_access (Pstrd_a rd) 8 base ofs k) - | _, _ => Error (msg "Asmgen.storeind") +Definition control_to_instruction (c: control) := + match c with + | PCtlFlow i => cf_instruction_to_instruction i + | Pbuiltin ef args res => Asm.Pbuiltin ef (List.map (map_builtin_arg DR) args) (map_builtin_res DR res) end. -Definition loadptr (base: iregsp) (ofs: ptrofs) (dst: ireg) (k: code) := - indexed_memory_access (Pldrx dst) 8 base ofs k. - -Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) := - indexed_memory_access (Pstrx src) 8 base ofs k. - -(** Function epilogue *) - -Definition make_epilogue (f: Mach.function) (k: code) := - (* FIXME - Cannot be used because memcpy destroys X30; - issue being discussed with X. Leroy *) - (* if is_leaf_function f - then Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k - else*) loadptr XSP f.(fn_retaddr_ofs) RA - (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k). - -(** Translation of a Mach instruction. *) - -Definition transl_instr (f: Mach.function) (i: Mach.instruction) - (r29_is_parent: bool) (k: code) : res code := - match i with - | Mgetstack ofs ty dst => - loadind XSP ofs ty dst k - | Msetstack src ofs ty => - storeind src XSP ofs ty k - | Mgetparam ofs ty dst => - (* load via the frame pointer if it is valid *) - do c <- loadind X29 ofs ty dst k; - OK (if r29_is_parent then c else loadptr XSP f.(fn_link_ofs) X29 c) - | Mop op args res => - transl_op op args res k - | Mload trap chunk addr args dst => - transl_load trap chunk addr args dst k - | Mstore chunk addr args src => - transl_store chunk addr args src k - | Mcall sig (inl r) => - do r1 <- ireg_of r; OK (Pblr r1 sig :: k) - | Mcall sig (inr symb) => - OK (Pbl symb sig :: k) - | Mtailcall sig (inl r) => - do r1 <- ireg_of r; - OK (make_epilogue f (Pbr r1 sig :: k)) - | Mtailcall sig (inr symb) => - OK (make_epilogue f (Pbs symb sig :: k)) - | Mbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) - | Mlabel lbl => - OK (Plabel lbl :: k) - | Mgoto lbl => - OK (Pb lbl :: k) - | Mcond cond args lbl => - transl_cond_branch cond args lbl k - | Mjumptable arg tbl => - do r <- ireg_of arg; - OK (Pbtbl r tbl :: k) - | Mreturn => - OK (make_epilogue f (Pret RA :: k)) - end. - -(** Translation of a code sequence *) - -Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := - match i with - | Msetstack src ofs ty => before - | Mgetparam ofs ty dst => negb (mreg_eq dst R29) - | Mop op args res => before && negb (mreg_eq res R29) - | _ => false +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll end. -(** This is the naive definition that we no longer use because it - is not tail-recursive. It is kept as specification. *) - -Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := - match il with +Fixpoint unfold_body (lb: list basic) : res Asm.code := + match lb with | nil => OK nil - | i1 :: il' => - do k <- transl_code f il' (it1_is_parent it1p i1); - transl_instr f i1 it1p k + | b :: lb => + (* x_is: x's instructions *) + do b_is <- basic_to_instruction b; + do lb_is <- unfold_body lb; + OK (b_is :: lb_is) end. -(** This is an equivalent definition in continuation-passing style - that runs in constant stack space. *) - -Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction) - (it1p: bool) (k: code -> res code) := - match il with - | nil => k nil - | i1 :: il' => - transl_code_rec f il' (it1_is_parent it1p i1) - (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2) +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil end. -Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) := - transl_code_rec f il it1p (fun c => OK c). +Definition unfold_bblock (bb: bblock) := + let lbl := unfold_label (header bb) in + (* + * With this dynamically checked assumption on a previous optimization we + * can show that [Asmblock.label_pos] and [Asm.label_pos] retrieve the same + * exact address. Maintaining this property allows us to use the simple + * formulation of match_states defined as equality. + * Otherwise we would have to deal with the case of a basic block header + * that has multiple labels. Asmblock.label_pos will, for all labels, point + * to the same location at the beginning of the basic block. Asm.label_pos + * on the other hand could return a position pointing into the original + * basic block. + *) + if zle (list_length_z (header bb)) 1 then + do bo_is <- unfold_body (body bb); + OK (lbl ++ bo_is ++ unfold_exit (exit bb)) + else + Error (msg "Asmgen.unfold_bblock: Multiple labels were generated."). + +Fixpoint unfold (bbs: Asmblock.bblocks) : res Asm.code := + match bbs with + | nil => OK (nil) + | bb :: bbs' => + do bb_is <- unfold_bblock bb; + do bbs'_is <- unfold bbs'; + OK (bb_is ++ bbs'_is) + end. -(** Translation of a whole function. Note that we must check - that the generated code contains less than [2^32] instructions, - otherwise the offset part of the [PC] code pointer could wrap - around, leading to incorrect executions. *) +Definition transf_function (f: Asmblock.function) : res Asm.function := + do c <- unfold (Asmblock.fn_blocks f); + if zlt Ptrofs.max_unsigned (list_length_z c) + then Error (msg "Asmgen.trans_function: code size exceeded") + else OK {| Asm.fn_sig := Asmblock.fn_sig f; Asm.fn_code := c |}. -Definition transl_function (f: Mach.function) := - do c <- transl_code' f f.(Mach.fn_code) true; - OK (mkfunction f.(Mach.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) :: - storeptr RA XSP f.(fn_retaddr_ofs) c)). +Definition transf_fundef (f: Asmblock.fundef) : res Asm.fundef := + transf_partial_fundef transf_function f. -Definition transf_function (f: Mach.function) : res Asm.function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) - then Error (msg "code size exceeded") - else OK tf. +Definition transf_program (p: Asmblock.program) : res Asm.program := + transform_partial_program transf_fundef p. -Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := - transf_partial_fundef transf_function f. +End Asmblock_TRANSF. Definition transf_program (p: Mach.program) : res Asm.program := - transform_partial_program transf_fundef p. + let mbp := Machblockgen.transf_program p in + do abp <- Asmblockgen.transf_program mbp; + do abp' <- (time "PostpassScheduling total oracle+verification" PostpassScheduling.transf_program) abp; + Asmblock_TRANSF.transf_program abp'. diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v index 6831509f..a33f90b3 100644 --- a/aarch64/Asmgenproof.v +++ b/aarch64/Asmgenproof.v @@ -1,24 +1,35 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, Collège de France and INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for AArch64 code generation. *) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Léo Gourdin UGA, VERIMAG *) +(* Justus Fasse UGA, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Mach Conventions Asm. -Require Import Asmgen Asmgenproof0 Asmgenproof1. +Require Import Op Locations Machblock Conventions Asm Asmblock. +Require Machblockgenproof Asmblockgenproof PostpassSchedulingproof. +Require Import Asmgen. +Require Import Axioms. +Require Import IterList. +Require Import Ring Lia. -Definition match_prog (p: Mach.program) (tp: Asm.program) := +Module Asmblock_PRESERVATION. + +Import Asmblock_TRANSF. + +Definition match_prog (p: Asmblock.program) (tp: Asm.program) := match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. Lemma transf_program_match: @@ -29,20 +40,36 @@ Qed. Section PRESERVATION. -Variable prog: Mach.program. +Variable prog: Asmblock.program. Variable tprog: Asm.program. Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. +Definition lk :aarch64_linker := {| Asmblock.symbol_low:=Asm.symbol_low tge; Asmblock.symbol_high:=Asm.symbol_high tge|}. + Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof (Genv.find_symbol_match TRANSF). +Lemma symbol_addresses_preserved: + forall (s: ident) (ofs: ptrofs), + Genv.symbol_address tge s ofs = Genv.symbol_address ge s ofs. +Proof. + intros; unfold Genv.symbol_address; rewrite symbols_preserved; reflexivity. +Qed. + Lemma senv_preserved: Senv.equiv ge tge. Proof (Genv.senv_match TRANSF). +Lemma symbol_high_low: forall (id: ident) (ofs: ptrofs), + Val.addl (Asmblock.symbol_high lk id ofs) (Asmblock.symbol_low lk id ofs) = Genv.symbol_address ge id ofs. +Proof. + unfold lk; simpl. intros; rewrite Asm.symbol_high_low; unfold Genv.symbol_address; + rewrite symbols_preserved; reflexivity. +Qed. + Lemma functions_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> @@ -50,1052 +77,2241 @@ Lemma functions_translated: Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. Proof (Genv.find_funct_ptr_transf_partial TRANSF). -Lemma functions_transl: - forall fb f tf, +Lemma internal_functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some (Internal f) -> + exists tf, + Genv.find_funct_ptr tge b = Some (Internal tf) /\ transf_function f = OK tf. +Proof. + intros; exploit functions_translated; eauto. + intros (x & FIND & TRANSf). + apply bind_inversion in TRANSf. + destruct TRANSf as (tf & TRANSf & X). + inv X. + eauto. +Qed. + +Lemma internal_functions_unfold: + forall b f, + Genv.find_funct_ptr ge b = Some (Internal f) -> + exists tc, + Genv.find_funct_ptr tge b = Some (Internal (Asm.mkfunction (fn_sig f) tc)) + /\ unfold (fn_blocks f) = OK tc + /\ list_length_z tc <= Ptrofs.max_unsigned. +Proof. + intros. + exploit internal_functions_translated; eauto. + intros (tf & FINDtf & TRANStf). + unfold transf_function in TRANStf. + monadInv TRANStf. + destruct (zlt _ _); try congruence. + inv EQ. inv EQ0. + eexists; intuition eauto. + lia. +Qed. + + +Inductive is_nth_inst (bb: bblock) (n:Z) (i:Asm.instruction): Prop := + | is_nth_label l: + list_nth_z (header bb) n = Some l -> + i = Asm.Plabel l -> + is_nth_inst bb n i + | is_nth_basic bi: + list_nth_z (body bb) (n - list_length_z (header bb)) = Some bi -> + basic_to_instruction bi = OK i -> + is_nth_inst bb n i + | is_nth_ctlflow cfi: + (exit bb) = Some cfi -> + n = size bb - 1 -> + i = control_to_instruction cfi -> + is_nth_inst bb n i. + +(* Asmblock and Asm share the same definition of state *) +Definition match_states (s1 s2 : state) := s1 = s2. + +Inductive match_internal: forall n, state -> state -> Prop := + | match_internal_intro n rs1 m1 rs2 m2 + (MEM: m1 = m2) + (AG: forall r, r <> PC -> rs1 r = rs2 r) + (AGPC: Val.offset_ptr (rs1 PC) (Ptrofs.repr n) = rs2 PC) + : match_internal n (State rs1 m1) (State rs2 m2). + +Lemma match_internal_set_parallel: + forall n rs1 m1 rs2 m2 r val, + match_internal n (State rs1 m1) (State rs2 m2) -> + r <> PC -> + match_internal n (State (rs1#r <- val) m1) (State (rs2#r <- val ) m2). +Proof. + intros n rs1 m1 rs2 m2 r v MI. + inversion MI; constructor; auto. + - intros r' NOTPC. + unfold Pregmap.set; rewrite AG. reflexivity. assumption. + - unfold Pregmap.set; destruct (PregEq.eq PC r); congruence. +Qed. + +Lemma agree_match_states: + forall rs1 m1 rs2 m2, + match_states (State rs1 m1) (State rs2 m2) -> + forall r : preg, rs1#r = rs2#r. +Proof. + intros. + unfold match_states in *. + assert (rs1 = rs2) as EQ. { congruence. } + rewrite EQ. reflexivity. +Qed. + +Lemma match_states_set_parallel: + forall rs1 m1 rs2 m2 r v, + match_states (State rs1 m1) (State rs2 m2) -> + match_states (State (rs1#r <- v) m1) (State (rs2#r <- v) m2). +Proof. + intros; unfold match_states in *. + assert (rs1 = rs2) as RSEQ. { congruence. } + assert (m1 = m2) as MEQ. { congruence. } + rewrite RSEQ in *; rewrite MEQ in *; unfold Pregmap.set; reflexivity. +Qed. + +(* match_internal from match_states *) +Lemma mi_from_ms: + forall rs1 m1 rs2 m2 b ofs, + match_states (State rs1 m1) (State rs2 m2) -> + rs1#PC = Vptr b ofs -> + match_internal 0 (State rs1 m1) (State rs2 m2). +Proof. + intros rs1 m1 rs2 m2 b ofs MS PCVAL. + inv MS; constructor; auto; unfold Val.offset_ptr; + rewrite PCVAL; rewrite Ptrofs.add_zero; reflexivity. +Qed. + +Lemma transf_initial_states: + forall s1, Asmblock.initial_state prog s1 -> + exists s2, Asm.initial_state tprog s2 /\ match_states s1 s2. +Proof. + intros ? INIT_s1. + inversion INIT_s1 as (m, ?, ge0, rs). unfold ge0 in *. + econstructor; split. + - econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + - rewrite (match_program_main TRANSF); rewrite symbol_addresses_preserved. + unfold rs; reflexivity. +Qed. + +Lemma transf_final_states: + forall s1 s2 r, + match_states s1 s2 -> Asmblock.final_state s1 r -> Asm.final_state s2 r. +Proof. + intros s1 s2 r MATCH FINAL_s1. + inv FINAL_s1; inv MATCH; constructor; assumption. +Qed. + +Definition max_pos (f : Asm.function) := list_length_z f.(Asm.fn_code). + +Lemma functions_bound_max_pos: forall fb f tf, Genv.find_funct_ptr ge fb = Some (Internal f) -> transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -(** * Properties of control flow *) - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - omega. -Qed. - -Lemma exec_straight_exec: - forall fb f c ep tf tc c' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - exec_straight tge tf tc rs m c' rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - intros. inv H. - eapply exec_straight_steps_1; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. -Qed. - -Lemma exec_straight_at: - forall fb f c ep tf tc c' ep' tc' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - transl_code f c' ep' = OK tc' -> - exec_straight tge tf tc rs m tc' rs' m' -> - transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. -Proof. - intros. inv H. - exploit exec_straight_steps_2; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. - intros [ofs' [PC' CT']]. - rewrite PC'. constructor; auto. -Qed. - -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) + max_pos tf <= Ptrofs.max_unsigned. +Proof. + intros fb f tf FINDf TRANSf. + unfold transf_function in TRANSf. + apply bind_inversion in TRANSf. + destruct TRANSf as (c & TRANSf). + destruct TRANSf as (_ & TRANSf). + destruct (zlt _ _). + - inversion TRANSf. + - unfold max_pos. + assert (Asm.fn_code tf = c) as H. { inversion TRANSf as (H'); auto. } + rewrite H; lia. +Qed. -Section TRANSL_LABEL. +Lemma one_le_max_unsigned: + 1 <= Ptrofs.max_unsigned. +Proof. + unfold Ptrofs.max_unsigned; simpl; unfold Ptrofs.wordsize; + unfold Wordsize_Ptrofs.wordsize; destruct Archi.ptr64; simpl; lia. +Qed. -Remark loadimm_z_label: forall sz rd l k, tail_nolabel k (loadimm_z sz rd l k). -Proof. - intros; destruct l as [ | [n1 p1] l]; simpl; TailNoLabel. - induction l as [ | [n p] l]; simpl; TailNoLabel. +(* NB: does not seem useful anymore, with the [exec_header_simulation] proof below +Lemma match_internal_exec_label: + forall n rs1 m1 rs2 m2 l fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + match_internal n (State rs1 m1) (State rs2 m2) -> + n >= 0 -> + (* There is no step if n is already max_pos *) + n < (max_pos tf) -> + exists rs2' m2', Asm.exec_instr tge tf (Asm.Plabel l) rs2 m2 = Next rs2' m2' + /\ match_internal (n+1) (State rs1 m1) (State rs2' m2'). +Proof. + intros. (* XXX auto generated names *) + unfold Asm.exec_instr. + eexists; eexists; split; eauto. + inversion H1; constructor; auto. + - intros; unfold Asm.nextinstr; unfold Pregmap.set; + destruct (PregEq.eq r PC); auto; contradiction. + - unfold Asm.nextinstr; rewrite Pregmap.gss; unfold Ptrofs.one. + rewrite <- AGPC; rewrite Val.offset_ptr_assoc; unfold Ptrofs.add; + rewrite Ptrofs.unsigned_repr. rewrite Ptrofs.unsigned_repr; trivial. + + split. + * apply Z.le_0_1. + * apply one_le_max_unsigned. + + split. + * apply Z.ge_le; assumption. + * rewrite <- functions_bound_max_pos; eauto; lia. Qed. +*) -Remark loadimm_n_label: forall sz rd l k, tail_nolabel k (loadimm_n sz rd l k). -Proof. - intros; destruct l as [ | [n1 p1] l]; simpl; TailNoLabel. - induction l as [ | [n p] l]; simpl; TailNoLabel. +Lemma incrPC_agree_but_pc: + forall rs r ofs, + r <> PC -> + (incrPC ofs rs)#r = rs#r. +Proof. + intros rs r ofs NOTPC. + unfold incrPC; unfold Pregmap.set; destruct (PregEq.eq r PC). + - contradiction. + - reflexivity. Qed. -Remark loadimm_label: forall sz rd n k, tail_nolabel k (loadimm sz rd n k). +Lemma bblock_non_empty bb: body bb <> nil \/ exit bb <> None. Proof. - unfold loadimm; intros. destruct Nat.leb; [apply loadimm_z_label|apply loadimm_n_label]. + destruct bb. simpl. + unfold non_empty_bblockb in correct. + unfold non_empty_body, non_empty_exit, Is_true in correct. + destruct body, exit. + - right. discriminate. + - contradiction. + - right. discriminate. + - left. discriminate. Qed. -Hint Resolve loadimm_label: labels. -Remark loadimm32_label: forall r n k, tail_nolabel k (loadimm32 r n k). +Lemma list_length_z_aux_increase A (l: list A): forall acc, + list_length_z_aux l acc >= acc. Proof. - unfold loadimm32; intros. destruct (is_logical_imm32 n); TailNoLabel. + induction l; simpl; intros. + - lia. + - generalize (IHl (Z.succ acc)). lia. Qed. -Hint Resolve loadimm32_label: labels. -Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k). +Lemma bblock_size_aux_pos bb: list_length_z (body bb) + Z.of_nat (length_opt (exit bb)) >= 1. Proof. - unfold loadimm64; intros. destruct (is_logical_imm64 n); TailNoLabel. + destruct (bblock_non_empty bb), (body bb) as [|hd tl], (exit bb); simpl; + try (congruence || lia); + unfold list_length_z; simpl; + generalize (list_length_z_aux_increase _ tl 1); lia. Qed. -Hint Resolve loadimm64_label: labels. -Remark addimm_aux: forall insn rd r1 n k, - (forall rd r1 n, nolabel (insn rd r1 n)) -> - tail_nolabel k (addimm_aux insn rd r1 n k). + +Lemma list_length_add_acc A (l : list A) acc: + list_length_z_aux l acc = (list_length_z l) + acc. Proof. - unfold addimm_aux; intros. - destruct Z.eqb. TailNoLabel. destruct Z.eqb; TailNoLabel. + unfold list_length_z, list_length_z_aux. simpl. + fold list_length_z_aux. + rewrite (list_length_z_aux_shift l acc 0). + lia. Qed. -Remark addimm32_label: forall rd r1 n k, tail_nolabel k (addimm32 rd r1 n k). +Lemma list_length_z_cons A hd (tl : list A): + list_length_z (hd :: tl) = list_length_z tl + 1. Proof. - unfold addimm32; intros. - destruct Int.eq. apply addimm_aux; intros; red; auto. - destruct Int.eq. apply addimm_aux; intros; red; auto. - destruct Int.lt; eapply tail_nolabel_trans; TailNoLabel. + unfold list_length_z; simpl; rewrite list_length_add_acc; reflexivity. Qed. -Hint Resolve addimm32_label: labels. -Remark addimm64_label: forall rd r1 n k, tail_nolabel k (addimm64 rd r1 n k). +Lemma bblock_size_aux bb: size bb = list_length_z (header bb) + list_length_z (body bb) + Z.of_nat (length_opt (exit bb)). Proof. - unfold addimm64; intros. - destruct Int64.eq. apply addimm_aux; intros; red; auto. - destruct Int64.eq. apply addimm_aux; intros; red; auto. - destruct Int64.lt; eapply tail_nolabel_trans; TailNoLabel. + unfold size. + repeat (rewrite list_length_z_nat). repeat (rewrite Nat2Z.inj_add). reflexivity. Qed. -Hint Resolve addimm64_label: labels. -Remark logicalimm32_label: forall insn1 insn2 rd r1 n k, - (forall rd r1 n, nolabel (insn1 rd r1 n)) -> - (forall rd r1 r2 s, nolabel (insn2 rd r1 r2 s)) -> - tail_nolabel k (logicalimm32 insn1 insn2 rd r1 n k). +Lemma header_size_lt_block_size bb: + list_length_z (header bb) < size bb. Proof. - unfold logicalimm32; intros. - destruct (is_logical_imm32 n). TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. + rewrite bblock_size_aux. + generalize (bblock_non_empty bb); intros NEMPTY; destruct NEMPTY as [HDR|EXIT]. + - destruct (body bb); try contradiction; rewrite list_length_z_cons; + repeat rewrite list_length_z_nat; lia. + - destruct (exit bb); try contradiction; simpl; repeat rewrite list_length_z_nat; lia. Qed. -Remark logicalimm64_label: forall insn1 insn2 rd r1 n k, - (forall rd r1 n, nolabel (insn1 rd r1 n)) -> - (forall rd r1 r2 s, nolabel (insn2 rd r1 r2 s)) -> - tail_nolabel k (logicalimm64 insn1 insn2 rd r1 n k). +Lemma body_size_le_block_size bb: + list_length_z (body bb) <= size bb. Proof. - unfold logicalimm64; intros. - destruct (is_logical_imm64 n). TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. + rewrite bblock_size_aux; repeat rewrite list_length_z_nat; lia. Qed. -Remark move_extended_label: forall rd r1 ex a k, tail_nolabel k (move_extended rd r1 ex a k). + +Lemma bblock_size_pos bb: size bb >= 1. Proof. - unfold move_extended, move_extended_base; intros. destruct Int.eq, ex; TailNoLabel. + rewrite (bblock_size_aux bb). + generalize (bblock_size_aux_pos bb). + generalize (list_length_z_pos (header bb)). + lia. Qed. -Hint Resolve move_extended_label: labels. -Remark arith_extended_label: forall insnX insnS rd r1 r2 ex a k, - (forall rd r1 r2 x, nolabel (insnX rd r1 r2 x)) -> - (forall rd r1 r2 s, nolabel (insnS rd r1 r2 s)) -> - tail_nolabel k (arith_extended insnX insnS rd r1 r2 ex a k). +Lemma unfold_car_cdr bb bbs tc: + unfold (bb :: bbs) = OK tc -> + exists tbb tc', unfold_bblock bb = OK tbb + /\ unfold bbs = OK tc' + /\ unfold (bb :: bbs) = OK (tbb ++ tc'). Proof. - unfold arith_extended; intros. destruct Int.ltu. - TailNoLabel. - destruct ex; simpl; TailNoLabel. + intros UNFOLD. + assert (UF := UNFOLD). + unfold unfold in UNFOLD. + apply bind_inversion in UNFOLD. destruct UNFOLD as (? & UBB). destruct UBB as (UBB & REST). + apply bind_inversion in REST. destruct REST as (? & UNFOLD'). + fold unfold in UNFOLD'. destruct UNFOLD' as (UNFOLD' & UNFOLD). + rewrite <- UNFOLD in UF. + eauto. Qed. -Remark loadsymbol_label: forall r id ofs k, tail_nolabel k (loadsymbol r id ofs k). +Lemma unfold_cdr bb bbs tc: + unfold (bb :: bbs) = OK tc -> + exists tc', unfold bbs = OK tc'. Proof. - intros; unfold loadsymbol. - destruct (Archi.pic_code tt); TailNoLabel. destruct Ptrofs.eq; TailNoLabel. -Qed. -Hint Resolve loadsymbol_label: labels. + intros; exploit unfold_car_cdr; eauto. intros (_ & ? & _ & ? & _). + eexists; eauto. +Qed. -Remark transl_cond_label: forall cond args k c, - transl_cond cond args k = OK c -> tail_nolabel k c. +Lemma unfold_car bb bbs tc: + unfold (bb :: bbs) = OK tc -> + exists tbb, unfold_bblock bb = OK tbb. Proof. - unfold transl_cond; intros; destruct cond; TailNoLabel. -- destruct is_arith_imm32; TailNoLabel. destruct is_arith_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_arith_imm32; TailNoLabel. destruct is_arith_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_logical_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_logical_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_arith_imm64; TailNoLabel. destruct is_arith_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_arith_imm64; TailNoLabel. destruct is_arith_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_logical_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. -- destruct is_logical_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. + intros; exploit unfold_car_cdr; eauto. intros (? & _ & ? & _ & _). + eexists; eauto. Qed. -Remark transl_cond_branch_default_label: forall cond args lbl k c, - transl_cond_branch_default cond args lbl k = OK c -> tail_nolabel k c. +Lemma all_blocks_translated: + forall bbs tc, + unfold bbs = OK tc -> + forall bb, In bb bbs -> + exists c, unfold_bblock bb = OK c. Proof. - unfold transl_cond_branch_default; intros. - eapply tail_nolabel_trans; [eapply transl_cond_label;eauto|TailNoLabel]. + induction bbs as [| bb bbs IHbbs]. + - contradiction. + - intros ? UNFOLD ? IN. + (* unfold proceeds by unfolding the basic block at the head of the list and + * then recurring *) + exploit unfold_car_cdr; eauto. intros (? & ? & ? & ? & _). + (* basic block is either in head or tail *) + inversion IN as [EQ | NEQ]. + + rewrite <- EQ; eexists; eauto. + + eapply IHbbs; eauto. Qed. -Hint Resolve transl_cond_branch_default_label: labels. -Remark transl_cond_branch_label: forall cond args lbl k c, - transl_cond_branch cond args lbl k = OK c -> tail_nolabel k c. +Lemma entire_body_translated: + forall lbi tc, + unfold_body lbi = OK tc -> + forall bi, In bi lbi -> + exists bi', basic_to_instruction bi = OK bi'. Proof. - unfold transl_cond_branch; intros; destruct args; TailNoLabel; destruct cond; TailNoLabel. -- destruct c0; TailNoLabel. -- destruct c0; TailNoLabel. -- destruct (Int.is_power2 n); TailNoLabel. -- destruct (Int.is_power2 n); TailNoLabel. -- destruct c0; TailNoLabel. -- destruct c0; TailNoLabel. -- destruct (Int64.is_power2' n); TailNoLabel. -- destruct (Int64.is_power2' n); TailNoLabel. + induction lbi as [| a lbi IHlbi]. + - intros. contradiction. + - intros tc UNFOLD_BODY bi IN. + unfold unfold_body in UNFOLD_BODY. apply bind_inversion in UNFOLD_BODY. + destruct UNFOLD_BODY as (? & TRANSbi & REST). + apply bind_inversion in REST. destruct REST as (? & UNFOLD_BODY' & ?). + fold unfold_body in UNFOLD_BODY'. + + inversion IN as [EQ | NEQ]. + + rewrite <- EQ; eauto. + + eapply IHlbi; eauto. Qed. -Remark transl_op_label: - forall op args r k c, - transl_op op args r k = OK c -> tail_nolabel k c. +Lemma bblock_in_bblocks bbs bb: forall + tc pos + (UNFOLD: unfold bbs = OK tc) + (FINDBB: find_bblock pos bbs = Some bb), + In bb bbs. Proof. - unfold transl_op; intros; destruct op; TailNoLabel. -- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. -- destruct (Float.eq_dec n Float.zero); TailNoLabel. -- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. -- apply logicalimm32_label; unfold nolabel; auto. -- apply logicalimm32_label; unfold nolabel; auto. -- apply logicalimm32_label; unfold nolabel; auto. -- unfold shrx32. destruct (Int.eq _ _); try destruct (Int.eq _ _); TailNoLabel. -- apply arith_extended_label; unfold nolabel; auto. -- apply arith_extended_label; unfold nolabel; auto. -- apply logicalimm64_label; unfold nolabel; auto. -- apply logicalimm64_label; unfold nolabel; auto. -- apply logicalimm64_label; unfold nolabel; auto. -- unfold shrx64. destruct (Int.eq _ _); try destruct (Int.eq _ _); TailNoLabel. -- eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel. -- destruct (preg_of r); try discriminate; TailNoLabel; - (eapply tail_nolabel_trans; [eapply transl_cond_label; eauto | TailNoLabel]). + induction bbs as [| b bbs IH]. + - intros. inversion FINDBB. + - destruct pos. + + intros. inversion FINDBB as (EQ). rewrite <- EQ. apply in_eq. + + intros. + exploit unfold_cdr; eauto. intros (tc' & UNFOLD'). + unfold find_bblock in FINDBB. simpl in FINDBB. + fold find_bblock in FINDBB. + apply in_cons. eapply IH; eauto. + + intros. inversion FINDBB. Qed. -Remark transl_addressing_label: - forall sz addr args insn k c, - transl_addressing sz addr args insn k = OK c -> - (forall ad, nolabel (insn ad)) -> - tail_nolabel k c. +Lemma blocks_translated tc pos bbs bb: forall + (UNFOLD: unfold bbs = OK tc) + (FINDBB: find_bblock pos bbs = Some bb), + exists tbb, unfold_bblock bb = OK tbb. Proof. - unfold transl_addressing; intros; destruct addr; TailNoLabel; - eapply tail_nolabel_trans; TailNoLabel. - eapply tail_nolabel_trans. apply arith_extended_label; unfold nolabel; auto. TailNoLabel. + intros; exploit bblock_in_bblocks; eauto; intros; + eapply all_blocks_translated; eauto. Qed. -Remark transl_load_label: - forall trap chunk addr args dst k c, - transl_load trap chunk addr args dst k = OK c -> tail_nolabel k c. +Lemma size_header b pos f bb: forall + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock pos (fn_blocks f) = Some bb), + list_length_z (header bb) <= 1. Proof. - unfold transl_load; intros; destruct trap; try discriminate; destruct chunk; TailNoLabel; eapply transl_addressing_label; eauto; unfold nolabel; auto. + intros. + exploit internal_functions_unfold; eauto. + intros (tc & FINDtf & TRANStf & ?). + exploit blocks_translated; eauto. intros TBB. + + unfold unfold_bblock in TBB. + destruct (zle (list_length_z (header bb)) 1). + - assumption. + - destruct TBB as (? & TBB). discriminate TBB. Qed. -Remark transl_store_label: - forall chunk addr args src k c, - transl_store chunk addr args src k = OK c -> tail_nolabel k c. +Lemma list_nth_z_neg A (l: list A): forall n, + n < 0 -> list_nth_z l n = None. Proof. - unfold transl_store; intros; destruct chunk; TailNoLabel; eapply transl_addressing_label; eauto; unfold nolabel; auto. + induction l; simpl; auto. + intros n H; destruct (zeq _ _); (try eapply IHl); lia. Qed. -Remark indexed_memory_access_label: - forall insn sz base ofs k, - (forall ad, nolabel (insn ad)) -> - tail_nolabel k (indexed_memory_access insn sz base ofs k). +Lemma find_bblock_neg bbs: forall pos, + pos < 0 -> find_bblock pos bbs = None. Proof. - unfold indexed_memory_access; intros. destruct offset_representable. - TailNoLabel. - eapply tail_nolabel_trans; TailNoLabel. + induction bbs; simpl; auto. + intros. destruct (zlt pos 0). { reflexivity. } + destruct (zeq pos 0); contradiction. Qed. -Remark loadind_label: - forall base ofs ty dst k c, - loadind base ofs ty dst k = OK c -> tail_nolabel k c. +Lemma equal_header_size bb: + length (header bb) = length (unfold_label (header bb)). Proof. - unfold loadind; intros. - destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I. + induction (header bb); auto. + simpl. rewrite IHl. auto. Qed. -Remark storeind_label: - forall src base ofs ty k c, - storeind src base ofs ty k = OK c -> tail_nolabel k c. +Lemma equal_body_size: + forall bb tb, + unfold_body (body bb) = OK tb -> + length (body bb) = length tb. Proof. - unfold storeind; intros. - destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I. + intros bb. induction (body bb). + - simpl. intros ? H. inversion H. auto. + - intros tb H. simpl in H. apply bind_inversion in H. destruct H as (? & BI & TAIL). + apply bind_inversion in TAIL. destruct TAIL as (tb' & BODY' & CONS). inv CONS. + simpl. specialize (IHl tb' BODY'). rewrite IHl. reflexivity. Qed. -Remark loadptr_label: - forall base ofs dst k, tail_nolabel k (loadptr base ofs dst k). +Lemma equal_exit_size bb: + length_opt (exit bb) = length (unfold_exit (exit bb)). Proof. - intros. apply indexed_memory_access_label. unfold nolabel; auto. + destruct (exit bb); trivial. Qed. -Remark storeptr_label: - forall src base ofs k, tail_nolabel k (storeptr src base ofs k). +Lemma bblock_size_preserved bb tb: + unfold_bblock bb = OK tb -> + size bb = list_length_z tb. Proof. - intros. apply indexed_memory_access_label. unfold nolabel; auto. + unfold unfold_bblock. intros UNFOLD_BBLOCK. + destruct (zle (list_length_z (header bb)) 1). 2: { inversion UNFOLD_BBLOCK. } + apply bind_inversion in UNFOLD_BBLOCK. destruct UNFOLD_BBLOCK as (? & UNFOLD_BODY & CONS). + inversion CONS. + unfold size. + rewrite equal_header_size, equal_exit_size. + erewrite equal_body_size; eauto. + rewrite list_length_z_nat. + repeat (rewrite app_length). + rewrite plus_assoc. auto. Qed. -Remark make_epilogue_label: - forall f k, tail_nolabel k (make_epilogue f k). +Lemma size_of_blocks_max_pos_aux: + forall bbs tbbs pos bb, + find_bblock pos bbs = Some bb -> + unfold bbs = OK tbbs -> + pos + size bb <= list_length_z tbbs. Proof. - unfold make_epilogue; intros. - (* FIXME destruct is_leaf_function. - { TailNoLabel. } *) - eapply tail_nolabel_trans. - apply loadptr_label. - TailNoLabel. + induction bbs as [| bb ? IHbbs]. + - intros tbbs ? ? FINDBB; inversion FINDBB. + - simpl; intros tbbs pos bb' FINDBB UNFOLD. + apply bind_inversion in UNFOLD; destruct UNFOLD as (tbb & UNFOLD_BBLOCK & H). + apply bind_inversion in H; destruct H as (tbbs' & UNFOLD & CONS). + inv CONS. + destruct (zlt pos 0). { discriminate FINDBB. } + destruct (zeq pos 0). + + inv FINDBB. + exploit bblock_size_preserved; eauto; intros SIZE; rewrite SIZE. + repeat (rewrite list_length_z_nat). rewrite app_length, Nat2Z.inj_add. + lia. + + generalize (IHbbs tbbs' (pos - size bb) bb' FINDBB UNFOLD). intros IH. + exploit bblock_size_preserved; eauto; intros SIZE. + repeat (rewrite list_length_z_nat); rewrite app_length. + rewrite Nat2Z.inj_add; repeat (rewrite <- list_length_z_nat). + lia. Qed. -Lemma transl_instr_label: - forall f i ep k c, - transl_instr f i ep k = OK c -> - match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. +Lemma size_of_blocks_max_pos pos f tf bi: + find_bblock pos (fn_blocks f) = Some bi -> + transf_function f = OK tf -> + pos + size bi <= max_pos tf. Proof. - unfold transl_instr; intros; destruct i; TailNoLabel. -- eapply loadind_label; eauto. -- eapply storeind_label; eauto. -- destruct ep. eapply loadind_label; eauto. - eapply tail_nolabel_trans. apply loadptr_label. eapply loadind_label; eauto. -- eapply transl_op_label; eauto. -- eapply transl_load_label; eauto. -- eapply transl_store_label; eauto. -- destruct s0; monadInv H; TailNoLabel. -- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]). -- eapply transl_cond_branch_label; eauto. -- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]. + unfold transf_function, max_pos. + intros FINDBB UNFOLD. + apply bind_inversion in UNFOLD. destruct UNFOLD as (? & UNFOLD & H). + destruct (zlt Ptrofs.max_unsigned (list_length_z x)). { discriminate H. } + inv H. simpl. + eapply size_of_blocks_max_pos_aux; eauto. Qed. -Lemma transl_instr_label': - forall lbl f i ep k c, - transl_instr f i ep k = OK c -> - find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. +Lemma unfold_bblock_not_nil bb: + unfold_bblock bb = OK nil -> False. Proof. - intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply B). - intros. subst c. simpl. auto. + intros. + exploit bblock_size_preserved; eauto. unfold list_length_z; simpl. intros SIZE. + generalize (bblock_size_pos bb). intros SIZE'. lia. Qed. -Lemma transl_code_label: - forall lbl f c ep tc, - transl_code f c ep = OK tc -> - match Mach.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' - end. +(* same proof as list_nth_z_range (Coqlib) *) +Lemma find_instr_range: + forall c n i, + Asm.find_instr n c = Some i -> 0 <= n < list_length_z c. Proof. induction c; simpl; intros. - inv H. auto. - monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). - generalize (Mach.is_label_correct lbl a). - destruct (Mach.is_label lbl a); intros. - subst a. simpl in EQ. exists x; auto. - eapply IHc; eauto. + discriminate. + rewrite list_length_z_cons. destruct (zeq n 0). + generalize (list_length_z_pos c); lia. + exploit IHc; eauto. lia. Qed. -Lemma transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match Mach.find_label lbl f.(Mach.fn_code) with - | None => find_label lbl tf.(fn_code) = None - | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc - end. +Lemma find_instr_tail: + forall tbb pos c i, + Asm.find_instr pos c = Some i -> + Asm.find_instr (pos + list_length_z tbb) (tbb ++ c) = Some i. Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. - monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. - simpl. destruct (storeptr_label X30 XSP (fn_retaddr_ofs f) x) as [A B]; rewrite B. - eapply transl_code_label; eauto. + induction tbb as [| ? ? IHtbb]. + - intros. unfold list_length_z; simpl. rewrite Z.add_0_r. assumption. + - intros. rewrite list_length_z_cons. simpl. + destruct (zeq (pos + (list_length_z tbb + 1)) 0). + + exploit find_instr_range; eauto. intros POS_RANGE. + generalize (list_length_z_pos tbb). lia. + + replace (pos + (list_length_z tbb + 1) - 1) with (pos + list_length_z tbb) by lia. + eapply IHtbb; eauto. Qed. -End TRANSL_LABEL. +Lemma size_of_blocks_bounds fb pos f bi: + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_bblock pos (fn_blocks f) = Some bi -> + pos + size bi <= Ptrofs.max_unsigned. +Proof. + intros; exploit internal_functions_translated; eauto. + intros (tf & _ & TRANSf). + assert (pos + size bi <= max_pos tf). { eapply size_of_blocks_max_pos; eauto. } + assert (max_pos tf <= Ptrofs.max_unsigned). { eapply functions_bound_max_pos; eauto. } + lia. +Qed. -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated Asm code. *) +Lemma find_instr_bblock_tail: + forall tbb bb pos c i, + Asm.find_instr pos c = Some i -> + unfold_bblock bb = OK tbb -> + Asm.find_instr (pos + size bb ) (tbb ++ c) = Some i. +Proof. + induction tbb. + - intros. exploit unfold_bblock_not_nil; eauto. intros. contradiction. + - intros. simpl. + destruct (zeq (pos + size bb) 0). + + (* absurd *) + exploit find_instr_range; eauto. intros POS_RANGE. + generalize (bblock_size_pos bb). intros SIZE. lia. + + erewrite bblock_size_preserved; eauto. + rewrite list_length_z_cons. + replace (pos + (list_length_z tbb + 1) - 1) with (pos + list_length_z tbb) by lia. + apply find_instr_tail; auto. +Qed. -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros [tc [A B]]. - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) +Lemma list_nth_z_find_label: + forall (ll : list label) il n l, + list_nth_z ll n = Some l -> + Asm.find_instr n ((unfold_label ll) ++ il) = Some (Asm.Plabel l). +Proof. + induction ll. + - intros. inversion H. + - intros. simpl. + destruct (zeq n 0) as [Z | NZ]. + + inversion H as (H'). rewrite Z in H'. simpl in H'. inv H'. reflexivity. + + simpl in H. destruct (zeq n 0). { contradiction. } + apply IHll; auto. +Qed. -Lemma return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists ra, return_address_offset f c ra. +Lemma list_nth_z_find_bi: + forall lbi bi tlbi n bi' exit, + list_nth_z lbi n = Some bi -> + unfold_body lbi = OK tlbi -> + basic_to_instruction bi = OK bi' -> + Asm.find_instr n (tlbi ++ exit) = Some bi'. Proof. - intros. eapply Asmgenproof0.return_address_exists; eauto. -- intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ. - rewrite transl_code'_transl_code in EQ0. - exists x; exists true; split; auto. unfold fn_code. - constructor. apply (storeptr_label X30 XSP (fn_retaddr_ofs f0) x). -- exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using simulation diagrams - of the following form. -<< - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' ->> - The invariant is the [match_states] predicate below, which includes: -- The Asm code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and Asm register values agree. -*) + induction lbi. + - intros. inversion H. + - simpl. intros. + apply bind_inversion in H0. destruct H0 as (? & ? & ?). + apply bind_inversion in H2. destruct H2 as (? & ? & ?). + destruct (zeq n 0) as [Z | NZ]. + + destruct n. + * inversion H as (BI). rewrite BI in *. + inversion H3. simpl. congruence. + * (* absurd *) congruence. + * (* absurd *) congruence. + + inv H3. simpl. destruct (zeq n 0). { contradiction. } + eapply IHlbi; eauto. +Qed. -Inductive match_states: Mach.state -> Asm.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#X29 = parent_sp s) - (LEAF: is_leaf_function f = true -> rs#RA = parent_ra s), - match_states (Mach.State s fb sp c ms m) - (Asm.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Mach.Callstate s fb ms m) - (Asm.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Mach.Returnstate s ms m) - (Asm.State rs m'). - -Lemma exec_straight_steps: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists rs2, - exec_straight tge tf c rs1 m1' k rs2 m2' - /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#X29 = parent_sp s) - /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c ms2 m2) st'. -Proof. - intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A [B [C D]]]]. - exists (State rs2 m2'); split. - - eapply exec_straight_exec; eauto. - - econstructor; eauto. eapply exec_straight_at; eauto. -Qed. - -Lemma exec_straight_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2' - /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B [C D]]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. - rewrite OTH by congruence; auto. -Qed. - -Lemma exec_straight_opt_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2' - /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B [C D]]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - inv A. -- exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. - rewrite OTH by congruence; auto. -- exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. - rewrite OTH by congruence; auto. -Qed. - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the Asm side. Actually, all Mach transitions - correspond to at least one Asm transition, except the - transition from [Machsem.Returnstate] to [Machsem.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) - -Definition measure (s: Mach.state) : nat := - match s with - | Mach.State _ _ _ _ _ _ => 0%nat - | Mach.Callstate _ _ _ _ => 0%nat - | Mach.Returnstate _ _ _ => 1%nat +Lemma list_nth_z_find_bi_with_header: + forall ll lbi bi tlbi n bi' (rest : list Asm.instruction), + list_nth_z lbi (n - list_length_z ll) = Some bi -> + unfold_body lbi = OK tlbi -> + basic_to_instruction bi = OK bi' -> + Asm.find_instr n ((unfold_label ll) ++ (tlbi) ++ (rest)) = Some bi'. +Proof. + induction ll. + - unfold list_length_z. simpl. intros. + replace (n - 0) with n in H by lia. eapply list_nth_z_find_bi; eauto. + - intros. simpl. destruct (zeq n 0). + + rewrite list_length_z_cons in H. rewrite e in H. + replace (0 - (list_length_z ll + 1)) with (-1 - (list_length_z ll)) in H by lia. + generalize (list_length_z_pos ll). intros. + rewrite list_nth_z_neg in H; try lia. inversion H. + + rewrite list_length_z_cons in H. + replace (n - (list_length_z ll + 1)) with (n -1 - (list_length_z ll)) in H by lia. + eapply IHll; eauto. +Qed. + +(* XXX unused *) +Lemma range_list_nth_z: + forall (A: Type) (l: list A) n, + 0 <= n < list_length_z l -> + exists x, list_nth_z l n = Some x. +Proof. + induction l. + - intros. unfold list_length_z in H. simpl in H. lia. + - intros n. destruct (zeq n 0). + + intros. simpl. destruct (zeq n 0). { eauto. } contradiction. + + intros H. rewrite list_length_z_cons in H. + simpl. destruct (zeq n 0). { contradiction. } + replace (Z.pred n) with (n - 1) by lia. + eapply IHl; lia. +Qed. + +Lemma list_nth_z_n_too_big: + forall (A: Type) (l: list A) n, + 0 <= n -> + list_nth_z l n = None -> + n >= list_length_z l. +Proof. + induction l. + - intros. unfold list_length_z. simpl. lia. + - intros. rewrite list_length_z_cons. + simpl in H0. + destruct (zeq n 0) as [N | N]. + + inversion H0. + + (* XXX there must be a more elegant way to prove this simple fact *) + assert (n > 0). { lia. } + assert (0 <= n - 1). { lia. } + generalize (IHl (n - 1)). intros IH. + assert (n - 1 >= list_length_z l). { auto. } + assert (n > list_length_z l); lia. +Qed. + +Lemma find_instr_past_header: + forall labels n rest, + list_nth_z labels n = None -> + Asm.find_instr n (unfold_label labels ++ rest) = + Asm.find_instr (n - list_length_z labels) rest. +Proof. + induction labels as [| label labels' IH]. + - unfold list_length_z; simpl; intros; rewrite Z.sub_0_r; reflexivity. + - intros. simpl. destruct (zeq n 0) as [N | N]. + + rewrite N in H. inversion H. + + rewrite list_length_z_cons. + replace (n - (list_length_z labels' + 1)) with (n - 1 - list_length_z labels') by lia. + simpl in H. destruct (zeq n 0). { contradiction. } + replace (Z.pred n) with (n - 1) in H by lia. + apply IH; auto. +Qed. + +(* very similar to find_instr_past_header *) +Lemma find_instr_past_body: + forall lbi n tlbi rest, + list_nth_z lbi n = None -> + unfold_body lbi = OK tlbi -> + Asm.find_instr n (tlbi ++ rest) = + Asm.find_instr (n - list_length_z lbi) rest. +Proof. + induction lbi. + - unfold list_length_z; simpl; intros ? ? ? ? H. inv H; rewrite Z.sub_0_r; reflexivity. + - intros n tlib ? NTH UNFOLD_BODY. + unfold unfold_body in UNFOLD_BODY. apply bind_inversion in UNFOLD_BODY. + destruct UNFOLD_BODY as (? & BI & H). + apply bind_inversion in H. destruct H as (? & UNFOLD_BODY' & CONS). + fold unfold_body in UNFOLD_BODY'. inv CONS. + simpl; destruct (zeq n 0) as [N|N]. + + rewrite N in NTH; inversion NTH. + + rewrite list_length_z_cons. + replace (n - (list_length_z lbi + 1)) with (n - 1 - list_length_z lbi) by lia. + simpl in NTH. destruct (zeq n 0). { contradiction. } + replace (Z.pred n) with (n - 1) in NTH by lia. + apply IHlbi; auto. +Qed. + +Lemma n_beyond_body: + forall bb n, + 0 <= n < size bb -> + list_nth_z (header bb) n = None -> + list_nth_z (body bb) (n - list_length_z (header bb)) = None -> + n >= Z.of_nat (length (header bb) + length (body bb)). +Proof. + intros. + assert (0 <= n). { lia. } + generalize (list_nth_z_n_too_big label (header bb) n H2 H0). intros. + generalize (list_nth_z_n_too_big _ (body bb) (n - list_length_z (header bb))). intros. + unfold size in H. + + assert (0 <= n - list_length_z (header bb)). { lia. } + assert (n - list_length_z (header bb) >= list_length_z (body bb)). { apply H4; auto. } + + assert (n >= list_length_z (header bb) + list_length_z (body bb)). { lia. } + rewrite Nat2Z.inj_add. + repeat (rewrite <- list_length_z_nat). assumption. +Qed. + +Lemma exec_arith_instr_dont_move_PC ai rs rs': forall + (BASIC: exec_arith_instr lk ai rs = rs'), + rs PC = rs' PC. +Proof. + destruct ai; simpl; intros; + try (rewrite <- BASIC; rewrite Pregmap.gso; auto; discriminate). + - destruct i; simpl in BASIC; + try destruct (negb _); rewrite <- BASIC; + repeat rewrite Pregmap.gso; try discriminate; reflexivity. + - destruct i; simpl in BASIC. + 1,2: rewrite <- BASIC; repeat rewrite Pregmap.gso; try discriminate; reflexivity. + destruct sz; + try (unfold compare_single in BASIC || unfold compare_float in BASIC); + destruct (rs r1), (rs r2); + try (rewrite <- BASIC; repeat rewrite Pregmap.gso; try (discriminate || reflexivity)). + - destruct i; simpl in BASIC; + destruct is; + try (unfold compare_int in BASIC || unfold compare_long in BASIC); + try (rewrite <- BASIC; repeat rewrite Pregmap.gso; try (discriminate || reflexivity)). + - destruct i; simpl in BASIC; destruct sz; + try (unfold compare_single in BASIC || unfold compare_float in BASIC); + destruct (rs r1); + try (rewrite <- BASIC; repeat rewrite Pregmap.gso; try (discriminate || reflexivity)). + - destruct fsz; rewrite <- BASIC; rewrite Pregmap.gso; try (discriminate || reflexivity). + - destruct fsz; rewrite <- BASIC; rewrite Pregmap.gso; try (discriminate || reflexivity). +Qed. + +Lemma exec_basic_dont_move_PC bi rs m rs' m': forall + (BASIC: exec_basic lk ge bi rs m = Next rs' m'), + rs PC = rs' PC. +Proof. + destruct bi; simpl; intros. + - inv BASIC. exploit exec_arith_instr_dont_move_PC; eauto. + - unfold exec_load in BASIC. + destruct ld. + + unfold exec_load_rd_a in BASIC. + destruct Mem.loadv. 2: { discriminate BASIC. } + inv BASIC. rewrite Pregmap.gso; try discriminate; auto. + + unfold exec_load_double, is_pair_addressing_mode_correct in BASIC. + destruct a; try discriminate BASIC. + do 2 (destruct Mem.loadv; try discriminate BASIC). + inv BASIC. rewrite Pregmap.gso; try discriminate; auto. + - unfold exec_store in BASIC. + destruct st. + + unfold exec_store_rs_a in BASIC. + destruct Mem.storev. 2: { discriminate BASIC. } + inv BASIC; reflexivity. + + unfold exec_store_double in BASIC. + destruct a; try discriminate BASIC. + do 2 (destruct Mem.storev; try discriminate BASIC). + inv BASIC; reflexivity. + - destruct Mem.alloc, Mem.store. 2: { discriminate BASIC. } + inv BASIC. repeat (rewrite Pregmap.gso; try discriminate). reflexivity. + - destruct Mem.loadv. 2: { discriminate BASIC. } + destruct rs, Mem.free; try discriminate BASIC. + inv BASIC; rewrite Pregmap.gso; try discriminate; auto. + - inv BASIC; rewrite Pregmap.gso; try discriminate; auto. + - inv BASIC; rewrite Pregmap.gso; try discriminate; auto. + - inv BASIC; rewrite Pregmap.gso; try discriminate; auto. + - inv BASIC; rewrite Pregmap.gso; try discriminate; auto. + - inv BASIC; auto. +Qed. + +Lemma exec_body_dont_move_PC_aux: + forall bis rs m rs' m' + (BODY: exec_body lk ge bis rs m = Next rs' m'), + rs PC = rs' PC. +Proof. + induction bis. + - intros; inv BODY; reflexivity. + - simpl; intros. + remember (exec_basic lk ge a rs m) as bi eqn:BI; destruct bi. 2: { discriminate BODY. } + symmetry in BI; destruct s in BODY, BI; simpl in BODY, BI. + exploit exec_basic_dont_move_PC; eauto; intros AGPC; rewrite AGPC. + eapply IHbis; eauto. +Qed. + +Lemma exec_body_dont_move_PC bb rs m rs' m': forall + (BODY: exec_body lk ge (body bb) rs m = Next rs' m'), + rs PC = rs' PC. +Proof. apply exec_body_dont_move_PC_aux. Qed. + +Lemma find_instr_bblock: + forall n lb pos bb tlb + (FINDBB: find_bblock pos lb = Some bb) + (UNFOLD: unfold lb = OK tlb) + (SIZE: 0 <= n < size bb), + exists i, is_nth_inst bb n i /\ Asm.find_instr (pos+n) tlb = Some i. +Proof. + induction lb as [| b lb IHlb]. + - intros. inversion FINDBB. + - intros pos bb tlb FINDBB UNFOLD SIZE. + destruct pos. + + inv FINDBB. simpl. + exploit unfold_car_cdr; eauto. intros (tbb & tlb' & UNFOLD_BBLOCK & UNFOLD' & UNFOLD_cons). + rewrite UNFOLD in UNFOLD_cons. inversion UNFOLD_cons. + unfold unfold_bblock in UNFOLD_BBLOCK. + destruct (zle (list_length_z (header bb)) 1). 2: { inversion UNFOLD_BBLOCK. } + apply bind_inversion in UNFOLD_BBLOCK. + destruct UNFOLD_BBLOCK as (? & UNFOLD_BODY & H). + inversion H as (UNFOLD_BBLOCK). + remember (list_nth_z (header bb) n) as label_opt eqn:LBL. destruct label_opt. + * (* nth instruction is a label *) + eexists; split. { eapply is_nth_label; eauto. } + inversion UNFOLD_cons. + symmetry in LBL. + rewrite <- app_assoc. + apply list_nth_z_find_label; auto. + * remember (list_nth_z (body bb) (n - list_length_z (header bb))) as bi_opt eqn:BI. + destruct bi_opt. + -- (* nth instruction is a basic instruction *) + exploit list_nth_z_in; eauto. intros INBB. + exploit entire_body_translated; eauto. intros BI'. + destruct BI'. + eexists; split. + ++ eapply is_nth_basic; eauto. + ++ repeat (rewrite <- app_assoc). eapply list_nth_z_find_bi_with_header; eauto. + -- (* nth instruction is the exit instruction *) + generalize n_beyond_body. intros TEMP. + assert (n >= Z.of_nat (Datatypes.length (header bb) + + Datatypes.length (body bb))) as NGE. { auto. } clear TEMP. + remember (exit bb) as exit_opt eqn:EXIT. destruct exit_opt. + ++ rewrite <- app_assoc. rewrite find_instr_past_header; auto. + rewrite <- app_assoc. erewrite find_instr_past_body; eauto. + assert (SIZE' := SIZE). + unfold size in SIZE. rewrite <- EXIT in SIZE. simpl in SIZE. + destruct SIZE as (LOWER & UPPER). + repeat (rewrite Nat2Z.inj_add in UPPER). + repeat (rewrite <- list_length_z_nat in UPPER). repeat (rewrite Nat2Z.inj_add in NGE). + repeat (rewrite <- list_length_z_nat in NGE). simpl in UPPER. + assert (n = list_length_z (header bb) + list_length_z (body bb)). { lia. } + assert (n = size bb - 1). { + unfold size. rewrite <- EXIT. simpl. + repeat (rewrite Nat2Z.inj_add). repeat (rewrite <- list_length_z_nat). simpl. lia. + } + symmetry in EXIT. + eexists; split. + ** eapply is_nth_ctlflow; eauto. + ** simpl. + destruct (zeq (n - list_length_z (header bb) - list_length_z (body bb)) 0). { reflexivity. } + (* absurd *) lia. + ++ (* absurd *) + unfold size in SIZE. rewrite <- EXIT in SIZE. simpl in SIZE. + destruct SIZE as (? & SIZE'). rewrite Nat.add_0_r in SIZE'. lia. + + unfold find_bblock in FINDBB; simpl in FINDBB; fold find_bblock in FINDBB. + inversion UNFOLD as (UNFOLD'). + apply bind_inversion in UNFOLD'. destruct UNFOLD' as (? & (UNFOLD_BBLOCK' & UNFOLD')). + apply bind_inversion in UNFOLD'. destruct UNFOLD' as (? & (UNFOLD' & TLB)). + inversion TLB. + generalize (IHlb _ _ _ FINDBB UNFOLD'). intros IH. + destruct IH as (? & (IH_is_nth & IH_find_instr)); eauto. + eexists; split. + * apply IH_is_nth. + * replace (Z.pos p + n) with (Z.pos p + n - size b + size b) by lia. + eapply find_instr_bblock_tail; try assumption. + replace (Z.pos p + n - size b) with (Z.pos p - size b + n) by lia. + apply IH_find_instr. + + (* absurd *) + generalize (Pos2Z.neg_is_neg p). intros. exploit (find_bblock_neg (b :: lb)); eauto. + rewrite FINDBB. intros CONTRA. inversion CONTRA. +Qed. + +Lemma exec_header_simulation b ofs f bb rs m: forall + (ATPC: rs PC = Vptr b ofs) + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb), + exists s', star Asm.step tge (State rs m) E0 s' + /\ match_internal (list_length_z (header bb)) (State rs m) s'. +Proof. + intros. + exploit internal_functions_unfold; eauto. + intros (tc & FINDtf & TRANStf & _). + assert (BNDhead: list_length_z (header bb) <= 1). { eapply size_header; eauto. } + destruct (header bb) as [|l[|]] eqn: EQhead. + + (* header nil *) + eexists; split. + - eapply star_refl. + - split; eauto. + unfold list_length_z; rewrite !ATPC; simpl. + rewrite Ptrofs.add_zero; auto. + + (* header one *) + assert (Lhead: list_length_z (header bb) = 1). { rewrite EQhead; unfold list_length_z; simpl. auto. } + exploit (find_instr_bblock 0); eauto. + { generalize (bblock_size_pos bb). lia. } + intros (i & NTH & FIND_INSTR). + inv NTH. + * rewrite EQhead in H; simpl in H. inv H. + replace (Ptrofs.unsigned ofs + 0) with (Ptrofs.unsigned ofs) in FIND_INSTR by lia. + eexists. split. + - eapply star_one. + eapply Asm.exec_step_internal; eauto. + simpl; eauto. + - unfold list_length_z; simpl. split; eauto. + intros r; destruct r; simpl; congruence || auto. + * (* absurd case *) + erewrite list_nth_z_neg in * |-; [ congruence | rewrite Lhead; lia]. + * (* absurd case *) + rewrite bblock_size_aux, Lhead in *. generalize (bblock_size_aux_pos bb). lia. + + (* absurd case *) + unfold list_length_z in BNDhead. simpl in *. + generalize (list_length_z_aux_increase _ l1 2); lia. +Qed. + +Lemma eval_addressing_preserved a rs1 rs2: + (forall r : preg, r <> PC -> rs1 r = rs2 r) -> + eval_addressing lk a rs1 = Asm.eval_addressing tge a rs2. +Proof. + intros EQ. + destruct a; simpl; try (rewrite !EQ; congruence). + auto. +Qed. + +Ltac next_stuck_cong := try (unfold Next, Stuck in *; congruence). + +Ltac inv_ok_eq := + repeat match goal with + | [EQ: OK ?x = OK ?y |- _ ] + => inversion EQ; clear EQ; subst + end. + +Ltac reg_rwrt := + match goal with + | [e: DR _ = DR _ |- _ ] + => rewrite e in * end. -Remark preg_of_not_X29: forall r, negb (mreg_eq r R29) = true -> IR X29 <> preg_of r. -Proof. - intros. change (IR X29) with (preg_of R29). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -Lemma sp_val': forall ms sp rs, agree ms sp rs -> sp = rs XSP. -Proof. - intros. eapply sp_val; eauto. -Qed. - -(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) - -Theorem step_simulation: - forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1') (WF: wf_state ge S1), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros; inv MS. - -- (* Mlabel *) - left; eapply exec_straight_steps; eauto; intros. - monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. { apply agree_nextinstr; auto. } - split. { simpl; congruence. } - rewrite nextinstr_inv by congruence; assumption. - -- (* Mgetstack *) - unfold load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q [R S]]]]. - exists rs'; split. eauto. - split. { eapply agree_set_mreg; eauto with asmgen. congruence. } - split. { simpl; congruence. } - rewrite S. assumption. - -- (* Msetstack *) - unfold store_stack in H. - assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto). - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - left; eapply exec_straight_steps; eauto. - rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - exploit storeind_correct; eauto with asmgen. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - simpl; intros. - split. rewrite Q; auto with asmgen. - rewrite R. assumption. - -- (* Mgetparam *) - assert (f0 = f) by congruence; subst f0. - unfold load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val' _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. -Opaque loadind. - left; eapply exec_straight_steps; eauto; intros. monadInv TR. - destruct ep. -(* X30 contains parent *) - exploit loadind_correct. eexact EQ. - instantiate (2 := rs0). simpl; rewrite DXP; eauto. simpl; congruence. - intros [rs1 [P [Q [R S]]]]. - exists rs1; split. eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; split; intros. - { rewrite R; auto with asmgen. - apply preg_of_not_X29; auto. +Ltac destruct_reg_inv := + repeat match goal with + | [ H : match ?reg with _ => _ end = _ |- _ ] + => simpl in *; destruct reg; try congruence; try inv_ok_eq; try reg_rwrt + end. + +Ltac destruct_ireg_inv := + repeat match goal with + | [ H : match ?reg with _ => _ end = _ |- _ ] + => destruct reg as [[r|]|]; try congruence; try inv_ok_eq; subst + end. + +Ltac destruct_reg_size := + simpl in *; + match goal with + | [ |- context [ match ?reg with _ => _ end ] ] + => destruct reg; try congruence + end. + +Ltac find_rwrt_ag := + simpl in *; + match goal with + | [ AG: forall r, r <> ?PC -> _ r = _ r |- _ ] + => repeat rewrite <- AG; try congruence + end. + +Ltac inv_matchi := + match goal with + | [ MATCHI : match_internal _ _ _ |- _ ] + => inversion MATCHI; subst; find_rwrt_ag + end. + +Ltac destruct_ir0_reg := + match goal with + | [ |- context [ ir0 _ _ ?r ] ] + => unfold ir0 in *; destruct r; find_rwrt_ag; eauto + end. + +Ltac pc_not_sp := + match goal with + | [ |- ?PC <> ?SP ] + => destruct (PregEq.eq SP PC); repeat congruence; discriminate + end. + +Ltac update_x_access_x := + subst; rewrite !Pregmap.gss; auto. + +Ltac update_x_access_r := + rewrite !Pregmap.gso; auto. + +Lemma nextinstr_agree_but_pc rs1 rs2: forall + (AG: forall r, r <> PC -> rs1 r = rs2 r), + forall r, r <> PC -> rs1 r = Asm.nextinstr rs2 r. +Proof. + intros; unfold Asm.nextinstr in *; rewrite Pregmap.gso in *; eauto. +Qed. + +Lemma ptrofs_nextinstr_agree rs1 rs2 n: forall + (BOUNDED : 0 <= n <= Ptrofs.max_unsigned) + (AGPC : Val.offset_ptr (rs1 PC) (Ptrofs.repr n) = rs2 PC), + Val.offset_ptr (rs1 PC) (Ptrofs.repr (n + 1)) = Asm.nextinstr rs2 PC. +Proof. + intros; unfold Asm.nextinstr; rewrite Pregmap.gss. + rewrite <- Ptrofs.unsigned_one; rewrite <- (Ptrofs.unsigned_repr n); eauto; + rewrite <- Ptrofs.add_unsigned; rewrite <- Val.offset_ptr_assoc; rewrite AGPC; eauto. +Qed. + +Lemma load_rd_a_preserved n rs1 m1 rs1' m1' rs2 m2 rd chk f a: forall + (BOUNDED: 0 <= n <= Ptrofs.max_unsigned) + (MATCHI: match_internal n (State rs1 m1) (State rs2 m2)) + (HLOAD: exec_load_rd_a lk chk f a rd rs1 m1 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), Asm.exec_load tge chk f a rd rs2 m2 = Next rs2' m2' + /\ match_internal (n + 1) (State rs1' m1') (State rs2' m2'). +Proof. + intros. + unfold exec_load_rd_a, Asm.exec_load in *. + inversion MATCHI as [n0 r1 mx1 r2 mx2 EQM EQR EQPC]; subst. + rewrite <- (eval_addressing_preserved a rs1 rs2); auto. + destruct (Mem.loadv _ _ _). + + inversion HLOAD; auto. repeat (econstructor; eauto). + * eapply nextinstr_agree_but_pc; intros. + destruct (PregEq.eq r rd); try update_x_access_x; try update_x_access_r. + * eapply ptrofs_nextinstr_agree; eauto. + + next_stuck_cong. +Qed. + +Lemma load_double_preserved n rs1 m1 rs1' m1' rs2 m2 rd1 rd2 chk1 chk2 f a: forall + (BOUNDED: 0 <= n <= Ptrofs.max_unsigned) + (MATCHI: match_internal n (State rs1 m1) (State rs2 m2)) + (HLOAD: exec_load_double lk chk1 chk2 f a rd1 rd2 rs1 m1 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), Asm.exec_load_double tge chk1 chk2 f a rd1 rd2 rs2 m2 = Next rs2' m2' + /\ match_internal (n + 1) (State rs1' m1') (State rs2' m2'). +Proof. + intros. + unfold exec_load_double, Asm.exec_load_double in *. + inversion MATCHI as [n0 r1 mx1 r2 mx2 EQM EQR EQPC]; subst. + erewrite <- !eval_addressing_preserved; eauto. + destruct (is_pair_addressing_mode_correct a); try discriminate. + destruct (Mem.loadv _ _ _); + destruct (Mem.loadv chk2 m2 + (eval_addressing lk + (get_offset_addr a match chk1 with + | Mint32 | Many32 => 4 + | _ => 8 + end) rs1)); + inversion HLOAD; auto. + repeat (econstructor; eauto). + * eapply nextinstr_agree_but_pc; intros. + destruct (PregEq.eq r rd2); destruct (PregEq.eq r rd1). + - try update_x_access_x. + - try update_x_access_x. + - subst; repeat rewrite Pregmap.gso, Pregmap.gss; auto. + - try update_x_access_r. + * eapply ptrofs_nextinstr_agree; eauto. +Qed. + +Lemma store_rs_a_preserved n rs1 m1 rs1' m1' rs2 m2 v chk a: forall + (BOUNDED: 0 <= n <= Ptrofs.max_unsigned) + (MATCHI: match_internal n (State rs1 m1) (State rs2 m2)) + (HSTORE: exec_store_rs_a lk chk a v rs1 m1 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), Asm.exec_store tge chk a v rs2 m2 = Next rs2' m2' + /\ match_internal (n + 1) (State rs1' m1') (State rs2' m2'). +Proof. + intros. + unfold exec_store_rs_a, Asm.exec_store in *. + inversion MATCHI as [n0 r1 mx1 r2 mx2 EQM EQR EQPC]; subst. + rewrite <- (eval_addressing_preserved a rs1 rs2); auto. + destruct (Mem.storev _ _ _ _). + + inversion HSTORE; auto. repeat (econstructor; eauto). + * eapply nextinstr_agree_but_pc; intros. + subst. apply EQR. auto. + * eapply ptrofs_nextinstr_agree; subst; eauto. + + next_stuck_cong. +Qed. + +Lemma store_double_preserved n rs1 m1 rs1' m1' rs2 m2 v1 v2 chk1 chk2 a: forall + (BOUNDED: 0 <= n <= Ptrofs.max_unsigned) + (MATCHI: match_internal n (State rs1 m1) (State rs2 m2)) + (HSTORE: exec_store_double lk chk1 chk2 a v1 v2 rs1 m1 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), Asm.exec_store_double tge chk1 chk2 a v1 v2 rs2 m2 = Next rs2' m2' + /\ match_internal (n + 1) (State rs1' m1') (State rs2' m2'). +Proof. + intros. + unfold exec_store_double, Asm.exec_store_double in *. + inversion MATCHI as [n0 r1 mx1 r2 mx2 EQM EQR EQPC]; subst. + erewrite <- !eval_addressing_preserved; eauto. + destruct (is_pair_addressing_mode_correct a); try discriminate. + destruct (Mem.storev _ _ _ _); + try destruct (Mem.storev chk2 m + (eval_addressing lk + (get_offset_addr a + match chk1 with + | Mint32 | Many32 => 4 + | _ => 8 + end) rs1) v2); + inversion HSTORE; auto. + repeat (econstructor; eauto). + * eapply nextinstr_agree_but_pc; intros. + subst. apply EQR. auto. + * eapply ptrofs_nextinstr_agree; subst; eauto. +Qed. + +Lemma next_inst_preserved n rs1 m1 rs1' m1' rs2 m2 (x: dreg) v: forall + (BOUNDED: 0 <= n <= Ptrofs.max_unsigned) + (MATCHI: match_internal n (State rs1 m1) (State rs2 m2)) + (NEXTI: Next rs1 # x <- v m1 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), + Next (Asm.nextinstr rs2 # x <- v) m2 = Next rs2' m2' + /\ match_internal (n + 1) (State rs1' m1') (State rs2' m2'). +Proof. + intros. + inversion MATCHI as [n0 r1 mx1 r2 mx2 EQM EQR EQPC]; subst. + inversion NEXTI. repeat (econstructor; eauto). + * eapply nextinstr_agree_but_pc; intros. + destruct (PregEq.eq r x); try update_x_access_x; try update_x_access_r. + * eapply ptrofs_nextinstr_agree; eauto. +Qed. + +Lemma match_internal_nextinstr_switch: + forall n s rs2 m2 r v, + r <> PC -> + match_internal n s (State ((Asm.nextinstr rs2)#r <- v) m2) -> + match_internal n s (State (Asm.nextinstr (rs2#r <- v)) m2). +Proof. + unfold Asm.nextinstr; intros n s rs2 m2 r v NOTPC1 MI. + inversion MI; subst; constructor; auto. + - eapply nextinstr_agree_but_pc; intros. + rewrite AG; try congruence. + destruct (PregEq.eq r r0); try update_x_access_x; try update_x_access_r. + - rewrite !Pregmap.gss, !Pregmap.gso; try congruence. + rewrite AGPC. + rewrite Pregmap.gso, Pregmap.gss; try congruence. +Qed. + +Lemma match_internal_nextinstr_set_parallel: + forall n rs1 m1 rs2 m2 r v1 v2, + r <> PC -> + match_internal n (State rs1 m1) (State (Asm.nextinstr rs2) m2) -> + v1 = v2 -> + match_internal n (State (rs1#r <- v1) m1) (State (Asm.nextinstr (rs2#r <- v2)) m2). +Proof. + intros; subst; eapply match_internal_nextinstr_switch; eauto. + intros; eapply match_internal_set_parallel; eauto. +Qed. + +Lemma exec_basic_simulation: + forall tf n rs1 m1 rs1' m1' rs2 m2 bi tbi + (BOUNDED: 0 <= n <= Ptrofs.max_unsigned) + (BASIC: exec_basic lk ge bi rs1 m1 = Next rs1' m1') + (MATCHI: match_internal n (State rs1 m1) (State rs2 m2)) + (TRANSBI: basic_to_instruction bi = OK tbi), + exists rs2' m2', Asm.exec_instr tge tf tbi + rs2 m2 = Next rs2' m2' + /\ match_internal (n + 1) (State rs1' m1') (State rs2' m2'). +Proof. + intros. + destruct bi. + { (* PArith *) + simpl in *; destruct i. + 1: { + destruct i. + 1,2,3: + try (destruct sumbool_rec; try congruence); + try (monadInv TRANSBI); + try (destruct_reg_inv); + try (inv_matchi); + try (exploit next_inst_preserved; eauto); + try (repeat destruct_reg_size); + try (destruct_ir0_reg). + 1,2: (* Special case for Pfmovimmd / Pfmovimms *) + try (monadInv TRANSBI); + try (destruct_reg_inv); + try (inv_matchi); + inversion BASIC; clear BASIC; subst; + try (destruct (is_immediate_float64 _)); + try (destruct (is_immediate_float32 _)); + eexists; eexists; split; eauto; + repeat (eapply match_internal_nextinstr_set_parallel; try congruence); + try (econstructor; eauto); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). + } + 1,2,3,4,5: (* PArithP, PArithPP, PArithPPP, PArithRR0R, PArithRR0, PArithARRRR0 *) + destruct i; + try (destruct sumbool_rec; try congruence); + try (monadInv TRANSBI); + try (destruct_reg_inv); + try (inv_matchi); + try (exploit next_inst_preserved; eauto); + try (repeat destruct_reg_size); + try (destruct_ir0_reg). + { (* PArithComparisonPP *) + destruct i; + try (monadInv TRANSBI); + try (inv_matchi); + try (destruct_reg_inv); + simpl in *. + 1,2: (* compare_long *) + inversion BASIC; clear BASIC; subst; + eexists; eexists; split; eauto; + unfold compare_long; + repeat (eapply match_internal_nextinstr_set_parallel; [ congruence | idtac | try (rewrite !AG; congruence)]); + try (econstructor; eauto); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). + + destruct sz. + - (* compare_single *) + unfold compare_single in BASIC. + destruct (rs1 x), (rs1 x0); + inversion BASIC; + eexists; eexists; split; eauto; + repeat (eapply match_internal_nextinstr_set_parallel; [ congruence | idtac | try (rewrite !AG; congruence)]); + try (econstructor; eauto); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). + - (* compare_float *) + unfold compare_float in BASIC. + destruct (rs1 x), (rs1 x0); + inversion BASIC; + eexists; eexists; split; eauto; + repeat (eapply match_internal_nextinstr_set_parallel; [ congruence | idtac | try (rewrite !AG; congruence)]); + try (econstructor; eauto); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). } + 1,2: (* PArithComparisonR0R, PArithComparisonP *) + destruct i; + try (monadInv TRANSBI); + try (inv_matchi); + try (destruct_reg_inv); + try (destruct_reg_size); + simpl in *; + inversion BASIC; clear BASIC; subst; + eexists; eexists; split; eauto; + unfold compare_long, compare_int, compare_float, compare_single; + try (destruct_reg_size); + repeat (eapply match_internal_nextinstr_set_parallel; [ congruence | idtac | try (rewrite !AG; congruence)]); + try (econstructor; eauto); + try (destruct_ir0_reg); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). + { (* Pcset *) + try (monadInv TRANSBI); + try (inv_matchi). + try (exploit next_inst_preserved; eauto); + try (simpl in *; intros; + unfold if_opt_bool_val in *; unfold eval_testcond in *; + rewrite <- !AG; try congruence; eauto). } + { (* Pfmovi *) + try (monadInv TRANSBI); + try (inv_matchi); + try (destruct_reg_size); + try (destruct_ir0_reg); + try (exploit next_inst_preserved; eauto). } + { (* Pcsel *) + try (destruct_reg_inv); + try (monadInv TRANSBI); + try (destruct_reg_inv); + try (inv_matchi); + try (exploit next_inst_preserved; eauto); + simpl in *; intros; + unfold if_opt_bool_val in *; unfold eval_testcond in *; + rewrite <- !AG; try congruence; eauto. } + { (* Pfnmul *) + try (monadInv TRANSBI); + try (inv_matchi); + try (destruct_reg_size); + try (exploit next_inst_preserved; eauto); + try (find_rwrt_ag). } } + { (* PLoad *) + destruct ld. + - destruct ld; monadInv TRANSBI; try destruct_ireg_inv; exploit load_rd_a_preserved; eauto; + intros; simpl in *; destruct sz; eauto. + - destruct ld; monadInv TRANSBI; exploit load_double_preserved; eauto. } + { (* PStore *) + destruct st. + - destruct st; monadInv TRANSBI; try destruct_ireg_inv; exploit store_rs_a_preserved; eauto; + simpl in *; inv_matchi; find_rwrt_ag. + - destruct st; monadInv TRANSBI; exploit store_double_preserved; eauto; + simpl in *; inv_matchi; find_rwrt_ag. } + { (* Pallocframe *) + monadInv TRANSBI; + inv_matchi; try pc_not_sp; + destruct sz eqn:EQSZ; + destruct Mem.alloc eqn:EQALLOC; + destruct Mem.store eqn:EQSTORE; inversion BASIC; try pc_not_sp; + eexists; eexists; split; eauto; + repeat (eapply match_internal_nextinstr_set_parallel; [ try (pc_not_sp; congruence) | idtac | try (reflexivity)]); + try (econstructor; eauto); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). } + { (* Pfreeframe *) + monadInv TRANSBI; + inv_matchi; try pc_not_sp; + destruct sz eqn:EQSZ; + destruct Mem.loadv eqn:EQLOAD; + destruct (rs1 SP) eqn:EQRS1SP; + try (destruct Mem.free eqn:EQFREE); + inversion BASIC; try pc_not_sp; + eexists; eexists; split; eauto; + repeat (eapply match_internal_nextinstr_set_parallel; [ try (pc_not_sp; congruence) | idtac | try (reflexivity)]); + try (econstructor; eauto); + try (eapply nextinstr_agree_but_pc; eauto); + try (eapply ptrofs_nextinstr_agree; eauto). } + 1,2,3,4: (* Ploadsymbol, Pcvtsw2x, Pcvtuw2x, Pcvtx2w *) + try (monadInv TRANSBI); + try (inv_matchi); + try (exploit next_inst_preserved; eauto); + rewrite symbol_addresses_preserved; eauto; + try (find_rwrt_ag). + { (* Pnop *) + monadInv TRANSBI; inv_matchi. + inversion BASIC. + repeat (econstructor; eauto). + eapply nextinstr_agree_but_pc; intros; + try rewrite <- H0, AG; auto. + try eapply ptrofs_nextinstr_agree; auto; rewrite <- H0; + assumption. } +Qed. + +Lemma find_basic_instructions b ofs f bb tc: forall + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (UNFOLD: unfold (fn_blocks f) = OK tc), + forall n, + (n < length (body bb))%nat -> + exists (i : Asm.instruction) (bi : basic), + list_nth_z (body bb) (Z.of_nat n) = Some bi + /\ basic_to_instruction bi = OK i + /\ Asm.find_instr (Ptrofs.unsigned ofs + + (list_length_z (header bb)) + + Z.of_nat n) tc + = Some i. +Proof. + intros until n; intros NLT. + exploit internal_functions_unfold; eauto. + intros (tc' & FINDtf & TRANStf & _). + assert (tc' = tc) by congruence; subst. + exploit (find_instr_bblock (list_length_z (header bb) + Z.of_nat n)); eauto. + { unfold size; split. + - rewrite list_length_z_nat; lia. + - repeat (rewrite list_length_z_nat). repeat (rewrite Nat2Z.inj_add). lia. } + intros (i & NTH & FIND_INSTR). + exists i; intros. + inv NTH. + - (* absurd *) apply list_nth_z_range in H; lia. + - exists bi; + rewrite Z.add_simpl_l in H; + rewrite Z.add_assoc in FIND_INSTR; + intuition. + - (* absurd *) rewrite bblock_size_aux in H0; + rewrite H in H0; simpl in H0; repeat rewrite list_length_z_nat in H0; lia. +Qed. + +(* TODO: remplacer find_basic_instructions directement par ce lemme ? *) +Lemma find_basic_instructions_alt b ofs f bb tc n: forall + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (UNFOLD: unfold (fn_blocks f) = OK tc) + (BOUND: 0 <= n < list_length_z (body bb)), + exists (i : Asm.instruction) (bi : basic), + list_nth_z (body bb) n = Some bi + /\ basic_to_instruction bi = OK i + /\ Asm.find_instr (Ptrofs.unsigned ofs + + (list_length_z (header bb)) + + n) tc + = Some i. +Proof. + intros; assert ((Z.to_nat n) < length (body bb))%nat. + { rewrite Nat2Z.inj_lt, <- list_length_z_nat, Z2Nat.id; try lia. } + exploit find_basic_instructions; eauto. + rewrite Z2Nat.id; try lia. intros (i & bi & X). + eexists; eexists; intuition eauto. +Qed. + +Lemma header_body_tail_bound: forall (a: basic) (li: list basic) bb ofs + (BOUNDBB : Ptrofs.unsigned ofs + size bb <= Ptrofs.max_unsigned) + (BDYLENPOS : 0 <= list_length_z (body bb) - list_length_z (a :: li) < + list_length_z (body bb)), +0 <= list_length_z (header bb) + list_length_z (body bb) - list_length_z (a :: li) <= +Ptrofs.max_unsigned. +Proof. + intros. + assert (HBBPOS: list_length_z (header bb) >= 0) by eapply list_length_z_pos. + assert (HBBSIZE: list_length_z (header bb) < size bb) by eapply header_size_lt_block_size. + assert (OFSBOUND: 0 <= Ptrofs.unsigned ofs <= Ptrofs.max_unsigned) by eapply Ptrofs.unsigned_range_2. + assert (BBSIZE: size bb <= Ptrofs.max_unsigned) by lia. + unfold size in BBSIZE. + rewrite !Nat2Z.inj_add in BBSIZE. + rewrite <- !list_length_z_nat in BBSIZE. + lia. +Qed. + +(* A more general version of the exec_body_simulation_plus lemma below. + This generalization is necessary for the induction proof inside the body. +*) +Lemma exec_body_simulation_plus_gen li: forall b ofs f bb rs m s2 rs' m' + (BLI: is_tail li (body bb)) + (ATPC: rs PC = Vptr b ofs) + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (NEMPTY_BODY: li <> nil) + (MATCHI: match_internal ((list_length_z (header bb)) + (list_length_z (body bb)) - (list_length_z li)) (State rs m) s2) + (BODY: exec_body lk ge li rs m = Next rs' m'), + exists s2', plus Asm.step tge s2 E0 s2' + /\ match_internal (size bb - (Z.of_nat (length_opt (exit bb)))) (State rs' m') s2'. +Proof. + induction li as [|a li]; simpl; try congruence. + intros. + assert (BDYLENPOS: 0 <= (list_length_z (body bb) - list_length_z (a::li)) < list_length_z (body bb)). { + assert (Z.of_nat O < list_length_z (a::li) <= list_length_z (body bb)); try lia. + rewrite !list_length_z_nat; split. + - rewrite <- Nat2Z.inj_lt. simpl. lia. + - rewrite <- Nat2Z.inj_le; eapply is_tail_bound; eauto. } - { rewrite S; auto. } - -(* X30 does not contain parent *) - exploit loadptr_correct. eexact A. simpl; congruence. intros [rs1 [P [Q R]]]. - exploit loadind_correct. eexact EQ. instantiate (2 := rs1). simpl; rewrite Q. eauto. simpl; congruence. - intros [rs2 [S [T [U V]]]]. - exists rs2; split. eapply exec_straight_trans; eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs1#X29 <- (rs2#X29)). intros. - rewrite Pregmap.gso; auto with asmgen. - congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' X29). congruence. auto with asmgen. - split; simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_X29; auto. - rewrite V. rewrite R by congruence. auto. - -- (* Mop *) - assert (eval_operation tge sp op (map rs args) m = Some v). - { rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. } - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_op_correct; eauto. intros [rs2 [P [Q [R S]]]]. - exists rs2; split. eauto. split. - apply agree_set_undef_mreg with rs0; auto. - apply Val.lessdef_trans with v'; auto. - split; simpl; intros. InvBooleans. - rewrite R; auto. apply preg_of_not_X29; auto. -Local Transparent destroyed_by_op. - destruct op; try exact I; simpl; congruence. - rewrite S. - auto. -- (* Mload *) - destruct trap. + exploit internal_functions_unfold; eauto. + intros (tc & FINDtf & TRANStf & _). + exploit find_basic_instructions_alt; eauto. + intros (tbi & (bi & (NTHBI & TRANSBI & FIND_INSTR))). + exploit is_tail_list_nth_z; eauto. + rewrite NTHBI; simpl. + intros X; inversion X; subst; clear X NTHBI. + destruct (exec_basic _ _ _ _ _) eqn:EXEC_BASIC; next_stuck_cong. + destruct s as (rs1 & m1); simpl in *. + destruct s2 as (rs2 & m2); simpl in *. + assert (BOUNDBBMAX: Ptrofs.unsigned ofs + size bb <= Ptrofs.max_unsigned) + by (eapply size_of_blocks_bounds; eauto). + exploit header_body_tail_bound; eauto. intros BDYTAIL. + exploit exec_basic_simulation; eauto. + intros (rs_next' & m_next' & EXEC_INSTR & MI_NEXT). + exploit exec_basic_dont_move_PC; eauto. intros AGPC. + inversion MI_NEXT as [A B C D E M_NEXT_AGREE RS_NEXT_AGREE ATPC_NEXT PC_OFS_NEXT RS RS']. + subst A. subst B. subst C. subst D. subst E. + rewrite ATPC in AGPC. symmetry in AGPC, ATPC_NEXT. + + inv MATCHI. symmetry in AGPC0. + rewrite ATPC in AGPC0. + unfold Val.offset_ptr in AGPC0. + + simpl in FIND_INSTR. + (* Execute internal step. *) + exploit (Asm.exec_step_internal tge b); eauto. { - assert (Op.eval_addressing tge sp addr (map rs args) = Some a). - { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. } - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_load_correct; eauto. intros [rs2 [P [Q [R S]]]]. - exists rs2; split. eauto. - split. eapply agree_set_undef_mreg; eauto. congruence. - split. simpl; congruence. - rewrite S. assumption. + rewrite Ptrofs.add_unsigned. + repeat (rewrite Ptrofs.unsigned_repr); try lia. + 2: { + assert (BOUNDOFS: 0 <= Ptrofs.unsigned ofs <= Ptrofs.max_unsigned) by eapply Ptrofs.unsigned_range_2. + assert (list_length_z (body bb) <= size bb) by eapply body_size_le_block_size. + assert (list_length_z (header bb) <= 1). { eapply size_header; eauto. } + lia. } + try rewrite list_length_z_nat; try split; + simpl; rewrite <- !list_length_z_nat; + replace (Ptrofs.unsigned ofs + (list_length_z (header bb) + list_length_z (body bb) - + list_length_z (a :: li))) with (Ptrofs.unsigned ofs + list_length_z (header bb) + + (list_length_z (body bb) - list_length_z (a :: li))) by lia; + try assumption; try lia. } + + (* This is our STEP hypothesis. *) + intros STEP_NEXT. + destruct li as [|a' li]; simpl in *. + - (* case of a single instruction in li: this our base case in the induction *) + inversion BODY; subst. + eexists; split. + + apply plus_one. eauto. + + constructor; auto. + rewrite ATPC_NEXT. + apply f_equal. + apply f_equal. + rewrite bblock_size_aux, list_length_z_cons; simpl. + lia. + - exploit (IHli b ofs f bb rs1 m_next' (State rs_next' m_next')); congruence || eauto. + + exploit is_tail_app_def; eauto. + intros (l3 & EQ); rewrite EQ. + exploit (is_tail_app_right (l3 ++ a::nil)). + rewrite <- app_assoc; simpl; eauto. + + constructor; auto. + rewrite ATPC_NEXT. + apply f_equal. + apply f_equal. + rewrite! list_length_z_cons; simpl. + lia. + + intros (s2' & LAST_STEPS & LAST_MATCHS). + eexists. split; eauto. + eapply plus_left'; eauto. +Qed. + +Lemma exec_body_simulation_plus b ofs f bb rs m s2 rs' m': forall + (ATPC: rs PC = Vptr b ofs) + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (NEMPTY_BODY: body bb <> nil) + (MATCHI: match_internal (list_length_z (header bb)) (State rs m) s2) + (BODY: exec_body lk ge (body bb) rs m = Next rs' m'), + exists s2', plus Asm.step tge s2 E0 s2' + /\ match_internal (size bb - (Z.of_nat (length_opt (exit bb)))) (State rs' m') s2'. +Proof. + intros. + exploit exec_body_simulation_plus_gen; eauto. + - constructor. + - replace (list_length_z (header bb) + list_length_z (body bb) - list_length_z (body bb)) with (list_length_z (header bb)); auto. + lia. +Qed. + +Lemma exec_body_simulation_star b ofs f bb rs m s2 rs' m': forall + (ATPC: rs PC = Vptr b ofs) + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (MATCHI: match_internal (list_length_z (header bb)) (State rs m) s2) + (BODY: exec_body lk ge (body bb) rs m = Next rs' m'), + exists s2', star Asm.step tge s2 E0 s2' + /\ match_internal (size bb - (Z.of_nat (length_opt (exit bb)))) (State rs' m') s2'. +Proof. + intros. + destruct (body bb) eqn: Hbb. + - simpl in BODY. inv BODY. + eexists. split. + eapply star_refl; eauto. + assert (EQ: (size bb - Z.of_nat (length_opt (exit bb))) = list_length_z (header bb)). + { rewrite bblock_size_aux. rewrite Hbb; unfold list_length_z; simpl. lia. } + rewrite EQ; eauto. + - exploit exec_body_simulation_plus; congruence || eauto. + { rewrite Hbb; eauto. } + intros (s2' & PLUS & MATCHI'). + eexists; split; eauto. + eapply plus_star; eauto. +Qed. + +Lemma list_nth_z_range_exceeded A (l : list A) n: + n >= list_length_z l -> + list_nth_z l n = None. +Proof. + intros N. + remember (list_nth_z l n) as opt eqn:H. symmetry in H. + destruct opt; auto. + exploit list_nth_z_range; eauto. lia. +Qed. + +Lemma label_in_header_list lbl a: + is_label lbl a = true -> list_length_z (header a) <= 1 -> header a = lbl :: nil. +Proof. + intros. + eapply is_label_correct_true in H. + destruct (header a). + - eapply in_nil in H. contradiction. + - rewrite list_length_z_cons in H0. + assert (list_length_z l0 >= 0) by eapply list_length_z_pos. + assert (list_length_z l0 = 0) by lia. + rewrite list_length_z_nat in H2. + assert (Datatypes.length l0 = 0%nat) by lia. + eapply length_zero_iff_nil in H3. subst. + unfold In in H. destruct H. + + subst; eauto. + + destruct H. +Qed. + +Lemma no_label_in_basic_inst: forall a lbl x, + basic_to_instruction a = OK x -> Asm.is_label lbl x = false. +Proof. + intros. + destruct a; simpl in *; + repeat destruct i; + repeat destruct ld; repeat destruct st; + simpl in *; + try (try destruct_reg_inv; monadInv H; simpl in *; reflexivity). +Qed. + +Lemma label_pos_body bdy: forall c1 c2 z ex lbl + (HUNF : unfold_body bdy = OK c2), + Asm.label_pos lbl (z + Z.of_nat ((Datatypes.length bdy) + length_opt ex)) c1 = Asm.label_pos lbl (z) ((c2 ++ unfold_exit ex) ++ c1). +Proof. + induction bdy. + - intros. inversion HUNF. simpl in *. + destruct ex eqn:EQEX. + + simpl in *. unfold Asm.is_label. destruct c; simpl; try congruence. + destruct i; simpl; try congruence. + + simpl in *. ring_simplify (z + 0). auto. + - intros. inversion HUNF; clear HUNF. monadInv H0. simpl in *. + erewrite no_label_in_basic_inst; eauto. rewrite <- IHbdy; eauto. + erewrite Zpos_P_of_succ_nat. + apply f_equal2; auto. lia. +Qed. + +Lemma asm_label_pos_header: forall z a x0 x1 lbl + (HUNF: unfold_body (body a) = OK x1), + Asm.label_pos lbl (z + size a) x0 = + Asm.label_pos lbl (z + list_length_z (header a)) ((x1 ++ unfold_exit (exit a)) ++ x0). +Proof. + intros. + unfold size. + rewrite <- plus_assoc. rewrite Nat2Z.inj_add. + rewrite list_length_z_nat. + replace (z + (Z.of_nat (Datatypes.length (header a)) + Z.of_nat (Datatypes.length (body a) + length_opt (exit a)))) with (z + Z.of_nat (Datatypes.length (header a)) + Z.of_nat (Datatypes.length (body a) + length_opt (exit a))) by lia. + eapply (label_pos_body (body a) x0 x1 (z + Z.of_nat (Datatypes.length (header a))) (exit a) lbl). auto. +Qed. + +Lemma header_size_cons_nil: forall (l0: label) (l1: list label) + (HSIZE: list_length_z (l0 :: l1) <= 1), + l1 = nil. +Proof. + intros. + destruct l1; try congruence. rewrite !list_length_z_cons in HSIZE. + assert (list_length_z l1 >= 0) by eapply list_length_z_pos. + assert (list_length_z l1 + 1 + 1 >= 2) by lia. + assert (2 <= 1) by lia. contradiction H1. lia. +Qed. + +Lemma label_pos_preserved_gen bbs: forall lbl c z + (HUNF: unfold bbs = OK c), + label_pos lbl z bbs = Asm.label_pos lbl z c. +Proof. + induction bbs. + - intros. simpl in *. inversion HUNF. simpl. reflexivity. + - intros. simpl in *. monadInv HUNF. unfold unfold_bblock in EQ. + destruct (zle _ _); try congruence. monadInv EQ. + destruct (is_label _ _) eqn:EQLBL. + + erewrite label_in_header_list; eauto. + simpl in *. destruct (peq lbl lbl); try congruence. + + erewrite IHbbs; eauto. + rewrite (asm_label_pos_header z a x0 x1 lbl); auto. + unfold is_label in *. + destruct (header a). + * replace (z + list_length_z (@nil label)) with (z); eauto. + unfold list_length_z. simpl. lia. + * eapply header_size_cons_nil in l as HL1. + subst. simpl in *. destruct (in_dec _ _); try congruence. + simpl in *. + destruct (peq _ _); try intuition congruence. +Qed. + +Lemma label_pos_preserved f lbl z tf: forall + (FINDF: transf_function f = OK tf), + label_pos lbl z (fn_blocks f) = Asm.label_pos lbl z (Asm.fn_code tf). +Proof. + intros. + eapply label_pos_preserved_gen. + unfold transf_function in FINDF. monadInv FINDF. + destruct zlt; try congruence. inversion EQ0. eauto. +Qed. + +Lemma goto_label_preserved bb rs1 m1 rs1' m1' rs2 m2 lbl f tf v: forall + (FINDF: transf_function f = OK tf) + (BOUNDED: size bb <= Ptrofs.max_unsigned) + (MATCHI: match_internal (size bb - 1) (State rs1 m1) (State rs2 m2)) + (HGOTO: goto_label f lbl (incrPC v rs1) m1 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), Asm.goto_label tf lbl rs2 m2 = Next rs2' m2' + /\ match_states (State rs1' m1') (State rs2' m2'). +Proof. + intros. + unfold goto_label, Asm.goto_label in *. + rewrite <- (label_pos_preserved f); auto. + inversion MATCHI as [n0 r1 mx1 r2 mx2 EQM EQR EQPC]; subst. + destruct label_pos; next_stuck_cong. + destruct (incrPC v rs1 PC) eqn:INCRPC; next_stuck_cong. + inversion HGOTO; auto. repeat (econstructor; eauto). + rewrite <- EQPC. + unfold incrPC in *. + rewrite !Pregmap.gss in *. + destruct (rs1 PC) eqn:EQRS1; simpl in *; try congruence. + replace (rs2 # PC <- (Vptr b0 (Ptrofs.repr z))) with ((rs1 # PC <- (Vptr b0 (Ptrofs.add i0 v))) # PC <- (Vptr b (Ptrofs.repr z))); auto. + eapply functional_extensionality. intros. + destruct (PregEq.eq x PC); subst. + rewrite !Pregmap.gss. congruence. + rewrite !Pregmap.gso; auto. +Qed. + +Lemma next_inst_incr_pc_preserved bb rs1 m1 rs1' m1' rs2 m2 f tf: forall + (FINDF: transf_function f = OK tf) + (BOUNDED: size bb <= Ptrofs.max_unsigned) + (MATCHI: match_internal (size bb - 1) (State rs1 m1) (State rs2 m2)) + (NEXT: Next (incrPC (Ptrofs.repr (size bb)) rs1) m2 = Next rs1' m1'), + exists (rs2' : regset) (m2' : mem), + Next (Asm.nextinstr rs2) m2 = Next rs2' m2' + /\ match_states (State rs1' m1') (State rs2' m2'). +Proof. + intros; simpl in *; unfold incrPC in NEXT; + inv_matchi; + assert (size bb >= 1) by eapply bblock_size_pos; + assert (0 <= size bb - 1 <= Ptrofs.max_unsigned) by lia; + inversion NEXT; subst; + eexists; eexists; split; eauto. + assert (rs1 # PC <- (Val.offset_ptr (rs1 PC) (Ptrofs.repr (size bb))) = Asm.nextinstr rs2). { + unfold Pregmap.set. apply functional_extensionality. + intros x. destruct (PregEq.eq x PC). + -- unfold Asm.nextinstr. rewrite <- AGPC. + rewrite Val.offset_ptr_assoc. rewrite Ptrofs.add_unsigned. + rewrite (Ptrofs.unsigned_repr (size bb - 1)); try lia. + rewrite Ptrofs.unsigned_one. + replace (size bb - 1 + 1) with (size bb) by lia. + rewrite e. rewrite Pregmap.gss. + reflexivity. + -- eapply nextinstr_agree_but_pc; eauto. } + rewrite H1. econstructor. +Qed. + +Lemma pc_reg_overwrite: forall (r: ireg) rs1 m1 rs2 m2 bb + (MATCHI: match_internal (size bb - 1) (State rs1 m1) (State rs2 m2)), + rs2 # PC <- (rs2 r) = + (rs1 # PC <- (Val.offset_ptr (rs1 PC) (Ptrofs.repr (size bb)))) # PC <- + (rs1 r). +Proof. + intros. + unfold Pregmap.set; apply functional_extensionality. + intros x; destruct (PregEq.eq x PC) as [X | X]; try discriminate; inv_matchi. +Qed. + +Lemma exec_cfi_simulation: + forall bb f tf rs1 m1 rs1' m1' rs2 m2 cfi + (SIZE: size bb <= Ptrofs.max_unsigned) + (FINDF: transf_function f = OK tf) + (* Warning: Asmblock's PC is assumed to be already pointing on the next instruction ! *) + (CFI: exec_cfi ge f cfi (incrPC (Ptrofs.repr (size bb)) rs1) m1 = Next rs1' m1') + (MATCHI: match_internal (size bb - 1) (State rs1 m1) (State rs2 m2)), + exists rs2' m2', Asm.exec_instr tge tf (cf_instruction_to_instruction cfi) + rs2 m2 = Next rs2' m2' + /\ match_states (State rs1' m1') (State rs2' m2'). +Proof. + intros. + assert (BBPOS: size bb >= 1) by eapply bblock_size_pos. + destruct cfi; inv CFI; simpl. + - (* Pb *) + exploit goto_label_preserved; eauto. + - (* Pbc *) + inv_matchi. + unfold eval_testcond in *. destruct c; + erewrite !incrPC_agree_but_pc in H0; try rewrite <- !AG; try congruence. + all: + destruct_reg_size; + try destruct b eqn:EQB. + 1,4,7,10,13,16,19,22,25,28,31,34: + exploit goto_label_preserved; eauto. + 1,3,5,7,9,11,13,15,17,19,21,23: + exploit next_inst_incr_pc_preserved; eauto. + all: repeat (econstructor; eauto). + - (* Pbl *) + eexists; eexists; split; eauto. + assert ( ((incrPC (Ptrofs.repr (size bb)) rs1) # X30 <- (incrPC (Ptrofs.repr (size bb)) rs1 PC)) + # PC <- (Genv.symbol_address ge id Ptrofs.zero) + = (rs2 # X30 <- (Val.offset_ptr (rs2 PC) Ptrofs.one)) + # PC <- (Genv.symbol_address tge id Ptrofs.zero) + ) as EQRS. { + unfold incrPC. unfold Pregmap.set. simpl. apply functional_extensionality. + intros x. destruct (PregEq.eq x PC). + * rewrite symbol_addresses_preserved. reflexivity. + * destruct (PregEq.eq x X30). + -- inv MATCHI. rewrite <- AGPC. rewrite Val.offset_ptr_assoc. + unfold Ptrofs.add, Ptrofs.one. repeat (rewrite Ptrofs.unsigned_repr); try lia. + replace (size bb - 1 + 1) with (size bb) by lia. reflexivity. + -- inv MATCHI; rewrite AG; try assumption; reflexivity. + } rewrite EQRS; inv MATCHI; reflexivity. + - (* Pbs *) + eexists; eexists; split; eauto. + assert ( (incrPC (Ptrofs.repr (size bb)) rs1) # PC <- + (Genv.symbol_address ge id Ptrofs.zero) + = rs2 # PC <- (Genv.symbol_address tge id Ptrofs.zero) + ) as EQRS. { + unfold incrPC, Pregmap.set. rewrite symbol_addresses_preserved. inv MATCHI. + apply functional_extensionality. intros x. destruct (PregEq.eq x PC); auto. + } rewrite EQRS; inv MATCHI; reflexivity. + - (* Pblr *) + eexists; eexists; split; eauto. + unfold incrPC. rewrite Pregmap.gss. rewrite Pregmap.gso; try discriminate. + assert ( (rs2 # X30 <- (Val.offset_ptr (rs2 PC) Ptrofs.one)) # PC <- (rs2 r) + = ((rs1 # PC <- (Val.offset_ptr (rs1 PC) (Ptrofs.repr (size bb)))) + # X30 <- (Val.offset_ptr (rs1 PC) (Ptrofs.repr (size bb)))) + # PC <- (rs1 r) + ) as EQRS. { + unfold Pregmap.set. apply functional_extensionality. + intros x; destruct (PregEq.eq x PC) as [X | X]. + - inv_matchi; rewrite AG; auto. + - destruct (PregEq.eq x X30) as [X' | X']. + + inversion MATCHI; subst. rewrite <- AGPC. + rewrite Val.offset_ptr_assoc. unfold Ptrofs.one. + rewrite Ptrofs.add_unsigned. rewrite Ptrofs.unsigned_repr; try lia. rewrite Ptrofs.unsigned_repr; try lia. + rewrite Z.sub_add; reflexivity. + + inv_matchi. + } rewrite EQRS. inv_matchi. + - (* Pbr *) + eexists; eexists; split; eauto. + unfold incrPC. rewrite Pregmap.gso; try discriminate. + rewrite (pc_reg_overwrite r rs1 m1' rs2 m2 bb); auto. + inv_matchi. + - (* Pret *) + eexists; eexists; split; eauto. + unfold incrPC. rewrite Pregmap.gso; try discriminate. + rewrite (pc_reg_overwrite r rs1 m1' rs2 m2 bb); auto. + inv_matchi. + - (* Pcbnz *) + inv_matchi. + unfold eval_neg_branch in *. + erewrite incrPC_agree_but_pc in H0; try congruence. + destruct eval_testzero; next_stuck_cong. + destruct b. + * exploit next_inst_incr_pc_preserved; eauto. + * exploit goto_label_preserved; eauto. + - (* Pcbz *) + inv_matchi. + unfold eval_branch in *. + erewrite incrPC_agree_but_pc in H0; try congruence. + destruct eval_testzero; next_stuck_cong. + destruct b. + * exploit goto_label_preserved; eauto. + * exploit next_inst_incr_pc_preserved; eauto. + - (* Ptbnbz *) + inv_matchi. + unfold eval_branch in *. + erewrite incrPC_agree_but_pc in H0; try congruence. + destruct eval_testbit; next_stuck_cong. + destruct b. + * exploit goto_label_preserved; eauto. + * exploit next_inst_incr_pc_preserved; eauto. + - (* Ptbz *) + inv_matchi. + unfold eval_neg_branch in *. + erewrite incrPC_agree_but_pc in H0; try congruence. + destruct eval_testbit; next_stuck_cong. + destruct b. + * exploit next_inst_incr_pc_preserved; eauto. + * exploit goto_label_preserved; eauto. + - (* Pbtbl *) + assert (rs2 # X16 <- Vundef r1 = (incrPC (Ptrofs.repr (size bb)) rs1) # X16 <- Vundef r1) + as EQUNDEFX16. { + unfold incrPC, Pregmap.set. + destruct (PregEq.eq r1 X16) as [X16 | X16]; auto. + destruct (PregEq.eq r1 PC) as [PC' | PC']; try discriminate. + inv MATCHI; rewrite AG; auto. + } rewrite <- EQUNDEFX16 in H0. + destruct_reg_inv; next_stuck_cong. + unfold goto_label, Asm.goto_label in *. + rewrite <- (label_pos_preserved f); auto. + inversion MATCHI; subst. + destruct label_pos; next_stuck_cong. + destruct ((incrPC (Ptrofs.repr (size bb)) rs1) # X16 <- Vundef PC) eqn:INCRPC; next_stuck_cong. + inversion H0; auto. repeat (econstructor; eauto). + rewrite !Pregmap.gso; try congruence. + rewrite <- AGPC. + unfold incrPC in *. + destruct (rs1 PC) eqn:EQRS1; simpl in *; try discriminate. + replace ((rs2 # X16 <- Vundef) # PC <- (Vptr b0 (Ptrofs.repr z))) with + (((rs1 # PC <- (Vptr b0 (Ptrofs.add i1 (Ptrofs.repr (size bb))))) # X16 <- + Vundef) # PC <- (Vptr b (Ptrofs.repr z))); auto. + eapply functional_extensionality; intros x. + destruct (PregEq.eq x PC); subst. + + rewrite Pregmap.gso in INCRPC; try congruence. + rewrite Pregmap.gss in INCRPC. + rewrite !Pregmap.gss in *; congruence. + + rewrite Pregmap.gso; auto. + rewrite (Pregmap.gso (i := x) (j := PC)); auto. + destruct (PregEq.eq x X16); subst. + * rewrite !Pregmap.gss; auto. + * rewrite !Pregmap.gso; auto. +Qed. + +Lemma last_instruction_cannot_be_label bb: + list_nth_z (header bb) (size bb - 1) = None. +Proof. + assert (list_length_z (header bb) <= size bb - 1). { + rewrite bblock_size_aux. generalize (bblock_size_aux_pos bb). lia. } - - (* Mload notrap1 *) - inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. - -- (* Mload notrap *) - inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. - -- (* Mload notrap *) - inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate. - -- (* Mstore *) - assert (Op.eval_addressing tge sp addr (map rs args) = Some a). - { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. } - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto). - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - left; eapply exec_straight_steps; eauto. - intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. - split. eapply agree_undef_regs; eauto with asmgen. - split. simpl; congruence. - rewrite R. assumption. - -- (* Mcall *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - { eapply transf_function_no_overflow; eauto. } - destruct ros as [rf|fid]; simpl in H; monadInv H5. -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - { destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs0 x0 = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. } - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - { econstructor; eauto. } - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. rewrite <- H2. auto. - -- (* Mtailcall *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - { eapply transf_function_no_overflow; eauto. } - exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. - destruct ros as [rf|fid]; simpl in H; monadInv H7. -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - { destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs0 x0 = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. } - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. -+ (* Direct call *) - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. - -- (* Mbuiltin *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_builtin. eauto. eauto. - eapply find_instr_tail; eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x). - unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. - rewrite <- H1. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. - congruence. - - Simpl. - rewrite set_res_other by trivial. - rewrite undef_regs_other. - assumption. - intro. - rewrite in_map_iff. - intros (x0 & PREG & IN). - subst r'. - intro. - apply (preg_of_not_RA x0). - congruence. - -- (* Mgoto *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H4. - exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. - left; exists (State rs' m'); split. - apply plus_one. econstructor; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - econstructor; eauto. - eapply agree_exten; eauto with asmgen. - congruence. - - rewrite INV by congruence. - assumption. - -- (* Mcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_opt_steps_goto; eauto. - intros. simpl in TR. - exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C & D). - exists jmp; exists k; exists rs'. - split. eexact A. - split. apply agree_exten with rs0; auto with asmgen. - split. - exact B. - rewrite D. exact LEAF. - -- (* Mcond false *) - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C & D). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. eexact B. auto. - split. apply agree_exten with rs0; auto. intros. Simpl. - split. - simpl; congruence. - Simpl. rewrite D. - exact LEAF. - -- (* Mjumptable *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H6. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H5); intro NOOV. - exploit find_label_goto_label. eauto. eauto. - instantiate (2 := rs0#X16 <- Vundef #X17 <- Vundef). - Simpl. eauto. - eauto. - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H. intros LD; inv LD. - left; econstructor; split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail; eauto. - simpl. Simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. - econstructor; eauto. - eapply agree_undef_regs; eauto. - simpl. intros. rewrite C; auto with asmgen. Simpl. - congruence. - - rewrite C by congruence. - repeat rewrite Pregmap.gso by congruence. - assumption. - -- (* Mreturn *) - assert (f0 = f) by congruence. subst f0. - inversion AT; subst. simpl in H6; monadInv H6. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_steps_2; eauto using functions_transl. - intros (ofs' & P & Q). - left; econstructor; split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q. - simpl. reflexivity. - traceEq. - (* match states *) - econstructor; eauto. - apply agree_set_other; auto with asmgen. - -- (* internal function *) - - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0. - unfold store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - simpl chunk_of_type in F. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - change (chunk_of_type Tptr) with Mint64 in *. - (* Execution of function prologue *) - monadInv EQ0. rewrite transl_code'_transl_code in EQ1. - set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) :: - storeptr RA XSP (fn_retaddr_ofs f) x0) in *. - set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *. - set (rs2 := nextinstr (rs0#X29 <- (parent_sp s) #SP <- sp #X16 <- Vundef)). - exploit (storeptr_correct tge tf XSP (fn_retaddr_ofs f) RA x0 m2' m3' rs2). - simpl preg_of_iregsp. change (rs2 X30) with (rs0 X30). rewrite ATLR. - change (rs2 X2) with sp. eexact P. - simpl; congruence. congruence. - intros (rs3 & U & V & W). - assert (EXEC_PROLOGUE: - exec_straight tge tf - tf.(fn_code) rs0 m' - x0 rs3 m3'). - { change (fn_code tf) with tfbody; unfold tfbody. - apply exec_straight_step with rs2 m2'. - unfold exec_instr. rewrite C. fold sp. - rewrite <- (sp_val _ _ _ AG). rewrite F. reflexivity. - reflexivity. - eexact U. } - exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3 m3'); split. - eapply exec_straight_steps_1; eauto. omega. constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_nextinstr. apply agree_set_other; auto with asmgen. - apply agree_change_sp with (parent_sp s). - apply agree_undef_regs with rs0. auto. -Local Transparent destroyed_at_function_entry. simpl. - simpl; intros; Simpl. - unfold sp; congruence. - intros. rewrite V by auto with asmgen. reflexivity. - - rewrite W. - unfold rs2. - Simpl. - -- (* external function *) - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. apply agree_set_other; auto. apply agree_set_pair; auto. - apply agree_undef_caller_save_regs; auto. - -- (* return *) - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. - inv WF. - inv STACK. - inv H1. - congruence. + remember (list_nth_z (header bb) (size bb - 1)) as label_opt; destruct label_opt; auto; + exploit list_nth_z_range; eauto; lia. Qed. -Lemma transf_initial_states: - forall st1, Mach.initial_state prog st1 -> - exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. +Lemma pc_ptr_exec_step: forall ofs bb b rs m _rs _m + (ATPC : rs PC = Vptr b ofs) + (MATCHI : match_internal (size bb - 1) + {| _rs := rs; _m := m |} + {| _rs := _rs; _m := _m |}), + _rs PC = Vptr b (Ptrofs.add ofs (Ptrofs.repr (size bb - 1))). Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. + intros; inv MATCHI. rewrite <- AGPC; rewrite ATPC; unfold Val.offset_ptr; eauto. Qed. -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. +Lemma find_instr_ofs_somei: forall ofs bb f tc asmi rs m _rs _m + (BOUNDOFS : Ptrofs.unsigned ofs + size bb <= Ptrofs.max_unsigned) + (FIND_INSTR : Asm.find_instr (Ptrofs.unsigned ofs + (size bb - 1)) tc = + Some (asmi)) + (MATCHI : match_internal (size bb - 1) + {| _rs := rs; _m := m |} + {| _rs := _rs; _m := _m |}), + Asm.find_instr (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bb - 1)))) + (Asm.fn_code {| Asm.fn_sig := fn_sig f; Asm.fn_code := tc |}) = + Some (asmi). Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. + intros; simpl. + replace (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bb - 1)))) + with (Ptrofs.unsigned ofs + (size bb - 1)); try assumption. + generalize (bblock_size_pos bb); generalize (Ptrofs.unsigned_range_2 ofs); intros. + unfold Ptrofs.add. + rewrite Ptrofs.unsigned_repr. rewrite Ptrofs.unsigned_repr; try lia. + rewrite Ptrofs.unsigned_repr; lia. Qed. +Lemma eval_builtin_arg_match: forall rs _m _rs a1 b1 + (AG : forall r : preg, r <> PC -> rs r = _rs r) + (EVAL : eval_builtin_arg tge (fun r : dreg => rs r) (rs SP) _m a1 b1), + eval_builtin_arg tge _rs (_rs SP) _m (map_builtin_arg DR a1) b1. +Proof. + intros; induction EVAL; simpl in *; try rewrite AG; try rewrite AG in EVAL; try discriminate; try congruence; eauto with barg. + econstructor. rewrite <- AG; try discriminate; auto. +Qed. + +Lemma eval_builtin_args_match: forall bb rs m _rs _m args vargs + (MATCHI : match_internal (size bb - 1) + {| _rs := rs; _m := m |} + {| _rs := _rs; _m := _m |}) + (EVAL : eval_builtin_args tge (fun r : dreg => rs r) (rs SP) m args vargs), + eval_builtin_args tge _rs (_rs SP) _m (map (map_builtin_arg DR) args) vargs. +Proof. + intros; inv MATCHI. + induction EVAL; subst. + - econstructor. + - econstructor. + + eapply eval_builtin_arg_match; eauto. + + eauto. +Qed. + +Lemma pc_both_sides: forall (rs _rs: regset) v + (AG : forall r : preg, r <> PC -> rs r = _rs r), + rs # PC <- v = _rs # PC <- v. +Proof. + intros; unfold Pregmap.set; apply functional_extensionality; intros y. + destruct (PregEq.eq y PC); try rewrite AG; eauto. +Qed. + +Lemma set_buitin_res_sym res: forall vres rs _rs r + (NPC: r <> PC) + (AG : forall r : preg, r <> PC -> rs r = _rs r), + set_res res vres rs r = set_res res vres _rs r. +Proof. + induction res; simpl; intros; unfold Pregmap.set; try rewrite AG; eauto. +Qed. + +Lemma set_builtin_res_dont_move_pc_gen res: forall vres rs _rs v1 v2 + (HV: v1 = v2) + (AG : forall r : preg, r <> PC -> rs r = _rs r), + (set_res res vres rs) # PC <- v1 = + (set_res res vres _rs) # PC <- v2. +Proof. + intros. rewrite HV. generalize res vres rs _rs AG v2. + clear res vres rs _rs AG v1 v2 HV. + induction res. + - simpl; intros. apply pc_both_sides; intros. + unfold Pregmap.set; try rewrite AG; eauto. + - simpl; intros; apply pc_both_sides; eauto. + - simpl; intros. + erewrite IHres2; eauto; intros. + eapply set_buitin_res_sym; eauto. +Qed. + +Lemma set_builtin_map_not_pc (res: builtin_res dreg): forall vres rs, + set_res (map_builtin_res DR res) vres rs PC = rs PC. +Proof. + induction res. + - intros; simpl. unfold Pregmap.set. destruct (PregEq.eq PC x); try congruence. + - intros; simpl; congruence. + - intros; simpl in *. rewrite IHres2. rewrite IHres1. reflexivity. +Qed. + +Lemma undef_reg_preserved (rl: list mreg): forall rs _rs r + (NPC: r <> PC) + (AG : forall r : preg, r <> PC -> rs r = _rs r), + undef_regs (map preg_of rl) rs r = undef_regs (map preg_of rl) _rs r. +Proof. + induction rl. + - simpl; auto. + - simpl; intros. erewrite IHrl; eauto. + intros. unfold Pregmap.set. destruct (PregEq.eq r0 (preg_of a)); try rewrite AG; eauto. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +Lemma exec_exit_simulation_plus b ofs f bb s2 t rs m rs' m': forall + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (NEMPTY_EXIT: exit bb <> None) + (MATCHI: match_internal (size bb - Z.of_nat (length_opt (exit bb))) (State rs m) s2) + (EXIT: exec_exit ge f (Ptrofs.repr (size bb)) rs m (exit bb) t rs' m') + (ATPC: rs PC = Vptr b ofs), + plus Asm.step tge s2 t (State rs' m'). +Proof. + intros. + exploit internal_functions_unfold; eauto. + intros (tc & FINDtf & TRANStf & _). + + exploit (find_instr_bblock (size bb - 1)); eauto. + { generalize (bblock_size_pos bb). lia. } + intros (i' & NTH & FIND_INSTR). + + inv NTH. + + rewrite last_instruction_cannot_be_label in *. discriminate. + + destruct (exit bb) as [ctrl |] eqn:NEMPTY_EXIT'. 2: { contradiction. } + rewrite bblock_size_aux in *. rewrite NEMPTY_EXIT' in *. simpl in *. + (* XXX: Is there a better way to simplify this expression i.e. automatically? *) + replace (list_length_z (header bb) + list_length_z (body bb) + 1 - 1 - + list_length_z (header bb)) with (list_length_z (body bb)) in H by lia. + rewrite list_nth_z_range_exceeded in H; try lia. discriminate. + + assert (Ptrofs.unsigned ofs + size bb <= Ptrofs.max_unsigned). { + eapply size_of_blocks_bounds; eauto. + } + assert (size bb <= Ptrofs.max_unsigned). { generalize (Ptrofs.unsigned_range_2 ofs); lia. } + destruct cfi. + * (* control flow instruction *) + destruct s2. + rewrite H in EXIT. (* exit bb is a cfi *) + inv EXIT. + rewrite H in MATCHI. simpl in MATCHI. + exploit internal_functions_translated; eauto. + rewrite FINDtf. + intros (tf & FINDtf' & TRANSf). inversion FINDtf'; subst; clear FINDtf'. + exploit exec_cfi_simulation; eauto. + (* extract exec_cfi_simulation's conclusion as separate hypotheses *) + intros (rs2' & m2' & EXECI & MATCHS); rewrite MATCHS. + apply plus_one. + eapply Asm.exec_step_internal; eauto. + - eapply pc_ptr_exec_step; eauto. + - eapply find_instr_ofs_somei; eauto. + * (* builtin *) + destruct s2. + rewrite H in EXIT. + rewrite H in MATCHI. simpl in MATCHI. + simpl in FIND_INSTR. + inversion EXIT. + apply plus_one. + eapply external_call_symbols_preserved in H10; try (apply senv_preserved). + eapply eval_builtin_args_preserved in H6; try (apply symbols_preserved). + eapply Asm.exec_step_builtin; eauto. + - eapply pc_ptr_exec_step; eauto. + - eapply find_instr_ofs_somei; eauto. + - eapply eval_builtin_args_match; eauto. + - inv MATCHI; eauto. + - inv MATCHI. + unfold Asm.nextinstr, incrPC. + assert (HPC: Val.offset_ptr (rs PC) (Ptrofs.repr (size bb)) + = Val.offset_ptr (_rs PC) Ptrofs.one). + { rewrite <- AGPC. rewrite ATPC. unfold Val.offset_ptr. + rewrite Ptrofs.add_assoc. unfold Ptrofs.add. + assert (BBPOS: size bb >= 1) by eapply bblock_size_pos. + rewrite (Ptrofs.unsigned_repr (size bb - 1)); try lia. + rewrite Ptrofs.unsigned_one. + replace (size bb - 1 + 1) with (size bb) by lia. + reflexivity. } + apply set_builtin_res_dont_move_pc_gen. + -- erewrite !set_builtin_map_not_pc. + erewrite !undef_regs_other. + rewrite HPC; auto. + all: intros; simpl in *; destruct H3 as [HX16 | [HX30 | HDES]]; subst; try discriminate; + exploit list_in_map_inv; eauto; intros [mr [A B]]; subst; discriminate. + -- intros. eapply undef_reg_preserved; eauto. + intros. destruct (PregEq.eq X16 r0); destruct (PregEq.eq X30 r0); subst. + rewrite Pregmap.gso, Pregmap.gss; try congruence. + do 2 (rewrite Pregmap.gso, Pregmap.gss; try discriminate; auto). + rewrite 2Pregmap.gss; auto. + rewrite !Pregmap.gso; auto. +Qed. + +Lemma exec_exit_simulation_star b ofs f bb s2 t rs m rs' m': forall + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (MATCHI: match_internal (size bb - Z.of_nat (length_opt (exit bb))) (State rs m) s2) + (EXIT: exec_exit ge f (Ptrofs.repr (size bb)) rs m (exit bb) t rs' m') + (ATPC: rs PC = Vptr b ofs), + star Asm.step tge s2 t (State rs' m'). +Proof. + intros. + destruct (exit bb) eqn: Hex. + - eapply plus_star. + eapply exec_exit_simulation_plus; try rewrite Hex; congruence || eauto. + - inv MATCHI. + inv EXIT. + assert (X: rs2 = incrPC (Ptrofs.repr (size bb)) rs). { + unfold incrPC. unfold Pregmap.set. + apply functional_extensionality. intros x. + destruct (PregEq.eq x PC) as [X|]. + - rewrite X. rewrite <- AGPC. simpl. + replace (size bb - 0) with (size bb) by lia. reflexivity. + - rewrite AG; try assumption. reflexivity. + } + destruct X. + subst; eapply star_refl; eauto. +Qed. + +Lemma exec_bblock_simulation b ofs f bb t rs m rs' m': forall + (ATPC: rs PC = Vptr b ofs) + (FINDF: Genv.find_funct_ptr ge b = Some (Internal f)) + (FINDBB: find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb) + (EXECBB: exec_bblock lk ge f bb rs m t rs' m'), + plus Asm.step tge (State rs m) t (State rs' m'). +Proof. + intros; destruct EXECBB as (rs1 & m1 & BODY & CTL). + exploit exec_header_simulation; eauto. + intros (s0 & STAR & MATCH0). + eapply star_plus_trans; traceEq || eauto. + destruct (bblock_non_empty bb). + - (* body bb <> nil *) + exploit exec_body_simulation_plus; eauto. + intros (s1 & PLUS & MATCH1). + eapply plus_star_trans; traceEq || eauto. + eapply exec_exit_simulation_star; eauto. + erewrite <- exec_body_dont_move_PC; eauto. + - (* exit bb <> None *) + exploit exec_body_simulation_star; eauto. + intros (s1 & STAR1 & MATCH1). + eapply star_plus_trans; traceEq || eauto. + eapply exec_exit_simulation_plus; eauto. + erewrite <- exec_body_dont_move_PC; eauto. +Qed. + +Lemma step_simulation s t s': + Asmblock.step lk ge s t s' -> plus Asm.step tge s t s'. +Proof. + intros STEP. + inv STEP; simpl; exploit functions_translated; eauto; + intros (tf0 & FINDtf & TRANSf); + monadInv TRANSf. + - (* internal step *) eapply exec_bblock_simulation; eauto. + - (* external step *) + apply plus_one. + exploit external_call_symbols_preserved; eauto. apply senv_preserved. + intros ?. + eapply Asm.exec_step_external; eauto. +Qed. + +Lemma transf_program_correct: + forward_simulation (Asmblock.semantics lk prog) (Asm.semantics tprog). +Proof. + eapply forward_simulation_plus. + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - (* TODO step_simulation *) + unfold match_states. + simpl; intros; subst; eexists; split; eauto. + eapply step_simulation; eauto. +Qed. + +End PRESERVATION. + +End Asmblock_PRESERVATION. + + +Local Open Scope linking_scope. + +Definition block_passes := + mkpass Machblockgenproof.match_prog + ::: mkpass Asmblockgenproof.match_prog + ::: mkpass PostpassSchedulingproof.match_prog + ::: mkpass Asmblock_PRESERVATION.match_prog + ::: pass_nil _. + +Definition match_prog := pass_match (compose_passes block_passes). + +Lemma transf_program_match: + forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp. +Proof. + intros p tp H. + unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. + inversion_clear H. apply bind_inversion in H1. destruct H1. + inversion_clear H. + unfold Compopts.time in *. remember (Machblockgen.transf_program p) as mbp. + unfold match_prog; simpl. + exists mbp; split. apply Machblockgenproof.transf_program_match; auto. + exists x; split. apply Asmblockgenproof.transf_program_match; auto. + exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. + exists tp; split. apply Asmblock_PRESERVATION.transf_program_match; auto. auto. +Qed. + +(** Return Address Offset *) + +Definition return_address_offset: Mach.function -> Mach.code -> ptrofs -> Prop := + Machblockgenproof.Mach_return_address_offset (Asmblockgenproof.return_address_offset). + +Lemma return_address_exists: + forall f sg ros c, is_tail (Mach.Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros; unfold return_address_offset; eapply Machblockgenproof.Mach_return_address_exists; eauto. + intros; eapply Asmblockgenproof.return_address_exists; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Asm.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. - eapply forward_simulation_star with (measure := measure) - (match_states := fun S1 S2 => match_states S1 S2 /\ wf_state ge S1). - - apply senv_preserved. - - simpl; intros. exploit transf_initial_states; eauto. - intros (s2 & A & B). - exists s2; intuition auto. apply wf_initial; auto. - - simpl; intros. destruct H as [MS WF]. eapply transf_final_states; eauto. - - simpl; intros. destruct H0 as [MS WF]. - exploit step_simulation; eauto. intros [ (s2' & A & B) | (A & B & C) ]. - + left; exists s2'; intuition auto. eapply wf_step; eauto. - + right; intuition auto. eapply wf_step; eauto. + unfold match_prog in TRANSF. simpl in TRANSF. + inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. + eapply compose_forward_simulations. + { exploit Machblockgenproof.transf_program_correct; eauto. } + + eapply compose_forward_simulations. + + apply Asmblockgenproof.transf_program_correct; eauto. + { intros. + unfold Genv.symbol_address. + erewrite <- PostpassSchedulingproof.symbols_preserved; eauto. + erewrite Asmblock_PRESERVATION.symbol_high_low; eauto. + reflexivity. + } + + eapply compose_forward_simulations. + - apply PostpassSchedulingproof.transf_program_correct; eauto. + - apply Asmblock_PRESERVATION.transf_program_correct; eauto. Qed. End PRESERVATION. + +Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). + +(*******************************************) +(* Stub actually needed by driver/Compiler *) + +Module Asmgenproof0. + +Definition return_address_offset := return_address_offset. + +End Asmgenproof0. diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v deleted file mode 100644 index 0e36bd05..00000000 --- a/aarch64/Asmgenproof1.v +++ /dev/null @@ -1,2138 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, Collège de France and INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for AArch64 code generation: auxiliary results. *) - -Require Import Recdef Coqlib Zwf Zbits. -Require Import Maps Errors AST Integers Floats Values Memory Globalenvs. -Require Import Op Locations Mach Asm Conventions. -Require Import Asmgen. -Require Import Asmgenproof0. - -Local Transparent Archi.ptr64. - -(** Properties of registers *) - -Lemma preg_of_not_RA: - forall r, (preg_of r) <> RA. -Proof. - destruct r; discriminate. -Qed. - -Lemma RA_not_written: - forall (rs : regset) dst v, - rs # (preg_of dst) <- v RA = rs RA. -Proof. - intros. - apply Pregmap.gso. - intro. - symmetry in H. - exact (preg_of_not_RA dst H). -Qed. - -Hint Resolve RA_not_written : asmgen. - -Lemma RA_not_written2: - forall (rs : regset) dst v i, - preg_of dst = i -> - rs # i <- v RA = rs RA. -Proof. - intros. - subst i. - apply RA_not_written. -Qed. - -Hint Resolve RA_not_written2 : asmgen. - -Lemma RA_not_written3: - forall (rs : regset) dst v i, - ireg_of dst = OK i -> - rs # i <- v RA = rs RA. -Proof. - intros. - unfold ireg_of in H. - destruct preg_of eqn:PREG; try discriminate. - replace i0 with i in * by congruence. - eapply RA_not_written2; eassumption. -Qed. - -Hint Resolve RA_not_written3 : asmgen. - -Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC. -Proof. - destruct r; simpl; congruence. -Qed. -Hint Resolve preg_of_iregsp_not_PC: asmgen. - -Lemma preg_of_not_X16: forall r, preg_of r <> X16. -Proof. - destruct r; simpl; congruence. -Qed. - -Lemma ireg_of_not_X16: forall r x, ireg_of r = OK x -> x <> X16. -Proof. - unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H. - red; intros; subst x. elim (preg_of_not_X16 r); auto. -Qed. - -Lemma ireg_of_not_RA: forall r x, ireg_of r = OK x -> x <> RA. -Proof. - unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H. - red; intros; subst x. elim (preg_of_not_RA r); auto. -Qed. - -Lemma ireg_of_not_RA': forall r x, ireg_of r = OK x -> RA <> x. -Proof. - intros. intro. - apply (ireg_of_not_RA r x); auto. -Qed. - -Lemma ireg_of_not_RA'': forall r x, ireg_of r = OK x -> IR RA <> IR x. -Proof. - intros. intro. - apply (ireg_of_not_RA' r x); auto. congruence. -Qed. - -Hint Resolve ireg_of_not_RA ireg_of_not_RA' ireg_of_not_RA'' : asmgen. - -Lemma ireg_of_not_X16': forall r x, ireg_of r = OK x -> IR x <> IR X16. -Proof. - intros. apply ireg_of_not_X16 in H. congruence. -Qed. - -Hint Resolve preg_of_not_X16 ireg_of_not_X16 ireg_of_not_X16': asmgen. - -(** Useful simplification tactic *) - - -Ltac Simplif := - ((rewrite nextinstr_inv by eauto with asmgen) - || (rewrite nextinstr_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextinstr_pc) - || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -(** * Correctness of ARM constructor functions *) - -Section CONSTRUCTORS. - -Variable ge: genv. -Variable fn: function. - -(** Decomposition of integer literals *) - -Inductive wf_decomposition: list (Z * Z) -> Prop := - | wf_decomp_nil: - wf_decomposition nil - | wf_decomp_cons: forall m n p l, - n = Zzero_ext 16 m -> 0 <= p -> wf_decomposition l -> - wf_decomposition ((n, p) :: l). - -Lemma decompose_int_wf: - forall N n p, 0 <= p -> wf_decomposition (decompose_int N n p). -Proof. -Local Opaque Zzero_ext. - induction N as [ | N]; simpl; intros. -- constructor. -- set (frag := Zzero_ext 16 (Z.shiftr n p)) in *. destruct (Z.eqb frag 0). -+ apply IHN. omega. -+ econstructor. reflexivity. omega. apply IHN; omega. -Qed. - -Fixpoint recompose_int (accu: Z) (l: list (Z * Z)) : Z := - match l with - | nil => accu - | (n, p) :: l => recompose_int (Zinsert accu n p 16) l - end. - -Lemma decompose_int_correct: - forall N n p accu, - 0 <= p -> - (forall i, p <= i -> Z.testbit accu i = false) -> - (forall i, 0 <= i < p + Z.of_nat N * 16 -> - Z.testbit (recompose_int accu (decompose_int N n p)) i = - if zlt i p then Z.testbit accu i else Z.testbit n i). -Proof. - induction N as [ | N]; intros until accu; intros PPOS ABOVE i RANGE. -- simpl. rewrite zlt_true; auto. xomega. -- rewrite inj_S in RANGE. simpl. - set (frag := Zzero_ext 16 (Z.shiftr n p)). - assert (FRAG: forall i, p <= i < p + 16 -> Z.testbit n i = Z.testbit frag (i - p)). - { unfold frag; intros. rewrite Zzero_ext_spec by omega. rewrite zlt_true by omega. - rewrite Z.shiftr_spec by omega. f_equal; omega. } - destruct (Z.eqb_spec frag 0). -+ rewrite IHN. -* destruct (zlt i p). rewrite zlt_true by omega. auto. - destruct (zlt i (p + 16)); auto. - rewrite ABOVE by omega. rewrite FRAG by omega. rewrite e, Z.testbit_0_l. auto. -* omega. -* intros; apply ABOVE; omega. -* xomega. -+ simpl. rewrite IHN. -* destruct (zlt i (p + 16)). -** rewrite Zinsert_spec by omega. unfold proj_sumbool. - rewrite zlt_true by omega. - destruct (zlt i p). - rewrite zle_false by omega. auto. - rewrite zle_true by omega. simpl. symmetry; apply FRAG; omega. -** rewrite Z.ldiff_spec, Z.shiftl_spec by omega. - change 65535 with (two_p 16 - 1). rewrite Ztestbit_two_p_m1 by omega. - rewrite zlt_false by omega. rewrite zlt_false by omega. apply andb_true_r. -* omega. -* intros. rewrite Zinsert_spec by omega. unfold proj_sumbool. - rewrite zle_true by omega. rewrite zlt_false by omega. simpl. - apply ABOVE. omega. -* xomega. -Qed. - -Corollary decompose_int_eqmod: forall N n, - eqmod (two_power_nat (N * 16)%nat) (recompose_int 0 (decompose_int N n 0)) n. -Proof. - intros; apply eqmod_same_bits; intros. - rewrite decompose_int_correct. apply zlt_false; omega. - omega. intros; apply Z.testbit_0_l. xomega. -Qed. - -Corollary decompose_notint_eqmod: forall N n, - eqmod (two_power_nat (N * 16)%nat) - (Z.lnot (recompose_int 0 (decompose_int N (Z.lnot n) 0))) n. -Proof. - intros; apply eqmod_same_bits; intros. - rewrite Z.lnot_spec, decompose_int_correct. - rewrite zlt_false by omega. rewrite Z.lnot_spec by omega. apply negb_involutive. - omega. intros; apply Z.testbit_0_l. xomega. omega. -Qed. - -Lemma negate_decomposition_wf: - forall l, wf_decomposition l -> wf_decomposition (negate_decomposition l). -Proof. - induction 1; simpl; econstructor; auto. - instantiate (1 := (Z.lnot m)). - apply equal_same_bits; intros. - rewrite H. change 65535 with (two_p 16 - 1). - rewrite Z.lxor_spec, !Zzero_ext_spec, Z.lnot_spec, Ztestbit_two_p_m1 by omega. - destruct (zlt i 16). - apply xorb_true_r. - auto. -Qed. - -Lemma Zinsert_eqmod: - forall n x1 x2 y p l, 0 <= p -> 0 <= l -> - eqmod (two_power_nat n) x1 x2 -> - eqmod (two_power_nat n) (Zinsert x1 y p l) (Zinsert x2 y p l). -Proof. - intros. apply eqmod_same_bits; intros. rewrite ! Zinsert_spec by omega. - destruct (zle p i && zlt i (p + l)); auto. - apply same_bits_eqmod with n; auto. -Qed. - -Lemma Zinsert_0_l: - forall y p l, - 0 <= p -> 0 <= l -> - Z.shiftl (Zzero_ext l y) p = Zinsert 0 (Zzero_ext l y) p l. -Proof. - intros. apply equal_same_bits; intros. - rewrite Zinsert_spec by omega. unfold proj_sumbool. - destruct (zlt i p); [rewrite zle_false by omega|rewrite zle_true by omega]; simpl. -- rewrite Z.testbit_0_l, Z.shiftl_spec_low by auto. auto. -- rewrite Z.shiftl_spec by omega. - destruct (zlt i (p + l)); auto. - rewrite Zzero_ext_spec, zlt_false, Z.testbit_0_l by omega. auto. -Qed. - -Lemma recompose_int_negated: - forall l, wf_decomposition l -> - forall accu, recompose_int (Z.lnot accu) (negate_decomposition l) = Z.lnot (recompose_int accu l). -Proof. - induction 1; intros accu; simpl. -- auto. -- rewrite <- IHwf_decomposition. f_equal. apply equal_same_bits; intros. - rewrite Z.lnot_spec, ! Zinsert_spec, Z.lxor_spec, Z.lnot_spec by omega. - unfold proj_sumbool. - destruct (zle p i); simpl; auto. - destruct (zlt i (p + 16)); simpl; auto. - change 65535 with (two_p 16 - 1). - rewrite Ztestbit_two_p_m1 by omega. rewrite zlt_true by omega. - apply xorb_true_r. -Qed. - -Lemma exec_loadimm_k_w: - forall (rd: ireg) k m l, - wf_decomposition l -> - rd <> RA -> - forall (rs: regset) accu, - rs#rd = Vint (Int.repr accu) -> - exists rs', - exec_straight_opt ge fn (loadimm_k W rd l k) rs m k rs' m - /\ rs'#rd = Vint (Int.repr (recompose_int accu l)) - /\ (forall r, r <> PC -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - induction 1; intros RD_NOT_RA rs accu ACCU; simpl. -- exists rs; split. apply exec_straight_opt_refl. auto. -- destruct (IHwf_decomposition RD_NOT_RA - (nextinstr (rs#rd <- (insert_in_int rs#rd n p 16))) - (Zinsert accu n p 16)) - as (rs' & P & Q & R & S). - Simpl. rewrite ACCU. simpl. f_equal. apply Int.eqm_samerepr. - apply Zinsert_eqmod. auto. omega. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. - exists rs'; split. - eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. - split. exact Q. - split. - { intros; Simpl. - rewrite R by auto. Simpl. } - { rewrite S. Simpl. } -Qed. - -Lemma exec_loadimm_z_w: - forall rd l k rs m, - wf_decomposition l -> - rd <> RA -> - exists rs', - exec_straight ge fn (loadimm_z W rd l k) rs m k rs' m - /\ rs'#rd = Vint (Int.repr (recompose_int 0 l)) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm_z; destruct 1; intro RD_NOT_RA. -- econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -- set (accu0 := Zinsert 0 n p 16). - set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))). - destruct (exec_loadimm_k_w rd k m l H1 RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R & S); auto. - unfold rs1; Simpl. - exists rs2; split. - eapply exec_straight_opt_step; eauto. - simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega. - reflexivity. - split. exact Q. - intros. rewrite R by auto. unfold rs1; Simpl. -Qed. - -Lemma exec_loadimm_n_w: - forall rd l k rs m, - wf_decomposition l -> - rd <> RA -> - exists rs', - exec_straight ge fn (loadimm_n W rd l k) rs m k rs' m - /\ rs'#rd = Vint (Int.repr (Z.lnot (recompose_int 0 l))) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm_n; destruct 1; intro RD_NOT_RA. -- econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -- set (accu0 := Z.lnot (Zinsert 0 n p 16)). - set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))). - destruct (exec_loadimm_k_w rd k m (negate_decomposition l) - (negate_decomposition_wf l H1) - RD_NOT_RA rs1 accu0) - as (rs2 & P & Q & R & S). - unfold rs1; Simpl. - exists rs2; split. - eapply exec_straight_opt_step; eauto. - simpl. unfold rs1. do 5 f_equal. - unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega. - reflexivity. - split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. - intros. rewrite R by auto. unfold rs1; Simpl. -Qed. - -Lemma exec_loadimm32: - forall rd n k rs m - (RD_NOT_RA : rd <> RA), - exists rs', - exec_straight ge fn (loadimm32 rd n k) rs m k rs' m - /\ rs'#rd = Vint n - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm32, loadimm; intros. - destruct (is_logical_imm32 n). -- econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. rewrite Int.repr_unsigned, Int.or_zero_l; auto. - intros; Simpl. -- set (dz := decompose_int 2%nat (Int.unsigned n) 0). - set (dn := decompose_int 2%nat (Z.lnot (Int.unsigned n)) 0). - assert (A: Int.repr (recompose_int 0 dz) = n). - { transitivity (Int.repr (Int.unsigned n)). - apply Int.eqm_samerepr. apply decompose_int_eqmod. - apply Int.repr_unsigned. } - assert (B: Int.repr (Z.lnot (recompose_int 0 dn)) = n). - { transitivity (Int.repr (Int.unsigned n)). - apply Int.eqm_samerepr. apply decompose_notint_eqmod. - apply Int.repr_unsigned. } - destruct Nat.leb. -+ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; omega. trivial. -+ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; omega. trivial. -Qed. - -Lemma exec_loadimm_k_x: - forall (rd: ireg) k m l, - wf_decomposition l -> - rd <> RA -> - forall (rs: regset) accu, - rs#rd = Vlong (Int64.repr accu) -> - exists rs', - exec_straight_opt ge fn (loadimm_k X rd l k) rs m k rs' m - /\ rs'#rd = Vlong (Int64.repr (recompose_int accu l)) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - induction 1; intros RD_NOT_RA rs accu ACCU; simpl. -- exists rs; split. apply exec_straight_opt_refl. auto. -- destruct (IHwf_decomposition RD_NOT_RA - (nextinstr (rs#rd <- (insert_in_long rs#rd n p 16))) - (Zinsert accu n p 16)) - as (rs' & P & Q & R). - Simpl. rewrite ACCU. simpl. f_equal. apply Int64.eqm_samerepr. - apply Zinsert_eqmod. auto. omega. apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr. - exists rs'; split. - eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P. - split. exact Q. intros; Simpl. rewrite R by auto. Simpl. -Qed. - -Lemma exec_loadimm_z_x: - forall rd l k rs m, - wf_decomposition l -> - rd <> RA -> - exists rs', - exec_straight ge fn (loadimm_z X rd l k) rs m k rs' m - /\ rs'#rd = Vlong (Int64.repr (recompose_int 0 l)) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm_z; destruct 1; intro RD_NOT_RA. -- econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -- set (accu0 := Zinsert 0 n p 16). - set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))). - destruct (exec_loadimm_k_x rd k m l H1 RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R); auto. - unfold rs1; Simpl. - exists rs2; split. - eapply exec_straight_opt_step; eauto. - simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega. - reflexivity. - split. exact Q. - intros. rewrite R by auto. unfold rs1; Simpl. -Qed. - -Lemma exec_loadimm_n_x: - forall rd l k rs m, - wf_decomposition l -> - rd <> RA -> - exists rs', - exec_straight ge fn (loadimm_n X rd l k) rs m k rs' m - /\ rs'#rd = Vlong (Int64.repr (Z.lnot (recompose_int 0 l))) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm_n; destruct 1; intro RD_NOT_RA. -- econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -- set (accu0 := Z.lnot (Zinsert 0 n p 16)). - set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))). - destruct (exec_loadimm_k_x rd k m (negate_decomposition l) - (negate_decomposition_wf l H1) - RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R). - unfold rs1; Simpl. - exists rs2; split. - eapply exec_straight_opt_step; eauto. - simpl. unfold rs1. do 5 f_equal. - unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega. - reflexivity. - split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q. - intros. rewrite R by auto. unfold rs1; Simpl. -Qed. - -Lemma exec_loadimm64: - forall rd n k rs m, - rd <> RA -> - exists rs', - exec_straight ge fn (loadimm64 rd n k) rs m k rs' m - /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm64, loadimm; intros until m; intro RD_NOT_RA. - destruct (is_logical_imm64 n). -- econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. rewrite Int64.repr_unsigned, Int64.or_zero_l; auto. - intros; Simpl. -- set (dz := decompose_int 4%nat (Int64.unsigned n) 0). - set (dn := decompose_int 4%nat (Z.lnot (Int64.unsigned n)) 0). - assert (A: Int64.repr (recompose_int 0 dz) = n). - { transitivity (Int64.repr (Int64.unsigned n)). - apply Int64.eqm_samerepr. apply decompose_int_eqmod. - apply Int64.repr_unsigned. } - assert (B: Int64.repr (Z.lnot (recompose_int 0 dn)) = n). - { transitivity (Int64.repr (Int64.unsigned n)). - apply Int64.eqm_samerepr. apply decompose_notint_eqmod. - apply Int64.repr_unsigned. } - destruct Nat.leb. -+ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; omega. trivial. -+ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; omega. trivial. -Qed. - -(** Add immediate *) - -Lemma exec_addimm_aux_32: - forall (insn: iregsp -> iregsp -> Z -> instruction) (sem: val -> val -> val), - (forall rd r1 n rs m, - exec_instr ge fn (insn rd r1 n) rs m = - Next (nextinstr (rs#rd <- (sem rs#r1 (Vint (Int.repr n))))) m) -> - (forall v n1 n2, sem (sem v (Vint n1)) (Vint n2) = sem v (Vint (Int.add n1 n2))) -> - forall rd r1 n k rs m, - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (addimm_aux insn rd r1 (Int.unsigned n) k) rs m k rs' m - /\ rs'#rd = sem rs#r1 (Vint n) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros insn sem SEM ASSOC; intros until m; intro RD_NOT_RA. unfold addimm_aux. - set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo). - assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; omega). - rewrite <- (Int.repr_unsigned n). - destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. -- econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. - split; intros; Simpl. -- econstructor; split. eapply exec_straight_two. - apply SEM. apply SEM. Simpl. Simpl. - split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int.eqm_samerepr. - rewrite E. auto with ints. - split; intros; Simpl. -Qed. - -Lemma exec_addimm32: - forall rd r1 n k rs m, - r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (addimm32 rd r1 n k) rs m k rs' m - /\ rs'#rd = Val.add rs#r1 (Vint n) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros. unfold addimm32. set (nn := Int.neg n). - destruct (Int.eq n (Int.zero_ext 24 n)); [| destruct (Int.eq nn (Int.zero_ext 24 nn))]. -- apply exec_addimm_aux_32 with (sem := Val.add); auto. intros; apply Val.add_assoc. -- rewrite <- Val.sub_opp_add. - apply exec_addimm_aux_32 with (sem := Val.sub); auto. - intros. rewrite ! Val.sub_add_opp, Val.add_assoc. rewrite Int.neg_add_distr. auto. -- destruct (Int.lt n Int.zero). -+ rewrite <- Val.sub_opp_add; fold nn. - edestruct (exec_loadimm32 X16 nn) as (rs1 & A & B & C). congruence. - econstructor; split. - eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. - split. Simpl. rewrite B, C; eauto with asmgen. - split; intros; Simpl. -+ edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). congruence. - econstructor; split. - eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto. - split. Simpl. rewrite B, C; eauto with asmgen. - split; intros; Simpl. -Qed. - -Lemma exec_addimm_aux_64: - forall (insn: iregsp -> iregsp -> Z -> instruction) (sem: val -> val -> val), - (forall rd r1 n rs m, - exec_instr ge fn (insn rd r1 n) rs m = - Next (nextinstr (rs#rd <- (sem rs#r1 (Vlong (Int64.repr n))))) m) -> - (forall v n1 n2, sem (sem v (Vlong n1)) (Vlong n2) = sem v (Vlong (Int64.add n1 n2))) -> - forall rd r1 n k rs m, - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (addimm_aux insn rd r1 (Int64.unsigned n) k) rs m k rs' m - /\ rs'#rd = sem rs#r1 (Vlong n) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros insn sem SEM ASSOC; intros. unfold addimm_aux. - set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo). - assert (E: Int64.unsigned n = nhi + nlo) by (unfold nhi; omega). - rewrite <- (Int64.repr_unsigned n). - destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)]. -- econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one. apply SEM. Simpl. - split. Simpl. do 3 f_equal; omega. - split; intros; Simpl. -- econstructor; split. eapply exec_straight_two. - apply SEM. apply SEM. Simpl. Simpl. - split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int64.eqm_samerepr. - rewrite E. auto with ints. - split; intros; Simpl. -Qed. - -Lemma exec_addimm64: - forall rd r1 n k rs m, - preg_of_iregsp r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (addimm64 rd r1 n k) rs m k rs' m - /\ rs'#rd = Val.addl rs#r1 (Vlong n) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros. - unfold addimm64. set (nn := Int64.neg n). - destruct (Int64.eq n (Int64.zero_ext 24 n)); [| destruct (Int64.eq nn (Int64.zero_ext 24 nn))]. -- apply exec_addimm_aux_64 with (sem := Val.addl); auto. intros; apply Val.addl_assoc. -- rewrite <- Val.subl_opp_addl. - apply exec_addimm_aux_64 with (sem := Val.subl); auto. - intros. rewrite ! Val.subl_addl_opp, Val.addl_assoc. rewrite Int64.neg_add_distr. auto. -- destruct (Int64.lt n Int64.zero). -+ rewrite <- Val.subl_opp_addl; fold nn. - edestruct (exec_loadimm64 X16 nn) as (rs1 & A & B & C). congruence. - econstructor; split. - eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. - split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. - split; intros; Simpl. -+ edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). congruence. - econstructor; split. - eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl. - split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto. - split; intros; Simpl. -Qed. - -(** Logical immediate *) - -Lemma exec_logicalimm32: - forall (insn1: ireg -> ireg0 -> Z -> instruction) - (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) - (sem: val -> val -> val), - (forall rd r1 n rs m, - exec_instr ge fn (insn1 rd r1 n) rs m = - Next (nextinstr (rs#rd <- (sem rs##r1 (Vint (Int.repr n))))) m) -> - (forall rd r1 r2 s rs m, - exec_instr ge fn (insn2 rd r1 r2 s) rs m = - Next (nextinstr (rs#rd <- (sem rs##r1 (eval_shift_op_int rs#r2 s)))) m) -> - forall rd r1 n k rs m, - r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (logicalimm32 insn1 insn2 rd r1 n k) rs m k rs' m - /\ rs'#rd = sem rs#r1 (Vint n) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros until sem; intros SEM1 SEM2; intros. unfold logicalimm32. - destruct (is_logical_imm32 n). -- econstructor; split. - apply exec_straight_one. apply SEM1. reflexivity. - split. Simpl. rewrite Int.repr_unsigned; auto. - split; intros; Simpl. -- edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). congruence. - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. apply SEM2. reflexivity. - split. Simpl. f_equal; auto. apply C; auto with asmgen. - split; intros; Simpl. -Qed. - -Lemma exec_logicalimm64: - forall (insn1: ireg -> ireg0 -> Z -> instruction) - (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction) - (sem: val -> val -> val), - (forall rd r1 n rs m, - exec_instr ge fn (insn1 rd r1 n) rs m = - Next (nextinstr (rs#rd <- (sem rs###r1 (Vlong (Int64.repr n))))) m) -> - (forall rd r1 r2 s rs m, - exec_instr ge fn (insn2 rd r1 r2 s) rs m = - Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) -> - forall rd r1 n k rs m, - r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (logicalimm64 insn1 insn2 rd r1 n k) rs m k rs' m - /\ rs'#rd = sem rs#r1 (Vlong n) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros until sem; intros SEM1 SEM2; intros. unfold logicalimm64. - destruct (is_logical_imm64 n). -- econstructor; split. - apply exec_straight_one. apply SEM1. reflexivity. - split. Simpl. rewrite Int64.repr_unsigned. auto. - split; intros; Simpl. -- edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). congruence. - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. apply SEM2. reflexivity. - split. Simpl. f_equal; auto. apply C; auto with asmgen. - split; intros; Simpl. -Qed. - -(** Load address of symbol *) - -Lemma exec_loadsymbol: forall rd s ofs k rs m, - rd <> X16 \/ Archi.pic_code tt = false -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (loadsymbol rd s ofs k) rs m k rs' m - /\ rs'#rd = Genv.symbol_address ge s ofs - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs'#RA = rs#RA. -Proof. - unfold loadsymbol; intros. destruct (Archi.pic_code tt). -- predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. -+ subst ofs. econstructor; split. - apply exec_straight_one; [simpl; eauto | reflexivity]. - split. Simpl. split; intros; Simpl. - -+ exploit exec_addimm64. instantiate (1 := rd). simpl. destruct H; congruence. - instantiate (1 := rd). assumption. - intros (rs1 & A & B & C & D). - econstructor; split. - econstructor. simpl; eauto. auto. eexact A. - split. simpl in B; rewrite B. Simpl. - rewrite <- Genv.shift_symbol_address_64 by auto. - rewrite Ptrofs.add_zero_l, Ptrofs.of_int64_to_int64 by auto. auto. - split; intros. rewrite C by auto; Simpl. - rewrite D. Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. rewrite symbol_high_low; auto. - split; intros; Simpl. -Qed. - -(** Shifted operands *) - -Remark transl_shift_not_none: - forall s a, transl_shift s a <> SOnone. -Proof. - destruct s; intros; simpl; congruence. -Qed. - -Remark or_zero_eval_shift_op_int: - forall v s, s <> SOnone -> Val.or (Vint Int.zero) (eval_shift_op_int v s) = eval_shift_op_int v s. -Proof. - intros; destruct s; try congruence; destruct v; auto; simpl; - destruct (Int.ltu n Int.iwordsize); auto; rewrite Int.or_zero_l; auto. -Qed. - -Remark or_zero_eval_shift_op_long: - forall v s, s <> SOnone -> Val.orl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s. -Proof. - intros; destruct s; try congruence; destruct v; auto; simpl; - destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.or_zero_l; auto. -Qed. - -Remark add_zero_eval_shift_op_long: - forall v s, s <> SOnone -> Val.addl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s. -Proof. - intros; destruct s; try congruence; destruct v; auto; simpl; - destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.add_zero_l; auto. -Qed. - -Lemma transl_eval_shift: forall s v (a: amount32), - eval_shift_op_int v (transl_shift s a) = eval_shift s v a. -Proof. - intros. destruct s; simpl; auto. -Qed. - -Lemma transl_eval_shift': forall s v (a: amount32), - Val.or (Vint Int.zero) (eval_shift_op_int v (transl_shift s a)) = eval_shift s v a. -Proof. - intros. rewrite or_zero_eval_shift_op_int by (apply transl_shift_not_none). - apply transl_eval_shift. -Qed. - -Lemma transl_eval_shiftl: forall s v (a: amount64), - eval_shift_op_long v (transl_shift s a) = eval_shiftl s v a. -Proof. - intros. destruct s; simpl; auto. -Qed. - -Lemma transl_eval_shiftl': forall s v (a: amount64), - Val.orl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a. -Proof. - intros. rewrite or_zero_eval_shift_op_long by (apply transl_shift_not_none). - apply transl_eval_shiftl. -Qed. - -Lemma transl_eval_shiftl'': forall s v (a: amount64), - Val.addl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a. -Proof. - intros. rewrite add_zero_eval_shift_op_long by (apply transl_shift_not_none). - apply transl_eval_shiftl. -Qed. - -(** Zero- and Sign- extensions *) - -Lemma exec_move_extended_base: forall rd r1 ex k rs m, - exists rs', - exec_straight ge fn (move_extended_base rd r1 ex k) rs m k rs' m - /\ rs' rd = match ex with Xsgn32 => Val.longofint rs#r1 | Xuns32 => Val.longofintu rs#r1 end - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold move_extended_base; destruct ex; econstructor; - (split; [apply exec_straight_one; [simpl;eauto|auto] | split; [Simpl|intros;Simpl]]). -Qed. - -Lemma exec_move_extended: forall rd r1 ex (a: amount64) k rs m, - exists rs', - exec_straight ge fn (move_extended rd r1 ex a k) rs m k rs' m - /\ rs' rd = Op.eval_extend ex rs#r1 a - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold move_extended; intros. predSpec Int.eq Int.eq_spec a Int.zero. -- exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C). - exists rs'; split. eexact A. split. unfold Op.eval_extend. rewrite H. rewrite B. - destruct ex, (rs r1); simpl; auto; rewrite Int64.shl'_zero; auto. - auto. -- Local Opaque Val.addl. - exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - unfold exec_instr. change (SOlsl a) with (transl_shift Slsl a). rewrite transl_eval_shiftl''. eauto. auto. - split. Simpl. rewrite B. auto. - intros; Simpl. -Qed. - -Lemma exec_arith_extended: - forall (sem: val -> val -> val) - (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction) - (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction), - (forall rd r1 r2 x rs m, - exec_instr ge fn (insnX rd r1 r2 x) rs m = - Next (nextinstr (rs#rd <- (sem rs#r1 (eval_extend rs#r2 x)))) m) -> - (forall rd r1 r2 s rs m, - exec_instr ge fn (insnS rd r1 r2 s) rs m = - Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) -> - forall (rd r1 r2: ireg) (ex: extension) (a: amount64) (k: code) rs m, - r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (arith_extended insnX insnS rd r1 r2 ex a k) rs m k rs' m - /\ rs'#rd = sem rs#r1 (Op.eval_extend ex rs#r2 a) - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros sem insnX insnS EX ES; intros. unfold arith_extended. destruct (Int.ltu a (Int.repr 5)). -- econstructor; split. - apply exec_straight_one. rewrite EX; eauto. auto. - split. Simpl. f_equal. destruct ex; auto. - split; intros; Simpl. -- exploit (exec_move_extended_base X16 r2 ex). intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - rewrite ES. eauto. auto. - split. Simpl. unfold ir0x. rewrite C by eauto with asmgen. f_equal. - rewrite B. destruct ex; auto. - split; intros; Simpl. -Qed. - -(** Extended right shift *) - -Lemma exec_shrx32: forall (rd r1: ireg) (n: int) k v (rs: regset) m, - Val.shrx rs#r1 (Vint n) = Some v -> - r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (shrx32 rd r1 n k) rs m k rs' m - /\ rs'#rd = v - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - unfold shrx32; intros. apply Val.shrx_shr_3 in H. - destruct (Int.eq n Int.zero) eqn:E. -- econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. - split. Simpl. subst v; auto. - split; intros; Simpl. -- generalize (Int.eq_spec n Int.one). - destruct (Int.eq n Int.one); intro ONE. - * subst n. - econstructor; split. eapply exec_straight_two. - all: simpl; auto. - split. - ** subst v; Simpl. - destruct (Val.add _ _); simpl; trivial. - change (Int.ltu Int.one Int.iwordsize) with true; simpl. - rewrite Int.or_zero_l. - reflexivity. - ** split; intros; Simpl. - * econstructor; split. eapply exec_straight_three. - unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. - simpl; eauto. - unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto. - auto. auto. auto. - split. subst v; Simpl. - split; intros; Simpl. -Qed. - -Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m, - Val.shrxl rs#r1 (Vint n) = Some v -> - r1 <> X16 -> - (IR RA) <> (preg_of_iregsp (RR1 rd)) -> - exists rs', - exec_straight ge fn (shrx64 rd r1 n k) rs m k rs' m - /\ rs'#rd = v - /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - unfold shrx64; intros. apply Val.shrxl_shrl_3 in H. - destruct (Int.eq n Int.zero) eqn:E. -- econstructor; split. apply exec_straight_one; [simpl;eauto|auto]. - split. Simpl. subst v; auto. - split; intros; Simpl. -- generalize (Int.eq_spec n Int.one). - destruct (Int.eq n Int.one); intro ONE. - * subst n. - econstructor; split. eapply exec_straight_two. - all: simpl; auto. - split. - ** subst v; Simpl. - destruct (Val.addl _ _); simpl; trivial. - change (Int.ltu Int.one Int64.iwordsize') with true; simpl. - rewrite Int64.or_zero_l. - reflexivity. - ** split; intros; Simpl. - * econstructor; split. eapply exec_straight_three. - unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. - simpl; eauto. - unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto. - auto. auto. auto. - split. subst v; Simpl. - split; intros; Simpl. -Qed. - -(** Condition bits *) - -Lemma compare_int_spec: forall rs v1 v2 m, - let rs' := compare_int rs v1 v2 m in - rs'#CN = (Val.negative (Val.sub v1 v2)) - /\ rs'#CZ = (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2) - /\ rs'#CC = (Val.cmpu (Mem.valid_pointer m) Cge v1 v2) - /\ rs'#CV = (Val.sub_overflow v1 v2). -Proof. - intros; unfold rs'; auto. -Qed. - -Lemma eval_testcond_compare_sint: forall c v1 v2 b rs m, - Val.cmp_bool c v1 v2 = Some b -> - eval_testcond (cond_for_signed_cmp c) (compare_int rs v1 v2 m) = Some b. -Proof. - intros. generalize (compare_int_spec rs v1 v2 m). - set (rs' := compare_int rs v1 v2 m). intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. - destruct v1; try discriminate; destruct v2; try discriminate. - simpl in H; inv H. - unfold Val.cmpu; simpl. destruct c; simpl. -- destruct (Int.eq i i0); auto. -- destruct (Int.eq i i0); auto. -- rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto. -- rewrite Int.lt_sub_overflow, Int.not_lt. - destruct (Int.eq i i0), (Int.lt i i0); auto. -- rewrite Int.lt_sub_overflow, (Int.lt_not i). - destruct (Int.eq i i0), (Int.lt i i0); auto. -- rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto. -Qed. - -Lemma eval_testcond_compare_uint: forall c v1 v2 b rs m, - Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> - eval_testcond (cond_for_unsigned_cmp c) (compare_int rs v1 v2 m) = Some b. -Proof. - intros. generalize (compare_int_spec rs v1 v2 m). - set (rs' := compare_int rs v1 v2 m). intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. - destruct v1; try discriminate; destruct v2; try discriminate. - simpl in H; inv H. - unfold Val.cmpu; simpl. destruct c; simpl. -- destruct (Int.eq i i0); auto. -- destruct (Int.eq i i0); auto. -- destruct (Int.ltu i i0); auto. -- rewrite (Int.not_ltu i). destruct (Int.eq i i0), (Int.ltu i i0); auto. -- rewrite (Int.ltu_not i). destruct (Int.eq i i0), (Int.ltu i i0); auto. -- destruct (Int.ltu i i0); auto. -Qed. - -Lemma compare_long_spec: forall rs v1 v2 m, - let rs' := compare_long rs v1 v2 m in - rs'#CN = (Val.negativel (Val.subl v1 v2)) - /\ rs'#CZ = (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2)) - /\ rs'#CC = (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cge v1 v2)) - /\ rs'#CV = (Val.subl_overflow v1 v2). -Proof. - intros; unfold rs'; auto. -Qed. - -Remark int64_sub_overflow: - forall x y, - Int.xor (Int.repr (Int64.unsigned (Int64.sub_overflow x y Int64.zero))) - (Int.repr (Int64.unsigned (Int64.negative (Int64.sub x y)))) = - (if Int64.lt x y then Int.one else Int.zero). -Proof. - intros. - transitivity (Int.repr (Int64.unsigned (if Int64.lt x y then Int64.one else Int64.zero))). - rewrite <- (Int64.lt_sub_overflow x y). - unfold Int64.sub_overflow, Int64.negative. - set (s := Int64.signed x - Int64.signed y - Int64.signed Int64.zero). - destruct (zle Int64.min_signed s && zle s Int64.max_signed); - destruct (Int64.lt (Int64.sub x y) Int64.zero); - auto. - destruct (Int64.lt x y); auto. -Qed. - -Lemma eval_testcond_compare_slong: forall c v1 v2 b rs m, - Val.cmpl_bool c v1 v2 = Some b -> - eval_testcond (cond_for_signed_cmp c) (compare_long rs v1 v2 m) = Some b. -Proof. - intros. generalize (compare_long_spec rs v1 v2 m). - set (rs' := compare_long rs v1 v2 m). intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. - destruct v1; try discriminate; destruct v2; try discriminate. - simpl in H; inv H. - unfold Val.cmplu; simpl. destruct c; simpl. -- destruct (Int64.eq i i0); auto. -- destruct (Int64.eq i i0); auto. -- rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto. -- rewrite int64_sub_overflow, Int64.not_lt. - destruct (Int64.eq i i0), (Int64.lt i i0); auto. -- rewrite int64_sub_overflow, (Int64.lt_not i). - destruct (Int64.eq i i0), (Int64.lt i i0); auto. -- rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto. -Qed. - -Lemma eval_testcond_compare_ulong: forall c v1 v2 b rs m, - Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> - eval_testcond (cond_for_unsigned_cmp c) (compare_long rs v1 v2 m) = Some b. -Proof. - intros. generalize (compare_long_spec rs v1 v2 m). - set (rs' := compare_long rs v1 v2 m). intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E; unfold Val.cmplu. - destruct v1; try discriminate; destruct v2; try discriminate; simpl in H. -- (* int-int *) - inv H. destruct c; simpl. -+ destruct (Int64.eq i i0); auto. -+ destruct (Int64.eq i i0); auto. -+ destruct (Int64.ltu i i0); auto. -+ rewrite (Int64.not_ltu i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto. -+ rewrite (Int64.ltu_not i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto. -+ destruct (Int64.ltu i i0); auto. -- (* int-ptr *) - simpl. - destruct (Int64.eq i Int64.zero && - (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) - || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))); try discriminate. - destruct c; simpl in H; inv H; reflexivity. -- (* ptr-int *) - simpl. - destruct (Int64.eq i0 Int64.zero && - (Mem.valid_pointer m b0 (Ptrofs.unsigned i) - || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))); try discriminate. - destruct c; simpl in H; inv H; reflexivity. -- (* ptr-ptr *) - simpl. - destruct (eq_block b0 b1). -+ destruct ((Mem.valid_pointer m b0 (Ptrofs.unsigned i) - || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1)) && - (Mem.valid_pointer m b1 (Ptrofs.unsigned i0) - || Mem.valid_pointer m b1 (Ptrofs.unsigned i0 - 1))); - inv H. - destruct c; simpl. -* destruct (Ptrofs.eq i i0); auto. -* destruct (Ptrofs.eq i i0); auto. -* destruct (Ptrofs.ltu i i0); auto. -* rewrite (Ptrofs.not_ltu i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto. -* rewrite (Ptrofs.ltu_not i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto. -* destruct (Ptrofs.ltu i i0); auto. -+ destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) && - Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate. - destruct c; simpl in H; inv H; reflexivity. -Qed. - -Lemma compare_float_spec: forall rs f1 f2, - let rs' := compare_float rs (Vfloat f1) (Vfloat f2) in - rs'#CN = (Val.of_bool (Float.cmp Clt f1 f2)) - /\ rs'#CZ = (Val.of_bool (Float.cmp Ceq f1 f2)) - /\ rs'#CC = (Val.of_bool (negb (Float.cmp Clt f1 f2))) - /\ rs'#CV = (Val.of_bool (negb (Float.ordered f1 f2))). -Proof. - intros; auto. -Qed. - -Lemma eval_testcond_compare_float: forall c v1 v2 b rs, - Val.cmpf_bool c v1 v2 = Some b -> - eval_testcond (cond_for_float_cmp c) (compare_float rs v1 v2) = Some b. -Proof. - intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. - generalize (compare_float_spec rs f f0). - set (rs' := compare_float rs (Vfloat f) (Vfloat f0)). - intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. -Local Transparent Float.cmp Float.ordered. - unfold Float.cmp, Float.ordered; - destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity. -Qed. - -Lemma eval_testcond_compare_not_float: forall c v1 v2 b rs, - option_map negb (Val.cmpf_bool c v1 v2) = Some b -> - eval_testcond (cond_for_float_not_cmp c) (compare_float rs v1 v2) = Some b. -Proof. - intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. - generalize (compare_float_spec rs f f0). - set (rs' := compare_float rs (Vfloat f) (Vfloat f0)). - intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. -Local Transparent Float.cmp Float.ordered. - unfold Float.cmp, Float.ordered; - destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity. -Qed. - -Lemma compare_single_spec: forall rs f1 f2, - let rs' := compare_single rs (Vsingle f1) (Vsingle f2) in - rs'#CN = (Val.of_bool (Float32.cmp Clt f1 f2)) - /\ rs'#CZ = (Val.of_bool (Float32.cmp Ceq f1 f2)) - /\ rs'#CC = (Val.of_bool (negb (Float32.cmp Clt f1 f2))) - /\ rs'#CV = (Val.of_bool (negb (Float32.ordered f1 f2))). -Proof. - intros; auto. -Qed. - -Lemma eval_testcond_compare_single: forall c v1 v2 b rs, - Val.cmpfs_bool c v1 v2 = Some b -> - eval_testcond (cond_for_float_cmp c) (compare_single rs v1 v2) = Some b. -Proof. - intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. - generalize (compare_single_spec rs f f0). - set (rs' := compare_single rs (Vsingle f) (Vsingle f0)). - intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. -Local Transparent Float32.cmp Float32.ordered. - unfold Float32.cmp, Float32.ordered; - destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity. -Qed. - -Lemma eval_testcond_compare_not_single: forall c v1 v2 b rs, - option_map negb (Val.cmpfs_bool c v1 v2) = Some b -> - eval_testcond (cond_for_float_not_cmp c) (compare_single rs v1 v2) = Some b. -Proof. - intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H. - generalize (compare_single_spec rs f f0). - set (rs' := compare_single rs (Vsingle f) (Vsingle f0)). - intros (B & C & D & E). - unfold eval_testcond; rewrite B, C, D, E. -Local Transparent Float32.cmp Float32.ordered. - unfold Float32.cmp, Float32.ordered; - destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity. -Qed. - -Remark compare_float_inv: forall rs v1 v2 r, - match r with CR _ => False | _ => True end -> - (nextinstr (compare_float rs v1 v2))#r = (nextinstr rs)#r. -Proof. - intros; unfold compare_float. - destruct r; try contradiction; destruct v1; auto; destruct v2; auto. -Qed. - -Remark compare_single_inv: forall rs v1 v2 r, - match r with CR _ => False | _ => True end -> - (nextinstr (compare_single rs v1 v2))#r = (nextinstr rs)#r. -Proof. - intros; unfold compare_single. - destruct r; try contradiction; destruct v1; auto; destruct v2; auto. -Qed. - -(** Translation of conditionals *) - -Ltac ArgsInv := - repeat (match goal with - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args - | [ H: bind _ _ = OK _ |- _ ] => monadInv H - | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - end); - subst; - repeat (match goal with - | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * - | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * - end). - -Lemma compare_int_RA: - forall rs a b m, - compare_int rs a b m X30 = rs X30. -Proof. - unfold compare_int. - intros. - repeat rewrite Pregmap.gso by congruence. - trivial. -Qed. - -Hint Resolve compare_int_RA : asmgen. - -Lemma compare_long_RA: - forall rs a b m, - compare_long rs a b m X30 = rs X30. -Proof. - unfold compare_long. - intros. - repeat rewrite Pregmap.gso by congruence. - trivial. -Qed. - -Hint Resolve compare_long_RA : asmgen. - -Lemma compare_float_RA: - forall rs a b, - compare_float rs a b X30 = rs X30. -Proof. - unfold compare_float. - intros. - destruct a; destruct b. - all: repeat rewrite Pregmap.gso by congruence; trivial. -Qed. - -Hint Resolve compare_float_RA : asmgen. - - -Lemma compare_single_RA: - forall rs a b, - compare_single rs a b X30 = rs X30. -Proof. - unfold compare_single. - intros. - destruct a; destruct b. - all: repeat rewrite Pregmap.gso by congruence; trivial. -Qed. - -Hint Resolve compare_single_RA : asmgen. - - -Lemma transl_cond_correct: - forall cond args k c rs m, - transl_cond cond args k = OK c -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ (forall b, - eval_condition cond (map rs (map preg_of args)) m = Some b -> - eval_testcond (cond_for_cond cond) rs' = Some b) - /\ (forall r, data_preg r = true -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros until m; intros TR. destruct cond; simpl in TR; ArgsInv. -- (* Ccomp *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. apply eval_testcond_compare_sint; auto. - destruct r; reflexivity || discriminate. -- (* Ccompu *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. apply eval_testcond_compare_uint; auto. - destruct r; reflexivity || discriminate. -- (* Ccompimm *) - destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_sint; auto. - destruct r; reflexivity || discriminate. -+ econstructor; split. - apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. - repeat split; intros. apply eval_testcond_compare_sint; auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply eval_testcond_compare_sint; auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. - auto with asmgen. - Simpl. rewrite compare_int_RA. - apply C; congruence. -- (* Ccompuimm *) - destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))]. -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_uint; auto. - destruct r; reflexivity || discriminate. -+ econstructor; split. - apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto. - repeat split; intros. apply eval_testcond_compare_uint; auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply eval_testcond_compare_uint; auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_int_RA. - apply C; congruence. -- (* Ccompshift *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_sint; auto. - destruct r; reflexivity || discriminate. -- (* Ccompushift *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_uint; auto. - destruct r; reflexivity || discriminate. -- (* Cmaskzero *) - destruct (is_logical_imm32 n). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Ceq); auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply (eval_testcond_compare_sint Ceq); auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_int_RA. - apply C; congruence. - -- (* Cmasknotzero *) - destruct (is_logical_imm32 n). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Cne); auto. - destruct r; reflexivity || discriminate. - -+ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply (eval_testcond_compare_sint Cne); auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_int_RA. - apply C; congruence. - -- (* Ccompl *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. apply eval_testcond_compare_slong; auto. - destruct r; reflexivity || discriminate. -- (* Ccomplu *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. apply eval_testcond_compare_ulong; auto. - destruct r; reflexivity || discriminate. -- (* Ccomplimm *) - destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_slong; auto. - destruct r; reflexivity || discriminate. -+ econstructor; split. - apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto. - repeat split; intros. apply eval_testcond_compare_slong; auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply eval_testcond_compare_slong; auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_long_RA. - apply C; congruence. - -- (* Ccompluimm *) - destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))]. -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_ulong; auto. - destruct r; reflexivity || discriminate. -+ econstructor; split. - apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto. - repeat split; intros. apply eval_testcond_compare_ulong; auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply eval_testcond_compare_ulong; auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_long_RA. - apply C; congruence. - -- (* Ccomplshift *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_slong; auto. - destruct r; reflexivity || discriminate. -- (* Ccomplushift *) - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_ulong; auto. - destruct r; reflexivity || discriminate. -- (* Cmasklzero *) - destruct (is_logical_imm64 n). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Ceq); auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply (eval_testcond_compare_slong Ceq); auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_long_RA. - apply C; congruence. - -- (* Cmasknotzero *) - destruct (is_logical_imm64 n). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - repeat split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Cne); auto. - destruct r; reflexivity || discriminate. -+ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto. - repeat split; intros. apply (eval_testcond_compare_slong Cne); auto. - transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen. - Simpl. rewrite compare_long_RA. - apply C; congruence. - -- (* Ccompf *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_float_inv; auto. - repeat split; intros. apply eval_testcond_compare_float; auto. - destruct r; discriminate || rewrite compare_float_inv; auto. - Simpl. -- (* Cnotcompf *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_float_inv; auto. - repeat split; intros. apply eval_testcond_compare_not_float; auto. - destruct r; discriminate || rewrite compare_float_inv; auto. - Simpl. -- (* Ccompfzero *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_float_inv; auto. - repeat split; intros. apply eval_testcond_compare_float; auto. - destruct r; discriminate || rewrite compare_float_inv; auto. - Simpl. -- (* Cnotcompfzero *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_float_inv; auto. - repeat split; intros. apply eval_testcond_compare_not_float; auto. - destruct r; discriminate || rewrite compare_float_inv; auto. - Simpl. -- (* Ccompfs *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_single_inv; auto. - repeat split; intros. apply eval_testcond_compare_single; auto. - destruct r; discriminate || rewrite compare_single_inv; auto. - Simpl. -- (* Cnotcompfs *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_single_inv; auto. - repeat split; intros. apply eval_testcond_compare_not_single; auto. - destruct r; discriminate || rewrite compare_single_inv; auto. - Simpl. -- (* Ccompfszero *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_single_inv; auto. - repeat split; intros. apply eval_testcond_compare_single; auto. - destruct r; discriminate || rewrite compare_single_inv; auto. - Simpl. -- (* Cnotcompfszero *) - econstructor; split. apply exec_straight_one. simpl; eauto. - rewrite compare_single_inv; auto. - repeat split; intros. apply eval_testcond_compare_not_single; auto. - destruct r; discriminate || rewrite compare_single_inv; auto. - Simpl. -Qed. - -(** Translation of conditional branches *) - -Lemma transl_cond_branch_correct: - forall cond args lbl k c rs m b, - transl_cond_branch cond args lbl k = OK c -> - eval_condition cond (map rs (map preg_of args)) m = Some b -> - exists rs' insn, - exec_straight_opt ge fn c rs m (insn :: k) rs' m - /\ exec_instr ge fn insn rs' m = - (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m) - /\ (forall r, data_preg r = true -> rs'#r = rs#r) - /\ rs' # RA = rs # RA. -Proof. - intros until b; intros TR EV. - assert (DFL: - transl_cond_branch_default cond args lbl k = OK c -> - exists rs' insn, - exec_straight_opt ge fn c rs m (insn :: k) rs' m - /\ exec_instr ge fn insn rs' m = - (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m) - /\ (forall r, data_preg r = true -> rs'#r = rs#r) - /\ rs' # RA = rs # RA ). - { - unfold transl_cond_branch_default; intros. - exploit transl_cond_correct; eauto. intros (rs' & A & B & C & D). - exists rs', (Pbc (cond_for_cond cond) lbl); split. - apply exec_straight_opt_intro. eexact A. - repeat split; auto. simpl. rewrite (B b) by auto. auto. - } -Local Opaque transl_cond transl_cond_branch_default. - destruct args as [ | a1 args]; simpl in TR; auto. - destruct args as [ | a2 args]; simpl in TR; auto. - destruct cond; simpl in TR; auto. -- (* Ccompimm *) - destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto; - apply Int.same_if_eq in N0; subst n; ArgsInv. -+ (* Ccompimm Cne 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. auto. -+ (* Ccompimm Ceq 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. destruct (Int.eq i Int.zero); auto. -- (* Ccompuimm *) - destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto; - apply Int.same_if_eq in N0; subst n; ArgsInv. -+ (* Ccompuimm Cne 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. rewrite EV. auto. -+ (* Ccompuimm Ceq 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cne), EV. destruct b; auto. -- (* Cmaskzero *) - destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv. - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. - erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto. - rewrite (Val.negate_cmp_bool Ceq), EV. destruct b; auto. -- (* Cmasknotzero *) - destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv. - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. - erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto. - rewrite EV. auto. -- (* Ccomplimm *) - destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto; - apply Int64.same_if_eq in N0; subst n; ArgsInv. -+ (* Ccomplimm Cne 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. auto. -+ (* Ccomplimm Ceq 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. destruct (Int64.eq i Int64.zero); auto. -- (* Ccompluimm *) - destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto; - apply Int64.same_if_eq in N0; subst n; ArgsInv. -+ (* Ccompluimm Cne 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. rewrite EV. auto. -+ (* Ccompluimm Ceq 0 *) - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cne), EV. destruct b; auto. -- (* Cmasklzero *) - destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv. - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. - erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto. - rewrite (Val.negate_cmpl_bool Ceq), EV. destruct b; auto. -- (* Cmasklnotzero *) - destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv. - do 2 econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. - erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto. - rewrite EV. auto. -Qed. - -(** Translation of arithmetic operations *) - -Ltac SimplEval H := - match type of H with - | Some _ = None _ => discriminate - | Some _ = Some _ => inv H - | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) -end. - -Ltac TranslOpSimpl := - econstructor; split; - [ apply exec_straight_one; [simpl; eauto | reflexivity] - | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; - apply Val.lessdef_same; Simpl; fail - | split; [ intros; Simpl; fail - | intros; Simpl; eauto with asmgen; fail] ]]. - -Ltac TranslOpBase := - econstructor; split; - [ apply exec_straight_one; [simpl; eauto | reflexivity] - | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; Simpl - | split; [ intros; Simpl; fail - | intros; Simpl; eapply RA_not_written2; eauto] ]]. - -Lemma transl_op_correct: - forall op args res k (rs: regset) m v c, - transl_op op args res k = OK c -> - eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ Val.lessdef v rs'#(preg_of res) - /\ (forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r) - /\ rs' RA = rs RA. -Proof. -Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize. - intros until c; intros TR EV. - unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. -- (* move *) - destruct (preg_of res) eqn:RR; try discriminate; destruct (preg_of m0) eqn:R1; inv TR. - all: TranslOpSimpl. -- (* intconst *) - exploit exec_loadimm32. apply (ireg_of_not_RA res); eassumption. - intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. - split. intros; auto with asmgen. - apply C. congruence. - eapply ireg_of_not_RA''; eauto. -- (* longconst *) - exploit exec_loadimm64. apply (ireg_of_not_RA res); eassumption. - intros (rs' & A & B & C). - exists rs'; split. eexact A. split. rewrite B; auto. - split. intros; auto with asmgen. - apply C. congruence. - eapply ireg_of_not_RA''; eauto. -- (* floatconst *) - destruct (Float.eq_dec n Float.zero). -+ subst n. TranslOpSimpl. -+ TranslOpSimpl. -- (* singleconst *) - destruct (Float32.eq_dec n Float32.zero). -+ subst n. TranslOpSimpl. -+ TranslOpSimpl. -- (* loadsymbol *) - exploit (exec_loadsymbol x id ofs). eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. - split; auto. -- (* addrstack *) - exploit (exec_addimm64 x XSP (Ptrofs.to_int64 ofs)). simpl; eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. simpl in B; rewrite B. -Local Transparent Val.addl. - destruct (rs SP); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto. - auto. -- (* shift *) - rewrite <- transl_eval_shift'. TranslOpSimpl. -- (* addimm *) - exploit (exec_addimm32 x x0 n). eauto with asmgen. eapply ireg_of_not_RA''; eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. auto. -- (* mul *) - TranslOpBase. -Local Transparent Val.add. - destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int.add_zero_l; auto. -- (* andimm *) - exploit (exec_logicalimm32 (Pandimm W) (Pand W)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. - split; auto. -- (* orimm *) - exploit (exec_logicalimm32 (Porrimm W) (Porr W)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. - split; auto. -- (* xorimm *) - exploit (exec_logicalimm32 (Peorimm W) (Peor W)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. auto. -- (* not *) - TranslOpBase. - destruct (rs x0); auto. simpl. rewrite Int.or_zero_l; auto. -- (* notshift *) - TranslOpBase. - destruct (eval_shift s (rs x0) a); auto. simpl. rewrite Int.or_zero_l; auto. -- (* shrx *) - exploit (exec_shrx32 x x0 n); eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - econstructor; split. eexact A. split. rewrite B; auto. - split; auto. -- (* zero-ext *) - TranslOpBase. - destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. -- (* sign-ext *) - TranslOpBase. - destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto. -- (* shlzext *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite <- Int.shl_zero_ext_min; auto using a32_range. -- (* shlsext *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite <- Int.shl_sign_ext_min; auto using a32_range. -- (* zextshr *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.zero_ext_shru_min; auto using a32_range. -- (* sextshr *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.sign_ext_shr_min; auto using a32_range. -- (* shiftl *) - rewrite <- transl_eval_shiftl'. TranslOpSimpl. -- (* extend *) - exploit (exec_move_extended x0 x1 x a k). intros (rs' & A & B & C). - econstructor; split. eexact A. - split. rewrite B; auto. - split; eauto with asmgen. -- (* addext *) - exploit (exec_arith_extended Val.addl Paddext (Padd X)). - auto. auto. instantiate (1 := x1). eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - econstructor; split. eexact A. split. rewrite B; auto. - split; auto. -- (* addlimm *) - exploit (exec_addimm64 x x0 n). simpl. generalize (ireg_of_not_X16 _ _ EQ1). congruence. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. simpl in B; rewrite B; auto. auto. -- (* subext *) - exploit (exec_arith_extended Val.subl Psubext (Psub X)). - auto. auto. instantiate (1 := x1). eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - econstructor; split. eexact A. split. rewrite B; auto. - split; auto. -- (* mull *) - TranslOpBase. - destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int64.add_zero_l; auto. -- (* andlimm *) - exploit (exec_logicalimm64 (Pandimm X) (Pand X)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. auto. -- (* orlimm *) - exploit (exec_logicalimm64 (Porrimm X) (Porr X)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. auto. -- (* xorlimm *) - exploit (exec_logicalimm64 (Peorimm X) (Peor X)). - intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. - intros (rs' & A & B & C & D). - exists rs'; split. eexact A. split. rewrite B; auto. auto. -- (* notl *) - TranslOpBase. - destruct (rs x0); auto. simpl. rewrite Int64.or_zero_l; auto. -- (* notlshift *) - TranslOpBase. - destruct (eval_shiftl s (rs x0) a); auto. simpl. rewrite Int64.or_zero_l; auto. -- (* shrx *) - exploit (exec_shrx64 x x0 n); eauto with asmgen. - apply (ireg_of_not_RA'' res); eassumption. intros (rs' & A & B & C & D ). - econstructor; split. eexact A. split. rewrite B; auto. auto. -- (* zero-ext-l *) - TranslOpBase. - destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto. -- (* sign-ext-l *) - TranslOpBase. - destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto. -- (* shllzext *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_zero_ext_min; auto using a64_range. -- (* shllsext *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_sign_ext_min; auto using a64_range. -- (* zextshrl *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.zero_ext_shru'_min; auto using a64_range. -- (* sextshrl *) - TranslOpBase. - destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.sign_ext_shr'_min; auto using a64_range. -- (* condition *) - exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. - split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. - rewrite (B b) by auto. auto. - auto. - split; intros; Simpl. -- (* select *) - destruct (preg_of res) eqn:RES; monadInv TR. - + (* integer *) - generalize (ireg_of_eq _ _ EQ) (ireg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. - exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. - split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. - rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. - rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. - auto. - split; intros; Simpl. - rewrite <- D. - eapply RA_not_written2; eassumption. - + (* FP *) - generalize (freg_of_eq _ _ EQ) (freg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2. - exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto. - split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *. - rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize. - rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen. - auto. - split; intros; Simpl. -Qed. - -(** Translation of addressing modes, loads, stores *) - -Lemma transl_addressing_correct: - forall sz addr args (insn: Asm.addressing -> instruction) k (rs: regset) m c b o, - transl_addressing sz addr args insn k = OK c -> - Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some (Vptr b o) -> - exists ad rs', - exec_straight_opt ge fn c rs m (insn ad :: k) rs' m - /\ Asm.eval_addressing ge ad rs' = Vptr b o - /\ (forall r, data_preg r = true -> rs' r = rs r) - /\ rs' # RA = rs # RA. -Proof. - intros until o; intros TR EV. - unfold transl_addressing in TR; destruct addr; ArgsInv; SimplEval EV. -- (* Aindexed *) - destruct (offset_representable sz ofs); inv EQ0. -+ econstructor; econstructor; split. apply exec_straight_opt_refl. - auto. -+ exploit (exec_loadimm64 X16 ofs). congruence. intros (rs' & A & B & C). - econstructor; exists rs'; split. apply exec_straight_opt_intro; eexact A. - split. simpl. rewrite B, C by eauto with asmgen. auto. - split; eauto with asmgen. -- (* Aindexed2 *) - econstructor; econstructor; split. apply exec_straight_opt_refl. - auto. -- (* Aindexed2shift *) - destruct (Int.eq a Int.zero) eqn:E; [|destruct (Int.eq (Int.shl Int.one a) (Int.repr sz))]; inv EQ2. -+ apply Int.same_if_eq in E. rewrite E. - econstructor; econstructor; split. apply exec_straight_opt_refl. - split; auto. simpl. - rewrite Val.addl_commut in H0. destruct (rs x0); try discriminate. - unfold Val.shll. rewrite Int64.shl'_zero. auto. -+ econstructor; econstructor; split. apply exec_straight_opt_refl. - auto. -+ econstructor; econstructor; split. - apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. - split. simpl. Simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero. auto. - split; intros; Simpl. -- (* Aindexed2ext *) - destruct (Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz)); inv EQ2. -+ econstructor; econstructor; split. apply exec_straight_opt_refl. - split; auto. destruct x; auto. -+ exploit (exec_arith_extended Val.addl Paddext (Padd X)); auto. - instantiate (1 := x0). eauto with asmgen. - instantiate (1 := X16). simpl. congruence. - intros (rs' & A & B & C & D). - econstructor; exists rs'; split. - apply exec_straight_opt_intro. eexact A. - split. simpl. rewrite B. rewrite Val.addl_assoc. f_equal. - unfold Op.eval_extend; destruct x, (rs x1); simpl; auto; rewrite ! a64_range; - simpl; rewrite Int64.add_zero; auto. - split; intros. - apply C; eauto with asmgen. - trivial. -- (* Aglobal *) - destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz); inv TR. -+ econstructor; econstructor; split. - apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto. - split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence. - split; intros; Simpl. -+ exploit (exec_loadsymbol X16 id ofs). auto. - simpl. congruence. - intros (rs' & A & B & C & D). - econstructor; exists rs'; split. - apply exec_straight_opt_intro. eexact A. - split. simpl. - rewrite B. rewrite <- Genv.shift_symbol_address_64, Ptrofs.add_zero by auto. - simpl in EV. congruence. - split; auto with asmgen. -- (* Ainstrack *) - assert (E: Val.addl (rs SP) (Vlong (Ptrofs.to_int64 ofs)) = Vptr b o). - { simpl in EV. inv EV. destruct (rs SP); simpl in H1; inv H1. simpl. - rewrite Ptrofs.of_int64_to_int64 by auto. auto. } - destruct (offset_representable sz (Ptrofs.to_int64 ofs)); inv TR. -+ econstructor; econstructor; split. apply exec_straight_opt_refl. - auto. -+ exploit (exec_loadimm64 X16 (Ptrofs.to_int64 ofs)). - simpl. congruence. - intros (rs' & A & B & C). - econstructor; exists rs'; split. - apply exec_straight_opt_intro. eexact A. - split. simpl. rewrite B, C by eauto with asmgen. auto. - auto with asmgen. -Qed. - -Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) m vaddr v, - transl_load TRAP chunk addr args dst k = OK c -> - Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr -> - Mem.loadv chunk m vaddr = Some v -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of dst) = v - /\ (forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r) - /\ rs' # RA = rs # RA. -Proof. - intros. destruct vaddr; try discriminate. - assert (A: exists sz insn, - transl_addressing sz addr args insn k = OK c - /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = - exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m)). - { - destruct chunk; monadInv H; - try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ); - do 2 econstructor; (split; [eassumption|auto]). - } - destruct A as (sz & insn & B & C). - exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R & S). - assert (X: exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m = - Next (nextinstr (rs'#(preg_of dst) <- v)) m). - { unfold exec_load. rewrite Q, H1. auto. } - econstructor; split. - eapply exec_straight_opt_right. eexact P. - apply exec_straight_one. rewrite C, X; eauto. Simpl. - split. Simpl. - split; intros; Simpl. - rewrite <- S. - apply RA_not_written. -Qed. - -Lemma transl_store_correct: - forall chunk addr args src k c (rs: regset) m vaddr m', - transl_store chunk addr args src k = OK c -> - Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr -> - Mem.storev chunk m vaddr rs#(preg_of src) = Some m' -> - exists rs', - exec_straight ge fn c rs m k rs' m' - /\ (forall r, data_preg r = true -> rs' r = rs r) - /\ rs' # RA = rs # RA. -Proof. - intros. destruct vaddr; try discriminate. - set (chunk' := match chunk with Mint8signed => Mint8unsigned - | Mint16signed => Mint16unsigned - | _ => chunk end). - assert (A: exists sz insn, - transl_addressing sz addr args insn k = OK c - /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = - exec_store ge chunk' ad rs'#(preg_of src) rs' m)). - { - unfold chunk'; destruct chunk; monadInv H; - try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ); - do 2 econstructor; (split; [eassumption|auto]). - } - destruct A as (sz & insn & B & C). - exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R & S). - assert (X: Mem.storev chunk' m (Vptr b i) rs#(preg_of src) = Some m'). - { rewrite <- H1. unfold chunk'. destruct chunk; auto; simpl; symmetry. - apply Mem.store_signed_unsigned_8. - apply Mem.store_signed_unsigned_16. } - assert (Y: exec_store ge chunk' ad rs'#(preg_of src) rs' m = - Next (nextinstr rs') m'). - { unfold exec_store. rewrite Q, R, X by auto with asmgen. auto. } - econstructor; split. - eapply exec_straight_opt_right. eexact P. - apply exec_straight_one. rewrite C, Y; eauto. Simpl. - split; intros; Simpl. -Qed. - -(** Translation of indexed memory accesses *) - -Lemma indexed_memory_access_correct: forall insn sz (base: iregsp) ofs k (rs: regset) m b i, - preg_of_iregsp base <> IR X16 -> - Val.offset_ptr rs#base ofs = Vptr b i -> - exists ad rs', - exec_straight_opt ge fn (indexed_memory_access insn sz base ofs k) rs m (insn ad :: k) rs' m - /\ Asm.eval_addressing ge ad rs' = Vptr b i - /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r. -Proof. - unfold indexed_memory_access; intros. - assert (Val.addl rs#base (Vlong (Ptrofs.to_int64 ofs)) = Vptr b i). - { destruct (rs base); try discriminate. simpl in *. rewrite Ptrofs.of_int64_to_int64 by auto. auto. } - destruct offset_representable. -- econstructor; econstructor; split. apply exec_straight_opt_refl. auto. -- exploit (exec_loadimm64 X16); eauto. - simpl. congruence. - intros (rs' & A & B & C). - econstructor; econstructor; split. apply exec_straight_opt_intro; eexact A. - split. simpl. rewrite B, C by eauto with asmgen. auto. auto. -Qed. - -Lemma loadptr_correct: forall (base: iregsp) ofs dst k m v (rs: regset), - Mem.loadv Mint64 m (Val.offset_ptr rs#base ofs) = Some v -> - preg_of_iregsp base <> IR X16 -> - exists rs', - exec_straight ge fn (loadptr base ofs dst k) rs m k rs' m - /\ rs'#dst = v - /\ (forall r, r <> PC -> r <> X16 -> r <> dst -> rs' r = rs r). -Proof. - intros. - destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. - exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. - apply exec_straight_one. simpl. unfold exec_load. rewrite B, H. eauto. auto. - split. Simpl. - intros; Simpl. -Qed. - -Lemma storeptr_correct: forall (base: iregsp) ofs (src: ireg) k m m' (rs: regset), - Mem.storev Mint64 m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> - preg_of_iregsp base <> IR X16 -> - src <> X16 -> - exists rs', - exec_straight ge fn (storeptr src base ofs k) rs m k rs' m' - /\ (forall r, r <> PC -> r <> X16 -> rs' r = rs r) - /\ rs' RA = rs RA. -Proof. - intros. - destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. - exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. - apply exec_straight_one. simpl. unfold exec_store. rewrite B, C, H by eauto with asmgen. eauto. auto. - split; intros; Simpl. -Qed. - -Lemma loadind_correct: forall (base: iregsp) ofs ty dst k c (rs: regset) m v, - loadind base ofs ty dst k = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> - preg_of_iregsp base <> IR X16 -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of dst) = v - /\ (forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r) - /\ rs' RA = rs RA. -Proof. - intros. - destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. - assert (X: exists sz insn, - c = indexed_memory_access insn sz base ofs k - /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = - exec_load ge (chunk_of_type ty) (fun v => v) ad (preg_of dst) rs' m)). - { - unfold loadind in H; destruct ty; destruct (preg_of dst); inv H; do 2 econstructor; eauto. - } - destruct X as (sz & insn & EQ & SEM). subst c. - exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. - apply exec_straight_one. rewrite SEM. unfold exec_load. rewrite B, H0. eauto. Simpl. - split. Simpl. - split. intros; Simpl. - Simpl. rewrite RA_not_written. - apply C; congruence. -Qed. - -Lemma storeind_correct: forall (base: iregsp) ofs ty src k c (rs: regset) m m', - storeind src base ofs ty k = OK c -> - Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> - preg_of_iregsp base <> IR X16 -> - exists rs', - exec_straight ge fn c rs m k rs' m' - /\ (forall r, data_preg r = true -> rs' r = rs r) - /\ rs' RA = rs RA. -Proof. - intros. - destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate. - assert (X: exists sz insn, - c = indexed_memory_access insn sz base ofs k - /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m = - exec_store ge (chunk_of_type ty) ad rs'#(preg_of src) rs' m)). - { - unfold storeind in H; destruct ty; destruct (preg_of src); inv H; do 2 econstructor; eauto. - } - destruct X as (sz & insn & EQ & SEM). subst c. - exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. - apply exec_straight_one. rewrite SEM. - unfold exec_store. rewrite B, C, H0 by eauto with asmgen. eauto. - Simpl. - split. intros; Simpl. - Simpl. -Qed. - -Lemma make_epilogue_correct: - forall ge0 f m stk soff cs m' ms rs k tm, - (is_leaf_function f = true -> rs # (IR RA) = parent_ra cs) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> - ((* FIXME is_leaf_function f = false -> *) load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs)) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - agree ms (Vptr stk soff) rs -> - Mem.extends m tm -> - match_stack ge0 cs -> - exists rs', exists tm', - exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' - /\ agree ms (parent_sp cs) rs' - /\ Mem.extends m' tm' - /\ rs'#RA = parent_ra cs - /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> SP -> r <> RA -> r <> X16 -> rs'#r = rs#r). -Proof. - intros until tm; intros LEAF_RA LP LRA FREE AG MEXT MCS. - - (* FIXME - Cannot be used at this point - destruct (is_leaf_function f) eqn:IS_LEAF. - { - exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). - exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. - exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). - unfold make_epilogue. - rewrite IS_LEAF. - - econstructor; econstructor; split. - apply exec_straight_one. simpl. - rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. - rewrite FREE'. eauto. auto. - split. apply agree_nextinstr. apply agree_set_other; auto. - apply agree_change_sp with (Vptr stk soff). - apply agree_exten with rs; auto. - eapply parent_sp_def; eauto. - split. auto. - split. Simpl. - split. Simpl. - intros. Simpl. - } - lapply LRA. 2: reflexivity. - clear LRA. intro LRA. *) - exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). - exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). - exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. - exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. - exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). - unfold make_epilogue. - (* FIXME rewrite IS_LEAF. *) - exploit (loadptr_correct XSP (fn_retaddr_ofs f)). - instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence. - intros (rs1 & A1 & B1 & C1). - - econstructor; econstructor; split. - eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl. - simpl; rewrite (C1 SP) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'. - rewrite FREE'. eauto. auto. - split. apply agree_nextinstr. apply agree_set_other; auto. - apply agree_change_sp with (Vptr stk soff). - apply agree_exten with rs; auto. intros; apply C1; auto with asmgen. - eapply parent_sp_def; eauto. - split. auto. - split. Simpl. - split. Simpl. - intros. Simpl. -Qed. - -End CONSTRUCTORS. diff --git a/aarch64/CBuiltins.ml b/aarch64/CBuiltins.ml index fdc1372d..e2a9c87a 100644 --- a/aarch64/CBuiltins.ml +++ b/aarch64/CBuiltins.ml @@ -6,6 +6,9 @@ (* *) (* 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. *) (* *) (* *********************************************************************) @@ -29,14 +32,6 @@ let builtins = { "__builtin_fence", (TVoid [], [], false); (* Integer arithmetic *) - "__builtin_bswap64", - (TInt(IULongLong, []), [TInt(IULongLong, [])], false); - "__builtin_clz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_clzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_clzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); "__builtin_cls", (TInt(IInt, []), [TInt(IInt, [])], false); "__builtin_clsl", diff --git a/aarch64/CSE2deps.v b/aarch64/CSE2deps.v index a23e41a8..d5c7ee0f 100644 --- a/aarch64/CSE2deps.v +++ b/aarch64/CSE2deps.v @@ -28,5 +28,8 @@ Definition may_overlap chunk addr args chunk' addr' args' := (base :: nil), (base' :: nil) => if peq base base' then negb (can_swap_accesses_ofs (Int64.unsigned ofs') chunk' (Int64.unsigned ofs) chunk) - else true | _, _, _, _ => true + else true + | (Ainstack ofs), (Ainstack ofs'), _, _ => + negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + | _, _, _, _ => true end. diff --git a/aarch64/CSE2depsproof.v b/aarch64/CSE2depsproof.v index dbd46142..653c88f4 100644 --- a/aarch64/CSE2depsproof.v +++ b/aarch64/CSE2depsproof.v @@ -104,9 +104,71 @@ Section MEMORY_WRITE. Qed. End INDEXED_AWAY. End MEMORY_WRITE. -End SOUNDNESS. +Section STACK_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Ainstack ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Ainstack ofsr) nil = Some addrr. + + Lemma stack_load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + rewrite ptrofs_modulus in *. + simpl in *. + inv ADDRR. + inv ADDRW. + + destruct sp; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + + all: try rewrite ptrofs_modulus in *. + + all: intuition lia. + Qed. + + Theorem stack_load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply stack_load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End STACK_WRITE. +End SOUNDNESS. + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. @@ -124,7 +186,7 @@ Proof. intros until rs. intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) + - (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. destruct args' as [ | base' [ | ]]. 1,3: discriminate. simpl in OVERLAP. @@ -134,7 +196,14 @@ Proof. 2: discriminate. simpl in *. eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. - } +- (* Ainstack / Ainstack *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + cbn in OVERLAP. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned ofs0) chunk' (Ptrofs.unsigned ofs) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply stack_load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. Qed. End SOUNDNESS. diff --git a/aarch64/ConstpropOpproof.v b/aarch64/ConstpropOpproof.v index deab7cd4..c777062c 100644 --- a/aarch64/ConstpropOpproof.v +++ b/aarch64/ConstpropOpproof.v @@ -335,40 +335,63 @@ Qed. Lemma make_divimm_correct: forall n r1 r2 v, - Val.divs e#r1 e#r2 = Some v -> + Val.maketotal (Val.divs e#r1 e#r2) = v -> e#r2 = Vint n -> let (op, args) := make_divimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divimm. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. - destruct (e#r1) eqn:?; - try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); - inv H; auto. - destruct (Int.is_power2 n) eqn:?. - destruct (Int.ltu i (Int.repr 31)) eqn:?. - exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. - exists v; auto. - exists v; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros; subst; rewrite H0. + { destruct (e # r1) eqn:Er1. + all: try (cbn; exists (e # r1); split; auto; fail). + rewrite Val.divs_one. + cbn. + rewrite Er1. + exists (Vint i); split; auto. + } + destruct (Int.is_power2 n) eqn:Power2. + { + destruct (Int.ltu i (Int.repr 31)) eqn:iLT31. + { + cbn. + exists (Val.maketotal (Val.shrx e # r1 (Vint i))); split; auto. + destruct (Val.divs e # r1 (Vint n)) eqn:DIVS; cbn; auto. + rewrite Val.divs_pow2 with (y:=v) (n:=n). + cbn. + all: auto. + } + exists (Val.maketotal (Val.divs e # r1 (Vint n))); split; cbn; auto; congruence. + } + exists (Val.maketotal (Val.divs e # r1 (Vint n))); split; cbn; auto; congruence. Qed. + Lemma make_divuimm_correct: forall n r1 r2 v, - Val.divu e#r1 e#r2 = Some v -> + Val.maketotal (Val.divu e#r1 e#r2) = v -> e#r2 = Vint n -> let (op, args) := make_divuimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divuimm. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. - destruct (e#r1) eqn:?; - try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); - inv H; auto. - destruct (Int.is_power2 n) eqn:?. - econstructor; split. simpl; eauto. - rewrite mk_amount32_eq by (eapply Int.is_power2_range; eauto). - rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. - exists v; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros; subst; rewrite H0. + { destruct (e # r1) eqn:Er1. + all: try (cbn; exists (e # r1); split; auto; fail). + rewrite Val.divu_one. + cbn. + rewrite Er1. + exists (Vint i); split; auto. + } + destruct (Int.is_power2 n) eqn:Power2. + { + cbn. + rewrite mk_amount32_eq by (eapply Int.is_power2_range; eauto). + exists (Val.shru e # r1 (Vint i)); split; auto. + destruct (Val.divu e # r1 (Vint n)) eqn:DIVU; cbn; auto. + rewrite Val.divu_pow2 with (y:=v) (n:=n). + all: auto. + } + exists (Val.maketotal (Val.divu e # r1 (Vint n))); split; cbn; auto; congruence. Qed. Lemma make_andimm_correct: @@ -503,34 +526,60 @@ Qed. Lemma make_divlimm_correct: forall n r1 r2 v, - Val.divls e#r1 e#r2 = Some v -> + Val.maketotal (Val.divls e#r1 e#r2) = v -> e#r2 = Vlong n -> let (op, args) := make_divlimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divlimm. - destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. - rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. - exists v; auto. - exists v; auto. + destruct (Int64.is_power2' n) eqn:Power2. + { + destruct (Int.ltu i (Int.repr 63)) eqn:iLT63. + { + cbn. + exists (Val.maketotal (Val.shrxl e # r1 (Vint i))); split; auto. + rewrite H0 in H. + destruct (Val.divls e # r1 (Vlong n)) eqn:DIVS; cbn in H; auto. + { + subst v0. + rewrite Val.divls_pow2 with (y:=v) (n:=n). + cbn. + all: auto. + } + subst. auto. + } + cbn. subst. rewrite H0. + exists (Val.maketotal (Val.divls e # r1 (Vlong n))); split; auto. + } + cbn. subst. rewrite H0. + exists (Val.maketotal (Val.divls e # r1 (Vlong n))); split; auto. Qed. + Lemma make_divluimm_correct: forall n r1 r2 v, - Val.divlu e#r1 e#r2 = Some v -> + Val.maketotal (Val.divlu e#r1 e#r2) = v -> e#r2 = Vlong n -> let (op, args) := make_divluimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divluimm. destruct (Int64.is_power2' n) eqn:?. + { econstructor; split. simpl; eauto. - rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto). - rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. - simpl. - erewrite Int64.is_power2'_range by eauto. - erewrite Int64.divu_pow2' by eauto. auto. - exists v; auto. + rewrite H0 in H. destruct (e#r1); inv H. + all: cbn; auto. + { + rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto). + destruct (Int64.eq n Int64.zero); cbn; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. auto. + } + } + exists v; split; auto. + cbn. + rewrite H. + reflexivity. Qed. Lemma make_andlimm_correct: @@ -679,10 +728,10 @@ Proof. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. - (* divs *) assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divimm_correct; auto. + apply make_divimm_correct; auto. congruence. - (* divu *) assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divuimm_correct; auto. + apply make_divuimm_correct; auto. congruence. - (* and 1 *) rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. - (* and 2 *) @@ -745,10 +794,10 @@ Proof. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. - (* divl *) assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divlimm_correct; auto. + apply make_divlimm_correct; auto. congruence. - (* divlu *) assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divluimm_correct; auto. + apply make_divluimm_correct; auto. congruence. - (* andl 1 *) rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. - (* andl 2 *) diff --git a/aarch64/Machregsaux.ml b/aarch64/Machregsaux.ml index f13a9ff5..41db3bd4 100644 --- a/aarch64/Machregsaux.ml +++ b/aarch64/Machregsaux.ml @@ -12,28 +12,9 @@ (** Auxiliary functions on machine registers *) -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - let is_scratch_register s = s = "X16" || s = "x16" || s = "X30" || s = "x30" - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = Conventions1.is_callee_save r - let class_of_type = function | AST.Tint | AST.Tlong -> 0 | AST.Tfloat | AST.Tsingle -> 1 diff --git a/aarch64/Op.v b/aarch64/Op.v index afc25aa6..f2a8e6fb 100644 --- a/aarch64/Op.v +++ b/aarch64/Op.v @@ -386,8 +386,8 @@ Definition eval_operation | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) | Omuladd, v1 :: v2 :: v3 :: nil => Some (Val.add v1 (Val.mul v2 v3)) | Omulsub, v1 :: v2 :: v3 :: nil => Some (Val.sub v1 (Val.mul v2 v3)) - | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 - | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 + | Odiv, v1 :: v2 :: nil => Some (Val.maketotal (Val.divs v1 v2)) + | Odivu, v1 :: v2 :: nil => Some (Val.maketotal (Val.divu v1 v2)) | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) | Oandshift s a, v1 :: v2 :: nil => Some (Val.and v1 (eval_shift s v2 a)) | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) @@ -408,7 +408,7 @@ Definition eval_operation | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshrximm n, v1::nil => Some (Val.maketotal (Val.shrx v1 (Vint n))) | Ozext s, v1 :: nil => Some (Val.zero_ext s v1) | Osext s, v1 :: nil => Some (Val.sign_ext s v1) | Oshlzext s a, v1 :: nil => Some (Val.shl (Val.zero_ext s v1) (Vint a)) @@ -435,8 +435,8 @@ Definition eval_operation | Omullsub, v1 :: v2 :: v3 :: nil => Some (Val.subl v1 (Val.mull v2 v3)) | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) - | Odivl, v1 :: v2 :: nil => Val.divls v1 v2 - | Odivlu, v1 :: v2 :: nil => Val.divlu v1 v2 + | Odivl, v1 :: v2 :: nil => Some (Val.maketotal (Val.divls v1 v2)) + | Odivlu, v1 :: v2 :: nil => Some (Val.maketotal (Val.divlu v1 v2)) | Oandl, v1 :: v2 :: nil => Some (Val.andl v1 v2) | Oandlshift s a, v1 :: v2 :: nil => Some (Val.andl v1 (eval_shiftl s v2 a)) | Oandlimm n, v1 :: nil => Some (Val.andl v1 (Vlong n)) @@ -457,7 +457,7 @@ Definition eval_operation | Oshll, v1 :: v2 :: nil => Some (Val.shll v1 v2) | Oshrl, v1 :: v2 :: nil => Some (Val.shrl v1 v2) | Oshrlu, v1 :: v2 :: nil => Some (Val.shrlu v1 v2) - | Oshrlximm n, v1::nil => Val.shrxl v1 (Vint n) + | Oshrlximm n, v1::nil => Some (Val.maketotal (Val.shrxl v1 (Vint n))) | Ozextl s, v1 :: nil => Some (Val.zero_ext_l s v1) | Osextl s, v1 :: nil => Some (Val.sign_ext_l s v1) | Oshllzext s a, v1 :: nil => Some (Val.shll (Val.zero_ext_l s v1) (Vint a)) @@ -481,22 +481,22 @@ Definition eval_operation | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 - | Ointofsingle, v1::nil => Val.intofsingle v1 - | Ointuofsingle, v1::nil => Val.intuofsingle v1 - | Osingleofint, v1::nil => Val.singleofint v1 - | Osingleofintu, v1::nil => Val.singleofintu v1 - | Olongoffloat, v1::nil => Val.longoffloat v1 - | Olonguoffloat, v1::nil => Val.longuoffloat v1 - | Ofloatoflong, v1::nil => Val.floatoflong v1 - | Ofloatoflongu, v1::nil => Val.floatoflongu v1 - | Olongofsingle, v1::nil => Val.longofsingle v1 - | Olonguofsingle, v1::nil => Val.longuofsingle v1 - | Osingleoflong, v1::nil => Val.singleoflong v1 - | Osingleoflongu, v1::nil => Val.singleoflongu v1 + | Ointoffloat, v1::nil => Some (Val.maketotal (Val.intoffloat v1)) + | Ointuoffloat, v1::nil => Some (Val.maketotal (Val.intuoffloat v1)) + | Ofloatofint, v1::nil => Some (Val.maketotal (Val.floatofint v1)) + | Ofloatofintu, v1::nil => Some (Val.maketotal (Val.floatofintu v1)) + | Ointofsingle, v1::nil => Some (Val.maketotal (Val.intofsingle v1)) + | Ointuofsingle, v1::nil => Some (Val.maketotal (Val.intuofsingle v1)) + | Osingleofint, v1::nil => Some (Val.maketotal (Val.singleofint v1)) + | Osingleofintu, v1::nil => Some (Val.maketotal (Val.singleofintu v1)) + | Olongoffloat, v1::nil => Some (Val.maketotal (Val.longoffloat v1)) + | Olonguoffloat, v1::nil => Some (Val.maketotal (Val.longuoffloat v1)) + | Ofloatoflong, v1::nil => Some (Val.maketotal (Val.floatoflong v1)) + | Ofloatoflongu, v1::nil => Some (Val.maketotal (Val.floatoflongu v1)) + | Olongofsingle, v1::nil => Some (Val.maketotal (Val.longofsingle v1)) + | Olonguofsingle, v1::nil => Some (Val.maketotal (Val.longuofsingle v1)) + | Osingleoflong, v1::nil => Some (Val.maketotal (Val.singleoflong v1)) + | Osingleoflongu, v1::nil => Some (Val.maketotal (Val.singleoflongu v1)) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty) @@ -788,10 +788,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0... destruct v1... - apply type_add. - apply type_sub. - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero); inv H2... + - destruct v0; destruct v1; cbn in *; trivial. + destruct (_ || _); trivial... + - destruct v0; destruct v1; cbn in *; trivial. + destruct (Int.eq i0 Int.zero); constructor. - destruct v0... destruct v1... - destruct v0... destruct (eval_shift s v1 a)... - destruct v0... @@ -812,7 +812,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + - destruct v0; cbn; trivial. + destruct (Int.ltu n (Int.repr 31)); cbn; trivial. - destruct v0... - destruct v0... - destruct (Val.zero_ext s v0)... simpl; rewrite a32_range... @@ -843,10 +844,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_subl. - destruct v0... destruct v1... - destruct v0... destruct v1... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero); inv H2... + - destruct v0; destruct v1; cbn; trivial. + destruct (_ || _); cbn; trivial. + - destruct v0; destruct v1; cbn; trivial. + destruct (Int64.eq i0 Int64.zero); cbn; trivial. - destruct v0... destruct v1... - destruct v0... destruct (eval_shiftl s v1 a)... - destruct v0... @@ -867,7 +868,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + - destruct v0; cbn; trivial. + destruct (Int.ltu n (Int.repr 63)); cbn; trivial. - destruct v0... - destruct v0... - destruct (Val.zero_ext_l s v0)... simpl; rewrite a64_range... @@ -893,29 +895,29 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0... - destruct v0... (* intoffloat, intuoffloat *) - - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + - destruct v0; cbn; trivial. destruct (Float.to_int f); cbn; trivial. + - destruct v0; cbn; trivial. destruct (Float.to_intu f); cbn; trivial. (* floatofint, floatofintu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* intofsingle, intuofsingle *) - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... + - destruct v0; cbn; trivial. destruct (Float32.to_int f); cbn; trivial. + - destruct v0; cbn; trivial. destruct (Float32.to_intu f); cbn; trivial. (* singleofint, singleofintu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* longoffloat, longuoffloat *) - - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2... + - destruct v0; cbn; trivial. destruct (Float.to_long f); cbn; trivial. + - destruct v0; cbn; trivial. destruct (Float.to_longu f); cbn; trivial. (* floatoflong, floatoflongu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* longofsingle, longuofsingle *) - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2... + - destruct v0; cbn; trivial. destruct (Float32.to_long f); cbn; trivial. + - destruct v0; cbn; trivial. destruct (Float32.to_longu f); cbn; trivial. (* singleoflong, singleoflongu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m) as [[]|]... - unfold Val.select. destruct (eval_condition cond vl m). apply Val.normalize_type. exact I. @@ -924,16 +926,7 @@ Qed. Definition is_trapping_op (op : operation) := match op with - | Odiv | Odivu | Odivl | Odivlu - | Oshrximm _ | Oshrlximm _ - | Ointoffloat | Ointuoffloat - | Ointofsingle | Ointuofsingle - | Ofloatofint | Ofloatofintu - | Osingleofint | Osingleofintu - | Olongoffloat | Olonguoffloat - | Olongofsingle | Olonguofsingle - | Ofloatoflong | Ofloatoflongu - | Osingleoflong | Osingleoflongu => true + | Omove => false | _ => false end. @@ -1209,6 +1202,20 @@ Proof. rewrite (cond_depends_on_memory_correct cond args m1 m2 H). auto. Qed. +Lemma op_valid_pointer_eq: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op eqn:OP; simpl; try congruence. + - intros MEM; destruct cond; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intro MEM; destruct cond; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. +Qed. + (** Global variables mentioned in an operation or addressing mode *) Definition globals_addressing (addr: addressing) : list ident := @@ -1409,12 +1416,12 @@ Proof. - apply Val.add_inject; auto. inv H2; inv H3; simpl; auto. - apply Val.sub_inject; auto. inv H2; inv H3; simpl; auto. (* div, divu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + - inv H4; inv H2; trivial. cbn. + destruct (_ || _); cbn; + constructor. + - inv H4; inv H2; trivial. cbn. + destruct (Int.eq i0 Int.zero); cbn; + constructor. (* and*) - inv H4; inv H2; simpl; auto. - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto. @@ -1446,8 +1453,8 @@ Proof. (* shru *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. (* shrx *) - - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + - inv H4; cbn; trivial. + destruct (Int.ltu n (Int.repr 31)); inv H; cbn; trivial. (* shift-ext *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1482,12 +1489,10 @@ Proof. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. (* divl, divlu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + - inv H4; inv H2; cbn; trivial. + destruct (_ || _); cbn; trivial. + - inv H4; inv H2; cbn; trivial. + destruct (Int64.eq i0 Int64.zero); cbn; trivial. (* andl *) - inv H4; inv H2; simpl; auto. - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto. @@ -1519,8 +1524,8 @@ Proof. (* shrlu *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. (* shrlx *) - - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + - inv H4; cbn; trivial. + destruct (Int.ltu n (Int.repr 63)); inv H; cbn; trivial. (* shift-ext *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1551,37 +1556,29 @@ Proof. - inv H4; simpl; auto. - inv H4; simpl; auto. (* intoffloat, intuoffloat *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. + - inv H4; cbn; trivial. destruct (Float.to_int f0); cbn; trivial. + - inv H4; cbn; trivial. destruct (Float.to_intu f0); cbn; trivial. (* floatofint, floatofintu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; trivial. + - inv H4; cbn; trivial. (* intofsingle, intuofsingle *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. + - inv H4; cbn; trivial. destruct (Float32.to_int f0); cbn; trivial. + - inv H4; cbn; trivial. destruct (Float32.to_intu f0); cbn; trivial. (* singleofint, singleofintu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; trivial. + - inv H4; cbn; trivial. (* longoffloat, longuoffloat *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2. - exists (Vlong i); auto. + - inv H4; cbn; trivial. destruct (Float.to_long f0); cbn; trivial. + - inv H4; cbn; trivial. destruct (Float.to_longu f0); cbn; trivial. (* floatoflong, floatoflongu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; trivial. + - inv H4; cbn; trivial. (* longofsingle, longuofsingle *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2. - exists (Vlong i); auto. + - inv H4; cbn; trivial. destruct (Float32.to_long f0); cbn; trivial. + - inv H4; cbn; trivial. destruct (Float32.to_longu f0); cbn; trivial. (* singleoflong, singleoflongu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; trivial. + - inv H4; cbn; trivial. (* cmp, sel *) - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. diff --git a/aarch64/OpWeights.ml b/aarch64/OpWeights.ml new file mode 100644 index 00000000..5cdd002c --- /dev/null +++ b/aarch64/OpWeights.ml @@ -0,0 +1,353 @@ +open Op;; +open PrepassSchedulingOracleDeps;; + +module Cortex_A53= + struct + let resource_bounds = [| 2; 2; 1; 1 |];; (* instr ; ALU ; MAC; LSU *) + let nr_non_pipelined_units = 1;; + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omove + | Ointconst _ + | Olongconst _ + | Ofloatconst _ + | Osingleconst _ + | Oaddrsymbol _ + | Oaddrstack _ -> 1 + | Oshift _ -> 2 + | Oadd -> 1 + | Oaddshift _ -> 2 + | Oaddimm _ + | Oneg -> 1 + | Onegshift _ -> 2 + | Osub -> 1 + | Osubshift _ -> 2 + | Omul + | Omuladd + | Omulsub -> 4 + | Odiv + | Odivu -> 29 + | Oand -> 1 + | Oandshift _ -> 2 + | Oandimm _ -> 1 + | Oor -> 1 + | Oorshift _ -> 2 + | Oorimm _ -> 1 + | Oxor -> 1 + | Oxorshift _ -> 2 + | Oxorimm _ -> 1 + | Onot -> 1 + | Onotshift _ -> 2 + | Obic -> 1 + | Obicshift _ -> 2 + | Oorn -> 1 + | Oornshift _ -> 2 + | Oeqv -> 1 + | Oeqvshift _ -> 2 + | Oshl + | Oshr + | Oshru -> 2 + | Oshrximm _ -> 6 + | Ozext _ + | Osext _ -> 1 + | Oshlzext _ + | Oshlsext _ + | Ozextshr _ + | Osextshr _ -> 2 + + (* 64-bit integer arithmetic *) + | Oshiftl _ -> 2 + | Oextend _ -> 1 + | Omakelong + | Olowlong + | Ohighlong + | Oaddl -> 1 + | Oaddlshift _ + | Oaddlext _ -> 2 + | Oaddlimm _ + | Onegl -> 1 + | Oneglshift _ -> 2 + | Osubl -> 1 + | Osublshift _ + | Osublext _ -> 2 + | Omull + | Omulladd + | Omullsub + | Omullhs + | Omullhu -> 4 + | Odivl -> 50 + | Odivlu -> 50 + | Oandl -> 1 + | Oandlshift _ -> 2 + | Oandlimm _ + | Oorl -> 1 + | Oorlshift _ -> 2 + | Oorlimm _ + | Oxorl -> 1 + | Oxorlshift _ -> 2 + | Oxorlimm _ + | Onotl -> 1 + | Onotlshift _ -> 2 + | Obicl -> 1 + | Obiclshift _ -> 2 + | Oornl -> 1 + | Oornlshift _ -> 2 + | Oeqvl -> 1 + | Oeqvlshift _ -> 2 + | Oshll + | Oshrl + | Oshrlu -> 2 + | Oshrlximm _ -> 6 + | Ozextl _ + | Osextl _ -> 1 + | Oshllzext _ + | Oshllsext _ + | Ozextshrl _ + | Osextshrl _ -> 2 + + (* 64-bit floating-point arithmetic *) + | Onegf (* r [rd = - r1] *) + | Oabsf (* r [rd = abs(r1)] *) + | Oaddf (* r [rd = r1 + r2] *) + | Osubf (* r [rd = r1 - r2] *) + | Omulf (* r [rd = r1 * r2] *) +(* 32-bit floating-point arithmetic *) + | Onegfs (* r [rd = - r1] *) + | Oabsfs (* r [rd = abs(r1)] *) + | Oaddfs (* r [rd = r1 + r2] *) + | Osubfs (* r [rd = r1 - r2] *) + | Omulfs (* r [rd = r1 * r2] *) + | Osingleoffloat (* r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (* r [rd] is [r1] extended to double-precision float *) +(* Conversions between int and float *) + | Ointoffloat (* r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (* r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (* r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (* r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (* r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (* r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (* r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (* r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (* r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (* r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (* r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (* r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (* r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (* r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (* r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu (* r [rd = float32_of_unsigned_int(r1)] *) + -> 6 + | Odivf -> 50 (* r [rd = r1 / r2] *) + | Odivfs -> 20 + (* Boolean tests *) + | Ocmp cmp | Osel (cmp, _) -> + (match cmp with + | Ccompf _ (* r FP comparison *) + | Cnotcompf _ (* r negation of an FP comparison *) + | Ccompfzero _ (* r comparison with 0.0 *) + | Cnotcompfzero _ (* r negation of comparison with 0.0 *) + | Ccompfs _ (* r FP comparison *) + | Cnotcompfs _ (* r negation of an FP comparison *) + | Ccompfszero _ (* r equal to 0.0 *) + | Cnotcompfszero _ (* r not equal to 0.0 *) -> 6 + | _ -> 1);; + + let resources_of_op (op : operation) (nargs : int) = + match op with + | Omove + | Ointconst _ + | Olongconst _ + | Ofloatconst _ + | Osingleconst _ + | Oaddrsymbol _ + | Oaddrstack _ + (* 32-bit integer arithmetic *) + | Oshift _ + | Oadd + | Oaddshift _ + | Oaddimm _ + | Oneg + | Onegshift _ + | Osub + | Osubshift _ -> [| 1 ; 1; 0; 0 |] + | Omul + | Omuladd + | Omulsub -> [| 1; 1; 1; 0 |] + | Odiv + | Odivu -> [| 1; 0; 0; 0 |] + | Oand + | Oandshift _ + | Oandimm _ + | Oor + | Oorshift _ + | Oorimm _ + | Oxor + | Oxorshift _ + | Oxorimm _ + | Onot + | Onotshift _ + | Obic + | Obicshift _ + | Oorn + | Oornshift _ + | Oeqv + | Oeqvshift _ + | Oshl + | Oshr + | Oshru + | Oshrximm _ + | Ozext _ + | Osext _ + | Oshlzext _ + | Oshlsext _ + | Ozextshr _ + | Osextshr _ + +(* 64-bit integer arithmetic *) + | Oshiftl _ + | Oextend _ + | Omakelong + | Olowlong + | Ohighlong + | Oaddl + | Oaddlshift _ + | Oaddlext _ + | Oaddlimm _ + | Onegl + | Oneglshift _ + | Osubl + | Osublshift _ + | Osublext _ -> [| 1 ; 1 ; 0; 0 |] + | Omull + | Omulladd + | Omullsub + | Omullhs + | Omullhu -> [| 1 ; 1 ; 1; 0 |] + | Odivl + | Odivlu -> [| 1; 0; 0; 0 |] + | Oandl + | Oandlshift _ + | Oandlimm _ + | Oorl + | Oorlshift _ + | Oorlimm _ + | Oxorl + | Oxorlshift _ + | Oxorlimm _ + | Onotl + | Onotlshift _ + | Obicl + | Obiclshift _ + | Oornl + | Oornlshift _ + | Oeqvl + | Oeqvlshift _ + | Oshll + | Oshrl + | Oshrlu + | Oshrlximm _ + | Ozextl _ + | Osextl _ + | Oshllzext _ + | Oshllsext _ + | Ozextshrl _ + | Osextshrl _ -> [| 1; 1; 0; 0 |] + (* 64-bit floating-point arithmetic *) + | Onegf (* r [rd = - r1] *) + | Oabsf (* r [rd = abs(r1)] *) + | Oaddf (* r [rd = r1 + r2] *) + | Osubf (* r [rd = r1 - r2] *) + | Omulf (* r [rd = r1 * r2] *) + | Odivf + (* 32-bit floating-point arithmetic *) + | Onegfs (* r [rd = - r1] *) + | Oabsfs (* r [rd = abs(r1)] *) + | Oaddfs (* r [rd = r1 + r2] *) + | Osubfs (* r [rd = r1 - r2] *) + | Omulfs (* r [rd = r1 * r2] *) + | Odivfs (* r [rd = r1 / r2] *) + | Osingleoffloat (* r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (* r [rd] is [r1] extended to double-precision float *) +(* Conversions between int and float *) + | Ointoffloat (* r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (* r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (* r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (* r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (* r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (* r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (* r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (* r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (* r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (* r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (* r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (* r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (* r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (* r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (* r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu (* r [rd = float32_of_unsigned_int(r1)] *) + -> [| 1 ; 1; 1; 0 |] + +(* Boolean tests *) + | Ocmp cmp | Osel (cmp, _) -> + (match cmp with + | Ccompf _ (* r FP comparison *) + | Cnotcompf _ (* r negation of an FP comparison *) + | Ccompfzero _ (* r comparison with 0.0 *) + | Cnotcompfzero _ (* r negation of comparison with 0.0 *) + | Ccompfs _ (* r FP comparison *) + | Cnotcompfs _ (* r negation of an FP comparison *) + | Ccompfszero _ (* r equal to 0.0 *) + | Cnotcompfszero _ (* r not equal to 0.0 *) -> + [| 1; 1; 1; 0 |] + | _ -> [| 1; 1; 0; 0 |] );; + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |];; + + let resources_of_cond (cmp : condition) (nargs : int) = + (match cmp with + | Ccompf _ (* r FP comparison *) + | Cnotcompf _ (* r negation of an FP comparison *) + | Ccompfzero _ (* r comparison with 0.0 *) + | Cnotcompfzero _ (* r negation of comparison with 0.0 *) + | Ccompfs _ (* r FP comparison *) + | Cnotcompfs _ (* r negation of an FP comparison *) + | Ccompfszero _ (* r equal to 0.0 *) + | Cnotcompfszero _ (* r not equal to 0.0 *) -> + [| 1; 1; 1; 0 |] + | _ -> [| 1; 1; 0; 0 |] );; + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; + let latency_of_call _ _ = 6;; + + let resources_of_load trap chunk addressing nargs = [| 1; 0; 0; 1 |];; + + let resources_of_store chunk addressing nargs = [| 1; 0; 0; 1 |];; + + let resources_of_call _ _ = resource_bounds;; + let resources_of_builtin _ = resource_bounds;; + end;; + +let get_opweights () : opweights = + match !Clflags.option_mtune with + | "cortex-a53" | "cortex-a35" | "" -> + { + pipelined_resource_bounds = Cortex_A53.resource_bounds; + nr_non_pipelined_units = Cortex_A53.nr_non_pipelined_units; + latency_of_op = Cortex_A53.latency_of_op; + resources_of_op = Cortex_A53.resources_of_op; + non_pipelined_resources_of_op = Cortex_A53.non_pipelined_resources_of_op; + latency_of_load = Cortex_A53.latency_of_load; + resources_of_load = Cortex_A53.resources_of_load; + resources_of_store = Cortex_A53.resources_of_store; + resources_of_cond = Cortex_A53.resources_of_cond; + latency_of_call = Cortex_A53.latency_of_call; + resources_of_call = Cortex_A53.resources_of_call; + resources_of_builtin = Cortex_A53.resources_of_builtin + } + | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);; diff --git a/aarch64/OpWeightsAsm.ml b/aarch64/OpWeightsAsm.ml new file mode 100644 index 00000000..44c6f16b --- /dev/null +++ b/aarch64/OpWeightsAsm.ml @@ -0,0 +1,165 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open Asmblock + +(*type called_function = (Registers.reg, AST.ident) Datatypes.sum*) + +type instruction = PBasic of Asmblock.basic | PControl of Asmblock.control + +type opweights = { + pipelined_resource_bounds : int array; + nr_non_pipelined_units : int; + latency_of_op : instruction -> int -> int; + resources_of_op : instruction -> int -> int array; + (*non_pipelined_resources_of_op : Op.operation -> int -> int array;*) + (*latency_of_load : AST.trapping_mode -> AST.memory_chunk -> Op.addressing -> int -> int;*) + (*resources_of_load : AST.trapping_mode -> AST.memory_chunk -> Op.addressing -> int -> int array;*) + (*resources_of_store : AST.memory_chunk -> Op.addressing -> int -> int array;*) + (*resources_of_cond : Op.condition -> int -> int array;*) + (*latency_of_call : AST.signature -> called_function -> int;*) + (*resources_of_call : AST.signature -> called_function -> int array;*) + (*resources_of_builtin : AST.external_function -> int array*) +} + +module Cortex_A53 = struct + let resource_bounds = [| 2; 2; 1; 1 |] + + (* instr ; ALU ; MAC; LSU *) + let nr_non_pipelined_units = 1 + + let latency_of_op (i : instruction) (nargs : int) = + match i with + | PBasic (PArith (PArithP (_, _))) -> 1 + | PBasic (PArith (PArithPP (i', _, _))) -> ( + match i' with + | Psbfiz (_, _, _) | Psbfx (_, _, _) | Pubfiz (_, _, _) | Pubfx (_, _, _) + -> + 2 + | Pfcvtds | Pfcvtsd + | Pfcvtzs (_, _) + | Pfcvtzu (_, _) + | Pfabs _ | Pfneg _ + | Pscvtf (_, _) + | Pucvtf (_, _) -> + 6 + | _ -> 1) + | PBasic (PArith (PArithPPP (i', _, _, _))) -> ( + match i' with + | Pasrv _ | Plslv _ | Plsrv _ | Prorv _ | Paddext _ | Psubext _ -> 2 + | Psmulh | Pumulh -> 4 + | Pfdiv _ | Psdiv _ | Pudiv _ -> 50 + | _ -> 6) + | PBasic (PArith (PArithRR0R (_, _, _, _))) -> 2 + | PBasic (PArith (PArithRR0 (_, _, _))) -> 1 + | PBasic (PArith (PArithARRRR0 (_, _, _, _, _))) -> 4 + | PBasic (PArith (PArithComparisonPP (_, _, _))) -> 6 + | PBasic (PArith (PArithComparisonR0R (_, _, _))) -> 1 + | PBasic (PArith (PArithComparisonP (i', _))) -> ( + match i' with Pfcmp0 _ -> 6 | _ -> 1) + | PBasic (PArith (Pcset (_, _))) | PBasic (PArith (Pcsel (_, _, _, _))) -> 6 + | PBasic (PArith _) -> 1 + | PBasic (PLoad _) -> 3 + | PBasic (PStore _) -> 3 + | PBasic (Pallocframe (_, _)) -> 3 + | PBasic (Pfreeframe (_, _)) -> 1 + | PBasic (Ploadsymbol (_, _)) -> 1 + | PBasic (Pcvtsw2x (_, _)) -> 2 + | PBasic (Pcvtuw2x (_, _)) -> 2 + | PBasic (Pcvtx2w _) -> 1 + | PBasic (Pnop) -> 0 + | PControl _ -> 6 + + let resources_of_op (i : instruction) (nargs : int) = + match i with + | PBasic (PArith (PArithP (i', _))) -> ( + match i' with + | Pfmovimmd _ | Pfmovimms _ -> [| 1; 1; 0; 1 |] + | _ -> [| 1; 1; 0; 0 |]) + | PBasic (PArith (PArithPP (i', _, _))) -> ( + match i' with + | Pfcvtds | Pfcvtsd + | Pfcvtzs (_, _) + | Pfcvtzu (_, _) + | Pfabs _ | Pfneg _ + | Pscvtf (_, _) + | Pucvtf (_, _) -> + [| 1 ; 1; 1; 0 |] + | _ -> [| 1; 1; 0; 0 |]) + | PBasic (PArith (PArithPPP (i', _, _, _))) -> ( + match i' with + | Pasrv _ | Plslv _ | Plsrv _ | Prorv _ | Paddext _ | Psubext _ -> [| 1; 1; 0; 0 |] + | Pfdiv _ | Psdiv _ | Pudiv _ -> [| 1; 0; 0; 0 |] + | _ -> [| 1; 1; 1; 0 |]) + | PBasic (PArith (PArithRR0R (_, _, _, _))) -> [| 1; 1; 0; 0 |] + | PBasic (PArith (PArithRR0 (_, _, _))) -> [| 1; 1; 0; 0 |] + | PBasic (PArith (PArithARRRR0 (_, _, _, _, _))) -> [| 1; 1; 1; 0 |] + | PBasic (PArith (PArithComparisonPP (_, _, _))) -> [| 1; 1; 1; 0 |] + | PBasic (PArith (PArithComparisonR0R (_, _, _))) -> [| 1; 1; 0; 0 |] + | PBasic (PArith (PArithComparisonP (i', _))) -> ( + match i' with Pfcmp0 _ -> [| 1; 1; 1; 0 |] | _ -> [| 1; 1; 0; 0 |]) + | PBasic (PArith (Pcset (_, _))) | PBasic (PArith (Pcsel (_, _, _, _))) -> [| 1; 1; 1; 0 |] + | PBasic (PArith _) -> [| 1; 1; 0; 0 |] + | PBasic (PLoad _) -> [| 1; 0; 0; 1 |] + | PBasic (PStore _) -> [| 1; 0; 0; 1 |] + | PBasic (Pallocframe (_, _)) -> [| 1; 0; 0; 1 |] + | PBasic (Pfreeframe (_, _)) -> [| 1; 1; 0; 0 |] + | PBasic (Ploadsymbol (_, _)) -> [| 1; 1; 0; 0 |] + | PBasic (Pcvtsw2x (_, _)) -> [| 1; 1; 0; 0 |] + | PBasic (Pcvtuw2x (_, _)) -> [| 1; 1; 0; 0 |] + | PBasic (Pcvtx2w _) -> [| 1; 1; 0; 0 |] + | PBasic (Pnop) -> [| 0; 0; 0; 0 |] + | PControl _ -> resource_bounds + + (*let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |];; + + let resources_of_cond (cmp : condition) (nargs : int) = + (match cmp with + | Ccompf _ (* r FP comparison *) + | Cnotcompf _ (* r negation of an FP comparison *) + | Ccompfzero _ (* r comparison with 0.0 *) + | Cnotcompfzero _ (* r negation of comparison with 0.0 *) + | Ccompfs _ (* r FP comparison *) + | Cnotcompfs _ (* r negation of an FP comparison *) + | Ccompfszero _ (* r equal to 0.0 *) + | Cnotcompfszero _ (* r not equal to 0.0 *) -> + [| 1; 1; 1; 0 |] + | _ -> [| 1; 1; 0; 0 |] )*) + +end + +let get_opweights () : opweights = + (*match !Clflags.option_mtune with*) + (*| "cortex-a53" | "cortex-a35" | "" ->*) + { + pipelined_resource_bounds = Cortex_A53.resource_bounds; + nr_non_pipelined_units = Cortex_A53.nr_non_pipelined_units; + latency_of_op = Cortex_A53.latency_of_op; + resources_of_op = + Cortex_A53.resources_of_op + (*non_pipelined_resources_of_op = Cortex_A53.non_pipelined_resources_of_op;*) + (*latency_of_load = Cortex_A53.latency_of_load;*) + (*resources_of_load = Cortex_A53.resources_of_load;*) + (*resources_of_store = Cortex_A53.resources_of_store;*) + (*resources_of_cond = Cortex_A53.resources_of_cond;*) + (*latency_of_call = Cortex_A53.latency_of_call;*) + (*resources_of_call = Cortex_A53.resources_of_call;*) + (*resources_of_builtin = Cortex_A53.resources_of_builtin*); + } + +(*| xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);;*) diff --git a/aarch64/PeepholeOracle.ml b/aarch64/PeepholeOracle.ml new file mode 100644 index 00000000..a6945b9f --- /dev/null +++ b/aarch64/PeepholeOracle.ml @@ -0,0 +1,596 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open Camlcoq +open Asmblock +open Asm +open Int64 +open Printf + +(* If true, the oracle will print a msg for each applied peephole *) +let debug = false + +(* Functions to verify the immediate offset range for ldp/stp *) +let is_valid_immofs_32 z = + if z <= 252 && z >= -256 && z mod 4 = 0 then true else false + +let is_valid_immofs_64 z = + if z <= 504 && z >= -512 && z mod 8 = 0 then true else false + +(* Functions to check if a ldp/stp replacement is valid according to args *) +let is_valid_ldrw rd1 rd2 b1 b2 n1 n2 = + let z1 = to_int (camlint64_of_coqint n1) in + let z2 = to_int (camlint64_of_coqint n2) in + if + (not (ireg_eq rd1 rd2)) + && iregsp_eq b1 b2 + && (not (iregsp_eq (RR1 rd1) b2)) + && (z2 = z1 + 4 || z2 = z1 - 4) + && is_valid_immofs_32 z1 + then true + else false + +let is_valid_ldrx rd1 rd2 b1 b2 n1 n2 = + let z1 = to_int (camlint64_of_coqint n1) in + let z2 = to_int (camlint64_of_coqint n2) in + if + (not (ireg_eq rd1 rd2)) + && iregsp_eq b1 b2 + && (not (iregsp_eq (RR1 rd1) b2)) + && (z2 = z1 + 8 || z2 = z1 - 8) + && is_valid_immofs_64 z1 + then true + else false + +let is_valid_strw b1 b2 n1 n2 = + let z1 = to_int (camlint64_of_coqint n1) in + let z2 = to_int (camlint64_of_coqint n2) in + if iregsp_eq b1 b2 && z2 = z1 + 4 && is_valid_immofs_32 z1 then true + else false + +let is_valid_strx b1 b2 n1 n2 = + let z1 = to_int (camlint64_of_coqint n1) in + let z2 = to_int (camlint64_of_coqint n2) in + if iregsp_eq b1 b2 && z2 = z1 + 8 && is_valid_immofs_64 z1 then true + else false + +let dreg_of_ireg r = IR (RR1 r) + +(* Return true if an intermediate + * affectation eliminates the potential + * candidate *) +let verify_load_affect reg rd b rev = + let b = IR b in + let rd = dreg_of_ireg rd in + if not rev then dreg_eq reg b else dreg_eq reg b || dreg_eq reg rd + +(* Return true if an intermediate + * read eliminates the potential + * candidate *) +let verify_load_read reg rd b rev = + let rd = dreg_of_ireg rd in + dreg_eq reg rd + +(* Return true if an intermediate + * affectation eliminates the potential + * candidate *) +let verify_store_affect reg rs b rev = + let b = IR b in + let rs = dreg_of_ireg rs in + dreg_eq reg b || dreg_eq reg rs + +(* Affect a symbolic memory list of potential replacements + * for a given write in reg *) +let rec affect_symb_mem reg insta pot_rep stype rev = + match pot_rep with + | [] -> [] + | h0 :: t0 -> ( + match (insta.(h0), stype) with + | PLoad (PLd_rd_a (_, IR (RR1 rd), ADimm (b, n))), "ldr" -> + if verify_load_affect reg rd b rev then + affect_symb_mem reg insta t0 stype rev + else h0 :: affect_symb_mem reg insta t0 stype rev + | PStore (PSt_rs_a (_, IR (RR1 rs), ADimm (b, n))), "str" -> + if verify_store_affect reg rs b rev then + affect_symb_mem reg insta t0 stype rev + else h0 :: affect_symb_mem reg insta t0 stype rev + | _, _ -> + failwith "affect_symb_mem: Found an inconsistent inst in pot_rep") + +(* Affect a symbolic memory list of potential replacements + * for a given read in reg *) +let rec read_symb_mem reg insta pot_rep stype rev = + match pot_rep with + | [] -> [] + | h0 :: t0 -> ( + match (insta.(h0), stype) with + | PLoad (PLd_rd_a (_, IR (RR1 rd), ADimm (b, n))), "ldr" -> + if verify_load_read reg rd b rev then + read_symb_mem reg insta t0 stype rev + else h0 :: read_symb_mem reg insta t0 stype rev + | PStore (PSt_rs_a (_, IR (RR1 rs), ADimm (b, n))), "str" -> + h0 :: read_symb_mem reg insta t0 stype rev + | _, _ -> failwith "read_symb_mem: Found an inconsistent inst in pot_rep") + +(* Update a symbolic memory list of potential replacements + * for any addressing *) +let update_pot_rep_addressing a insta pot_rep stype rev = + match a with + | ADimm (base, _) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev + | ADreg (base, r) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg r) insta !pot_rep stype rev + | ADlsl (base, r, _) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg r) insta !pot_rep stype rev + | ADsxt (base, r, _) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg r) insta !pot_rep stype rev + | ADuxt (base, r, _) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg r) insta !pot_rep stype rev + | ADadr (base, _, _) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev + | ADpostincr (base, _) -> + pot_rep := read_symb_mem (IR base) insta !pot_rep stype rev + +(* Update a symbolic memory list of potential replacements + * for any basic instruction *) +let update_pot_rep_basic inst insta pot_rep stype rev = + match inst with + | PArith i -> ( + match i with + | PArithP (_, rd) -> + pot_rep := affect_symb_mem rd insta !pot_rep stype rev + | PArithPP (_, rd, rs) -> + pot_rep := affect_symb_mem rd insta !pot_rep stype rev; + pot_rep := read_symb_mem rs insta !pot_rep stype rev + | PArithPPP (_, rd, rs1, rs2) -> + pot_rep := affect_symb_mem rd insta !pot_rep stype rev; + pot_rep := read_symb_mem rs1 insta !pot_rep stype rev; + pot_rep := read_symb_mem rs2 insta !pot_rep stype rev + | PArithRR0R (_, rd, rs1, rs2) -> + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev; + (match rs1 with + | RR0 rs1 -> + pot_rep := + read_symb_mem (dreg_of_ireg rs1) insta !pot_rep stype rev + | _ -> ()); + pot_rep := read_symb_mem (dreg_of_ireg rs2) insta !pot_rep stype rev + | PArithRR0 (_, rd, rs) -> ( + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev; + match rs with + | RR0 rs1 -> + pot_rep := + read_symb_mem (dreg_of_ireg rs1) insta !pot_rep stype rev + | _ -> ()) + | PArithARRRR0 (_, rd, rs1, rs2, rs3) -> ( + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg rs1) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg rs2) insta !pot_rep stype rev; + match rs3 with + | RR0 rs1 -> + pot_rep := + read_symb_mem (dreg_of_ireg rs1) insta !pot_rep stype rev + | _ -> ()) + | PArithComparisonPP (_, rs1, rs2) -> + pot_rep := read_symb_mem rs1 insta !pot_rep stype rev; + pot_rep := read_symb_mem rs2 insta !pot_rep stype rev + | PArithComparisonR0R (_, rs1, rs2) -> + (match rs1 with + | RR0 rs1 -> + pot_rep := + read_symb_mem (dreg_of_ireg rs1) insta !pot_rep stype rev + | _ -> ()); + pot_rep := read_symb_mem (dreg_of_ireg rs2) insta !pot_rep stype rev + | PArithComparisonP (_, rs1) -> + pot_rep := read_symb_mem rs1 insta !pot_rep stype rev + | Pcset (rd, _) -> + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev + | Pfmovi (_, _, rs) -> ( + match rs with + | RR0 rs -> + pot_rep := + read_symb_mem (dreg_of_ireg rs) insta !pot_rep stype rev + | _ -> ()) + | Pcsel (rd, rs1, rs2, _) -> + pot_rep := affect_symb_mem rd insta !pot_rep stype rev; + pot_rep := read_symb_mem rs1 insta !pot_rep stype rev; + pot_rep := read_symb_mem rs2 insta !pot_rep stype rev + | Pfnmul (_, rd, rs1, rs2) -> ()) + | PLoad i -> ( + (* Here, we consider a different behavior for load and store potential candidates: + * a load does not obviously cancel the ldp candidates, but it does for any stp candidate. *) + match stype with + | "ldr" -> ( + match i with + | PLd_rd_a (_, rd, a) -> + pot_rep := affect_symb_mem rd insta !pot_rep stype rev; + update_pot_rep_addressing a insta pot_rep stype rev + | Pldp (_, rd1, rd2, _, _, a) -> + pot_rep := + affect_symb_mem (dreg_of_ireg rd1) insta !pot_rep stype rev; + pot_rep := + affect_symb_mem (dreg_of_ireg rd2) insta !pot_rep stype rev; + update_pot_rep_addressing a insta pot_rep stype rev) + | _ -> pot_rep := []) + | PStore _ -> ( + (* Here, we consider that a store cancel all ldp candidates, but it is far more complicated for stp ones : + * if we cancel stp candidates here, we would prevent ourselves to apply the non-consec store peephole. + * To solve this issue, the store candidates cleaning is managed directly in the peephole function below. *) + match stype with "ldr" -> pot_rep := [] | _ -> ()) + | Pallocframe (_, _) -> pot_rep := [] + | Pfreeframe (_, _) -> pot_rep := [] + | Ploadsymbol (rd, _) -> + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev + | Pcvtsw2x (rd, rs) -> + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg rs) insta !pot_rep stype rev + | Pcvtuw2x (rd, rs) -> + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg rs) insta !pot_rep stype rev + | Pcvtx2w rd -> + pot_rep := affect_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev; + pot_rep := read_symb_mem (dreg_of_ireg rd) insta !pot_rep stype rev + | Pnop -> () + +(* Try to find the index of the first previous compatible + * replacement in a given symbolic memory *) +let rec search_compat_rep r2 b2 n2 insta pot_rep stype = + match pot_rep with + | [] -> None + | h0 :: t0 -> ( + match (insta.(h0), stype) with + | PLoad (PLd_rd_a (ld1, IR (RR1 rd1), ADimm (b1, n1))), "ldrw" -> + if is_valid_ldrw rd1 r2 b1 b2 n1 n2 then + Some (h0, chunk_load ld1, rd1, b1, n1) + else search_compat_rep r2 b2 n2 insta t0 stype + | PLoad (PLd_rd_a (ld1, IR (RR1 rd1), ADimm (b1, n1))), "ldrx" -> + if is_valid_ldrx rd1 r2 b1 b2 n1 n2 then + Some (h0, chunk_load ld1, rd1, b1, n1) + else search_compat_rep r2 b2 n2 insta t0 stype + | PStore (PSt_rs_a (st1, IR (RR1 rs1), ADimm (b1, n1))), "strw" -> + if is_valid_strw b1 b2 n1 n2 then + Some (h0, chunk_store st1, rs1, b1, n1) + else search_compat_rep r2 b2 n2 insta t0 stype + | PStore (PSt_rs_a (st1, IR (RR1 rs1), ADimm (b1, n1))), "strx" -> + if is_valid_strx b1 b2 n1 n2 then + Some (h0, chunk_store st1, rs1, b1, n1) + else search_compat_rep r2 b2 n2 insta t0 stype + | _, _ -> + failwith "search_compat_rep: Found an inconsistent inst in pot_rep") + +(* Try to find the index of the first previous compatible + * replacement in a given symbolic memory (when iterating in the reversed list) *) +let rec search_compat_rep_inv r2 b2 n2 insta pot_rep stype = + match pot_rep with + | [] -> None + | h0 :: t0 -> ( + match (insta.(h0), stype) with + | PLoad (PLd_rd_a (ld1, IR (RR1 rd1), ADimm (b1, n1))), "ldrw" -> + if is_valid_ldrw r2 rd1 b2 b1 n2 n1 then + Some (h0, chunk_load ld1, rd1, b1, n1) + else search_compat_rep_inv r2 b2 n2 insta t0 stype + | PLoad (PLd_rd_a (ld1, IR (RR1 rd1), ADimm (b1, n1))), "ldrx" -> + if is_valid_ldrx r2 rd1 b2 b1 n2 n1 then + Some (h0, chunk_load ld1, rd1, b1, n1) + else search_compat_rep_inv r2 b2 n2 insta t0 stype + | PStore (PSt_rs_a (st1, IR (RR1 rs1), ADimm (b1, n1))), "strw" -> + if is_valid_strw b2 b1 n2 n1 then + Some (h0, chunk_store st1, rs1, b1, n1) + else search_compat_rep_inv r2 b2 n2 insta t0 stype + | PStore (PSt_rs_a (st1, IR (RR1 rs1), ADimm (b1, n1))), "strx" -> + if is_valid_strx b2 b1 n2 n1 then + Some (h0, chunk_store st1, rs1, b1, n1) + else search_compat_rep_inv r2 b2 n2 insta t0 stype + | _, _ -> + failwith + "search_compat_rep_inv: Found an inconsistent inst in pot_rep") + +(* This is useful to manage the case were the immofs + * of the first ldr/str is greater than the second one *) +let min_is_rev n1 n2 = + let z1 = to_int (camlint64_of_coqint n1) in + let z2 = to_int (camlint64_of_coqint n2) in + if z1 < z2 then true else false + +(* Below functions were added to merge pattern matching cases in peephole, + * thanks to this, we can make the chunk difference (int/any) compatible. *) +let trans_ldi (ldi : load_rd_a) : load_rd1_rd2_a = + match ldi with + | Pldrw | Pldrw_a -> Pldpw + | Pldrx | Pldrx_a -> Pldpx + | _ -> failwith "trans_ldi: Found a non compatible load to translate" + +let trans_sti (sti : store_rs_a) : store_rs1_rs2_a = + match sti with + | Pstrw | Pstrw_a -> Pstpw + | Pstrx | Pstrx_a -> Pstpx + | _ -> failwith "trans_sti: Found a non compatible store to translate" + +let is_compat_load (ldi : load_rd_a) = + match ldi with Pldrw | Pldrw_a | Pldrx | Pldrx_a -> true | _ -> false + +let are_compat_load (ldi1 : load_rd_a) (ldi2 : load_rd_a) = + match ldi1 with + | Pldrw | Pldrw_a -> ( match ldi2 with Pldrw | Pldrw_a -> true | _ -> false) + | Pldrx | Pldrx_a -> ( match ldi2 with Pldrx | Pldrx_a -> true | _ -> false) + | _ -> false + +let is_compat_store (sti : store_rs_a) = + match sti with Pstrw | Pstrw_a | Pstrx | Pstrx_a -> true | _ -> false + +let are_compat_store (sti1 : store_rs_a) (sti2 : store_rs_a) = + match sti1 with + | Pstrw | Pstrw_a -> ( match sti2 with Pstrw | Pstrw_a -> true | _ -> false) + | Pstrx | Pstrx_a -> ( match sti2 with Pstrx | Pstrx_a -> true | _ -> false) + | _ -> false + +let get_load_string (ldi : load_rd_a) = + match ldi with + | Pldrw | Pldrw_a -> "ldrw" + | Pldrx | Pldrx_a -> "ldrx" + | _ -> failwith "get_load_string: Found a non compatible load to translate" + +let get_store_string (sti : store_rs_a) = + match sti with + | Pstrw | Pstrw_a -> "strw" + | Pstrx | Pstrx_a -> "strx" + | _ -> failwith "get_store_string: Found a non compatible store to translate" + +let is_valid_ldr rd1 rd2 b1 b2 n1 n2 stype = + match stype with + | "ldrw" -> is_valid_ldrw rd1 rd2 b1 b2 n1 n2 + | _ -> is_valid_ldrx rd1 rd2 b1 b2 n1 n2 + +let is_valid_str b1 b2 n1 n2 stype = + match stype with + | "strw" -> is_valid_strw b1 b2 n1 n2 + | _ -> is_valid_strx b1 b2 n1 n2 + +(* Main peephole function in backward style *) +let pair_rep_inv insta = + (* Each list below is a symbolic mem representation + * for one type of inst. Lists contains integers which + * are the indices of insts in the main array "insta". *) + let pot_ldrw_rep = ref [] in + let pot_ldrx_rep = ref [] in + let pot_strw_rep = ref [] in + let pot_strx_rep = ref [] in + for i = Array.length insta - 1 downto 1 do + let h0 = insta.(i) in + let h1 = insta.(i - 1) in + (* Here we need to update every symbolic memory according to the matched inst *) + update_pot_rep_basic h0 insta pot_ldrw_rep "ldr" true; + update_pot_rep_basic h0 insta pot_ldrx_rep "ldr" true; + update_pot_rep_basic h0 insta pot_strw_rep "str" true; + update_pot_rep_basic h0 insta pot_strx_rep "str" true; + match (h0, h1) with + (* Non-consecutive ldr *) + | PLoad (PLd_rd_a (ldi, IR (RR1 rd1), ADimm (b1, n1))), _ -> ( + if is_compat_load ldi then + let pot_rep = + match ldi with Pldrw | Pldrw_a -> pot_ldrw_rep | _ -> pot_ldrx_rep + in + (* Search a previous compatible load *) + match + search_compat_rep_inv rd1 b1 n1 insta !pot_rep (get_load_string ldi) + with + (* If we can't find a candidate, add the current load as a potential future one *) + | None -> pot_rep := i :: !pot_rep + (* Else, perform the peephole *) + | Some (rep, c, r, b, n) -> + (* The two lines below are used to filter the elected candidate *) + let filt x = x != rep in + pot_rep := List.filter filt !pot_rep; + insta.(rep) <- Pnop; + if min_is_rev n n1 then ( + if debug then eprintf "LDP_BACK_SPACED_PEEP_IMM_INC\n"; + insta.(i) <- + PLoad + (Pldp + (trans_ldi ldi, r, rd1, c, chunk_load ldi, ADimm (b, n)))) + else ( + if debug then eprintf "LDP_BACK_SPACED_PEEP_IMM_DEC\n"; + insta.(i) <- + PLoad + (Pldp + (trans_ldi ldi, rd1, r, chunk_load ldi, c, ADimm (b, n1)))) + ) + (* Non-consecutive str *) + | PStore (PSt_rs_a (sti, IR (RR1 rd1), ADimm (b1, n1))), _ -> ( + if is_compat_store sti then + let pot_rep = + match sti with Pstrw | Pstrw_a -> pot_strw_rep | _ -> pot_strx_rep + in + (* Search a previous compatible store *) + match + search_compat_rep_inv rd1 b1 n1 insta !pot_rep + (get_store_string sti) + with + (* If we can't find a candidate, clean and add the current store as a potential future one *) + | None -> + pot_strw_rep := []; + pot_strx_rep := []; + pot_rep := i :: !pot_rep + (* Else, perform the peephole *) + | Some (rep, c, r, b, n) -> + (* The two lines below are used to filter the elected candidate *) + let filt x = x != rep in + pot_rep := List.filter filt !pot_rep; + insta.(rep) <- Pnop; + if debug then eprintf "STP_BACK_SPACED_PEEP_IMM_INC\n"; + insta.(i) <- + PStore + (Pstp + (trans_sti sti, rd1, r, chunk_store sti, c, ADimm (b, n1))) + (* Any other inst *)) + | i, _ -> ( + (* Clear list of candidates if there is a non supported store *) + match i with + | PStore _ -> + pot_strw_rep := []; + pot_strx_rep := [] + | _ -> ()) + done + +(* Main peephole function in forward style *) +let pair_rep insta = + (* Each list below is a symbolic mem representation + * for one type of inst. Lists contains integers which + * are the indices of insts in the main array "insta". *) + let pot_ldrw_rep = ref [] in + let pot_ldrx_rep = ref [] in + let pot_strw_rep = ref [] in + let pot_strx_rep = ref [] in + for i = 0 to Array.length insta - 2 do + let h0 = insta.(i) in + let h1 = insta.(i + 1) in + (* Here we need to update every symbolic memory according to the matched inst *) + update_pot_rep_basic h0 insta pot_ldrw_rep "ldr" false; + update_pot_rep_basic h0 insta pot_ldrx_rep "ldr" false; + update_pot_rep_basic h0 insta pot_strw_rep "str" false; + update_pot_rep_basic h0 insta pot_strx_rep "str" false; + match (h0, h1) with + (* Consecutive ldr *) + | ( PLoad (PLd_rd_a (ldi1, IR (RR1 rd1), ADimm (b1, n1))), + PLoad (PLd_rd_a (ldi2, IR (RR1 rd2), ADimm (b2, n2))) ) -> + if are_compat_load ldi1 ldi2 then + if is_valid_ldr rd1 rd2 b1 b2 n1 n2 (get_load_string ldi1) then ( + if min_is_rev n1 n2 then ( + if debug then eprintf "LDP_CONSEC_PEEP_IMM_INC\n"; + insta.(i) <- + PLoad + (Pldp + ( trans_ldi ldi1, + rd1, + rd2, + chunk_load ldi1, + chunk_load ldi2, + ADimm (b1, n1) ))) + else ( + if debug then eprintf "LDP_CONSEC_PEEP_IMM_DEC\n"; + insta.(i) <- + PLoad + (Pldp + ( trans_ldi ldi1, + rd2, + rd1, + chunk_load ldi2, + chunk_load ldi1, + ADimm (b1, n2) ))); + insta.(i + 1) <- Pnop) + (* Non-consecutive ldr *) + | PLoad (PLd_rd_a (ldi, IR (RR1 rd1), ADimm (b1, n1))), _ -> ( + if is_compat_load ldi then + let pot_rep = + match ldi with Pldrw | Pldrw_a -> pot_ldrw_rep | _ -> pot_ldrx_rep + in + (* Search a previous compatible load *) + match + search_compat_rep rd1 b1 n1 insta !pot_rep (get_load_string ldi) + with + (* If we can't find a candidate, add the current load as a potential future one *) + | None -> pot_rep := i :: !pot_rep + (* Else, perform the peephole *) + | Some (rep, c, r, b, n) -> + (* The two lines below are used to filter the elected candidate *) + let filt x = x != rep in + pot_rep := List.filter filt !pot_rep; + insta.(rep) <- Pnop; + if min_is_rev n n1 then ( + if debug then eprintf "LDP_FORW_SPACED_PEEP_IMM_INC\n"; + insta.(i) <- + PLoad + (Pldp + (trans_ldi ldi, r, rd1, c, chunk_load ldi, ADimm (b, n)))) + else ( + if debug then eprintf "LDP_FORW_SPACED_PEEP_IMM_DEC\n"; + insta.(i) <- + PLoad + (Pldp + (trans_ldi ldi, rd1, r, chunk_load ldi, c, ADimm (b, n1)))) + ) + (* Consecutive str *) + | ( PStore (PSt_rs_a (sti1, IR (RR1 rd1), ADimm (b1, n1))), + PStore (PSt_rs_a (sti2, IR (RR1 rd2), ADimm (b2, n2))) ) -> + (* Regardless of whether we can perform the peephole or not, + * we have to clean the potential candidates for stp now as we are + * looking at two new store instructions. *) + pot_strw_rep := []; + pot_strx_rep := []; + if are_compat_store sti1 sti2 then + if is_valid_str b1 b2 n1 n2 (get_store_string sti1) then ( + if debug then eprintf "STP_CONSEC_PEEP_IMM_INC\n"; + insta.(i) <- + PStore + (Pstp + ( trans_sti sti1, + rd1, + rd2, + chunk_store sti1, + chunk_store sti2, + ADimm (b1, n1) )); + insta.(i + 1) <- Pnop) + (* Non-consecutive str *) + | PStore (PSt_rs_a (sti, IR (RR1 rd1), ADimm (b1, n1))), _ -> ( + if is_compat_store sti then + let pot_rep = + match sti with Pstrw | Pstrw_a -> pot_strw_rep | _ -> pot_strx_rep + in + (* Search a previous compatible store *) + match + search_compat_rep rd1 b1 n1 insta !pot_rep (get_store_string sti) + with + (* If we can't find a candidate, clean and add the current store as a potential future one *) + | None -> + pot_strw_rep := []; + pot_strx_rep := []; + pot_rep := i :: !pot_rep + (* Else, perform the peephole *) + | Some (rep, c, r, b, n) -> + (* The two lines below are used to filter the elected candidate *) + let filt x = x != rep in + pot_rep := List.filter filt !pot_rep; + insta.(rep) <- Pnop; + if debug then eprintf "STP_FORW_SPACED_PEEP_IMM_INC\n"; + insta.(i) <- + PStore + (Pstp (trans_sti sti, r, rd1, c, chunk_store sti, ADimm (b, n))) + ) + (* Any other inst *) + | i, _ -> ( + (* Clear list of candidates if there is a non supported store *) + match i with + | PStore _ -> + pot_strw_rep := []; + pot_strx_rep := [] + | _ -> ()) + done + +(* Calling peephole if flag is set *) +let optimize_bdy (bdy : basic list) : basic list = + if !Clflags.option_fcoalesce_mem then ( + let insta = Array.of_list bdy in + pair_rep insta; + pair_rep_inv insta; + Array.to_list insta) + else bdy + +(* Called peephole function from Coq *) +let peephole_opt bdy = + Timing.time_coq + [ + 'P'; 'e'; 'e'; 'p'; 'h'; 'o'; 'l'; 'e'; ' '; 'o'; 'r'; 'a'; 'c'; 'l'; 'e'; + ] + optimize_bdy bdy diff --git a/aarch64/PostpassScheduling.v b/aarch64/PostpassScheduling.v new file mode 100644 index 00000000..f826632b --- /dev/null +++ b/aarch64/PostpassScheduling.v @@ -0,0 +1,146 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Implementation (and basic properties) of the verified postpass scheduler *) + +Require Import Coqlib Errors AST Integers. +Require Import Asmblock Axioms Memory Globalenvs. +Require Import Asmblockdeps Asmblockprops. +Require Import IterList. + +Local Open Scope error_monad_scope. + +(** * Oracle taking as input a basic block, + returns a scheduled basic block *) +Axiom schedule: bblock -> (list basic) * option control. + +Axiom peephole_opt: (list basic) -> list basic. + +Extract Constant schedule => "PostpassSchedulingOracle.schedule". + +Extract Constant peephole_opt => "PeepholeOracle.peephole_opt". + +Section verify_schedule. + +Variable lk: aarch64_linker. + +Definition verify_schedule (bb bb' : bblock) : res unit := + match bblock_simub bb bb' with + | true => OK tt + | false => Error (msg "PostpassScheduling.verify_schedule") + end. + +Definition verify_size bb bb' := if (Z.eqb (size bb) (size bb')) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). + +Lemma verify_size_size: + forall bb bb', verify_size bb bb' = OK tt -> size bb = size bb'. +Proof. + intros. unfold verify_size in H. destruct (size bb =? size bb') eqn:SIZE; try discriminate. + apply Z.eqb_eq. assumption. +Qed. + +Program Definition make_bblock_from_basics lb := + match lb with + | nil => Error (msg "PostpassScheduling.make_bblock_from_basics") + | b :: lb => OK {| header := nil; body := b::lb; exit := None |} + end. + +Program Definition schedule_to_bblock (lb: list basic) (oc: option control) : res bblock := + match oc with + | None => make_bblock_from_basics lb + | Some c => OK {| header := nil; body := lb; exit := Some c |} + end. +Next Obligation. + unfold Is_true, non_empty_bblockb. + unfold non_empty_exit. rewrite orb_true_r. reflexivity. +Qed. + +Definition do_schedule (bb: bblock) : res bblock := + if (Z.eqb (size bb) 1) then OK (bb) + else match (schedule bb) with (lb, oc) => schedule_to_bblock lb oc end. + +(*Definition do_peephole (bb: bblock) : bblock :=*) + (*let res := Peephole.optimize_bblock bb in*) + (*if (size res =? size bb) then res else bb.*) + +Program Definition do_peephole (bb : bblock) := + let optimized := peephole_opt (body bb) in + let wf_ok := non_empty_bblockb optimized (exit bb) in + {| header := header bb; + body := if wf_ok then optimized else (body bb); + exit := exit bb |}. +Next Obligation. + destruct (non_empty_bblockb (peephole_opt (body bb))) eqn:Rwf. + - rewrite Rwf. cbn. trivial. + - exact (correct bb). +Qed. + +Definition verified_schedule (bb : bblock) : res bblock := + let nhbb := no_header bb in + let phbb := do_peephole nhbb in + do schbb <- do_schedule phbb; + let bb' := stick_header (header bb) schbb in + do sizecheck <- verify_size bb bb'; + do schedcheck <- verify_schedule bb bb'; + OK (bb'). + +Lemma verified_schedule_size: + forall bb bb', verified_schedule bb = OK bb' -> size bb = size bb'. +Proof. + intros. unfold verified_schedule in H. + monadInv H. + unfold verify_size in EQ1. + destruct (size _ =? size _) eqn:ESIZE_H in EQ1; try discriminate. + rewrite Z.eqb_eq in ESIZE_H; rewrite ESIZE_H; reflexivity. +Qed. + +Theorem verified_schedule_correct: + forall ge f bb bb', + verified_schedule bb = OK bb' -> + bblock_simu lk ge f bb bb'. +Proof. + intros. + monadInv H. + eapply bblock_simub_correct. + unfold verify_schedule in EQ0. + destruct (bblock_simub _ _) in *; try discriminate; auto. +Qed. + +End verify_schedule. + +Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := + match lbb with + | nil => OK nil + | bb :: lbb => + do tlbb <- transf_blocks lbb; + do tbb <- verified_schedule bb; + OK (tbb :: tlbb) + end. + +Definition transl_function (f: function) : res function := + do lb <- transf_blocks (fn_blocks f); + OK (mkfunction (fn_sig f) lb). + +Definition transf_function (f: function) : res function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. diff --git a/aarch64/PostpassSchedulingOracle.ml b/aarch64/PostpassSchedulingOracle.ml new file mode 100644 index 00000000..d7fab1de --- /dev/null +++ b/aarch64/PostpassSchedulingOracle.ml @@ -0,0 +1,671 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open Asmblock +open OpWeightsAsm +open InstructionScheduler + +let debug = false + +let stats = false + +(** + * Extracting infos from Asm instructions + *) + +type location = Reg of Asm.preg | Mem | IREG0_XZR + +type ab_inst_rec = { + inst : instruction; + write_locs : location list; + read_locs : location list; + is_control : bool; +} + +(** Asm constructor to real instructions *) + +exception OpaqueInstruction + +let is_XZR = function IREG0_XZR -> true | _ -> false + +let reg_of_pc = Reg Asm.PC + +let reg_of_dreg r = Reg (Asm.DR r) + +let reg_of_ireg r = Reg (Asm.DR (Asm.IR (Asm.RR1 r))) + +let reg_of_iregsp r = Reg (Asm.DR (Asm.IR r)) + +let reg_of_ireg0 r = + match r with Asm.RR0 ir -> reg_of_ireg ir | Asm.XZR -> IREG0_XZR + +let reg_of_freg r = Reg (Asm.DR (Asm.FR r)) + +let reg_of_cr r = Reg (Asm.CR r) + +let regXSP = Reg (Asm.DR (Asm.IR Asm.XSP)) + +let flags_wlocs = + [ reg_of_cr Asm.CN; reg_of_cr Asm.CZ; reg_of_cr Asm.CC; reg_of_cr Asm.CV ] + +let get_arith_p_wlocs = function + | Pfmovimms _ -> [ reg_of_ireg Asm.X16 ] + | Pfmovimmd _ -> [ reg_of_ireg Asm.X16 ] + | _ -> [] + +let arith_p_rec i i' rd = + { + inst = i; + write_locs = [ rd ] @ get_arith_p_wlocs i'; + read_locs = []; + is_control = false; + } + +let arith_pp_rec i rd rs = + { inst = i; write_locs = [ rd ]; read_locs = [ rs ]; is_control = false } + +let arith_ppp_rec i rd r1 r2 = + { inst = i; write_locs = [ rd ]; read_locs = [ r1; r2 ]; is_control = false } + +let arith_rr0r_rec i rd r1 r2 = + let rlocs = if is_XZR r1 then [ r2 ] else [ r1; r2 ] in + { inst = i; write_locs = [ rd ]; read_locs = rlocs; is_control = false } + +let arith_rr0_rec i rd r1 = + let rlocs = if is_XZR r1 then [] else [ r1 ] in + { inst = i; write_locs = [ rd ]; read_locs = rlocs; is_control = false } + +let arith_arrrr0_rec i rd r1 r2 r3 = + let rlocs = if is_XZR r3 then [ r1; r2 ] else [ r1; r2; r3 ] in + { inst = i; write_locs = [ rd ]; read_locs = rlocs; is_control = false } + +let arith_comparison_pp_rec i r1 r2 = + { + inst = i; + write_locs = flags_wlocs; + read_locs = [ r1; r2 ]; + is_control = false; + } + +let arith_comparison_r0r_rec i r1 r2 = + let rlocs = if is_XZR r1 then [ r2 ] else [ r1; r2 ] in + { inst = i; write_locs = flags_wlocs; read_locs = rlocs; is_control = false } + +let arith_comparison_p_rec i r1 = + { inst = i; write_locs = flags_wlocs; read_locs = [ r1 ]; is_control = false } + +let get_eval_addressing_rlocs a = + match a with + | Asm.ADimm (base, _) -> [ reg_of_iregsp base ] + | Asm.ADreg (base, r) -> [ reg_of_iregsp base; reg_of_ireg r ] + | Asm.ADlsl (base, r, _) -> [ reg_of_iregsp base; reg_of_ireg r ] + | Asm.ADsxt (base, r, _) -> [ reg_of_iregsp base; reg_of_ireg r ] + | Asm.ADuxt (base, r, _) -> [ reg_of_iregsp base; reg_of_ireg r ] + | Asm.ADadr (base, _, _) -> [ reg_of_iregsp base ] + | Asm.ADpostincr (base, _) -> [ reg_of_iregsp base ] + +let load_rd_a_rec ld rd a = + { + inst = ld; + write_locs = [ rd ]; + read_locs = [ Mem ] @ get_eval_addressing_rlocs a; + is_control = false; + } + +let load_rd1_rd2_a_rec ld rd1 rd2 a = + { + inst = ld; + write_locs = [ rd1; rd2 ]; + read_locs = [ Mem ] @ get_eval_addressing_rlocs a; + is_control = false; + } + +let load_rec ldi = + match ldi with + | PLd_rd_a (ld, rd, a) -> + load_rd_a_rec (PBasic (PLoad ldi)) (reg_of_dreg rd) a + | Pldp (ld, rd1, rd2, _, _, a) -> + load_rd1_rd2_a_rec (PBasic (PLoad ldi)) (reg_of_ireg rd1) + (reg_of_ireg rd2) a + +let store_rs_a_rec st rs a = + { + inst = st; + write_locs = [ Mem ]; + read_locs = [ rs; Mem ] @ get_eval_addressing_rlocs a; + is_control = false; + } + +let store_rs1_rs2_a_rec st rs1 rs2 a = + { + inst = st; + write_locs = [ Mem ]; + read_locs = [ rs1; rs2; Mem ] @ get_eval_addressing_rlocs a; + is_control = false; + } + +let store_rec sti = + match sti with + | PSt_rs_a (st, rs, a) -> + store_rs_a_rec (PBasic (PStore sti)) (reg_of_dreg rs) a + | Pstp (st, rs1, rs2, _, _, a) -> + store_rs1_rs2_a_rec (PBasic (PStore sti)) (reg_of_ireg rs1) + (reg_of_ireg rs2) a + +let loadsymbol_rec i rd id = + { inst = i; write_locs = [ rd ]; read_locs = [ Mem ]; is_control = false } + +let cvtsw2x_rec i rd r1 = + { inst = i; write_locs = [ rd ]; read_locs = [ r1 ]; is_control = false } + +let cvtuw2x_rec i rd r1 = + { inst = i; write_locs = [ rd ]; read_locs = [ r1 ]; is_control = false } + +let cvtx2w_rec i rd = + { inst = i; write_locs = [ rd ]; read_locs = [ rd ]; is_control = false } + +let get_testcond_rlocs c = + match c with + | Asm.TCeq -> [ reg_of_cr Asm.CZ ] + | Asm.TCne -> [ reg_of_cr Asm.CZ ] + | Asm.TChs -> [ reg_of_cr Asm.CC ] + | Asm.TClo -> [ reg_of_cr Asm.CC ] + | Asm.TCmi -> [ reg_of_cr Asm.CN ] + | Asm.TCpl -> [ reg_of_cr Asm.CN ] + | Asm.TChi -> [ reg_of_cr Asm.CZ; reg_of_cr Asm.CC ] + | Asm.TCls -> [ reg_of_cr Asm.CZ; reg_of_cr Asm.CC ] + | Asm.TCge -> [ reg_of_cr Asm.CN; reg_of_cr Asm.CV ] + | Asm.TClt -> [ reg_of_cr Asm.CN; reg_of_cr Asm.CV ] + | Asm.TCgt -> [ reg_of_cr Asm.CN; reg_of_cr Asm.CZ; reg_of_cr Asm.CV ] + | Asm.TCle -> [ reg_of_cr Asm.CN; reg_of_cr Asm.CZ; reg_of_cr Asm.CV ] + +let cset_rec i rd c = + { + inst = i; + write_locs = [ rd ]; + read_locs = get_testcond_rlocs c; + is_control = false; + } + +let csel_rec i rd r1 r2 c = + { + inst = i; + write_locs = [ rd ]; + read_locs = [ r1; r2 ] @ get_testcond_rlocs c; + is_control = false; + } + +let fmovi_rec i fsz rd r1 = + let rlocs = if is_XZR r1 then [] else [ r1 ] in + { inst = i; write_locs = [ rd ]; read_locs = rlocs; is_control = false } + +let fnmul_rec i fsz rd r1 r2 = + { inst = i; write_locs = [ rd ]; read_locs = [ r1; r2 ]; is_control = false } + +let allocframe_rec i sz linkofs = + { + inst = i; + write_locs = [ Mem; regXSP; reg_of_ireg Asm.X16; reg_of_ireg Asm.X29 ]; + read_locs = [ regXSP; Mem ]; + is_control = false; + } + +let freeframe_rec i sz linkofs = + { + inst = i; + write_locs = [ Mem; regXSP; reg_of_ireg Asm.X16 ]; + read_locs = [ regXSP; Mem ]; + is_control = false; + } + +let nop_rec i = + { inst = i; write_locs = []; read_locs = []; is_control = false } + +let arith_rec i = + match i with + | PArithP (i', rd) -> arith_p_rec (PBasic (PArith i)) i' (reg_of_dreg rd) + | PArithPP (i', rd, rs) -> + arith_pp_rec (PBasic (PArith i)) (reg_of_dreg rd) (reg_of_dreg rs) + | PArithPPP (i', rd, r1, r2) -> + arith_ppp_rec (PBasic (PArith i)) (reg_of_dreg rd) (reg_of_dreg r1) + (reg_of_dreg r2) + | PArithRR0R (i', rd, r1, r2) -> + arith_rr0r_rec (PBasic (PArith i)) (reg_of_ireg rd) (reg_of_ireg0 r1) + (reg_of_ireg r2) + | PArithRR0 (i', rd, r1) -> + arith_rr0_rec (PBasic (PArith i)) (reg_of_ireg rd) (reg_of_ireg0 r1) + | PArithARRRR0 (i', rd, r1, r2, r3) -> + arith_arrrr0_rec (PBasic (PArith i)) (reg_of_ireg rd) (reg_of_ireg r1) + (reg_of_ireg r2) (reg_of_ireg0 r3) + | PArithComparisonPP (i', r1, r2) -> + arith_comparison_pp_rec (PBasic (PArith i)) (reg_of_dreg r1) + (reg_of_dreg r2) + | PArithComparisonR0R (i', r1, r2) -> + arith_comparison_r0r_rec (PBasic (PArith i)) (reg_of_ireg0 r1) + (reg_of_ireg r2) + | PArithComparisonP (i', r1) -> + arith_comparison_p_rec (PBasic (PArith i)) (reg_of_dreg r1) + | Pcset (rd, c) -> cset_rec (PBasic (PArith i)) (reg_of_ireg rd) c + | Pfmovi (fsz, rd, r1) -> + fmovi_rec (PBasic (PArith i)) fsz (reg_of_freg rd) (reg_of_ireg0 r1) + | Pcsel (rd, r1, r2, c) -> + csel_rec (PBasic (PArith i)) (reg_of_dreg rd) (reg_of_dreg r1) + (reg_of_dreg r2) c + | Pfnmul (fsz, rd, r1, r2) -> + fnmul_rec (PBasic (PArith i)) fsz (reg_of_freg rd) (reg_of_freg r1) + (reg_of_freg r2) + +let basic_rec i = + match i with + | PArith i' -> arith_rec i' + | PLoad ld -> load_rec ld + | PStore st -> store_rec st + | Pallocframe (sz, linkofs) -> allocframe_rec (PBasic i) sz linkofs + | Pfreeframe (sz, linkofs) -> freeframe_rec (PBasic i) sz linkofs + | Ploadsymbol (rd, id) -> loadsymbol_rec (PBasic i) (reg_of_ireg rd) id + | Pcvtsw2x (rd, r1) -> + cvtsw2x_rec (PBasic i) (reg_of_ireg rd) (reg_of_ireg r1) + | Pcvtuw2x (rd, r1) -> + cvtuw2x_rec (PBasic i) (reg_of_ireg rd) (reg_of_ireg r1) + | Pcvtx2w rd -> cvtx2w_rec (PBasic i) (reg_of_ireg rd) + | Pnop -> nop_rec (PBasic i) + +let builtin_rec i ef args res = + { inst = i; write_locs = [ Mem ]; read_locs = [ Mem ]; is_control = true } + +let ctl_flow_rec i = + match i with + | Pb lbl -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_pc ]; + is_control = true; + } + | Pbc (c, lbl) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_pc ]; + is_control = true; + } + | Pbl (id, sg) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_ireg Asm.X30; reg_of_pc ]; + read_locs = [ reg_of_pc ]; + is_control = true; + } + | Pbs (id, sg) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = []; + is_control = true; + } + | Pblr (r, sg) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_ireg Asm.X30; reg_of_pc ]; + read_locs = [ reg_of_ireg r ]; + is_control = true; + } + | Pbr (r, sg) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_ireg r ]; + is_control = true; + } + | Pret r -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_ireg r ]; + is_control = true; + } + | Pcbnz (sz, r, lbl) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_ireg r; reg_of_pc ]; + is_control = true; + } + | Pcbz (sz, r, lbl) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_ireg r; reg_of_pc ]; + is_control = true; + } + | Ptbnz (sz, r, n, lbl) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_ireg r; reg_of_pc ]; + is_control = true; + } + | Ptbz (sz, r, n, lbl) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_pc ]; + read_locs = [ reg_of_ireg r; reg_of_pc ]; + is_control = true; + } + | Pbtbl (r1, tbl) -> + { + inst = PControl (PCtlFlow i); + write_locs = [ reg_of_ireg Asm.X16; reg_of_ireg Asm.X17; reg_of_pc ]; + read_locs = [ reg_of_ireg r1; reg_of_pc ]; + is_control = true; + } + +let control_rec i = + match i with + | Pbuiltin (ef, args, res) -> builtin_rec (PControl i) ef args res + | PCtlFlow i' -> ctl_flow_rec i' + +let rec basic_recs body = + match body with [] -> [] | bi :: body -> basic_rec bi :: basic_recs body + +let exit_rec exit = match exit with None -> [] | Some ex -> [ control_rec ex ] + +let instruction_recs bb = basic_recs bb.body @ exit_rec bb.exit + +(** + * Providing informations relative to the real instructions + *) + +type inst_info = { + write_locs : location list; + read_locs : location list; + is_control : bool; + (* resources consumed by the instruction *) + usage : int array; + latency : int; +} + +(** Abstraction providing all the necessary informations for solving the scheduling problem *) + +let rec_to_info (r : ab_inst_rec) : inst_info = + let opweights = OpWeightsAsm.get_opweights () in + let usage = opweights.resources_of_op r.inst 0 + and latency = opweights.latency_of_op r.inst 0 in + { + write_locs = r.write_locs; + read_locs = r.read_locs; + usage; + latency; + is_control = r.is_control; + } + +let instruction_infos bb = List.map rec_to_info (instruction_recs bb) + +let instruction_usages bb = + let usages = List.map (fun info -> info.usage) (instruction_infos bb) in + Array.of_list usages + +(** + * Latency constraints building + *) + +module LocHash = Hashtbl + +(* Hash table : location => list of instruction ids *) + +let rec intlist n = + if n < 0 then failwith "intlist: n < 0" + else if n = 0 then [] + else (n - 1) :: intlist (n - 1) + +let find_in_hash hashloc loc = + match LocHash.find_opt hashloc loc with Some idl -> idl | None -> [] + +(* Returns a list of instruction ids *) +let rec get_accesses hashloc (ll : location list) = + match ll with + | [] -> [] + | loc :: llocs -> find_in_hash hashloc loc @ get_accesses hashloc llocs + +let compute_latency (ifrom : inst_info) = ifrom.latency + +let latency_constraints bb = + let written = LocHash.create 70 + and read = LocHash.create 70 + and count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb in + let step (i : inst_info) = + let raw = get_accesses written i.read_locs + and waw = get_accesses written i.write_locs + and war = get_accesses read i.write_locs in + List.iter + (fun i -> + constraints := + { + instr_from = i; + instr_to = !count; + latency = compute_latency (List.nth instr_infos i); + } + :: !constraints) + raw; + List.iter + (fun i -> + constraints := + { + instr_from = i; + instr_to = !count; + latency = compute_latency (List.nth instr_infos i); + } + :: !constraints) + waw; + List.iter + (fun i -> + constraints := + { instr_from = i; instr_to = !count; latency = 0 } :: !constraints) + war; + if i.is_control then + List.iter + (fun n -> + constraints := + { instr_from = n; instr_to = !count; latency = 0 } :: !constraints) + (intlist !count); + (* Updating "read" and "written" hashmaps *) + List.iter + (fun loc -> + LocHash.replace written loc [ !count ]; + LocHash.replace read loc [] + (* Clearing all the entries of "read" hashmap when a register is written *)) + i.write_locs; + List.iter + (fun loc -> LocHash.replace read loc (!count :: find_in_hash read loc)) + i.read_locs; + count := !count + 1 + in + List.iter step instr_infos; + !constraints + +(** + * Using the InstructionScheduler + *) + +let opweights = OpWeightsAsm.get_opweights () + +let build_problem bb = + { + max_latency = -1; + resource_bounds = opweights.pipelined_resource_bounds; + instruction_usages = instruction_usages bb; + latency_constraints = latency_constraints bb; + } + +let get_from_indexes indexes l = List.map (List.nth l) indexes + +(*let is_basic = function PBasic _ -> true | _ -> false*) +let is_control = function PControl _ -> true | _ -> false + +let to_control = function + | PControl i -> i + | _ -> failwith "to_control: basic instruction found" + +let rec body_to_instrs bdy = + match bdy with [] -> [] | i :: l' -> PBasic i :: body_to_instrs l' + +let rec instrs_to_bdy instrs = + match instrs with + | [] -> [] + | PBasic i :: l' -> i :: instrs_to_bdy l' + | PControl _ :: l' -> failwith "instrs_to_bdy: control instruction found" + +let repack li hd = + let last = List.nth li (List.length li - 1) in + if is_control last then + let cut_li = + Array.to_list @@ Array.sub (Array.of_list li) 0 (List.length li - 1) + in + { header = hd; body = instrs_to_bdy cut_li; exit = Some (to_control last) } + else { header = hd; body = instrs_to_bdy li; exit = None } + +module TimeHash = Hashtbl + +(*Hash table : time => list of instruction ids *) + +(* Flattening the minpack result *) +let hashtbl2flatarray h maxint = + let rec f i = + match TimeHash.find_opt h i with + | None -> if i > maxint then [] else f (i + 1) + | Some bund -> bund @ f (i + 1) + in + f 0 + +let find_max l = + let rec f = function + | [] -> None + | e :: l -> ( + match f l with + | None -> Some e + | Some m -> if e > m then Some e else Some m) + in + match f l with None -> raise Not_found | Some m -> m + +(* We still use the minpack algorithm even without bundles, but the result is then flattened *) +(*(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *)*) +let minpack_list (l : int list) = + let timehash = TimeHash.create (List.length l) in + let rec f i = function + | [] -> () + | t :: l -> + (match TimeHash.find_opt timehash t with + | None -> TimeHash.add timehash t [ i ] + | Some bund -> TimeHash.replace timehash t (bund @ [ i ])); + f (i + 1) l + in + f 0 l; + hashtbl2flatarray timehash (find_max l) + +let bb_to_instrs bb = + body_to_instrs bb.body + @ match bb.exit with None -> [] | Some e -> [ PControl e ] + +let build_solution bb sol = + (* Remove last element - the total *) + let tmp = Array.to_list @@ Array.sub sol 0 (Array.length sol - 1) in + let pack = minpack_list tmp and instrs = bb_to_instrs bb in + repack (get_from_indexes pack instrs) bb.header + +let print_schedule sched = + print_string "[ "; + Array.iter (fun x -> Printf.printf "%d; " x) sched; + print_endline "]" + +let do_schedule bb = + let problem = build_problem bb in + if debug then print_problem stdout problem; + let solution = scheduler_by_name !Clflags.option_fpostpass_sched problem in + match solution with + | None -> failwith "Could not find a valid schedule" + | Some sol -> + if debug then print_schedule sol; + build_solution bb sol + +(** + * Dumb schedule if the above doesn't work + *) + +(* Pack result *) +let pack_result (bb : bblock) = (bb.body, bb.exit) + +let smart_schedule bb = + let bb' = + try do_schedule bb with + | OpaqueInstruction -> + if debug then + Printf.eprintf "OpaqueInstruction raised, using identity scheduling\n"; + bb (* Identity in case of failure *) + | e -> + let msg = Printexc.to_string e and stack = Printexc.get_backtrace () in + Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg + stack; + failwith "Invalid schedule" + in + pack_result bb' + +let bblock_schedule bb = + let identity_mode = not !Clflags.option_fpostpass in + if debug && not identity_mode then ( + Printf.eprintf "###############################\n"; + Printf.eprintf "SCHEDULING\n"); + if stats then ( + let oc = + open_out_gen [ Open_append; Open_creat ] 0o666 "oracle_stats.csv" + in + Printf.fprintf oc "%d\n" (Camlcoq.Z.to_int (size bb)); + close_out oc); + if identity_mode then pack_result bb else smart_schedule bb + +(** Called schedule function from Coq *) + +(*let schedule_notime bb = let toto = bblock_schedule in toto*) +let schedule bb = + Timing.time_coq + [ + 'P'; + 'o'; + 's'; + 't'; + 'p'; + 'a'; + 's'; + 's'; + 'S'; + 'c'; + 'h'; + 'e'; + 'd'; + 'u'; + 'l'; + 'i'; + 'n'; + 'g'; + ' '; + 'o'; + 'r'; + 'a'; + 'c'; + 'l'; + 'e'; + ] + bblock_schedule bb diff --git a/aarch64/PostpassSchedulingproof.v b/aarch64/PostpassSchedulingproof.v new file mode 100644 index 00000000..48840602 --- /dev/null +++ b/aarch64/PostpassSchedulingproof.v @@ -0,0 +1,481 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockprops. +Require Import PostpassScheduling. +Require Import Asmblockgenproof. +Require Import Axioms. + +Local Open Scope error_monad_scope. + +Definition match_prog (p tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION_ASMBLOCK. + +Variables prog tprog: program. +Variable lk: aarch64_linker. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_match TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + exists tf, + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSL). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s1 s2, s1 = s2 -> match_states s1 s2. + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSL). + +Lemma prog_main_address_preserved: + (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = + (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). +Proof. + unfold Genv.symbol_address. rewrite symbols_preserved. + rewrite prog_main_preserved. auto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + econstructor; split. + - eapply initial_state_intro. + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. econstructor; eauto. +Qed. + +Lemma transf_find_bblock: + forall ofs f bb tf, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> + transf_function f = OK tf -> + exists tbb, + verified_schedule bb = OK tbb + /\ find_bblock (Ptrofs.unsigned ofs) (fn_blocks tf) = Some tbb. +Proof. + intros. + monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); try (inv EQ0; fail). inv EQ0. + monadInv EQ. simpl in *. + generalize (Ptrofs.unsigned ofs) H x EQ0; clear ofs H x g EQ0. + induction (fn_blocks f). + - intros. simpl in *. discriminate. + - intros. simpl in *. + monadInv EQ0. simpl. + destruct (zlt z 0); try discriminate. + destruct (zeq z 0). + + inv H. eauto. + + monadInv EQ0. + exploit IHb; eauto. + intros (tbb & SCH & FIND). + eexists; split; eauto. + inv FIND. + unfold verify_size in EQ0. + destruct (size a =? size (stick_header (header a) x)) eqn:EQSIZE; try discriminate. + rewrite Z.eqb_eq in EQSIZE; rewrite EQSIZE. + reflexivity. +Qed. + +Lemma stick_header_neutral: forall a, + a = (stick_header (header a) (no_header a)). +Proof. + intros. + unfold stick_header. unfold Asmblock.stick_header_obligation_1. simpl. destruct a. + simpl. reflexivity. +Qed. + +Lemma symbol_address_preserved: + forall l ofs, Genv.symbol_address ge l ofs = Genv.symbol_address tge l ofs. +Proof. + intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. +Qed. + +Lemma verified_schedule_label: + forall bb tbb l, + verified_schedule bb = OK (tbb) -> + is_label l bb = is_label l tbb. +Proof. + intros. + unfold is_label. + monadInv H. simpl. auto. +Qed. + +Remark label_pos_pvar_none_add: + forall tc l p p' k, + label_pos l (p+k) tc = None -> label_pos l (p'+k) tc = None. +Proof. + induction tc. + - intros. simpl. auto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + discriminate. + + pose (IHtc l p p' (k + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_none: + forall tc l p p', + label_pos l p tc = None -> label_pos l p' tc = None. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_none_add; eauto. +Qed. + +Remark label_pos_pvar_some_add_add: + forall tc l p p' k k', + label_pos l (p+k') tc = Some (p+k) -> label_pos l (p'+k') tc = Some (p'+k). +Proof. + induction tc. + - intros. simpl in H. discriminate. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + inv H. assert (k = k') by omega. subst. reflexivity. + + pose (IHtc l p p' k (k' + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_some_add: + forall tc l p p' k, + label_pos l p tc = Some (p+k) -> label_pos l p' tc = Some (p'+k). +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_some_add_add; eauto. +Qed. + +Remark label_pos_pvar_add: + forall c tc l p p' k, + label_pos l (p+k) c = label_pos l p tc -> + label_pos l (p'+k) c = label_pos l p' tc. +Proof. + induction c. + - intros. simpl in *. + exploit label_pos_pvar_none; eauto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + exploit label_pos_pvar_some_add; eauto. + + pose (IHc tc l p p' (k+size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar: + forall c tc l p p', + label_pos l p c = label_pos l p tc -> + label_pos l p' c = label_pos l p' tc. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_add; eauto. +Qed. + +Lemma label_pos_head_cons: + forall c bb tbb l tc p, + verified_schedule bb = OK tbb -> + label_pos l p c = label_pos l p tc -> + label_pos l p (bb :: c) = label_pos l p (tbb :: tc). +Proof. + intros. simpl. + exploit verified_schedule_label; eauto. intros ISLBL. + rewrite ISLBL. + destruct (is_label l tbb) eqn:ISLBL'; simpl; auto. + eapply label_pos_pvar in H0. erewrite H0. + erewrite verified_schedule_size; eauto. +Qed. + +Lemma label_pos_preserved: + forall c tc l, + transf_blocks c = OK tc -> label_pos l 0 c = label_pos l 0 tc. +Proof. + induction c. + - intros. simpl in *. inv H. reflexivity. + - intros. unfold transf_blocks in H; fold transf_blocks in H. monadInv H. + eapply IHc in EQ. eapply label_pos_head_cons; eauto. +Qed. + +Lemma label_pos_preserved_blocks: + forall l f tf, + transf_function f = OK tf -> + label_pos l 0 (fn_blocks f) = label_pos l 0 (fn_blocks tf). +Proof. + intros. monadInv H. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned _); try discriminate. + monadInv EQ0. simpl. eapply label_pos_preserved; eauto. +Qed. + +Lemma transf_exec_basic: + forall i rs m, exec_basic lk ge i rs m = exec_basic lk tge i rs m. +Proof. + intros. pose symbol_address_preserved. + unfold exec_basic. + destruct i; simpl; auto; try congruence. +Qed. + +Lemma transf_exec_body: + forall bdy rs m, exec_body lk ge bdy rs m = exec_body lk tge bdy rs m. +Proof. + induction bdy; intros. + - simpl. reflexivity. + - simpl. rewrite transf_exec_basic. + destruct (exec_basic _ _ _); auto. +Qed. + +Lemma transf_exec_cfi: forall f tf cfi rs m, + transf_function f = OK tf -> + exec_cfi ge f cfi rs m = exec_cfi tge tf cfi rs m. +Proof. + intros. destruct cfi; simpl; auto; + assert (ge = Genv.globalenv prog); auto; + assert (tge = Genv.globalenv tprog); auto; + pose symbol_address_preserved. + all: try unfold eval_branch; try unfold eval_neg_branch; try unfold goto_label; + try erewrite label_pos_preserved_blocks; try rewrite e; eauto. + destruct (rs # X16 <- Vundef r1); auto. + destruct (list_nth_z tbl (Int.unsigned i)); auto. + erewrite label_pos_preserved_blocks; eauto. +Qed. + +Lemma transf_exec_exit: + forall f tf sz ex t rs m rs' m', + transf_function f = OK tf -> + exec_exit ge f sz rs m ex t rs' m' -> + exec_exit tge tf sz rs m ex t rs' m'. +Proof. + intros. induction H0. + - econstructor. + - econstructor. erewrite <- transf_exec_cfi; eauto. + - econstructor; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. +Qed. + +Lemma transf_exec_bblock: + forall f tf bb t rs m rs' m', + transf_function f = OK tf -> + exec_bblock lk ge f bb rs m t rs' m' -> + exec_bblock lk tge tf bb rs m t rs' m'. +Proof. + intros. + destruct H0 as [rs1[m1[BDY EXIT]]]. + unfold exec_bblock. + eexists; eexists; split. + rewrite <- transf_exec_body; eauto. + eapply transf_exec_exit; eauto. +Qed. + +Theorem transf_step_correct: + forall s1 t s2, step lk ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + (exists s2', step lk tge s1' t s2' /\ match_states s2 s2'). +Proof. + induction 1; intros; inv MS. + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + exploit transf_find_bblock; eauto. intros (tbb & VES & FIND). + exploit verified_schedule_correct; eauto. intros EBB. + eapply transf_exec_bblock in EBB; eauto. + exists (State rs' m'). + split; try (econstructor; eauto). + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + remember (State _ m') as s'. exists s'. split; try constructor; auto. + subst s'. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. +Qed. + +Theorem transf_program_correct_Asmblock: + forward_simulation (Asmblock.semantics lk prog) (Asmblock.semantics lk tprog). +Proof. + eapply forward_simulation_step. + - apply senv_preserved. + - apply transf_initial_states. + - apply transf_final_states. + - apply transf_step_correct. +Qed. + +End PRESERVATION_ASMBLOCK. + +(* +Require Import Asm. + +Lemma verified_par_checks_alls_bundles lb x: forall bundle, + verify_par lb = OK x -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + induction lb; simpl; try tauto. + intros bundle H; monadInv H. + destruct 1; subst; eauto. + destruct x0; auto. +Qed. + +Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: + verified_schedule_nob bb = OK lb -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + unfold verified_schedule_nob. intros H; + monadInv H. destruct x4. + intros; eapply verified_par_checks_alls_bundles; eauto. +Qed. + +Lemma verify_par_bblock_PExpand bb i: + exit bb = Some (PExpand i) -> verify_par_bblock bb = OK tt. +Proof. + destruct bb as [h bdy ext H]; simpl. + intros; subst. destruct i. + generalize H. + rewrite <- wf_bblock_refl in H. + destruct H as [H H0]. + unfold builtin_alone in H0. erewrite H0; eauto. +Qed. + +Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core. + +Lemma verified_schedule_checks_alls_bundles bb lb bundle: + verified_schedule bb = OK lb -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + unfold verified_schedule. remember (exit bb) as exb. + destruct exb as [c|]; eauto. + destruct c as [i|]; eauto. + destruct i; intros H. inversion_clear H; simpl. + intuition subst. + intros; eapply verify_par_bblock_PExpand; eauto. +Qed. + +Lemma transf_blocks_checks_all_bundles lbb: forall lb bundle, + transf_blocks lbb = OK lb -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + induction lbb; simpl. + - intros lb bundle H; inversion_clear H. simpl; try tauto. + - intros lb bundle H0. + monadInv H0. + rewrite in_app. destruct 1; eauto. + eapply verified_schedule_checks_alls_bundles; eauto. +Qed. + +Lemma find_bblock_Some_in lb: + forall ofs b, find_bblock ofs lb = Some b -> List.In b lb. +Proof. + induction lb; simpl; try congruence. + intros ofs b. + destruct (zlt ofs 0); try congruence. + destruct (zeq ofs 0); eauto. + intros X; inversion X; eauto. +Qed.*) + +(* +Section PRESERVATION_ASMVLIW. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma all_bundles_are_checked b ofs f bundle: + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock ofs (fn_blocks f) = Some bundle -> + verify_par_bblock bundle = OK tt. +Proof. + unfold match_prog, match_program in TRANSL. + unfold Genv.find_funct_ptr; simpl; intros X. + destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. + destruct y as [tf0|]; try congruence. + inversion X as [H1]. subst. clear X. + remember (@Gfun fundef unit (Internal f)) as f2. + destruct H as [ctx' f1 f2 H0|]; try congruence. + inversion Heqf2 as [H2]. subst; clear Heqf2. + unfold transf_fundef, transf_partial_fundef in H. + destruct f1 as [f1|f1]; try congruence. + unfold transf_function, transl_function in H. + monadInv H. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks _))); simpl in *|-; try congruence. + injection EQ1; intros; subst. + monadInv EQ0. simpl in * |-. + intros; exploit transf_blocks_checks_all_bundles; eauto. + intros; eapply find_bblock_Some_in; eauto. +Qed. + +Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m': + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + verify_par_bblock bundle = OK tt -> + det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. +Proof. + intros. unfold verify_par_bblock in H0. destruct (Asmblockdeps.bblock_para_check _) eqn:BPC; try discriminate. clear H0. + simpl in H. + eapply Asmblockdeps.bblock_para_check_correct; eauto. +Qed. + +Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m': + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. +Proof. + intros; eapply checked_bundles_are_parexec_equiv; eauto. + eapply all_bundles_are_checked; eauto. +Qed. + +Theorem transf_program_correct_Asmvliw: + forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). +Proof. + eapply forward_simulation_step with (match_states:=fun (s1:Asmvliw.state) s2 => s1=s2); eauto. + - intros; subst; auto. + - intros s1 t s1' H s2 H0; subst; inversion H; clear H; subst; eexists; split; eauto. + + eapply exec_step_internal; eauto. + intros; eapply seqexec_parexec_equiv; eauto. + + eapply exec_step_builtin; eauto. + + eapply exec_step_external; eauto. +Qed. + +End PRESERVATION_ASMVLIW.*) + +Section PRESERVATION. + +Variable lk: aarch64_linker. +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics lk prog) (Asmblock.semantics lk tprog). +Proof. + eapply transf_program_correct_Asmblock; eauto. +Qed. + +End PRESERVATION. diff --git a/aarch64/PrepassSchedulingOracle.ml b/aarch64/PrepassSchedulingOracle.ml new file mode 100644 index 00000000..2c3eb14f --- /dev/null +++ b/aarch64/PrepassSchedulingOracle.ml @@ -0,0 +1,477 @@ +open AST +open RTL +open Maps +open InstructionScheduler +open Registers +open PrepassSchedulingOracleDeps + +let use_alias_analysis () = false + +let length_of_chunk = function +| Mint8signed +| Mint8unsigned -> 1 +| Mint16signed +| Mint16unsigned -> 2 +| Mint32 +| Mfloat32 +| Many32 -> 4 +| Mint64 +| Mfloat64 +| Many64 -> 8;; + +let get_simple_dependencies (opweights : opweights) (seqa : (instruction*Regset.t) array) = + let last_reg_reads : int list PTree.t ref = ref PTree.empty + and last_reg_write : (int*int) PTree.t ref = ref PTree.empty + and last_mem_reads : int list ref = ref [] + and last_mem_write : int option ref = ref None + and last_branch : int option ref = ref None + and last_non_pipelined_op : int array = Array.make + opweights.nr_non_pipelined_units ( -1 ) + and latency_constraints : latency_constraint list ref = ref [] in + let add_constraint instr_from instr_to latency = + assert (instr_from <= instr_to); + assert (latency >= 0); + if instr_from = instr_to + then (if latency = 0 + then () + else failwith "PrepassSchedulingOracle.get_dependencies: negative self-loop") + else + latency_constraints := + { instr_from = instr_from; + instr_to = instr_to; + latency = latency + }:: !latency_constraints + and get_last_reads reg = + match PTree.get reg !last_reg_reads + with Some l -> l + | None -> [] in + let add_input_mem i = + if not (use_alias_analysis ()) + then + begin + begin + (* Read after write *) + match !last_mem_write with + | None -> () + | Some j -> add_constraint j i 1 + end; + last_mem_reads := i :: !last_mem_reads + end + and add_output_mem i = + if not (use_alias_analysis ()) + then + begin + begin + (* Write after write *) + match !last_mem_write with + | None -> () + | Some j -> add_constraint j i 1 + end; + (* Write after read *) + List.iter (fun j -> add_constraint j i 0) !last_mem_reads; + last_mem_write := Some i; + last_mem_reads := [] + end + and add_input_reg i reg = + begin + (* Read after write *) + match PTree.get reg !last_reg_write with + | None -> () + | Some (j, latency) -> add_constraint j i latency + end; + last_reg_reads := PTree.set reg + (i :: get_last_reads reg) + !last_reg_reads + and add_output_reg i latency reg = + begin + (* Write after write *) + match PTree.get reg !last_reg_write with + | None -> () + | Some (j, _) -> add_constraint j i 1 + end; + begin + (* Write after read *) + List.iter (fun j -> add_constraint j i 0) (get_last_reads reg) + end; + last_reg_write := PTree.set reg (i, latency) !last_reg_write; + last_reg_reads := PTree.remove reg !last_reg_reads + in + let add_input_regs i regs = List.iter (add_input_reg i) regs in + let rec add_builtin_res i (res : reg builtin_res) = + match res with + | BR r -> add_output_reg i 10 r + | BR_none -> () + | BR_splitlong (hi, lo) -> add_builtin_res i hi; + add_builtin_res i lo in + let rec add_builtin_arg i (ba : reg builtin_arg) = + match ba with + | BA r -> add_input_reg i r + | BA_int _ | BA_long _ | BA_float _ | BA_single _ -> () + | BA_loadstack(_,_) -> add_input_mem i + | BA_addrstack _ -> () + | BA_loadglobal(_, _, _) -> add_input_mem i + | BA_addrglobal _ -> () + | BA_splitlong(hi, lo) -> add_builtin_arg i hi; + add_builtin_arg i lo + | BA_addptr(a1, a2) -> add_builtin_arg i a1; + add_builtin_arg i a2 in + let irreversible_action i = + match !last_branch with + | None -> () + | Some j -> add_constraint j i 1 in + let set_branch i = + irreversible_action i; + last_branch := Some i in + let add_non_pipelined_resources i resources = + Array.iter2 + (fun latency last -> + if latency >= 0 && last >= 0 then add_constraint last i latency) + resources last_non_pipelined_op; + Array.iteri (fun rsc latency -> + if latency >= 0 + then last_non_pipelined_op.(rsc) <- i) resources + in + Array.iteri + begin + fun i (insn, other_uses) -> + List.iter (fun use -> + add_input_reg i use) + (Regset.elements other_uses); + + match insn with + | Inop _ -> () + | Iop(op, inputs, output, _) -> + add_non_pipelined_resources i + (opweights.non_pipelined_resources_of_op op (List.length inputs)); + (if Op.is_trapping_op op then irreversible_action i); + add_input_regs i inputs; + add_output_reg i (opweights.latency_of_op op (List.length inputs)) output + | Iload(trap, chunk, addressing, addr_regs, output, _) -> + (if trap=TRAP then irreversible_action i); + add_input_mem i; + add_input_regs i addr_regs; + add_output_reg i (opweights.latency_of_load trap chunk addressing (List.length addr_regs)) output + | Istore(chunk, addressing, addr_regs, input, _) -> + irreversible_action i; + add_input_regs i addr_regs; + add_input_reg i input; + add_output_mem i + | Icall(signature, ef, inputs, output, _) -> + set_branch i; + (match ef with + | Datatypes.Coq_inl r -> add_input_reg i r + | Datatypes.Coq_inr symbol -> () + ); + add_input_mem i; + add_input_regs i inputs; + add_output_reg i (opweights.latency_of_call signature ef) output; + add_output_mem i; + failwith "Icall" + | Itailcall(signature, ef, inputs) -> + set_branch i; + (match ef with + | Datatypes.Coq_inl r -> add_input_reg i r + | Datatypes.Coq_inr symbol -> () + ); + add_input_mem i; + add_input_regs i inputs; + failwith "Itailcall" + | Ibuiltin(ef, builtin_inputs, builtin_output, _) -> + set_branch i; + add_input_mem i; + List.iter (add_builtin_arg i) builtin_inputs; + add_builtin_res i builtin_output; + add_output_mem i; + failwith "Ibuiltin" + | Icond(cond, inputs, _, _, _) -> + set_branch i; + add_input_mem i; + add_input_regs i inputs + | Ijumptable(input, _) -> + set_branch i; + add_input_reg i input; + failwith "Ijumptable" + | Ireturn(Some input) -> + set_branch i; + add_input_reg i input; + failwith "Ireturn" + | Ireturn(None) -> + set_branch i; + failwith "Ireturn none" + end seqa; + !latency_constraints;; + +let resources_of_instruction (opweights : opweights) = function + | Inop _ -> Array.map (fun _ -> 0) opweights.pipelined_resource_bounds + | Iop(op, inputs, output, _) -> + opweights.resources_of_op op (List.length inputs) + | Iload(trap, chunk, addressing, addr_regs, output, _) -> + opweights.resources_of_load trap chunk addressing (List.length addr_regs) + | Istore(chunk, addressing, addr_regs, input, _) -> + opweights.resources_of_store chunk addressing (List.length addr_regs) + | Icall(signature, ef, inputs, output, _) -> + opweights.resources_of_call signature ef + | Ibuiltin(ef, builtin_inputs, builtin_output, _) -> + opweights.resources_of_builtin ef + | Icond(cond, args, _, _ , _) -> + opweights.resources_of_cond cond (List.length args) + | Itailcall _ | Ijumptable _ | Ireturn _ -> opweights.pipelined_resource_bounds + +let print_sequence pp (seqa : instruction array) = + Array.iteri ( + fun i (insn : instruction) -> + PrintRTL.print_instruction pp (i, insn)) seqa;; + +type unique_id = int + +type 'a symbolic_term_node = + | STop of Op.operation * 'a list + | STinitial_reg of int + | STother of int;; + +type symbolic_term = { + hash_id : unique_id; + hash_ct : symbolic_term symbolic_term_node + };; + +let rec print_term channel term = + match term.hash_ct with + | STop(op, args) -> + PrintOp.print_operation print_term channel (op, args) + | STinitial_reg n -> Printf.fprintf channel "x%d" n + | STother n -> Printf.fprintf channel "y%d" n;; + +type symbolic_term_table = { + st_table : (unique_id symbolic_term_node, symbolic_term) Hashtbl.t; + mutable st_next_id : unique_id };; + +let hash_init () = { + st_table = Hashtbl.create 20; + st_next_id = 0 + };; + +let ground_to_id = function + | STop(op, l) -> STop(op, List.map (fun t -> t.hash_id) l) + | STinitial_reg r -> STinitial_reg r + | STother i -> STother i;; + +let hash_node (table : symbolic_term_table) (term : symbolic_term symbolic_term_node) : symbolic_term = + let grounded = ground_to_id term in + match Hashtbl.find_opt table.st_table grounded with + | Some x -> x + | None -> + let term' = { hash_id = table.st_next_id; + hash_ct = term } in + (if table.st_next_id = max_int then failwith "hash: max_int"); + table.st_next_id <- table.st_next_id + 1; + Hashtbl.add table.st_table grounded term'; + term';; + +type access = { + base : symbolic_term; + offset : int64; + length : int + };; + +let term_equal a b = (a.hash_id = b.hash_id);; + +let access_of_addressing get_reg chunk addressing args = + match addressing, args with + | (Op.Aindexed ofs), [reg] -> Some + { base = get_reg reg; + offset = Camlcoq.camlint64_of_ptrofs ofs; + length = length_of_chunk chunk + } + | _, _ -> None ;; +(* TODO: global *) + +let symbolic_execution (seqa : instruction array) = + let regs = ref PTree.empty + and table = hash_init() in + let assign reg term = regs := PTree.set reg term !regs + and hash term = hash_node table term in + let get_reg reg = + match PTree.get reg !regs with + | None -> hash (STinitial_reg (Camlcoq.P.to_int reg)) + | Some x -> x in + let targets = Array.make (Array.length seqa) None in + Array.iteri + begin + fun i insn -> + match insn with + | Iop(Op.Omove, [input], output, _) -> + assign output (get_reg input) + | Iop(op, inputs, output, _) -> + assign output (hash (STop(op, List.map get_reg inputs))) + + | Iload(trap, chunk, addressing, args, output, _) -> + let access = access_of_addressing get_reg chunk addressing args in + targets.(i) <- access; + assign output (hash (STother(i))) + + | Icall(_, _, _, output, _) + | Ibuiltin(_, _, BR output, _) -> + assign output (hash (STother(i))) + + | Istore(chunk, addressing, args, va, _) -> + let access = access_of_addressing get_reg chunk addressing args in + targets.(i) <- access + + | Inop _ -> () + | Ibuiltin(_, _, BR_none, _) -> () + | Ibuiltin(_, _, BR_splitlong _, _) -> failwith "BR_splitlong" + + | Itailcall (_, _, _) + |Icond (_, _, _, _, _) + |Ijumptable (_, _) + |Ireturn _ -> () + end seqa; + targets;; + +let print_access channel = function + | None -> Printf.fprintf channel "any" + | Some x -> Printf.fprintf channel "%a + %Ld" print_term x.base x.offset;; + +let print_targets channel seqa = + let targets = symbolic_execution seqa in + Array.iteri + (fun i insn -> + match insn with + | Iload _ -> Printf.fprintf channel "%d: load %a\n" + i print_access targets.(i) + | Istore _ -> Printf.fprintf channel "%d: store %a\n" + i print_access targets.(i) + | _ -> () + ) seqa;; + +let may_overlap a0 b0 = + match a0, b0 with + | (None, _) | (_ , None) -> true + | (Some a), (Some b) -> + if term_equal a.base b.base + then (max a.offset b.offset) < + (min (Int64.add (Int64.of_int a.length) a.offset) + (Int64.add (Int64.of_int b.length) b.offset)) + else match a.base.hash_ct, b.base.hash_ct with + | STop(Op.Oaddrsymbol(ida, ofsa),[]), + STop(Op.Oaddrsymbol(idb, ofsb),[]) -> + (ida=idb) && + let ao = Int64.add a.offset (Camlcoq.camlint64_of_ptrofs ofsa) + and bo = Int64.add b.offset (Camlcoq.camlint64_of_ptrofs ofsb) in + (max ao bo) < + (min (Int64.add (Int64.of_int a.length) ao) + (Int64.add (Int64.of_int b.length) bo)) + | STop(Op.Oaddrstack _, []), + STop(Op.Oaddrsymbol _, []) + | STop(Op.Oaddrsymbol _, []), + STop(Op.Oaddrstack _, []) -> false + | STop(Op.Oaddrstack(ofsa),[]), + STop(Op.Oaddrstack(ofsb),[]) -> + let ao = Int64.add a.offset (Camlcoq.camlint64_of_ptrofs ofsa) + and bo = Int64.add b.offset (Camlcoq.camlint64_of_ptrofs ofsb) in + (max ao bo) < + (min (Int64.add (Int64.of_int a.length) ao) + (Int64.add (Int64.of_int b.length) bo)) + | _ -> true;; + +(* +(* TODO suboptimal quadratic algorithm *) +let get_alias_dependencies seqa = + let targets = symbolic_execution seqa + and deps = ref [] in + let add_constraint instr_from instr_to latency = + deps := { instr_from = instr_from; + instr_to = instr_to; + latency = latency + }:: !deps in + for i=0 to (Array.length seqa)-1 + do + for j=0 to i-1 + do + match seqa.(j), seqa.(i) with + | (Istore _), ((Iload _) | (Istore _)) -> + if may_overlap targets.(j) targets.(i) + then add_constraint j i 1 + | (Iload _), (Istore _) -> + if may_overlap targets.(j) targets.(i) + then add_constraint j i 0 + | (Istore _ | Iload _), (Icall _ | Ibuiltin _) + | (Icall _ | Ibuiltin _), (Icall _ | Ibuiltin _ | Iload _ | Istore _) -> + add_constraint j i 1 + | (Inop _ | Iop _), _ + | _, (Inop _ | Iop _) + | (Iload _), (Iload _) -> () + done + done; + !deps;; + *) + +let define_problem (opweights : opweights) seqa = + let simple_deps = get_simple_dependencies opweights seqa in + { max_latency = -1; + resource_bounds = opweights.pipelined_resource_bounds; + instruction_usages = Array.map (resources_of_instruction opweights) (Array.map fst seqa); + latency_constraints = + (* if (use_alias_analysis ()) + then (get_alias_dependencies seqa) @ simple_deps + else *) simple_deps };; + +let zigzag_scheduler problem early_ones = + let nr_instructions = get_nr_instructions problem in + assert(nr_instructions = (Array.length early_ones)); + match list_scheduler problem with + | Some fwd_schedule -> + let fwd_makespan = fwd_schedule.((Array.length fwd_schedule) - 1) in + let constraints' = ref problem.latency_constraints in + Array.iteri (fun i is_early -> + if is_early then + constraints' := { + instr_from = i; + instr_to = nr_instructions ; + latency = fwd_makespan - fwd_schedule.(i) } ::!constraints' ) + early_ones; + validated_scheduler reverse_list_scheduler + { problem with latency_constraints = !constraints' } + | None -> None;; + +let prepass_scheduler_by_name name problem early_ones = + match name with + | "zigzag" -> zigzag_scheduler problem early_ones + | _ -> scheduler_by_name name problem + +let schedule_sequence (seqa : (instruction*Regset.t) array) = + let opweights = OpWeights.get_opweights () in + try + if (Array.length seqa) <= 1 + then None + else + begin + let nr_instructions = Array.length seqa in + (if !Clflags.option_debug_compcert > 6 + then Printf.printf "prepass scheduling length = %d\n" (Array.length seqa)); + let problem = define_problem opweights seqa in + (if !Clflags.option_debug_compcert > 7 + then (print_sequence stdout (Array.map fst seqa); + print_problem stdout problem)); + match prepass_scheduler_by_name + (!Clflags.option_fprepass_sched) + problem + (Array.map (fun (ins, _) -> + match ins with + | Icond _ -> true + | _ -> false) seqa) with + | None -> Printf.printf "no solution in prepass scheduling\n"; + None + | Some solution -> + let positions = Array.init nr_instructions (fun i -> i) in + Array.sort (fun i j -> + let si = solution.(i) and sj = solution.(j) in + if si < sj then -1 + else if si > sj then 1 + else i - j) positions; + Some positions + end + with (Failure s) -> + Printf.printf "failure in prepass scheduling: %s\n" s; + None;; + diff --git a/aarch64/PrepassSchedulingOracleDeps.ml b/aarch64/PrepassSchedulingOracleDeps.ml new file mode 100644 index 00000000..8d10d406 --- /dev/null +++ b/aarch64/PrepassSchedulingOracleDeps.ml @@ -0,0 +1,17 @@ +type called_function = (Registers.reg, AST.ident) Datatypes.sum + +type opweights = + { + pipelined_resource_bounds : int array; + nr_non_pipelined_units : int; + latency_of_op : Op.operation -> int -> int; + resources_of_op : Op.operation -> int -> int array; + non_pipelined_resources_of_op : Op.operation -> int -> int array; + latency_of_load : AST.trapping_mode -> AST.memory_chunk -> Op.addressing -> int -> int; + resources_of_load : AST.trapping_mode -> AST.memory_chunk -> Op.addressing -> int -> int array; + resources_of_store : AST.memory_chunk -> Op.addressing -> int -> int array; + resources_of_cond : Op.condition -> int -> int array; + latency_of_call : AST.signature -> called_function -> int; + resources_of_call : AST.signature -> called_function -> int array; + resources_of_builtin : AST.external_function -> int array + };; diff --git a/aarch64/SelectLongproof.v b/aarch64/SelectLongproof.v index 60dc1a12..513ee9bd 100644 --- a/aarch64/SelectLongproof.v +++ b/aarch64/SelectLongproof.v @@ -559,25 +559,29 @@ Qed. Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. Proof. red; intros; unfold divls_base; TrivialExists. + cbn. rewrite H1. reflexivity. Qed. Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. Proof. red; intros; unfold modls_base, modl_aux. exploit Val.modls_divls; eauto. intros (q & A & B). subst z. - TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. + TrivialExists. repeat (econstructor; eauto with evalexpr). + rewrite A. reflexivity. Qed. Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. Proof. red; intros; unfold divlu_base; TrivialExists. + cbn. rewrite H1. reflexivity. Qed. Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. Proof. red; intros; unfold modlu_base, modl_aux. exploit Val.modlu_divlu; eauto. intros (q & A & B). subst z. - TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. + TrivialExists. repeat (econstructor; eauto with evalexpr). + rewrite A. reflexivity. Qed. Theorem eval_shrxlimm: @@ -592,7 +596,7 @@ Proof. destruct x; simpl in H0; try discriminate. change (Int.ltu Int.zero (Int.repr 63)) with true in H0; inv H0. rewrite Int64.shrx'_zero. auto. -- TrivialExists. +- TrivialExists. cbn. rewrite H0. reflexivity. Qed. (** General shifts *) @@ -726,42 +730,42 @@ Qed. Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. Proof. - red; intros; TrivialExists. + red; intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. End CMCONSTR. diff --git a/aarch64/SelectOpproof.v b/aarch64/SelectOpproof.v index 3379cbd8..9ce7a8bf 100644 --- a/aarch64/SelectOpproof.v +++ b/aarch64/SelectOpproof.v @@ -666,7 +666,8 @@ Theorem eval_divs_base: Val.divs x y = Some z -> exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. Proof. - intros; unfold divs_base; TrivialExists. + intros; unfold divs_base; TrivialExists; cbn. + rewrite H1. reflexivity. Qed. Theorem eval_mods_base: @@ -678,7 +679,8 @@ Theorem eval_mods_base: Proof. intros; unfold mods_base, mod_aux. exploit Val.mods_divs; eauto. intros (q & A & B). subst z. - TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. + TrivialExists. repeat (econstructor; eauto with evalexpr). + cbn. rewrite A. reflexivity. Qed. Theorem eval_divu_base: @@ -689,6 +691,7 @@ Theorem eval_divu_base: exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. Proof. intros; unfold divu_base; TrivialExists. + cbn. rewrite H1. reflexivity. Qed. Theorem eval_modu_base: @@ -700,7 +703,8 @@ Theorem eval_modu_base: Proof. intros; unfold modu_base, mod_aux. exploit Val.modu_divu; eauto. intros (q & A & B). subst z. - TrivialExists. repeat (econstructor; eauto with evalexpr). exact A. + TrivialExists. repeat (econstructor; eauto with evalexpr). + rewrite A. reflexivity. Qed. Theorem eval_shrximm: @@ -715,7 +719,7 @@ Proof. destruct x; simpl in H0; try discriminate. change (Int.ltu Int.zero (Int.repr 31)) with true in H0; inv H0. rewrite Int.shrx_zero by (compute; auto). auto. -- TrivialExists. +- TrivialExists. cbn. rewrite H0. reflexivity. Qed. (** General shifts *) @@ -928,7 +932,7 @@ Theorem eval_intoffloat: Val.intoffloat x = Some y -> exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. - intros; TrivialExists. + intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_floatofint: @@ -939,7 +943,7 @@ Theorem eval_floatofint: Proof. intros until y; unfold floatofint. case (floatofint_match a); intros; InvEval. - TrivialExists. -- TrivialExists. +- TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_intuoffloat: @@ -948,7 +952,7 @@ Theorem eval_intuoffloat: Val.intuoffloat x = Some y -> exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. Proof. - intros; TrivialExists. + intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_floatofintu: @@ -959,7 +963,7 @@ Theorem eval_floatofintu: Proof. intros until y; unfold floatofintu. case (floatofintu_match a); intros; InvEval. - TrivialExists. -- TrivialExists. +- TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_intofsingle: @@ -968,7 +972,7 @@ Theorem eval_intofsingle: Val.intofsingle x = Some y -> exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. Proof. - intros; TrivialExists. + intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleofint: @@ -979,7 +983,7 @@ Theorem eval_singleofint: Proof. intros until y; unfold singleofint. case (singleofint_match a); intros; InvEval. - TrivialExists. -- TrivialExists. +- TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_intuofsingle: @@ -988,7 +992,7 @@ Theorem eval_intuofsingle: Val.intuofsingle x = Some y -> exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. Proof. - intros; TrivialExists. + intros; TrivialExists. cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleofintu: @@ -999,7 +1003,7 @@ Theorem eval_singleofintu: Proof. intros until y; unfold singleofintu. case (singleofintu_match a); intros; InvEval. - TrivialExists. -- TrivialExists. +- TrivialExists. cbn. rewrite H0. reflexivity. Qed. (** Selection *) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 8d74daf4..40e4a182 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -21,24 +21,9 @@ open AisAnnot open PrintAsmaux open Fileinfo -(* Recognition of FP numbers that are supported by the fmov #imm instructions: - "a normalized binary floating point encoding with 1 sign bit, - 4 bits of fraction and a 3-bit exponent" -*) - -let is_immediate_float64 bits = - let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in - let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in - exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant - -let is_immediate_float32 bits = - let exp = (Int32.(to_int (shift_right_logical bits 23)) land 0xFF) - 127 in - let mant = Int32.logand bits 0x7F_FFFFl in - exp >= -3 && exp <= 4 && Int32.logand mant 0x78_0000l = mant - (* Module containing the printing functions *) -module Target : TARGET = +module Target (*: TARGET*) = struct (* Basic printing functions *) @@ -120,13 +105,13 @@ module Target : TARGET = output_string oc (match sz with D -> dreg_name r | S -> sreg_name r) let preg_asm oc ty = function - | IR r -> if ty = Tint then wreg oc r else xreg oc r - | FR r -> if ty = Tsingle then sreg oc r else dreg oc r + | DR (IR (RR1 r)) -> if ty = Tint then wreg oc r else xreg oc r + | DR (FR r) -> if ty = Tsingle then sreg oc r else dreg oc r | _ -> assert false let preg_annot = function - | IR r -> xreg_name r - | FR r -> dreg_name r + | DR (IR (RR1 r)) -> xreg_name r + | DR (FR r) -> dreg_name r | _ -> assert false (* Names of sections *) @@ -294,7 +279,9 @@ module Target : TARGET = (* the upper 32 bits of Xrd are set to 0, performing zero-extension *) | Pldrsw(rd, a) -> fprintf oc " ldrsw %a, %a\n" xreg rd addressing a - | Pldp(rd1, rd2, a) -> + | Pldpw(rd1, rd2, _, _, a) -> + fprintf oc " ldp %a, %a, %a\n" wreg rd1 wreg rd2 addressing a + | Pldpx(rd1, rd2, _, _, a) -> fprintf oc " ldp %a, %a, %a\n" xreg rd1 xreg rd2 addressing a | Pstrw(rs, a) | Pstrw_a(rs, a) -> fprintf oc " str %a, %a\n" wreg rs addressing a @@ -304,7 +291,9 @@ module Target : TARGET = fprintf oc " strb %a, %a\n" wreg rs addressing a | Pstrh(rs, a) -> fprintf oc " strh %a, %a\n" wreg rs addressing a - | Pstp(rs1, rs2, a) -> + | Pstpw(rs1, rs2, _, _, a) -> + fprintf oc " stp %a, %a, %a\n" wreg rs1 wreg rs2 addressing a + | Pstpx(rs1, rs2, _, _, a) -> fprintf oc " stp %a, %a, %a\n" xreg rs1 xreg rs2 addressing a (* Integer arithmetic, immediate *) | Paddimm(sz, rd, r1, n) -> @@ -399,6 +388,8 @@ module Target : TARGET = fprintf oc " rev %a, %a\n" ireg (sz, rd) ireg (sz, r1) | Prev16(sz, rd, r1) -> fprintf oc " rev16 %a, %a\n" ireg (sz, rd) ireg (sz, r1) + | Prbit(sz, rd, r1) -> + fprintf oc " rbit %a, %a\n" ireg (sz, rd) ireg (sz, r1) (* Conditional data processing *) | Pcsel(rd, r1, r2, c) -> fprintf oc " csel %a, %a, %a, %s\n" xreg rd xreg r1 xreg r2 (condition_name c) @@ -431,7 +422,7 @@ module Target : TARGET = fprintf oc " fmov %a, %a\n" dreg rd dreg r1 | Pfmovimmd(rd, f) -> let d = camlint64_of_coqint (Floats.Float.to_bits f) in - if is_immediate_float64 d then + if is_immediate_float64 f then fprintf oc " fmov %a, #%.7f\n" dreg rd (Int64.float_of_bits d) else begin let lbl = label_literal64 d in @@ -440,7 +431,7 @@ module Target : TARGET = end | Pfmovimms(rd, f) -> let d = camlint_of_coqint (Floats.Float32.to_bits f) in - if is_immediate_float32 d then + if is_immediate_float32 f then fprintf oc " fmov %a, #%.7f\n" sreg rd (Int32.float_of_bits d) else begin let lbl = label_literal32 d in @@ -489,6 +480,10 @@ module Target : TARGET = fprintf oc " fnmadd %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3) | Pfnmsub(sz, rd, r1, r2, r3) -> fprintf oc " fnmsub %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3) + | Pfmax (sz, rd, r1, r2) -> + fprintf oc " fmax %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) + | Pfmin (sz, rd, r1, r2) -> + fprintf oc " fmin %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) (* Floating-point comparison *) | Pfcmp(sz, r1, r2) -> fprintf oc " fcmp %a, %a\n" freg (sz, r1) freg (sz, r2) @@ -498,8 +493,8 @@ module Target : TARGET = | Pfsel(rd, r1, r2, c) -> fprintf oc " fcsel %a, %a, %a, %s\n" dreg rd dreg r1 dreg r2 (condition_name c) (* No-op *) - | Pnop -> - fprintf oc " nop\n" + | Pnop -> () + (*fprintf oc " nop\n"*) (* Pseudo-instructions expanded in Asmexpand *) | Pallocframe(sz, linkofs) -> assert false | Pfreeframe(sz, linkofs) -> assert false diff --git a/aarch64/ValueAOp.v b/aarch64/ValueAOp.v index e0d98c85..e6a60d4e 100644 --- a/aarch64/ValueAOp.v +++ b/aarch64/ValueAOp.v @@ -96,8 +96,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omul, v1::v2::nil => mul v1 v2 | Omuladd, v1::v2::v3::nil => add v1 (mul v2 v3) | Omulsub, v1::v2::v3::nil => sub v1 (mul v2 v3) - | Odiv, v1::v2::nil => divs v1 v2 - | Odivu, v1::v2::nil => divu v1 v2 + | Odiv, v1::v2::nil => divs_total v1 v2 + | Odivu, v1::v2::nil => divu_total v1 v2 | Oand, v1::v2::nil => and v1 v2 | Oandshift s a, v1::v2::nil => and v1 (eval_static_shift s v2 a) | Oandimm n, v1::nil => and v1 (I n) @@ -145,8 +145,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omullsub, v1::v2::v3::nil => subl v1 (mull v2 v3) | Omullhs, v1::v2::nil => mullhs v1 v2 | Omullhu, v1::v2::nil => mullhu v1 v2 - | Odivl, v1::v2::nil => divls v1 v2 - | Odivlu, v1::v2::nil => divlu v1 v2 + | Odivl, v1::v2::nil => divls_total v1 v2 + | Odivlu, v1::v2::nil => divlu_total v1 v2 | Oandl, v1::v2::nil => andl v1 v2 | Oandlshift s a, v1::v2::nil => andl v1 (eval_static_shiftl s v2 a) | Oandlimm n, v1::nil => andl v1 (L n) @@ -191,20 +191,20 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 - | Ointoffloat, v1::nil => intoffloat v1 - | Ointuoffloat, v1::nil => intuoffloat v1 + | Ointoffloat, v1::nil => intoffloat_total v1 + | Ointuoffloat, v1::nil => intuoffloat_total v1 | Ofloatofint, v1::nil => floatofint v1 | Ofloatofintu, v1::nil => floatofintu v1 - | Ointofsingle, v1::nil => intofsingle v1 - | Ointuofsingle, v1::nil => intuofsingle v1 + | Ointofsingle, v1::nil => intofsingle_total v1 + | Ointuofsingle, v1::nil => intuofsingle_total v1 | Osingleofint, v1::nil => singleofint v1 | Osingleofintu, v1::nil => singleofintu v1 - | Olongoffloat, v1::nil => longoffloat v1 - | Olonguoffloat, v1::nil => longuoffloat v1 + | Olongoffloat, v1::nil => longoffloat_total v1 + | Olonguoffloat, v1::nil => longuoffloat_total v1 | Ofloatoflong, v1::nil => floatoflong v1 | Ofloatoflongu, v1::nil => floatoflongu v1 - | Olongofsingle, v1::nil => longofsingle v1 - | Olonguofsingle, v1::nil => longuofsingle v1 + | Olongofsingle, v1::nil => longofsingle_total v1 + | Olonguofsingle, v1::nil => longuofsingle_total v1 | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 diff --git a/aarch64/ValueAOpSSA.v b/aarch64/ValueAOpSSA.v index 28c1612f..6dfc1e7b 100644 --- a/aarch64/ValueAOpSSA.v +++ b/aarch64/ValueAOpSSA.v @@ -96,8 +96,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omul, v1::v2::nil => mul v1 v2 | Omuladd, v1::v2::v3::nil => add v1 (mul v2 v3) | Omulsub, v1::v2::v3::nil => sub v1 (mul v2 v3) - | Odiv, v1::v2::nil => divs v1 v2 - | Odivu, v1::v2::nil => divu v1 v2 + | Odiv, v1::v2::nil => divs_total v1 v2 + | Odivu, v1::v2::nil => divu_total v1 v2 | Oand, v1::v2::nil => and v1 v2 | Oandshift s a, v1::v2::nil => and v1 (eval_static_shift s v2 a) | Oandimm n, v1::nil => and v1 (I n) @@ -145,8 +145,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omullsub, v1::v2::v3::nil => subl v1 (mull v2 v3) | Omullhs, v1::v2::nil => mullhs v1 v2 | Omullhu, v1::v2::nil => mullhu v1 v2 - | Odivl, v1::v2::nil => divls v1 v2 - | Odivlu, v1::v2::nil => divlu v1 v2 + | Odivl, v1::v2::nil => divls_total v1 v2 + | Odivlu, v1::v2::nil => divlu_total v1 v2 | Oandl, v1::v2::nil => andl v1 v2 | Oandlshift s a, v1::v2::nil => andl v1 (eval_static_shiftl s v2 a) | Oandlimm n, v1::nil => andl v1 (L n) @@ -191,20 +191,20 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 - | Ointoffloat, v1::nil => intoffloat v1 - | Ointuoffloat, v1::nil => intuoffloat v1 + | Ointoffloat, v1::nil => intoffloat_total v1 + | Ointuoffloat, v1::nil => intuoffloat_total v1 | Ofloatofint, v1::nil => floatofint v1 | Ofloatofintu, v1::nil => floatofintu v1 - | Ointofsingle, v1::nil => intofsingle v1 - | Ointuofsingle, v1::nil => intuofsingle v1 + | Ointofsingle, v1::nil => intofsingle_total v1 + | Ointuofsingle, v1::nil => intuofsingle_total v1 | Osingleofint, v1::nil => singleofint v1 | Osingleofintu, v1::nil => singleofintu v1 - | Olongoffloat, v1::nil => longoffloat v1 - | Olonguoffloat, v1::nil => longuoffloat v1 + | Olongoffloat, v1::nil => longoffloat_total v1 + | Olonguoffloat, v1::nil => longuoffloat_total v1 | Ofloatoflong, v1::nil => floatoflong v1 | Ofloatoflongu, v1::nil => floatoflongu v1 - | Olongofsingle, v1::nil => longofsingle v1 - | Olonguofsingle, v1::nil => longuofsingle v1 + | Olongofsingle, v1::nil => longofsingle_total v1 + | Olonguofsingle, v1::nil => longuofsingle_total v1 | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 diff --git a/aarch64/extractionMachdep.v b/aarch64/extractionMachdep.v index e82056e2..69edeb55 100644 --- a/aarch64/extractionMachdep.v +++ b/aarch64/extractionMachdep.v @@ -6,6 +6,9 @@ (* *) (* 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. *) (* *) (* *********************************************************************) @@ -21,4 +24,4 @@ Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) (* Asm *) Extract Constant Asm.symbol_low => "fun _ _ _ -> assert false". Extract Constant Asm.symbol_high => "fun _ _ _ -> assert false". -Extract Constant Asmgen.symbol_is_aligned => "C2C.atom_is_aligned". +Extract Constant Asmblockgen.symbol_is_aligned => "C2C.atom_is_aligned". diff --git a/arm/Archi.v b/arm/Archi.v index 738341cc..c334c2a7 100644 --- a/arm/Archi.v +++ b/arm/Archi.v @@ -16,9 +16,8 @@ (** Architecture-dependent parameters for ARM *) +From Flocq Require Import Binary Bits. Require Import ZArith List. -(*From Flocq*) -Require Import Binary Bits. Definition ptr64 := false. @@ -696,7 +696,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfsubd r1 r2 r3 => Next (nextinstr (rs#r1 <- (Val.subf rs#r2 rs#r3))) m | Pflid r1 f => - Next (nextinstr (rs#r1 <- (Vfloat f))) m + Next (nextinstr (rs#IR14 <- Vundef #r1 <- (Vfloat f))) m | Pfcmpd r1 r2 => Next (nextinstr (compare_float rs rs#r1 rs#r2)) m | Pfcmpzd r1 => @@ -923,7 +923,7 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge vargs m t vres m' -> rs' = nextinstr (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + (undef_regs (IR IR14 :: map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index 6996c9bb..104bfc94 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -349,9 +349,7 @@ let expand_builtin_inline name args res = emit (Prsb(res, res, SOimm _32)); emit (Plabel lbl2) (* Float arithmetic *) - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> - emit (Pfabsd (res,a1)) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + | ("__builtin_fsqrt" | "__builtin_sqrt"), [BA(FR a1)], BR(FR res) -> emit (Pfsqrt (res,a1)) (* 64-bit integer arithmetic *) | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 92ae524f..fd70c9ad 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -225,7 +225,7 @@ Proof. TailNoLabel. eapply tail_nolabel_trans; TailNoLabel. Qed. -Hint Resolve indexed_memory_access_label. +Hint Resolve indexed_memory_access_label: labels. Remark loadind_label: forall base ofs ty dst k c, loadind base ofs ty dst k = OK c -> tail_nolabel k c. @@ -761,13 +761,15 @@ Opaque loadind. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. + rewrite set_res_other. simpl. rewrite undef_regs_other_2. + rewrite Pregmap.gso by auto with asmgen. rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. rewrite preg_notin_charact. intros. auto with asmgen. auto with asmgen. apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. + eapply agree_undef_regs; eauto. + intros. simpl. rewrite undef_regs_other_2; auto. apply Pregmap.gso. auto with asmgen. congruence. - (* Mgoto *) diff --git a/arm/CBuiltins.ml b/arm/CBuiltins.ml index d6a1ea35..6462a8c5 100644 --- a/arm/CBuiltins.ml +++ b/arm/CBuiltins.ml @@ -22,19 +22,6 @@ let builtins = { "__builtin_va_list", TPtr(TVoid [], []) ]; builtin_functions = [ - (* Integer arithmetic *) - "__builtin_clz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_clzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_clzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); - "__builtin_ctz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_ctzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_ctzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); (* Memory accesses *) "__builtin_read16_reversed", (TInt(IUShort, []), [TPtr(TInt(IUShort, [AConst]), [])], false); diff --git a/arm/CSE2deps.v b/arm/CSE2deps.v index d48dabf3..4592f408 100644 --- a/arm/CSE2deps.v +++ b/arm/CSE2deps.v @@ -28,5 +28,8 @@ Definition may_overlap chunk addr args chunk' addr' args' := (base :: nil), (base' :: nil) => if peq base base' then negb (can_swap_accesses_ofs (Int.unsigned ofs') chunk' (Int.unsigned ofs) chunk) - else true | _, _, _, _ => true + else true + | (Ainstack ofs), (Ainstack ofs'), _, _ => + negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + | _, _, _, _ => true end. diff --git a/arm/CSE2depsproof.v b/arm/CSE2depsproof.v index 28ef41ca..7dd0914e 100644 --- a/arm/CSE2depsproof.v +++ b/arm/CSE2depsproof.v @@ -105,6 +105,68 @@ Section MEMORY_WRITE. Qed. End INDEXED_AWAY. End MEMORY_WRITE. + +Section STACK_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Ainstack ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Ainstack ofsr) nil = Some addrr. + + Lemma stack_load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + rewrite ptrofs_modulus in *. + simpl in *. + inv ADDRR. + inv ADDRW. + + destruct sp; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + + all: try rewrite ptrofs_modulus in *. + + all: intuition lia. + Qed. + + Theorem stack_load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply stack_load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End STACK_WRITE. End SOUNDNESS. @@ -125,7 +187,7 @@ Proof. intros until rs. intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) +- (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. destruct args' as [ | base' [ | ]]. 1,3: discriminate. simpl in OVERLAP. @@ -135,7 +197,15 @@ Proof. 2: discriminate. simpl in *. eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. - } + +- (* Ainstack / Ainstack *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + cbn in OVERLAP. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply stack_load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. Qed. End SOUNDNESS. diff --git a/arm/Machregsaux.ml b/arm/Machregsaux.ml index 14c75155..24a33e9e 100644 --- a/arm/Machregsaux.ml +++ b/arm/Machregsaux.ml @@ -12,27 +12,7 @@ (** Auxiliary functions on machine registers *) -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - let is_scratch_register s = s = "R14" || s = "r14" - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = - List.mem r Conventions1.int_callee_save_regs - || List.mem r Conventions1.float_callee_save_regs let class_of_type = function | AST.Tint | AST.Tlong -> 0 diff --git a/arm/Machregsaux.mli b/arm/Machregsaux.mli index d7117c21..01b0f9fd 100644 --- a/arm/Machregsaux.mli +++ b/arm/Machregsaux.mli @@ -12,9 +12,6 @@ (** Auxiliary functions on machine registers *) -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool val class_of_type: AST.typ -> int @@ -751,6 +751,20 @@ Proof. auto. Qed. +Lemma op_valid_pointer_eq: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op eqn:OP; simpl; try congruence. + - intros MEM; destruct c; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intro MEM; destruct c; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. +Qed. + (** Global variables mentioned in an operation or addressing mode *) Definition globals_operation (op: operation) : list ident := diff --git a/arm/PrepassSchedulingOracle.ml b/arm/PrepassSchedulingOracle.ml new file mode 120000 index 00000000..9885fd52 --- /dev/null +++ b/arm/PrepassSchedulingOracle.ml @@ -0,0 +1 @@ +../x86/PrepassSchedulingOracle.ml
\ No newline at end of file diff --git a/backend/CSE3.v b/backend/CSE3.v index df1c2bfc..13d07e65 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -58,7 +58,8 @@ Definition transf_instr (fmap : PMap.t RB.t) match instr with | Iop op args dst s => let args' := subst_args fmap pc args in - match (if is_trivial_op op then None else find_op_in_fmap fmap pc op args') with + match (if (negb (Compopts.optim_CSE3_trivial_ops tt)) && (is_trivial_op op) + then None else find_op_in_fmap fmap pc op args') with | None => Iop op args' dst s | Some src => Iop Omove (src::nil) dst s end diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 5ed04bc4..8b7f1190 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -181,12 +181,24 @@ Definition eq_depends_on_mem eq := | SOp op => op_depends_on_memory op end. +Definition eq_depends_on_store eq := + match eq_op eq with + | SLoad _ _ => true + | SOp op => false + end. + Definition get_mem_kills (eqs : PTree.t equation) : PSet.t := PTree.fold (fun already (eqno : eq_id) (eq : equation) => if eq_depends_on_mem eq then PSet.add eqno already else already) eqs PSet.empty. +Definition get_store_kills (eqs : PTree.t equation) : PSet.t := + PTree.fold (fun already (eqno : eq_id) (eq : equation) => + if eq_depends_on_store eq + then PSet.add eqno already + else already) eqs PSet.empty. + Definition is_move (op : operation) : { op = Omove } + { op <> Omove }. Proof. @@ -216,6 +228,7 @@ Record eq_context := mkeqcontext eq_rhs_oracle : node -> sym_op -> list reg -> PSet.t; eq_kill_reg : reg -> PSet.t; eq_kill_mem : unit -> PSet.t; + eq_kill_store : unit -> PSet.t; eq_moves : reg -> PSet.t }. Section OPERATIONS. @@ -342,6 +355,9 @@ Section OPERATIONS. (oper1 dst op args' rel) end. + Definition kill_store (rel : RELATION.t) : RELATION.t := + PSet.subtract rel (eq_kill_store ctx tt). + Definition clever_kill_store (chunk : memory_chunk) (addr: addressing) (args : list reg) (src : reg) @@ -358,7 +374,7 @@ Section OPERATIONS. may_overlap chunk addr args chunk' addr' (eq_args eq) end end) - (PSet.inter rel (eq_kill_mem ctx tt))). + (PSet.inter rel (eq_kill_store ctx tt))). Definition store2 (chunk : memory_chunk) (addr: addressing) (args : list reg) @@ -366,7 +382,7 @@ Section OPERATIONS. (rel : RELATION.t) : RELATION.t := if Compopts.optim_CSE3_alias_analysis tt then clever_kill_store chunk addr args src rel - else kill_mem rel. + else kill_store rel. Definition store1 (chunk : memory_chunk) (addr: addressing) (args : list reg) @@ -501,6 +517,7 @@ Definition context_from_hints (hints : analysis_hints) := let eqs := hint_eq_catalog hints in let reg_kills := get_reg_kills eqs in let mem_kills := get_mem_kills eqs in + let store_kills := get_store_kills eqs in let moves := get_moves eqs in {| eq_catalog := fun eq_id => PTree.get eq_id eqs; @@ -508,5 +525,6 @@ Definition context_from_hints (hints : analysis_hints) := eq_rhs_oracle := hint_eq_rhs_oracle hints; eq_kill_reg := fun reg => PMap.get reg reg_kills; eq_kill_mem := fun _ => mem_kills; + eq_kill_store := fun _ => store_kills; eq_moves := fun reg => PMap.get reg moves |}. diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index e37ef61f..e038331c 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -174,6 +174,7 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = and rhs_table = Hashtbl.create 100 and cur_kill_reg = ref (PMap.init PSet.empty) and cur_kill_mem = ref PSet.empty + and cur_kill_store = ref PSet.empty and cur_moves = ref (PMap.init PSet.empty) in let eq_find_oracle node eq = assert (not (is_trivial eq)); @@ -216,6 +217,8 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = (eq.eq_lhs :: eq.eq_args); (if eq_depends_on_mem eq then cur_kill_mem := PSet.add coq_id !cur_kill_mem); + (if eq_depends_on_store eq + then cur_kill_store := PSet.add coq_id !cur_kill_store); (match eq.eq_op, eq.eq_args with | (SOp Op.Omove), [rhs] -> imp_add_i_j cur_moves eq.eq_lhs coq_id | _, _ -> ()); @@ -232,6 +235,7 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = eq_rhs_oracle = rhs_find_oracle ; eq_kill_reg = (fun reg -> PMap.get reg !cur_kill_reg); eq_kill_mem = (fun () -> !cur_kill_mem); + eq_kill_store = (fun () -> !cur_kill_store); eq_moves = (fun reg -> PMap.get reg !cur_moves) } in match internal_analysis ctx tenv f diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 1e5b88c3..b298ea65 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -133,13 +133,18 @@ Definition xlget_kills (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : add_i_j (eq_lhs (snd item)) (fst item) (add_ilist_j (eq_args (snd item)) (fst item) already)) eqs m. - Definition xlget_mem_kills (eqs : list (positive * equation)) (m : PSet.t) : PSet.t := (fold_left (fun (a : PSet.t) (p : positive * equation) => if eq_depends_on_mem (snd p) then PSet.add (fst p) a else a) eqs m). +Definition xlget_store_kills (eqs : list (positive * equation)) (m : PSet.t) : PSet.t := +(fold_left + (fun (a : PSet.t) (p : positive * equation) => + if eq_depends_on_store (snd p) then PSet.add (fst p) a else a) + eqs m). + Lemma xlget_kills_monotone : forall eqs m i j, PSet.contains (Regmap.get i m) j = true -> @@ -170,6 +175,24 @@ Qed. Hint Resolve xlget_mem_kills_monotone : cse3. +Lemma xlget_store_kills_monotone : + forall eqs m j, + PSet.contains m j = true -> + PSet.contains (xlget_store_kills eqs m) j = true. +Proof. + induction eqs; simpl; trivial. + intros. + destruct eq_depends_on_store. + - apply IHeqs. + destruct (peq (fst a) j). + + subst j. apply PSet.gadds. + + rewrite PSet.gaddo by congruence. + trivial. + - auto. +Qed. + +Hint Resolve xlget_store_kills_monotone : cse3. + Lemma xlget_kills_has_lhs : forall eqs m lhs sop args j, In (j, {| eq_lhs := lhs; @@ -333,6 +356,60 @@ Qed. Hint Resolve context_from_hints_get_kills_has_eq_depends_on_mem : cse3. +Lemma xlget_kills_has_eq_depends_on_store : + forall eqs eq j m, + In (j, eq) eqs -> + eq_depends_on_store eq = true -> + PSet.contains (xlget_store_kills eqs m) j = true. +Proof. + induction eqs; simpl. + contradiction. + intros. + destruct H. + { subst a. + simpl. + rewrite H0. + apply xlget_store_kills_monotone. + apply PSet.gadds. + } + eauto. +Qed. + +Hint Resolve xlget_kills_has_eq_depends_on_store : cse3. + +Lemma get_kills_has_eq_depends_on_store : + forall eqs eq j, + PTree.get j eqs = Some eq -> + eq_depends_on_store eq = true -> + PSet.contains (get_store_kills eqs) j = true. +Proof. + intros. + unfold get_store_kills. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : PSet.t) (p : positive * equation) => + if eq_depends_on_store (snd p) then PSet.add (fst p) a else a) + (PTree.elements eqs) PSet.empty) + with (xlget_store_kills (PTree.elements eqs) PSet.empty). + eapply xlget_kills_has_eq_depends_on_store. + apply PTree.elements_correct. + eassumption. + trivial. +Qed. + +Lemma context_from_hints_get_kills_has_eq_depends_on_store : + forall hints eq j, + PTree.get j (hint_eq_catalog hints) = Some eq -> + eq_depends_on_store eq = true -> + PSet.contains (eq_kill_store (context_from_hints hints) tt) j = true. +Proof. + intros. + simpl. + eapply get_kills_has_eq_depends_on_store; eassumption. +Qed. + +Hint Resolve context_from_hints_get_kills_has_eq_depends_on_store : cse3. + Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). @@ -418,6 +495,12 @@ Section SOUNDNESS. eq_depends_on_mem eq = true -> PSet.contains (eq_kill_mem ctx tt) j = true. + Hypothesis ctx_kill_store_has_depends_on_store : + forall eq j, + eq_catalog ctx j = Some eq -> + eq_depends_on_store eq = true -> + PSet.contains (eq_kill_store ctx tt) j = true. + Theorem kill_reg_sound : forall rel rs m dst v, (sem_rel rel rs m) -> @@ -574,6 +657,55 @@ Section SOUNDNESS. Hint Resolve kill_mem_sound : cse3. + (* TODO: shouldn't this already be proved somewhere else? *) + Lemma store_preserves_validity: + forall m m' wchunk a v + (STORE : Mem.storev wchunk m a v = Some m') + (b : block) (z : Z), + Mem.valid_pointer m' b z = Mem.valid_pointer m b z. + Proof. + unfold Mem.storev. + intros. + destruct a; try discriminate. + Local Transparent Mem.store. + unfold Mem.store in STORE. + destruct Mem.valid_access_dec in STORE. + 2: discriminate. + inv STORE. + reflexivity. + Qed. + + Hint Resolve store_preserves_validity : cse3. + + Theorem kill_store_sound : + forall rel rs m m' wchunk a v, + (sem_rel rel rs m) -> + (Mem.storev wchunk m a v = Some m') -> + (sem_rel (kill_store (ctx:=ctx) rel) rs m'). + Proof. + unfold sem_rel, sem_eq, sem_rhs, kill_store. + intros until v. + intros REL STORE i eq. + specialize REL with (i := i) (eq0 := eq). + intros SUBTRACT CATALOG. + rewrite PSet.gsubtract in SUBTRACT. + rewrite andb_true_iff in SUBTRACT. + intuition. + destruct (eq_op eq) as [op | chunk addr] eqn:OP. + - rewrite op_valid_pointer_eq with (m2 := m). + assumption. + eapply store_preserves_validity; eauto. + - specialize ctx_kill_store_has_depends_on_store with (eq0 := eq) (j := i). + destruct eq as [lhs op args]; simpl in *. + rewrite OP in ctx_kill_store_has_depends_on_store. + rewrite negb_true_iff in H0. + rewrite OP in CATALOG. + intuition. + congruence. + Qed. + + Hint Resolve kill_store_sound : cse3. + Theorem eq_find_sound: forall no eq id, eq_find (ctx := ctx) no eq = Some id -> @@ -895,13 +1027,12 @@ Section SOUNDNESS. unfold sem_eq in *. simpl in *. destruct eq_op as [op' | chunk' addr']; simpl. - - destruct (op_depends_on_memory op') eqn:DEPENDS. - + erewrite ctx_kill_mem_has_depends_on_mem in CONTAINS by eauto. - discriminate. - + rewrite op_depends_on_memory_correct with (m2:=m); trivial. + - rewrite op_valid_pointer_eq with (m2 := m). + + cbn in *. apply REL; auto. + + eapply store_preserves_validity; eauto. - simpl in REL. - erewrite ctx_kill_mem_has_depends_on_mem in CONTAINS by eauto. + erewrite ctx_kill_store_has_depends_on_store in CONTAINS by eauto. simpl in CONTAINS. rewrite negb_true_iff in CONTAINS. destruct (eval_addressing genv sp addr' rs ## eq_args) as [a'|] eqn:ADDR'. diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 3fbc9912..2257b4de 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -463,12 +463,12 @@ Proof. destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SOp op) (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. - * destruct (if is_trivial_op op + * destruct (if (negb (Compopts.optim_CSE3_trivial_ops tt)) && (is_trivial_op op) then None else rhs_find pc (SOp op) (subst_args (fst (preanalysis tenv f)) pc args) t) eqn:FIND. - ** destruct (is_trivial_op op). discriminate. + ** destruct ((negb (Compopts.optim_CSE3_trivial_ops tt)) && (is_trivial_op op)). discriminate. apply exec_Iop with (op := Omove) (args := r :: nil). TR_AT. subst instr'. diff --git a/backend/Debugvar.v b/backend/Debugvar.v index 56908855..7806984a 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -92,7 +92,7 @@ Fixpoint remove_state (v: ident) (s: avail) : avail := end end. -Fixpoint set_debug_info (v: ident) (info: list (builtin_arg loc)) (s: avail) := +Definition set_debug_info (v: ident) (info: list (builtin_arg loc)) (s: avail) := match normalize_debug info with | Some a => set_state v a s | None => remove_state v s diff --git a/backend/Duplicate.v b/backend/Duplicate.v index 7dea752b..3fd86728 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -86,7 +86,7 @@ Global Opaque builtin_res_eq_pos. Definition verify_match_inst dupmap inst tinst := match inst with - | Inop n => match tinst with Inop n' => do u <- verify_is_copy dupmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end + | Inop n => match tinst with Inop n' => verify_is_copy dupmap n n' | _ => Error(msg "verify_match_inst Inop") end | Iop op lr r n => match tinst with Iop op' lr' r' n' => @@ -167,10 +167,10 @@ Definition verify_match_inst dupmap inst tinst := if (list_eq_dec Pos.eq_dec lr lr') then if (eq_condition cond cond') then do u1 <- verify_is_copy dupmap n1 n1'; - do u2 <- verify_is_copy dupmap n2 n2'; OK tt + verify_is_copy dupmap n2 n2' else if (eq_condition (negate_condition cond) cond') then do u1 <- verify_is_copy dupmap n1 n2'; - do u2 <- verify_is_copy dupmap n2 n1'; OK tt + verify_is_copy dupmap n2 n1' else Error (msg "Incompatible conditions in Icond") else Error (msg "Different lr in Icond") | _ => Error (msg "verify_match_inst Icond") end @@ -203,8 +203,7 @@ Fixpoint verify_mapping_mn_rec dupmap f f' lm := match lm with | nil => OK tt | m :: lm => do u <- verify_mapping_mn dupmap f f' m; - do u2 <- verify_mapping_mn_rec dupmap f f' lm; - OK tt + verify_mapping_mn_rec dupmap f f' lm end. Definition verify_mapping_match_nodes dupmap (f f': function): res unit := @@ -213,7 +212,7 @@ Definition verify_mapping_match_nodes dupmap (f f': function): res unit := (** Verifies that the [dupmap] of the translated function [f'] is giving correct information in regards to [f] *) Definition verify_mapping dupmap (f f': function) : res unit := do u <- verify_mapping_entrypoint dupmap f f'; - do v <- verify_mapping_match_nodes dupmap f f'; OK tt. + verify_mapping_match_nodes dupmap f f'. (** * Entry points *) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 76b5616b..b3635527 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -22,9 +22,8 @@ open RTL open Maps open Camlcoq +open DebugPrint -let debug_flag = LICMaux.debug_flag -let debug = LICMaux.debug let get_loop_headers = LICMaux.get_loop_headers let get_some = LICMaux.get_some let rtl_successors = LICMaux.rtl_successors @@ -87,8 +86,6 @@ end module PSet = Set.Make(PInt) -let print_intlist = LICMaux.print_intlist - let print_intset s = let seq = PSet.to_seq s in begin @@ -101,30 +98,20 @@ let print_intset s = end end -let ptree_printbool pt = - let elements = PTree.elements pt - in begin - if !debug_flag then begin - Printf.printf "["; - List.iter (fun (n, b) -> - if b then Printf.printf "%d, " (P.to_int n) else () - ) elements; - Printf.printf "]" - end - end - (* Looks ahead (until a branch) to see if a node further down verifies * the given predicate *) -let rec look_ahead code node is_loop_header predicate = +let rec look_ahead_gen (successors: RTL.instruction -> P.t list) code node is_loop_header predicate = if (predicate node) then true - else match (rtl_successors @@ get_some @@ PTree.get node code) with + else match (successors @@ get_some @@ PTree.get node code) with | [n] -> if (predicate n) then true else ( if (get_some @@ PTree.get n is_loop_header) then false - else look_ahead code n is_loop_header predicate + else look_ahead_gen successors code n is_loop_header predicate ) | _ -> false +let look_ahead = look_ahead_gen rtl_successors + (** * Heuristics mostly based on the paper Branch Prediction for Free *) @@ -183,7 +170,7 @@ let do_loop_heuristic code cond ifso ifnot is_loop_header = let predicate n = get_some @@ PTree.get n is_loop_header in let ifso_loop = look_ahead code ifso is_loop_header predicate in let ifnot_loop = look_ahead code ifnot is_loop_header predicate in - if ifso_loop && ifnot_loop then None (* TODO - take the innermost loop ? *) + if ifso_loop && ifnot_loop then (debug "\t\tLOOP but can't choose which\n"; None) (* TODO - take the innermost loop ? *) else if ifso_loop then Some true else if ifnot_loop then Some false else None @@ -197,23 +184,155 @@ let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header = | Some b -> Some b end +(** Innermost loop detection *) + +type innerLoop = { + preds: P.t list; + body: P.t list; + head: P.t; (* head of the loop *) + finals: P.t list; (* the final instructions, which loops back to the head *) + (* There may be more than one ; for instance if there is an if inside the loop with both + * branches leading to a goto backedge + * Such cases usually happen after a tail-duplication *) + sb_final: P.t option; (* if the innerloop wraps a superblock, this is its final instruction *) + (* may be None if we predict that we do not loop *) +} + +let print_pset = LICMaux.pp_pset + +let rtl_successors_pref = function +| Itailcall _ | Ireturn _ -> [] +| Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n) +| Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n] +| Icond (_,_,n1,n2,p) -> (match p with + | Some true -> [n1] + | Some false -> [n2] + | None -> [n1; n2]) +| Ijumptable (_,ln) -> ln + +(* Find the last node of a trace (starting at "node"), until a loop is encountered. + * If a non-predicted branch is encountered, returns None *) +let rec find_last_node_before_loop code node trace is_loop_header = + let rtl_succ = rtl_successors @@ get_some @@ PTree.get node code in + let headers = List.filter (fun n -> + get_some @@ PTree.get n is_loop_header && HashedSet.PSet.contains trace n) rtl_succ in + match headers with + | [] -> ( + let next_nodes = rtl_successors_pref @@ get_some @@ PTree.get node code in + match next_nodes with + | [n] -> ( + (* To prevent getting out of the superblock and loop infinitely when the prediction is false *) + if HashedSet.PSet.contains trace n then + find_last_node_before_loop code n trace is_loop_header + else None + ) + | _ -> None (* May happen when we predict that a loop is not taken *) + ) + | [h] -> Some node + | _ -> failwith "Multiple branches leading to a loop" + +(* The computation of sb_final requires to already have branch prediction *) +let get_inner_loops f code is_loop_header = + let fake_f = { fn_sig = f.fn_sig; fn_params = f.fn_params; + fn_stacksize = f.fn_stacksize; fn_code = code; fn_entrypoint = f.fn_entrypoint } in + let (_, predmap, loopmap) = LICMaux.inner_loops fake_f in + begin + debug "PREDMAP: "; print_ptree print_intlist predmap; + debug "LOOPMAP: "; print_ptree print_pset loopmap; + List.map (fun (n, body) -> + let preds = List.filter (fun p -> not @@ HashedSet.PSet.contains body p) + @@ get_some @@ PTree.get n predmap in + let head = (* the instruction from body which is a loop header *) + let heads = HashedSet.PSet.elements @@ HashedSet.PSet.filter + (fun n -> ptree_get_some n is_loop_header) body in + begin + assert (List.length heads == 1); + List.hd heads + end in + let finals = (* the predecessors from head that are in the body *) + let head_preds = ptree_get_some head predmap in + let filtered = List.filter (fun n -> HashedSet.PSet.contains body n) head_preds in + begin + debug "HEAD: %d\n" (P.to_int head); + debug "BODY: %a\n" print_pset body; + debug "HEADPREDS: %a\n" print_intlist head_preds; + filtered + end in + let sb_final = find_last_node_before_loop code head body is_loop_header in + let body = HashedSet.PSet.elements body in + { preds = preds; body = body; head = head; finals = finals; + sb_final = sb_final; } + ) + (* LICMaux.inner_loops also returns non-inner loops, but with a body of 1 instruction + * We remove those to get just the inner loops *) + @@ List.filter (fun (n, body) -> + let count = List.length @@ HashedSet.PSet.elements body in count != 1 + ) (PTree.elements loopmap) + end + + (* Returns a PTree of either None or Some b where b determines the node following the loop, for a cb instruction *) (* It uses the fact that loops in CompCert are done by a branch (backedge) instruction followed by a cb *) -let get_loop_info is_loop_header bfs_order code = +let get_loop_info f is_loop_header bfs_order code = + debug "GET LOOP INFO\n"; + debug "==================================\n"; let loop_info = ref (PTree.map (fun n i -> None) code) in - let mark_path s n = + let mark_path n lbody = + let cb_info = ref PTree.empty in let visited = ref (PTree.map (fun n i -> false) code) in - let rec explore src dest = - if (get_some @@ PTree.get src !visited) then false - else if src == dest then true - else begin - visited := PTree.set src true !visited; - match rtl_successors @@ get_some @@ PTree.get src code with - | [] -> false - | [s] -> explore s dest - | [s1; s2] -> (explore s1 dest) || (explore s2 dest) - | _ -> false - end + (* Returns true if there is a path from src to dest (not involving jumptables) *) + (* Mark nodes as visited along the way *) + let explore src dest = + debug "Trying to dive a path from %d to %d\n" (P.to_int src) (P.to_int dest); + (* Memoizing the results to avoid exponential blow-up *) + let memory = ref PTree.empty in + let rec explore_rec src = + debug "explore_rec %d vs %d... " (P.to_int src) (P.to_int dest); + if (P.to_int src) == (P.to_int dest) then (debug "FOUND\n"; true) + else if (get_some @@ PTree.get src !visited) then (debug "VISITED... :( \n"; false) + (* if we went out of the innermost loop *) + else if (not @@ List.mem src lbody) then (debug "Out of innermost...\n"; false) + else begin + let inst = get_some @@ PTree.get src code in + visited := PTree.set src true !visited; + match rtl_successors inst with + | [] -> false + | [s] -> explore_wrap s + | [s1; s2] -> let snapshot_visited = ref !visited in begin + debug "\t\tSplit at %d: either %d or %d\n" (P.to_int src) (P.to_int s1) (P.to_int s2); + (* Remembering that we tried the ifso node *) + cb_info := PTree.set src true !cb_info; + match explore_wrap s1 with + | true -> ( + visited := !snapshot_visited; + match explore_wrap s2 with + | true -> begin + (* Both paths lead to a loop: we cannot predict the CB + * (but the explore still succeeds) *) + cb_info := PTree.remove src !cb_info; + true + end + | false -> true (* nothing to do, the explore succeeded *) + ) + | false -> begin + cb_info := PTree.set src false !cb_info; + match explore_wrap s2 with + | true -> true + | false -> (cb_info := PTree.remove src !cb_info; false) + end + end + | _ -> false + end + and explore_wrap src = begin + match PTree.get src !memory with + | Some b -> b + | None -> + let result = explore_rec src in + (memory := PTree.set src result !memory; result) + end in explore_wrap src + (* Goes forward until a CB is encountered + * Returns None if no CB was found, or Some the_cb_node + * Marks nodes as visited along the way *) in let rec advance_to_cb src = if (get_some @@ PTree.get src !visited) then None else begin @@ -225,44 +344,53 @@ let get_loop_info is_loop_header bfs_order code = | Ijumptable _ | Itailcall _ | Ireturn _ -> None end in begin - debug "Marking path from %d to %d\n" (P.to_int n) (P.to_int s); - match advance_to_cb s with - | None -> (debug "Nothing found\n") - | Some s -> ( debug "Advancing to %d\n" (P.to_int s); + debug "Attempting to find natural loop from HEAD %d..\n" (P.to_int n); + match advance_to_cb n with + | None -> (debug "\tNo CB found\n") + | Some s -> ( debug "\tFound a CB! %d\n" (P.to_int s); match get_some @@ PTree.get s !loop_info with | None | Some _ -> begin match get_some @@ PTree.get s code with - | Icond (_, _, n1, n2, _) -> + | Icond (_, _, n1, n2, _) -> ( let b1 = explore n1 n in let b2 = explore n2 n in - if (b1 && b2) then (debug "both true\n") - else if b1 then (debug "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info) - else if b2 then (debug "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info) - else (debug "none true\n") - | _ -> ( debug "not an icond\n" ) + if (b1 && b2) then + debug "\tBoth paths lead back to the head: NONE\n" + else if (b1 || b2) then begin + if b1 then begin + debug "\tTrue path leads to the head: TRUE\n"; + loop_info := PTree.set s (Some true) !loop_info; + end else if b2 then begin + debug "\tFalse path leads to the head: FALSE\n"; + loop_info := PTree.set s (Some false) !loop_info + end; + debug "\tSetting other CBs encountered..\n"; + List.iter (fun (cb, dir) -> + debug "\t\t%d is %B\n" (P.to_int cb) dir; + loop_info := PTree.set cb (Some dir) !loop_info + ) (PTree.elements !cb_info) + end else + debug "\tNo path leads back to the head: NONE\n" + ) + | _ -> failwith "\tNot an Icond\n" end (* | Some _ -> ( debug "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *) ) end - in begin - List.iter (fun n -> - match get_some @@ PTree.get n code with - | Inop s | Iop (_,_,_,s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s) - | Ibuiltin (_, _, _, s) -> - if get_some @@ PTree.get s is_loop_header then mark_path s n - | Icond _ -> () (* loop backedges are never Icond in CompCert RTL.3 *) - | Ijumptable _ -> () - | Itailcall _ | Ireturn _ -> () - ) bfs_order; + in let iloops = get_inner_loops f code is_loop_header in + begin + List.iter (fun il -> mark_path il.head il.body) iloops; + (* List.iter mark_path @@ List.filter (fun n -> get_some @@ PTree.get n is_loop_header) bfs_order; *) + debug "==================================\n"; !loop_info end (* Remark - compared to the original Branch Prediction for Free paper, we don't use the store heuristic *) -let get_directions code entrypoint = begin +let get_directions f code entrypoint = begin debug "get_directions\n"; let bfs_order = bfs code entrypoint in let is_loop_header = get_loop_headers code entrypoint in - let loop_info = get_loop_info is_loop_header bfs_order code in + let loop_info = get_loop_info f is_loop_header bfs_order code in let directions = ref (PTree.map (fun n i -> None) code) in (* None <=> no predicted direction *) begin (* ptree_printbool is_loop_header; *) @@ -305,21 +433,21 @@ let update_direction direction = function | Some _ -> Icond (cond, lr, n, n', pred) ) | i -> i -let rec update_direction_rec directions = function -| [] -> PTree.empty -| m::lm -> let (n, i) = m - in let direction = get_some @@ PTree.get n directions - in PTree.set n (update_direction direction i) (update_direction_rec directions lm) - (* Uses branch prediction to write prediction annotations in Icond *) -let update_directions code entrypoint = begin +let update_directions f code entrypoint = begin debug "Update_directions\n"; - let directions = get_directions code entrypoint - in begin + let directions = get_directions f code entrypoint in + let code' = ref code in + begin + debug "Get Directions done, now proceeding to update all direction information..\n"; (* debug "Ifso directions: "; ptree_printbool directions; debug "\n"; *) - update_direction_rec directions (PTree.elements code) + List.iter (fun (n, i) -> + let direction = get_some @@ PTree.get n directions in + code' := PTree.set n (update_direction direction i) !code' + ) (PTree.elements code); + !code' end end @@ -401,8 +529,6 @@ let print_traces oc traces = Printf.fprintf oc "Traces: {%a}\n" f traces end -let print_code code = LICMaux.print_code code - (* Dumb (but linear) trace selection *) let select_traces_linear code entrypoint = let is_visited = ref (PTree.map (fun n i -> false) code) in @@ -545,7 +671,8 @@ let is_a_nop code n = * preds: mapping node -> predecessors * ptree: the revmap * trace: the trace to follow tail duplication on *) -let tail_duplicate code preds ptree trace = +let tail_duplicate code preds is_loop_header ptree trace = + debug "Tail_duplicate on that trace: %a\n" print_trace trace; (* next_int: unused integer that can be used for the next duplication *) let next_int = ref (next_free_pc code) (* last_node and last_duplicate store resp. the last processed node of the trace, and its duplication *) @@ -560,7 +687,12 @@ let tail_duplicate code preds ptree trace = if is_first then (code, ptree) (* first node is never duplicated regardless of its inputs *) else let node_preds = ptree_get_some n preds - in let node_preds_nolast = List.filter (fun e -> e <> get_some !last_node) node_preds + in let node_preds_nolast = + (* We traverse loop headers without initiating tail duplication + * (see case of two imbricated loops) *) + if (get_some @@ PTree.get n is_loop_header) then [] + else List.filter (fun e -> e <> get_some !last_node) node_preds + (* in let node_preds_nolast = List.filter (fun e -> not @@ List.mem e t) node_preds_nolast *) in let final_node_preds = match !last_duplicate with | None -> node_preds_nolast | Some n' -> n' :: node_preds_nolast @@ -581,12 +713,12 @@ let tail_duplicate code preds ptree trace = in let new_code, new_ptree = f code ptree true trace in (new_code, new_ptree, !nb_duplicated) -let superblockify_traces code preds traces ptree = +let superblockify_traces code preds is_loop_header traces ptree = let max_nb_duplicated = !Clflags.option_ftailduplicate (* FIXME - should be architecture dependent *) in let rec f code ptree = function | [] -> (code, ptree, 0) | trace :: traces -> - let new_code, new_ptree, nb_duplicated = tail_duplicate code preds ptree trace + let new_code, new_ptree, nb_duplicated = tail_duplicate code preds is_loop_header ptree trace in if (nb_duplicated < max_nb_duplicated) then (debug "End duplication\n"; f new_code new_ptree traces) else (debug "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0)) @@ -611,19 +743,13 @@ let invert_iconds code = * cyclic dependencies between LICMaux and Duplicateaux *) -type innerLoop = { - preds: P.t list; - body: P.t list; - head: P.t; (* head of the loop *) - finals: P.t list (* the final instructions, which loops back to the head *) - (* There may be more than one ; for instance if there is an if inside the loop with both - * branches leading to a goto backedge *) -} - -let print_pset = LICMaux.pp_pset - let print_inner_loop iloop = - debug "{preds: %a, body: %a}" print_intlist iloop.preds print_intlist iloop.body + debug "{preds: %a, body: %a, head: %d, finals: %a, sb_final: %a}\n" + print_intlist iloop.preds + print_intlist iloop.body + (P.to_int iloop.head) + print_intlist iloop.finals + print_option_pint iloop.sb_final let rec print_inner_loops = function | [] -> () @@ -633,18 +759,6 @@ let rec print_inner_loops = function print_inner_loops iloops end -let print_ptree printer pt = - let elements = PTree.elements pt in - begin - debug "[\n"; - List.iter (fun (n, elt) -> - debug "\t%d: %a\n" (P.to_int n) printer elt - ) elements; - debug "]\n" - end - -let print_pint oc i = if !debug_flag then Printf.fprintf oc "%d" (P.to_int i) else () - let cb_exit_node = function | Icond (_,_,n1,n2,p) -> begin match p with | Some true -> Some n2 @@ -692,41 +806,6 @@ let get_inner_loops f code is_loop_header = !iloops *) -let get_inner_loops f code is_loop_header = - let fake_f = { fn_sig = f.fn_sig; fn_params = f.fn_params; - fn_stacksize = f.fn_stacksize; fn_code = code; fn_entrypoint = f.fn_entrypoint } in - let (_, predmap, loopmap) = LICMaux.inner_loops fake_f in - begin - debug "PREDMAP: "; print_ptree print_intlist predmap; - debug "LOOPMAP: "; print_ptree print_pset loopmap; - List.map (fun (n, body) -> - let preds = List.filter (fun p -> not @@ HashedSet.PSet.contains body p) - @@ get_some @@ PTree.get n predmap in - let head = (* the instruction from body which is a loop header *) - let heads = HashedSet.PSet.elements @@ HashedSet.PSet.filter - (fun n -> ptree_get_some n is_loop_header) body in - begin - assert (List.length heads == 1); - List.hd heads - end in - let finals = (* the predecessors from head that are in the body *) - let head_preds = ptree_get_some head predmap in - let filtered = List.filter (fun n -> HashedSet.PSet.contains body n) head_preds in - begin - debug "HEAD: %d\n" (P.to_int head); - debug "BODY: %a\n" print_pset body; - debug "HEADPREDS: %a\n" print_intlist head_preds; - filtered - end in - { preds = preds; body = (HashedSet.PSet.elements body); head = head; finals = finals } - ) - (* LICMaux.inner_loops also returns non-inner loops, but with a body of 1 instruction - * We remove those to get just the inner loops *) - @@ List.filter (fun (n, body) -> - let count = List.length @@ HashedSet.PSet.elements body in count != 1 - ) (PTree.elements loopmap) - end - let rec generate_fwmap ln ln' fwmap = match ln with | [] -> begin @@ -836,31 +915,50 @@ let unroll_inner_loops_single f code revmap = (!code', !revmap') end +let is_some o = match o with Some _ -> true | None -> false + +let rec go_through_predicted code start final = + if start == final then + Some [start] + else + match rtl_successors_pref @@ get_some @@ PTree.get start code with + | [n] -> ( + match go_through_predicted code n final with + | Some ln -> Some (start :: ln) + | None -> None + ) + | _ -> None + (* Unrolls the body of the inner loop once - duplicating the exit condition as well * 1) Clones body into body' - * 2) Links the last instruction of body into the first of body' + * 2) Links the last instruction of body (sb_final) into the first of body' * 3) Links the last instruction of body' into the first of body *) let unroll_inner_loop_body code revmap iloop = + debug "iloop = "; print_inner_loop iloop; let body = iloop.body in let limit = !Clflags.option_funrollbody in if count_ignore_nops code body > limit then begin - debug "Too many nodes in the loop body (%d > %d)" (List.length body) limit; + debug "Too many nodes in the loop body (%d > %d)\n" (List.length body) limit; + (code, revmap) + end else if not @@ is_some iloop.sb_final then begin + debug "The loop body does not form a superblock OR we have predicted that we do not loop\n"; (code, revmap) end else - let (code2, revmap2, dupbody, fwmap) = clone code revmap body in + let sb_final = get_some @@ iloop.sb_final in + let sb_body = get_some @@ go_through_predicted code iloop.head sb_final in + let (code2, revmap2, dupbody, fwmap) = clone code revmap sb_body in let code' = ref code2 in let head' = apply_map fwmap (iloop.head) in - let finals' = apply_map_list fwmap (iloop.finals) in + let sb_final' = apply_map fwmap sb_final in begin - code' := change_pointers !code' iloop.head head' iloop.finals; - code' := change_pointers !code' head' iloop.head finals'; + code' := change_pointers !code' iloop.head head' [sb_final]; + code' := change_pointers !code' head' iloop.head [sb_final']; (!code', revmap2) end let unroll_inner_loops_body f code revmap = let is_loop_header = get_loop_headers code (f.fn_entrypoint) in - (* debug_flag := true; *) let inner_loops = get_inner_loops f code is_loop_header in debug "Number of loops found: %d\n" (List.length inner_loops); let code' = ref code in @@ -870,7 +968,7 @@ let unroll_inner_loops_body f code revmap = List.iter (fun iloop -> let (new_code, new_revmap) = unroll_inner_loop_body !code' !revmap' iloop in code' := new_code; revmap' := new_revmap - ) inner_loops; (* debug_flag := false; *) + ) inner_loops; (!code', !revmap') end @@ -930,7 +1028,7 @@ let static_predict f = let revmap = make_identity_ptree code in let code = if !Clflags.option_fpredict then - update_directions code entrypoint + update_directions f code entrypoint else code in let code = if !Clflags.option_fpredict then @@ -966,6 +1064,7 @@ let tail_duplicate f = if !Clflags.option_ftailduplicate > 0 then let traces = select_traces code entrypoint in let preds = get_predecessors_rtl code in - superblockify_traces code preds traces revmap + let is_loop_header = get_loop_headers code entrypoint in + superblockify_traces code preds is_loop_header traces revmap else (code, revmap) in ((code, entrypoint), revmap) diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 2480ccf0..2f3bad2f 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -111,7 +111,7 @@ Proof. - monadInv H0. inversion H. - inversion H. + subst. monadInv H0. destruct x. assumption. - + monadInv H0. destruct x0. eapply IHlb; assumption. + + monadInv H0. destruct x. eapply IHlb; assumption. Qed. Lemma verify_is_copy_correct: @@ -144,8 +144,8 @@ Proof. intros. unfold verify_match_inst in H. destruct i; try (inversion H; fail). (* Inop *) - - destruct i'; try (inversion H; fail). monadInv H. - destruct x. eapply verify_is_copy_correct in EQ. + - destruct i'; try (inversion H; fail). + eapply verify_is_copy_correct in H. constructor; eauto. (* Iop *) - destruct i'; try (inversion H; fail). monadInv H. @@ -197,12 +197,12 @@ Proof. destruct (list_eq_dec _ _ _); try discriminate. subst. destruct (eq_condition _ _); try discriminate. + monadInv H. destruct x. eapply verify_is_copy_correct in EQ. - destruct x0. eapply verify_is_copy_correct in EQ1. - constructor; assumption. + eapply verify_is_copy_correct in EQ0. + subst; constructor; assumption. + destruct (eq_condition _ _); try discriminate. monadInv H. destruct x. eapply verify_is_copy_correct in EQ. - destruct x0. eapply verify_is_copy_correct in EQ1. - constructor; assumption. + eapply verify_is_copy_correct in EQ0. + subst; constructor; assumption. (* Ijumptable *) - destruct i'; try (inversion H; fail). monadInv H. destruct x. eapply verify_is_copy_list_correct in EQ. @@ -257,7 +257,7 @@ Proof. exists mp; constructor 1; simpl; auto. + (* correct *) intros until n'. intros REVM i FNC. - unfold verify_mapping_match_nodes in EQ. simpl in EQ. destruct x1. + unfold verify_mapping_match_nodes in EQ1. simpl in EQ1. destruct x. eapply verify_mapping_mn_rec_correct; eauto. simpl; eauto. + (* entrypoint *) diff --git a/backend/IRC.ml b/backend/IRC.ml index 785b0a2d..29d224c8 100644 --- a/backend/IRC.ml +++ b/backend/IRC.ml @@ -102,7 +102,7 @@ after IRC elimination, when assigning a stack slot to a spilled variable. *) let name_of_loc = function | R r -> - begin match Machregsaux.name_of_register r with + begin match Machregsnames.name_of_register r with | None -> "fixed-reg" | Some s -> s end @@ -247,12 +247,10 @@ let class_of_loc = function let no_spill_class = 2 -let reserved_registers = ref ([]: mreg list) - let rec remove_reserved = function | [] -> [] | hd :: tl -> - if List.mem hd !reserved_registers + if List.mem hd !CPragmas.reserved_registers then remove_reserved tl else hd :: remove_reserved tl diff --git a/backend/IRC.mli b/backend/IRC.mli index f7bbf9c5..254f27ff 100644 --- a/backend/IRC.mli +++ b/backend/IRC.mli @@ -13,7 +13,6 @@ (* Iterated Register Coalescing: George and Appel's graph coloring algorithm *) open Registers -open Machregs open Locations open XTL @@ -39,8 +38,5 @@ val add_pref: graph -> var -> var -> unit (* Color the graph. Return an assignment of locations to variables. *) val coloring: graph -> (var -> loc) -(* Machine registers that are reserved and not available for allocation. *) -val reserved_registers: mreg list ref - (* Auxiliaries to deal with register classes *) val class_of_loc: loc -> int diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 6283e129..1f6b8817 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -16,16 +16,11 @@ open Maps;; open Kildall;; open HashedSet;; open Inject;; +open DebugPrint;; type reg = P.t;; (** get_loop_headers moved from Duplicateaux.ml to LICMaux.ml to prevent cycle dependencies *) -let debug_flag = ref false - -let debug fmt = - if !debug_flag then Printf.eprintf fmt - else Printf.ifprintf stderr fmt - type vstate = Unvisited | Processed | Visited let get_some = function @@ -39,42 +34,6 @@ let rtl_successors = function | Icond (_,_,n1,n2,_) -> [n1; n2] | Ijumptable (_,ln) -> ln -let print_ptree_bool oc pt = - if !debug_flag then - let elements = PTree.elements pt in - begin - Printf.fprintf oc "["; - List.iter (fun (n, b) -> - if b then Printf.fprintf oc "%d, " (P.to_int n) - ) elements; - Printf.fprintf oc "]\n" - end - else () - -let print_intlist oc l = - let rec f oc = function - | [] -> () - | n::ln -> (Printf.fprintf oc "%d %a" (P.to_int n) f ln) - in begin - if !debug_flag then begin - Printf.fprintf oc "[%a]" f l - end - end - -(* Adapted from backend/PrintRTL.ml: print_function *) -let print_code code = let open PrintRTL in let open Printf in - if (!debug_flag) then begin - fprintf stdout "{\n"; - let instrs = - List.sort - (fun (pc1, _) (pc2, _) -> compare pc2 pc1) - (List.rev_map - (fun (pc, i) -> (P.to_int pc, i)) - (PTree.elements code)) in - List.iter (print_instruction stdout) instrs; - fprintf stdout "}" - end - (** Getting loop branches with a DFS visit : * Each node is either Unvisited, Visited, or Processed * pre-order: node becomes Processed @@ -255,8 +214,8 @@ let rewrite_loop_body (last_alloc : reg ref) (List.map (map_reg mapper) args), new_res)); PTree.set res new_res mapper - | Iload(_, chunk, addr, args, res, pc') - | Istore(chunk, addr, args, res, pc') + | Iload(_, chunk, addr, args, v, pc') + | Istore(chunk, addr, args, v, pc') when Archi.has_notrap_loads && !Clflags.option_fnontrap_loads -> let new_res = P.succ !last_alloc in @@ -264,7 +223,7 @@ let rewrite_loop_body (last_alloc : reg ref) add_inj (INJload(chunk, addr, (List.map (map_reg mapper) args), new_res)); - PTree.set res new_res mapper + PTree.set v new_res mapper | _ -> mapper in List.iter (fun x -> if PSet.contains loop_body x diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 3fe61470..22658fb7 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -324,7 +324,6 @@ Local Opaque mreg_type. apply wt_setreg; auto; try (apply wt_undef_regs; auto). eapply Val.has_subtype; eauto. - change ty_res with (snd (ty_args, ty_res)). rewrite <- TYOP. eapply type_of_operation_sound; eauto. red; intros; subst op. simpl in ISMOVE. destruct args; try discriminate. destruct args; discriminate. diff --git a/backend/Machregsnames.ml b/backend/Machregsnames.ml new file mode 100644 index 00000000..fdcbd0e5 --- /dev/null +++ b/backend/Machregsnames.ml @@ -0,0 +1,24 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +let register_names : (Machregs.mreg, string) Hashtbl.t = Hashtbl.create 31 + +let _ = + List.iter + (fun (s, r) -> Hashtbl.add register_names r (Camlcoq.camlstring_of_coqstring s)) + Machregs.register_names + +let name_of_register r = + Hashtbl.find_opt register_names r + +let register_by_name s = + Machregs.register_by_name (Camlcoq.coqstring_uppercase_ascii_of_camlstring s) diff --git a/backend/Machregsnames.mli b/backend/Machregsnames.mli new file mode 100644 index 00000000..1b600d35 --- /dev/null +++ b/backend/Machregsnames.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +val name_of_register: Machregs.mreg -> string option +val register_by_name: string -> Machregs.mreg option diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v index 3c2d8e20..d9e9e025 100644 --- a/backend/NeedDomain.v +++ b/backend/NeedDomain.v @@ -47,7 +47,7 @@ Definition iagree (p q mask: int) : Prop := forall i, 0 <= i < Int.zwordsize -> Int.testbit mask i = true -> Int.testbit p i = Int.testbit q i. -Fixpoint vagree (v w: val) (x: nval) {struct x}: Prop := +Definition vagree (v w: val) (x: nval) : Prop := match x with | Nothing => True | I m => diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 7fa10aee..5cb693af 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -297,8 +297,8 @@ let print_inline_asm print_preg oc txt sg args res = let print_version_and_options oc comment = let version_string = - if Version.buildnr <> "" && Version.tag <> "" then - sprintf "Release: %s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + if Version.buildnr <> "" && Version.tag <> "" && Version.branch <> "" then + sprintf "Release: %s, Build: %s, Tag: %s, Branch: %s" Version.version Version.buildnr Version.tag Version.branch else Version.version in fprintf oc "%s File generated by CompCert %s\n" comment version_string; diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml index 8259297b..87e8a1fc 100644 --- a/backend/PrintLTL.ml +++ b/backend/PrintLTL.ml @@ -22,7 +22,7 @@ open PrintAST open PrintOp let mreg pp r = - match Machregsaux.name_of_register r with + match Machregsnames.name_of_register r with | Some s -> fprintf pp "%s" s | None -> fprintf pp "<unknown machreg>" diff --git a/backend/PrintMach.ml b/backend/PrintMach.ml index 70e65832..3481421b 100644 --- a/backend/PrintMach.ml +++ b/backend/PrintMach.ml @@ -16,12 +16,11 @@ open Printf open Camlcoq open Datatypes open AST -open Machregsaux open Mach open PrintAST let reg pp r = - match name_of_register r with + match Machregsnames.name_of_register r with | Some s -> fprintf pp "%s" s | None -> fprintf pp "<unknown reg>" diff --git a/backend/PrintXTL.ml b/backend/PrintXTL.ml index d1b79623..6f2b1df9 100644 --- a/backend/PrintXTL.ml +++ b/backend/PrintXTL.ml @@ -22,7 +22,7 @@ open PrintOp open XTL let mreg pp r = - match Machregsaux.name_of_register r with + match Machregsnames.name_of_register r with | Some s -> fprintf pp "%s" s | None -> fprintf pp "<unknown machreg>" diff --git a/backend/Selection.v b/backend/Selection.v index 342bd8ca..8667922f 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -251,10 +251,16 @@ Function sel_known_builtin (bf: builtin_function) (args: exprlist) := Some (sel_select ty a1 a2 a3) | BI_standard BI_fabs, a1 ::: Enil => Some (SelectOp.absf a1) + | BI_standard BI_fabsf, a1 ::: Enil => + Some (SelectOp.absfs a1) | _, _ => None end. +(** A CminorSel statement that does nothing, like [Sskip], but reduces. *) + +Definition Sno_op := Sseq Sskip Sskip. + (** Builtin functions in general *) Definition sel_builtin_default (optid: option ident) (ef: external_function) @@ -264,17 +270,22 @@ Definition sel_builtin_default (optid: option ident) (ef: external_function) Definition sel_builtin (optid: option ident) (ef: external_function) (args: list Cminor.expr) := - match optid, ef with - | Some id, EF_builtin name sg => + match ef with + | EF_builtin name sg => match lookup_builtin_function name sg with | Some bf => - match sel_known_builtin bf (sel_exprlist args) with - | Some a => Sassign id a - | None => sel_builtin_default optid ef args + match optid with + | Some id => + match sel_known_builtin bf (sel_exprlist args) with + | Some a => Sassign id a + | None => sel_builtin_default optid ef args + end + | None => + Sno_op (**r builtins with semantics are pure *) end | None => sel_builtin_default optid ef args end - | _, _ => + | _ => sel_builtin_default optid ef args end. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 955c45a4..4d075f4a 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -396,13 +396,10 @@ Proof. inv ARGS; try discriminate. inv H0; try discriminate. inv SEL. simpl in SEM; inv SEM. apply eval_absf; auto. - (* + (* expect *) - inv ARGS; try discriminate. - inv H0; try discriminate. - inv H2; try discriminate. - simpl in SEM. inv SEM. inv SEL. - destruct v1; destruct v0. - all: econstructor; split; eauto. *) ++ (* fabsf *) + inv ARGS; try discriminate. inv H0; try discriminate. + inv SEL. + simpl in SEM; inv SEM. apply eval_absfs; auto. - eapply eval_platform_builtin; eauto. Qed. @@ -852,8 +849,8 @@ Lemma sel_builtin_default_correct: external_call ef ge vl m1 t v m2 -> env_lessdef e1 e1' -> Mem.extends m1 m1' -> exists e2' m2', - step tge (State f (sel_builtin_default optid ef al) k sp e1' m1') - t (State f Sskip k sp e2' m2') + plus step tge (State f (sel_builtin_default optid ef al) k sp e1' m1') + t (State f Sskip k sp e2' m2') /\ env_lessdef (set_optvar optid v e1) e2' /\ Mem.extends m2 m2'. Proof. @@ -861,6 +858,7 @@ Proof. exploit sel_builtin_args_correct; eauto. intros (vl' & A & B). exploit external_call_mem_extends; eauto. intros (v' & m2' & D & E & F & _). econstructor; exists m2'; split. + apply plus_one. econstructor. eexact A. eapply external_call_symbols_preserved. eexact senv_preserved. eexact D. split; auto. apply sel_builtin_res_correct; auto. Qed. @@ -871,8 +869,8 @@ Lemma sel_builtin_correct: external_call ef ge vl m1 t v m2 -> env_lessdef e1 e1' -> Mem.extends m1 m1' -> exists e2' m2', - step tge (State f (sel_builtin optid ef al) k sp e1' m1') - t (State f Sskip k sp e2' m2') + plus step tge (State f (sel_builtin optid ef al) k sp e1' m1') + t (State f Sskip k sp e2' m2') /\ env_lessdef (set_optvar optid v e1) e2' /\ Mem.extends m2 m2'. Proof. @@ -880,15 +878,18 @@ Proof. exploit sel_exprlist_correct; eauto. intros (vl' & A & B). exploit external_call_mem_extends; eauto. intros (v' & m2' & D & E & F & _). unfold sel_builtin. - destruct optid as [id|]; eauto using sel_builtin_default_correct. destruct ef; eauto using sel_builtin_default_correct. destruct (lookup_builtin_function name sg) as [bf|] eqn:LKUP; eauto using sel_builtin_default_correct. - destruct (sel_known_builtin bf (sel_exprlist al)) as [a|] eqn:SKB; eauto using sel_builtin_default_correct. simpl in D. red in D. rewrite LKUP in D. inv D. + destruct optid as [id|]; eauto using sel_builtin_default_correct. +- destruct (sel_known_builtin bf (sel_exprlist al)) as [a|] eqn:SKB; eauto using sel_builtin_default_correct. exploit eval_sel_known_builtin; eauto. intros (v'' & U & V). econstructor; exists m2'; split. - econstructor. eexact U. + apply plus_one. econstructor. eexact U. split; auto. apply set_var_lessdef; auto. apply Val.lessdef_trans with v'; auto. +- exists e1', m2'; split. + eapply plus_two. constructor. constructor. auto. + simpl; auto. Qed. (** If-conversion *) @@ -1179,8 +1180,8 @@ Remark sel_builtin_nolabel: forall (hf: helper_functions) optid ef args, nolabel' (sel_builtin optid ef args). Proof. unfold sel_builtin; intros; red; intros. - destruct optid; auto. destruct ef; auto. destruct lookup_builtin_function; auto. - destruct sel_known_builtin; auto. + destruct ef; auto. destruct lookup_builtin_function; auto. + destruct optid; auto. destruct sel_known_builtin; auto. Qed. Remark find_label_commut: @@ -1243,34 +1244,34 @@ Definition measure (s: Cminor.state) : nat := Lemma sel_step_correct: forall S1 t S2, Cminor.step ge S1 t S2 -> forall T1, match_states S1 T1 -> wt_state S1 -> - (exists T2, step tge T1 t T2 /\ match_states S2 T2) + (exists T2, plus step tge T1 t T2 /\ match_states S2 T2) \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat \/ (exists S3 T2, star Cminor.step ge S2 E0 S3 /\ step tge T1 t T2 /\ match_states S3 T2). Proof. induction 1; intros T1 ME WTS; inv ME; try (monadInv TS). - (* skip seq *) - inv MC. left; econstructor; split. econstructor. econstructor; eauto. + inv MC. left; econstructor; split. apply plus_one; econstructor. econstructor; eauto. inv H. - (* skip block *) - inv MC. left; econstructor; split. econstructor. econstructor; eauto. + inv MC. left; econstructor; split. apply plus_one; econstructor. econstructor; eauto. inv H. - (* skip call *) exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. left; econstructor; split. - econstructor. eapply match_is_call_cont; eauto. + apply plus_one; econstructor. eapply match_is_call_cont; eauto. erewrite stackspace_function_translated; eauto. econstructor; eauto. eapply match_is_call_cont; eauto. - (* assign *) exploit sel_expr_correct; eauto. intros [v' [A B]]. left; econstructor; split. - econstructor; eauto. + apply plus_one; econstructor; eauto. econstructor; eauto. apply set_var_lessdef; auto. - (* store *) exploit sel_expr_correct. try apply LINK. try apply HF. eexact H. eauto. eauto. intros [vaddr' [A B]]. exploit sel_expr_correct. try apply LINK. try apply HF. eexact H0. eauto. eauto. intros [v' [C D]]. exploit Mem.storev_extends; eauto. intros [m2' [P Q]]. left; econstructor; split. - eapply eval_store; eauto. + apply plus_one; eapply eval_store; eauto. econstructor; eauto. - (* Scall *) exploit classify_call_correct; eauto. @@ -1280,7 +1281,7 @@ Proof. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. exploit functions_translated; eauto. intros (cunit' & fd' & U & V & W). left; econstructor; split. - econstructor; eauto. econstructor; eauto. + apply plus_one; econstructor; eauto. econstructor; eauto. eapply sig_function_translated; eauto. eapply match_callstate with (cunit := cunit'); eauto. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. @@ -1289,7 +1290,7 @@ Proof. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. exploit functions_translated; eauto. intros (cunit' & fd' & X & Y & Z). left; econstructor; split. - econstructor; eauto. + apply plus_one; econstructor; eauto. subst vf. econstructor; eauto. rewrite symbols_preserved; eauto. eapply sig_function_translated; eauto. eapply match_callstate with (cunit := cunit'); eauto. @@ -1304,6 +1305,7 @@ Proof. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. exploit functions_translated; eauto. intros (cunit' & fd' & E & F & G). left; econstructor; split. + apply plus_one. exploit classify_call_correct. eexact LINK. eauto. eauto. destruct (classify_call (prog_defmap cunit)) as [ | id | ef]; intros. econstructor; eauto. econstructor; eauto. eapply sig_function_translated; eauto. @@ -1317,7 +1319,7 @@ Proof. left; econstructor; split. eexact P. econstructor; eauto. - (* Seq *) left; econstructor; split. - constructor. + apply plus_one; constructor. econstructor; eauto. constructor; auto. - (* Sifthenelse *) simpl in TS. destruct (if_conversion (known_id f) env a s1 s2) as [s|] eqn:IFC; monadInv TS. @@ -1329,21 +1331,21 @@ Proof. + exploit sel_expr_correct; eauto. intros [v' [A B]]. assert (Val.bool_of_val v' b). inv B. auto. inv H0. left; exists (State f' (if b then x else x0) k' sp e' m'); split. - econstructor; eauto. eapply eval_condexpr_of_expr; eauto. + apply plus_one; econstructor; eauto. eapply eval_condexpr_of_expr; eauto. econstructor; eauto. destruct b; auto. - (* Sloop *) - left; econstructor; split. constructor. econstructor; eauto. + left; econstructor; split. apply plus_one; constructor. econstructor; eauto. constructor; auto. simpl; rewrite EQ; auto. - (* Sblock *) - left; econstructor; split. constructor. econstructor; eauto. constructor; auto. + left; econstructor; split. apply plus_one; constructor. econstructor; eauto. constructor; auto. - (* Sexit seq *) - inv MC. left; econstructor; split. constructor. econstructor; eauto. + inv MC. left; econstructor; split. apply plus_one; constructor. econstructor; eauto. inv H. - (* Sexit0 block *) - inv MC. left; econstructor; split. constructor. econstructor; eauto. + inv MC. left; econstructor; split. apply plus_one; constructor. econstructor; eauto. inv H. - (* SexitS block *) - inv MC. left; econstructor; split. constructor. econstructor; eauto. + inv MC. left; econstructor; split. apply plus_one; constructor. econstructor; eauto. inv H. - (* Sswitch *) inv H0; simpl in TS. @@ -1351,29 +1353,29 @@ Proof. destruct (validate_switch Int.modulus default cases ct) eqn:VALID; inv TS. exploit sel_expr_correct; eauto. intros [v' [A B]]. inv B. left; econstructor; split. - econstructor. eapply sel_switch_int_correct; eauto. + apply plus_one; econstructor. eapply sel_switch_int_correct; eauto. econstructor; eauto. + set (ct := compile_switch Int64.modulus default cases) in *. destruct (validate_switch Int64.modulus default cases ct) eqn:VALID; inv TS. exploit sel_expr_correct; eauto. intros [v' [A B]]. inv B. left; econstructor; split. - econstructor. eapply sel_switch_long_correct; eauto. + apply plus_one; econstructor. eapply sel_switch_long_correct; eauto. econstructor; eauto. - (* Sreturn None *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. left; econstructor; split. - econstructor. simpl; eauto. + apply plus_one; econstructor. simpl; eauto. econstructor; eauto. eapply call_cont_commut; eauto. - (* Sreturn Some *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. exploit sel_expr_correct; eauto. intros [v' [A B]]. left; econstructor; split. - econstructor; eauto. + apply plus_one; econstructor; eauto. econstructor; eauto. eapply call_cont_commut; eauto. - (* Slabel *) - left; econstructor; split. constructor. econstructor; eauto. + left; econstructor; split. apply plus_one; constructor. econstructor; eauto. - (* Sgoto *) assert (sel_stmt (prog_defmap cunit) (known_id f) env (Cminor.fn_body f) = OK (fn_body f')). { monadInv TF; simpl. congruence. } @@ -1384,7 +1386,7 @@ Proof. as [[s'' k'']|] eqn:?; intros; try contradiction. destruct H1. left; econstructor; split. - econstructor; eauto. + apply plus_one; econstructor; eauto. econstructor; eauto. - (* internal function *) destruct TF as (hf & HF & TF). @@ -1392,7 +1394,7 @@ Proof. exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. intros [m2' [A B]]. left; econstructor; split. - econstructor; simpl; eauto. + apply plus_one; econstructor; simpl; eauto. econstructor; simpl; eauto. apply match_cont_other; auto. apply set_locals_lessdef. apply set_params_lessdef; auto. @@ -1402,7 +1404,7 @@ Proof. exploit external_call_mem_extends; eauto. intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. - econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + apply plus_one; econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* external call turned into a Sbuiltin *) exploit sel_builtin_correct; eauto. intros (e2' & m2' & P & Q & R). @@ -1410,7 +1412,7 @@ Proof. - (* return *) inv MC. left; econstructor; split. - econstructor. + apply plus_one; econstructor. econstructor; eauto. destruct optid; simpl; auto. apply set_var_lessdef; auto. - (* return of an external call turned into a Sbuiltin *) right; left; split. simpl; omega. split. auto. econstructor; eauto. @@ -1453,7 +1455,7 @@ Proof. unfold MS. exploit sel_step_correct; eauto. intros [(T2 & D & E) | [(D & E & F) | (S3 & T2 & D & E & F)]]. -+ exists S2, T2. intuition auto using star_refl, plus_one. ++ exists S2, T2. intuition auto using star_refl. + subst t. exists S2, T1. intuition auto using star_refl. + assert (wt_state S3) by (eapply subject_reduction_star; eauto using wt_prog). exists S3, T2. intuition auto using plus_one. diff --git a/backend/Tunnelingaux.ml b/backend/Tunnelingaux.ml index af89adea..87e6d303 100644 --- a/backend/Tunnelingaux.ml +++ b/backend/Tunnelingaux.ml @@ -178,11 +178,11 @@ let final_export f c = ) else ( n.dist <- undef_dist; (* force [dist] to compute the actual [n.dist] *) count := !count+1; - (tn, n)::acc + n::acc ) in let nops = Hashtbl.fold filter_nops_init_dist c.nodes [] in - let res = List.fold_left (fun acc (tn,n) -> PTree.set (lab_p n) (lab_p tn, Z.of_uint (dist n)) acc) PTree.empty nops in + let res = List.fold_left (fun acc n -> PTree.set (lab_p n) (lab_p n.link, Z.of_uint (dist n)) acc) PTree.empty nops in debug "* Tunneling.branch_target: final number of eliminated nops = %d\n" !count; res diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index 779e7bb9..f1a46baa 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -2069,7 +2069,6 @@ Definition divfs := binop_single Float32.div. Lemma divfs_sound: forall v x w y, vmatch v x -> vmatch w y -> vmatch (Val.divfs v w) (divfs x y). Proof (binop_single_sound Float32.div). - (** Conversions *) Definition zero_ext (nbits: Z) (v: aval) := @@ -2483,6 +2482,468 @@ Proof. destruct 1; simpl; auto with va. Qed. + +(* Extensions for KVX and Risc-V *) + +Definition intoffloat_total (x: aval) := + match x with + | F f => + match Float.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longoffloat_total (x: aval) := + match x with + | F f => + match Float.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Lemma intoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intoffloat v)) (intoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma intuoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intuoffloat v)) (intuoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma intofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intofsingle v)) (intofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma intuofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intuofsingle v)) (intuofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma singleofint_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleofint v)) (singleofint x). +Proof. + unfold Val.singleofint, singleofint; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma singleofintu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleofintu v)) (singleofintu x). +Proof. + unfold Val.singleofintu, singleofintu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma longoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longoffloat v)) (longoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma longuoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longuoffloat v)) (longuoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma longofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longofsingle v)) (longofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma longuofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longuofsingle v)) (longuofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma singleoflong_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleoflong v)) (singleoflong x). +Proof. + unfold Val.singleoflong, singleoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma singleoflongu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleoflongu v)) (singleoflongu x). +Proof. + unfold Val.singleoflongu, singleoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatoflong_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatoflong v)) (floatoflong x). +Proof. + unfold Val.floatoflong, floatoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatoflongu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatoflongu v)) (floatoflongu x). +Proof. + unfold Val.floatoflongu, floatoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatofint_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatofint v)) (floatofint x). +Proof. + unfold Val.floatofint, floatofint; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatofintu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatofintu v)) (floatofintu x). +Proof. + unfold Val.floatofintu, floatofintu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + + +Definition divs_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + || Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone + then ntop + else I (Int.divs i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divs_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divs v w)) (divs_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct (_ || _) eqn:E; cbn; unfold ntop; auto with va. + } + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2; cbn; auto with va. +Qed. + +Definition divu_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + then ntop + else I (Int.divu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divu v w)) (divu_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct Int.eq eqn:E; cbn; unfold ntop; auto with va. + } + all: unfold ntop2; auto with va. + all: destruct Int.eq eqn:E; unfold ntop2; cbn; auto with va. +Qed. + +Definition mods_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + || Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone + then ntop + else I (Int.mods i1 i2) + | _, _ => ntop2 v w + end. + +Lemma mods_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.mods v w)) (mods_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct (_ || _) eqn:E; cbn; unfold ntop; auto with va. + } + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2; cbn; auto with va. +Qed. + +Definition modu_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + then ntop + else I (Int.modu i1 i2) + | I i2, _ => uns (provenance v) (usize i2) + | _, _ => ntop2 v w + end. + +Lemma modu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.modu v w)) (modu_total x y). +Proof. + assert (UNS: forall i j, j <> Int.zero -> is_uns (usize j) (Int.modu i j)). + { + intros. apply is_uns_mon with (usize (Int.modu i j)). + { apply is_uns_usize. + } + unfold usize, Int.size. + apply Zsize_monotone. + generalize (Int.unsigned_range_2 j); intros RANGE. + assert (Int.unsigned j <> 0). + { red; intros; elim H. rewrite <- (Int.repr_unsigned j). rewrite H0. auto. } + exploit (Z_mod_lt (Int.unsigned i) (Int.unsigned j)). omega. intros MOD. + unfold Int.modu. rewrite Int.unsigned_repr. omega. omega. + } + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct Int.eq eqn:E; unfold ntop; cbn; auto with va. + } + all: try discriminate. + all: unfold ntop2; auto with va. + all: try (destruct Int.eq eqn:E; cbn; unfold ntop2; auto with va; fail). + all: try apply vmatch_uns_undef. + + all: + generalize (Int.eq_spec i0 Int.zero); + destruct (Int.eq i0 Int.zero); + cbn; + intro. + all: try apply vmatch_uns_undef. + all: apply vmatch_uns; auto. +Qed. + + +Lemma shrx_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.shrx v w)) (shrx x y). +Proof. + intros until y. intros HX HY. + inv HX; inv HY; cbn. + all: unfold ntop1; auto with va. + all: destruct Int.ltu eqn:LTU; cbn; unfold ntop; auto with va. +Qed. + + +Definition divls_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + || Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone + then ntop + else L (Int64.divs i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divls_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divls v w)) (divls_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2, ntop; cbn; auto with va. +Qed. + +Definition divlu_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + then ntop + else L (Int64.divu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divlu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divlu v w)) (divlu_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct Int64.eq eqn:E; unfold ntop2, ntop; cbn; auto with va. +Qed. + + +Definition modls_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + || Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone + then ntop + else L (Int64.mods i1 i2) + | _, _ => ntop2 v w + end. + +Lemma modls_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.modls v w)) (modls_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2, ntop; cbn; auto with va. +Qed. + + +Definition modlu_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + then ntop + else L (Int64.modu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma modlu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.modlu v w)) (modlu_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct Int64.eq eqn:E; cbn; unfold ntop2, ntop; auto with va. +Qed. + +Lemma shrxl_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.shrxl v w)) (shrxl x y). +Proof. + intros until y. intros HX HY. + inv HX; inv HY; cbn. + all: unfold ntop1; auto with va. + all: destruct Int.ltu eqn:LTU; cbn; unfold ntop; auto with va. +Qed. + (** Comparisons and variation intervals *) Definition cmp_intv (c: comparison) (i: Z * Z) (n: Z) : abool := @@ -4734,6 +5195,26 @@ Hint Resolve cnot_sound symbol_address_sound longoffloat_sound longuoffloat_sound floatoflong_sound floatoflongu_sound longofsingle_sound longuofsingle_sound singleoflong_sound singleoflongu_sound longofwords_sound loword_sound hiword_sound + intoffloat_total_sound + intuoffloat_total_sound + intofsingle_total_sound + intuofsingle_total_sound + singleofint_total_sound + singleofintu_total_sound + longoffloat_total_sound + longuoffloat_total_sound + longofsingle_total_sound + longuofsingle_total_sound + singleoflong_total_sound + singleoflongu_total_sound + floatoflong_total_sound + floatoflongu_total_sound + floatofint_total_sound + floatofintu_total_sound + divu_total_sound divs_total_sound + modu_total_sound mods_total_sound shrx_total_sound + divlu_total_sound divls_total_sound + modlu_total_sound modls_total_sound shrxl_total_sound cmpu_bool_sound cmp_bool_sound cmplu_bool_sound cmpl_bool_sound cmpf_bool_sound cmpfs_bool_sound maskzero_sound : va. diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 75f5eb3e..d830ada6 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -194,12 +194,28 @@ let builtins_generic = { (TInt(IUInt, []), [TInt(IUInt, [])], false); "__builtin_bswap16", (TInt(IUShort, []), [TInt(IUShort, [])], false); + "__builtin_clz", + (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_clzl", + (TInt(IInt, []), [TInt(IULong, [])], false); + "__builtin_clzll", + (TInt(IInt, []), [TInt(IULongLong, [])], false); + "__builtin_ctz", + (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_ctzl", + (TInt(IInt, []), [TInt(IULong, [])], false); + "__builtin_ctzll", + (TInt(IInt, []), [TInt(IULongLong, [])], false); (* Floating-point absolute value *) "__builtin_fabs", (TFloat(FDouble, []), [TFloat(FDouble, [])], false); + "__builtin_fabsf", + (TFloat(FFloat, []), [TFloat(FFloat, [])], false); (* Float arithmetic *) "__builtin_fsqrt", (TFloat(FDouble, []), [TFloat(FDouble, [])], false); + "__builtin_sqrt", + (TFloat(FDouble, []), [TFloat(FDouble, [])], false); (* Block copy *) "__builtin_memcpy_aligned", (TVoid [], @@ -1540,7 +1556,7 @@ let convertProgram p = let p' = { prog_defs = gl2; prog_public = public_globals gl2; - prog_main = intern_string "main"; + prog_main = intern_string !Clflags.main_function_name; prog_types = typs; prog_comp_env = ce } in Diagnostics.check_errors (); diff --git a/cfrontend/CPragmas.ml b/cfrontend/CPragmas.ml index 44660718..22ab2b5a 100644 --- a/cfrontend/CPragmas.ml +++ b/cfrontend/CPragmas.ml @@ -49,13 +49,15 @@ let process_use_section_pragma classname id = (* #pragma reserve_register *) +let reserved_registers = ref ([]: Machregs.mreg list) + let process_reserve_register_pragma name = - match Machregsaux.register_by_name name with + match Machregsnames.register_by_name name with | None -> C2C.error "unknown register in `reserve_register' pragma" | Some r -> - if Machregsaux.can_reserve_register r then - IRC.reserved_registers := r :: !IRC.reserved_registers + if Conventions1.is_callee_save r then + reserved_registers := r :: !reserved_registers else C2C.error "cannot reserve this register (not a callee-save)" @@ -84,5 +86,8 @@ let process_pragma name = | _ -> false +let reset () = + reserved_registers := [] + let initialize () = C2C.process_pragma_hook := process_pragma diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index beca056f..cfb2b584 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -270,6 +270,9 @@ let rec expr p (prec, e) = | Ebuiltin(EF_debug(kind,txt,_),_,args,_) -> fprintf p "__builtin_debug@[<hov 1>(%d,%S%a)@]" (P.to_int kind) (extern_atom txt) exprlist (false,args) + | Ebuiltin(EF_builtin(name, _), _, args, _) -> + fprintf p "%s@[<hov 1>(%a)@]" + (camlstring_of_coqstring name) exprlist (true, args) | Ebuiltin(_, _, args, _) -> fprintf p "<unknown builtin>@[<hov 1>(%a)@]" exprlist (true, args) | Eparen(a1, tycast, ty) -> diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index 7cdff468..c7e57a54 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -268,8 +268,13 @@ Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement do (sl2, a2) <- transl_expr For_val r2; ret (finish dst (sl1 ++ sl2) (Ebinop op a1 a2 ty)) | Csyntax.Ecast r1 ty => - do (sl1, a1) <- transl_expr For_val r1; - ret (finish dst sl1 (Ecast a1 ty)) + match dst with + | For_val | For_set _ => + do (sl1, a1) <- transl_expr For_val r1; + ret (finish dst sl1 (Ecast a1 ty)) + | For_effects => + transl_expr For_effects r1 + end | Csyntax.Eseqand r1 r2 ty => do (sl1, a1) <- transl_expr For_val r1; match dst with diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index ee1df409..9a3f32ec 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -145,18 +145,18 @@ 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 discriminate; auto. - rewrite H0; auto. simpl; auto. - rewrite H0; auto. simpl; auto. - destruct H1; congruence. - destruct (andb_prop _ _ H6). inv H1. +- rewrite H0; auto. simpl; auto. +- rewrite H0; auto. simpl; auto. +- destruct H1; congruence. +- destruct (andb_prop _ _ H6). inv H1. rewrite H0; eauto. simpl; auto. unfold chunk_for_volatile_type in H9. destruct (type_is_volatile (Csyntax.typeof e1)); simpl in H8; congruence. - rewrite H0; auto. simpl; auto. - rewrite H0; auto. simpl; auto. - destruct (andb_prop _ _ H7). rewrite H0; auto. rewrite H2; auto. simpl; auto. - rewrite H0; auto. simpl; auto. - destruct (andb_prop _ _ H6). rewrite H0; auto. +- rewrite H0; auto. simpl; auto. +- rewrite H0; auto. simpl; auto. +- destruct (andb_prop _ _ H7). rewrite H0; auto. rewrite H2; auto. simpl; auto. +- rewrite H0; auto. simpl; auto. +- destruct (andb_prop _ _ H6). rewrite H0; auto. Qed. Lemma tr_simple_expr_nil: @@ -234,11 +234,11 @@ Proof. Opaque makeif. intros e m. apply (eval_simple_rvalue_lvalue_ind ge e m); intros until tmps; intros TR; inv TR. -(* value *) +- (* value *) auto. - auto. - exists a0; auto. -(* rvalof *) +- auto. +- exists a0; auto. +- (* rvalof *) inv H7; try congruence. exploit H0; eauto. intros [A [B C]]. subst sl1; simpl. @@ -248,53 +248,55 @@ Opaque makeif. exploit deref_loc_translated; eauto. unfold chunk_for_volatile_type; rewrite H2. tauto. destruct dst; auto. econstructor. split. simpl; eauto. auto. -(* addrof *) +- (* addrof *) exploit H0; eauto. intros [A [B C]]. subst sl1; simpl. assert (eval_expr tge e le m (Eaddrof' a1 ty) (Vptr b ofs)) by (apply eval_Eaddrof'; auto). assert (typeof (Eaddrof' a1 ty) = ty) by (apply typeof_Eaddrof'). destruct dst; auto. simpl; econstructor; eauto. -(* unop *) +- (* 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 *) +- (* 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. rewrite comp_env_preserved; congruence. destruct dst; auto. simpl; econstructor; eauto. -(* cast *) +- (* cast effects *) + exploit H0; eauto. +- (* cast val *) 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 *) +- (* sizeof *) rewrite <- comp_env_preserved. destruct dst. split; auto. split; auto. constructor. auto. exists (Esizeof ty1 ty). split. auto. split. auto. constructor. -(* alignof *) +- (* alignof *) rewrite <- comp_env_preserved. destruct dst. split; auto. split; auto. constructor. auto. exists (Ealignof ty1 ty). split. auto. split. auto. constructor. -(* var local *) +- (* var local *) split; auto. split; auto. apply eval_Evar_local; auto. -(* var global *) +- (* var global *) split; auto. split; auto. apply eval_Evar_global; auto. rewrite symbols_preserved; auto. -(* deref *) +- (* deref *) exploit H0; eauto. intros [A [B C]]. subst sl1. split; auto. split. rewrite typeof_Ederef'; auto. apply eval_Ederef'; auto. -(* field struct *) +- (* field struct *) rewrite <- comp_env_preserved in *. exploit H0; eauto. intros [A [B C]]. subst sl1. split; auto. split; auto. rewrite B in H1. eapply eval_Efield_struct; eauto. -(* field union *) +- (* field union *) rewrite <- comp_env_preserved in *. exploit H0; eauto. intros [A [B C]]. subst sl1. split; auto. split; auto. rewrite B in H1. eapply eval_Efield_union; eauto. @@ -408,43 +410,43 @@ Ltac UNCHANGED := (*generalize compat_dest_change; intro CDC.*) apply leftcontext_leftcontextlist_ind; intros. -(* base *) +- (* base *) TR. rewrite <- app_nil_end; auto. red; auto. intros. rewrite <- app_nil_end; auto. -(* deref *) +- (* deref *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1; rewrite app_ass; eauto. auto. intros. rewrite <- app_ass. econstructor; eauto. -(* field *) +- (* field *) inv H1. exploit H0. eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1; rewrite app_ass; eauto. auto. intros. rewrite <- app_ass. econstructor; eauto. -(* rvalof *) +- (* rvalof *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1; rewrite app_ass; eauto. red; eauto. intros. rewrite <- app_ass; econstructor; eauto. exploit typeof_context; eauto. congruence. -(* addrof *) +- (* addrof *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1; rewrite app_ass; eauto. auto. intros. rewrite <- app_ass. econstructor; eauto. -(* unop *) +- (* unop *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1; rewrite app_ass; eauto. auto. intros. rewrite <- app_ass. econstructor; eauto. -(* binop left *) +- (* binop left *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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 *) +- (* 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 [R S]]]]]]]]. @@ -452,14 +454,19 @@ Ltac UNCHANGED := 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 *) +- (* cast *) inv H1. ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. - TR. subst sl1; rewrite app_ass; eauto. auto. + TR. eauto. auto. + intros. econstructor; eauto. ++ (* generic *) + exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. + TR. subst sl1. rewrite app_ass. eauto. auto. intros. rewrite <- app_ass. econstructor; eauto. -(* seqand *) +- (* seqand *) inv H1. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -467,15 +474,15 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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. auto. - (* for set *) + auto. auto. auto. ++ (* for set *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -483,9 +490,9 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. -(* seqor *) +- (* seqor *) inv H1. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -493,15 +500,15 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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. auto. - (* for set *) + auto. auto. auto. ++ (* for set *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -509,9 +516,9 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. -(* condition *) +- (* condition *) inv H1. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -520,7 +527,7 @@ Ltac UNCHANGED := eapply tr_expr_invariant; eauto. UNCHANGED. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. auto. auto. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -529,7 +536,7 @@ Ltac UNCHANGED := eapply tr_expr_invariant; eauto. UNCHANGED. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. auto. - (* for set *) ++ (* for set *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. rewrite app_ass. eauto. @@ -538,16 +545,16 @@ Ltac UNCHANGED := eapply tr_expr_invariant; eauto. UNCHANGED. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. auto. auto. -(* assign left *) +- (* assign left *) inv H1. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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 *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. red; auto. @@ -556,9 +563,9 @@ Ltac UNCHANGED := auto. auto. auto. auto. auto. auto. eapply typeof_context; eauto. auto. -(* assign right *) +- (* assign right *) inv H2. - (* for effects *) ++ (* 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 [R S]]]]]]]]. TR. subst sl2. rewrite app_ass. eauto. @@ -567,7 +574,7 @@ Ltac UNCHANGED := econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. auto. auto. auto. - (* for val *) ++ (* 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 [R S]]]]]]]]. TR. subst sl2. rewrite app_ass. eauto. @@ -577,9 +584,9 @@ Ltac UNCHANGED := eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. auto. auto. auto. auto. auto. auto. auto. eapply typeof_context; eauto. -(* assignop left *) +- (* assignop left *) inv H1. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. red; auto. @@ -587,7 +594,7 @@ Ltac UNCHANGED := eapply tr_expr_invariant; eauto. UNCHANGED. symmetry; eapply typeof_context; eauto. eauto. auto. auto. auto. auto. auto. auto. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. red; auto. @@ -595,9 +602,9 @@ Ltac UNCHANGED := eapply tr_expr_invariant; eauto. UNCHANGED. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. eapply typeof_context; eauto. -(* assignop right *) +- (* assignop right *) inv H2. - (* for effects *) ++ (* 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 [R S]]]]]]]]. TR. subst sl2. rewrite app_ass. eauto. @@ -605,7 +612,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. auto. eauto. auto. auto. auto. auto. auto. auto. - (* for val *) ++ (* 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 [R S]]]]]]]]. TR. subst sl2. rewrite app_ass. eauto. @@ -613,35 +620,35 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. -(* postincr *) +- (* postincr *) inv H1. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. red; auto. intros. rewrite <- app_ass. econstructor; eauto. symmetry; eapply typeof_context; eauto. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. red; auto. intros. rewrite <- app_ass. econstructor; eauto. eapply typeof_context; eauto. -(* call left *) +- (* call left *) inv H1. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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 *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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 *) +- (* call right *) inv H2. - (* for effects *) ++ (* 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 [R S]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. @@ -650,7 +657,7 @@ Ltac UNCHANGED := 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 *) ++ (* 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 [R S]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. @@ -660,42 +667,42 @@ Ltac UNCHANGED := auto. eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. auto. auto. auto. auto. -(* builtin *) +- (* builtin *) inv H1. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. red; auto. intros. rewrite <- app_ass. change (sl3++sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. apply S; auto. auto. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. red; auto. intros. rewrite <- app_ass. change (sl3++sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. auto. apply S; auto. auto. auto. -(* comma *) +- (* comma *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [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 *) +- (* paren *) inv H1. - (* for val *) ++ (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. eauto. red; auto. intros. econstructor; eauto. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. eauto. auto. intros. econstructor; eauto. - (* for set *) ++ (* for set *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. rewrite Q. eauto. auto. intros. econstructor; eauto. -(* cons left *) +- (* cons left *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. @@ -703,7 +710,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_exprlist_invariant; eauto. UNCHANGED. auto. auto. auto. -(* cons right *) +- (* 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 [R S]]]]]]]]. diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index 95e3957c..98425311 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -108,7 +108,12 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> tr_expr le dst (Csyntax.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_cast_effects: forall le e1 ty sl1 a1 any tmp, + tr_expr le For_effects e1 sl1 a1 tmp -> + tr_expr le For_effects (Csyntax.Ecast e1 ty) + sl1 + any tmp + | tr_cast_val: forall le dst e1 ty sl1 a1 tmp, tr_expr le For_val e1 sl1 a1 tmp -> tr_expr le dst (Csyntax.Ecast e1 ty) (sl1 ++ final dst (Ecast a1 ty)) @@ -767,58 +772,69 @@ Lemma transl_meets_spec: exists tmps, (forall le, tr_exprlist le rl sl al tmps) /\ contained tmps g g'). Proof. apply expr_exprlist_ind; simpl add_dest; intros. -(* val *) +- (* val *) simpl in H. destruct v; monadInv H; exists (@nil ident); split; auto with gensym. Opaque makeif. -- intros. destruct dst; simpl in *; inv H2. ++ intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. -- intros. destruct dst; simpl in *; inv H2. ++ intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. -- intros. destruct dst; simpl in *; inv H2. ++ intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. -- intros. destruct dst; simpl in *; inv H2. ++ intros. destruct dst; simpl in *; inv H2. 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. auto. intros [tmp [A B]]. UseFinish. +- (* var *) + monadInv H; econstructor; split; auto with gensym. UseFinish. constructor. +- (* field *) + monadInv H0. exploit H; eauto. auto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. -(* valof *) -- monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. +- (* valof *) + monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. exploit transl_valof_meets_spec; eauto. intros [tmp2 [Csyntax D]]. UseFinish. exists (tmp1 ++ tmp2); split. intros; apply tr_expr_add_dest. econstructor; eauto with gensym. eauto with gensym. -(* deref *) -- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- (* deref *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. -(* addrof *) -- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- (* addrof *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. econstructor; eauto. -(* unop *) -- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- (* unop *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. -(* binop *) -- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- (* binop *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. UseFinish. exists (tmp1 ++ tmp2); split. intros; apply tr_expr_add_dest. econstructor; eauto with gensym. eauto with gensym. -(* cast *) -- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. - econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. -(* seqand *) -- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- (* cast *) + destruct dst. ++ (* for value *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. + econstructor; split; eauto. intros; apply tr_expr_add_dest. + rewrite (app_nil_end sl). + apply tr_cast_val with (dst := For_val); auto. ++ (* for effects *) + exploit H; eauto. intros [tmp [A B]]. + econstructor; split; eauto. intros; eapply tr_cast_effects; eauto. ++ (* for set *) + monadInv H0. exploit H; eauto. intros [tmp [A B]]. + econstructor; split; eauto. intros; apply tr_expr_add_dest. + apply tr_cast_val with (dst := For_set sd); auto. +- (* seqand *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0. - (* for value *) ++ (* for value *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. simpl add_dest in *. exists (x0 :: tmp1 ++ tmp2); split. @@ -826,23 +842,23 @@ Opaque makeif. apply list_disjoint_cons_r; eauto with gensym. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. - (* for effects *) ++ (* for effects *) exploit H0; eauto with gensym. intros [tmp2 [Csyntax D]]. simpl add_dest in *. exists (tmp1 ++ tmp2); split. intros; eapply tr_seqand_effects; eauto with gensym. apply contained_app; eauto with gensym. - (* for set *) ++ (* for set *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. simpl add_dest in *. exists (tmp1 ++ tmp2); split. intros; eapply tr_seqand_set; eauto with gensym. apply list_disjoint_cons_r; eauto with gensym. apply contained_app; eauto with gensym. -(* seqor *) -- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- (* seqor *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0. - (* for value *) ++ (* for value *) exploit H0; eauto with gensym. intros [tmp2 [Csyntax D]]. simpl add_dest in *. exists (x0 :: tmp1 ++ tmp2); split. @@ -850,23 +866,23 @@ Opaque makeif. apply list_disjoint_cons_r; eauto with gensym. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. - (* for effects *) ++ (* for effects *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. simpl add_dest in *. exists (tmp1 ++ tmp2); split. intros; eapply tr_seqor_effects; eauto with gensym. apply contained_app; eauto with gensym. - (* for set *) ++ (* for set *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. simpl add_dest in *. exists (tmp1 ++ tmp2); split. intros; eapply tr_seqor_set; eauto with gensym. apply list_disjoint_cons_r; eauto with gensym. apply contained_app; eauto with gensym. -(* condition *) -- monadInv H2. exploit H; eauto. intros [tmp1 [A B]]. +- (* condition *) + monadInv H2. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0. - (* for value *) ++ (* for value *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. exploit H1; eauto with gensym. intros [tmp3 [E F]]. simpl add_dest in *. @@ -877,14 +893,14 @@ Opaque makeif. apply contained_cons. eauto with gensym. apply contained_app. eauto with gensym. apply contained_app; eauto with gensym. - (* for effects *) ++ (* for effects *) exploit H0; eauto. intros [tmp2 [Csyntax D]]. exploit H1; eauto. intros [tmp3 [E F]]. simpl add_dest in *. exists (tmp1 ++ tmp2 ++ tmp3); split. intros; eapply tr_condition_effects; eauto with gensym. apply contained_app; eauto with gensym. - (* for test *) ++ (* for test *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. exploit H1; eauto 10 with gensym. intros [tmp3 [E F]]. simpl add_dest in *. @@ -895,70 +911,70 @@ Opaque makeif. apply contained_cons; eauto with gensym. apply contained_app; eauto with gensym. apply contained_app; eauto with gensym. -(* sizeof *) -- monadInv H. UseFinish. +- (* sizeof *) + monadInv H. UseFinish. exists (@nil ident); split; auto with gensym. constructor. -(* alignof *) -- monadInv H. UseFinish. +- (* alignof *) + monadInv H. UseFinish. exists (@nil ident); split; auto with gensym. constructor. -(* assign *) -- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- (* assign *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. destruct dst; monadInv EQ2; simpl add_dest in *. - (* for value *) ++ (* 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 *) ++ (* for effects *) exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. apply contained_app; eauto with gensym. - (* for set *) ++ (* for set *) exists (x1 :: tmp1 ++ tmp2); split. repeat rewrite app_ass. simpl. intros. eapply tr_assign_val with (dst := For_set sd); 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]]. +- (* assignop *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. exploit transl_valof_meets_spec; eauto. intros [tmp3 [E F]]. destruct dst; monadInv EQ3; simpl add_dest in *. - (* for value *) ++ (* for value *) exists (x2 :: tmp1 ++ tmp2 ++ tmp3); 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 *) ++ (* for effects *) exists (tmp1 ++ tmp2 ++ tmp3); split. econstructor; eauto with gensym. apply contained_app; eauto with gensym. - (* for set *) ++ (* for set *) exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. repeat rewrite app_ass. simpl. intros. eapply tr_assignop_val with (dst := For_set sd); 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]]. +- (* postincr *) + monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0; simpl add_dest in *. - (* for value *) ++ (* for value *) exists (x0 :: tmp1); split. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. - (* for effects *) ++ (* for effects *) exploit transl_valof_meets_spec; eauto. intros [tmp2 [Csyntax D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. eauto with gensym. - (* for set *) ++ (* for set *) 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]]. +- (* comma *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto with gensym. intros [tmp2 [Csyntax D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. @@ -967,47 +983,47 @@ Opaque makeif. simpl. eapply incl_tran. 2: apply add_dest_incl. auto with gensym. destruct dst; simpl; auto with gensym. apply contained_app; eauto with gensym. -(* call *) -- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- (* call *) + monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. destruct dst; monadInv EQ2; simpl add_dest in *. - (* for value *) ++ (* 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 *) ++ (* for effects *) exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. apply contained_app; eauto with gensym. - (* for set *) ++ (* for set *) 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. -(* builtin *) -- monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. +- (* builtin *) + monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0; simpl add_dest in *. - (* for value *) ++ (* for value *) exists (x0 :: tmp1); split. econstructor; eauto with gensym. congruence. apply contained_cons; eauto with gensym. - (* for effects *) ++ (* for effects *) exists tmp1; split. econstructor; eauto with gensym. auto. - (* for set *) ++ (* for set *) exists (x0 :: tmp1); split. repeat rewrite app_ass. econstructor; eauto with gensym. congruence. apply contained_cons; 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]]. +- (* 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 [Csyntax D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. diff --git a/common/AST.v b/common/AST.v index 268e13d5..979db4b9 100644 --- a/common/AST.v +++ b/common/AST.v @@ -105,7 +105,7 @@ Lemma rettype_eq: forall (t1 t2: rettype), {t1=t2} + {t1<>t2}. Proof. generalize typ_eq; decide equality. Defined. Global Opaque rettype_eq. -Fixpoint proj_rettype (r: rettype) : typ := +Definition proj_rettype (r: rettype) : typ := match r with | Tret t => t | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => Tint diff --git a/common/Builtins0.v b/common/Builtins0.v index 8da98314..d84c9112 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -332,6 +332,7 @@ End LOOKUP. Inductive standard_builtin : Type := | BI_select (t: typ) | BI_fabs + | BI_fabsf | BI_fsqrt | BI_negl | BI_addl @@ -364,7 +365,9 @@ Definition standard_builtin_table : list (string * standard_builtin) := :: ("__builtin_sel", BI_select Tfloat) :: ("__builtin_sel", BI_select Tsingle) :: ("__builtin_fabs", BI_fabs) + :: ("__builtin_fabsf", BI_fabsf) :: ("__builtin_fsqrt", BI_fsqrt) + :: ("__builtin_sqrt", BI_fsqrt) :: ("__builtin_negl", BI_negl) :: ("__builtin_addl", BI_addl) :: ("__builtin_subl", BI_subl) @@ -396,6 +399,8 @@ Definition standard_builtin_sig (b: standard_builtin) : signature := mksignature (Tint :: t :: t :: nil) t cc_default | BI_fabs | BI_fsqrt => mksignature (Tfloat :: nil) Tfloat cc_default + | BI_fabsf => + mksignature (Tsingle :: nil) Tsingle cc_default | BI_negl => mksignature (Tlong :: nil) Tlong cc_default | BI_addl | BI_subl | BI_i64_umulh| BI_i64_smulh @@ -428,6 +433,7 @@ Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (sig | _ => None end) _ _ | BI_fabs => mkbuiltin_n1t Tfloat Tfloat Float.abs + | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs | BI_fsqrt => mkbuiltin_n1t Tfloat Tfloat Float.sqrt | BI_negl => mkbuiltin_n1t Tlong Tlong Int64.neg | BI_addl => mkbuiltin_v2t Tlong Val.addl _ _ diff --git a/common/DebugPrint.ml b/common/DebugPrint.ml new file mode 100644 index 00000000..64efe727 --- /dev/null +++ b/common/DebugPrint.ml @@ -0,0 +1,118 @@ +open Maps +open Camlcoq +open Registers + +let debug_flag = ref false + +let debug fmt = + if !debug_flag then (flush stderr; Printf.eprintf fmt) + else Printf.ifprintf stderr fmt + +let print_ptree_bool oc pt = + if !debug_flag then + let elements = PTree.elements pt in + begin + Printf.fprintf oc "["; + List.iter (fun (n, b) -> + if b then Printf.fprintf oc "%d, " (P.to_int n) + ) elements; + Printf.fprintf oc "]\n" + end + else () + +let print_intlist oc l = + let rec f oc = function + | [] -> () + | n::ln -> (Printf.fprintf oc "%d %a" (P.to_int n) f ln) + in begin + if !debug_flag then begin + Printf.fprintf oc "[%a]" f l + end + end + +(* Adapted from backend/PrintRTL.ml: print_function *) +let print_code code = let open PrintRTL in let open Printf in + if (!debug_flag) then begin + fprintf stdout "{\n"; + let instrs = + List.sort + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) + (List.rev_map + (fun (pc, i) -> (P.to_int pc, i)) + (PTree.elements code)) in + List.iter (print_instruction stdout) instrs; + fprintf stdout "}" + end + +let ptree_printbool pt = + let elements = PTree.elements pt + in begin + if !debug_flag then begin + Printf.printf "["; + List.iter (fun (n, b) -> + if b then Printf.printf "%d, " (P.to_int n) else () + ) elements; + Printf.printf "]" + end + end + +let print_ptree printer pt = + let elements = PTree.elements pt in + begin + debug "[\n"; + List.iter (fun (n, elt) -> + debug "\t%d: %a\n" (P.to_int n) printer elt + ) elements; + debug "]\n" + end + +let print_option_pint oc o = + if !debug_flag then + match o with + | None -> Printf.fprintf oc "None" + | Some n -> Printf.fprintf oc "Some %d" (P.to_int n) + +let print_pint oc i = if !debug_flag then Printf.fprintf oc "%d" (P.to_int i) else () + +let print_regset rs = begin + debug "["; + List.iter (fun n -> debug "%d " (P.to_int n)) (Regset.elements rs); + debug "]" +end + +let print_ptree_regset pt = begin + debug "["; + List.iter (fun (n, rs) -> + debug "\n\t"; + debug "%d: " (P.to_int n); + print_regset rs + ) (PTree.elements pt); + debug "]" +end + +let print_true_nodes booltree = begin + debug "["; + List.iter (fun (n,b) -> + if b then debug "%d " (P.to_int n) + ) (PTree.elements booltree); + debug "]"; +end + + +let print_instructions insts code = + let get_some = function + | None -> failwith "Did not get some" + | Some thing -> thing + in if (!debug_flag) then begin + debug "[ "; + List.iter ( + fun n -> (PrintRTL.print_instruction stdout (P.to_int n, get_some @@ PTree.get n code)) + ) insts; debug "]" + end + +let print_arrayp arr = begin + debug "[| "; + Array.iter (fun n -> debug "%d, " (P.to_int n)) arr; + debug "|]" +end + diff --git a/common/Memory.v b/common/Memory.v index cd8a2001..65f36966 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -1322,6 +1322,18 @@ Proof. eapply load_store_same. eassumption. Qed. + +Theorem storev_preserv_valid (b : block) (ofs: Z): valid_pointer m1 b ofs = valid_pointer m2 b ofs. +Proof. + unfold storev in STORE. + cut (valid_pointer m1 b ofs = true <-> valid_pointer m2 b ofs = true). + { destruct (valid_pointer _ _ _), (valid_pointer _ _ _); intuition congruence. } + destruct addr; try congruence. + rewrite! valid_pointer_valid_access. split. + - intros; eapply store_valid_access_1; eauto. + - intros; eapply store_valid_access_2; eauto. +Qed. + End STOREV. Lemma load_store_overlap: diff --git a/common/Values.v b/common/Values.v index 6401ba52..4146dd59 100644 --- a/common/Values.v +++ b/common/Values.v @@ -2613,6 +2613,55 @@ Qed. End VAL_INJ_OPS. +(* Specializations of cmpu_bool, cmpu, cmplu_bool, and cmplu for maximal pointer validity *) + +Definition mxcmpu_bool cmp v1 v2: option bool := + cmpu_bool (fun _ _ => true) cmp v1 v2. + +Lemma mxcmpu_bool_correct vptr (cmp: comparison) (v1 v2: val) b: + cmpu_bool vptr cmp v1 v2 = Some b + -> mxcmpu_bool cmp v1 v2 = Some b. +Proof. + intros; eapply cmpu_bool_lessdef; (econstructor 1 || eauto). +Qed. + +Definition mxcmpu cmp v1 v2 := of_optbool (mxcmpu_bool cmp v1 v2). + +Lemma mxcmpu_correct vptr (cmp: comparison) (v1 v2: val): + lessdef (cmpu vptr cmp v1 v2) (mxcmpu cmp v1 v2). +Proof. + unfold cmpu, mxcmpu. + remember (cmpu_bool _ cmp v1 v2) as ob. + destruct ob; simpl. + - erewrite mxcmpu_bool_correct; eauto. + econstructor. + - econstructor. +Qed. + +Definition mxcmplu_bool (cmp: comparison) (v1 v2: val) + := (cmplu_bool (fun _ _ => true) cmp v1 v2). + +Lemma mxcmplu_bool_correct vptr (cmp: comparison) (v1 v2: val) b: + (cmplu_bool vptr cmp v1 v2) = Some b + -> (mxcmplu_bool cmp v1 v2) = Some b. +Proof. + intros; eapply cmplu_bool_lessdef; (econstructor 1 || eauto). +Qed. + +Definition mxcmplu cmp v1 v2 := of_optbool (mxcmplu_bool cmp v1 v2). + +Lemma mxcmplu_correct vptr (cmp: comparison) (v1 v2: val): + lessdef (maketotal (cmplu vptr cmp v1 v2)) + (mxcmplu cmp v1 v2). +Proof. + unfold cmplu, mxcmplu. + remember (cmplu_bool _ cmp v1 v2) as ob. + destruct ob as [b|]; simpl. + - erewrite mxcmplu_bool_correct; eauto. + simpl. econstructor. + - econstructor. +Qed. + End Val. Notation meminj := Val.meminj. @@ -2706,3 +2755,24 @@ Proof. unfold compose_meminj; rewrite H1; rewrite H3; eauto. rewrite Ptrofs.add_assoc. decEq. unfold Ptrofs.add. apply Ptrofs.eqm_samerepr. auto with ints. Qed. + + +(** Particular cases of extensionality lemma *) + +Lemma cmpu_bool_valid_pointer_eq vptr1 vptr2 c v1 v2: + (forall (b : block) (z : Z), vptr1 b z = vptr2 b z) -> + Val.cmpu_bool vptr1 c v1 v2 = Val.cmpu_bool vptr2 c v1 v2. +Proof. + intros EQ; unfold Val.cmpu_bool; destruct v1; try congruence; + destruct v2; try congruence; + rewrite !EQ; auto. +Qed. + +Lemma cmplu_bool_valid_pointer_eq vptr1 vptr2 c v1 v2: + (forall (b : block) (z : Z), vptr1 b z = vptr2 b z) -> + Val.cmplu_bool vptr1 c v1 v2 = Val.cmplu_bool vptr2 c v1 v2. +Proof. + intros EQ; unfold Val.cmplu_bool; destruct v1; try congruence; + destruct v2; try congruence; + rewrite !EQ; auto. +Qed. @@ -27,6 +27,8 @@ clightgen=false install_coqdev=false responsefile="gnu" ignore_coq_version=false +library_Flocq=local +library_MenhirLib=local usage='Usage: ./configure [options] target For help on options and targets, do: ./configure -help @@ -48,11 +50,11 @@ Supported targets: armeb-hardfloat (ARM, EABI using hardware FP registers, big endian) x86_32-linux (x86 32 bits, Linux) x86_32-bsd (x86 32 bits, BSD) - x86_32-macosx (x86 32 bits, MacOS X) x86_32-cygwin (x86 32 bits, Cygwin environment under Windows) x86_64-linux (x86 64 bits, Linux) x86_64-bsd (x86 64 bits, BSD) x86_64-macosx (x86 64 bits, MacOS X) + x86_64-cygwin (x86 64 bits, Cygwin environment under Windows) rv32-linux (RISC-V 32 bits, Linux) rv64-linux (RISC-V 64 bits, Linux) kvx-mbr (Kalray KVX, bare runtime) @@ -87,6 +89,8 @@ Options: -libdir <dir> Install libraries in <dir> -coqdevdir <dir> Install Coq development (.vo files) in <dir> -toolprefix <pref> Prefix names of tools ("gcc", etc) with <pref> + -use-external-Flocq Use an already-installed Flocq library + -use-external-MenhirLib Use an already-installed MenhirLib library -no-runtime-lib Do not compile nor install the runtime support library -no-standard-headers Do not install nor use the standard .h headers -clightgen Also compile and install the clightgen tool @@ -127,6 +131,10 @@ while : ; do ignore_coq_version=true;; -install-coqdev|--install-coqdev|-install-coq-dev|--install-coq-dev) install_coqdev=true;; + -use-external-Flocq|--use-external-Flocq) + library_Flocq=external;; + -use-external-MenhirLib|--use-external-MenhirLib) + library_MenhirLib=external;; -help|--help) echo "$help"; exit 0;; -*) @@ -332,29 +340,6 @@ if test "$arch" = "x86" -a "$bitsize" = "32"; then libmath="-lm" system="linux" ;; - macosx) - # kernel major versions count upwards from 4 for OSX 10.0 to 15 for OSX 10.11 - kernel_major=`uname -r | cut -d "." -f 1` - - abi="macosx" - casm="${toolprefix}gcc" - casm_options="-arch i386 -c" - cc="${toolprefix}gcc -arch i386" - clinker="${toolprefix}gcc" - clinker_needs_no_pie=false - cprepro="${toolprefix}gcc" - cprepro_options="-std=c99 -arch i386 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' -E" - libmath="" - system="macosx" - - if [[ $kernel_major -gt 11 ]]; then - # OSX >= 10.8 - clinker_options="-arch i386 -Wl,-no_pie" - else - # OSX <= 10.7 - clinker_options="-arch i386" - fi - ;; *) echo "Error: invalid eabi/system '$target' for architecture IA32/X86_32." 1>&2 echo "$usage" 1>&2 @@ -407,6 +392,18 @@ if test "$arch" = "x86" -a "$bitsize" = "64"; then libmath="" system="macosx" ;; + cygwin) + abi="standard" + casm="${toolprefix}gcc" + casm_options="-m64 -c" + cc="${toolprefix}gcc -m64" + clinker="${toolprefix}gcc" + clinker_options="-m64" + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -m64 -U__GNUC__ '-D__attribute__(x)=' -E" + libmath="-lm" + system="cygwin" + ;; *) echo "Error: invalid eabi/system '$target' for architecture X86_64." 1>&2 echo "$usage" 1>&2 @@ -568,24 +565,24 @@ missingtools=false echo "Testing Coq... " | tr -d '\n' coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p') case "$coq_ver" in - 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1|8.11.2) + 8.8.0|8.8.1|8.8.2|8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1|8.11.2|8.12.0|8.12.1|8.12.2) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" if $ignore_coq_version; then echo "Warning: this version of Coq is unsupported, proceed at your own risks." else - echo "Error: CompCert requires one of the following Coq versions: 8.11.1, 8.11.0, 8.10.2, 8.10.1, 8.10.0, 8.9.1, 8.9.0" + echo "Error: CompCert requires a version of Coq between 8.8.0 and 8.12.1" missingtools=true fi;; "") echo "NOT FOUND" - echo "Error: make sure Coq version 8.9.1 is installed." + echo "Error: make sure Coq version 8.11.2 is installed." missingtools=true;; esac echo "Testing OCaml... " | tr -d '\n' -ocaml_ver=`ocamlopt -version 2>/dev/null` +ocaml_ver=`ocamlc -version 2>/dev/null` case "$ocaml_ver" in 4.00.*|4.01.*| 4.02.*|4.03.*|4.04.*) echo "version $ocaml_ver -- UNSUPPORTED" @@ -603,9 +600,19 @@ case "$ocaml_ver" in missingtools=true;; esac +echo "Testing OCaml native-code compiler..." | tr -d '\n' +ocamlopt_ver=`ocamlopt -version 2>/dev/null` +if test "$ocamlopt_ver" = "$ocaml_ver"; then + echo "yes" + ocaml_native_comp=true +else + echo "no, will build to bytecode only" + ocaml_native_comp=false +fi + echo "Testing OCaml .opt compilers... " | tr -d '\n' -ocaml_opt_ver=`ocamlopt.opt -version 2>/dev/null` -if test "$ocaml_opt_ver" = "$ocaml_ver"; then +ocamlopt_opt_ver=`ocamlopt.opt -version 2>/dev/null` +if test "$ocamlopt_opt_ver" = "$ocaml_ver"; then echo "yes" ocaml_opt_comp=true else @@ -620,8 +627,11 @@ case "$menhir_ver" in 20[0-9][0-9][0-9][0-9][0-9][0-9]) if test "$menhir_ver" -ge $MENHIR_REQUIRED; then echo "version $menhir_ver -- good!" - menhir_dir=$(menhir --suggest-menhirLib | tr -d '\r' | tr '\\' '/') - if test -z "$menhir_dir"; then + menhir_dir=$(ocamlfind query menhirLib 2>/dev/null) || \ + menhir_dir=$(menhir --suggest-menhirLib) || \ + menhir_dir="" + menhir_dir=$(echo "$menhir_dir" | tr -d '\r' | tr '\\' '/') + if test ! -d "$menhir_dir"; then echo "Error: cannot determine the location of the Menhir API library." echo "This can be due to an incorrect Menhir package." echo "Consider using the OPAM package for Menhir." @@ -660,48 +670,6 @@ if $missingtools; then exit 2 fi -cat > .merlin <<EOF -S lib -S common -S $arch -S backend -S cfrontend -S driver -S debug -S exportclight -S cparser -S extraction - -B lib -B common -B $arch -B backend -B cfrontend -B driver -B debug -B exportclight -B cparser -B extraction - -EOF - -echo "-R lib compcert.lib \ --R common compcert.common \ --R ${arch} compcert.${arch} \ --R backend compcert.backend \ --R midend compcert.midend \ --R cfrontend compcert.cfrontend \ --R driver compcert.driver \ --R flocq compcert.flocq \ --R exportclight compcert.exportclight \ --R cparser compcert.cparser \ --R MenhirLib compcert.MenhirLib" > _CoqProject -case $arch in - x86) - echo "-R x86_${bitsize} compcert.x86_${bitsize}" >> _CoqProject - ;; -esac - # # Generate Makefile.config # @@ -715,6 +683,7 @@ LIBDIR=$libdir MANDIR=$sharedir/man SHAREDIR=$sharedir COQDEVDIR=$coqdevdir +OCAML_NATIVE_COMP=$ocaml_native_comp OCAML_OPT_COMP=$ocaml_opt_comp MENHIR_DIR=$menhir_dir COMPFLAGS=-bin-annot @@ -743,6 +712,8 @@ LIBMATH=$libmath MODEL=$model SYSTEM=$system RESPONSEFILE=$responsefile +LIBRARY_FLOCQ=$library_Flocq +LIBRARY_MENHIRLIB=$library_MenhirLib EOF else cat >> Makefile.config <<'EOF' @@ -836,12 +807,30 @@ CLIGHTGEN=false # Whether the other tools support responsefiles in gnu syntax RESPONSEFILE="none" +# Whether to use the local copies of Flocq and MenhirLib +LIBRARY_FLOCQ=local # external +LIBRARY_MENHIRLIB=local # external +EOF +fi + +if [ "$arch" = "aarch64" ]; then # for aarch64 scheduling +cat >> Makefile.config <<EOF +ARCHDIRS=$arch scheduling/abstractbb scheduling/postpass_lib +BACKENDLIB=Machblock.v Machblockgen.v Machblockgenproof.v OptionMonad.v IterList.v \\ + Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v Asm.v Asmblockprops.v\\ + ForwardSimulationBlock.v PostpassScheduling.v PostpassSchedulingproof.v\\ + Asmblockdeps.v\\ + AbstractBasicBlocksDef.v SeqSimuTheory.v ImpSimuTest.v Parallelizability.v\\ + ImpConfig.v ImpCore.v ImpExtern.v ImpHCons.v ImpIO.v ImpLoops.v ImpMonads.v ImpPrelude.v + # TODO: UPDATE THIS + # DecBoolOps.v Chunks.v Peephole.v ExtValues.v ExtFloats.v +EXTRA_EXTRACTION= Asmgen.Asmgen_expand.loadimm32 Asmgen.Asmgen_expand.addimm64 Asmgen.Asmgen_expand.storeptr EOF fi if [ "$arch" = "kvx" ]; then cat >> Makefile.config <<EOF -ARCHDIRS=$arch $arch/lib $arch/abstractbb $arch/abstractbb/Impure +ARCHDIRS=$arch scheduling/abstractbb scheduling/postpass_lib EXECUTE=kvx-cluster --syscall=libstd_scalls.so -- CFLAGS= -D __KVX_COS__ SIMU=kvx-cluster -- @@ -849,12 +838,40 @@ BACKENDLIB=Machblock.v Machblockgen.v Machblockgenproof.v\\ Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v Asmvliw.v Asmblockprops.v\\ ForwardSimulationBlock.v PostpassScheduling.v PostpassSchedulingproof.v\\ Asmblockdeps.v DecBoolOps.v Chunks.v Peephole.v ExtValues.v ExtFloats.v\\ - AbstractBasicBlocksDef.v SeqSimuTheory.v ImpSimuTest.v Parallelizability.v\\ - ImpConfig.v ImpCore.v ImpExtern.v ImpHCons.v ImpIO.v ImpLoops.v ImpMonads.v ImpPrelude.v + AbstractBasicBlocksDef.v SeqSimuTheory.v ImpSimuTest.v Parallelizability.v EOF fi # +# Generate Merlin and CoqProject files to simplify development +# +cat > .merlin <<EOF +S lib +S common +S $arch +S backend +S cfrontend +S driver +S debug +S exportclight +S cparser +S extraction + +B lib +B common +B $arch +B backend +B cfrontend +B driver +B debug +B exportclight +B cparser +B extraction +EOF + +make CoqProject + +# # Clean up target-dependent files to force their recompilation # rm -f .depend $arch/Archi.vo ${arch}_${bitsize}/Archi.vo runtime/*.o @@ -891,6 +908,9 @@ CompCert configuration: Linker needs '-no-pie'........ $clinker_needs_no_pie Math library.................. $libmath Build command to use.......... $make + Menhir API library............ $menhir_dir + The Flocq library............. $library_Flocq + The MenhirLib library......... $library_MenhirLib Binaries installed in......... $bindirexp Runtime library provided...... $has_runtime_lib Library files installed in.... $libdirexp @@ -1,10 +1,8 @@ #!/bin/sh -# Start coqide with the right -I options +# Start coqide with the right options # Use the Makefile to rebuild dependencies if needed # Recompile the modified file after coqide editing -INCLUDES=`make print-includes` - make -q ${1}o || { make -n ${1}o | grep -v "\\b${1}\\b" | \ (while read cmd; do @@ -12,4 +10,4 @@ make -q ${1}o || { done) } -"${COQBIN}coqide" -async-proofs off $INCLUDES $1 && make ${1}o +"${COQBIN}coqide" -async-proofs off $1 && make ${1}o diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index 696a9a8d..7a00f719 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -50,8 +50,7 @@ let bitfield_table = (Hashtbl.create 57: (ident * string, bitfield_info) Hashtbl.t) let is_bitfield structid fieldname = - try Some (Hashtbl.find bitfield_table (structid, fieldname)) - with Not_found -> None + Hashtbl.find_opt bitfield_table (structid, fieldname) (* Mapping struct/union identifier -> list of members after transformation, including the carrier fields, but without the bit fields. @@ -189,10 +188,12 @@ let rec transf_union_members env id count = function { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} :: transf_union_members env id (count + 1) ms) -let transf_composite env su id attr ml = +let transf_composite env loc su id attr ml = if List.for_all (fun f -> f.fld_bitfield = None) ml then (attr, ml) else begin + if find_custom_attributes ["packed";"__packed__"] attr <> [] then + Diagnostics.error loc "bitfields in packed structs not allowed"; let ml' = match su with | Struct -> transf_struct_members env id 1 ml @@ -550,7 +551,7 @@ and transf_init env i = (* Declarations *) -let transf_decl env (sto, id, ty, init_opt) = +let transf_decl env loc (sto, id, ty, init_opt) = (sto, id, ty, match init_opt with None -> None | Some i -> Some(transf_init env i)) @@ -559,12 +560,12 @@ let transf_decl env (sto, id, ty, init_opt) = let transf_stmt env s = Transform.stmt ~expr:(fun loc env ctx e -> transf_exp env ctx e) - ~decl:transf_decl + ~decl:(fun env (sto, id, ty, init_opt) -> transf_decl env s.sloc (sto, id, ty, init_opt)) env s (* Functions *) -let transf_fundef env f = +let transf_fundef env loc f = Transform.fundef transf_stmt env f (* Programs *) diff --git a/cparser/Cabs.v b/cparser/Cabs.v index 2dae061a..174261ef 100644 --- a/cparser/Cabs.v +++ b/cparser/Cabs.v @@ -92,6 +92,7 @@ with parameter := (* The optional expression is the bitfield *) with field_group := | Field_group : list spec_elem -> list (option name * option expression) -> loc -> field_group + | Field_group_static_assert : expression -> loc -> constant -> loc -> loc -> field_group (* The decl_type is in the order in which they are printed. Only the name of * the declared identifier is pulled out. *) @@ -197,6 +198,7 @@ Inductive definition := | FUNDEF : list spec_elem -> name -> list definition -> statement -> loc -> definition | DECDEF : init_name_group -> loc -> definition (* global variable(s), or function prototype *) | PRAGMA : string -> loc -> definition + | STATIC_ASSERT : expression -> loc -> constant -> loc -> loc -> definition (* ** statements diff --git a/cparser/Cabshelper.ml b/cparser/Cabshelper.ml index 22f3b3c7..7cffef08 100644 --- a/cparser/Cabshelper.ml +++ b/cparser/Cabshelper.ml @@ -44,6 +44,7 @@ let get_definitionloc (d : definition) : loc = | FUNDEF(_, _, _, _, l) -> l | DECDEF(_, l) -> l | PRAGMA(_, l) -> l + | STATIC_ASSERT(_, _, _, _, l) -> l let get_statementloc (s : statement) : loc = begin diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml index 7957375c..86a5e522 100644 --- a/cparser/Diagnostics.ml +++ b/cparser/Diagnostics.ml @@ -400,16 +400,16 @@ let raise_on_errors () = raise Abort let crash exn = - if Version.buildnr <> "" && Version.tag <> "" then begin + if Version.buildnr <> "" && Version.tag <> "" && Version.branch <> "" then begin let backtrace = Printexc.get_backtrace () in - eprintf "%tThis is CompCert, Release %s, Build:%s, Tag:%s%t\n" - bc Version.version Version.buildnr Version.tag rsc; + eprintf "%tThis is CompCert, Release %s, Build:%s, Tag:%s, Branch:%s%t\n" + bc Version.version Version.buildnr Version.tag Version.branch rsc; eprintf "Backtrace (please include this in your support request):\n%s" backtrace; eprintf "%tUncaught exception: %s.\n\ \ Please report this problem to our support.\n\ -\ Error occurred in Build: %s, Tag: %s.\n%t" - rc (Printexc.to_string exn) Version.buildnr Version.tag rsc; +\ Error occurred in Build: %s, Tag: %s, Branch %s.\n%t" + rc (Printexc.to_string exn) Version.buildnr Version.tag Version.branch rsc; exit 2 end else begin let backtrace = Printexc.get_backtrace () diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 0504ad0b..e822dfcb 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -346,10 +346,7 @@ let integer_representable v ik = v >= 0L && v < Int64.shift_left 1L (bitsize - 1) let elab_int_constant loc s0 = - let s = String.map (fun d -> match d with - | '0'..'9' | 'A'..'F' | 'L' | 'U' | 'X' -> d - | 'a'..'f' | 'l' | 'u' | 'x' -> Char.chr (Char.code d - 32) - | _ -> error loc "bad digit '%c' in integer literal '%s'" d s0; d) s0 in + let s = String.uppercase_ascii s0 in (* Determine possible types and chop type suffix *) let (s, dec_kinds, hex_kinds) = if has_suffix s "ULL" || has_suffix s "LLU" then @@ -479,6 +476,23 @@ let elab_simple_string loc wide chars = | CStr s -> s | _ -> error loc "cannot use wide string literal in 'asm'"; "" +(** Elaboration and checking of static assertions *) + +let elab_static_assert env exp loc_exp msg loc_msg loc = + let (exp, env) = !elab_expr_f loc_exp env exp in + match Ceval.integer_expr env exp with + | None -> + error loc_exp "expression in static assertion is not an integer constant" + | Some n -> + if n = 0L then begin + match elab_constant loc_msg msg with + | CStr s -> + error loc "static assertion failed: \"%s\"" s + | _ -> + (* This can happen with a wide string literal *) + error loc "static assertion failed (cannot display associated message)" + end + (** * Elaboration of type expressions, type specifiers, name declarations *) @@ -987,7 +1001,9 @@ and elab_name_group loc env (spec, namelist) = (* Elaboration of a field group *) -and elab_field_group env (Field_group (spec, fieldlist, loc)) = +and elab_field_group env = function + +| Field_group (spec, fieldlist, loc) -> let fieldlist = List.map (function (None, x) -> (Name ("", JUSTBASE, [], loc), x) @@ -999,6 +1015,7 @@ and elab_field_group env (Field_group (spec, fieldlist, loc)) = elab_name_group loc env (spec, List.map fst fieldlist) in if sto <> Storage_default then + (* This should actually never be triggered, catched by pre-parser *) error loc "non-default storage in struct or union"; if fieldlist = [] then (* This should actually never be triggered, empty structs are captured earlier *) @@ -1052,6 +1069,10 @@ and elab_field_group env (Field_group (spec, fieldlist, loc)) = in (mmap2 elab_bitfield env' fieldlist names) +| Field_group_static_assert(exp, loc_exp, msg, loc_msg, loc) -> + elab_static_assert env exp loc_exp msg loc_msg loc; + ([], env) + (* Elaboration of a struct or union. C99 section 6.7.2.1 *) and elab_struct_or_union_info kind loc env members attrs = @@ -1719,11 +1740,12 @@ let elab_expr ctx loc env a = let check_ptr_arith env ty s = match unroll env ty with | TVoid _ -> - error "illegal arithmetic on a pointer to void in binary '%c'" s + error "illegal arithmetic on a pointer to void in %s" s | TFun _ -> - error "illegal arithmetic on a pointer to the function type %a in binary '%c'" (print_typ env) ty s - | _ -> if incomplete_type env ty then - error "arithmetic on a pointer to an incomplete type %a in binary '%c'" (print_typ env) ty s + error "illegal arithmetic on a pointer to the function type %a in %s" (print_typ env) ty s + | _ -> + if incomplete_type env ty then + error "arithmetic on a pointer to an incomplete type %a in %s" (print_typ env) ty s in let check_static_var env id sto ty = @@ -1818,14 +1840,18 @@ let elab_expr ctx loc env a = (preprocessing) --> __builtin_va_arg(ap, ty) (elaboration) --> __builtin_va_arg(ap, sizeof(ty)) *) - | CALL((VARIABLE "__builtin_va_start" as a1), [a2; a3]) -> + | CALL((VARIABLE "__builtin_va_start" as a1), args) -> if not ctx.ctx_vararg then error "'va_start' used in function with fixed args"; - let b1,env = elab env a1 in - let b2,env = elab env a2 in - let _b3,env = elab env a3 in - { edesc = ECall(b1, [b2]); - etyp = TVoid [] },env + let b1, env = elab env a1 in + begin match args with + | [a2; a3] -> + let b2,env = elab env a2 in + let _b3,env = elab env a3 in + { edesc = ECall(b1, [b2]); + etyp = TVoid [] },env + | _ -> fatal_error "'__builtin_va_start' expects 2 arguments" + end | BUILTIN_VA_ARG (a2, a3) -> let ident = @@ -1842,6 +1868,16 @@ let elab_expr ctx loc env a = (print_typ env) ty (print_typ env) ty' (print_typ env) ty' (print_typ env) ty; { edesc = ECall(ident, [b2; b3]); etyp = ty },env + | CALL(VARIABLE "__builtin_constant_p", al) -> + begin match al with + | [a1] -> + let b1,env = elab env a1 in + let v = if Ceval.is_constant_expr env b1 then 1L else 0L in + intconst v IInt, env + | _ -> + fatal_error "'__builtin_constant_p' expects one argument" + end + | CALL((VARIABLE "__builtin_sel" as a0), al) -> begin match al with | [a1; a2; a3] -> @@ -2115,7 +2151,7 @@ let elab_expr ctx loc env a = | _, _ -> fatal_error "invalid operands to binary '+' (%a and %a)" (print_typ env) b1.etyp (print_typ env) b2.etyp in - check_ptr_arith env ty '+'; + check_ptr_arith env ty "binary '+'"; TPtr(ty, []) end in { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres },env @@ -2130,20 +2166,20 @@ let elab_expr ctx loc env a = end else begin match wrap unroll loc env b1.etyp, wrap unroll loc env b2.etyp with | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> - if not (wrap pointer_arithmetic_ok loc env ty) then - error "illegal pointer arithmetic in binary '-'"; + check_ptr_arith env ty "binary '-'"; (TPtr(ty, []), TPtr(ty, [])) | (TPtr(ty1, a1) | TArray(ty1, _, a1)), (TPtr(ty2, a2) | TArray(ty2, _, a2)) -> if not (compatible_types AttrIgnoreAll env ty1 ty2) then error "%a and %a are not pointers to compatible types" (print_typ env) b1.etyp (print_typ env) b1.etyp; - check_ptr_arith env ty1 '-'; - check_ptr_arith env ty2 '-'; + check_ptr_arith env ty1 "binary '-'"; + check_ptr_arith env ty2 "binary '-'"; if wrap sizeof loc env ty1 = Some 0 then error "subtraction between two pointers to zero-sized objects"; (TPtr(ty1, []), TInt(ptrdiff_t_ikind(), [])) - | _, _ -> fatal_error "invalid operands to binary '-' (%a and %a)" + | _, _ -> + fatal_error "invalid operands to binary '-' (%a and %a)" (print_typ env) b1.etyp (print_typ env) b2.etyp end in { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres },env @@ -2301,6 +2337,11 @@ let elab_expr ctx loc env a = error "expression is not assignable"; if not (is_scalar_type env b1.etyp) then error "cannot %s value of type %a" msg (print_typ env) b1.etyp; + begin match unroll env b1.etyp with + | TPtr (ty, _) | TArray (ty, _ , _) -> + check_ptr_arith env ty ("unary " ^ msg) + | _ -> () + end; { edesc = EUnop(op, b1); etyp = b1.etyp },env (* Elaboration of binary operators over integers *) @@ -2657,6 +2698,8 @@ let elab_fundef genv spec name defs body loc = and structs and unions defined in the parameter list. *) let (fun_id, sto, inline, noret, ty, kr_params, genv, lenv) = elab_fundef_name genv spec name in + if Env.is_builtin fun_id.C.name then + error loc "definition of builtin function '%s'" fun_id.C.name; let s = fun_id.C.name in if sto = Storage_auto || sto = Storage_register then fatal_error loc "invalid storage class %s on function" @@ -2847,6 +2890,7 @@ let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool) (* "int f(int x) { ... }" *) (* "int f(x, y) double y; { ... }" *) | FUNDEF(spec, name, defs, body, loc) -> + (* This should actually never be triggered, catched by pre-parser *) if local then error loc "function definition is not allowed here"; let env1 = elab_fundef env spec name defs body loc in ([], env1) @@ -2860,6 +2904,11 @@ let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool) emit_elab env loc (Gpragma s); ([], env) + (* static assertion *) + | STATIC_ASSERT(exp, loc_exp, msg, loc_msg, loc) -> + elab_static_assert env exp loc_exp msg loc_msg loc; + ([], env) + (* Extended asm *) let elab_asm_operand ctx loc env (ASMOPERAND(label, wide, chars, e)) = diff --git a/cparser/Env.ml b/cparser/Env.ml index 4723a725..00806be1 100644 --- a/cparser/Env.ml +++ b/cparser/Env.ml @@ -316,6 +316,9 @@ let set_builtins blt = List.iter Init.add_typedef blt.builtin_typedefs; List.iter Init.add_function blt.builtin_functions +let is_builtin name = + ident_is_bound !Init.env name + (* Error reporting *) open Printf diff --git a/cparser/Env.mli b/cparser/Env.mli index 1baab68f..589a76c7 100644 --- a/cparser/Env.mli +++ b/cparser/Env.mli @@ -84,3 +84,4 @@ val initial: unit -> t val initial_identifiers: unit -> C.ident list val initial_declarations: unit -> C.globdecl list val set_builtins: C.builtins -> unit +val is_builtin : string -> bool diff --git a/cparser/ExtendedAsm.ml b/cparser/ExtendedAsm.ml index 257e9cf7..df2da2a2 100644 --- a/cparser/ExtendedAsm.ml +++ b/cparser/ExtendedAsm.ml @@ -156,7 +156,7 @@ let transf_outputs loc env = function let check_clobbers loc clob = List.iter (fun c -> - if Machregsaux.register_by_name c <> None + if Machregsnames.register_by_name c <> None || Machregsaux.is_scratch_register c || c = "memory" || c = "cc" (* GCC does not accept MEMORY or CC *) then () diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index b36b3e81..f5e8edb3 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -35,6 +35,7 @@ let () = ("_Bool", fun loc -> UNDERSCORE_BOOL loc); ("_Complex", fun loc -> reserved_keyword loc "_Complex"); ("_Imaginary", fun loc -> reserved_keyword loc "_Imaginary"); + ("_Static_assert", fun loc -> STATIC_ASSERT loc); ("__alignof", fun loc -> ALIGNOF loc); ("__alignof__", fun loc -> ALIGNOF loc); ("__asm", fun loc -> ASM loc); @@ -579,6 +580,7 @@ and singleline_comment = parse | Pre_parser.SLASH loc -> loop (Parser.SLASH loc) | Pre_parser.STAR loc -> loop (Parser.STAR loc) | Pre_parser.STATIC loc -> loop (Parser.STATIC loc) + | Pre_parser.STATIC_ASSERT loc -> loop (Parser.STATIC_ASSERT loc) | Pre_parser.STRING_LITERAL (wide, str, loc) -> (* Merge consecutive string literals *) let rec doConcat wide str = diff --git a/cparser/Machine.ml b/cparser/Machine.ml index 97ca9223..73b71ea0 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -61,6 +61,7 @@ type t = { supports_unaligned_accesses: bool; struct_passing_style: struct_passing_style; struct_return_style : struct_return_style; + has_non_trapping_loads : bool; } let ilp32ll64 = { @@ -96,6 +97,7 @@ let ilp32ll64 = { supports_unaligned_accesses = false; struct_passing_style = SP_ref_callee; struct_return_style = SR_ref; + has_non_trapping_loads = false; } let i32lpll64 = { @@ -131,6 +133,7 @@ let i32lpll64 = { supports_unaligned_accesses = false; struct_passing_style = SP_ref_callee; struct_return_style = SR_ref; + has_non_trapping_loads = false; } let il32pll64 = { @@ -166,6 +169,7 @@ let il32pll64 = { supports_unaligned_accesses = false; struct_passing_style = SP_ref_callee; struct_return_style = SR_ref; + has_non_trapping_loads = false; } (* Canned configurations for some ABIs *) @@ -270,7 +274,9 @@ let kvx = bitfields_msb_first = false; (* TO CHECK *) supports_unaligned_accesses = true; struct_passing_style = SP_value32_ref_callee; - struct_return_style = SR_int1to4 } + struct_return_style = SR_int1to4; + has_non_trapping_loads = true; +} let aarch64 = { i32lpll64 with name = "aarch64"; @@ -323,6 +329,7 @@ let undef = { supports_unaligned_accesses = false; struct_passing_style = SP_ref_callee; struct_return_style = SR_ref; + has_non_trapping_loads = false; } (* The current configuration. Must be initialized before use. *) diff --git a/cparser/Machine.mli b/cparser/Machine.mli index 0e1e22d1..54436758 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -60,6 +60,7 @@ type t = { supports_unaligned_accesses: bool; struct_passing_style: struct_passing_style; struct_return_style: struct_return_style; + has_non_trapping_loads: bool; } (* The current configuration *) diff --git a/cparser/Parse.ml b/cparser/Parse.ml index 29245083..d9f9aa1c 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -18,7 +18,14 @@ module CharSet = Set.Make(struct type t = char let compare = compare end) let transform_program t p name = - let run_pass pass flag p = if CharSet.mem flag t then pass p else p in + let run_pass pass flag p = + if CharSet.mem flag t then begin + let p = pass p in + Diagnostics.check_errors (); + p + end else + p + in let p1 = (run_pass StructPassing.program 's' (run_pass PackedStructs.program 'p' (run_pass Unblock.program 'b' diff --git a/cparser/Parser.vy b/cparser/Parser.vy index 4f3b9789..ebed6e34 100644 --- a/cparser/Parser.vy +++ b/cparser/Parser.vy @@ -37,7 +37,7 @@ Require Cabs. STRUCT UNION ENUM UNDERSCORE_BOOL PACKED ALIGNAS ATTRIBUTE ASM %token<Cabs.loc> CASE DEFAULT IF_ ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK - RETURN BUILTIN_VA_ARG BUILTIN_OFFSETOF + RETURN BUILTIN_VA_ARG BUILTIN_OFFSETOF STATIC_ASSERT %token EOF @@ -55,6 +55,8 @@ Require Cabs. %type<list Cabs.spec_elem> declaration_specifiers_typespec_opt %type<list Cabs.init_name (* Reverse order *)> init_declarator_list %type<Cabs.init_name> init_declarator +%type<(Cabs.expression * Cabs.loc) * (Cabs.constant * Cabs.loc) * Cabs.loc> + static_assert_declaration %type<Cabs.storage * Cabs.loc> storage_class_specifier %type<Cabs.typeSpecifier * Cabs.loc> type_specifier struct_or_union_specifier enum_specifier %type<Cabs.structOrUnion * Cabs.loc> struct_or_union @@ -343,6 +345,9 @@ declaration: { Cabs.DECDEF (fst decspec, rev' decls) (snd decspec) } | decspec = declaration_specifiers SEMICOLON { Cabs.DECDEF (fst decspec, []) (snd decspec) } +| asrt = static_assert_declaration + { let '((e, loc_e), (s, loc_s), loc) := asrt in + Cabs.STATIC_ASSERT e loc_e s loc_s loc } declaration_specifiers_typespec_opt: | storage = storage_class_specifier rest = declaration_specifiers_typespec_opt @@ -461,6 +466,10 @@ struct_declaration: (* Extension to C99 grammar needed to parse some GNU header files. *) | decspec = specifier_qualifier_list SEMICOLON { Cabs.Field_group (fst decspec) [(None,None)] (snd decspec) } +(* C11 static assertions *) +| asrt = static_assert_declaration + { let '((e, loc_e), (s, loc_s), loc) := asrt in + Cabs.Field_group_static_assert e loc_e s loc_s loc } specifier_qualifier_list: | typ = type_specifier rest = specifier_qualifier_list @@ -751,6 +760,14 @@ designator: | DOT id = OTHER_NAME { Cabs.INFIELD_INIT (fst id) } +(* C11 6.7.10 *) + +static_assert_declaration: +| loc = STATIC_ASSERT LPAREN expr = constant_expression + COMMA str = STRING_LITERAL RPAREN SEMICOLON + { let '((wide, chars), locs) := str in + (expr, (Cabs.CONST_STRING wide chars, locs), loc) } + (* 6.8 *) statement_dangerous: | stmt = labeled_statement(statement_dangerous) diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml index 3aff090e..6d63b8f9 100644 --- a/cparser/StructPassing.ml +++ b/cparser/StructPassing.ml @@ -433,7 +433,7 @@ and transf_init env = function (* Declarations *) -let transf_decl env (sto, id, ty, init) = +let transf_decl env loc (sto, id, ty, init) = (sto, id, transf_type env ty, match init with None -> None | Some i -> Some (transf_init env i)) @@ -503,7 +503,7 @@ let rec transf_stmt s = | Sblock sl -> {s with sdesc = Sblock(List.map transf_stmt sl)} | Sdecl d -> - {s with sdesc = Sdecl(transf_decl env d)} + {s with sdesc = Sdecl(transf_decl env s.sloc d)} | Sasm(attr, template, outputs, inputs, clob) -> {s with sdesc = Sasm(attr, template, List.map transf_asm_operand outputs, @@ -549,13 +549,13 @@ let rec transf_funparams loc env params = actions, IdentMap.add x (ereinterpret tx' y) subst) -let transf_fundef env f = +let transf_fundef env loc f = reset_temps(); let ret = transf_type env f.fd_ret in let (params, actions, subst) = transf_funparams f.fd_body.sloc env f.fd_params in let locals = - List.map (fun d -> transf_decl env (subst_decl subst d)) f.fd_locals in + List.map (fun d -> transf_decl env loc (subst_decl subst d)) f.fd_locals in let (attr1, ret1, params1, body1) = match classify_return env f.fd_ret with | Ret_scalar -> @@ -586,7 +586,7 @@ let transf_fundef env f = (* Composites *) -let transf_composite env su id attr fl = +let transf_composite env loc su id attr fl = (attr, List.map (fun f -> {f with fld_typ = transf_type env f.fld_typ}) fl) (* Entry point *) @@ -604,5 +604,5 @@ let program p = ~decl:transf_decl ~fundef:transf_fundef ~composite:transf_composite - ~typedef:(fun env id ty -> transf_type env ty) + ~typedef:(fun env loc id ty -> transf_type env ty) p diff --git a/cparser/Transform.ml b/cparser/Transform.ml index 349a3155..a57d94c4 100644 --- a/cparser/Transform.ml +++ b/cparser/Transform.ml @@ -161,8 +161,8 @@ let stmt ~expr ?(decl = fun env decl -> assert false) env s = | Scontinue -> s | Sswitch(e, s1) -> {s with sdesc = Sswitch(expr s.sloc env Val e, stm s1)} - | Slabeled(lbl, s) -> - {s with sdesc = Slabeled(lbl, stm s)} + | Slabeled(lbl, s1) -> + {s with sdesc = Slabeled(lbl, stm s1)} | Sgoto lbl -> s | Sreturn None -> s | Sreturn (Some e) -> @@ -191,12 +191,12 @@ let fundef trstmt env f = (* Generic transformation of a program *) let program - ?(decl = fun env d -> d) - ?(fundef = fun env fd -> fd) - ?(composite = fun env su id attr fl -> (attr, fl)) - ?(typedef = fun env id ty -> ty) - ?(enum = fun env id attr members -> (attr, members)) - ?(pragma = fun env s -> s) + ?(decl = fun env loc d -> d) + ?(fundef = fun env loc fd -> fd) + ?(composite = fun env loc su id attr fl -> (attr, fl)) + ?(typedef = fun env loc id ty -> ty) + ?(enum = fun env loc id attr members -> (attr, members)) + ?(pragma = fun env loc s -> s) p = let rec transf_globdecls env accu = function @@ -205,25 +205,25 @@ let program let (desc', env') = match g.gdesc with | Gdecl((sto, id, ty, init) as d) -> - (Gdecl(decl env d), Env.add_ident env id sto ty) + (Gdecl(decl env g.gloc d), Env.add_ident env id sto ty) | Gfundef f -> - (Gfundef(fundef env f), + (Gfundef(fundef env g.gloc f), Env.add_ident env f.fd_name f.fd_storage (fundef_typ f)) | Gcompositedecl(su, id, attr) -> (Gcompositedecl(su, id, attr), Env.add_composite env id (composite_info_decl su attr)) | Gcompositedef(su, id, attr, fl) -> - let (attr', fl') = composite env su id attr fl in + let (attr', fl') = composite env g.gloc su id attr fl in (Gcompositedef(su, id, attr', fl'), Env.add_composite env id (composite_info_def env su attr fl)) | Gtypedef(id, ty) -> - (Gtypedef(id, typedef env id ty), Env.add_typedef env id ty) + (Gtypedef(id, typedef env g.gloc id ty), Env.add_typedef env id ty) | Genumdef(id, attr, members) -> - let (attr', members') = enum env id attr members in + let (attr', members') = enum env g.gloc id attr members in (Genumdef(id, attr', members'), Env.add_enum env id {ei_members = members; ei_attr = attr}) | Gpragma s -> - (Gpragma(pragma env s), env) + (Gpragma(pragma env g.gloc s), env) in transf_globdecls env' ({g with gdesc = desc'} :: accu) gl diff --git a/cparser/Transform.mli b/cparser/Transform.mli index dbd8e575..220b7944 100644 --- a/cparser/Transform.mli +++ b/cparser/Transform.mli @@ -62,14 +62,14 @@ val fundef : (Env.t -> C.stmt -> C.stmt) -> Env.t -> C.fundef -> C.fundef (** Generic transformation of a program *) val program : - ?decl:(Env.t -> C.decl -> C.decl) -> - ?fundef:(Env.t -> C.fundef -> C.fundef) -> - ?composite:(Env.t -> C.struct_or_union -> + ?decl:(Env.t -> C.location -> C.decl -> C.decl) -> + ?fundef:(Env.t -> C.location -> C.fundef -> C.fundef) -> + ?composite:(Env.t -> C.location -> C.struct_or_union -> C.ident -> C.attributes -> C.field list -> C.attributes * C.field list) -> - ?typedef:(Env.t -> C.ident -> C.typ -> C.typ) -> - ?enum:(Env.t -> C.ident -> C.attributes -> C.enumerator list -> + ?typedef:(Env.t -> C.location -> C.ident -> C.typ -> C.typ) -> + ?enum:(Env.t -> C.location -> C.ident -> C.attributes -> C.enumerator list -> C.attributes * C.enumerator list) -> - ?pragma:(Env.t -> string -> string) -> + ?pragma:(Env.t -> C.location -> string -> string) -> C.program -> C.program diff --git a/cparser/deLexer.ml b/cparser/deLexer.ml index 43c1a679..e2f4f77f 100644 --- a/cparser/deLexer.ml +++ b/cparser/deLexer.ml @@ -117,6 +117,7 @@ let delex (symbol : string) : string = | "DOT" -> "." | "PRAGMA" -> "#pragma \n" | "BUILTIN_OFFSETOF" -> "__builtin_offsetof" + | "STATIC_ASSERT" -> "_Static_assert" | "EOF" -> "" (* this should be ok *) | _ -> raise Not_found (* this should not happen *) diff --git a/cparser/handcrafted.messages b/cparser/handcrafted.messages index 6d972439..23e90b3e 100644 --- a/cparser/handcrafted.messages +++ b/cparser/handcrafted.messages @@ -179,22 +179,22 @@ # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN INT XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN INT XOR_ASSIGN ## -## Ends in an error in state: 314. +## Ends in an error in state: 322. ## ## attribute_specifier -> ALIGNAS LPAREN type_name . RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ALIGNAS LPAREN type_name +## ALIGNAS LPAREN type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## # Maybe the type name was not complete, but we have reduced anyway @@ -212,40 +212,40 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ ALIGNOF LPAREN VOID XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ ALIGNOF LPAREN VOID XOR_ASSIGN ## -## Ends in an error in state: 304. +## Ends in an error in state: 312. ## ## unary_expression -> ALIGNOF LPAREN type_name . RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## ALIGNOF LPAREN type_name +## ALIGNOF LPAREN type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF LPAREN VOID XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF LPAREN VOID XOR_ASSIGN ## -## Ends in an error in state: 388. +## Ends in an error in state: 396. ## ## postfix_expression -> LPAREN type_name . RPAREN LBRACE initializer_list option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## unary_expression -> SIZEOF LPAREN type_name . RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## SIZEOF LPAREN type_name +## SIZEOF LPAREN type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## Ill-formed use of $2. @@ -256,22 +256,22 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN PRE_NAME VAR_NAME COMMA VOID XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN PRE_NAME VAR_NAME COMMA VOID XOR_ASSIGN ## -## Ends in an error in state: 333. +## Ends in an error in state: 341. ## ## postfix_expression -> BUILTIN_VA_ARG LPAREN assignment_expression COMMA type_name . RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_VA_ARG LPAREN assignment_expression COMMA type_name +## BUILTIN_VA_ARG LPAREN assignment_expression COMMA type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## Ill-formed use of __builtin_va_arg. @@ -282,22 +282,22 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN VOID XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN VOID XOR_ASSIGN ## -## Ends in an error in state: 363. +## Ends in an error in state: 371. ## ## postfix_expression -> LPAREN type_name . RPAREN LBRACE initializer_list option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN type_name +## LPAREN type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## # gcc simply says it expects a closing parenthesis, @@ -311,23 +311,23 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN VOID XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN VOID XOR_ASSIGN ## -## Ends in an error in state: 385. +## Ends in an error in state: 393. ## ## cast_expression -> LPAREN type_name . RPAREN cast_expression [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## postfix_expression -> LPAREN type_name . RPAREN LBRACE initializer_list option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN type_name +## LPAREN type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## # gcc and clang say they expect a closing parenthesis. @@ -339,35 +339,35 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: ALIGNAS LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 316. +## Ends in an error in state: 324. ## ## argument_expression_list -> argument_expression_list . COMMA assignment_expression [ RPAREN COMMA ] ## attribute_specifier -> ALIGNAS LPAREN argument_expression_list . RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ALIGNAS LPAREN argument_expression_list +## ALIGNAS LPAREN argument_expression_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 230, spurious reduction of production argument_expression_list -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 155, spurious reduction of production argument_expression_list -> assignment_expression ## # We are trying to recognize an alignas specifier. @@ -389,27 +389,27 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN INT LBRACK RPAREN +translation_unit_file: ALIGNAS LPAREN INT LBRACK RPAREN ## -## Ends in an error in state: 151. +## Ends in an error in state: 248. ## ## direct_abstract_declarator -> option(direct_abstract_declarator) LBRACK option(type_qualifier_list) . optional(assignment_expression,RBRACK) [ RPAREN LPAREN LBRACK COMMA ] ## type_qualifier_list -> option(type_qualifier_list) . type_qualifier_noattr [ VOLATILE TILDE STRING_LITERAL STAR SIZEOF RESTRICT RBRACK PRE_NAME PLUS PACKED MINUS LPAREN INC DEC CONSTANT CONST BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG ATTRIBUTE AND ALIGNOF ALIGNAS ] ## type_qualifier_list -> option(type_qualifier_list) . attribute_specifier [ VOLATILE TILDE STRING_LITERAL STAR SIZEOF RESTRICT RBRACK PRE_NAME PLUS PACKED MINUS LPAREN INC DEC CONSTANT CONST BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## option(direct_abstract_declarator) LBRACK option(type_qualifier_list) +## option(direct_abstract_declarator) LBRACK option(type_qualifier_list) ## -translation_unit_file: INT PRE_NAME VAR_NAME LBRACK RPAREN +translation_unit_file: INT PRE_NAME VAR_NAME LBRACK RPAREN ## -## Ends in an error in state: 257. +## Ends in an error in state: 265. ## ## direct_declarator -> direct_declarator LBRACK option(type_qualifier_list) . optional(assignment_expression,RBRACK) [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## type_qualifier_list -> option(type_qualifier_list) . type_qualifier_noattr [ VOLATILE TILDE STRING_LITERAL STAR SIZEOF RESTRICT RBRACK PRE_NAME PLUS PACKED MINUS LPAREN INC DEC CONSTANT CONST BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG ATTRIBUTE AND ALIGNOF ALIGNAS ] ## type_qualifier_list -> option(type_qualifier_list) . attribute_specifier [ VOLATILE TILDE STRING_LITERAL STAR SIZEOF RESTRICT RBRACK PRE_NAME PLUS PACKED MINUS LPAREN INC DEC CONSTANT CONST BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## direct_declarator LBRACK option(type_qualifier_list) +## direct_declarator LBRACK option(type_qualifier_list) ## # We are trying to recognize an array declarator. @@ -434,32 +434,32 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN INT LPAREN INT COMMA ELLIPSIS XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN INT LPAREN INT COMMA ELLIPSIS XOR_ASSIGN ## -## Ends in an error in state: 268. +## Ends in an error in state: 276. ## ## direct_abstract_declarator -> LPAREN option(context_parameter_type_list) . RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## LPAREN option(context_parameter_type_list) +## LPAREN option(context_parameter_type_list) ## -translation_unit_file: ALIGNAS LPAREN INT LBRACK RBRACK LPAREN INT COMMA ELLIPSIS XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN INT LBRACK RBRACK LPAREN INT COMMA ELLIPSIS XOR_ASSIGN ## -## Ends in an error in state: 251. +## Ends in an error in state: 259. ## ## direct_abstract_declarator -> direct_abstract_declarator LPAREN option(context_parameter_type_list) . RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## direct_abstract_declarator LPAREN option(context_parameter_type_list) +## direct_abstract_declarator LPAREN option(context_parameter_type_list) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT COMMA ELLIPSIS XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT COMMA ELLIPSIS XOR_ASSIGN ## -## Ends in an error in state: 285. +## Ends in an error in state: 293. ## ## direct_declarator -> direct_declarator LPAREN context_parameter_type_list . RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## direct_declarator LPAREN context_parameter_type_list +## direct_declarator LPAREN context_parameter_type_list ## # Unlikely error, since only the ELLIPSIS allows us to tell that @@ -469,20 +469,20 @@ At this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN INT LPAREN LPAREN RPAREN COMMA +translation_unit_file: ALIGNAS LPAREN INT LPAREN LPAREN RPAREN COMMA ## -## Ends in an error in state: 266. +## Ends in an error in state: 274. ## ## direct_abstract_declarator -> LPAREN save_context abstract_declarator(type_name) . RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## LPAREN save_context abstract_declarator(type_name) +## LPAREN save_context abstract_declarator(type_name) ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 259, spurious reduction of production abstract_declarator(type_name) -> direct_abstract_declarator +## In state 267, spurious reduction of production abstract_declarator(type_name) -> direct_abstract_declarator ## # # The first LPAREN in this example must be the beginning of an abstract_declarator. @@ -511,15 +511,15 @@ At this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN INT LPAREN XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN INT LPAREN XOR_ASSIGN ## -## Ends in an error in state: 307. +## Ends in an error in state: 315. ## ## direct_abstract_declarator -> LPAREN . save_context abstract_declarator(type_name) RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## direct_abstract_declarator -> LPAREN . option(context_parameter_type_list) RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## LPAREN +## LPAREN ## # gcc and clang both say they want a closing parenthesis. @@ -534,16 +534,16 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT LPAREN XOR_ASSIGN ## -## Ends in an error in state: 145. +## Ends in an error in state: 242. ## ## direct_abstract_declarator -> LPAREN . save_context abstract_declarator(type_name) RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## direct_abstract_declarator -> LPAREN . option(context_parameter_type_list) RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## direct_declarator -> LPAREN . save_context declarator RPAREN [ RPAREN PACKED LPAREN LBRACK COMMA ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## LPAREN +## LPAREN ## # Analogous to the above, but has a third item. @@ -557,16 +557,16 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN VOLATILE ADD_ASSIGN +translation_unit_file: ALIGNAS LPAREN VOLATILE ADD_ASSIGN ## -## Ends in an error in state: 299. +## Ends in an error in state: 307. ## ## option(type_qualifier_list) -> type_qualifier_list . [ VOLATILE RESTRICT PACKED CONST ATTRIBUTE ALIGNAS ] ## specifier_qualifier_list(type_name) -> type_qualifier_list . typedef_name option(type_qualifier_list) [ STAR RPAREN LPAREN LBRACK COMMA ] ## specifier_qualifier_list(type_name) -> type_qualifier_list . type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) [ STAR RPAREN LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## type_qualifier_list +## type_qualifier_list ## # We are trying to recognize a specifier-qualifier-list, and have not yet seen @@ -582,7 +582,7 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN XOR_ASSIGN ## ## Ends in an error in state: 61. ## @@ -590,7 +590,7 @@ translation_unit_file: ALIGNAS LPAREN XOR_ASSIGN ## attribute_specifier -> ALIGNAS LPAREN . type_name RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ALIGNAS LPAREN +## ALIGNAS LPAREN ## # This one seems easy. We have recognized ALIGNAS LPAREN, and nothing that makes sense beyond that. @@ -604,7 +604,7 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS XOR_ASSIGN +translation_unit_file: ALIGNAS XOR_ASSIGN ## ## Ends in an error in state: 60. ## @@ -612,7 +612,7 @@ translation_unit_file: ALIGNAS XOR_ASSIGN ## attribute_specifier -> ALIGNAS . LPAREN type_name RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ALIGNAS +## ALIGNAS ## # Fingers in the nose. @@ -622,14 +622,14 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN COMMA XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN COMMA XOR_ASSIGN ## -## Ends in an error in state: 345. +## Ends in an error in state: 353. ## ## gcc_attribute_list -> gcc_attribute_list COMMA . gcc_attribute [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## gcc_attribute_list COMMA +## gcc_attribute_list COMMA ## # We are expecting a gcc_attribute. This symbol is nullable, so @@ -644,14 +644,14 @@ At this point, a gcc attribute is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN RPAREN XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN RPAREN XOR_ASSIGN ## -## Ends in an error in state: 343. +## Ends in an error in state: 351. ## ## attribute_specifier -> ATTRIBUTE LPAREN LPAREN gcc_attribute_list RPAREN . RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ATTRIBUTE LPAREN LPAREN gcc_attribute_list RPAREN +## ATTRIBUTE LPAREN LPAREN gcc_attribute_list RPAREN ## Ill-formed attribute specifier. @@ -659,15 +659,15 @@ At this point, a second closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN RPAREN XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN RPAREN XOR_ASSIGN ## -## Ends in an error in state: 342. +## Ends in an error in state: 350. ## ## attribute_specifier -> ATTRIBUTE LPAREN LPAREN gcc_attribute_list . RPAREN RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## gcc_attribute_list -> gcc_attribute_list . COMMA gcc_attribute [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## ATTRIBUTE LPAREN LPAREN gcc_attribute_list +## ATTRIBUTE LPAREN LPAREN gcc_attribute_list ## # We have a seen a (non-empty) attribute list, so we expect either @@ -682,35 +682,35 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME COMMA PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME COMMA PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 338. +## Ends in an error in state: 346. ## ## argument_expression_list -> argument_expression_list . COMMA assignment_expression [ RPAREN COMMA ] ## gcc_attribute -> gcc_attribute_word LPAREN typedef_name COMMA argument_expression_list . RPAREN [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## gcc_attribute_word LPAREN typedef_name COMMA argument_expression_list +## gcc_attribute_word LPAREN typedef_name COMMA argument_expression_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 230, spurious reduction of production argument_expression_list -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 155, spurious reduction of production argument_expression_list -> assignment_expression ## # We know for sure that we are parsing a gcc attribute. @@ -726,14 +726,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME COMMA XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 337. +## Ends in an error in state: 345. ## ## gcc_attribute -> gcc_attribute_word LPAREN typedef_name COMMA . argument_expression_list RPAREN [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## gcc_attribute_word LPAREN typedef_name COMMA +## gcc_attribute_word LPAREN typedef_name COMMA ## # gcc/clang agree. @@ -743,14 +743,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 336. +## Ends in an error in state: 344. ## ## gcc_attribute -> gcc_attribute_word LPAREN typedef_name . COMMA argument_expression_list RPAREN [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## gcc_attribute_word LPAREN typedef_name +## gcc_attribute_word LPAREN typedef_name ## # gcc and clang complain about the TYPEDEF_NAME, not sure why. @@ -760,7 +760,7 @@ At this point, a comma ',' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN XOR_ASSIGN ## ## Ends in an error in state: 47. ## @@ -768,7 +768,7 @@ translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME LPAREN XOR_ASSI ## gcc_attribute -> gcc_attribute_word LPAREN . typedef_name COMMA argument_expression_list RPAREN [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## gcc_attribute_word LPAREN +## gcc_attribute_word LPAREN ## # gcc and clang just say they expect an expression. @@ -780,7 +780,7 @@ At this point, a list of expressions is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME XOR_ASSIGN ## ## Ends in an error in state: 46. ## @@ -789,7 +789,7 @@ translation_unit_file: ATTRIBUTE LPAREN LPAREN PRE_NAME VAR_NAME XOR_ASSIGN ## gcc_attribute -> gcc_attribute_word . LPAREN typedef_name COMMA argument_expression_list RPAREN [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## gcc_attribute_word +## gcc_attribute_word ## # gcc and clang say they expect a closing parenthesis (as usual). @@ -806,14 +806,14 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN LPAREN XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN LPAREN XOR_ASSIGN ## ## Ends in an error in state: 39. ## ## attribute_specifier -> ATTRIBUTE LPAREN LPAREN . gcc_attribute_list RPAREN RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ATTRIBUTE LPAREN LPAREN +## ATTRIBUTE LPAREN LPAREN ## # A non-empty attribute list is expected. @@ -828,14 +828,14 @@ At this point, a gcc attribute is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE LPAREN XOR_ASSIGN +translation_unit_file: ATTRIBUTE LPAREN XOR_ASSIGN ## ## Ends in an error in state: 38. ## ## attribute_specifier -> ATTRIBUTE LPAREN . LPAREN gcc_attribute_list RPAREN RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ATTRIBUTE LPAREN +## ATTRIBUTE LPAREN ## Ill-formed gcc attribute specifier. @@ -843,14 +843,14 @@ At this point, a second opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ATTRIBUTE XOR_ASSIGN +translation_unit_file: ATTRIBUTE XOR_ASSIGN ## ## Ends in an error in state: 37. ## ## attribute_specifier -> ATTRIBUTE . LPAREN LPAREN gcc_attribute_list RPAREN RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ATTRIBUTE +## ATTRIBUTE ## Ill-formed gcc attribute specifier. @@ -858,15 +858,15 @@ At this point, two opening parentheses '((' are expected. # ------------------------------------------------------------------------------ -translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 353. +## Ends in an error in state: 361. ## ## enumerator_list -> enumerator_list COMMA . declare_varname(enumerator) [ RBRACE COMMA ] ## option(COMMA) -> COMMA . [ RBRACE ] ## ## The known suffix of the stack is as follows: -## enumerator_list COMMA +## enumerator_list COMMA ## # We omit the possibility of a closing brace. @@ -879,36 +879,36 @@ At this point, an enumerator is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME EQ CONSTANT SEMICOLON +translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME EQ CONSTANT SEMICOLON ## -## Ends in an error in state: 352. +## Ends in an error in state: 360. ## ## enum_specifier -> ENUM attribute_specifier_list option(other_identifier) LBRACE enumerator_list . option(COMMA) RBRACE [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## enumerator_list -> enumerator_list . COMMA declare_varname(enumerator) [ RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## ENUM attribute_specifier_list option(other_identifier) LBRACE enumerator_list +## ENUM attribute_specifier_list option(other_identifier) LBRACE enumerator_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 154, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 357, spurious reduction of production enumerator -> enumeration_constant EQ conditional_expression -## In state 354, spurious reduction of production declare_varname(enumerator) -> enumerator -## In state 361, spurious reduction of production enumerator_list -> declare_varname(enumerator) +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 79, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 365, spurious reduction of production enumerator -> enumeration_constant EQ conditional_expression +## In state 362, spurious reduction of production declare_varname(enumerator) -> enumerator +## In state 369, spurious reduction of production enumerator_list -> declare_varname(enumerator) ## # # At first sight, it seems that the last enumerator that we have recognized @@ -937,14 +937,14 @@ then at this point, a closing brace '}' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME EQ XOR_ASSIGN +translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME EQ XOR_ASSIGN ## -## Ends in an error in state: 356. +## Ends in an error in state: 364. ## ## enumerator -> enumeration_constant EQ . conditional_expression [ RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## enumeration_constant EQ +## enumeration_constant EQ ## Ill-formed enumeration specifier. @@ -952,15 +952,15 @@ At this point, a constant expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: ENUM LBRACE PRE_NAME VAR_NAME XOR_ASSIGN ## -## Ends in an error in state: 355. +## Ends in an error in state: 363. ## ## enumerator -> enumeration_constant . [ RBRACE COMMA ] ## enumerator -> enumeration_constant . EQ conditional_expression [ RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## enumeration_constant +## enumeration_constant ## # Here, both clang and gcc give an incomplete diagnostic message. @@ -973,14 +973,14 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: ENUM LBRACE XOR_ASSIGN +translation_unit_file: ENUM LBRACE XOR_ASSIGN ## -## Ends in an error in state: 350. +## Ends in an error in state: 358. ## ## enum_specifier -> ENUM attribute_specifier_list option(other_identifier) LBRACE . enumerator_list option(COMMA) RBRACE [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ENUM attribute_specifier_list option(other_identifier) LBRACE +## ENUM attribute_specifier_list option(other_identifier) LBRACE ## # gcc says it expects an identifier. @@ -991,15 +991,15 @@ At this point, an enumerator is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ENUM XOR_ASSIGN +translation_unit_file: ENUM XOR_ASSIGN ## -## Ends in an error in state: 348. +## Ends in an error in state: 356. ## ## enum_specifier -> ENUM attribute_specifier_list . option(other_identifier) LBRACE enumerator_list option(COMMA) RBRACE [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## enum_specifier -> ENUM attribute_specifier_list . general_identifier [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ENUM attribute_specifier_list +## ENUM attribute_specifier_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an @@ -1018,16 +1018,16 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ ALIGNOF LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ ALIGNOF LPAREN XOR_ASSIGN ## ## Ends in an error in state: 65. ## ## unary_expression -> ALIGNOF LPAREN . type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## ALIGNOF LPAREN +## ALIGNOF LPAREN ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF LPAREN XOR_ASSIGN ## ## Ends in an error in state: 28. ## @@ -1036,7 +1036,7 @@ translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF LPAREN XOR_ASSIGN ## unary_expression -> SIZEOF LPAREN . type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## SIZEOF LPAREN +## SIZEOF LPAREN ## # Tricky because we could be looking at the beginning of a compound @@ -1051,14 +1051,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ ALIGNOF XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ ALIGNOF XOR_ASSIGN ## ## Ends in an error in state: 64. ## ## unary_expression -> ALIGNOF . LPAREN type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## ALIGNOF +## ALIGNOF ## Ill-formed use of $0. @@ -1067,7 +1067,7 @@ followed with a type name. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF XOR_ASSIGN ## ## Ends in an error in state: 23. ## @@ -1075,7 +1075,7 @@ translation_unit_file: INT PRE_NAME VAR_NAME EQ SIZEOF XOR_ASSIGN ## unary_expression -> SIZEOF . LPAREN type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## SIZEOF +## SIZEOF ## # Let's not reveal that sizeof can be used without parentheses. @@ -1089,33 +1089,33 @@ followed with an expression or a type name. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 331. +## Ends in an error in state: 339. ## ## postfix_expression -> BUILTIN_VA_ARG LPAREN assignment_expression . COMMA type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_VA_ARG LPAREN assignment_expression +## BUILTIN_VA_ARG LPAREN assignment_expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression ## Ill-formed use of $2. @@ -1126,14 +1126,14 @@ then at this point, a comma ',' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 332. +## Ends in an error in state: 340. ## ## postfix_expression -> BUILTIN_VA_ARG LPAREN assignment_expression COMMA . type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_VA_ARG LPAREN assignment_expression COMMA +## BUILTIN_VA_ARG LPAREN assignment_expression COMMA ## Ill-formed use of $3. @@ -1141,14 +1141,14 @@ At this point, a type name is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG LPAREN XOR_ASSIGN ## ## Ends in an error in state: 51. ## ## postfix_expression -> BUILTIN_VA_ARG LPAREN . assignment_expression COMMA type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_VA_ARG LPAREN +## BUILTIN_VA_ARG LPAREN ## Ill-formed use of $1. @@ -1156,14 +1156,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ BUILTIN_VA_ARG XOR_ASSIGN ## ## Ends in an error in state: 50. ## ## postfix_expression -> BUILTIN_VA_ARG . LPAREN assignment_expression COMMA type_name RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_VA_ARG +## BUILTIN_VA_ARG ## Ill-formed use of $0. @@ -1171,23 +1171,23 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ DEC XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ DEC XOR_ASSIGN ## ## Ends in an error in state: 48. ## ## unary_expression -> DEC . unary_expression [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## DEC +## DEC ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ INC XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ INC XOR_ASSIGN ## ## Ends in an error in state: 33. ## ## unary_expression -> INC . unary_expression [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## INC +## INC ## Ill-formed expression. @@ -1195,14 +1195,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN INT RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN INT RPAREN XOR_ASSIGN ## -## Ends in an error in state: 364. +## Ends in an error in state: 372. ## ## postfix_expression -> LPAREN type_name RPAREN . LBRACE initializer_list option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN type_name RPAREN +## LPAREN type_name RPAREN ## # Here, we seem to be certain that this must be the beginning of a @@ -1226,7 +1226,7 @@ If this is intended to be the beginning of a cast expression, # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN XOR_ASSIGN ## ## Ends in an error in state: 34. ## @@ -1234,7 +1234,7 @@ translation_unit_file: INT PRE_NAME VAR_NAME EQ INC LPAREN XOR_ASSIGN ## primary_expression -> LPAREN . expression RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN +## LPAREN ## # gcc and clang expect an expression. @@ -1247,35 +1247,35 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 382. +## Ends in an error in state: 390. ## ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] ## primary_expression -> LPAREN expression . RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN expression +## LPAREN expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## # Since we are saying "if this expression is complete", @@ -1291,36 +1291,36 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN INT RPAREN LBRACE PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN INT RPAREN LBRACE PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 379. +## Ends in an error in state: 387. ## ## initializer_list -> initializer_list . COMMA option(designation) c_initializer [ RBRACE COMMA ] ## postfix_expression -> LPAREN type_name RPAREN LBRACE initializer_list . option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN type_name RPAREN LBRACE initializer_list +## LPAREN type_name RPAREN LBRACE initializer_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 372, spurious reduction of production c_initializer -> assignment_expression -## In state 378, spurious reduction of production initializer_list -> option(designation) c_initializer +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 380, spurious reduction of production c_initializer -> assignment_expression +## In state 386, spurious reduction of production initializer_list -> option(designation) c_initializer ## # Let's ignore the fact that a comma can precede a closing brace. @@ -1333,14 +1333,14 @@ then at this point, a closing brace '}' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN INT RPAREN LBRACE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN INT RPAREN LBRACE XOR_ASSIGN ## -## Ends in an error in state: 365. +## Ends in an error in state: 373. ## ## postfix_expression -> LPAREN type_name RPAREN LBRACE . initializer_list option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN type_name RPAREN LBRACE +## LPAREN type_name RPAREN LBRACE ## # gcc and clang say an expression is expected, which is incomplete. @@ -1350,15 +1350,15 @@ At this point, an initializer is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN INT RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN INT RPAREN XOR_ASSIGN ## -## Ends in an error in state: 386. +## Ends in an error in state: 394. ## ## cast_expression -> LPAREN type_name RPAREN . cast_expression [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## postfix_expression -> LPAREN type_name RPAREN . LBRACE initializer_list option(COMMA) RBRACE [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN type_name RPAREN +## LPAREN type_name RPAREN ## # clang and gcc expect an expression. @@ -1372,7 +1372,7 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN XOR_ASSIGN ## ## Ends in an error in state: 30. ## @@ -1381,7 +1381,7 @@ translation_unit_file: INT PRE_NAME VAR_NAME EQ LPAREN XOR_ASSIGN ## primary_expression -> LPAREN . expression RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## LPAREN +## LPAREN ## # clang and gcc expect an expression. @@ -1394,14 +1394,14 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ TILDE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ TILDE XOR_ASSIGN ## -## Ends in an error in state: 153. +## Ends in an error in state: 78. ## ## unary_expression -> unary_operator . cast_expression [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LEQ LEFT_ASSIGN LEFT HAT GT GEQ EQEQ EQ DIV_ASSIGN COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## unary_operator +## unary_operator ## # clang and gcc expect an expression. @@ -1411,95 +1411,95 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME AND XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME AND XOR_ASSIGN ## -## Ends in an error in state: 213. +## Ends in an error in state: 138. ## ## and_expression -> and_expression AND . equality_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION HAT COMMA COLON BARBAR BAR ANDAND AND ] ## ## The known suffix of the stack is as follows: -## and_expression AND +## and_expression AND ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME ANDAND XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME ANDAND XOR_ASSIGN ## -## Ends in an error in state: 202. +## Ends in an error in state: 127. ## ## logical_and_expression -> logical_and_expression ANDAND . inclusive_or_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION COMMA COLON BARBAR ANDAND ] ## ## The known suffix of the stack is as follows: -## logical_and_expression ANDAND +## logical_and_expression ANDAND ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME BAR XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME BAR XOR_ASSIGN ## -## Ends in an error in state: 204. +## Ends in an error in state: 129. ## ## inclusive_or_expression -> inclusive_or_expression BAR . exclusive_or_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION COMMA COLON BARBAR BAR ANDAND ] ## ## The known suffix of the stack is as follows: -## inclusive_or_expression BAR +## inclusive_or_expression BAR ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME BARBAR XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME BARBAR XOR_ASSIGN ## -## Ends in an error in state: 225. +## Ends in an error in state: 150. ## ## logical_or_expression -> logical_or_expression BARBAR . logical_and_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION COMMA COLON BARBAR ] ## ## The known suffix of the stack is as follows: -## logical_or_expression BARBAR +## logical_or_expression BARBAR ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME HAT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME HAT XOR_ASSIGN ## -## Ends in an error in state: 206. +## Ends in an error in state: 131. ## ## exclusive_or_expression -> exclusive_or_expression HAT . and_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION HAT COMMA COLON BARBAR BAR ANDAND ] ## ## The known suffix of the stack is as follows: -## exclusive_or_expression HAT +## exclusive_or_expression HAT ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LT XOR_ASSIGN ## -## Ends in an error in state: 196. +## Ends in an error in state: 121. ## ## relational_expression -> relational_expression relational_operator . shift_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION NEQ LT LEQ HAT GT GEQ EQEQ COMMA COLON BARBAR BAR ANDAND AND ] ## ## The known suffix of the stack is as follows: -## relational_expression relational_operator +## relational_expression relational_operator ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME NEQ XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME NEQ XOR_ASSIGN ## -## Ends in an error in state: 210. +## Ends in an error in state: 135. ## ## equality_expression -> equality_expression equality_operator . relational_expression [ SEMICOLON RPAREN RBRACK RBRACE QUESTION NEQ HAT EQEQ COMMA COLON BARBAR BAR ANDAND AND ] ## ## The known suffix of the stack is as follows: -## equality_expression equality_operator +## equality_expression equality_operator ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME PLUS XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME PLUS XOR_ASSIGN ## -## Ends in an error in state: 189. +## Ends in an error in state: 114. ## ## additive_expression -> additive_expression additive_operator . multiplicative_expression [ SEMICOLON RPAREN RIGHT RBRACK RBRACE QUESTION PLUS NEQ MINUS LT LEQ LEFT HAT GT GEQ EQEQ COMMA COLON BARBAR BAR ANDAND AND ] ## ## The known suffix of the stack is as follows: -## additive_expression additive_operator +## additive_expression additive_operator ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME RIGHT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME RIGHT XOR_ASSIGN ## -## Ends in an error in state: 178. +## Ends in an error in state: 103. ## ## shift_expression -> shift_expression shift_operator . additive_expression [ SEMICOLON RPAREN RIGHT RBRACK RBRACE QUESTION NEQ LT LEQ LEFT HAT GT GEQ EQEQ COMMA COLON BARBAR BAR ANDAND AND ] ## ## The known suffix of the stack is as follows: -## shift_expression shift_operator +## shift_expression shift_operator ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME STAR XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME STAR XOR_ASSIGN ## -## Ends in an error in state: 183. +## Ends in an error in state: 108. ## ## multiplicative_expression -> multiplicative_expression multiplicative_operator . cast_expression [ STAR SLASH SEMICOLON RPAREN RIGHT RBRACK RBRACE QUESTION PLUS PERCENT NEQ MINUS LT LEQ LEFT HAT GT GEQ EQEQ COMMA COLON BARBAR BAR ANDAND AND ] ## ## The known suffix of the stack is as follows: -## multiplicative_expression multiplicative_operator +## multiplicative_expression multiplicative_operator ## # clang and gcc expect an expression. @@ -1509,14 +1509,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME XOR_ASSIGN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME XOR_ASSIGN XOR_ASSIGN ## -## Ends in an error in state: 174. +## Ends in an error in state: 99. ## ## assignment_expression -> unary_expression assignment_operator . assignment_expression [ SEMICOLON RPAREN RBRACK RBRACE COMMA COLON ] ## ## The known suffix of the stack is as follows: -## unary_expression assignment_operator +## unary_expression assignment_operator ## # clang and gcc expect an expression. @@ -1526,14 +1526,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 232. +## Ends in an error in state: 157. ## ## argument_expression_list -> argument_expression_list COMMA . assignment_expression [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## argument_expression_list COMMA +## argument_expression_list COMMA ## # Here, we could say more about the context if we parameterized @@ -1547,23 +1547,23 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME DOT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME DOT XOR_ASSIGN ## -## Ends in an error in state: 238. +## Ends in an error in state: 163. ## ## postfix_expression -> postfix_expression DOT . general_identifier [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## postfix_expression DOT +## postfix_expression DOT ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME PTR XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME PTR XOR_ASSIGN ## -## Ends in an error in state: 159. +## Ends in an error in state: 84. ## ## postfix_expression -> postfix_expression PTR . general_identifier [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## postfix_expression PTR +## postfix_expression PTR ## # clang and gcc expect an identifier. @@ -1573,35 +1573,35 @@ At this point, the name of a struct or union member is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LBRACK PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LBRACK PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 235. +## Ends in an error in state: 160. ## ## expression -> expression . COMMA assignment_expression [ RBRACK COMMA ] ## postfix_expression -> postfix_expression LBRACK expression . RBRACK [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## postfix_expression LBRACK expression +## postfix_expression LBRACK expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## # We know for sure that an array subscript expression has begun, and @@ -1618,14 +1618,14 @@ then at this point, a closing bracket ']' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LBRACK XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LBRACK XOR_ASSIGN ## -## Ends in an error in state: 234. +## Ends in an error in state: 159. ## ## postfix_expression -> postfix_expression LBRACK . expression RBRACK [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## postfix_expression LBRACK +## postfix_expression LBRACK ## Ill-formed expression. @@ -1633,35 +1633,35 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 231. +## Ends in an error in state: 156. ## ## argument_expression_list -> argument_expression_list . COMMA assignment_expression [ RPAREN COMMA ] ## option(argument_expression_list) -> argument_expression_list . [ RPAREN ] ## ## The known suffix of the stack is as follows: -## argument_expression_list +## argument_expression_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 230, spurious reduction of production argument_expression_list -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 155, spurious reduction of production argument_expression_list -> assignment_expression ## Up to this point, a list of expressions has been recognized: @@ -1671,14 +1671,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME LPAREN XOR_ASSIGN ## -## Ends in an error in state: 161. +## Ends in an error in state: 86. ## ## postfix_expression -> postfix_expression LPAREN . option(argument_expression_list) RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## postfix_expression LPAREN +## postfix_expression LPAREN ## # gcc and clang expect an expression: this is incomplete. @@ -1689,23 +1689,23 @@ followed with a closing parenthesis ')', is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME QUESTION PRE_NAME VAR_NAME COLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME QUESTION PRE_NAME VAR_NAME COLON XOR_ASSIGN ## -## Ends in an error in state: 222. +## Ends in an error in state: 147. ## ## conditional_expression -> logical_or_expression QUESTION expression COLON . conditional_expression [ SEMICOLON RPAREN RBRACK RBRACE COMMA COLON ] ## ## The known suffix of the stack is as follows: -## logical_or_expression QUESTION expression COLON +## logical_or_expression QUESTION expression COLON ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME QUESTION XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME QUESTION XOR_ASSIGN ## -## Ends in an error in state: 200. +## Ends in an error in state: 125. ## ## conditional_expression -> logical_or_expression QUESTION . expression COLON conditional_expression [ SEMICOLON RPAREN RBRACK RBRACE COMMA COLON ] ## ## The known suffix of the stack is as follows: -## logical_or_expression QUESTION +## logical_or_expression QUESTION ## Ill-formed conditional expression. @@ -1713,35 +1713,35 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME QUESTION PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME VAR_NAME QUESTION PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 218. +## Ends in an error in state: 143. ## ## conditional_expression -> logical_or_expression QUESTION expression . COLON conditional_expression [ SEMICOLON RPAREN RBRACK RBRACE COMMA COLON ] ## expression -> expression . COMMA assignment_expression [ COMMA COLON ] ## ## The known suffix of the stack is as follows: -## logical_or_expression QUESTION expression +## logical_or_expression QUESTION expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## # gcc and clang simply expect a colon. @@ -1756,35 +1756,35 @@ then at this point, a colon ':' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: PACKED LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 391. +## Ends in an error in state: 399. ## ## argument_expression_list -> argument_expression_list . COMMA assignment_expression [ RPAREN COMMA ] ## attribute_specifier -> PACKED LPAREN argument_expression_list . RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PACKED LPAREN argument_expression_list +## PACKED LPAREN argument_expression_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 230, spurious reduction of production argument_expression_list -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 155, spurious reduction of production argument_expression_list -> assignment_expression ## Ill-formed $2 attribute. @@ -1795,14 +1795,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN XOR_ASSIGN +translation_unit_file: PACKED LPAREN XOR_ASSIGN ## ## Ends in an error in state: 19. ## ## attribute_specifier -> PACKED LPAREN . argument_expression_list RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PACKED LPAREN +## PACKED LPAREN ## # clang expects a "parameter declarator" (?). @@ -1814,14 +1814,14 @@ At this point, a list of expressions is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME TYPEDEF_NAME +translation_unit_file: INT PRE_NAME VAR_NAME EQ PRE_NAME TYPEDEF_NAME ## ## Ends in an error in state: 24. ## ## primary_expression -> PRE_NAME . VAR_NAME [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## Ill-formed expression. @@ -1830,14 +1830,14 @@ The following identifier is used as a variable, but has been defined as a type: # ------------------------------------------------------------------------------ -translation_unit_file: PACKED XOR_ASSIGN +translation_unit_file: PACKED XOR_ASSIGN ## ## Ends in an error in state: 18. ## ## attribute_specifier -> PACKED . LPAREN argument_expression_list RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER RBRACK PRE_NAME PLUS PACKED NORETURN MINUS LPAREN LONG LBRACK LBRACE INT INLINE INC FLOAT EXTERN EQ ENUM DOUBLE DEC CONSTANT CONST COMMA COLON CHAR BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AUTO ATTRIBUTE AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PACKED +## PACKED ## # This one seems important, since CompCert currently does not support __packed__ @@ -1850,15 +1850,15 @@ is expected. # ------------------------------------------------------------------------------ -translation_unit_file: XOR_ASSIGN +translation_unit_file: XOR_ASSIGN ## ## Ends in an error in state: 2. ## -## list(translation_item) -> list(translation_item) . translation_item [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PRAGMA PACKED NORETURN LONG INT INLINE FLOAT EXTERN EOF ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] +## list(translation_item) -> list(translation_item) . translation_item [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC_ASSERT STATIC SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PRAGMA PACKED NORETURN LONG INT INLINE FLOAT EXTERN EOF ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## translation_unit_file -> list(translation_item) . EOF [ # ] ## ## The known suffix of the stack is as follows: -## list(translation_item) +## list(translation_item) ## # We are at the toplevel. @@ -1873,9 +1873,9 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: TYPEDEF PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: TYPEDEF PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 394. +## Ends in an error in state: 402. ## ## declaration_specifiers_typedef -> TYPEDEF list(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] @@ -1884,11 +1884,11 @@ translation_unit_file: TYPEDEF PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## TYPEDEF list(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) +## TYPEDEF list(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: PRE_NAME TYPEDEF_NAME TYPEDEF XOR_ASSIGN +translation_unit_file: PRE_NAME TYPEDEF_NAME TYPEDEF XOR_ASSIGN ## -## Ends in an error in state: 403. +## Ends in an error in state: 411. ## ## declaration_specifiers_typedef -> typedef_name list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] @@ -1897,11 +1897,11 @@ translation_unit_file: PRE_NAME TYPEDEF_NAME TYPEDEF XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## typedef_name list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) +## typedef_name list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) ## -translation_unit_file: VOLATILE TYPEDEF PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: VOLATILE TYPEDEF PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 413. +## Ends in an error in state: 422. ## ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] @@ -1910,11 +1910,11 @@ translation_unit_file: VOLATILE TYPEDEF PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: VOLATILE PRE_NAME TYPEDEF_NAME TYPEDEF XOR_ASSIGN +translation_unit_file: VOLATILE PRE_NAME TYPEDEF_NAME TYPEDEF XOR_ASSIGN ## -## Ends in an error in state: 419. +## Ends in an error in state: 428. ## ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] @@ -1923,47 +1923,47 @@ translation_unit_file: VOLATILE PRE_NAME TYPEDEF_NAME TYPEDEF XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) ## -translation_unit_file: TYPEDEF INT XOR_ASSIGN +translation_unit_file: TYPEDEF INT XOR_ASSIGN ## -## Ends in an error in state: 396. +## Ends in an error in state: 404. ## ## declaration_specifiers_typedef -> TYPEDEF list(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## TYPEDEF list(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## TYPEDEF list(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: INT TYPEDEF XOR_ASSIGN +translation_unit_file: INT TYPEDEF XOR_ASSIGN ## -## Ends in an error in state: 407. +## Ends in an error in state: 415. ## ## declaration_specifiers_typedef -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) +## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) ## -translation_unit_file: VOLATILE TYPEDEF INT XOR_ASSIGN +translation_unit_file: VOLATILE TYPEDEF INT XOR_ASSIGN ## -## Ends in an error in state: 415. +## Ends in an error in state: 424. ## ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: VOLATILE INT TYPEDEF XOR_ASSIGN +translation_unit_file: VOLATILE INT TYPEDEF XOR_ASSIGN ## -## Ends in an error in state: 423. +## Ends in an error in state: 432. ## ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) +## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) ## # We have begun a type definition (a.k.a. declaration_specifiers_typedef). @@ -1994,7 +1994,7 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: TYPEDEF XOR_ASSIGN +translation_unit_file: TYPEDEF XOR_ASSIGN ## ## Ends in an error in state: 9. ## @@ -2006,11 +2006,11 @@ translation_unit_file: TYPEDEF XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT RESTRICT REGISTER PRE_NAME PACKED NORETURN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## TYPEDEF list(declaration_specifier_no_type) +## TYPEDEF list(declaration_specifier_no_type) ## -translation_unit_file: VOLATILE TYPEDEF XOR_ASSIGN +translation_unit_file: VOLATILE TYPEDEF XOR_ASSIGN ## -## Ends in an error in state: 411. +## Ends in an error in state: 420. ## ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) . typedef_name list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2020,7 +2020,7 @@ translation_unit_file: VOLATILE TYPEDEF XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT RESTRICT REGISTER PRE_NAME PACKED NORETURN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) ## # We have seen the TYPEDEF keyword, and possibly some declaration_specifiers_no_type. @@ -2042,21 +2042,21 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE XOR_ASSIGN ## -## Ends in an error in state: 133. +## Ends in an error in state: 230. ## ## declaration_specifiers(parameter_declaration) -> rlist(declaration_specifier_no_type) . typedef_name list(declaration_specifier_no_type) [ STAR RPAREN PRE_NAME LPAREN LBRACK COMMA ] ## declaration_specifiers(parameter_declaration) -> rlist(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) [ STAR RPAREN PRE_NAME LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 125, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr +## In state 222, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr ## # Analogous to the above, except we are in the context of a parameter declaration, @@ -2078,9 +2078,9 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 401. +## Ends in an error in state: 409. ## ## declaration_specifiers(declaration(external_declaration)) -> typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> typedef_name list(declaration_specifier_no_type) . TYPEDEF list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2090,11 +2090,11 @@ translation_unit_file: PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## typedef_name list(declaration_specifier_no_type) +## typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 417. +## Ends in an error in state: 426. ## ## declaration_specifiers(declaration(external_declaration)) -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . TYPEDEF list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2104,29 +2104,29 @@ translation_unit_file: VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: INT XOR_ASSIGN +translation_unit_file: INT XOR_ASSIGN ## -## Ends in an error in state: 405. +## Ends in an error in state: 413. ## ## declaration_specifiers(declaration(external_declaration)) -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . TYPEDEF list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: VOLATILE INT XOR_ASSIGN +translation_unit_file: VOLATILE INT XOR_ASSIGN ## -## Ends in an error in state: 421. +## Ends in an error in state: 430. ## ## declaration_specifiers(declaration(external_declaration)) -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . TYPEDEF list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## # We have seen a TYPEDEF_NAME or a primitive type specifier, @@ -2178,9 +2178,9 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 112. +## Ends in an error in state: 209. ## ## declaration_specifiers(parameter_declaration) -> typedef_name list(declaration_specifier_no_type) . [ STAR RPAREN PRE_NAME LPAREN LBRACK COMMA ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] @@ -2189,11 +2189,11 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME TYPEDEF_NAME XOR_AS ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## typedef_name list(declaration_specifier_no_type) +## typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 135. +## Ends in an error in state: 232. ## ## declaration_specifiers(parameter_declaration) -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . [ STAR RPAREN PRE_NAME LPAREN LBRACK COMMA ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] @@ -2202,27 +2202,27 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE PRE_NAME TYPEDEF_NA ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT XOR_ASSIGN ## -## Ends in an error in state: 118. +## Ends in an error in state: 215. ## ## declaration_specifiers(parameter_declaration) -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR RPAREN PRE_NAME LPAREN LBRACK COMMA ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE INT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN VOLATILE INT XOR_ASSIGN ## -## Ends in an error in state: 137. +## Ends in an error in state: 234. ## ## declaration_specifiers(parameter_declaration) -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR RPAREN PRE_NAME LPAREN LBRACK COMMA ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## # Analogous to the above situation, except this time, we are in the @@ -2263,9 +2263,9 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: VOLATILE XOR_ASSIGN +translation_unit_file: VOLATILE XOR_ASSIGN ## -## Ends in an error in state: 409. +## Ends in an error in state: 418. ## ## declaration_specifiers(declaration(external_declaration)) -> rlist(declaration_specifier_no_type) . typedef_name list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers(declaration(external_declaration)) -> rlist(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2275,13 +2275,13 @@ translation_unit_file: VOLATILE XOR_ASSIGN ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 125, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr +## In state 222, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr ## # We have seen some specifiers or qualifiers. We have probably seen at least @@ -2308,9 +2308,9 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE VOLATILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE VOLATILE XOR_ASSIGN ## -## Ends in an error in state: 518. +## Ends in an error in state: 528. ## ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) . typedef_name list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2320,13 +2320,13 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) TYPEDEF list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 125, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr +## In state 222, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr ## # Identical to the previous one, except we are not at the top level, # so we know this cannot be the beginning of a function definition. @@ -2339,9 +2339,9 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME TYPEDEF_NAME VOLATILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME TYPEDEF_NAME VOLATILE XOR_ASSIGN ## -## Ends in an error in state: 515. +## Ends in an error in state: 524. ## ## declaration_specifiers(declaration(block_item)) -> typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> typedef_name list(declaration_specifier_no_type) . TYPEDEF list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2351,11 +2351,11 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## typedef_name list(declaration_specifier_no_type) +## typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 520. +## Ends in an error in state: 530. ## ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . TYPEDEF list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] @@ -2365,29 +2365,29 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE INT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE INT XOR_ASSIGN ## -## Ends in an error in state: 517. +## Ends in an error in state: 526. ## ## declaration_specifiers(declaration(block_item)) -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . TYPEDEF list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE VOLATILE INT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE VOLATILE INT XOR_ASSIGN ## -## Ends in an error in state: 522. +## Ends in an error in state: 532. ## ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . TYPEDEF list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## # This is analogous to the error sentence TYPEDEF_NAME VOLATILE XOR_ASSIGN, @@ -2418,20 +2418,20 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: UNION LBRACE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 92. +## Ends in an error in state: 189. ## -## struct_declaration -> specifier_qualifier_list(struct_declaration) . option(struct_declarator_list) SEMICOLON [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT SIGNED SHORT RESTRICT RBRACE PRE_NAME PACKED LONG INT FLOAT ENUM DOUBLE CONST CHAR ATTRIBUTE ALIGNAS ] +## struct_declaration -> specifier_qualifier_list(struct_declaration) . option(struct_declarator_list) SEMICOLON [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC_ASSERT SIGNED SHORT RESTRICT RBRACE PRE_NAME PACKED LONG INT FLOAT ENUM DOUBLE CONST CHAR ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## specifier_qualifier_list(struct_declaration) +## specifier_qualifier_list(struct_declaration) ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 78, spurious reduction of production specifier_qualifier_list(struct_declaration) -> typedef_name option(type_qualifier_list) +## In state 174, spurious reduction of production specifier_qualifier_list(struct_declaration) -> typedef_name option(type_qualifier_list) ## # We have (spuriously) recognized a specifier_qualifier_list, @@ -2463,35 +2463,35 @@ at this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE LONG COLON CONSTANT RPAREN +translation_unit_file: UNION LBRACE LONG COLON CONSTANT RPAREN ## -## Ends in an error in state: 287. +## Ends in an error in state: 295. ## ## option(struct_declarator_list) -> struct_declarator_list . [ SEMICOLON ] ## struct_declarator_list -> struct_declarator_list . COMMA struct_declarator [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## struct_declarator_list +## struct_declarator_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 154, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 292, spurious reduction of production struct_declarator -> option(declarator) COLON conditional_expression -## In state 294, spurious reduction of production struct_declarator_list -> struct_declarator +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 79, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 300, spurious reduction of production struct_declarator -> option(declarator) COLON conditional_expression +## In state 302, spurious reduction of production struct_declarator_list -> struct_declarator ## # We have seen a non-empty struct_declarator_list. @@ -2507,14 +2507,14 @@ then at this point, a semicolon ';' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE INT COLON XOR_ASSIGN +translation_unit_file: UNION LBRACE INT COLON XOR_ASSIGN ## -## Ends in an error in state: 291. +## Ends in an error in state: 299. ## ## struct_declarator -> option(declarator) COLON . conditional_expression [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## option(declarator) COLON +## option(declarator) COLON ## Ill-formed struct declarator. @@ -2522,14 +2522,14 @@ At this point, a constant expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE INT PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: UNION LBRACE INT PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 288. +## Ends in an error in state: 296. ## ## struct_declarator_list -> struct_declarator_list COMMA . struct_declarator [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## struct_declarator_list COMMA +## struct_declarator_list COMMA ## Ill-formed struct declaration. @@ -2537,23 +2537,23 @@ At this point, a struct declarator is expected. # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE INT PRE_NAME VAR_NAME RPAREN +translation_unit_file: UNION LBRACE INT PRE_NAME VAR_NAME RPAREN ## -## Ends in an error in state: 293. +## Ends in an error in state: 301. ## ## option(declarator) -> declarator . [ COLON ] ## struct_declarator -> declarator . [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## declarator +## declarator ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 255, spurious reduction of production declarator_noattrend -> direct_declarator -## In state 260, spurious reduction of production attribute_specifier_list -> -## In state 261, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list +## In state 263, spurious reduction of production declarator_noattrend -> direct_declarator +## In state 268, spurious reduction of production attribute_specifier_list -> +## In state 269, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list ## # Assuming the declarator so far is complete, we expect @@ -2574,16 +2574,16 @@ then at this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE VOLATILE ADD_ASSIGN +translation_unit_file: UNION LBRACE VOLATILE ADD_ASSIGN ## -## Ends in an error in state: 86. +## Ends in an error in state: 182. ## ## option(type_qualifier_list) -> type_qualifier_list . [ VOLATILE RESTRICT PACKED CONST ATTRIBUTE ALIGNAS ] ## specifier_qualifier_list(struct_declaration) -> type_qualifier_list . typedef_name option(type_qualifier_list) [ STAR SEMICOLON PRE_NAME LPAREN COLON ] ## specifier_qualifier_list(struct_declaration) -> type_qualifier_list . type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN COLON ] ## ## The known suffix of the stack is as follows: -## type_qualifier_list +## type_qualifier_list ## # A list of qualifiers has been read. @@ -2597,15 +2597,15 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: UNION LBRACE XOR_ASSIGN +translation_unit_file: UNION LBRACE XOR_ASSIGN ## ## Ends in an error in state: 75. ## -## struct_declaration_list -> struct_declaration_list . struct_declaration [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT SIGNED SHORT RESTRICT RBRACE PRE_NAME PACKED LONG INT FLOAT ENUM DOUBLE CONST CHAR ATTRIBUTE ALIGNAS ] +## struct_declaration_list -> struct_declaration_list . struct_declaration [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC_ASSERT SIGNED SHORT RESTRICT RBRACE PRE_NAME PACKED LONG INT FLOAT ENUM DOUBLE CONST CHAR ATTRIBUTE ALIGNAS ] ## struct_or_union_specifier -> struct_or_union attribute_specifier_list option(other_identifier) LBRACE struct_declaration_list . RBRACE [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## struct_or_union attribute_specifier_list option(other_identifier) LBRACE struct_declaration_list +## struct_or_union attribute_specifier_list option(other_identifier) LBRACE struct_declaration_list ## # gcc and clang do not seem prepared to accept a struct or union with @@ -2617,7 +2617,7 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: UNION XOR_ASSIGN +translation_unit_file: UNION XOR_ASSIGN ## ## Ends in an error in state: 72. ## @@ -2625,7 +2625,7 @@ translation_unit_file: UNION XOR_ASSIGN ## struct_or_union_specifier -> struct_or_union attribute_specifier_list . general_identifier [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF STRUCT STATIC STAR SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK INT INLINE FLOAT EXTERN ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## struct_or_union attribute_specifier_list +## struct_or_union attribute_specifier_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an @@ -2646,22 +2646,22 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 264. +## Ends in an error in state: 272. ## ## direct_declarator -> LPAREN save_context declarator . RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## LPAREN save_context declarator +## LPAREN save_context declarator ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 255, spurious reduction of production declarator_noattrend -> direct_declarator -## In state 260, spurious reduction of production attribute_specifier_list -> -## In state 261, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list +## In state 263, spurious reduction of production declarator_noattrend -> direct_declarator +## In state 268, spurious reduction of production attribute_specifier_list -> +## In state 269, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list ## Up to this point, a declarator has been recognized: @@ -2671,14 +2671,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT LPAREN XOR_ASSIGN +translation_unit_file: INT LPAREN XOR_ASSIGN ## -## Ends in an error in state: 98. +## Ends in an error in state: 195. ## ## direct_declarator -> LPAREN save_context . declarator RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## LPAREN save_context +## LPAREN save_context ## # clang and gcc expect identifier or '(', as usual. @@ -2688,15 +2688,15 @@ At this point, a declarator is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME XOR_ASSIGN ## -## Ends in an error in state: 281. +## Ends in an error in state: 289. ## ## identifier_list -> identifier_list . COMMA PRE_NAME VAR_NAME [ RPAREN COMMA ] ## option(identifier_list) -> identifier_list . [ RPAREN ] ## ## The known suffix of the stack is as follows: -## identifier_list +## identifier_list ## Ill-formed K&R function definition. @@ -2707,15 +2707,15 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN XOR_ASSIGN ## -## Ends in an error in state: 104. +## Ends in an error in state: 201. ## ## context_parameter_type_list -> save_context . parameter_type_list save_context [ RPAREN ] ## direct_declarator -> direct_declarator LPAREN save_context . option(identifier_list) RPAREN [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## direct_declarator LPAREN save_context +## direct_declarator LPAREN save_context ## # Ignore K&R syntax, just request ANSI syntax. @@ -2731,9 +2731,9 @@ followed with a closing parenthesis ')', is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT STAR RPAREN +translation_unit_file: INT STAR RPAREN ## -## Ends in an error in state: 101. +## Ends in an error in state: 198. ## ## declarator_noattrend -> list(pointer1) STAR option(type_qualifier_list) . direct_declarator [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LONG LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## list(pointer1) -> list(pointer1) STAR option(type_qualifier_list) . [ STAR ] @@ -2741,7 +2741,7 @@ translation_unit_file: INT STAR RPAREN ## type_qualifier_list -> option(type_qualifier_list) . attribute_specifier [ VOLATILE STAR RESTRICT PRE_NAME PACKED LPAREN CONST ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## list(pointer1) STAR option(type_qualifier_list) +## list(pointer1) STAR option(type_qualifier_list) ## # If the pointer isn't finished, we expect @@ -2764,26 +2764,26 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: TYPEDEF INT PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: TYPEDEF INT PRE_NAME VAR_NAME XOR_ASSIGN ## -## Ends in an error in state: 534. +## Ends in an error in state: 544. ## ## option(typedef_declarator_list) -> typedef_declarator_list . [ SEMICOLON ] ## typedef_declarator_list -> typedef_declarator_list . COMMA typedef_declarator [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## typedef_declarator_list +## typedef_declarator_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 255, spurious reduction of production declarator_noattrend -> direct_declarator -## In state 260, spurious reduction of production attribute_specifier_list -> -## In state 261, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list -## In state 538, spurious reduction of production declare_typename(declarator) -> declarator -## In state 537, spurious reduction of production typedef_declarator -> declare_typename(declarator) -## In state 539, spurious reduction of production typedef_declarator_list -> typedef_declarator +## In state 263, spurious reduction of production declarator_noattrend -> direct_declarator +## In state 268, spurious reduction of production attribute_specifier_list -> +## In state 269, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list +## In state 548, spurious reduction of production declare_typename(declarator) -> declarator +## In state 547, spurious reduction of production typedef_declarator -> declare_typename(declarator) +## In state 549, spurious reduction of production typedef_declarator_list -> typedef_declarator ## # Because attribute_specifier_list, declarator and declarator_noattrend have been marked @@ -2807,28 +2807,28 @@ then at this point, a semicolon ';' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: TYPEDEF INT PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: TYPEDEF INT PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 535. +## Ends in an error in state: 545. ## ## typedef_declarator_list -> typedef_declarator_list COMMA . typedef_declarator [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## typedef_declarator_list COMMA +## typedef_declarator_list COMMA ## At this point, a declarator is expected. # ------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN INT LPAREN RPAREN LPAREN XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN INT LPAREN RPAREN LPAREN XOR_ASSIGN ## -## Ends in an error in state: 249. +## Ends in an error in state: 257. ## ## direct_abstract_declarator -> direct_abstract_declarator LPAREN . option(context_parameter_type_list) RPAREN [ RPAREN LPAREN LBRACK COMMA ] ## ## The known suffix of the stack is as follows: -## direct_abstract_declarator LPAREN +## direct_abstract_declarator LPAREN ## At this point, a list of parameter declarations, @@ -2836,32 +2836,32 @@ followed with a closing parenthesis ')', is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM CONST XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM CONST XOR_ASSIGN ## -## Ends in an error in state: 450. +## Ends in an error in state: 459. ## ## asm_attributes -> CONST . asm_attributes [ LPAREN ] ## ## The known suffix of the stack is as follows: -## CONST +## CONST ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM VOLATILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM VOLATILE XOR_ASSIGN ## -## Ends in an error in state: 449. +## Ends in an error in state: 458. ## ## asm_attributes -> VOLATILE . asm_attributes [ LPAREN ] ## ## The known suffix of the stack is as follows: -## VOLATILE +## VOLATILE ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM XOR_ASSIGN ## -## Ends in an error in state: 448. +## Ends in an error in state: 457. ## -## asm_statement -> ASM . asm_attributes LPAREN string_literals_list asm_arguments RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## asm_statement -> ASM . asm_attributes LPAREN string_literals_list asm_arguments RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ASM +## ASM ## Ill-formed assembly statement. @@ -2871,26 +2871,26 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON COLON STRING_LITERAL COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON COLON STRING_LITERAL COMMA XOR_ASSIGN ## -## Ends in an error in state: 474. +## Ends in an error in state: 483. ## ## asm_flags -> asm_flags COMMA . string_literals_list [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## asm_flags COMMA +## asm_flags COMMA ## # We are in the clobber list. # We have seen a comma, so we expect a string literal. # first(asm_flags) = STRING_LITERAL -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON COLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON COLON XOR_ASSIGN ## -## Ends in an error in state: 471. +## Ends in an error in state: 480. ## ## asm_arguments -> COLON asm_operands COLON asm_operands COLON . asm_flags [ RPAREN ] ## ## The known suffix of the stack is as follows: -## COLON asm_operands COLON asm_operands COLON +## COLON asm_operands COLON asm_operands COLON ## # We are at the beginning of the clobber list. # first(asm_flags) = STRING_LITERAL @@ -2903,21 +2903,21 @@ Examples of clobbered resources: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON COLON STRING_LITERAL XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON COLON STRING_LITERAL XOR_ASSIGN ## -## Ends in an error in state: 473. +## Ends in an error in state: 482. ## ## asm_arguments -> COLON asm_operands COLON asm_operands COLON asm_flags . [ RPAREN ] ## asm_flags -> asm_flags . COMMA string_literals_list [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## COLON asm_operands COLON asm_operands COLON asm_flags +## COLON asm_operands COLON asm_operands COLON asm_flags ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 472, spurious reduction of production asm_flags -> string_literals_list +## In state 481, spurious reduction of production asm_flags -> string_literals_list ## # Let's ignore the possibility of concatenating string literals. @@ -2932,22 +2932,22 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN CONSTANT RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN CONSTANT RPAREN XOR_ASSIGN ## -## Ends in an error in state: 468. +## Ends in an error in state: 477. ## ## asm_arguments -> COLON asm_operands . [ RPAREN ] ## asm_arguments -> COLON asm_operands . COLON asm_operands [ RPAREN ] ## asm_arguments -> COLON asm_operands . COLON asm_operands COLON asm_flags [ RPAREN ] ## ## The known suffix of the stack is as follows: -## COLON asm_operands +## COLON asm_operands ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 460, spurious reduction of production asm_operands -> asm_operands_ne +## In state 469, spurious reduction of production asm_operands -> asm_operands_ne ## # We have seen one COLON, hence the outputs. (The list of outputs may be empty.) @@ -2962,21 +2962,21 @@ then at this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON COLON XOR_ASSIGN ## -## Ends in an error in state: 470. +## Ends in an error in state: 479. ## ## asm_arguments -> COLON asm_operands COLON asm_operands . [ RPAREN ] ## asm_arguments -> COLON asm_operands COLON asm_operands . COLON asm_flags [ RPAREN ] ## ## The known suffix of the stack is as follows: -## COLON asm_operands COLON asm_operands +## COLON asm_operands COLON asm_operands ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 469, spurious reduction of production asm_operands -> +## In state 478, spurious reduction of production asm_operands -> ## # We have seen two COLONs, hence the outputs and inputs. (The list of inputs may be empty.) @@ -2994,14 +2994,14 @@ then at this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON LBRACK PRE_NAME VAR_NAME RBRACK XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON LBRACK PRE_NAME VAR_NAME RBRACK XOR_ASSIGN ## -## Ends in an error in state: 463. +## Ends in an error in state: 472. ## ## asm_operand -> asm_op_name . string_literals_list LPAREN expression RPAREN [ RPAREN COMMA COLON ] ## ## The known suffix of the stack is as follows: -## asm_op_name +## asm_op_name ## # Example of asm_operand: [oldval]"=r"(res) @@ -3013,14 +3013,14 @@ At this point, a string literal, representing a constraint, is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON LBRACK PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON LBRACK PRE_NAME VAR_NAME XOR_ASSIGN ## -## Ends in an error in state: 458. +## Ends in an error in state: 467. ## ## asm_op_name -> LBRACK general_identifier . RBRACK [ STRING_LITERAL ] ## ## The known suffix of the stack is as follows: -## LBRACK general_identifier +## LBRACK general_identifier ## Ill-formed assembly operand. @@ -3028,14 +3028,14 @@ At this point, a closing bracket ']' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON LBRACK XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON LBRACK XOR_ASSIGN ## -## Ends in an error in state: 457. +## Ends in an error in state: 466. ## ## asm_op_name -> LBRACK . general_identifier RBRACK [ STRING_LITERAL ] ## ## The known suffix of the stack is as follows: -## LBRACK +## LBRACK ## Ill-formed assembly operand. @@ -3043,14 +3043,14 @@ At this point, an identifier is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN CONSTANT RPAREN COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN CONSTANT RPAREN COMMA XOR_ASSIGN ## -## Ends in an error in state: 461. +## Ends in an error in state: 470. ## ## asm_operands_ne -> asm_operands_ne COMMA . asm_operand [ RPAREN COMMA COLON ] ## ## The known suffix of the stack is as follows: -## asm_operands_ne COMMA +## asm_operands_ne COMMA ## # clang and gcc request a string literal (which is incomplete). @@ -3060,35 +3060,35 @@ At this point, an assembly operand is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 466. +## Ends in an error in state: 475. ## ## asm_operand -> asm_op_name string_literals_list LPAREN expression . RPAREN [ RPAREN COMMA COLON ] ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## asm_op_name string_literals_list LPAREN expression +## asm_op_name string_literals_list LPAREN expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## Ill-formed assembly operand. @@ -3099,14 +3099,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL LPAREN XOR_ASSIGN ## -## Ends in an error in state: 465. +## Ends in an error in state: 474. ## ## asm_operand -> asm_op_name string_literals_list LPAREN . expression RPAREN [ RPAREN COMMA COLON ] ## ## The known suffix of the stack is as follows: -## asm_op_name string_literals_list LPAREN +## asm_op_name string_literals_list LPAREN ## Ill-formed assembly operand. @@ -3114,15 +3114,15 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL COLON STRING_LITERAL XOR_ASSIGN ## -## Ends in an error in state: 464. +## Ends in an error in state: 473. ## ## asm_operand -> asm_op_name string_literals_list . LPAREN expression RPAREN [ RPAREN COMMA COLON ] ## string_literals_list -> string_literals_list . STRING_LITERAL [ STRING_LITERAL LPAREN ] ## ## The known suffix of the stack is as follows: -## asm_op_name string_literals_list +## asm_op_name string_literals_list ## # If we disregard the concatenation of string literals, then @@ -3134,15 +3134,15 @@ followed with an expression and a closing parenthesis ')', is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL XOR_ASSIGN ## -## Ends in an error in state: 455. +## Ends in an error in state: 464. ## -## asm_statement -> ASM asm_attributes LPAREN string_literals_list . asm_arguments RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## asm_statement -> ASM asm_attributes LPAREN string_literals_list . asm_arguments RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## string_literals_list -> string_literals_list . STRING_LITERAL [ STRING_LITERAL RPAREN COLON ] ## ## The known suffix of the stack is as follows: -## ASM asm_attributes LPAREN string_literals_list +## ASM asm_attributes LPAREN string_literals_list ## # Expecting either one more string literal, or COLON, or RPAREN. @@ -3156,14 +3156,14 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN XOR_ASSIGN ## -## Ends in an error in state: 454. +## Ends in an error in state: 463. ## -## asm_statement -> ASM asm_attributes LPAREN . string_literals_list asm_arguments RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## asm_statement -> ASM asm_attributes LPAREN . string_literals_list asm_arguments RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ASM asm_attributes LPAREN +## ASM asm_attributes LPAREN ## Ill-formed assembly statement. @@ -3171,50 +3171,50 @@ At this point, a string literal, representing an instruction, is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE BREAK XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE BREAK XOR_ASSIGN ## -## Ends in an error in state: 446. +## Ends in an error in state: 455. ## -## jump_statement -> BREAK . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## jump_statement -> BREAK . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## BREAK +## BREAK ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CONTINUE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CONTINUE XOR_ASSIGN ## -## Ends in an error in state: 441. +## Ends in an error in state: 450. ## -## jump_statement -> CONTINUE . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## jump_statement -> CONTINUE . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## CONTINUE +## CONTINUE ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN ## -## Ends in an error in state: 565. +## Ends in an error in state: 575. ## -## iteration_statement -> save_context do_statement1 WHILE LPAREN expression RPAREN . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context do_statement1 WHILE LPAREN expression RPAREN . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context do_statement1 WHILE LPAREN expression RPAREN +## save_context do_statement1 WHILE LPAREN expression RPAREN ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE GOTO PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE GOTO PRE_NAME VAR_NAME XOR_ASSIGN ## -## Ends in an error in state: 437. +## Ends in an error in state: 446. ## -## jump_statement -> GOTO general_identifier . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## jump_statement -> GOTO general_identifier . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## GOTO general_identifier +## GOTO general_identifier ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE ASM LPAREN STRING_LITERAL RPAREN XOR_ASSIGN ## -## Ends in an error in state: 478. +## Ends in an error in state: 487. ## -## asm_statement -> ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## asm_statement -> ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN +## ASM asm_attributes LPAREN string_literals_list asm_arguments RPAREN ## Ill-formed statement. @@ -3222,32 +3222,32 @@ At this point, a semicolon ';' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CASE CONSTANT COLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CASE CONSTANT COLON XOR_ASSIGN ## -## Ends in an error in state: 445. +## Ends in an error in state: 454. ## -## labeled_statement -> CASE conditional_expression COLON . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> CASE conditional_expression COLON . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## CASE conditional_expression COLON +## CASE conditional_expression COLON ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DEFAULT COLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DEFAULT COLON XOR_ASSIGN ## -## Ends in an error in state: 440. +## Ends in an error in state: 449. ## -## labeled_statement -> DEFAULT COLON . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> DEFAULT COLON . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## DEFAULT COLON +## DEFAULT COLON ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME VAR_NAME COLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME VAR_NAME COLON XOR_ASSIGN ## -## Ends in an error in state: 494. +## Ends in an error in state: 503. ## -## labeled_statement -> general_identifier COLON . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> general_identifier COLON . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## general_identifier COLON +## general_identifier COLON ## # gcc and clang request an expression, which seems misleading (incomplete). @@ -3257,32 +3257,32 @@ At this point, a statement is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CASE CONSTANT SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CASE CONSTANT SEMICOLON ## -## Ends in an error in state: 444. +## Ends in an error in state: 453. ## -## labeled_statement -> CASE conditional_expression . COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> CASE conditional_expression . COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## CASE conditional_expression +## CASE conditional_expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 154, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 79, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression ## Ill-formed labeled statement. @@ -3293,14 +3293,14 @@ then at this point, a colon ':' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CASE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE CASE XOR_ASSIGN ## -## Ends in an error in state: 443. +## Ends in an error in state: 452. ## -## labeled_statement -> CASE . conditional_expression COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> CASE . conditional_expression COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## CASE +## CASE ## Ill-formed labeled statement. @@ -3308,23 +3308,23 @@ At this point, a constant expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DEFAULT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DEFAULT XOR_ASSIGN ## -## Ends in an error in state: 439. +## Ends in an error in state: 448. ## -## labeled_statement -> DEFAULT . COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> DEFAULT . COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## DEFAULT +## DEFAULT ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 493. +## Ends in an error in state: 502. ## -## labeled_statement -> general_identifier . COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## labeled_statement -> general_identifier . COLON statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## general_identifier +## general_identifier ## # gcc and clang apparently do not allow a TYPEDEF_NAME to be reclassified as a label. @@ -3334,35 +3334,35 @@ At this point, a colon ':' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 564. +## Ends in an error in state: 574. ## ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] -## iteration_statement -> save_context do_statement1 WHILE LPAREN expression . RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context do_statement1 WHILE LPAREN expression . RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context do_statement1 WHILE LPAREN expression +## save_context do_statement1 WHILE LPAREN expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## Ill-formed 'do' ... 'while' statement. @@ -3373,14 +3373,14 @@ then at this point, a closing parenthesis ')' and a semicolon ';' are expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE LPAREN XOR_ASSIGN ## -## Ends in an error in state: 563. +## Ends in an error in state: 573. ## -## iteration_statement -> save_context do_statement1 WHILE LPAREN . expression RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context do_statement1 WHILE LPAREN . expression RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context do_statement1 WHILE LPAREN +## save_context do_statement1 WHILE LPAREN ## Ill-formed 'do' ... 'while' statement. @@ -3388,14 +3388,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON WHILE XOR_ASSIGN ## -## Ends in an error in state: 562. +## Ends in an error in state: 572. ## -## iteration_statement -> save_context do_statement1 WHILE . LPAREN expression RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context do_statement1 WHILE . LPAREN expression RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context do_statement1 WHILE +## save_context do_statement1 WHILE ## Ill-formed 'do' ... 'while' statement. @@ -3403,14 +3403,14 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO SEMICOLON XOR_ASSIGN ## -## Ends in an error in state: 561. +## Ends in an error in state: 571. ## -## iteration_statement -> save_context do_statement1 . WHILE LPAREN expression RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context do_statement1 . WHILE LPAREN expression RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context do_statement1 +## save_context do_statement1 ## # Quite nicely, in this case, there is no doubt that the statement is @@ -3424,14 +3424,14 @@ At this point, a 'while' keyword is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO XOR_ASSIGN ## -## Ends in an error in state: 557. +## Ends in an error in state: 567. ## ## do_statement1 -> save_context DO . statement [ WHILE ] ## ## The known suffix of the stack is as follows: -## save_context DO +## save_context DO ## # gcc and clang expect an expression. @@ -3441,14 +3441,14 @@ At this point, a statement (the loop body) is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON SEMICOLON RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON SEMICOLON RPAREN XOR_ASSIGN ## -## Ends in an error in state: 527. +## Ends in an error in state: 537. ## -## iteration_statement -> save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) +## save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) ## Ill-formed 'for' statement. @@ -3456,35 +3456,35 @@ At this point, a statement (the loop body) is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON SEMICOLON PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON SEMICOLON PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 529. +## Ends in an error in state: 539. ## ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] ## optional(expression,RPAREN) -> expression . RPAREN [ WHILE TILDE SWITCH STRING_LITERAL STAR SIZEOF SEMICOLON RETURN PRE_NAME PLUS MINUS LPAREN LBRACE INC IF GOTO FOR DO DEFAULT DEC CONTINUE CONSTANT CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG ASM AND ALIGNOF ] ## ## The known suffix of the stack is as follows: -## expression +## expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## # The use of optional(expression,RPAREN) tells us that we are in a FOR statement. @@ -3498,14 +3498,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON SEMICOLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON SEMICOLON XOR_ASSIGN ## -## Ends in an error in state: 525. +## Ends in an error in state: 535. ## -## iteration_statement -> save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) . optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) . optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) +## save_context FOR LPAREN for_statement_header optional(expression,SEMICOLON) ## # Expecting the third part of the loop header -- the expression @@ -3518,14 +3518,14 @@ followed with a closing parenthesis ')', is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN SEMICOLON XOR_ASSIGN ## -## Ends in an error in state: 524. +## Ends in an error in state: 534. ## -## iteration_statement -> save_context FOR LPAREN for_statement_header . optional(expression,SEMICOLON) optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context FOR LPAREN for_statement_header . optional(expression,SEMICOLON) optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context FOR LPAREN for_statement_header +## save_context FOR LPAREN for_statement_header ## # Expecting the second part of the loop header -- the controlling expression. @@ -3537,35 +3537,35 @@ followed with a semicolon ';', is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN PRE_NAME VAR_NAME RPAREN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN PRE_NAME VAR_NAME RPAREN ## -## Ends in an error in state: 531. +## Ends in an error in state: 541. ## ## expression -> expression . COMMA assignment_expression [ SEMICOLON COMMA ] ## optional(expression,SEMICOLON) -> expression . SEMICOLON [ TILDE STRING_LITERAL STAR SIZEOF SEMICOLON RPAREN PRE_NAME PLUS MINUS LPAREN INC DEC CONSTANT BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AND ALIGNOF ] ## ## The known suffix of the stack is as follows: -## expression +## expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## # At the time of writing, optional(expression,SEMICOLON) is used only in FOR @@ -3579,14 +3579,14 @@ then at this point, a semicolon ';' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR LPAREN XOR_ASSIGN ## -## Ends in an error in state: 512. +## Ends in an error in state: 521. ## -## iteration_statement -> save_context FOR LPAREN . for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context FOR LPAREN . for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context FOR LPAREN +## save_context FOR LPAREN ## # gcc and clang say they expect an expression, which is incomplete. @@ -3600,14 +3600,14 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE FOR XOR_ASSIGN ## -## Ends in an error in state: 511. +## Ends in an error in state: 520. ## -## iteration_statement -> save_context FOR . LPAREN for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context FOR . LPAREN for_statement_header optional(expression,SEMICOLON) optional(expression,RPAREN) statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context FOR +## save_context FOR ## Ill-formed 'for' statement. @@ -3615,14 +3615,14 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE GOTO XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE GOTO XOR_ASSIGN ## -## Ends in an error in state: 436. +## Ends in an error in state: 445. ## -## jump_statement -> GOTO . general_identifier SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## jump_statement -> GOTO . general_identifier SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## GOTO +## GOTO ## Ill-formed 'goto' statement. @@ -3630,14 +3630,14 @@ At this point, an identifier (a 'goto' label) is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO IF LPAREN CONSTANT RPAREN SEMICOLON ELSE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE DO IF LPAREN CONSTANT RPAREN SEMICOLON ELSE XOR_ASSIGN ## -## Ends in an error in state: 559. +## Ends in an error in state: 569. ## -## selection_statement -> save_context ifelse_statement1 . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context ifelse_statement1 . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context ifelse_statement1 +## save_context ifelse_statement1 ## Ill-formed 'if' ... 'else' statement. @@ -3645,15 +3645,15 @@ At this point, a statement is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN ## -## Ends in an error in state: 508. +## Ends in an error in state: 517. ## ## ifelse_statement1 -> IF LPAREN expression RPAREN save_context . statement ELSE [ WHILE TILDE SWITCH STRING_LITERAL STAR SIZEOF SEMICOLON RETURN PRE_NAME PLUS MINUS LPAREN LBRACE INC IF GOTO FOR DO DEFAULT DEC CONTINUE CONSTANT CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG ASM AND ALIGNOF ] -## selection_statement -> save_context IF LPAREN expression RPAREN save_context . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context IF LPAREN expression RPAREN save_context . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context IF LPAREN expression RPAREN save_context +## save_context IF LPAREN expression RPAREN save_context ## Ill-formed 'if' statement. @@ -3661,36 +3661,36 @@ At this point, a statement is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 506. +## Ends in an error in state: 515. ## ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] ## ifelse_statement1 -> IF LPAREN expression . RPAREN save_context statement ELSE [ WHILE TILDE SWITCH STRING_LITERAL STAR SIZEOF SEMICOLON RETURN PRE_NAME PLUS MINUS LPAREN LBRACE INC IF GOTO FOR DO DEFAULT DEC CONTINUE CONSTANT CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG ASM AND ALIGNOF ] -## selection_statement -> save_context IF LPAREN expression . RPAREN save_context statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context IF LPAREN expression . RPAREN save_context statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context IF LPAREN expression +## save_context IF LPAREN expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## Ill-formed 'if' statement. @@ -3701,15 +3701,15 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF LPAREN XOR_ASSIGN ## -## Ends in an error in state: 505. +## Ends in an error in state: 514. ## ## ifelse_statement1 -> IF LPAREN . expression RPAREN save_context statement ELSE [ WHILE TILDE SWITCH STRING_LITERAL STAR SIZEOF SEMICOLON RETURN PRE_NAME PLUS MINUS LPAREN LBRACE INC IF GOTO FOR DO DEFAULT DEC CONTINUE CONSTANT CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG ASM AND ALIGNOF ] -## selection_statement -> save_context IF LPAREN . expression RPAREN save_context statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context IF LPAREN . expression RPAREN save_context statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context IF LPAREN +## save_context IF LPAREN ## Ill-formed 'if' statement. @@ -3717,15 +3717,15 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE IF XOR_ASSIGN ## -## Ends in an error in state: 504. +## Ends in an error in state: 513. ## ## ifelse_statement1 -> IF . LPAREN expression RPAREN save_context statement ELSE [ WHILE TILDE SWITCH STRING_LITERAL STAR SIZEOF SEMICOLON RETURN PRE_NAME PLUS MINUS LPAREN LBRACE INC IF GOTO FOR DO DEFAULT DEC CONTINUE CONSTANT CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG ASM AND ALIGNOF ] -## selection_statement -> save_context IF . LPAREN expression RPAREN save_context statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context IF . LPAREN expression RPAREN save_context statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context IF +## save_context IF ## Ill-formed 'if' statement. @@ -3733,14 +3733,14 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN ## -## Ends in an error in state: 502. +## Ends in an error in state: 511. ## -## selection_statement -> save_context SWITCH LPAREN expression RPAREN . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context SWITCH LPAREN expression RPAREN . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context SWITCH LPAREN expression RPAREN +## save_context SWITCH LPAREN expression RPAREN ## @@ -3757,35 +3757,35 @@ enclosed within braces '{' and '}'. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 501. +## Ends in an error in state: 510. ## ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] -## selection_statement -> save_context SWITCH LPAREN expression . RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context SWITCH LPAREN expression . RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context SWITCH LPAREN expression +## save_context SWITCH LPAREN expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## Ill-formed 'switch' statement. @@ -3796,14 +3796,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH LPAREN XOR_ASSIGN ## -## Ends in an error in state: 500. +## Ends in an error in state: 509. ## -## selection_statement -> save_context SWITCH LPAREN . expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context SWITCH LPAREN . expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context SWITCH LPAREN +## save_context SWITCH LPAREN ## Ill-formed 'switch' statement. @@ -3811,14 +3811,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE SWITCH XOR_ASSIGN ## -## Ends in an error in state: 499. +## Ends in an error in state: 508. ## -## selection_statement -> save_context SWITCH . LPAREN expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## selection_statement -> save_context SWITCH . LPAREN expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context SWITCH +## save_context SWITCH ## Ill-formed 'switch' statement. @@ -3826,14 +3826,14 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE LPAREN PRE_NAME VAR_NAME RPAREN XOR_ASSIGN ## -## Ends in an error in state: 486. +## Ends in an error in state: 495. ## -## iteration_statement -> save_context WHILE LPAREN expression RPAREN . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context WHILE LPAREN expression RPAREN . statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context WHILE LPAREN expression RPAREN +## save_context WHILE LPAREN expression RPAREN ## Ill-formed 'while' statement. @@ -3841,35 +3841,35 @@ At this point, a statement (the loop body) is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE LPAREN PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE LPAREN PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 485. +## Ends in an error in state: 494. ## ## expression -> expression . COMMA assignment_expression [ RPAREN COMMA ] -## iteration_statement -> save_context WHILE LPAREN expression . RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context WHILE LPAREN expression . RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context WHILE LPAREN expression +## save_context WHILE LPAREN expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## Ill-formed 'while' statement. @@ -3880,14 +3880,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE LPAREN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE LPAREN XOR_ASSIGN ## -## Ends in an error in state: 484. +## Ends in an error in state: 493. ## -## iteration_statement -> save_context WHILE LPAREN . expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context WHILE LPAREN . expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context WHILE LPAREN +## save_context WHILE LPAREN ## Ill-formed 'while' statement. @@ -3895,14 +3895,14 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE WHILE XOR_ASSIGN ## -## Ends in an error in state: 483. +## Ends in an error in state: 492. ## -## iteration_statement -> save_context WHILE . LPAREN expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## iteration_statement -> save_context WHILE . LPAREN expression RPAREN statement [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context WHILE +## save_context WHILE ## Ill-formed 'while' statement. @@ -3910,15 +3910,15 @@ At this point, an opening parenthesis '(' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE XOR_ASSIGN ## -## Ends in an error in state: 427. +## Ends in an error in state: 436. ## -## block_item_list -> option(block_item_list) . block_item [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] -## compound_statement -> save_context LBRACE option(block_item_list) . RBRACE [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## block_item_list -> option(block_item_list) . block_item [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## compound_statement -> save_context LBRACE option(block_item_list) . RBRACE [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## save_context LBRACE option(block_item_list) +## save_context LBRACE option(block_item_list) ## # We are possibly at the end of a block. # @@ -3938,14 +3938,14 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE RETURN XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE RETURN XOR_ASSIGN ## -## Ends in an error in state: 428. +## Ends in an error in state: 437. ## -## jump_statement -> RETURN . option(expression) SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## jump_statement -> RETURN . option(expression) SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN ENUM ELSE DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] ## ## The known suffix of the stack is as follows: -## RETURN +## RETURN ## # clang and gcc expect an expression. @@ -3957,37 +3957,37 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE STRING_LITERAL RPAREN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE STRING_LITERAL RPAREN ## -## Ends in an error in state: 431. +## Ends in an error in state: 440. ## ## expression -> expression . COMMA assignment_expression [ SEMICOLON COMMA ] ## option(expression) -> expression . [ SEMICOLON ] ## ## The known suffix of the stack is as follows: -## expression +## expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 155, spurious reduction of production primary_expression -> string_literals_list -## In state 157, spurious reduction of production postfix_expression -> primary_expression -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 224, spurious reduction of production expression -> assignment_expression +## In state 80, spurious reduction of production primary_expression -> string_literals_list +## In state 82, spurious reduction of production postfix_expression -> primary_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 149, spurious reduction of production expression -> assignment_expression ## Up to this point, an expression has been recognized: @@ -3997,16 +3997,16 @@ then at this point, a semicolon ';' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 568. +## Ends in an error in state: 578. ## ## declaration_specifiers(declaration(block_item)) -> typedef_name . list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers_typedef -> typedef_name . list(declaration_specifier_no_type) TYPEDEF list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] ## general_identifier -> typedef_name . [ COLON ] ## ## The known suffix of the stack is as follows: -## typedef_name +## typedef_name ## # We see a type name "foo" at the beginning of a block_item, it seems. @@ -4032,14 +4032,14 @@ at this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME RPAREN LBRACE PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 219. +## Ends in an error in state: 144. ## ## expression -> expression COMMA . assignment_expression [ SEMICOLON RPAREN RBRACK COMMA COLON ] ## ## The known suffix of the stack is as follows: -## expression COMMA +## expression COMMA ## Ill-formed use of the sequencing operator ','. @@ -4047,26 +4047,26 @@ At this point, an expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME COMMA PRE_NAME VAR_NAME RPAREN +translation_unit_file: INT PRE_NAME VAR_NAME COMMA PRE_NAME VAR_NAME RPAREN ## -## Ends in an error in state: 545. +## Ends in an error in state: 555. ## ## init_declarator_list -> init_declarator_list . COMMA init_declarator [ SEMICOLON COMMA ] ## option(init_declarator_list) -> init_declarator_list . [ SEMICOLON ] ## ## The known suffix of the stack is as follows: -## init_declarator_list +## init_declarator_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 255, spurious reduction of production declarator_noattrend -> direct_declarator -## In state 553, spurious reduction of production declare_varname(declarator_noattrend) -> declarator_noattrend -## In state 548, spurious reduction of production save_context -> -## In state 549, spurious reduction of production attribute_specifier_list -> -## In state 550, spurious reduction of production init_declarator -> declare_varname(declarator_noattrend) save_context attribute_specifier_list -## In state 547, spurious reduction of production init_declarator_list -> init_declarator_list COMMA init_declarator +## In state 263, spurious reduction of production declarator_noattrend -> direct_declarator +## In state 563, spurious reduction of production declare_varname(declarator_noattrend) -> declarator_noattrend +## In state 558, spurious reduction of production save_context -> +## In state 559, spurious reduction of production attribute_specifier_list -> +## In state 560, spurious reduction of production init_declarator -> declare_varname(declarator_noattrend) save_context attribute_specifier_list +## In state 557, spurious reduction of production init_declarator_list -> init_declarator_list COMMA init_declarator ## Up to this point, a list of declarators has been recognized: @@ -4076,14 +4076,14 @@ then at this point, a semicolon ';' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 546. +## Ends in an error in state: 556. ## ## init_declarator_list -> init_declarator_list COMMA . init_declarator [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## init_declarator_list COMMA +## init_declarator_list COMMA ## Ill-formed declaration. @@ -4091,23 +4091,23 @@ At this point, an init declarator is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE DOT PRE_NAME VAR_NAME EQ ALIGNAS +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE DOT PRE_NAME VAR_NAME EQ ALIGNAS ## -## Ends in an error in state: 366. +## Ends in an error in state: 374. ## ## initializer_list -> option(designation) . c_initializer [ RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## option(designation) +## option(designation) ## -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE PRE_NAME VAR_NAME COMMA DOT PRE_NAME VAR_NAME EQ ALIGNAS +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE PRE_NAME VAR_NAME COMMA DOT PRE_NAME VAR_NAME EQ ALIGNAS ## -## Ends in an error in state: 370. +## Ends in an error in state: 378. ## ## initializer_list -> initializer_list COMMA option(designation) . c_initializer [ RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## initializer_list COMMA option(designation) +## initializer_list COMMA option(designation) ## Ill-formed initializer list. @@ -4115,15 +4115,15 @@ At this point, an initializer is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE DOT PRE_NAME VAR_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE DOT PRE_NAME VAR_NAME XOR_ASSIGN ## -## Ends in an error in state: 373. +## Ends in an error in state: 381. ## ## designation -> designator_list . EQ [ TILDE STRING_LITERAL STAR SIZEOF PRE_NAME PLUS MINUS LPAREN LBRACE INC DEC CONSTANT BUILTIN_VA_ARG BUILTIN_OFFSETOF BANG AND ALIGNOF ] ## option(designator_list) -> designator_list . [ LBRACK DOT ] ## ## The known suffix of the stack is as follows: -## designator_list +## designator_list ## # We are expecting either one more designator, @@ -4137,14 +4137,14 @@ then at this point, an equals sign '=' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE DOT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE DOT XOR_ASSIGN ## -## Ends in an error in state: 326. +## Ends in an error in state: 334. ## ## designator -> DOT . general_identifier [ RPAREN LBRACK EQ DOT ] ## ## The known suffix of the stack is as follows: -## DOT +## DOT ## # clang gives examples of designators. @@ -4154,32 +4154,32 @@ At this point, the name of a struct or union member is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE LBRACK PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE LBRACK PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 324. +## Ends in an error in state: 332. ## ## designator -> LBRACK conditional_expression . RBRACK [ RPAREN LBRACK EQ DOT ] ## ## The known suffix of the stack is as follows: -## LBRACK conditional_expression +## LBRACK conditional_expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 154, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 79, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression ## Ill-formed designator. @@ -4190,14 +4190,14 @@ then at this point, a closing bracket ']' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE LBRACK XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE LBRACK XOR_ASSIGN ## -## Ends in an error in state: 323. +## Ends in an error in state: 331. ## ## designator -> LBRACK . conditional_expression RBRACK [ RPAREN LBRACK EQ DOT ] ## ## The known suffix of the stack is as follows: -## LBRACK +## LBRACK ## Ill-formed designator. @@ -4205,15 +4205,15 @@ At this point, a constant expression is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 369. +## Ends in an error in state: 377. ## ## initializer_list -> initializer_list COMMA . option(designation) c_initializer [ RBRACE COMMA ] ## option(COMMA) -> COMMA . [ RBRACE ] ## ## The known suffix of the stack is as follows: -## initializer_list COMMA +## initializer_list COMMA ## # This could be a trailing comma, in which case a closing brace is legal. @@ -4226,36 +4226,36 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE CONSTANT SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE CONSTANT SEMICOLON ## -## Ends in an error in state: 368. +## Ends in an error in state: 376. ## ## c_initializer -> LBRACE initializer_list . option(COMMA) RBRACE [ SEMICOLON RBRACE COMMA ] ## initializer_list -> initializer_list . COMMA option(designation) c_initializer [ RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## LBRACE initializer_list +## LBRACE initializer_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression -## In state 372, spurious reduction of production c_initializer -> assignment_expression -## In state 378, spurious reduction of production initializer_list -> option(designation) c_initializer +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression +## In state 380, spurious reduction of production c_initializer -> assignment_expression +## In state 386, spurious reduction of production initializer_list -> option(designation) c_initializer ## # Omitting the fact that the closing brace can be preceded with a comma. @@ -4268,14 +4268,14 @@ then at this point, a closing brace '}' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ LBRACE XOR_ASSIGN ## -## Ends in an error in state: 367. +## Ends in an error in state: 375. ## ## c_initializer -> LBRACE . initializer_list option(COMMA) RBRACE [ SEMICOLON RBRACE COMMA ] ## ## The known suffix of the stack is as follows: -## LBRACE +## LBRACE ## # An initializer list is expected. @@ -4289,14 +4289,14 @@ followed with an initializer, is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME EQ XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME EQ XOR_ASSIGN ## -## Ends in an error in state: 551. +## Ends in an error in state: 561. ## ## init_declarator -> declare_varname(declarator_noattrend) save_context attribute_specifier_list EQ . c_initializer [ SEMICOLON COMMA ] ## ## The known suffix of the stack is as follows: -## declare_varname(declarator_noattrend) save_context attribute_specifier_list EQ +## declare_varname(declarator_noattrend) save_context attribute_specifier_list EQ ## # clang and gcc expect an expression (incomplete). @@ -4306,33 +4306,33 @@ At this point, an initializer is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LBRACK CONSTANT SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LBRACK CONSTANT SEMICOLON ## -## Ends in an error in state: 243. +## Ends in an error in state: 251. ## ## optional(assignment_expression,RBRACK) -> assignment_expression . RBRACK [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## assignment_expression +## assignment_expression ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 158, spurious reduction of production unary_expression -> postfix_expression -## In state 162, spurious reduction of production cast_expression -> unary_expression -## In state 185, spurious reduction of production multiplicative_expression -> cast_expression -## In state 179, spurious reduction of production additive_expression -> multiplicative_expression -## In state 198, spurious reduction of production shift_expression -> additive_expression -## In state 175, spurious reduction of production relational_expression -> shift_expression -## In state 191, spurious reduction of production equality_expression -> relational_expression -## In state 207, spurious reduction of production and_expression -> equality_expression -## In state 215, spurious reduction of production exclusive_or_expression -> and_expression -## In state 216, spurious reduction of production inclusive_or_expression -> exclusive_or_expression -## In state 217, spurious reduction of production logical_and_expression -> inclusive_or_expression -## In state 201, spurious reduction of production logical_or_expression -> logical_and_expression -## In state 199, spurious reduction of production conditional_expression -> logical_or_expression -## In state 220, spurious reduction of production assignment_expression -> conditional_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 87, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## In state 145, spurious reduction of production assignment_expression -> conditional_expression ## # At the time of writing, optional(expression,RBRACK) is used only in direct @@ -4348,14 +4348,14 @@ then at this point, a closing bracket ']' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME COMMA XOR_ASSIGN ## -## Ends in an error in state: 282. +## Ends in an error in state: 290. ## ## identifier_list -> identifier_list COMMA . PRE_NAME VAR_NAME [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## identifier_list COMMA +## identifier_list COMMA ## # Strangely, gcc requests ')'. @@ -4365,14 +4365,14 @@ At this point, an identifier is expected. # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME COMMA PRE_NAME TYPEDEF_NAME +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME COMMA PRE_NAME TYPEDEF_NAME ## -## Ends in an error in state: 283. +## Ends in an error in state: 291. ## ## identifier_list -> identifier_list COMMA PRE_NAME . VAR_NAME [ RPAREN COMMA ] ## ## The known suffix of the stack is as follows: -## identifier_list COMMA PRE_NAME +## identifier_list COMMA PRE_NAME ## Ill-formed K&R function definition. @@ -4381,29 +4381,29 @@ The following type name is used as a K&R parameter name: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN INT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN INT XOR_ASSIGN ## -## Ends in an error in state: 586. +## Ends in an error in state: 596. ## ## declaration_specifiers(declaration(block_item)) -> type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOLATILE INT XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOLATILE INT XOR_ASSIGN ## -## Ends in an error in state: 591. +## Ends in an error in state: 601. ## ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_typedef_name) -> list(declaration_specifier_no_typedef_name) . declaration_specifier_no_typedef_name [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC STAR SIGNED SHORT SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) +## rlist(declaration_specifier_no_type) type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 584. +## Ends in an error in state: 594. ## ## declaration_specifiers(declaration(block_item)) -> typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] @@ -4412,11 +4412,11 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN PRE ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## typedef_name list(declaration_specifier_no_type) +## typedef_name list(declaration_specifier_no_type) ## -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOLATILE PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 589. +## Ends in an error in state: 599. ## ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) . [ STAR SEMICOLON PRE_NAME LPAREN ] ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . storage_class_specifier_no_typedef [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] @@ -4425,7 +4425,7 @@ translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOL ## list(declaration_specifier_no_type) -> list(declaration_specifier_no_type) . attribute_specifier [ VOLATILE STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) typedef_name list(declaration_specifier_no_type) ## # We omit the case of the empty list of declarators @@ -4439,21 +4439,21 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOLATILE XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN VOLATILE XOR_ASSIGN ## -## Ends in an error in state: 587. +## Ends in an error in state: 597. ## ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) . typedef_name list(declaration_specifier_no_type) [ STAR SEMICOLON PRE_NAME LPAREN ] ## declaration_specifiers(declaration(block_item)) -> rlist(declaration_specifier_no_type) . type_specifier_no_typedef_name list(declaration_specifier_no_typedef_name) [ STAR SEMICOLON PRE_NAME LPAREN ] ## ## The known suffix of the stack is as follows: -## rlist(declaration_specifier_no_type) +## rlist(declaration_specifier_no_type) ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 125, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr +## In state 222, spurious reduction of production rlist(declaration_specifier_no_type) -> type_qualifier_noattr ## Ill-formed K&R parameter declaration. @@ -4464,16 +4464,16 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: VOID PRE_NAME TYPEDEF_NAME PACKED LPAREN CONSTANT RPAREN XOR_ASSIGN +translation_unit_file: VOID PRE_NAME TYPEDEF_NAME PACKED LPAREN CONSTANT RPAREN XOR_ASSIGN ## -## Ends in an error in state: 600. +## Ends in an error in state: 610. ## ## attribute_specifier_list -> attribute_specifier . attribute_specifier_list [ SEMICOLON LBRACE EQ COMMA ] ## rlist(declaration_specifier_no_type) -> attribute_specifier . [ VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT SIGNED SHORT PRE_NAME LONG INT FLOAT ENUM DOUBLE CHAR ] ## rlist(declaration_specifier_no_type) -> attribute_specifier . rlist(declaration_specifier_no_type) [ VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT SIGNED SHORT PRE_NAME LONG INT FLOAT ENUM DOUBLE CHAR ] ## ## The known suffix of the stack is as follows: -## attribute_specifier +## attribute_specifier ## # We have just parsed a list of attribute specifiers, but we cannot @@ -4497,15 +4497,15 @@ If this is the parameter declaration of a K&R function definition, # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT COMMA XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT COMMA XOR_ASSIGN ## -## Ends in an error in state: 141. +## Ends in an error in state: 238. ## ## parameter_list -> parameter_list COMMA . parameter_declaration [ RPAREN COMMA ] ## parameter_type_list -> parameter_list COMMA . ELLIPSIS [ RPAREN ] ## ## The known suffix of the stack is as follows: -## parameter_list COMMA +## parameter_list COMMA ## At this point, one of the following is expected: @@ -4514,27 +4514,27 @@ At this point, one of the following is expected: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME SEMICOLON +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN INT PRE_NAME VAR_NAME SEMICOLON ## -## Ends in an error in state: 140. +## Ends in an error in state: 237. ## ## parameter_list -> parameter_list . COMMA parameter_declaration [ RPAREN COMMA ] ## parameter_type_list -> parameter_list . [ RPAREN ] ## parameter_type_list -> parameter_list . COMMA ELLIPSIS [ RPAREN ] ## ## The known suffix of the stack is as follows: -## parameter_list +## parameter_list ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 255, spurious reduction of production declarator_noattrend -> direct_declarator -## In state 260, spurious reduction of production attribute_specifier_list -> -## In state 261, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list -## In state 277, spurious reduction of production declare_varname(declarator) -> declarator -## In state 276, spurious reduction of production parameter_declaration -> declaration_specifiers(parameter_declaration) declare_varname(declarator) -## In state 148, spurious reduction of production parameter_list -> parameter_declaration +## In state 263, spurious reduction of production declarator_noattrend -> direct_declarator +## In state 268, spurious reduction of production attribute_specifier_list -> +## In state 269, spurious reduction of production declarator -> declarator_noattrend attribute_specifier_list +## In state 285, spurious reduction of production declare_varname(declarator) -> declarator +## In state 284, spurious reduction of production parameter_declaration -> declaration_specifiers(parameter_declaration) declare_varname(declarator) +## In state 245, spurious reduction of production parameter_list -> parameter_declaration ## # We omit the possibility of an ellipsis. @@ -4550,14 +4550,14 @@ then at this point, a closing parenthesis ')' is expected. # ------------------------------------------------------------------------------ -translation_unit_file: PRE_NAME VAR_NAME +translation_unit_file: PRE_NAME VAR_NAME ## ## Ends in an error in state: 16. ## ## typedef_name -> PRE_NAME . TYPEDEF_NAME [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA COLON AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## # This can only happen in a declaration @@ -4568,15 +4568,15 @@ The following identifier is used as a type, but has not been defined as such: # ------------------------------------------------------------------------------ -translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN INT SEMICOLON XOR_ASSIGN +translation_unit_file: INT PRE_NAME VAR_NAME LPAREN PRE_NAME VAR_NAME RPAREN INT SEMICOLON XOR_ASSIGN ## -## Ends in an error in state: 596. +## Ends in an error in state: 606. ## ## declaration_list -> declaration_list . kr_param_declaration [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT RESTRICT REGISTER PRE_NAME PACKED NORETURN LONG LBRACE INT INLINE FLOAT EXTERN ENUM DOUBLE CONST CHAR AUTO ATTRIBUTE ALIGNAS ] ## function_definition1 -> declaration_specifiers(declaration(external_declaration)) declare_varname(declarator_noattrend) save_context declaration_list . [ LBRACE ] ## ## The known suffix of the stack is as follows: -## declaration_specifiers(declaration(external_declaration)) declare_varname(declarator_noattrend) save_context declaration_list +## declaration_specifiers(declaration(external_declaration)) declare_varname(declarator_noattrend) save_context declaration_list ## # clang requests the function body; gcc requests a declaration :-) @@ -4587,7 +4587,7 @@ At this point, one of the following is expected: #------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF XOR_ASSIGN +translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF XOR_ASSIGN ## ## Ends in an error in state: 52. ## @@ -4595,7 +4595,7 @@ translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF XOR_ASSIGN ## postfix_expression -> BUILTIN_OFFSETOF . LPAREN type_name COMMA general_identifier designator_list RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_OFFSETOF +## BUILTIN_OFFSETOF ## Ill-formed __builtin_offsetof. @@ -4603,7 +4603,7 @@ At this point, an opening parenthesis '(' is expected. #------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN XOR_ASSIGN +translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN XOR_ASSIGN ## ## Ends in an error in state: 53. ## @@ -4611,7 +4611,7 @@ translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN XOR_ASSIGN ## postfix_expression -> BUILTIN_OFFSETOF LPAREN . type_name COMMA general_identifier designator_list RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_OFFSETOF LPAREN +## BUILTIN_OFFSETOF LPAREN ## Ill-formed __builtin_offsetof. @@ -4619,23 +4619,23 @@ At this point, a struct or union name is expected. #------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID XOR_ASSIGN +translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID XOR_ASSIGN ## -## Ends in an error in state: 318. +## Ends in an error in state: 326. ## ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name . COMMA general_identifier RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name . COMMA general_identifier designator_list RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_OFFSETOF LPAREN type_name +## BUILTIN_OFFSETOF LPAREN type_name ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). ## In state 67, spurious reduction of production specifier_qualifier_list(type_name) -> type_specifier_no_typedef_name list(specifier_qualifier_no_typedef_name) -## In state 306, spurious reduction of production option(abstract_declarator(type_name)) -> -## In state 312, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) +## In state 314, spurious reduction of production option(abstract_declarator(type_name)) -> +## In state 320, spurious reduction of production type_name -> specifier_qualifier_list(type_name) option(abstract_declarator(type_name)) ## Ill-formed __builtin_offsetof. @@ -4643,15 +4643,15 @@ At this point, a colon ',' is expected #------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID COMMA XOR_ASSIGN +translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID COMMA XOR_ASSIGN ## -## Ends in an error in state: 319. +## Ends in an error in state: 327. ## ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name COMMA . general_identifier RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name COMMA . general_identifier designator_list RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_OFFSETOF LPAREN type_name COMMA +## BUILTIN_OFFSETOF LPAREN type_name COMMA ## Ill-formed __builtin_offsetof. @@ -4659,15 +4659,15 @@ At this point, a member-designator is expected. #------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID COMMA PRE_NAME TYPEDEF_NAME XOR_ASSIGN +translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID COMMA PRE_NAME TYPEDEF_NAME XOR_ASSIGN ## -## Ends in an error in state: 320. +## Ends in an error in state: 328. ## ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier . RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier . designator_list RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier +## BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier ## Ill-formed __builtin_offsetof. @@ -4675,24 +4675,134 @@ At this point, a member-designator is expected. #------------------------------------------------------------------------------ -translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID COMMA PRE_NAME TYPEDEF_NAME LBRACK STRING_LITERAL RBRACK XOR_ASSIGN +translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF LPAREN VOID COMMA PRE_NAME TYPEDEF_NAME LBRACK STRING_LITERAL RBRACK XOR_ASSIGN ## -## Ends in an error in state: 329. +## Ends in an error in state: 337. ## ## option(designator_list) -> designator_list . [ LBRACK DOT ] ## postfix_expression -> BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier designator_list . RPAREN [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RBRACK RBRACE QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA COLON BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier designator_list +## BUILTIN_OFFSETOF LPAREN type_name COMMA general_identifier designator_list ## Ill-formed __builtin_offsetof. At this point, a member-designator is expected. +# ------------------------------------------------------------------------------ + +translation_unit_file: STATIC_ASSERT XOR_ASSIGN +## +## Ends in an error in state: 76. +## +## static_assert_declaration -> STATIC_ASSERT . LPAREN conditional_expression COMMA string_literals_list RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## +## The known suffix of the stack is as follows: +## STATIC_ASSERT +## + +Ill-formed _Static_assert. +At this point, an opening parenthesis '(' is expected. #------------------------------------------------------------------------------ -translation_unit_file: ALIGNAS LPAREN PRE_NAME XOR_ASSIGN +translation_unit_file: STATIC_ASSERT LPAREN XOR_ASSIGN +## +## Ends in an error in state: 77. +## +## static_assert_declaration -> STATIC_ASSERT LPAREN . conditional_expression COMMA string_literals_list RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## +## The known suffix of the stack is as follows: +## STATIC_ASSERT LPAREN +## + +Ill-formed _Static_assert. +At this point, a constant expression is expected. + +#------------------------------------------------------------------------------ + +translation_unit_file: STATIC_ASSERT LPAREN STRING_LITERAL XOR_ASSIGN +## +## Ends in an error in state: 167. +## +## static_assert_declaration -> STATIC_ASSERT LPAREN conditional_expression . COMMA string_literals_list RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## +## The known suffix of the stack is as follows: +## STATIC_ASSERT LPAREN conditional_expression +## +## WARNING: This example involves spurious reductions. +## This implies that, although the LR(1) items shown above provide an +## accurate view of the past (what has been recognized so far), they +## may provide an INCOMPLETE view of the future (what was expected next). +## In state 80, spurious reduction of production primary_expression -> string_literals_list +## In state 82, spurious reduction of production postfix_expression -> primary_expression +## In state 83, spurious reduction of production unary_expression -> postfix_expression +## In state 79, spurious reduction of production cast_expression -> unary_expression +## In state 110, spurious reduction of production multiplicative_expression -> cast_expression +## In state 104, spurious reduction of production additive_expression -> multiplicative_expression +## In state 123, spurious reduction of production shift_expression -> additive_expression +## In state 100, spurious reduction of production relational_expression -> shift_expression +## In state 116, spurious reduction of production equality_expression -> relational_expression +## In state 132, spurious reduction of production and_expression -> equality_expression +## In state 140, spurious reduction of production exclusive_or_expression -> and_expression +## In state 141, spurious reduction of production inclusive_or_expression -> exclusive_or_expression +## In state 142, spurious reduction of production logical_and_expression -> inclusive_or_expression +## In state 126, spurious reduction of production logical_or_expression -> logical_and_expression +## In state 124, spurious reduction of production conditional_expression -> logical_or_expression +## + +Ill-formed _Static_assert. +At this point, a comma ',' is expected. + +#------------------------------------------------------------------------------ + +translation_unit_file: STATIC_ASSERT LPAREN STRING_LITERAL COMMA XOR_ASSIGN +## +## Ends in an error in state: 168. +## +## static_assert_declaration -> STATIC_ASSERT LPAREN conditional_expression COMMA . string_literals_list RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## +## The known suffix of the stack is as follows: +## STATIC_ASSERT LPAREN conditional_expression COMMA +## + +Ill-formed _Static_assert. +At this point, a string literal is expected. + +#------------------------------------------------------------------------------ + +translation_unit_file: STATIC_ASSERT LPAREN STRING_LITERAL COMMA STRING_LITERAL XOR_ASSIGN +## +## Ends in an error in state: 169. +## +## static_assert_declaration -> STATIC_ASSERT LPAREN conditional_expression COMMA string_literals_list . RPAREN SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## string_literals_list -> string_literals_list . STRING_LITERAL [ STRING_LITERAL RPAREN ] +## +## The known suffix of the stack is as follows: +## STATIC_ASSERT LPAREN conditional_expression COMMA string_literals_list +## + +Ill-formed _Static_assert. +At this point, a closing parenthesis ')' is expected. + +#------------------------------------------------------------------------------ + +translation_unit_file: STATIC_ASSERT LPAREN STRING_LITERAL COMMA STRING_LITERAL RPAREN XOR_ASSIGN +## +## Ends in an error in state: 170. +## +## static_assert_declaration -> STATIC_ASSERT LPAREN conditional_expression COMMA string_literals_list RPAREN . SEMICOLON [ WHILE VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF TILDE SWITCH STRUCT STRING_LITERAL STATIC_ASSERT STATIC STAR SIZEOF SIGNED SHORT SEMICOLON RETURN RESTRICT REGISTER RBRACE PRE_NAME PRAGMA PLUS PACKED NORETURN MINUS LPAREN LONG LBRACE INT INLINE INC IF GOTO FOR FLOAT EXTERN EOF ENUM DOUBLE DO DEFAULT DEC CONTINUE CONSTANT CONST CHAR CASE BUILTIN_VA_ARG BUILTIN_OFFSETOF BREAK BANG AUTO ATTRIBUTE ASM AND ALIGNOF ALIGNAS ] +## +## The known suffix of the stack is as follows: +## STATIC_ASSERT LPAREN conditional_expression COMMA string_literals_list RPAREN +## + +Ill-formed _Static_assert. +At this point, a semicolon ';' is expected. + +#------------------------------------------------------------------------------ + +translation_unit_file: ALIGNAS LPAREN PRE_NAME XOR_ASSIGN ## ## Ends in an error in state: 29. ## @@ -4700,20 +4810,20 @@ translation_unit_file: ALIGNAS LPAREN PRE_NAME XOR_ASSIGN ## typedef_name -> PRE_NAME . TYPEDEF_NAME [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## -translation_unit_file: ALIGNAS LPAREN VOID LPAREN VOID LPAREN PRE_NAME XOR_ASSIGN +translation_unit_file: ALIGNAS LPAREN VOID LPAREN VOID LPAREN PRE_NAME XOR_ASSIGN ## -## Ends in an error in state: 147. +## Ends in an error in state: 244. ## ## declarator_identifier -> PRE_NAME . low_prec TYPEDEF_NAME [ RPAREN PACKED LPAREN LBRACK ATTRIBUTE ALIGNAS ] ## declarator_identifier -> PRE_NAME . VAR_NAME [ RPAREN PACKED LPAREN LBRACK ATTRIBUTE ALIGNAS ] ## typedef_name -> PRE_NAME . TYPEDEF_NAME [ VOLATILE STATIC STAR RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## -translation_unit_file: UNION PRE_NAME XOR_ASSIGN +translation_unit_file: UNION PRE_NAME XOR_ASSIGN ## ## Ends in an error in state: 40. ## @@ -4721,38 +4831,38 @@ translation_unit_file: UNION PRE_NAME XOR_ASSIGN ## typedef_name -> PRE_NAME . TYPEDEF_NAME [ XOR_ASSIGN VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL TYPEDEF SUB_ASSIGN STRUCT STATIC STAR SLASH SIGNED SHORT SEMICOLON RPAREN RIGHT_ASSIGN RIGHT RESTRICT REGISTER RBRACK RBRACE QUESTION PTR PRE_NAME PLUS PERCENT PACKED OR_ASSIGN NORETURN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LONG LEQ LEFT_ASSIGN LEFT LBRACK LBRACE INT INLINE INC HAT GT GEQ FLOAT EXTERN EQEQ EQ ENUM DOUBLE DOT DIV_ASSIGN DEC CONST COMMA COLON CHAR BARBAR BAR AUTO ATTRIBUTE AND_ASSIGN ANDAND AND ALIGNAS ADD_ASSIGN ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## -translation_unit_file: VOID PRE_NAME TYPEDEF_NAME LBRACE PRE_NAME XOR_ASSIGN +translation_unit_file: VOID PRE_NAME TYPEDEF_NAME LBRACE PRE_NAME XOR_ASSIGN ## -## Ends in an error in state: 433. +## Ends in an error in state: 442. ## ## general_identifier -> PRE_NAME . VAR_NAME [ COLON ] ## primary_expression -> PRE_NAME . VAR_NAME [ XOR_ASSIGN SUB_ASSIGN STAR SLASH SEMICOLON RIGHT_ASSIGN RIGHT QUESTION PTR PLUS PERCENT OR_ASSIGN NEQ MUL_ASSIGN MOD_ASSIGN MINUS LT LPAREN LEQ LEFT_ASSIGN LEFT LBRACK INC HAT GT GEQ EQEQ EQ DOT DIV_ASSIGN DEC COMMA BARBAR BAR AND_ASSIGN ANDAND AND ADD_ASSIGN ] ## typedef_name -> PRE_NAME . TYPEDEF_NAME [ VOLATILE TYPEDEF STATIC STAR SEMICOLON RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN INLINE EXTERN CONST COLON AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## -translation_unit_file: VOID PRE_NAME TYPEDEF_NAME LPAREN PRE_NAME XOR_ASSIGN +translation_unit_file: VOID PRE_NAME TYPEDEF_NAME LPAREN PRE_NAME XOR_ASSIGN ## -## Ends in an error in state: 105. +## Ends in an error in state: 202. ## ## identifier_list -> PRE_NAME . VAR_NAME [ RPAREN COMMA ] ## typedef_name -> PRE_NAME . TYPEDEF_NAME [ VOLATILE STATIC STAR RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LBRACK INLINE EXTERN CONST COMMA AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## -translation_unit_file: VOID PRE_NAME XOR_ASSIGN +translation_unit_file: VOID PRE_NAME XOR_ASSIGN ## -## Ends in an error in state: 93. +## Ends in an error in state: 190. ## ## declarator_identifier -> PRE_NAME . low_prec TYPEDEF_NAME [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## declarator_identifier -> PRE_NAME . VAR_NAME [ VOLATILE VOID UNSIGNED UNION UNDERSCORE_BOOL STRUCT STATIC SIGNED SHORT SEMICOLON RPAREN RESTRICT REGISTER PRE_NAME PACKED NORETURN LPAREN LONG LBRACK LBRACE INT INLINE FLOAT EXTERN EQ ENUM DOUBLE CONST COMMA COLON CHAR AUTO ATTRIBUTE ALIGNAS ] ## ## The known suffix of the stack is as follows: -## PRE_NAME +## PRE_NAME ## # This is not supposed to be possible, since the Lexer can only emit a diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly index e21a3519..822c7011 100644 --- a/cparser/pre_parser.mly +++ b/cparser/pre_parser.mly @@ -57,7 +57,7 @@ AUTO REGISTER INLINE THREAD_LOCAL NORETURN CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE UNDERSCORE_BOOL CONST VOLATILE VOID STRUCT UNION ENUM CASE DEFAULT IF ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK RETURN BUILTIN_VA_ARG ALIGNOF - ATTRIBUTE ALIGNAS PACKED ASM BUILTIN_OFFSETOF + ATTRIBUTE ALIGNAS PACKED ASM BUILTIN_OFFSETOF STATIC_ASSERT %token EOF @@ -404,6 +404,7 @@ expression: declaration(phantom): | declaration_specifiers(declaration(phantom)) init_declarator_list? SEMICOLON | declaration_specifiers_typedef typedef_declarator_list? SEMICOLON +| static_assert_declaration {} init_declarator_list: @@ -519,6 +520,7 @@ struct_declaration_list: struct_declaration: | specifier_qualifier_list(struct_declaration) struct_declarator_list? SEMICOLON +| static_assert_declaration {} (* As in the standard, except it also encodes the constraint described @@ -608,6 +610,10 @@ gcc_attribute_word: | PACKED {} +static_assert_declaration: +| STATIC_ASSERT LPAREN constant_expression COMMA string_literals_list RPAREN SEMICOLON + {} + function_specifier: | INLINE | NORETURN diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml index 6c1d0846..020ac60e 100644 --- a/debug/Dwarfgen.ml +++ b/debug/Dwarfgen.ml @@ -543,8 +543,8 @@ let diab_file_loc sec (f,l) = let prod_name = let version_string = - if Version.buildnr <> "" && Version.tag <> "" then - Printf.sprintf "Release: %s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag + if Version.buildnr <> "" && Version.tag <> "" && Version.branch <> "" then + Printf.sprintf "Release: %s, Build: %s, Tag: %s, Branch:%s" Version.version Version.buildnr Version.tag Version.branch else Version.version in Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)" diff --git a/doc/index-kvx.html b/doc/index-kvx.html index b8850727..6d56cbdb 100644 --- a/doc/index-kvx.html +++ b/doc/index-kvx.html @@ -22,15 +22,17 @@ a:active {color : Red; text-decoration : underline; } </HEAD> <BODY> -<font color=gray><H1 align="center">The CompCert verified compiler</H1> +<font color=gray> +<H1 align="center">The CompCert verified compiler</H1> <H2 align="center">Commented Coq development</H2> -<H3 align="center">Version 3.7, 2020-03-31</H3></font> +<H3 align="center">Version 3.8, 2020-11-16</H3> +</font> <H3 align="center">PATCHED for the Kalray MPPA-KVX VLIW CORE<!--@DATE@--></H3> <H2>Introduction</H2> -<p>This web page is a patched version of the table of contents of the official CompCert documentation, - as given on <A HREF="http://compcert.inria.fr/doc/index.html">the CompCert Web site</A>. +<p>This web page is a patched version of the table of contents of the official CompCert sources documentation, + as given on <A HREF="http://compcert.org/doc/index.html">the CompCert Web site</A>. The unmodified parts of this table appear in <font color=gray>gray</font>. <br> <br> @@ -40,7 +42,8 @@ a:active {color : Red; text-decoration : underline; } See also the <tt>README.md</tt> of our <a href=https://gricad-gitlab.univ-grenoble-alpes.fr/certicompil/compcert-kvx>GitLab public repository</a>. </p> -<font color=gray><H2>Table of contents</H2> +<font color=gray> +<H2>Table of contents</H2> <H3>General-purpose libraries, data structures and algorithms</H3> @@ -62,9 +65,9 @@ inequations by fixpoint iteration. <H4>The <tt>abstractbb</tt> library, introduced for KVX core</H4> <UL> -<LI> <A HREF="html/compcert.kvx.abstractbb.AbstractBasicBlocksDef.html">AbstractBasicBlocksDef</A>: an IR for verifying some semantic properties on basic-blocks. -<LI> <A HREF="html/compcert.kvx.abstractbb.Parallelizability.html">Parallelizability</A>: verifying that sequential and parallel semantics are equivalent for a given abstract basic-block. -<LI> <A HREF="html/compcert.kvx.abstractbb.ImpSimuTest.html">ImpSimuTest</A>: verifying that a given abstract basic-block is simulated by another one for sequential semantics. This module refines <A HREF="html/compcert.kvx.abstractbb.SeqSimuTheory.html">SeqSimuTheory</A> with hash-consing and uses <A HREF=https://github.com/boulme/ImpureDemo>the Impure library</A> to reason on physical equality and handling of imperative code in Coq. +<LI> <A HREF="html/compcert.scheduling.abstractbb.AbstractBasicBlocksDef.html">AbstractBasicBlocksDef</A>: an IR for verifying some semantic properties on basic-blocks. +<LI> <A HREF="html/compcert.scheduling.abstractbb.Parallelizability.html">Parallelizability</A>: verifying that sequential and parallel semantics are equivalent for a given abstract basic-block. +<LI> <A HREF="html/compcert.scheduling.abstractbb.ImpSimuTest.html">ImpSimuTest</A>: verifying that a given abstract basic-block is simulated by another one for sequential semantics. This module refines <A HREF="html/compcert.scheduling.abstractbb.SeqSimuTheory.html">SeqSimuTheory</A> with hash-consing and uses <A HREF=https://github.com/boulme/ImpureDemo>the Impure library</A> to reason on physical equality and handling of imperative code in Coq. </UL> <font color=gray> @@ -85,6 +88,8 @@ See also: <A HREF="html/compcert.common.Memdata.html">Memdata</A> (in-memory rep <LI> <A HREF="html/compcert.common.Determinism.html">Determinism</A>: determinism properties of small-step semantics. <LI> <A HREF="html/compcert.kvx.Op.html"><I>Op</I></A>: operators, addressing modes and their semantics. +<LI> <A HREF="html/compcert.common.Builtins.html">Builtins</A>: semantics of built-in functions. <BR> +See also: <A HREF="html/compcert.common.Builtins0.html">Builtins0</A> (target-independent part), <A HREF="html/compcert.kvx.Builtins1.html"><I>Builtins1</I></A> (target-dependent part). <LI> <A HREF="html/compcert.common.Unityping.html">Unityping</A>: a solver for atomic unification constraints. </UL> @@ -123,7 +128,9 @@ view of the activation record. </font> <H4>Languages introduced for KVX core</H4> <UL> -<LI> <A HREF="html/compcert.kvx.lib.Machblock.html">Machblock</A>: a variant of Mach, with a syntax for basic-blocks, and a block-step semantics (execute one basic-block in one step). + <LI> <A HREF="html/compcert.scheduling.RTLpath.html">RTLpath</A>: extends RTL with annotations for delimitating superblocks (with possible liveness information). + This IR is generic over the processor, and used for prepass scheduling. +<LI> <A HREF="html/compcert.scheduling.postpass_lib.Machblock.html">Machblock</A>: a variant of Mach, with a syntax for basic-blocks, and a block-step semantics (execute one basic-block in one step). This IR is generic over the processor, even if currently, only used for KVX. <LI> <A HREF="html/compcert.kvx.Asmvliw.html"><I>Asmvliw</I></A>: abstract syntax and semantics for KVX VLIW assembly: atomic instructions are grouped by "bundles". These bundles are executed sequentially, but execution is parallel within bundles. <LI> <A HREF="html/compcert.kvx.Asmblock.html"><I>Asmblock</I></A>: a variant of Asmvliw, with a sequential semantics within bundles, which make them corresponds here to usual basic-blocks. @@ -131,14 +138,14 @@ This IR is generic over the processor, even if currently, only used for KVX. <LI> <A HREF="html/compcert.kvx.Asm.html"><I>Asm</I></A>: a variant of Asmvliw with a flat syntax for bundles, instead of a structured one (bundle termination is encoded as a pseudo-instruction). This IR is mainly a wrapper of <I>Asmvliw</I> for a smooth integration in CompCert (and an easier pretty-printing of the abstract syntax). </UL> -<font color=gray><H3>Compiler passes</H3></font> +<H3>Compiler passes</H3> <TABLE cellpadding="5%" style="color:#808080"> <TR valign="top"> - <TH>Pass</TH> - <TH>Source & target</TH> - <TH>Compiler code</TH> - <TH>Correctness proof</TH> + <TH align=left>Pass</TH> + <TH align=left>Source & target</TH> + <TH align=left>Compiler code</TH> + <TH align=left>Correctness proof</TH> </TR> <TR valign="top"> @@ -172,7 +179,8 @@ This IR is generic over the processor, even if currently, only used for KVX. </TR> <TR valign="top"> - <TD>Recognition of operators<br>and addressing modes</TD> + <TD>Recognition of operators<br>and addressing modes;<br> + if-conversion</TD> <TD>Cminor to CminorSel</TD> <TD><A HREF="html/compcert.backend.Selection.html">Selection</A><br> <A HREF="html/compcert.kvx.SelectOp.html"><I>SelectOp</I></A><br> @@ -215,16 +223,6 @@ This IR is generic over the processor, even if currently, only used for KVX. <TD><A HREF="html/compcert.backend.Renumber.html">Renumber</A></TD> <TD><A HREF="html/compcert.backend.Renumberproof.html">Renumberproof</A></TD> </TR> - -<TR valign="top"> - <TD>Constant propagation</TD> - <TD>RTL to RTL</TD> - <TD><A HREF="html/compcert.backend.Constprop.html">Constprop</A><br> - <A HREF="html/compcert.kvx.ConstpropOp.html"><I>ConstpropOp</I></A></TD> - <TD><A HREF="html/compcert.backend.Constpropproof.html">Constpropproof</A><br> - <A HREF="html/compcert.kvx.ConstpropOpproof.html"><I>ConstproppOproof</I></A></TD> -</TR> - <TR valign="top"> <TD>Common subexpression elimination</TD> <TD>RTL to RTL</TD> @@ -235,12 +233,19 @@ This IR is generic over the processor, even if currently, only used for KVX. </TR> <TR valign="top"> + <TD>Constant propagation</TD> + <TD>RTL to RTL</TD> + <TD><A HREF="html/compcert.backend.Constprop.html">Constprop</A><br> + <A HREF="html/compcert.kvx.ConstpropOp.html"><I>ConstpropOp</I></A></TD> + <TD><A HREF="html/compcert.backend.Constpropproof.html">Constpropproof</A><br> + <A HREF="html/compcert.kvx.ConstpropOpproof.html"><I>ConstproppOproof</I></A></TD> +</TR> +<TR valign="top"> <TD>Redundancy elimination</TD> <TD>RTL to RTL</TD> <TD><A HREF="html/compcert.backend.Deadcode.html">Deadcode</A></TD> <TD><A HREF="html/compcert.backend.Deadcodeproof.html">Deadcodeproof</A></TD> </TR> - <TR valign="top"> <TD>Removal of unused static globals</TD> <TD>RTL to RTL</TD> @@ -248,6 +253,60 @@ This IR is generic over the processor, even if currently, only used for KVX. <TD><A HREF="html/compcert.backend.Unusedglobproof.html">Unusedglobproof</A></TD> </TR> +<TR valign="top" style="color:#000000"> + <TD colspan="4"><b>Passes introduced for profiling (for later use in trace selection)</b></TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD>Insert profiling annotations (for recording experiments -- see PROFILE.md). + </TD> + <TD>RTL to RTL</TD> + <TD><A HREF="html/compcert.backend.Profiling.html">Profiling</A></TD> + <TD><A HREF="html/compcert.backend.Profilingproof.html">Profilingproof</A></TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD>Update ICond nodes (from recorded experiments -- see PROFILE.md). + </TD> + <TD>RTL to RTL</TD> + <TD><A HREF="html/compcert.backend.ProfilingExploit.html">ProfilingExploit</A></TD> + <TD><A HREF="html/compcert.backend.ProfilingExploitproof.html">ProfilingExploitproof</A></TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD colspan="4"><b>Passes introduced for superblock prepass scheduling</b></TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD>Code duplications (trace selection, loop unrollings, etc) + </TD> + <TD>RTL to RTL</TD> + <TD><A HREF="html/compcert.backend.Duplicate.html">Duplicate</A> (generic checker)</TD> + <TD><A HREF="html/compcert.scheduling.Duplicateproof.html">Duplicateproof</A> (generic proof)<BR> + <a href="html/compcert.backend.Duplicatepasses.html">Duplicatepasses</a> (several passes from several oracles)</TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD>Superblock selection (with Liveness information)</TD> + <TD>RTL to RTLPath</TD> + <TD><A HREF="html/compcert.scheduling.RTLpathLivegen.html">RTLpathLivegen</A></TD> + <TD><A HREF="html/compcert.scheduling.RTLpathLivegenproof.html">RTLpathLivegenproof</A></TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD>Superblock prepass scheduling</TD> + <TD>RTLPath to RTLPath</TD> + <TD><A HREF="html/compcert.scheduling.RTLpathScheduler.html">RTLpathScheduler</A></TD> + <TD><A HREF="html/compcert.scheduling.RTLpathSchedulerproof.html">RTLpathSchedulerproof</A><BR> + with <A HREF="html/compcert.scheduling.RTLpathSE_theory.html">RTLpathSE_theory</A> (the theory of symbolic execution on RTLpath)<BR> + and <A HREF="html/compcert.scheduling.RTLpathSE_simu_specs.html">RTLpathSE_simu_specs</A> (the low-level specifications of the simulation checker)<BR> + and <A HREF="html/compcert.scheduling.RTLpathSE_impl.html">RTLpathSE_impl</A> (the simulation checker with hash-consing)</TD> +</TR> +<TR valign="top" style="color:#000000"> + <TD>Forgeting superblocks</TD> + <TD>RTLPath to RTL</TD> + <TD><A HREF="html/compcert.scheduling.RTLpath.html#transf_program">RTLpath.transf_program</A></TD> + <TD><A HREF="html/compcert.scheduling.RTLpathproof.html">RTLpathproof</A></TD> +</TR> + +<TR valign="top"> + <TD colspan="4"><b>Passes from register allocation</b></TD> +</TR> + <TR valign="top"> <TD>Register allocation (validation a posteriori)</TD> <TD>RTL to LTL</TD> @@ -292,36 +351,37 @@ This IR is generic over the processor, even if currently, only used for KVX. <TD><A HREF="html/compcert.backend.Stackingproof.html">Stackingproof</A><br> <A HREF="html/compcert.common.Separation.html">Separation</A></TD> </TR> -</TABLE> -<H4>Compilation passes introduced for KVX VLIW</H4> -<TABLE cellpadding="5%"> -<TR valign="top"> +<TR valign="top" style="color:#000000"> + <TD colspan="4"><b>Passes introduced for KVX VLIW</b></TD> +</TR> +<TR valign="top" style="color:#000000"> <TD>Reconstruction of basic-blocks at Mach level</TD> <TD>Mach to Machblock</TD> - <TD><A HREF="html/compcert.kvx.lib.Machblockgen.html">Machblockgen</A></TD> - <TD><A HREF="html/compcert.kvx.lib.ForwardSimulationBlock.html">ForwardSimulationBlock</A><BR> - <A HREF="html/compcert.kvx.lib.Machblockgenproof.html">Machblockgenproof</A></TD> + <TD><A HREF="html/compcert.scheduling.postpass_lib.Machblockgen.html">Machblockgen</A></TD> + <TD><A HREF="html/compcert.scheduling.postpass_lib.ForwardSimulationBlock.html">ForwardSimulationBlock</A><BR> + <A HREF="html/compcert.scheduling.postpass_lib.Machblockgenproof.html">Machblockgenproof</A></TD> </TR> -<TR valign="top"> +<TR valign="top" style="color:#000000"> <TD>Emission of purely sequential assembly code</TD> <TD>Machblock to Asmblock</TD> <TD><A HREF="html/compcert.kvx.Asmblockgen.html"><I>Asmblockgen</I></A></TD> - <TD><A HREF="html/compcert.kvx.lib.Asmblockgenproof0.html"><I>Asmblockgenproof0</I></A><BR> + <TD><A HREF="html/compcert.kvx.Asmblockgenproof0.html"><I>Asmblockgenproof0</I></A><BR> <A HREF="html/compcert.kvx.Asmblockgenproof1.html"><I>Asmblockgenproof1</I></A><BR> <A HREF="html/compcert.kvx.Asmblockgenproof.html"><I>Asmblockgenproof</I></A></TD> </TR> -<TR valign="top"> +<TR valign="top" style="color:#000000"> <TD>Bundling (and basic-block scheduling)</TD> <TD>Asmblock to Asmvliw</TD> - <TD><A HREF="html/compcert.kvx.PostpassScheduling.html"><I>PostpassScheduling</I></A> using<BR> - <A HREF="html/compcert.kvx.Asmblockdeps.html"><I>Asmblockdeps</I></A> and the <tt>abstractbb</tt> library</TD> + <TD><A HREF="html/compcert.kvx.PostpassScheduling.html"><I>PostpassScheduling</I></A><BR> + using <A HREF="html/compcert.kvx.Asmblockdeps.html"><I>Asmblockdeps</I></A><BR> + and the <tt>abstractbb</tt> library</TD> <TD><A HREF="html/compcert.kvx.PostpassSchedulingproof.html"><I>PostpassSchedulingproof</I></A></TD> </TR> -<TR valign="top"> +<TR valign="top" style="color:#000000"> <TD>Flattening bundles (only a bureaucratic operation)</TD> <TD>Asmvliw to Asm</TD> <TD><A HREF="html/compcert.kvx.Asmgen.html"><I>Asmgen</I></A></TD> @@ -329,12 +389,13 @@ This IR is generic over the processor, even if currently, only used for KVX. </TR> </TABLE> -<font color=gray> -<H3>All together</H3> +<H3>All together (there are many more RTL passes than on vanilla CompCert: their order is specified in Compiler)</H3> <UL> +</font> <LI> <A HREF="html/compcert.driver.Compiler.html">Compiler</A>: composing the passes together; whole-compiler semantic preservation theorems. +<font color=gray> <LI> <A HREF="html/compcert.driver.Complements.html">Complements</A>: interesting consequences of the semantic preservation theorems. </UL> diff --git a/doc/index.html b/doc/index.html index 631c5d99..ec8c4d91 100644 --- a/doc/index.html +++ b/doc/index.html @@ -24,7 +24,7 @@ a:active {color : Red; text-decoration : underline; } <H1 align="center">The CompCert verified compiler</H1> <H2 align="center">Commented Coq development</H2> -<H3 align="center">Version 3.7, 2020-03-31</H3> +<H3 align="center">Version 3.8, 2020-11-16</H3> <H2>Introduction</H2> @@ -56,12 +56,14 @@ substantially changed since the overview papers above were written.</P> <P>The complete sources for CompCert can be downloaded from -<A HREF="http://compcert.inria.fr/">the CompCert Web site</A>.</P> +<A HREF="https://github.com/AbsInt/CompCert/">the Git repository</A> +or <A HREF="https://compcert.org/">the CompCert Web site</A>. +</P> <P>This document and the CompCert sources are copyright Institut National de Recherche en Informatique et en Automatique (INRIA) and AbsInt Angewandte Informatik GmbH, and are distributed under the terms of the -following <A HREF="LICENSE">license</A>. +following <A HREF="LICENSE.txt">license</A>. </P> <H2>Table of contents</H2> @@ -348,7 +350,7 @@ reconstruction. </UL> <HR> -<ADDRESS>Xavier.Leroy@inria.fr</ADDRESS> +<ADDRESS>xavier.leroy@college-de-france.fr</ADDRESS> <HR> </BODY> diff --git a/driver/Clflags.ml b/driver/Clflags.ml index c3f30b88..95dc4b20 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -46,8 +46,15 @@ let option_funrollsingle = ref 0 (* unroll a single iteration of innermost loops let option_funrollbody = ref 0 (* unroll the body of innermost loops of size n *) let option_flooprotate = ref 0 (* rotate the innermost loops to have the condition inside the loop body *) +(* Scheduling *) +let option_mtune = ref "" + +let option_fprepass = ref true +let option_fprepass_sched = ref "list" + let option_fpostpass = ref true let option_fpostpass_sched = ref "list" + let option_fifconversion = ref true let option_Obranchless = ref false let option_falignfunctions = ref (None: int option) @@ -116,3 +123,4 @@ let option_inline_auto_threshold = ref 0 let option_profile_arcs = ref false let option_fbranch_probabilities = ref true let option_debug_compcert = ref 0 +let main_function_name = ref "main" diff --git a/driver/CommonOptions.ml b/driver/CommonOptions.ml index c151ecf2..e8a6941c 100644 --- a/driver/CommonOptions.ml +++ b/driver/CommonOptions.ml @@ -15,8 +15,9 @@ open Commandline (* The version string for [tool_name] *) let version_string tool_name = - if Version.buildnr <> "" && Version.tag <> "" then - Printf.sprintf "The CompCert %s, Release: %s, Build: %s, Tag: %s\n" tool_name Version.version Version.buildnr Version.tag + if Version.buildnr <> "" && Version.tag <> "" && Version.branch <> "" then + Printf.sprintf "The CompCert %s, Release: %s, Build: %s, Tag: %s, Branch: %s\n" + tool_name Version.version Version.buildnr Version.tag Version.branch else Printf.sprintf "The CompCert %s, version %s\n" tool_name Version.version @@ -26,7 +27,7 @@ let print_version_and_exit tool_name () = let version_options tool_name = [ Exact "-version", Unit (print_version_and_exit tool_name); - Exact "--version", Unit (print_version_and_exit tool_name);] + Exact "--version", Unit (print_version_and_exit tool_name) ] (* Language support options *) @@ -76,6 +77,7 @@ let general_help = -v Print external commands before invoking them -timings Show the time spent in various compiler passes -version Print the version string and exit + -version-file <file> Print version inforation to <file> and exit -target <value> Generate code for the given target -conf <file> Read configuration from file @<file> Read command line options from <file> @@ -86,4 +88,4 @@ let general_options = Exact "-target", Ignore;(* Ignore option since it is already handled *) Exact "-v", Set option_v; Exact "-stdlib", String(fun s -> stdlib_path := s); - Exact "-timings", Set option_timings;] + Exact "-timings", Set option_timings ] diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand index 48567327..3fb9ceac 100644 --- a/driver/Compiler.vexpand +++ b/driver/Compiler.vexpand @@ -489,6 +489,14 @@ EXPAND_ASM_SEMANTICS eapply RTLgenproof.transf_program_correct; eassumption. EXPAND_RTL_FORWARD_SIMULATIONS eapply compose_forward_simulations. + eapply RTLpathLivegenproof.transf_program_correct; eassumption. + pose proof RTLpathLivegenproof.all_fundef_liveness_ok as X. + refine (modusponens _ _ (X _ _ _) _); eauto. intro. + eapply compose_forward_simulations. + eapply RTLpathSchedulerproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply RTLpathproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. eapply Allocationproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Tunnelingproof.transf_program_correct; eassumption. @@ -588,6 +596,14 @@ EXPAND_RTL_FORWARD_SIMULATIONS eapply Renumberproof.transf_program_correct; eassumption. EXPAND_POST_SSA_FORWARD_SIMULATIONS + eapply compose_forward_simulations. + eapply RTLpathLivegenproof.transf_program_correct; eassumption. + pose proof RTLpathLivegenproof.all_fundef_liveness_ok as X. + refine (modusponens _ _ (X _ _ _) _); eauto. intro. + eapply compose_forward_simulations. + eapply RTLpathSchedulerproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply RTLpathproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Allocationproof.transf_program_correct; eassumption. diff --git a/driver/Driver.ml b/driver/Driver.ml index cd33e4db..d75449d1 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -223,7 +223,11 @@ Processing options: -fcse3-refine Refine CSE3 invariants by descending iteration [on] -fmove-loop-invariants Perform loop-invariant code motion [off] -fredundancy Perform redundancy elimination [on] - -fpostpass Perform postpass scheduling (only for K1 architecture) [on] + -mtune= Type of CPU (for scheduling on some architectures) + -fprepass Perform prepass scheduling (only on some architectures) [off] + -fprepass= <optim> Perform postpass scheduling with the specified optimization [list] + (<optim>=list: list scheduling, <optim>=ilp: ILP, <optim>=greedy: just packing bundles) + -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= <optim> Perform postpass scheduling with the specified optimization [list] (<optim>=list: list scheduling, <optim>=ilp: ILP, <optim>=greedy: just packing bundles) -fpredict Insert static branch prediction information [on] @@ -291,18 +295,13 @@ General options: |} ^ {|SSA mode: -ssa <mode> Set the ssa mode to [on,off] + -main <name> Start executing at function <name> instead of main() |} let print_usage_and_exit () = printf "%s" usage_string; exit 0 -let enforce_buildnr nr = - let build = int_of_string Version.buildnr in - if nr != build then - fatal_error no_loc "Mismatching builds: This is CompCert build %d, but QSK requires build %d.\n\ -Please use matching builds of QSK and CompCert." build nr - let dump_mnemonics destfile = let oc = open_out_bin destfile in let pp = Format.formatter_of_out_channel oc in @@ -349,10 +348,7 @@ let cmdline_actions = @ version_options tool_name @ (* Enforcing CompCert build numbers for QSKs and mnemonics dump *) (if Version.buildnr <> "" then - [ Exact "-qsk-enforce-build", Integer enforce_buildnr; - Exact "--qsk-enforce-build", Integer enforce_buildnr; - Exact "-dump-mnemonics", String dump_mnemonics; - ] + [Exact "-dump-mnemonics", String dump_mnemonics;] else []) @ (* Processing options *) [ Exact "-c", Set option_c; @@ -445,7 +441,8 @@ let cmdline_actions = Exact "-quiet", Unit (fun () -> Interp.trace := 0); Exact "-trace", Unit (fun () -> Interp.trace := 2); Exact "-random", Unit (fun () -> Interp.mode := Interp.Random); - Exact "-all", Unit (fun () -> Interp.mode := Interp.All) + Exact "-all", Unit (fun () -> Interp.mode := Interp.All); + Exact "-main", String (fun s -> main_function_name := s) ] (* Optimization options *) (* -f options: come in -f and -fno- variants *) @@ -466,6 +463,8 @@ let cmdline_actions = @ f_opt "move-loop-invariants_2" option_fmove_loop_invariants_2 @ f_opt "move-loop-invariants_s" option_fmove_loop_invariants_s @ f_opt "redundancy" option_fredundancy + @ [ Exact "-mtune", String (fun s -> option_mtune := s) ] + @ f_opt "prepass" option_fprepass @ f_opt "postpass" option_fpostpass @ [ Exact "-ftailduplicate", Integer (fun n -> option_ftailduplicate := n) ] @ f_opt "predict" option_fpredict @@ -473,6 +472,7 @@ let cmdline_actions = @ [ Exact "-funrollbody", Integer (fun n -> option_funrollbody := n) ] @ [ Exact "-flooprotate", Integer (fun n -> option_flooprotate := n) ] @ f_opt "tracelinearize" option_ftracelinearize + @ f_opt_str "prepass" option_fprepass option_fprepass_sched @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched @ f_opt "inline" option_finline @ f_opt "inline-functions-called-once" option_finline_functions_called_once @@ -533,6 +533,8 @@ let _ = fatal_error no_loc "ambiguous '-o' option (multiple source files)"; if !num_input_files = 0 then fatal_error no_loc "no input file"; + if not !option_interp && !main_function_name <> "main" then + fatal_error no_loc "option '-main' requires option '-interp'"; let linker_args = time "Total compilation time" perform_actions () in if not (nolink ()) && linker_args <> [] then begin linker (output_filename_default "a.out") linker_args diff --git a/driver/Frontend.ml b/driver/Frontend.ml index 5db0040f..c99da945 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -75,6 +75,7 @@ let preprocess ifile ofile = let parse_c_file sourcename ifile = Debug.init_compile_unit sourcename; Sections.initialize(); + CPragmas.reset(); (* Simplification options *) let simplifs = "b" (* blocks: mandatory *) diff --git a/driver/Interp.ml b/driver/Interp.ml index d4286779..6c83e819 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -587,41 +587,60 @@ let world_program prog = (* Massaging the program to get a suitable "main" function *) -let change_main_function p old_main old_main_ty = - let old_main = Evalof(Evar(old_main, old_main_ty), old_main_ty) in +let change_main_function p new_main_fn = + let new_main_id = intern_string "%main%" in + { p with + Ctypes.prog_main = new_main_id; + Ctypes.prog_defs = + (new_main_id, Gfun(Internal new_main_fn)) :: p.Ctypes.prog_defs } + +let call_main3_function main_id main_ty = + let main_var = Evalof(Evar(main_id, main_ty), main_ty) in let arg1 = Eval(Vint(coqint_of_camlint 0l), type_int32s) in let arg2 = arg1 in let body = - Sreturn(Some(Ecall(old_main, Econs(arg1, Econs(arg2, Enil)), type_int32s))) in - let new_main_fn = - { fn_return = type_int32s; fn_callconv = cc_default; - fn_params = []; fn_vars = []; fn_body = body } in - let new_main_id = intern_string "___main" in - { prog_main = new_main_id; - Ctypes.prog_defs = (new_main_id, Gfun(Ctypes.Internal new_main_fn)) :: p.Ctypes.prog_defs; - Ctypes.prog_public = p.Ctypes.prog_public; - prog_types = p.prog_types; - prog_comp_env = p.prog_comp_env } + Sreturn(Some(Ecall(main_var, Econs(arg1, Econs(arg2, Enil)), type_int32s))) + in + { fn_return = type_int32s; fn_callconv = cc_default; + fn_params = []; fn_vars = []; fn_body = body } + +let call_other_main_function main_id main_ty main_ty_res = + let main_var = Evalof(Evar(main_id, main_ty), main_ty) in + let body = + Ssequence(Sdo(Ecall(main_var, Enil, main_ty_res)), + Sreturn(Some(Eval(Vint(coqint_of_camlint 0l), type_int32s)))) in + { fn_return = type_int32s; fn_callconv = cc_default; + fn_params = []; fn_vars = []; fn_body = body } let rec find_main_function name = function | [] -> None - | (id, Gfun fd) :: gdl -> if id = name then Some fd else find_main_function name gdl - | (id, Gvar v) :: gdl -> find_main_function name gdl + | (id, Gfun fd) :: gdl -> + if id = name then Some fd else find_main_function name gdl + | (id, Gvar v) :: gdl -> + find_main_function name gdl let fixup_main p = match find_main_function p.Ctypes.prog_main p.Ctypes.prog_defs with | None -> - fprintf err_formatter "ERROR: no main() function@."; + fprintf err_formatter "ERROR: no entry function %s()@." + (extern_atom p.Ctypes.prog_main); None | Some main_fd -> match type_of_fundef main_fd with | Tfunction(Tnil, Ctypes.Tint(I32, Signed, _), _) -> Some p - | Tfunction(Tcons(Ctypes.Tint _, Tcons(Tpointer(Tpointer(Ctypes.Tint(I8,_,_),_),_), Tnil)), + | Tfunction(Tcons(Ctypes.Tint _, + Tcons(Tpointer(Tpointer(Ctypes.Tint(I8,_,_),_),_), Tnil)), Ctypes.Tint _, _) as ty -> - Some (change_main_function p p.Ctypes.prog_main ty) + Some (change_main_function p + (call_main3_function p.Ctypes.prog_main ty)) + | Tfunction(Tnil, ty_res, _) as ty -> + Some (change_main_function p + (call_other_main_function p.Ctypes.prog_main ty ty_res)) | _ -> - fprintf err_formatter "ERROR: wrong type for main() function@."; + fprintf err_formatter + "ERROR: wrong type for entry function %s()@." + (extern_atom p.Ctypes.prog_main); None (* Execution of a whole program *) diff --git a/exportclight/Clightdefs.v b/exportclight/Clightdefs.v index 83d82d88..8af920df 100644 --- a/exportclight/Clightdefs.v +++ b/exportclight/Clightdefs.v @@ -15,7 +15,7 @@ (** All imports and definitions used by .v Clight files generated by clightgen *) -From Coq Require Import String List ZArith. +From Coq Require Import Ascii String List ZArith. From compcert Require Import Integers Floats Maps Errors AST Ctypes Cop Clight. Definition tvoid := Tvoid. @@ -80,3 +80,212 @@ Definition mkprogram (types: list composite_definition) prog_types := types; prog_comp_env := ce; prog_comp_env_eq := EQ |}. + +(** The following encoding of character strings as positive numbers + must be kept consistent with the OCaml function [Camlcoq.pos_of_string]. *) + +Definition append_bit_pos (b: bool) (p: positive) : positive := + if b then xI p else xO p. + +Definition append_char_pos_default (c: ascii) (p: positive) : positive := + let '(Ascii b7 b6 b5 b4 b3 b2 b1 b0) := c in + xI (xI (xI (xI (xI (xI + (append_bit_pos b0 (append_bit_pos b1 + (append_bit_pos b2 (append_bit_pos b3 + (append_bit_pos b4 (append_bit_pos b5 + (append_bit_pos b6 (append_bit_pos b7 p))))))))))))). + +Definition append_char_pos (c: ascii) (p: positive) : positive := + match c with + | "0"%char => xO (xO (xO (xO (xO (xO p))))) + | "1"%char => xI (xO (xO (xO (xO (xO p))))) + | "2"%char => xO (xI (xO (xO (xO (xO p))))) + | "3"%char => xI (xI (xO (xO (xO (xO p))))) + | "4"%char => xO (xO (xI (xO (xO (xO p))))) + | "5"%char => xI (xO (xI (xO (xO (xO p))))) + | "6"%char => xO (xI (xI (xO (xO (xO p))))) + | "7"%char => xI (xI (xI (xO (xO (xO p))))) + | "8"%char => xO (xO (xO (xI (xO (xO p))))) + | "9"%char => xI (xO (xO (xI (xO (xO p))))) + | "a"%char => xO (xI (xO (xI (xO (xO p))))) + | "b"%char => xI (xI (xO (xI (xO (xO p))))) + | "c"%char => xO (xO (xI (xI (xO (xO p))))) + | "d"%char => xI (xO (xI (xI (xO (xO p))))) + | "e"%char => xO (xI (xI (xI (xO (xO p))))) + | "f"%char => xI (xI (xI (xI (xO (xO p))))) + | "g"%char => xO (xO (xO (xO (xI (xO p))))) + | "h"%char => xI (xO (xO (xO (xI (xO p))))) + | "i"%char => xO (xI (xO (xO (xI (xO p))))) + | "j"%char => xI (xI (xO (xO (xI (xO p))))) + | "k"%char => xO (xO (xI (xO (xI (xO p))))) + | "l"%char => xI (xO (xI (xO (xI (xO p))))) + | "m"%char => xO (xI (xI (xO (xI (xO p))))) + | "n"%char => xI (xI (xI (xO (xI (xO p))))) + | "o"%char => xO (xO (xO (xI (xI (xO p))))) + | "p"%char => xI (xO (xO (xI (xI (xO p))))) + | "q"%char => xO (xI (xO (xI (xI (xO p))))) + | "r"%char => xI (xI (xO (xI (xI (xO p))))) + | "s"%char => xO (xO (xI (xI (xI (xO p))))) + | "t"%char => xI (xO (xI (xI (xI (xO p))))) + | "u"%char => xO (xI (xI (xI (xI (xO p))))) + | "v"%char => xI (xI (xI (xI (xI (xO p))))) + | "w"%char => xO (xO (xO (xO (xO (xI p))))) + | "x"%char => xI (xO (xO (xO (xO (xI p))))) + | "y"%char => xO (xI (xO (xO (xO (xI p))))) + | "z"%char => xI (xI (xO (xO (xO (xI p))))) + | "A"%char => xO (xO (xI (xO (xO (xI p))))) + | "B"%char => xI (xO (xI (xO (xO (xI p))))) + | "C"%char => xO (xI (xI (xO (xO (xI p))))) + | "D"%char => xI (xI (xI (xO (xO (xI p))))) + | "E"%char => xO (xO (xO (xI (xO (xI p))))) + | "F"%char => xI (xO (xO (xI (xO (xI p))))) + | "G"%char => xO (xI (xO (xI (xO (xI p))))) + | "H"%char => xI (xI (xO (xI (xO (xI p))))) + | "I"%char => xO (xO (xI (xI (xO (xI p))))) + | "J"%char => xI (xO (xI (xI (xO (xI p))))) + | "K"%char => xO (xI (xI (xI (xO (xI p))))) + | "L"%char => xI (xI (xI (xI (xO (xI p))))) + | "M"%char => xO (xO (xO (xO (xI (xI p))))) + | "N"%char => xI (xO (xO (xO (xI (xI p))))) + | "O"%char => xO (xI (xO (xO (xI (xI p))))) + | "P"%char => xI (xI (xO (xO (xI (xI p))))) + | "Q"%char => xO (xO (xI (xO (xI (xI p))))) + | "R"%char => xI (xO (xI (xO (xI (xI p))))) + | "S"%char => xO (xI (xI (xO (xI (xI p))))) + | "T"%char => xI (xI (xI (xO (xI (xI p))))) + | "U"%char => xO (xO (xO (xI (xI (xI p))))) + | "V"%char => xI (xO (xO (xI (xI (xI p))))) + | "W"%char => xO (xI (xO (xI (xI (xI p))))) + | "X"%char => xI (xI (xO (xI (xI (xI p))))) + | "Y"%char => xO (xO (xI (xI (xI (xI p))))) + | "Z"%char => xI (xO (xI (xI (xI (xI p))))) + | "_"%char => xO (xI (xI (xI (xI (xI p))))) + | _ => append_char_pos_default c p + end. + +Fixpoint ident_of_string (s: string) : ident := + match s with + | EmptyString => xH + | String c s => append_char_pos c (ident_of_string s) + end. + +(** A convenient notation [$ "ident"] to force evaluation of + [ident_of_string "ident"] *) + +Ltac ident_of_string s := + let x := constr:(ident_of_string s) in + let y := eval compute in x in + exact y. + +Notation "$ s" := (ltac:(ident_of_string s)) + (at level 1, only parsing) : string_scope. + +(** The inverse conversion, from encoded strings to strings *) + +Section DECODE_BITS. + +Variable rec: positive -> string. + +Fixpoint decode_n_bits (n: nat) (l: list bool) (p: positive) : string := + match n with + | O => + match l with + | b7 :: b6 :: b5 :: b4 :: b3 :: b2 :: b1 :: b0 :: _ => + String (Ascii b7 b6 b5 b4 b3 b2 b1 b0) (rec p) + | _ => EmptyString + end + | S n => + match p with + | xO q => decode_n_bits n (false :: l) q + | xI q => decode_n_bits n (true :: l) q + | xH => EmptyString + end + end. + +Definition decode_8_bits := Eval compute in (decode_n_bits 8%nat nil). + +End DECODE_BITS. + +Fixpoint string_of_ident (p: positive) : string := + match p with + | xO (xO (xO (xO (xO (xO p))))) => String "0"%char (string_of_ident p) + | xI (xO (xO (xO (xO (xO p))))) => String "1"%char (string_of_ident p) + | xO (xI (xO (xO (xO (xO p))))) => String "2"%char (string_of_ident p) + | xI (xI (xO (xO (xO (xO p))))) => String "3"%char (string_of_ident p) + | xO (xO (xI (xO (xO (xO p))))) => String "4"%char (string_of_ident p) + | xI (xO (xI (xO (xO (xO p))))) => String "5"%char (string_of_ident p) + | xO (xI (xI (xO (xO (xO p))))) => String "6"%char (string_of_ident p) + | xI (xI (xI (xO (xO (xO p))))) => String "7"%char (string_of_ident p) + | xO (xO (xO (xI (xO (xO p))))) => String "8"%char (string_of_ident p) + | xI (xO (xO (xI (xO (xO p))))) => String "9"%char (string_of_ident p) + | xO (xI (xO (xI (xO (xO p))))) => String "a"%char (string_of_ident p) + | xI (xI (xO (xI (xO (xO p))))) => String "b"%char (string_of_ident p) + | xO (xO (xI (xI (xO (xO p))))) => String "c"%char (string_of_ident p) + | xI (xO (xI (xI (xO (xO p))))) => String "d"%char (string_of_ident p) + | xO (xI (xI (xI (xO (xO p))))) => String "e"%char (string_of_ident p) + | xI (xI (xI (xI (xO (xO p))))) => String "f"%char (string_of_ident p) + | xO (xO (xO (xO (xI (xO p))))) => String "g"%char (string_of_ident p) + | xI (xO (xO (xO (xI (xO p))))) => String "h"%char (string_of_ident p) + | xO (xI (xO (xO (xI (xO p))))) => String "i"%char (string_of_ident p) + | xI (xI (xO (xO (xI (xO p))))) => String "j"%char (string_of_ident p) + | xO (xO (xI (xO (xI (xO p))))) => String "k"%char (string_of_ident p) + | xI (xO (xI (xO (xI (xO p))))) => String "l"%char (string_of_ident p) + | xO (xI (xI (xO (xI (xO p))))) => String "m"%char (string_of_ident p) + | xI (xI (xI (xO (xI (xO p))))) => String "n"%char (string_of_ident p) + | xO (xO (xO (xI (xI (xO p))))) => String "o"%char (string_of_ident p) + | xI (xO (xO (xI (xI (xO p))))) => String "p"%char (string_of_ident p) + | xO (xI (xO (xI (xI (xO p))))) => String "q"%char (string_of_ident p) + | xI (xI (xO (xI (xI (xO p))))) => String "r"%char (string_of_ident p) + | xO (xO (xI (xI (xI (xO p))))) => String "s"%char (string_of_ident p) + | xI (xO (xI (xI (xI (xO p))))) => String "t"%char (string_of_ident p) + | xO (xI (xI (xI (xI (xO p))))) => String "u"%char (string_of_ident p) + | xI (xI (xI (xI (xI (xO p))))) => String "v"%char (string_of_ident p) + | xO (xO (xO (xO (xO (xI p))))) => String "w"%char (string_of_ident p) + | xI (xO (xO (xO (xO (xI p))))) => String "x"%char (string_of_ident p) + | xO (xI (xO (xO (xO (xI p))))) => String "y"%char (string_of_ident p) + | xI (xI (xO (xO (xO (xI p))))) => String "z"%char (string_of_ident p) + | xO (xO (xI (xO (xO (xI p))))) => String "A"%char (string_of_ident p) + | xI (xO (xI (xO (xO (xI p))))) => String "B"%char (string_of_ident p) + | xO (xI (xI (xO (xO (xI p))))) => String "C"%char (string_of_ident p) + | xI (xI (xI (xO (xO (xI p))))) => String "D"%char (string_of_ident p) + | xO (xO (xO (xI (xO (xI p))))) => String "E"%char (string_of_ident p) + | xI (xO (xO (xI (xO (xI p))))) => String "F"%char (string_of_ident p) + | xO (xI (xO (xI (xO (xI p))))) => String "G"%char (string_of_ident p) + | xI (xI (xO (xI (xO (xI p))))) => String "H"%char (string_of_ident p) + | xO (xO (xI (xI (xO (xI p))))) => String "I"%char (string_of_ident p) + | xI (xO (xI (xI (xO (xI p))))) => String "J"%char (string_of_ident p) + | xO (xI (xI (xI (xO (xI p))))) => String "K"%char (string_of_ident p) + | xI (xI (xI (xI (xO (xI p))))) => String "L"%char (string_of_ident p) + | xO (xO (xO (xO (xI (xI p))))) => String "M"%char (string_of_ident p) + | xI (xO (xO (xO (xI (xI p))))) => String "N"%char (string_of_ident p) + | xO (xI (xO (xO (xI (xI p))))) => String "O"%char (string_of_ident p) + | xI (xI (xO (xO (xI (xI p))))) => String "P"%char (string_of_ident p) + | xO (xO (xI (xO (xI (xI p))))) => String "Q"%char (string_of_ident p) + | xI (xO (xI (xO (xI (xI p))))) => String "R"%char (string_of_ident p) + | xO (xI (xI (xO (xI (xI p))))) => String "S"%char (string_of_ident p) + | xI (xI (xI (xO (xI (xI p))))) => String "T"%char (string_of_ident p) + | xO (xO (xO (xI (xI (xI p))))) => String "U"%char (string_of_ident p) + | xI (xO (xO (xI (xI (xI p))))) => String "V"%char (string_of_ident p) + | xO (xI (xO (xI (xI (xI p))))) => String "W"%char (string_of_ident p) + | xI (xI (xO (xI (xI (xI p))))) => String "X"%char (string_of_ident p) + | xO (xO (xI (xI (xI (xI p))))) => String "Y"%char (string_of_ident p) + | xI (xO (xI (xI (xI (xI p))))) => String "Z"%char (string_of_ident p) + | xO (xI (xI (xI (xI (xI p))))) => String "_"%char (string_of_ident p) + | xI (xI (xI (xI (xI (xI p))))) => decode_8_bits string_of_ident p + | _ => EmptyString + end. + +Lemma string_of_ident_of_string: + forall s, string_of_ident (ident_of_string s) = s. +Proof. + induction s as [ | c s]; simpl. +- auto. +- rewrite <- IHs at 2. destruct c as [[] [] [] [] [] [] [] []]; reflexivity. +Qed. + +Corollary ident_of_string_injective: + forall s1 s2, ident_of_string s1 = ident_of_string s2 -> s1 = s2. +Proof. + intros. rewrite <- (string_of_ident_of_string s1), <- (string_of_ident_of_string s2). + congruence. +Qed. diff --git a/exportclight/Clightgen.ml b/exportclight/Clightgen.ml index f7279a5e..5e27370e 100644 --- a/exportclight/Clightgen.ml +++ b/exportclight/Clightgen.ml @@ -91,13 +91,15 @@ let process_i_file sourcename = compile_c_file sourcename sourcename ofile let usage_string = - version_string tool_name^ + version_string tool_name ^ {|Usage: clightgen [options] <source files> Recognized source files: .c C source file .i or .p C source file that should not be preprocessed Processing options: -normalize Normalize the generated Clight code w.r.t. loads in expressions + -canonical-idents Use canonical numbers to represent identifiers (default) + -short-idents Use small, non-canonical numbers to represent identifiers -E Preprocess only, send result to standard output -o <file> Generate output in <file> |} ^ @@ -142,6 +144,8 @@ let cmdline_actions = (* Processing options *) [ Exact "-E", Set option_E; Exact "-normalize", Set option_normalize; + Exact "-canonical-idents", Set Camlcoq.use_canonical_atoms; + Exact "-short-idents", Unset Camlcoq.use_canonical_atoms; Exact "-o", String(fun s -> option_o := Some s); Prefix "-o", Self (fun s -> let s = String.sub s 2 ((String.length s) - 2) in option_o := Some s);] @@ -175,12 +179,13 @@ let cmdline_actions = ] let _ = - try +try Gc.set { (Gc.get()) with Gc.minor_heap_size = 524288; (* 512k *) Gc.major_heap_increment = 4194304 (* 4M *) }; Printexc.record_backtrace true; + Camlcoq.use_canonical_atoms := true; Frontend.init (); parse_cmdline cmdline_actions; if !option_o <> None && !num_input_files >= 2 then @@ -188,7 +193,7 @@ let _ = if !num_input_files = 0 then fatal_error no_loc "no input file"; perform_actions () - with +with | Sys_error msg | CmdError msg -> error no_loc "%s" msg; exit 2 | Abort -> exit 2 diff --git a/exportclight/Clightnorm.ml b/exportclight/Clightnorm.ml index a0001250..a6158b60 100644 --- a/exportclight/Clightnorm.ml +++ b/exportclight/Clightnorm.ml @@ -143,7 +143,18 @@ and norm_lbl_stmt ls = | LSnil -> LSnil | LScons(n, s, ls) -> LScons(n, norm_stmt s, norm_lbl_stmt ls) -let next_var curr (v, _) = if P.lt v curr then curr else P.succ v +(* In "canonical atoms" mode, temporaries are between 2^7 and 2^12 - 1. + Below 2^7 are single-letter identifiers and above 2^12 are all + other identifiers. *) + +let first_temp = P.of_int 128 +let last_temp = P.of_int 4095 + +let next_var curr (v, _) = + if P.lt v curr + || !use_canonical_atoms && (P.lt v first_temp || P.gt v last_temp) + then curr + else P.succ v let next_var_list vars start = List.fold_left next_var start vars diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index c9d6fced..4ff901eb 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -43,6 +43,48 @@ let print_list fn p l = in plist l; fprintf p ")@]" +(* Numbers *) + +let coqint p n = + let n = camlint_of_coqint n in + if n >= 0l + then fprintf p "(Int.repr %ld)" n + else fprintf p "(Int.repr (%ld))" n + +let coqptrofs p n = + let s = Z.to_string n in + if Z.ge n Z.zero + then fprintf p "(Ptrofs.repr %s)" s + else fprintf p "(Ptrofs.repr (%s))" s + +let coqint64 p n = + let n = camlint64_of_coqint n in + if n >= 0L + then fprintf p "(Int64.repr %Ld)" n + else fprintf p "(Int64.repr (%Ld))" n + +let coqfloat p n = + fprintf p "(Float.of_bits %a)" coqint64 (Floats.Float.to_bits n) + +let coqsingle p n = + fprintf p "(Float32.of_bits %a)" coqint (Floats.Float32.to_bits n) + +let positive p n = + fprintf p "%s%%positive" (Z.to_string (Z.Zpos n)) + +let coqN p n = + fprintf p "%s%%N" (Z.to_string (Z.of_N n)) + +let coqZ p n = + if Z.ge n Z.zero + then fprintf p "%s" (Z.to_string n) + else fprintf p "(%s)" (Z.to_string n) + +(* Coq strings *) + +let coqstring p s = + fprintf p "\"%s\"" (camlstring_of_coqstring s) + (* Identifiers *) exception Not_an_identifier @@ -69,7 +111,7 @@ let ident p id = let s = Hashtbl.find temp_names id in fprintf p "%s" s with Not_found -> - fprintf p "%ld%%positive" (P.to_int32 id) + positive p id let iter_hashtbl_sorted (h: ('a, string) Hashtbl.t) (f: 'a * string -> unit) = List.iter f @@ -81,65 +123,33 @@ let define_idents p = string_of_atom (fun (id, name) -> try - fprintf p "Definition _%s : ident := %ld%%positive.@ " - (sanitize name) (P.to_int32 id) + if !use_canonical_atoms && id = pos_of_string name then + fprintf p "Definition _%s : ident := $\"%s\".@ " + (sanitize name) name + else + fprintf p "Definition _%s : ident := %a.@ " + (sanitize name) positive id with Not_an_identifier -> ()); iter_hashtbl_sorted temp_names (fun (id, name) -> - fprintf p "Definition %s : ident := %ld%%positive.@ " - name (P.to_int32 id)); + fprintf p "Definition %s : ident := %a.@ " + name positive id); fprintf p "@ " let name_temporary t = - let t1 = P.to_int t and t0 = P.to_int (first_unused_ident ()) in - if t1 >= t0 && not (Hashtbl.mem temp_names t) - then Hashtbl.add temp_names t (sprintf "_t'%d" (t1 - t0 + 1)) + if not (Hashtbl.mem string_of_atom t) && not (Hashtbl.mem temp_names t) + then begin + let t0 = first_unused_ident () in + let d = Z.succ (Z.sub (Z.Zpos t) (Z.Zpos t0)) in + Hashtbl.add temp_names t ("_t'" ^ Z.to_string d) + end let name_opt_temporary = function | None -> () | Some id -> name_temporary id -(* Numbers *) - -let coqint p n = - let n = camlint_of_coqint n in - if n >= 0l - then fprintf p "(Int.repr %ld)" n - else fprintf p "(Int.repr (%ld))" n - -let coqptrofs p n = - let s = Z.to_string n in - if Z.ge n Z.zero - then fprintf p "(Ptrofs.repr %s)" s - else fprintf p "(Ptrofs.repr (%s))" s - -let coqint64 p n = - let n = camlint64_of_coqint n in - if n >= 0L - then fprintf p "(Int64.repr %Ld)" n - else fprintf p "(Int64.repr (%Ld))" n - -let coqfloat p n = - fprintf p "(Float.of_bits %a)" coqint64 (Floats.Float.to_bits n) - -let coqsingle p n = - fprintf p "(Float32.of_bits %a)" coqint (Floats.Float32.to_bits n) - -let coqN p n = - fprintf p "%ld%%N" (N.to_int32 n) - -let coqZ p n = - if Z.ge n Z.zero - then fprintf p "%s" (Z.to_string n) - else fprintf p "(%s)" (Z.to_string n) - -(* Coq strings *) - -let coqstring p s = - fprintf p "\"%s\"" (camlstring_of_coqstring s) - (* Raw attributes *) let attribute p a = @@ -247,8 +257,6 @@ let signatur p sg = astrettype sg.sig_res callconv sg.sig_cc -let assertions = ref ([]: (string * typ list) list) - let external_function p = function | EF_external(name, sg) -> fprintf p "@[<hov 2>(EF_external %a@ %a)@]" coqstring name signatur sg @@ -264,14 +272,15 @@ let external_function p = function | EF_free -> fprintf p "EF_free" | EF_memcpy(sz, al) -> fprintf p "(EF_memcpy %ld %ld)" (Z.to_int32 sz) (Z.to_int32 al) - | EF_annot(kind,text, targs) -> - assertions := (camlstring_of_coqstring text, targs) :: !assertions; - fprintf p "(EF_annot %a %a)" coqstring text (print_list asttype) targs - | EF_annot_val(kind,text, targ) -> - assertions := (camlstring_of_coqstring text, [targ]) :: !assertions; - fprintf p "(EF_annot_val %a %a)" coqstring text asttype targ + | EF_annot(kind, text, targs) -> + fprintf p "(EF_annot %a %a %a)" + positive kind coqstring text (print_list asttype) targs + | EF_annot_val(kind, text, targ) -> + fprintf p "(EF_annot_val %a %a %a)" + positive kind coqstring text asttype targ | EF_debug(kind, text, targs) -> - fprintf p "(EF_debug %ld%%positive %ld%%positive %a)" (P.to_int32 kind) (P.to_int32 text) (print_list asttype) targs + fprintf p "(EF_debug %a %a %a)" + positive kind positive text (print_list asttype) targs | EF_inline_asm(text, sg, clob) -> fprintf p "@[<hov 2>(EF_inline_asm %a@ %a@ %a)@]" coqstring text @@ -441,61 +450,13 @@ let print_composite_definition p (Composite(id, su, m, a)) = (print_list (print_pair ident typ)) m attribute a -(* Assertion processing *) - -let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*" - -type fragment = Text of string | Param of int - -(* For compatibility with OCaml < 4.00 *) -let list_iteri f l = - let rec iteri i = function - | [] -> () - | a::l -> f i a; iteri (i + 1) l - in iteri 0 l - -let print_assertion p (txt, targs) = - let frags = - List.map - (function - | Str.Text s -> Text s - | Str.Delim "%%" -> Text "%" - | Str.Delim s -> Param(int_of_string(String.sub s 1 (String.length s - 1)))) - (Str.full_split re_annot_param txt) in - let max_param = ref 0 in - List.iter - (function - | Text _ -> () - | Param n -> max_param := max n !max_param) - frags; - fprintf p " | \"%s\"%%string, " txt; - list_iteri - (fun i targ -> fprintf p "_x%d :: " (i + 1)) - targs; - fprintf p "nil =>@ "; - fprintf p " "; - List.iter - (function - | Text s -> fprintf p "%s" s - | Param n -> fprintf p "_x%d" n) - frags; - fprintf p "@ " - -let print_assertions p = - if !assertions <> [] then begin - fprintf p "Definition assertions (txt: string) args : Prop :=@ "; - fprintf p " match txt, args with@ "; - List.iter (print_assertion p) !assertions; - fprintf p " | _, _ => False@ "; - fprintf p " end.@ @ " - end - (* The prologue *) let prologue = "\ From Coq Require Import String List ZArith.\n\ From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.\n\ -Local Open Scope Z_scope.\n" +Local Open Scope Z_scope.\n\ +Local Open Scope string_scope.\n" (* Naming the compiler-generated temporaries occurring in the program *) @@ -554,15 +515,16 @@ let name_program p = let print_clightgen_info p sourcefile normalized = fprintf p "@[<v 2>Module Info."; - fprintf p "@ Definition version := %S%%string." Version.version; - fprintf p "@ Definition build_number := %S%%string." Version.buildnr; - fprintf p "@ Definition build_tag := %S%%string." Version.tag; - fprintf p "@ Definition arch := %S%%string." Configuration.arch; - fprintf p "@ Definition model := %S%%string." Configuration.model; - fprintf p "@ Definition abi := %S%%string." Configuration.abi; + fprintf p "@ Definition version := %S." Version.version; + fprintf p "@ Definition build_number := %S." Version.buildnr; + fprintf p "@ Definition build_tag := %S." Version.tag; + fprintf p "@ Definition build_branch := %S." Version.branch; + fprintf p "@ Definition arch := %S." Configuration.arch; + fprintf p "@ Definition model := %S." Configuration.model; + fprintf p "@ Definition abi := %S." Configuration.abi; fprintf p "@ Definition bitsize := %d." (if Archi.ptr64 then 64 else 32); fprintf p "@ Definition big_endian := %B." Archi.big_endian; - fprintf p "@ Definition source_file := %S%%string." sourcefile; + fprintf p "@ Definition source_file := %S." sourcefile; fprintf p "@ Definition normalized := %B." normalized; fprintf p "@]@ End Info.@ @ " @@ -588,5 +550,4 @@ let print_program p prog sourcefile normalized = fprintf p "Definition prog : Clight.program := @ "; fprintf p " mkprogram composites global_definitions public_idents %a Logic.I.@ @ " ident prog.Ctypes.prog_main; - print_assertions p; fprintf p "@]@." diff --git a/extraction/extraction.v b/extraction/extraction.vexpand index 15651610..2cc7bef1 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.vexpand @@ -13,6 +13,7 @@ (* *) (* *********************************************************************) +Require Import ZArith PeanoNat. Require Coqlib. Require Wfsimpl. Require DecidableClass Decidableplus. @@ -243,7 +244,8 @@ Set Extraction AccessOpaque. Cd "extraction". -Separate Extraction +Separate Extraction + Z.ldiff Z.lnot Nat.leb CSE3analysis.internal_analysis CSE3analysis.eq_depends_on_mem Compiler.transf_c_program Compiler.transf_cminor_program Compiler.transf_c_program_via_SSA Compiler.transf_cminor_program_via_SSA @@ -270,4 +272,4 @@ Separate Extraction Globalenvs.Senv.invert_symbol Parser.translation_unit_file Compopts.optim_postpass - Archi.has_notrap_loads. + Archi.has_notrap_loads diff --git a/filter_peeplog.fish b/filter_peeplog.fish new file mode 100755 index 00000000..b7ba1d28 --- /dev/null +++ b/filter_peeplog.fish @@ -0,0 +1,9 @@ +echo "LDP_CONSEC_PEEP_IMM_INC" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC" | wc -l) +echo "STP_CONSEC_PEEP_IMM_INC" (cat log | ack "STP_CONSEC_PEEP_IMM_INC" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC" | wc -l)
\ No newline at end of file @@ -35,12 +35,14 @@ Require Import Smallstep. Require Import Locations. Require Stacklayout. Require Import Conventions. -Require Import Asmvliw. +Require Export Asmvliw. Require Import Linking. Require Import Errors. (** Definitions for OCaml code *) Definition label := positive. + +(* Necessary definition for Asmexpandaux.mli *) Definition preg := preg. Inductive addressing : Type := @@ -102,6 +104,9 @@ Inductive instruction : Type := | Palclrd (dst: ireg) (addr: ireg) | Palclrw (dst: ireg) (addr: ireg) | Pclzll (rd rs: ireg) + | Pclzw (rd rs: ireg) + | Pctzll (rd rs: ireg) + | Pctzw (rd rs: ireg) | Pstsud (rd rs1 rs2: ireg) (** Loads *) diff --git a/kvx/Asmblockdeps.v b/kvx/Asmblockdeps.v index 3d981100..b6d18c3e 100644 --- a/kvx/Asmblockdeps.v +++ b/kvx/Asmblockdeps.v @@ -40,6 +40,10 @@ Require Import Chunks. Require Import Lia. + +Import ListNotations. +Local Open Scope list_scope. + Open Scope impure. (** Definition of [L] *) @@ -394,8 +398,8 @@ Definition control_eval (o: control_op) (l: list value) := end | Ocbu bt l, [Val v; Val vpc] => match cmpu_for_btest bt with - | (Some c, Int) => eval_branch_deps fn l vpc (Val_cmpu_bool c v (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch_deps fn l vpc (Val_cmplu_bool c v (Vlong (Int64.repr 0))) + | (Some c, Int) => eval_branch_deps fn l vpc (Val.mxcmpu_bool c v (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch_deps fn l vpc (Val.mxcmplu_bool c v (Vlong (Int64.repr 0))) | (None, _) => None end | Odiv, [Val v1; Val v2] => @@ -706,19 +710,20 @@ Proof. destruct r; destruct r'. all: try discriminate; try contradiction. - intros. apply not_eq_add. apply ireg_to_pos_discr. congruence. - - intros. unfold ppos. cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. - apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. + - intros. unfold ppos. replace (3 + ireg_to_pos g) with ((1 + ireg_to_pos g) + 2). + apply Pos.add_no_neutral. + rewrite Pos.add_comm, Pos.add_assoc. reflexivity. - intros. unfold ppos. rewrite Pos.add_comm. apply Pos.add_no_neutral. - intros. unfold ppos. apply not_eq_sym. - cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. - apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. + replace (3 + ireg_to_pos g) with ((1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. + rewrite Pos.add_comm, Pos.add_assoc. reflexivity. - intros. unfold ppos. apply not_eq_sym. rewrite Pos.add_comm. apply Pos.add_no_neutral. Qed. Lemma ppos_pmem_discr: forall r, pmem <> ppos r. Proof. intros. destruct r. - - unfold ppos. unfold pmem. apply not_eq_sym. rewrite Pos.add_comm. cutrewrite (3 = 2 + 1). rewrite Pos.add_assoc. apply Pos.add_no_neutral. + - unfold ppos. unfold pmem. apply not_eq_sym. rewrite Pos.add_comm. replace 3 with (2 + 1). rewrite Pos.add_assoc. apply Pos.add_no_neutral. reflexivity. - unfold ppos. unfold pmem. discriminate. - unfold ppos. unfold pmem. discriminate. @@ -1227,12 +1232,12 @@ Proof. (* Pcbu *) + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. - ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. + ++ destruct (Val.mxcmpu_bool _ _ _); simpl; auto. destruct b. +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b. + ++ destruct (Val.mxcmplu_bool _ _ _); simpl; auto. destruct b. +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. intros rr; destruct rr; Simpl. @@ -1250,7 +1255,7 @@ Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw: Proof. intros; unfold estep. exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. - cutrewrite (rsw # PC <- (rsw PC) = rsw); auto. + replace (rsw # PC <- (rsw PC)) with rsw; auto. apply extensionality. intros; destruct x; simpl; auto. Qed. @@ -1461,8 +1466,8 @@ Proof. destruct H2 as (m2' & H2 & H4). discriminate. rewrite H2 in H3. destruct (exec_bblock ge fn p2 rs m); simpl in H3. * destruct H3 as (s' & H3 & H5 & H6). inv H3. inv MS'. - cutrewrite (rs0=rs1). - - cutrewrite (m0=m1); auto. congruence. + replace rs0 with rs1. + - replace m0 with m1; auto. congruence. - apply functional_extensionality. intros r. generalize (H0 r). intros Hr. congruence. * discriminate. diff --git a/kvx/Asmblockgen.v b/kvx/Asmblockgen.v index 7167cebe..e218f4ef 100644 --- a/kvx/Asmblockgen.v +++ b/kvx/Asmblockgen.v @@ -19,7 +19,7 @@ Require Archi. Require Import Coqlib Errors. Require Import AST Integers Floats Memdata. -Require Import Op Locations Machblock Asmblock. +Require Import Op Locations Machblock Asmvliw Asmblock. Require ExtValues. Require Import Chunks. @@ -36,12 +36,6 @@ Import PArithCoercions. (** Extracting integer or float registers. *) -Definition ireg_of (r: mreg) : res ireg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.ireg_of") end. - -Definition freg_of (r: mreg) : res freg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. - Inductive immed32 : Type := | Imm32_single (imm: int). diff --git a/kvx/lib/Asmblockgenproof0.v b/kvx/Asmblockgenproof0.v index 1af59238..12bb863a 100644 --- a/kvx/lib/Asmblockgenproof0.v +++ b/kvx/Asmblockgenproof0.v @@ -36,7 +36,6 @@ Require Import Asmblock. Require Import Asmblockgen. Require Import Conventions1. Require Import Axioms. -Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) Require Import Asmblockprops. Module MB:=Machblock. diff --git a/kvx/Asmblockgenproof1.v b/kvx/Asmblockgenproof1.v index 74b9b62b..c6ad70ab 100644 --- a/kvx/Asmblockgenproof1.v +++ b/kvx/Asmblockgenproof1.v @@ -256,7 +256,7 @@ Lemma transl_compu_correct: exists rs', exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (Val_cmpu_bool cmp rs#r1 rs#r2 = Some b -> + /\ (Val.mxcmpu_bool cmp rs#r1 rs#r2 = Some b -> exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -272,8 +272,8 @@ Proof. assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val_cmpu_bool cmp rs#r1 rs#r2) as cmpubool. - destruct cmp; simpl; unfold Val_cmpu; + remember (Val.mxcmpu_bool cmp rs#r1 rs#r2) as cmpubool. + destruct cmp; simpl; unfold Val.mxcmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; destruct b0; simpl; auto. } @@ -285,7 +285,7 @@ Lemma transl_compui_correct: exists rs', exec_straight ge (transl_compi cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> + /\ (Val.mxcmpu_bool cmp rs#r1 (Vint n) = Some b -> exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -301,8 +301,8 @@ Proof. assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val_cmpu_bool cmp rs#r1 (Vint n)) as cmpubool. - destruct cmp; simpl; unfold Val_cmpu; + remember (Val.mxcmpu_bool cmp rs#r1 (Vint n)) as cmpubool. + destruct cmp; simpl; unfold Val.mxcmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; destruct b0; simpl; auto. } @@ -656,7 +656,7 @@ Lemma transl_complu_correct: exists rs', exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmplu_bool cmp rs#r1 rs#r2 = Some b -> + /\ ( Val.mxcmplu_bool cmp rs#r1 rs#r2 = Some b -> exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -672,9 +672,9 @@ Proof. assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val_cmplu_bool cmp rs#r1 rs#r2) as cmpbool. + remember (Val.mxcmplu_bool cmp rs#r1 rs#r2) as cmpbool. destruct cmp; simpl; - unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + unfold compare_long, Val.mxcmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. } rewrite H0. simpl; auto. @@ -685,7 +685,7 @@ Lemma transl_compilu_correct: exists rs', exec_straight ge (transl_compil cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> + /\ ( Val.mxcmplu_bool cmp rs#r1 (Vlong n) = Some b -> exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . @@ -701,9 +701,9 @@ Proof. assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))). { rewrite Heqrs'. auto. } rewrite H0. rewrite <- H. - remember (Val_cmplu_bool cmp rs#r1 (Vlong n)) as cmpbool. + remember (Val.mxcmplu_bool cmp rs#r1 (Vlong n)) as cmpbool. destruct cmp; simpl; - unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + unfold compare_long, Val.mxcmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. } rewrite H0. simpl; auto. @@ -715,7 +715,7 @@ Lemma transl_opt_compuimm_correct: exists rs', exists insn, exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> + /\ ( Val.mxcmpu_bool cmp rs#r1 (Vint n) = Some b -> exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -791,7 +791,7 @@ Lemma transl_opt_compluimm_correct: exists rs', exists insn, exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> + /\ ( Val.mxcmplu_bool cmp rs#r1 (Vlong n) = Some b -> exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) . Proof. @@ -859,7 +859,7 @@ Proof. destruct cmp; discriminate. Qed. -Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core. +Local Hint Resolve Val.mxcmpu_bool_correct Val.mxcmplu_bool_correct: core. Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m' tbb, @@ -988,7 +988,7 @@ Proof. split. * constructor. eexact A'. * split; auto. - { apply C'; auto. eapply Val_cmplu_bool_correct; eauto. } + { apply C'; auto. eapply Val.mxcmplu_bool_correct; eauto. } (* Ccompf *) - exploit (transl_compf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). @@ -1078,7 +1078,7 @@ Lemma transl_cond_int32u_correct: forall cmp rd r1 r2 k rs m, exists rs', exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ rs'#rd = Val_cmpu cmp rs#r1 rs#r2 + /\ rs'#rd = Val.mxcmpu cmp rs#r1 rs#r2 /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. @@ -1122,7 +1122,7 @@ Lemma transl_cond_int64u_correct: forall cmp rd r1 r2 k rs m, exists rs', exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ rs'#rd = Val_cmplu cmp rs#r1 rs#r2 + /\ rs'#rd = Val.mxcmplu cmp rs#r1 rs#r2 /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. Proof. intros. destruct cmp; simpl. @@ -1163,7 +1163,7 @@ Proof. split; intros; Simpl. Qed. -Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core. +Local Hint Resolve Val.mxcmpu_correct Val.mxcmplu_correct: core. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, @@ -1279,12 +1279,12 @@ Proof. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float32.cmp_swap. + replace (Cge) with (swap_comparison Cle); auto. rewrite Float32.cmp_swap. destruct (Float32.cmp _ _ _); auto. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float32.cmp_swap. + replace (Clt) with (swap_comparison Cgt); auto. rewrite Float32.cmp_swap. destruct (Float32.cmp _ _ _); auto. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. @@ -1345,12 +1345,12 @@ Proof. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float.cmp_swap. + replace (Cge) with (swap_comparison Cle); auto. rewrite Float.cmp_swap. destruct (Float.cmp _ _ _); auto. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float.cmp_swap. + replace (Clt) with (swap_comparison Cgt); auto. rewrite Float.cmp_swap. destruct (Float.cmp _ _ _); auto. - econstructor; split. apply exec_straight_one; [simpl; eauto]. split; intros; Simpl. @@ -1374,7 +1374,7 @@ Proof. exploit transl_cond_int32s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; eauto. + (* cmpu *) exploit transl_cond_int32u_correct; eauto. simpl. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B; eapply Val_cmpu_correct. + exists rs'; repeat split; eauto. rewrite B; eapply Val.mxcmpu_correct. + (* cmpimm *) apply transl_condimm_int32s_correct; eauto with asmgen. + (* cmpuimm *) @@ -1385,7 +1385,7 @@ Proof. + (* cmplu *) exploit transl_cond_int64u_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. - eapply Val_cmplu_correct. + eapply Val.mxcmplu_correct. + (* cmplimm *) exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. intros (rs' & A & B & C). diff --git a/kvx/Asmexpand.ml b/kvx/Asmexpand.ml index 5d4fd2f5..1e76a355 100644 --- a/kvx/Asmexpand.ml +++ b/kvx/Asmexpand.ml @@ -359,7 +359,7 @@ let expand_bswap32 d s = let open Asmvliw in emit (Psrliw(GPR32, s, _8)); emit Psemi; emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; emit (Pslliw(GPR32, GPR32, _16)); emit Psemi; - emit (Porw(GPR16, GPR16, GPR31)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR32)); emit Psemi; emit (Psrliw(GPR32, s, _16)); emit Psemi; emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; @@ -399,8 +399,14 @@ let expand_builtin_inline name args res = let open Asmvliw in (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> expand_builtin_va_start a + | "__builtin_kvx_clzw", [BA(IR a)], BR(IR res) -> + emit (Pclzw(res, a)) | "__builtin_clzll", [BA(IR a)], BR(IR res) -> emit (Pclzll(res, a)) + | "__builtin_kvx_ctzw", [BA(IR a)], BR(IR res) -> + emit (Pctzw(res, a)) + | "__builtin_ctzll", [BA(IR a)], BR(IR res) -> + emit (Pctzll(res, a)) | "__builtin_kvx_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> emit (Pstsud(res, a1, a2)) | "__builtin_kvx_get", [BA_int(n)], BR(IR res) -> diff --git a/kvx/Asmvliw.v b/kvx/Asmvliw.v index 66b468d7..8afe8d07 100644 --- a/kvx/Asmvliw.v +++ b/kvx/Asmvliw.v @@ -163,6 +163,30 @@ Module PregEq. Definition eq := preg_eq. End PregEq. +(* FIXME - R16 and R32 are excluded *) +Definition preg_of (r: mreg) : preg := + match r with + | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 + | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 + | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 + | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 + | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 + | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 + | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 + | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 + | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 + end. + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.ireg_of") end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. + Module Pregmap := EMap(PregEq). (** ** Conventional names for stack pointer ([SP]), return address ([RA]), frame pointer ([FP]) and other temporaries used *) @@ -829,58 +853,6 @@ Definition cmpu_for_btest (bt: btest) := end. -(* **** a few lemma on comparisons of unsigned (e.g. pointers) *) - -Definition Val_cmpu_bool cmp v1 v2: option bool := - Val.cmpu_bool (fun _ _ => true) cmp v1 v2. - -Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: - (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b - -> (Val_cmpu_bool cmp v1 v2) = Some b. -Proof. - intros; eapply Val.cmpu_bool_lessdef; (econstructor 1 || eauto). -Qed. - -Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). - -Lemma Val_cmpu_correct (m:mem) (cmp: comparison) (v1 v2: val): - Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) - (Val_cmpu cmp v1 v2). -Proof. - unfold Val.cmpu, Val_cmpu. - remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. - destruct ob; cbn. - - erewrite Val_cmpu_bool_correct; eauto. - econstructor. - - econstructor. -Qed. - -Definition Val_cmplu_bool (cmp: comparison) (v1 v2: val) - := (Val.cmplu_bool (fun _ _ => true) cmp v1 v2). - -Lemma Val_cmplu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: - (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b - -> (Val_cmplu_bool cmp v1 v2) = Some b. -Proof. - intros; eapply Val.cmplu_bool_lessdef; (econstructor 1 || eauto). -Qed. - -Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). - -Lemma Val_cmplu_correct (m:mem) (cmp: comparison) (v1 v2: val): - Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp v1 v2)) - (Val_cmplu cmp v1 v2). -Proof. - unfold Val.cmplu, Val_cmplu. - remember (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. - destruct ob as [b|]; cbn. - - erewrite Val_cmplu_bool_correct; eauto. - cbn. econstructor. - - econstructor. -Qed. - - - (** **** Comparing integers *) Definition compare_int (t: itest) (v1 v2: val): val := match t with @@ -890,12 +862,12 @@ Definition compare_int (t: itest) (v1 v2: val): val := | ITge => Val.cmp Cge v1 v2 | ITle => Val.cmp Cle v1 v2 | ITgt => Val.cmp Cgt v1 v2 - | ITneu => Val_cmpu Cne v1 v2 - | ITequ => Val_cmpu Ceq v1 v2 - | ITltu => Val_cmpu Clt v1 v2 - | ITgeu => Val_cmpu Cge v1 v2 - | ITleu => Val_cmpu Cle v1 v2 - | ITgtu => Val_cmpu Cgt v1 v2 + | ITneu => Val.mxcmpu Cne v1 v2 + | ITequ => Val.mxcmpu Ceq v1 v2 + | ITltu => Val.mxcmpu Clt v1 v2 + | ITgeu => Val.mxcmpu Cge v1 v2 + | ITleu => Val.mxcmpu Cle v1 v2 + | ITgtu => Val.mxcmpu Cgt v1 v2 end. Definition compare_long (t: itest) (v1 v2: val): val := @@ -906,12 +878,12 @@ Definition compare_long (t: itest) (v1 v2: val): val := | ITge => Val.cmpl Cge v1 v2 | ITle => Val.cmpl Cle v1 v2 | ITgt => Val.cmpl Cgt v1 v2 - | ITneu => Some (Val_cmplu Cne v1 v2) - | ITequ => Some (Val_cmplu Ceq v1 v2) - | ITltu => Some (Val_cmplu Clt v1 v2) - | ITgeu => Some (Val_cmplu Cge v1 v2) - | ITleu => Some (Val_cmplu Cle v1 v2) - | ITgtu => Some (Val_cmplu Cgt v1 v2) + | ITneu => Some (Val.mxcmplu Cne v1 v2) + | ITequ => Some (Val.mxcmplu Ceq v1 v2) + | ITltu => Some (Val.mxcmplu Clt v1 v2) + | ITgeu => Some (Val.mxcmplu Cge v1 v2) + | ITleu => Some (Val.mxcmplu Cle v1 v2) + | ITgtu => Some (Val.mxcmplu Cgt v1 v2) end in match res with | Some v => v @@ -1123,13 +1095,13 @@ Definition cmove bt v1 v2 v3 := Definition cmoveu bt v1 v2 v3 := match cmpu_for_btest bt with | (Some c, Int) => - match Val_cmpu_bool c v2 (Vint Int.zero) with + match Val.mxcmpu_bool c v2 (Vint Int.zero) with | None => Vundef | Some true => v3 | Some false => v1 end | (Some c, Long) => - match Val_cmplu_bool c v2 (Vlong Int64.zero) with + match Val.mxcmplu_bool c v2 (Vlong Int64.zero) with | None => Vundef | Some true => v3 | Some false => v1 @@ -1505,8 +1477,8 @@ Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) end | Pcbu bt r l => match cmpu_for_btest bt with - | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val_cmpu_bool c rsr#r (Vint (Int.repr 0))) - | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val_cmplu_bool c rsr#r (Vlong (Int64.repr 0))) + | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val.mxcmpu_bool c rsr#r (Vint (Int.repr 0))) + | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val.mxcmplu_bool c rsr#r (Vlong (Int64.repr 0))) | (None, _) => Stuck end (**r Pseudo-instructions *) @@ -1548,24 +1520,6 @@ Definition det_parexec (f: function) (bundle: bblock) (rs: regset) (m: mem) rs' code. *) -(* FIXME - R16 and R32 are excluded *) -Definition preg_of (r: mreg) : preg := - match r with - | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 - | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 - | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) - | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 - | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 - | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 - | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 - | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 - | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 - | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 - | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 - | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 - | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 - end. - (** **** Undefine all registers except SP and callee-save registers *) Definition undef_caller_save_regs (rs: regset) : regset := diff --git a/kvx/Builtins1.v b/kvx/Builtins1.v index eeb578d0..441345bf 100644 --- a/kvx/Builtins1.v +++ b/kvx/Builtins1.v @@ -24,7 +24,6 @@ Inductive platform_builtin : Type := | BI_fmax | BI_fminf | BI_fmaxf -| BI_fabsf | BI_fma | BI_fmaf. @@ -35,7 +34,6 @@ Definition platform_builtin_table : list (string * platform_builtin) := :: ("__builtin_fmax", BI_fmax) :: ("__builtin_fminf", BI_fminf) :: ("__builtin_fmaxf", BI_fmaxf) - :: ("__builtin_fabsf", BI_fabsf) :: ("__builtin_fma", BI_fma) :: ("__builtin_fmaf", BI_fmaf) :: nil. @@ -46,8 +44,6 @@ Definition platform_builtin_sig (b: platform_builtin) : signature := mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default | BI_fminf | BI_fmaxf => mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default - | BI_fabsf => - mksignature (Tsingle :: nil) Tsingle cc_default | BI_fma => mksignature (Tfloat :: Tfloat :: Tfloat :: nil) Tfloat cc_default | BI_fmaf => @@ -60,7 +56,6 @@ Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (pl | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max - | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs | BI_fma => mkbuiltin_n3t Tfloat Tfloat Tfloat Tfloat Float.fma | BI_fmaf => mkbuiltin_n3t Tsingle Tsingle Tsingle Tsingle Float32.fma end. diff --git a/kvx/CBuiltins.ml b/kvx/CBuiltins.ml index fa2f4c60..7398e0f4 100644 --- a/kvx/CBuiltins.ml +++ b/kvx/CBuiltins.ml @@ -73,8 +73,10 @@ let builtins = { (* "__builtin_kvx_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *) (* "__builtin_kvx_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) (* "__builtin_kvx_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) - "__builtin_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_kvx_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); "__builtin_clzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + "__builtin_kvx_ctzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_ctzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); (* "__builtin_kvx_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) (* "__builtin_kvx_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_kvx_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) diff --git a/kvx/CSE2deps.v b/kvx/CSE2deps.v index b4b80e2f..c0deacf0 100644 --- a/kvx/CSE2deps.v +++ b/kvx/CSE2deps.v @@ -28,5 +28,8 @@ Definition may_overlap chunk addr args chunk' addr' args' := (base :: nil), (base' :: nil) => if peq base base' then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) - else true | _, _, _, _ => true + else true + | (Ainstack ofs), (Ainstack ofs'), _, _ => + negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + | _, _, _, _ => true end. diff --git a/kvx/CSE2depsproof.v b/kvx/CSE2depsproof.v index 6c584450..a5f7b317 100644 --- a/kvx/CSE2depsproof.v +++ b/kvx/CSE2depsproof.v @@ -123,17 +123,24 @@ Proof. intros until rs. intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) - destruct args as [ | base [ | ]]. 1,3: discriminate. - destruct args' as [ | base' [ | ]]. 1,3: discriminate. - cbn in OVERLAP. - destruct (peq base base'). 2: discriminate. - subst base'. - destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. - 2: discriminate. - cbn in *. - eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. - } + - (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + cbn in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + - (* Ainstack / Ainstack *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + cbn in OVERLAP. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. Qed. End SOUNDNESS. diff --git a/kvx/Machregsaux.ml b/kvx/Machregsaux.ml index 76956959..e3b18181 100644 --- a/kvx/Machregsaux.ml +++ b/kvx/Machregsaux.ml @@ -27,14 +27,6 @@ let _ = let is_scratch_register r = false -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = Conventions1.is_callee_save r - let class_of_type = function | AST.Tint | AST.Tlong | AST.Tfloat | AST.Tsingle -> 0 diff --git a/kvx/Machregsaux.mli b/kvx/Machregsaux.mli index d7117c21..01b0f9fd 100644 --- a/kvx/Machregsaux.mli +++ b/kvx/Machregsaux.mli @@ -12,9 +12,6 @@ (** Auxiliary functions on machine registers *) -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool val class_of_type: AST.typ -> int @@ -1238,6 +1238,26 @@ Proof. unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. +Lemma op_valid_pointer_eq: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + - intros MEM; destruct cond; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intros MEM; destruct c0; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intros MEM; destruct c0; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intros MEM; destruct c0; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. +Qed. + (** Global variables mentioned in an operation or addressing mode *) Definition globals_addressing (addr: addressing) : list ident := diff --git a/kvx/OpWeights.ml b/kvx/OpWeights.ml new file mode 100644 index 00000000..23c2e5d3 --- /dev/null +++ b/kvx/OpWeights.ml @@ -0,0 +1,115 @@ +open Op;; +open PostpassSchedulingOracle;; +open PrepassSchedulingOracleDeps;; + +module KV3 = + struct +let resource_bounds = PostpassSchedulingOracle.resource_bounds;; +let nr_non_pipelined_units = 0;; + +let rec nlist_rec x l = function + | 0 -> l + | n when n > 0 -> nlist_rec x (x :: l) (n-1) + | _ -> failwith "nlist_rec";; +let nlist x n = nlist_rec x [] n;; + +let bogus_register = Machregs.R0;; +let bogus_inputs n = nlist bogus_register n;; + +let insns_of_op (op : operation) (nargs : int) = + match Asmblockgen.transl_op op + (bogus_inputs nargs) bogus_register [] with + | Errors.Error msg -> failwith "OpWeights.insns_of_op" + | Errors.OK insns -> insns;; + +let insn_of_op op nargs = + match insns_of_op op nargs with + | [] -> failwith "OpWeights.insn_of_op" + | h::_ -> h;; + +let insns_of_cond (cond : condition) (nargs : int) = + match Asmblockgen.transl_cond_op cond + Asmvliw.GPR0 (bogus_inputs nargs) [] with + | Errors.Error msg -> failwith "OpWeights.insns_of_cond" + | Errors.OK insns -> insns;; + +let insn_of_cond cond nargs = + match insns_of_cond cond nargs with + | [] -> failwith "OpWeights.insn_of_cond" + | h::_ -> h;; + +let insns_of_load trap chunk addressing (nargs : int) = + match Asmblockgen.transl_load trap chunk addressing + (bogus_inputs nargs) bogus_register [] with + | Errors.Error msg -> failwith "OpWeights.insns_of_load" + | Errors.OK insns -> insns;; + +let insn_of_load trap chunk addressing nargs = + match insns_of_load trap chunk addressing nargs with + | [] -> failwith "OpWeights.insn_of_load" + | h::_ -> h;; + +let insns_of_store chunk addressing (nargs : int) = + match Asmblockgen.transl_store chunk addressing + (bogus_inputs nargs) bogus_register [] with + | Errors.Error msg -> failwith "OpWeights.insns_of_store" + | Errors.OK insns -> insns;; + +let insn_of_store chunk addressing nargs = + match insns_of_store chunk addressing nargs with + | [] -> failwith "OpWeights.insn_of_store" + | h::_ -> h;; + +let latency_of_op (op : operation) (nargs : int) = + let insn = insn_of_op op nargs in + let record = basic_rec insn in + let latency = real_inst_to_latency record.inst in + latency;; + +let resources_of_op (op : operation) (nargs : int) = + let insn = insn_of_op op nargs in + let record = basic_rec insn in + rec_to_usage record;; + +let non_pipelined_resources_of_op (op : operation) (nargs : int) = [| |] + +let resources_of_cond (cond : condition) (nargs : int) = + let insn = insn_of_cond cond nargs in + let record = basic_rec insn in + rec_to_usage record;; + +let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; +let latency_of_call _ _ = 6;; + +let resources_of_load trap chunk addressing nargs = + let insn = insn_of_load trap chunk addressing nargs in + let record = basic_rec insn in + rec_to_usage record;; + +let resources_of_store chunk addressing nargs = + let insn = insn_of_store chunk addressing nargs in + let record = basic_rec insn in + rec_to_usage record;; + +let resources_of_call _ _ = resource_bounds;; +let resources_of_builtin _ = resource_bounds;; + end;; + +let get_opweights () : opweights = + match !Clflags.option_mtune with + | "kv3" | "" -> + { + pipelined_resource_bounds = KV3.resource_bounds; + nr_non_pipelined_units = KV3.nr_non_pipelined_units; + latency_of_op = KV3.latency_of_op; + resources_of_op = KV3.resources_of_op; + non_pipelined_resources_of_op = KV3.non_pipelined_resources_of_op; + latency_of_load = KV3.latency_of_load; + resources_of_load = KV3.resources_of_load; + resources_of_store = KV3.resources_of_store; + resources_of_cond = KV3.resources_of_cond; + latency_of_call = KV3.latency_of_call; + resources_of_call = KV3.resources_of_call; + resources_of_builtin = KV3.resources_of_builtin + } + | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);; diff --git a/kvx/PrepassSchedulingOracle.ml b/kvx/PrepassSchedulingOracle.ml new file mode 120000 index 00000000..912e9ffa --- /dev/null +++ b/kvx/PrepassSchedulingOracle.ml @@ -0,0 +1 @@ +../aarch64/PrepassSchedulingOracle.ml
\ No newline at end of file diff --git a/kvx/PrepassSchedulingOracleDeps.ml b/kvx/PrepassSchedulingOracleDeps.ml new file mode 120000 index 00000000..1e955b85 --- /dev/null +++ b/kvx/PrepassSchedulingOracleDeps.ml @@ -0,0 +1 @@ +../aarch64/PrepassSchedulingOracleDeps.ml
\ No newline at end of file diff --git a/kvx/SelectOp.vp b/kvx/SelectOp.vp index 65dba3ac..aa241c1e 100644 --- a/kvx/SelectOp.vp +++ b/kvx/SelectOp.vp @@ -704,7 +704,6 @@ Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr | BI_fmax => Some (Eop Omaxf args) | BI_fminf => Some (Eop Ominfs args) | BI_fmaxf => Some (Eop Omaxfs args) - | BI_fabsf => Some (Eop Oabsfs args) | BI_fma => gen_fma args | BI_fmaf => gen_fmaf args end. diff --git a/kvx/SelectOpproof.v b/kvx/SelectOpproof.v index 8c834de5..7a301929 100644 --- a/kvx/SelectOpproof.v +++ b/kvx/SelectOpproof.v @@ -1199,7 +1199,6 @@ Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. Qed. diff --git a/kvx/TargetPrinter.ml b/kvx/TargetPrinter.ml index dfafc137..5b6230ca 100644 --- a/kvx/TargetPrinter.ml +++ b/kvx/TargetPrinter.ml @@ -414,6 +414,9 @@ module Target (*: TARGET*) = | Psemi -> fprintf oc ";;\n" | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs + | Pclzw (rd, rs) -> fprintf oc " clzw %a = %a\n" ireg rd ireg rs + | Pctzll (rd, rs) -> fprintf oc " ctzd %a = %a\n" ireg rd ireg rs + | Pctzw (rd, rs) -> fprintf oc " ctzw %a = %a\n" ireg rd ireg rs | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 diff --git a/kvx/ValueAOp.v b/kvx/ValueAOp.v index 122c9a60..87554258 100644 --- a/kvx/ValueAOp.v +++ b/kvx/ValueAOp.v @@ -16,87 +16,6 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op ExtValues ExtFloats RTL ValueDomain. - -Definition intoffloat_total (x: aval) := - match x with - | F f => - match Float.to_int f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition intuoffloat_total (x: aval) := - match x with - | F f => - match Float.to_intu f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition intofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_int f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition intuofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_intu f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longoffloat_total (x: aval) := - match x with - | F f => - match Float.to_long f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longuoffloat_total (x: aval) := - match x with - | F f => - match Float.to_longu f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_long f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longuofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_longu f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - Definition minf := binop_float ExtFloat.min. Definition maxf := binop_float ExtFloat.max. Definition minfs := binop_single ExtFloat32.min. @@ -400,196 +319,6 @@ Hypothesis GENV: genv_match bc ge. Variable sp: block. Hypothesis STACK: bc sp = BCstack. -Lemma intoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intoffloat v)) (intoffloat_total x). -Proof. - unfold Val.intoffloat, intoffloat_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float.to_int f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intoffloat_total_sound : va. - -Lemma intuoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intuoffloat v)) (intuoffloat_total x). -Proof. - unfold Val.intoffloat, intoffloat_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float.to_intu f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intuoffloat_total_sound : va. - -Lemma intofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intofsingle v)) (intofsingle_total x). -Proof. - unfold Val.intofsingle, intofsingle_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float32.to_int f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intofsingle_total_sound : va. - -Lemma intuofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intuofsingle v)) (intuofsingle_total x). -Proof. - unfold Val.intofsingle, intofsingle_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float32.to_intu f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intuofsingle_total_sound : va. - -Lemma singleofint_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleofint v)) (singleofint x). -Proof. - unfold Val.singleofint, singleofint; intros. - inv H; cbn. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleofint_total_sound : va. - -Lemma singleofintu_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleofintu v)) (singleofintu x). -Proof. - unfold Val.singleofintu, singleofintu; intros. - inv H; cbn. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleofintu_total_sound : va. - -Lemma longoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longoffloat v)) (longoffloat_total x). -Proof. - unfold Val.longoffloat, longoffloat_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float.to_long f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longoffloat_total_sound : va. - -Lemma longuoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longuoffloat v)) (longuoffloat_total x). -Proof. - unfold Val.longoffloat, longoffloat_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float.to_longu f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longuoffloat_total_sound : va. - -Lemma longofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longofsingle v)) (longofsingle_total x). -Proof. - unfold Val.longofsingle, longofsingle_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float32.to_long f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longofsingle_total_sound : va. - -Lemma longuofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longuofsingle v)) (longuofsingle_total x). -Proof. - unfold Val.longofsingle, longofsingle_total. intros. - inv MATCH; cbn in *; try constructor. - all: destruct (Float32.to_longu f) as [i|] eqn:E; cbn; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longuofsingle_total_sound : va. - -Lemma singleoflong_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleoflong v)) (singleoflong x). -Proof. - unfold Val.singleoflong, singleoflong; intros. - inv H; cbn. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleoflong_total_sound : va. - -Lemma singleoflongu_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleoflongu v)) (singleoflongu x). -Proof. - unfold Val.singleoflongu, singleoflongu; intros. - inv H; cbn. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleoflongu_total_sound : va. - -Lemma floatoflong_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.floatoflong v)) (floatoflong x). -Proof. - unfold Val.floatoflong, floatoflong; intros. - inv H; cbn. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve floatoflong_total_sound : va. - -Lemma floatoflongu_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.floatoflongu v)) (floatoflongu x). -Proof. - unfold Val.floatoflongu, floatoflongu; intros. - inv H; cbn. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve floatoflongu_total_sound : va. - Lemma minf_sound: forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y). Proof. @@ -815,16 +544,6 @@ Proof. inv H1; cbn; try constructor. all: destruct Int.ltu; [cbn | constructor; fail]. all: auto with va. - - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with - | Vlong n2 => Vlong (Int64.add n n2) - | Vptr b2 ofs2 => - if Archi.ptr64 - then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n)) - else Vundef - | _ => Vundef - end) with (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). - + eauto with va. - + destruct a1; destruct shift; reflexivity. - inv H1; constructor. - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with | Vlong n2 => Vlong (Int64.sub n n2) @@ -832,10 +551,6 @@ Proof. end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. - - (* shrxl *) - inv H1; cbn; try constructor. - all: destruct Int.ltu; [cbn | constructor; fail]. - all: auto with va. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. (* extfz *) diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index 66322efb..af65b28e 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -282,23 +282,96 @@ type atom = positive let atom_of_string = (Hashtbl.create 17 : (string, atom) Hashtbl.t) let string_of_atom = (Hashtbl.create 17 : (atom, string) Hashtbl.t) let next_atom = ref Coq_xH +let use_canonical_atoms = ref false + +(* If [use_canonical_atoms] is false, strings are numbered from 1 up + in the order in which they are encountered. This produces small + numbers, and is therefore efficient, but the number for a given + string may differ between the compilation of different units. + + If [use_canonical_atoms] is true, strings are Huffman-encoded as bit + sequences, which are then encoded as positive numbers. The same + string is always represented by the same number in all compilation + units. However, the numbers are bigger than in the first + implementation. Also, this places a hard limit on the number of + fresh identifiers that can be generated starting with + [first_unused_ident]. *) + +let rec append_bits_pos nbits n p = + if nbits <= 0 then p else + if n land 1 = 0 + then Coq_xO (append_bits_pos (nbits - 1) (n lsr 1) p) + else Coq_xI (append_bits_pos (nbits - 1) (n lsr 1) p) + +(* The encoding of strings as bit sequences is optimized for C identifiers: + - numbers are encoded as a 6-bit integer between 0 and 9 + - lowercase letters are encoded as a 6-bit integer between 10 and 35 + - uppercase letters are encoded as a 6-bit integer between 36 and 61 + - the underscore character is encoded as the 6-bit integer 62 + - all other characters are encoded as 6 "one" bits followed by + the 8-bit encoding of the character. *) + +let append_char_pos c p = + match c with + | '0'..'9' -> append_bits_pos 6 (Char.code c - Char.code '0') p + | 'a'..'z' -> append_bits_pos 6 (Char.code c - Char.code 'a' + 10) p + | 'A'..'Z' -> append_bits_pos 6 (Char.code c - Char.code 'A' + 36) p + | '_' -> append_bits_pos 6 62 p + | _ -> append_bits_pos 6 63 (append_bits_pos 8 (Char.code c) p) + +(* The empty string is represented as the positive "1", that is, [xH]. *) + +let pos_of_string s = + let rec encode i accu = + if i < 0 then accu else encode (i - 1) (append_char_pos s.[i] accu) + in encode (String.length s - 1) Coq_xH + +let fresh_atom () = + let a = !next_atom in + next_atom := Pos.succ !next_atom; + a let intern_string s = try Hashtbl.find atom_of_string s with Not_found -> - let a = !next_atom in - next_atom := Pos.succ !next_atom; + let a = + if !use_canonical_atoms then pos_of_string s else fresh_atom () in Hashtbl.add atom_of_string s a; Hashtbl.add string_of_atom a s; a + let extern_atom a = try Hashtbl.find string_of_atom a with Not_found -> Printf.sprintf "$%d" (P.to_int a) -let first_unused_ident () = !next_atom +(* Ignoring the terminating "1" bit, canonical encodings of strings can + be viewed as lists of bits, formed by concatenation of 6-bit fragments + (for letters, numbers, and underscore) and 14-bit fragments (for other + characters). Hence, not all positive numbers are canonical encodings: + only those whose log2 is of the form [6n + 14m]. + + Here are the first intervals of positive numbers corresponding to strings: + - [1, 1] for the empty string + - [2^6, 2^7-1] for one "compact" character + - [2^12, 2^13-1] for two "compact" characters + - [2^14, 2^14-1] for one "escaped" character + + Hence, between 2^7 and 2^12 - 1, we have 3968 consecutive positive + numbers that cannot be the encoding of a string. These are the positive + numbers we'll use as temporaries in the SimplExpr pass if canonical + atoms are in use. + + If short atoms are used, we just number the temporaries consecutively + starting one above the last generated atom. +*) + +let first_unused_ident () = + if !use_canonical_atoms + then P.of_int 128 + else !next_atom (* Strings *) diff --git a/driver/Commandline.ml b/lib/Commandline.ml index 672ed834..672ed834 100644 --- a/driver/Commandline.ml +++ b/lib/Commandline.ml diff --git a/driver/Commandline.mli b/lib/Commandline.mli index 8bb6f18f..8bb6f18f 100644 --- a/driver/Commandline.mli +++ b/lib/Commandline.mli diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 16d880fa..7a7261a3 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -1053,6 +1053,41 @@ Proof. induction 1; intros. auto. apply IHis_tail. eapply is_tail_cons_left; eauto. Qed. +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; cbn; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; cbn; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + +Lemma is_tail_app_right A (l2 l1: list A): is_tail l1 (l2++l1). +Proof. + intros; eauto with coqlib. +Qed. + +Lemma is_tail_app_def A (l1 l2: list A): + is_tail l1 l2 -> exists l3, l2 = l3 ++ l1. +Proof. + induction 1 as [|x l1 l2]; simpl. + - exists nil; simpl; auto. + - destruct IHis_tail as (l3 & EQ); rewrite EQ. + exists (x::l3); simpl; auto. +Qed. + +Lemma is_tail_bound A (l1 l2: list A): + is_tail l1 l2 -> (length l1 <= length l2)%nat. +Proof. + intros H; destruct (is_tail_app_def H) as (l3 & EQ). + subst; rewrite app_length. + omega. +Qed. + (** [list_forall2 P [x1 ... xN] [y1 ... yM]] holds iff [N = M] and [P xi yi] holds for all [i]. *) diff --git a/lib/Floats.v b/lib/Floats.v index 272efa52..ac67b88c 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -17,11 +17,11 @@ (** Formalization of floating-point numbers, using the Flocq library. *) Require Import Coqlib Zbits Integers Axioms. -(*From Flocq*) -Require Import Binary Bits Core. +From Flocq Require Import Binary Bits Core. Require Import IEEE754_extra. Require Import Program. Require Archi. +Import ListNotations. Close Scope R_scope. Open Scope Z_scope. diff --git a/lib/IEEE754_extra.v b/lib/IEEE754_extra.v index c23149be..18313ec1 100644 --- a/lib/IEEE754_extra.v +++ b/lib/IEEE754_extra.v @@ -17,11 +17,11 @@ (** Additional operations and proofs about IEEE-754 binary floating-point numbers, on top of the Flocq library. *) +From Flocq Require Import Core Digits Operations Round Bracket Sterbenz + Binary Round_odd. Require Import Psatz. Require Import Bool. Require Import Eqdep_dec. -(*From Flocq *) -Require Import Core Digits Operations Round Bracket Sterbenz Binary Round_odd. Local Open Scope Z_scope. diff --git a/kvx/abstractbb/Impure/ImpConfig.v b/lib/Impure/ImpConfig.v index dd9785b5..dd9785b5 100644 --- a/kvx/abstractbb/Impure/ImpConfig.v +++ b/lib/Impure/ImpConfig.v diff --git a/kvx/abstractbb/Impure/ImpCore.v b/lib/Impure/ImpCore.v index 508b3f19..508b3f19 100644 --- a/kvx/abstractbb/Impure/ImpCore.v +++ b/lib/Impure/ImpCore.v diff --git a/kvx/abstractbb/Impure/ImpExtern.v b/lib/Impure/ImpExtern.v index 8fb3cf3b..8fb3cf3b 100644 --- a/kvx/abstractbb/Impure/ImpExtern.v +++ b/lib/Impure/ImpExtern.v diff --git a/kvx/abstractbb/Impure/ImpHCons.v b/lib/Impure/ImpHCons.v index 637116cc..637116cc 100644 --- a/kvx/abstractbb/Impure/ImpHCons.v +++ b/lib/Impure/ImpHCons.v diff --git a/kvx/abstractbb/Impure/ImpIO.v b/lib/Impure/ImpIO.v index 6c02c395..6c02c395 100644 --- a/kvx/abstractbb/Impure/ImpIO.v +++ b/lib/Impure/ImpIO.v diff --git a/kvx/abstractbb/Impure/ImpLoops.v b/lib/Impure/ImpLoops.v index 33376c19..33376c19 100644 --- a/kvx/abstractbb/Impure/ImpLoops.v +++ b/lib/Impure/ImpLoops.v diff --git a/kvx/abstractbb/Impure/ImpMonads.v b/lib/Impure/ImpMonads.v index f01a2755..f01a2755 100644 --- a/kvx/abstractbb/Impure/ImpMonads.v +++ b/lib/Impure/ImpMonads.v diff --git a/kvx/abstractbb/Impure/ImpPrelude.v b/lib/Impure/ImpPrelude.v index de4c7973..de4c7973 100644 --- a/kvx/abstractbb/Impure/ImpPrelude.v +++ b/lib/Impure/ImpPrelude.v diff --git a/kvx/abstractbb/Impure/LICENSE b/lib/Impure/LICENSE index 65c5ca88..65c5ca88 100644 --- a/kvx/abstractbb/Impure/LICENSE +++ b/lib/Impure/LICENSE diff --git a/kvx/abstractbb/Impure/README.md b/lib/Impure/README.md index 2b19d14a..2b19d14a 100644 --- a/kvx/abstractbb/Impure/README.md +++ b/lib/Impure/README.md diff --git a/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/lib/Impure/ocaml/ImpHConsOracles.ml index 2b66899b..68a33a91 100644 --- a/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ b/lib/Impure/ocaml/ImpHConsOracles.ml @@ -38,12 +38,18 @@ let xhCons (type a) (hp:a hashP) = let t = MyHashtbl.create 1000 in let logs = ref [] in { - hC = (fun (k:a hashinfo) -> + hC = (fun (k:a hashinfo) -> + (* DEBUG: + Printf.printf "*in %d -- look for hcodes= " (Obj.magic t); + List.iter (fun i -> Printf.printf "%d " i) k.hcodes; + print_newline(); + *) match MyHashtbl.find_opt t k with | Some d -> d - | None -> (*print_string "+";*) - let d = hp.set_hid k.hdata (MyHashtbl.length t) in - MyHashtbl.add t {k with hdata = d } d; d); + | None -> + (* DEBUG: Printf.printf "*in %d -- new hid:%d" (Obj.magic t) (MyHashtbl.length t); print_newline(); *) + let d = hp.set_hid k.hdata (MyHashtbl.length t) in + MyHashtbl.add t {k with hdata = d } d; d); next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); next_hid = (fun () -> MyHashtbl.length t); remove = (fun (x:a hashinfo) -> MyHashtbl.remove t x); diff --git a/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/lib/Impure/ocaml/ImpHConsOracles.mli index 5075d176..5075d176 100644 --- a/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ b/lib/Impure/ocaml/ImpHConsOracles.mli diff --git a/kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml b/lib/Impure/ocaml/ImpIOOracles.ml index 9e63c12d..9e63c12d 100644 --- a/kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml +++ b/lib/Impure/ocaml/ImpIOOracles.ml diff --git a/kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli b/lib/Impure/ocaml/ImpIOOracles.mli index 6064286a..6064286a 100644 --- a/kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli +++ b/lib/Impure/ocaml/ImpIOOracles.mli diff --git a/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml b/lib/Impure/ocaml/ImpLoopOracles.ml index cb7625e5..cb7625e5 100644 --- a/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml +++ b/lib/Impure/ocaml/ImpLoopOracles.ml diff --git a/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli b/lib/Impure/ocaml/ImpLoopOracles.mli index 194696a1..194696a1 100644 --- a/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli +++ b/lib/Impure/ocaml/ImpLoopOracles.mli diff --git a/lib/IterList.v b/lib/IterList.v new file mode 100644 index 00000000..bde47068 --- /dev/null +++ b/lib/IterList.v @@ -0,0 +1,111 @@ +Require Import Coqlib. + +(** TODO: are these def and lemma already defined in the standard library ? + +In this case, it should be better to reuse those of the standard library ! + +*) + +Fixpoint iter {A} (n:nat) (f: A -> A) (x: A) {struct n}: A := + match n with + | O => x + | S n0 => iter n0 f (f x) + end. + +Lemma iter_S A (n:nat) (f: A -> A): forall x, iter (S n) f x = f (iter n f x). +Proof. + induction n; simpl; auto. + intros; erewrite <- IHn; simpl; auto. +Qed. + +Lemma iter_plus A (n m:nat) (f: A -> A): forall x, iter (n+m) f x = iter m f (iter n f x). +Proof. + induction n; simpl; auto. +Qed. + +Definition iter_tail {A} (n:nat) (l: list A) := iter n (@tl A) l. + +Lemma iter_tail_S {A} (n:nat) (l: list A): iter_tail (S n) l = tl (iter_tail n l). +Proof. + apply iter_S. +Qed. + +Lemma iter_tail_plus A (n m:nat) (l: list A): iter_tail (n+m) l = iter_tail m (iter_tail n l). +Proof. + apply iter_plus. +Qed. + +Lemma iter_tail_length A l1: forall (l2: list A), iter_tail (length l1) (l1 ++ l2) = l2. +Proof. + induction l1; auto. +Qed. + +Lemma iter_tail_nil A n: @iter_tail A n nil = nil. +Proof. + unfold iter_tail; induction n; simpl; auto. +Qed. + +Lemma iter_tail_reach_nil A (l: list A): iter_tail (length l) l = nil. +Proof. + rewrite (app_nil_end l) at 2. + rewrite iter_tail_length. + auto. +Qed. + +Lemma length_iter_tail {A} (n:nat): forall (l: list A), (n <= List.length l)%nat -> (List.length l = n + List.length (iter_tail n l))%nat. +Proof. + unfold iter_tail; induction n; auto. + intros l; destruct l. { simpl; omega. } + intros; simpl. erewrite IHn; eauto. + simpl in *; omega. +Qed. + +Lemma iter_tail_S_ex {A} (n:nat): forall (l: list A), (n < length l)%nat -> exists x, iter_tail n l = x::(iter_tail (S n) l). +Proof. + unfold iter_tail; induction n; simpl. + - intros l; destruct l; simpl; omega || eauto. + - intros l H; destruct (IHn (tl l)) as (x & H1). + + destruct l; simpl in *; try omega. + + rewrite H1; eauto. +Qed. + +Lemma iter_tail_inject1 {A} (n1 n2:nat) (l: list A): (n1 <= List.length l)%nat -> (n2 <= List.length l)%nat -> iter_tail n1 l = iter_tail n2 l -> n1=n2. +Proof. + intros H1 H2 EQ; exploit (length_iter_tail n1 l); eauto. + rewrite EQ. + rewrite (length_iter_tail n2 l); eauto. + omega. +Qed. + +Lemma iter_tail_nil_inject {A} (n:nat) (l: list A): iter_tail n l = nil -> (List.length l <= n)%nat. +Proof. + destruct (le_lt_dec n (List.length l)); try omega. + intros; exploit (iter_tail_inject1 n (length l) l); try omega. + rewrite iter_tail_reach_nil. auto. +Qed. + +Lemma list_length_z_nat (A: Type) (l: list A): list_length_z l = Z.of_nat (length l). +Proof. + induction l; auto. + rewrite list_length_z_cons. simpl. rewrite Zpos_P_of_succ_nat. omega. +Qed. + +Lemma list_length_nat_z (A: Type) (l: list A): length l = Z.to_nat (list_length_z l). +Proof. + intros; rewrite list_length_z_nat, Nat2Z.id. auto. +Qed. + +Lemma is_tail_list_nth_z A (l1 l2: list A): + is_tail l1 l2 -> list_nth_z l2 ((list_length_z l2) - (list_length_z l1)) = list_nth_z l1 0. +Proof. + induction 1; simpl. + - replace (list_length_z c - list_length_z c) with 0; omega || auto. + - assert (X: list_length_z (i :: c2) > list_length_z c1). + { rewrite !list_length_z_nat, <- Nat2Z.inj_gt. + exploit is_tail_bound; simpl; eauto. + omega. } + destruct (zeq (list_length_z (i :: c2) - list_length_z c1) 0) as [Y|Y]; try omega. + replace (Z.pred (list_length_z (i :: c2) - list_length_z c1)) with (list_length_z c2 - list_length_z c1); auto. + rewrite list_length_z_cons. + omega. +Qed. diff --git a/lib/OptionMonad.v b/lib/OptionMonad.v new file mode 100644 index 00000000..824a9c2f --- /dev/null +++ b/lib/OptionMonad.v @@ -0,0 +1,49 @@ +(* Declare Scope option_monad_scope. *) + +Notation "'SOME' X <- A 'IN' B" := (match A with Some X => B | None => None end) + (at level 200, X ident, A at level 100, B at level 200) + : option_monad_scope. + +Notation "'ASSERT' A 'IN' B" := (if A then B else None) + (at level 200, A at level 100, B at level 200) + : option_monad_scope. + +Local Open Scope option_monad_scope. + + +(** Simple tactics for option-monad *) + +Lemma destruct_SOME A B (P: option B -> Prop) (e: option A) (f: A -> option B): + (forall x, e = Some x -> P (f x)) -> (e = None -> P None) -> (P (SOME x <- e IN f x)). +Proof. + intros; destruct e; simpl; auto. +Qed. + +Lemma destruct_ASSERT B (P: option B -> Prop) (e: bool) (x: option B): + (e = true -> P x) -> (e = false -> P None) -> (P (ASSERT e IN x)). +Proof. + intros; destruct e; simpl; auto. +Qed. + +Ltac inversion_SOME x := + try (eapply destruct_SOME; [ let x := fresh x in intro x | simpl; try congruence ]). + +Ltac inversion_ASSERT := + try (eapply destruct_ASSERT; [ idtac | simpl; try congruence ]). + +Ltac simplify_someHyp := + match goal with + | H: None = Some _ |- _ => inversion H; clear H; subst + | H: Some _ = None |- _ => inversion H; clear H; subst + | H: ?t = ?t |- _ => clear H + | H: Some _ = Some _ |- _ => inversion H; clear H; subst + | H: Some _ <> None |- _ => clear H + | H: None <> Some _ |- _ => clear H + | H: _ = Some _ |- _ => (try rewrite !H in * |- *); generalize H; clear H + end. + +Ltac simplify_someHyps := + repeat (simplify_someHyp; simpl in * |- *). + +Ltac try_simplify_someHyps := + try (intros; simplify_someHyps; eauto). diff --git a/lib/Readconfig.mll b/lib/Readconfig.mll index 7b98255e..8abcc407 100644 --- a/lib/Readconfig.mll +++ b/lib/Readconfig.mll @@ -20,7 +20,7 @@ let key_val_tbl : (string, string list) Hashtbl.t = Hashtbl.create 17 let key_val key = - try Some(Hashtbl.find key_val_tbl key) with Not_found -> None + Hashtbl.find_opt key_val_tbl key (* Auxiliaries for parsing *) diff --git a/lib/Zbits.v b/lib/Zbits.v index 27586aff..6f3acaab 100644 --- a/lib/Zbits.v +++ b/lib/Zbits.v @@ -266,7 +266,7 @@ Qed. Remark Ztestbit_shiftin_base: forall b x, Z.testbit (Zshiftin b x) 0 = b. Proof. - intros. rewrite Ztestbit_shiftin. apply zeq_true. omega. + intros. rewrite Ztestbit_shiftin; reflexivity. Qed. Remark Ztestbit_shiftin_succ: @@ -316,7 +316,7 @@ Qed. Remark Ztestbit_base: forall x, Z.testbit x 0 = Z.odd x. Proof. - intros. rewrite Ztestbit_eq. apply zeq_true. omega. + intros. rewrite Ztestbit_eq; reflexivity. Qed. Remark Ztestbit_succ: diff --git a/midend/ValueDomainSSA.v b/midend/ValueDomainSSA.v index 181e070d..6ef69210 100644 --- a/midend/ValueDomainSSA.v +++ b/midend/ValueDomainSSA.v @@ -2483,6 +2483,468 @@ Proof. destruct 1; simpl; auto with va. Qed. + +(* Extensions for KVX and Risc-V *) + +Definition intoffloat_total (x: aval) := + match x with + | F f => + match Float.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longoffloat_total (x: aval) := + match x with + | F f => + match Float.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Lemma intoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intoffloat v)) (intoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma intuoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intuoffloat v)) (intuoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma intofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intofsingle v)) (intofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma intuofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.intuofsingle v)) (intuofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma singleofint_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleofint v)) (singleofint x). +Proof. + unfold Val.singleofint, singleofint; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma singleofintu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleofintu v)) (singleofintu x). +Proof. + unfold Val.singleofintu, singleofintu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma longoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longoffloat v)) (longoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma longuoffloat_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longuoffloat v)) (longuoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma longofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longofsingle v)) (longofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma longuofsingle_total_sound: + forall v x + (MATCH : vmatch v x), + vmatch (Val.maketotal (Val.longuofsingle v)) (longuofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. +Qed. + +Lemma singleoflong_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleoflong v)) (singleoflong x). +Proof. + unfold Val.singleoflong, singleoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma singleoflongu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.singleoflongu v)) (singleoflongu x). +Proof. + unfold Val.singleoflongu, singleoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatoflong_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatoflong v)) (floatoflong x). +Proof. + unfold Val.floatoflong, floatoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatoflongu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatoflongu v)) (floatoflongu x). +Proof. + unfold Val.floatoflongu, floatoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatofint_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatofint v)) (floatofint x). +Proof. + unfold Val.floatofint, floatofint; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Lemma floatofintu_total_sound: + forall v x, vmatch v x -> + vmatch (Val.maketotal (Val.floatofintu v)) (floatofintu x). +Proof. + unfold Val.floatofintu, floatofintu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + + +Definition divs_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + || Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone + then ntop + else I (Int.divs i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divs_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divs v w)) (divs_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct (_ || _) eqn:E; cbn; unfold ntop; auto with va. + } + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2; cbn; auto with va. +Qed. + +Definition divu_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + then ntop + else I (Int.divu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divu v w)) (divu_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct Int.eq eqn:E; cbn; unfold ntop; auto with va. + } + all: unfold ntop2; auto with va. + all: destruct Int.eq eqn:E; unfold ntop2; cbn; auto with va. +Qed. + +Definition mods_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + || Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone + then ntop + else I (Int.mods i1 i2) + | _, _ => ntop2 v w + end. + +Lemma mods_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.mods v w)) (mods_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct (_ || _) eqn:E; cbn; unfold ntop; auto with va. + } + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2; cbn; auto with va. +Qed. + +Definition modu_total (v w: aval) := + match w, v with + | I i2, I i1 => + if Int.eq i2 Int.zero + then ntop + else I (Int.modu i1 i2) + | I i2, _ => uns (provenance v) (usize i2) + | _, _ => ntop2 v w + end. + +Lemma modu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.modu v w)) (modu_total x y). +Proof. + assert (UNS: forall i j, j <> Int.zero -> is_uns (usize j) (Int.modu i j)). + { + intros. apply is_uns_mon with (usize (Int.modu i j)). + { apply is_uns_usize. + } + unfold usize, Int.size. + apply Zsize_monotone. + generalize (Int.unsigned_range_2 j); intros RANGE. + assert (Int.unsigned j <> 0). + { red; intros; elim H. rewrite <- (Int.repr_unsigned j). rewrite H0. auto. } + exploit (Z_mod_lt (Int.unsigned i) (Int.unsigned j)). omega. intros MOD. + unfold Int.modu. rewrite Int.unsigned_repr. omega. omega. + } + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + { destruct Int.eq eqn:E; unfold ntop; cbn; auto with va. + } + all: try discriminate. + all: unfold ntop2; auto with va. + all: try (destruct Int.eq eqn:E; cbn; unfold ntop2; auto with va; fail). + all: try apply vmatch_uns_undef. + + all: + generalize (Int.eq_spec i0 Int.zero); + destruct (Int.eq i0 Int.zero); + cbn; + intro. + all: try apply vmatch_uns_undef. + all: apply vmatch_uns; auto. +Qed. + + +Lemma shrx_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.shrx v w)) (shrx x y). +Proof. + intros until y. intros HX HY. + inv HX; inv HY; cbn. + all: unfold ntop1; auto with va. + all: destruct Int.ltu eqn:LTU; cbn; unfold ntop; auto with va. +Qed. + + +Definition divls_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + || Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone + then ntop + else L (Int64.divs i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divls_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divls v w)) (divls_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2, ntop; cbn; auto with va. +Qed. + +Definition divlu_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + then ntop + else L (Int64.divu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma divlu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.divlu v w)) (divlu_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct Int64.eq eqn:E; unfold ntop2, ntop; cbn; auto with va. +Qed. + + +Definition modls_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + || Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone + then ntop + else L (Int64.mods i1 i2) + | _, _ => ntop2 v w + end. + +Lemma modls_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.modls v w)) (modls_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct (_ || _) eqn:E; unfold ntop2, ntop; cbn; auto with va. +Qed. + + +Definition modlu_total (v w: aval) := + match w, v with + | L i2, L i1 => + if Int64.eq i2 Int64.zero + then ntop + else L (Int64.modu i1 i2) + | _, _ => ntop2 v w + end. + +Lemma modlu_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.modlu v w)) (modlu_total x y). +Proof. + intros until y. + intros HX HY. + inv HX; inv HY; cbn in *. + all: unfold ntop2; auto with va. + all: destruct Int64.eq eqn:E; cbn; unfold ntop2, ntop; auto with va. +Qed. + +Lemma shrxl_total_sound: + forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.maketotal (Val.shrxl v w)) (shrxl x y). +Proof. + intros until y. intros HX HY. + inv HX; inv HY; cbn. + all: unfold ntop1; auto with va. + all: destruct Int.ltu eqn:LTU; cbn; unfold ntop; auto with va. +Qed. + (** Comparisons and variation intervals *) Definition cmp_intv (c: comparison) (i: Z * Z) (n: Z) : abool := @@ -4739,6 +5201,26 @@ Hint Resolve cnot_sound symbol_address_sound longoffloat_sound longuoffloat_sound floatoflong_sound floatoflongu_sound longofsingle_sound longuofsingle_sound singleoflong_sound singleoflongu_sound longofwords_sound loword_sound hiword_sound + intoffloat_total_sound + intuoffloat_total_sound + intofsingle_total_sound + intuofsingle_total_sound + singleofint_total_sound + singleofintu_total_sound + longoffloat_total_sound + longuoffloat_total_sound + longofsingle_total_sound + longuofsingle_total_sound + singleoflong_total_sound + singleoflongu_total_sound + floatoflong_total_sound + floatoflongu_total_sound + floatofint_total_sound + floatofintu_total_sound + divu_total_sound divs_total_sound + modu_total_sound mods_total_sound shrx_total_sound + divlu_total_sound divls_total_sound + modlu_total_sound modls_total_sound shrxl_total_sound cmpu_bool_sound cmp_bool_sound cmplu_bool_sound cmpl_bool_sound cmpf_bool_sound cmpfs_bool_sound maskzero_sound : va. diff --git a/powerpc/Archi.v b/powerpc/Archi.v index 8f96dafc..5b9d67cc 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -16,9 +16,8 @@ (** Architecture-dependent parameters for PowerPC *) +From Flocq Require Import Binary Bits. Require Import ZArith List. -(*From Flocq*) -Require Import Binary Bits. Definition ptr64 := false. diff --git a/powerpc/Asm.v b/powerpc/Asm.v index 4fb38ff8..d9901960 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -200,12 +200,9 @@ Inductive instruction : Type := | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) | Pfadds: freg -> freg -> freg -> instruction (**r float addition *) | Pfcmpu: freg -> freg -> instruction (**r float comparison *) - | Pfcfi: freg -> ireg -> instruction (**r signed-int-to-float conversion (pseudo, PPC64) *) | Pfcfl: freg -> ireg -> instruction (**r signed-long-to-float conversion (pseudo, PPC64) *) - | Pfcfiu: freg -> ireg -> instruction (**r unsigned-int-to-float conversion (pseudo, PPC64) *) | Pfcfid: freg -> freg -> instruction (**r signed-long-to-float conversion (PPC64) *) | Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion, round towards 0 (pseudo) *) - | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion, round towards 0 (pseudo, PPC64) *) | Pfctid: ireg -> freg -> instruction (**r float-to-signed-int conversion, round towards 0 (pseudo, PPC64) *) | Pfctidz: freg -> freg -> instruction (**r float-to-signed-long conversion, round towards 0 (PPC64) *) | Pfctiw: freg -> freg -> instruction (**r float-to-signed-int conversion, round by default *) @@ -825,16 +822,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#rd <- (Val.addfs rs#r1 rs#r2))) m | Pfcmpu r1 r2 => Next (nextinstr (compare_float rs rs#r1 rs#r2)) m - | Pfcfi rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m | Pfcfl rd r1 => Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m - | Pfcfiu rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofintu rs#r1)))) m | Pfcti rd r1 => Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m - | Pfctiu rd r1 => - Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.intuoffloat rs#r1)))) m | Pfctid rd r1 => Next (nextinstr (rs#FPR13 <- Vundef #rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m | Pfdiv rd r1 r2 => @@ -1204,7 +1195,7 @@ Inductive step: state -> trace -> state -> Prop := external_call ef ge vargs m t vres m' -> rs' = nextinstr (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> + (undef_regs (IR GPR0 :: map preg_of (destroyed_by_builtin ef)) rs)) -> step (State rs m) t (State rs' m') | exec_step_external: forall b ef args res rs m t rs' m', diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index 38f4bc75..1f32dd62 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -198,12 +198,9 @@ let pp_instructions pp ic = | Pfadd (fr1,fr2,fr3) -> instruction pp "Pfadd" [Freg fr1; Freg fr2; Freg fr3] | Pfadds (fr1,fr2,fr3) -> instruction pp "Pfadds" [Freg fr1; Freg fr2; Freg fr3] | Pfcmpu (fr1,fr2) -> instruction pp "Pfcmpu" [Freg fr1; Freg fr2] - | Pfcfi (ir,fr) | Pfcfl (ir,fr) -> assert false (* Should not occur *) | Pfcfid (fr1,fr2) -> instruction pp "Pfcfid" [Freg fr1; Freg fr2] - | Pfcfiu _ (* Should not occur *) | Pfcti _ (* Should not occur *) - | Pfctiu _ (* Should not occur *) | Pfctid _ -> assert false (* Should not occur *) | Pfctidz (fr1,fr2) -> instruction pp "Pfctidz" [Freg fr1; Freg fr2] | Pfctiw (fr1,fr2) -> instruction pp "Pfctiw" [Freg fr1; Freg fr2] diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index ce88778c..cb6a659f 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -594,9 +594,7 @@ let expand_builtin_inline name args res = emit (Pfnmadd(res, a1, a2, a3)) | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfnmsub(res, a1, a2, a3)) - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> - emit (Pfabs(res, a1)) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + | ("__builtin_fsqrt" | "__builtin_sqrt"), [BA(FR a1)], BR(FR res) -> emit (Pfsqrt(res, a1)) | "__builtin_frsqrte", [BA(FR a1)], BR(FR res) -> emit (Pfrsqrte(res, a1)) @@ -767,6 +765,8 @@ let expand_builtin_inline name args res = emit (Pori (GPR0, GPR0, Cint _0)) (* atomic operations *) | "__builtin_atomic_exchange", [BA (IR a1); BA (IR a2); BA (IR a3)],_ -> + (* Register constraints imposed by Machregs.v *) + assert(a1 = GPR3 && a2 = GPR4 && a3 = GPR5); emit (Plwz (GPR10,Cint _0,a2)); emit (Psync); let lbl = new_label() in @@ -786,6 +786,8 @@ let expand_builtin_inline name args res = emit (Pisync); emit (Pstw (GPR0,Cint _0, a2)) | "__builtin_sync_fetch_and_add", [BA (IR a1); BA(IR a2)], BR (IR res) -> + (* Register constraints imposed by Machregs.v *) + assert (a1 = GPR4 && a2 = GPR5 && res = GPR3); let lbl = new_label() in emit (Psync); emit (Plabel lbl); @@ -795,6 +797,8 @@ let expand_builtin_inline name args res = emit (Pbf (CRbit_2, lbl)); emit (Pisync); | "__builtin_atomic_compare_exchange", [BA (IR dst); BA(IR exp); BA (IR des)], BR (IR res) -> + (* Register constraints imposed by Machregs.v *) + assert (dst = GPR4 && exp = GPR5 && des = GPR6 && res = GPR3); let lbls = new_label () and lblneq = new_label () and lblsucc = new_label () in @@ -871,15 +875,6 @@ let expand_instruction instr = emit (Paddi(GPR1, GPR1, Cint(coqint_of_camlint sz))) else emit (Plwz(GPR1, Cint ofs, GPR1)) - | Pfcfi(r1, r2) -> - assert (Archi.ppc64); - emit (Pextsw(GPR0, r2)); - emit (Pstdu(GPR0, Cint _m8, GPR1)); - emit (Pcfi_adjust _8); - emit (Plfd(r1, Cint _0, GPR1)); - emit (Pfcfid(r1, r1)); - emit (Paddi(GPR1, GPR1, Cint _8)); - emit (Pcfi_adjust _m8) | Pfcfl(r1, r2) -> assert (Archi.ppc64); emit (Pstdu(r2, Cint _m8, GPR1)); @@ -888,15 +883,6 @@ let expand_instruction instr = emit (Pfcfid(r1, r1)); emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) - | Pfcfiu(r1, r2) -> - assert (Archi.ppc64); - emit (Prldicl(GPR0, r2, _0, _32)); - emit (Pstdu(GPR0, Cint _m8, GPR1)); - emit (Pcfi_adjust _8); - emit (Plfd(r1, Cint _0, GPR1)); - emit (Pfcfid(r1, r1)); - emit (Paddi(GPR1, GPR1, Cint _8)); - emit (Pcfi_adjust _m8) | Pfcti(r1, r2) -> emit (Pfctiwz(FPR13, r2)); emit (Pstfdu(FPR13, Cint _m8, GPR1)); @@ -904,14 +890,6 @@ let expand_instruction instr = emit (Plwz(r1, Cint _4, GPR1)); emit (Paddi(GPR1, GPR1, Cint _8)); emit (Pcfi_adjust _m8) - | Pfctiu(r1, r2) -> - assert (Archi.ppc64); - emit (Pfctidz(FPR13, r2)); - emit (Pstfdu(FPR13, Cint _m8, GPR1)); - emit (Pcfi_adjust _8); - emit (Plwz(r1, Cint _4, GPR1)); - emit (Paddi(GPR1, GPR1, Cint _8)); - emit (Pcfi_adjust _m8) | Pfctid(r1, r2) -> assert (Archi.ppc64); emit (Pfctidz(FPR13, r2)); diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 29e2c028..d0c44f08 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -611,15 +611,6 @@ Definition transl_op | Ointoffloat, a1 :: nil => do r1 <- freg_of a1; do r <- ireg_of res; OK (Pfcti r r1 :: k) - | Ointuoffloat, a1 :: nil => - do r1 <- freg_of a1; do r <- ireg_of res; - OK (Pfctiu r r1 :: k) - | Ofloatofint, a1 :: nil => - do r1 <- ireg_of a1; do r <- freg_of res; - OK (Pfcfi r r1 :: k) - | Ofloatofintu, a1 :: nil => - do r1 <- ireg_of a1; do r <- freg_of res; - OK (Pfcfiu r r1 :: k) | Ofloatofwords, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- freg_of res; OK (Pfmake r r1 r2 :: k) diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 21d5ce48..93589a31 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -789,16 +789,18 @@ Opaque loadind. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). unfold nextinstr. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. + rewrite set_res_other. simpl. rewrite undef_regs_other_2. + rewrite Pregmap.gso by auto with asmgen. rewrite <- H1. simpl. econstructor; eauto. eapply code_tail_next_int; eauto. rewrite preg_notin_charact. intros. auto with asmgen. auto with asmgen. apply agree_nextinstr. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. + eapply agree_undef_regs; eauto. + intros. simpl. rewrite undef_regs_other_2; auto. apply Pregmap.gso. auto with asmgen. congruence. intros. Simpl. rewrite set_res_other by auto. - rewrite undef_regs_other_2; auto with asmgen. + simpl. rewrite undef_regs_other_2; auto with asmgen. - (* Mgoto *) assert (f0 = f) by congruence. subst f0. diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 1b797999..850e95c7 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -1500,18 +1500,6 @@ Opaque Val.add. - replace v with (Val.maketotal (Val.intoffloat (rs x))). TranslOpSimpl. rewrite H1; auto. - (* Ointuoffloat *) -- replace v with (Val.maketotal (Val.intuoffloat (rs x))). - TranslOpSimpl. - rewrite H1; auto. - (* Ofloatofint *) -- replace v with (Val.maketotal (Val.floatofint (rs x))). - TranslOpSimpl. - rewrite H1; auto. - (* Ofloatofintu *) -- replace v with (Val.maketotal (Val.floatofintu (rs x))). - TranslOpSimpl. - rewrite H1; auto. (* Ocmp *) - destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto. exists rs'; auto with asmgen. diff --git a/powerpc/Builtins1.v b/powerpc/Builtins1.v index 53c83d7e..9d7aadd9 100644 --- a/powerpc/Builtins1.v +++ b/powerpc/Builtins1.v @@ -19,15 +19,55 @@ Require Import String Coqlib. Require Import AST Integers Floats Values. Require Import Builtins0. -Inductive platform_builtin : Type := . +Inductive platform_builtin : Type := + | BI_isel + | BI_uisel + | BI_isel64 + | BI_uisel64 + | BI_bsel + | BI_mulhw + | BI_mulhwu + | BI_mulhd + | BI_mulhdu. Local Open Scope string_scope. Definition platform_builtin_table : list (string * platform_builtin) := - nil. + ("__builtin_isel", BI_isel) + :: ("__builtin_uisel", BI_uisel) + :: ("__builtin_isel64", BI_isel64) + :: ("__builtin_uisel64", BI_uisel64) + :: ("__builtin_bsel", BI_bsel) + :: ("__builtin_mulhw", BI_mulhw) + :: ("__builtin_mulhwu", BI_mulhwu) + :: ("__builtin_mulhd", BI_mulhd) + :: ("__builtin_mulhdu", BI_mulhdu) + :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := - match b with end. + match b with + | BI_isel | BI_uisel | BI_bsel => + mksignature (Tint :: Tint :: Tint :: nil) Tint cc_default + | BI_isel64 | BI_uisel64 => + mksignature (Tint :: Tlong :: Tlong :: nil) Tlong cc_default + | BI_mulhw | BI_mulhwu => + mksignature (Tint :: Tint :: nil) Tint cc_default + | BI_mulhd | BI_mulhdu => + mksignature (Tlong :: Tlong :: nil) Tlong cc_default + end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := - match b with end. + match b with + | BI_isel | BI_uisel | BI_bsel => + mkbuiltin_n3t Tint Tint Tint Tint (fun c n1 n2 => if Int.eq c Int.zero then n2 else n1) + | BI_isel64 | BI_uisel64 => + mkbuiltin_n3t Tint Tlong Tlong Tlong (fun c n1 n2 => if Int.eq c Int.zero then n2 else n1) + | BI_mulhw => + mkbuiltin_n2t Tint Tint Tint Int.mulhs + | BI_mulhwu => + mkbuiltin_n2t Tint Tint Tint Int.mulhu + | BI_mulhd => + mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhs + | BI_mulhdu => + mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhu + end. diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml index e29a41f1..e0826877 100644 --- a/powerpc/CBuiltins.ml +++ b/powerpc/CBuiltins.ml @@ -28,18 +28,6 @@ let builtins = { (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); "__builtin_mulhwu", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); - "__builtin_clz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_clzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_clzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); - "__builtin_ctz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_ctzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_ctzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); "__builtin_cmpb", (TInt (IUInt, []), [TInt(IUInt, []);TInt(IUInt, [])], false); (* Integer arithmetic in 32/64-bit hybrid mode *) diff --git a/powerpc/CSE2deps.v b/powerpc/CSE2deps.v index d48dabf3..4592f408 100644 --- a/powerpc/CSE2deps.v +++ b/powerpc/CSE2deps.v @@ -28,5 +28,8 @@ Definition may_overlap chunk addr args chunk' addr' args' := (base :: nil), (base' :: nil) => if peq base base' then negb (can_swap_accesses_ofs (Int.unsigned ofs') chunk' (Int.unsigned ofs) chunk) - else true | _, _, _, _ => true + else true + | (Ainstack ofs), (Ainstack ofs'), _, _ => + negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + | _, _, _, _ => true end. diff --git a/powerpc/CSE2depsproof.v b/powerpc/CSE2depsproof.v index 123341da..ede09dd6 100644 --- a/powerpc/CSE2depsproof.v +++ b/powerpc/CSE2depsproof.v @@ -111,6 +111,66 @@ Section MEMORY_WRITE. Qed. End INDEXED_AWAY. End MEMORY_WRITE. + +Section STACK_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Ainstack ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Ainstack ofsr) nil = Some addrr. + + Lemma stack_load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + inv ADDRR. + inv ADDRW. + + destruct sp; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + all: try rewrite ptrofs_modulus in *. + all: destruct Archi.ptr64. + + all: intuition lia. + Qed. + + Theorem stack_load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply stack_load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End STACK_WRITE. End SOUNDNESS. @@ -131,7 +191,7 @@ Proof. intros until rs. intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) +- (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. destruct args' as [ | base' [ | ]]. 1,3: discriminate. simpl in OVERLAP. @@ -141,7 +201,14 @@ Proof. 2: discriminate. simpl in *. eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. - } +- (* Ainstack / Ainstack *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + cbn in OVERLAP. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply stack_load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. Qed. End SOUNDNESS. diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v index e7c8758b..9967bbae 100644 --- a/powerpc/Machregs.v +++ b/powerpc/Machregs.v @@ -166,7 +166,7 @@ Definition destroyed_by_op (op: operation): list mreg := | Ofloatconst _ => R12 :: nil | Osingleconst _ => R12 :: nil | Olongconst _ => R12 :: nil - | Ointoffloat | Ointuoffloat => F13 :: nil + | Ointoffloat => F13 :: nil | Olongoffloat => F13 :: nil | Oaddlimm _ => R12 :: nil | Oandlimm _ => R12 :: nil @@ -232,7 +232,7 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list | EF_builtin id sg => if string_dec id "__builtin_atomic_exchange" then ((Some R3)::(Some R4)::(Some R5)::nil,nil) else if string_dec id "__builtin_sync_fetch_and_add" then ((Some R4)::(Some R5)::nil,(Some R3)::nil) - else if string_dec id "___builtin_atomic_compare_exchange" then ((Some R4)::(Some R5)::(Some R6)::nil, (Some R3):: nil) + else if string_dec id "__builtin_atomic_compare_exchange" then ((Some R4)::(Some R5)::(Some R6)::nil, (Some R3):: nil) else (nil, nil) | _ => (nil, nil) end. diff --git a/powerpc/Machregsaux.ml b/powerpc/Machregsaux.ml index 0b0d4548..d17382ad 100644 --- a/powerpc/Machregsaux.ml +++ b/powerpc/Machregsaux.ml @@ -12,27 +12,7 @@ (** Auxiliary functions on machine registers *) -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - let is_scratch_register s = s = "R0" || s = "r0" - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = - List.mem r Conventions1.int_callee_save_regs - || List.mem r Conventions1.float_callee_save_regs let class_of_type = function | AST.Tint | AST.Tlong -> 0 diff --git a/powerpc/Machregsaux.mli b/powerpc/Machregsaux.mli index d7117c21..01b0f9fd 100644 --- a/powerpc/Machregsaux.mli +++ b/powerpc/Machregsaux.mli @@ -12,9 +12,6 @@ (** Auxiliary functions on machine registers *) -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool val class_of_type: AST.typ -> int diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v index 5ea09bd8..74ee6b85 100644 --- a/powerpc/NeedOp.v +++ b/powerpc/NeedOp.v @@ -61,7 +61,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) | Osingleoffloat | Ofloatofsingle => op1 (default nv) - | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv) + | Ointoffloat => op1 (default nv) | Ofloatofwords | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocmp c => needs_of_condition c diff --git a/powerpc/Op.v b/powerpc/Op.v index a0ee5bb8..684b90bf 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -105,7 +105,7 @@ Inductive operation : Type := | Osubl: operation (**r [rd = r1 - r2] *) | Onegl: operation (**r [rd = - r1] *) | Omull: operation (**r [rd = r1 * r2] *) - | Omullhs: operation (**r [rd = high part of r1 * r2, signed] *) + | Omullhs: operation (**r [rd = high part of r1 * r2, signed] *) | Omullhu: operation (**r [rd = high part of r1 * r2, unsigned] *) | Odivl: operation (**r [rd = r1 / r2] (signed) *) | Odivlu: operation (**r [rd = r1 / r2] (unsigned) *) @@ -141,9 +141,6 @@ Inductive operation : Type := | Ofloatofsingle: operation (**r [rd] is [r1] extended to double-precision float *) (*c Conversions between int and float: *) | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *) - | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] (PPC64 only) *) - | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] (PPC64 only) *) - | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] (PPC64 only *) | Ofloatofwords: operation (**r [rd = float_of_words(r1,r2)] *) (*c Manipulating 64-bit integers: *) | Omakelong: operation (**r [rd = r1 << 32 | r2] *) @@ -299,9 +296,6 @@ Definition eval_operation | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 | Ofloatofwords, v1::v2::nil => Some(Val.floatofwords v1 v2) | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) | Olowlong, v1::nil => Some(Val.loword v1) @@ -449,9 +443,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) - | Ointuoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ofloatofintu => (Tint :: nil, Tfloat) | Ofloatofwords => (Tint :: Tint :: nil, Tfloat) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -570,9 +561,6 @@ Proof with (try exact I; try reflexivity). destruct v0... destruct v0... destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; simpl in H0; inv H0... destruct v0; destruct v1... destruct v0; destruct v1... destruct v0... @@ -585,8 +573,7 @@ Definition is_trapping_op (op : operation) := match op with | Odiv | Odivl | Odivu | Odivlu | Oshrximm _ | Oshrxlimm _ - | Ointoffloat | Ointuoffloat - | Ofloatofint | Ofloatofintu + | Ointoffloat | Olongoffloat | Ofloatoflong => true | _ => false @@ -797,6 +784,20 @@ Proof. auto. Qed. +Lemma op_valid_pointer_eq: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op eqn:OP; simpl; try congruence. + - intros MEM; destruct c; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intro MEM; destruct c; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. +Qed. + (** Global variables mentioned in an operation or addressing mode *) Definition globals_operation (op: operation) : list ident := @@ -1029,10 +1030,6 @@ Proof. inv H4; simpl; auto. inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. - inv H4; simpl in H1; inv H1; simpl. TrivialExists. - inv H4; simpl in H1; inv H1; simpl. TrivialExists. inv H4; inv H2; simpl; auto. inv H4; inv H2; simpl; auto. inv H4; simpl; auto. diff --git a/powerpc/PrepassSchedulingOracle.ml b/powerpc/PrepassSchedulingOracle.ml new file mode 120000 index 00000000..9885fd52 --- /dev/null +++ b/powerpc/PrepassSchedulingOracle.ml @@ -0,0 +1 @@ +../x86/PrepassSchedulingOracle.ml
\ No newline at end of file diff --git a/powerpc/PrintOp.ml b/powerpc/PrintOp.ml index 8d7f17ab..77791827 100644 --- a/powerpc/PrintOp.ml +++ b/powerpc/PrintOp.ml @@ -42,6 +42,14 @@ let print_condition reg pp = function 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) + | (Ccompl c, [r1;r2]) -> + fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 + | (Ccomplu c, [r1;r2]) -> + fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 + | (Ccomplimm(c, n), [r1]) -> + fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Ccompluimm(c, n), [r1]) -> + fprintf pp "%a %slu %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) | _ -> fprintf pp "<bad condition>" diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index 52f4f855..fe8b5453 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -468,7 +468,7 @@ Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). Definition intuoffloat (e: expr) := if Archi.ppc64 then - Eop Ointuoffloat (e ::: Enil) + Eop Olowlong (Eop Olongoffloat (e ::: Enil) ::: Enil) else Elet e (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) @@ -482,7 +482,8 @@ Nondetfunction floatofintu (e: expr) := Eop (Ofloatconst (Float.of_intu n)) Enil | _ => if Archi.ppc64 then - Eop Ofloatofintu (e ::: Enil) else + Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil) + else subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: e ::: Enil)) (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil) end. @@ -493,7 +494,8 @@ Nondetfunction floatofint (e: expr) := Eop (Ofloatconst (Float.of_int n)) Enil | _ => if Archi.ppc64 then - Eop Ofloatofint (e ::: Enil) else + Eop Ofloatoflong (Eop Ocast32signed (e ::: Enil) ::: Enil) + else subf (Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: addimm Float.ox8000_0000 e ::: Enil)) (Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil) diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index 8135bad6..ed81c83f 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -855,8 +855,13 @@ Proof. destruct (Float.to_intu f) as [n|] eqn:?; simpl in H0; inv H0. exists (Vint n); split; auto. unfold intuoffloat. destruct Archi.ppc64. - econstructor. constructor; eauto. constructor. simpl; rewrite Heqo; auto. - set (im := Int.repr Int.half_modulus). +- apply Float.to_intu_to_long in Heqo. + econstructor. constructor. econstructor. econstructor; eauto. constructor. + simpl; rewrite Heqo; simpl; eauto. constructor. + simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned. auto. + assert (Int.modulus < Int64.max_unsigned) by (compute; auto). + generalize (Int.unsigned_range n). omega. +- set (im := Int.repr Int.half_modulus). set (fm := Float.of_intu im). assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f)). constructor. auto. @@ -893,11 +898,12 @@ Theorem eval_floatofint: Proof. intros until y. unfold floatofint. destruct (floatofint_match a); intros. InvEval. TrivialExists. - destruct Archi.ppc64. - TrivialExists. rename e0 into a. destruct x; simpl in H0; inv H0. exists (Vfloat (Float.of_int i)); split; auto. - set (t1 := addimm Float.ox8000_0000 a). + destruct Archi.ppc64. +- rewrite Float.of_int_of_long. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. auto. +- set (t1 := addimm Float.ox8000_0000 a). set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: t1 ::: Enil)). set (t3 := Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Float.ox8000_0000)) Enil). exploit (eval_addimm Float.ox8000_0000 le a). eauto. fold t1. @@ -917,12 +923,12 @@ Theorem eval_floatofintu: Proof. intros until y. unfold floatofintu. destruct (floatofintu_match a); intros. InvEval. TrivialExists. - destruct Archi.ppc64. - TrivialExists. rename e0 into a. destruct x; simpl in H0; inv H0. exists (Vfloat (Float.of_intu i)); split; auto. - unfold floatofintu. - set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: a ::: Enil)). + destruct Archi.ppc64. +- rewrite Float.of_intu_of_long. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. auto. +- set (t2 := Eop Ofloatofwords (Eop (Ointconst Float.ox4330_0000) Enil ::: a ::: Enil)). set (t3 := Eop (Ofloatconst (Float.from_words Float.ox4330_0000 Int.zero)) Enil). exploit (eval_subf le t2). unfold t2. EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 3ea03786..554bfe09 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -557,22 +557,16 @@ module Target (System : SYSTEM):TARGET = fprintf oc " fadds %a, %a, %a\n" freg r1 freg r2 freg r3 | Pfcmpu(r1, r2) -> fprintf oc " fcmpu %a, %a, %a\n" creg 0 freg r1 freg r2 - | Pfcfi(r1, r2) -> - assert false | Pfcfl(r1, r2) -> assert false | Pfcfid(r1, r2) -> fprintf oc " fcfid %a, %a\n" freg r1 freg r2 - | Pfcfiu(r1, r2) -> - assert false | Pfcti(r1, r2) -> assert false | Pfctid(r1, r2) -> assert false | Pfctidz(r1, r2) -> fprintf oc " fctidz %a, %a\n" freg r1 freg r2 - | Pfctiu(r1, r2) -> - assert false | Pfctiw(r1, r2) -> fprintf oc " fctiw %a, %a\n" freg r1 freg r2 | Pfctiwz(r1, r2) -> diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v index a270d857..c81f1a6c 100644 --- a/powerpc/ValueAOp.v +++ b/powerpc/ValueAOp.v @@ -133,9 +133,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 - | Ointuoffloat, v1::nil => intuoffloat v1 - | Ofloatofint, v1::nil => floatofint v1 - | Ofloatofintu, v1::nil => floatofintu v1 | Ofloatofwords, v1::v2::nil => floatofwords v1 v2 | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 diff --git a/riscV/Archi.v b/riscV/Archi.v index 9bdaad99..1bb80e89 100644 --- a/riscV/Archi.v +++ b/riscV/Archi.v @@ -16,9 +16,8 @@ (** Architecture-dependent parameters for RISC-V *) +From Flocq Require Import Binary Bits. Require Import ZArith List. -(*From Flocq*) -Require Import Binary Bits. Parameter ptr64 : bool. diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 7e36abf8..810514a3 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -394,6 +394,90 @@ let expand_bswap64 d s = emit (Psrlil(X31, X s, coqint_of_camlint 56l)); emit (Porl(d, X X1, X X31)) +(* Count leading zeros. Algorithm 5-7 from Hacker's Delight, + re-rolled as a loop to produce more compact code. *) + +let expand_clz ~sixtyfour ~splitlong = + (* Input: X in X5 or (X5, X6) if splitlong + Result: N in X7 + Temporaries: S in X8, Y in X9 *) + let lbl1 = new_label() in + let lbl2 = new_label() in + (* N := bitsize of X's type (32 or 64) *) + expand_loadimm32 X7 (coqint_of_camlint + (if sixtyfour || splitlong then 64l else 32l)); + (* S := initial shift amount (16 or 32) *) + expand_loadimm32 X8 (coqint_of_camlint (if sixtyfour then 32l else 16l)); + if splitlong then begin + (* if (Xhigh == 0) goto lbl1 *) + emit (Pbeqw(X X6, X0, lbl1)); + (* N := 32 *) + expand_loadimm32 X7 (coqint_of_camlint 32l); + (* X := Xhigh *) + emit (Pmv(X5, X6)) + end; + (* lbl1: *) + emit (Plabel lbl1); + (* Y := X >> S *) + emit (if sixtyfour then Psrll(X9, X X5, X X8) else Psrlw(X9, X X5, X X8)); + (* if (Y == 0) goto lbl2 *) + emit (if sixtyfour then Pbeql(X X9, X0, lbl2) else Pbeqw(X X9, X0, lbl2)); + (* N := N - S *) + emit (Psubw(X7, X X7, X X8)); + (* X := Y *) + emit (Pmv(X5, X9)); + (* lbl2: *) + emit (Plabel lbl2); + (* S := S / 2 *) + emit (Psrliw(X8, X X8, _1)); + (* if (S != 0) goto lbl1; *) + emit (Pbnew(X X8, X0, lbl1)); + (* N := N - X *) + emit (Psubw(X7, X X7, X X5)) + +(* Count trailing zeros. Algorithm 5-14 from Hacker's Delight, + re-rolled as a loop to produce more compact code. *) + +let expand_ctz ~sixtyfour ~splitlong = + (* Input: X in X6 or (X5, X6) if splitlong + Result: N in X7 + Temporaries: S in X8, Y in X9 *) + let lbl1 = new_label() in + let lbl2 = new_label() in + (* N := bitsize of X's type (32 or 64) *) + expand_loadimm32 X7 (coqint_of_camlint + (if sixtyfour || splitlong then 64l else 32l)); + (* S := initial shift amount (16 or 32) *) + expand_loadimm32 X8 (coqint_of_camlint (if sixtyfour then 32l else 16l)); + if splitlong then begin + (* if (Xlow == 0) goto lbl1 *) + emit (Pbeqw(X X5, X0, lbl1)); + (* N := 32 *) + expand_loadimm32 X7 (coqint_of_camlint 32l); + (* X := Xlow *) + emit (Pmv(X6, X5)) + end; + (* lbl1: *) + emit (Plabel lbl1); + (* Y := X >> S *) + emit (if sixtyfour then Pslll(X9, X X6, X X8) else Psllw(X9, X X6, X X8)); + (* if (Y == 0) goto lbl2 *) + emit (if sixtyfour then Pbeql(X X9, X0, lbl2) else Pbeqw(X X9, X0, lbl2)); + (* N := N - S *) + emit (Psubw(X7, X X7, X X8)); + (* X := Y *) + emit (Pmv(X6, X9)); + (* lbl2: *) + emit (Plabel lbl2); + (* S := S / 2 *) + emit (Psrliw(X8, X X8, _1)); + (* if (S != 0) goto lbl1; *) + emit (Pbnew(X X8, X0, lbl1)); + (* N := N - most significant bit of X *) + emit (if sixtyfour then Psrlil(X6, X X6, coqint_of_camlint 63l) + else Psrliw(X6, X X6, coqint_of_camlint 31l)); + emit (Psubw(X7, X X7, X X6)) + (* Handling of compiler-inlined builtins *) let expand_builtin_inline name args res = @@ -418,10 +502,33 @@ let expand_builtin_inline name args res = assert (ah = X6 && al = X5 && rh = X5 && rl = X6); expand_bswap32 X5 X5; expand_bswap32 X6 X6 + (* Count zeros *) + | "__builtin_clz", [BA(IR a)], BR(IR res) -> + assert (a = X5 && res = X7); + expand_clz ~sixtyfour:false ~splitlong:false + | "__builtin_clzl", [BA(IR a)], BR(IR res) -> + assert (a = X5 && res = X7); + expand_clz ~sixtyfour:Archi.ptr64 ~splitlong:false + | "__builtin_clzll", [BA(IR a)], BR(IR res) -> + assert (a = X5 && res = X7); + expand_clz ~sixtyfour:true ~splitlong:false + | "__builtin_clzll", [BA_splitlong(BA(IR ah), BA(IR al))], BR(IR res) -> + assert (al = X5 && ah = X6 && res = X7); + expand_clz ~sixtyfour:false ~splitlong:true + | "__builtin_ctz", [BA(IR a)], BR(IR res) -> + assert (a = X6 && res = X7); + expand_ctz ~sixtyfour:false ~splitlong:false + | "__builtin_ctzl", [BA(IR a)], BR(IR res) -> + assert (a = X6 && res = X7); + expand_ctz ~sixtyfour:Archi.ptr64 ~splitlong:false + | "__builtin_ctzll", [BA(IR a)], BR(IR res) -> + assert (a = X6 && res = X7); + expand_ctz ~sixtyfour:true ~splitlong:false + | "__builtin_ctzll", [BA_splitlong(BA(IR ah), BA(IR al))], BR(IR res) -> + assert (al = X5 && ah = X6 && res = X7); + expand_ctz ~sixtyfour:false ~splitlong:true (* Float arithmetic *) - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> - emit (Pfabsd(res, a1)) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + | ("__builtin_fsqrt" | "__builtin_sqrt"), [BA(FR a1)], BR(FR res) -> emit (Pfsqrtd(res, a1)) | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> emit (Pfmaddd(res, a1, a2, a3)) diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 8678a5dc..d2255e66 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1035,7 +1035,9 @@ Opaque Int.eq. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. - (* shrximm *) - clear H. exploit Val.shrx_shr_3; eauto. intros E; subst v; clear EV. + destruct (Val.shrx (rs x0) (Vint n)) eqn:TOTAL; cbn. + { + exploit Val.shrx_shr_3; eauto. intros E; subst v. destruct (Int.eq n Int.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. @@ -1052,6 +1054,24 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. + } + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + - (* longofintu *) econstructor; split. eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. @@ -1076,7 +1096,27 @@ Opaque Int.eq. intros (rs' & A & B & C). exists rs'; split; eauto. rewrite B; auto with asmgen. - (* shrxlimm *) - clear H. exploit Val.shrxl_shrl_3; eauto. intros E; subst v; clear EV. + destruct (Val.shrxl (rs x0) (Vint n)) eqn:TOTAL. + { + exploit Val.shrxl_shrl_3; eauto. intros E; subst v. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. ++ destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + + * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + } destruct (Int.eq n Int.zero). + econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. @@ -1094,6 +1134,7 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. + - (* cond *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. diff --git a/riscV/CSE2deps.v b/riscV/CSE2deps.v index b4b80e2f..c0deacf0 100644 --- a/riscV/CSE2deps.v +++ b/riscV/CSE2deps.v @@ -28,5 +28,8 @@ Definition may_overlap chunk addr args chunk' addr' args' := (base :: nil), (base' :: nil) => if peq base base' then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) - else true | _, _, _, _ => true + else true + | (Ainstack ofs), (Ainstack ofs'), _, _ => + negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + | _, _, _, _ => true end. diff --git a/riscV/CSE2depsproof.v b/riscV/CSE2depsproof.v index f283c8ac..cf9e62b1 100644 --- a/riscV/CSE2depsproof.v +++ b/riscV/CSE2depsproof.v @@ -123,7 +123,7 @@ Proof. intros until rs. intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) +- (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. destruct args' as [ | base' [ | ]]. 1,3: discriminate. simpl in OVERLAP. @@ -133,7 +133,15 @@ Proof. 2: discriminate. simpl in *. eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. - } + +- (* Ainstack / Ainstack *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + cbn in OVERLAP. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. Qed. End SOUNDNESS. diff --git a/riscV/ConstpropOpproof.v b/riscV/ConstpropOpproof.v index 765aa035..26a50317 100644 --- a/riscV/ConstpropOpproof.v +++ b/riscV/ConstpropOpproof.v @@ -265,52 +265,84 @@ Qed. Lemma make_divimm_correct: forall n r1 r2 v, - Val.divs e#r1 e#r2 = Some v -> + Val.maketotal (Val.divs e#r1 e#r2) = v -> e#r2 = Vint n -> let (op, args) := make_divimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divimm. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. - destruct (e#r1) eqn:?; - try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); - inv H; auto. - destruct (Int.is_power2 n) eqn:?. - destruct (Int.ltu i (Int.repr 31)) eqn:?. - exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. - exists v; auto. - exists v; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros; subst; rewrite H0. + { destruct (e # r1) eqn:Er1. + all: try (cbn; exists (e # r1); split; auto; fail). + rewrite Val.divs_one. + cbn. + rewrite Er1. + exists (Vint i); split; auto. + } + destruct (Int.is_power2 n) eqn:Power2. + { + destruct (Int.ltu i (Int.repr 31)) eqn:iLT31. + { + cbn. + exists (Val.maketotal (Val.shrx e # r1 (Vint i))); split; auto. + destruct (Val.divs e # r1 (Vint n)) eqn:DIVS; cbn; auto. + rewrite Val.divs_pow2 with (y:=v) (n:=n). + cbn. + all: auto. + } + exists (Val.maketotal (Val.divs e # r1 (Vint n))); split; cbn; auto; congruence. + } + exists (Val.maketotal (Val.divs e # r1 (Vint n))); split; cbn; auto; congruence. Qed. Lemma make_divuimm_correct: forall n r1 r2 v, - Val.divu e#r1 e#r2 = Some v -> + Val.maketotal (Val.divu e#r1 e#r2) = v -> e#r2 = Vint n -> let (op, args) := make_divuimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divuimm. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. - destruct (e#r1) eqn:?; - try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); - inv H; auto. - destruct (Int.is_power2 n) eqn:?. - econstructor; split. simpl; eauto. - rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. - exists v; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros; subst; rewrite H0. + { destruct (e # r1) eqn:Er1. + all: try (cbn; exists (e # r1); split; auto; fail). + rewrite Val.divu_one. + cbn. + rewrite Er1. + exists (Vint i); split; auto. + } + destruct (Int.is_power2 n) eqn:Power2. + { + cbn. + exists (Val.shru e # r1 (Vint i)); split; auto. + destruct (Val.divu e # r1 (Vint n)) eqn:DIVU; cbn; auto. + rewrite Val.divu_pow2 with (y:=v) (n:=n). + all: auto. + } + exists (Val.maketotal (Val.divu e # r1 (Vint n))); split; cbn; auto; congruence. Qed. Lemma make_moduimm_correct: forall n r1 r2 v, - Val.modu e#r1 e#r2 = Some v -> + Val.maketotal (Val.modu e#r1 e#r2) = v -> e#r2 = Vint n -> let (op, args) := make_moduimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_moduimm. destruct (Int.is_power2 n) eqn:?. - exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. - exists v; auto. + { destruct (Val.modu e # r1 e # r2) eqn:MODU; cbn in H. + { subst v0. + exists v; split; auto. + cbn. decEq. eapply Val.modu_pow2; eauto. congruence. + } + subst v. + eexists; split; auto. + cbn. reflexivity. + } + exists v; split; auto. + cbn. + congruence. Qed. Lemma make_andimm_correct: @@ -444,48 +476,82 @@ Qed. Lemma make_divlimm_correct: forall n r1 r2 v, - Val.divls e#r1 e#r2 = Some v -> + Val.maketotal (Val.divls e#r1 e#r2) = v -> e#r2 = Vlong n -> let (op, args) := make_divlimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divlimm. - destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. - rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. - exists v; auto. - exists v; auto. + destruct (Int64.is_power2' n) eqn:Power2. + { + destruct (Int.ltu i (Int.repr 63)) eqn:iLT63. + { + cbn. + exists (Val.maketotal (Val.shrxl e # r1 (Vint i))); split; auto. + rewrite H0 in H. + destruct (Val.divls e # r1 (Vlong n)) eqn:DIVS; cbn in H; auto. + { + subst v0. + rewrite Val.divls_pow2 with (y:=v) (n:=n). + cbn. + all: auto. + } + subst. auto. + } + cbn. subst. rewrite H0. + exists (Val.maketotal (Val.divls e # r1 (Vlong n))); split; auto. + } + cbn. subst. rewrite H0. + exists (Val.maketotal (Val.divls e # r1 (Vlong n))); split; auto. Qed. Lemma make_divluimm_correct: forall n r1 r2 v, - Val.divlu e#r1 e#r2 = Some v -> + Val.maketotal (Val.divlu e#r1 e#r2) = v -> e#r2 = Vlong n -> let (op, args) := make_divluimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_divluimm. destruct (Int64.is_power2' n) eqn:?. + { econstructor; split. simpl; eauto. - rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. - simpl. - erewrite Int64.is_power2'_range by eauto. - erewrite Int64.divu_pow2' by eauto. auto. - exists v; auto. + rewrite H0 in H. destruct (e#r1); inv H. + all: cbn; auto. + { + destruct (Int64.eq n Int64.zero); cbn; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. auto. + } + } + exists v; split; auto. + cbn. + rewrite H. + reflexivity. Qed. Lemma make_modluimm_correct: forall n r1 r2 v, - Val.modlu e#r1 e#r2 = Some v -> + Val.maketotal (Val.modlu e#r1 e#r2) = v -> e#r2 = Vlong n -> let (op, args) := make_modluimm n r1 r2 in exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. Proof. intros; unfold make_modluimm. destruct (Int64.is_power2 n) eqn:?. - exists v; split; auto. simpl. decEq. - rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. - simpl. erewrite Int64.modu_and by eauto. auto. - exists v; auto. + { + econstructor; split. simpl; eauto. + rewrite H0 in H. destruct (e#r1); inv H. + all: cbn; auto. + { + destruct (Int64.eq n Int64.zero); cbn; auto. + erewrite Int64.modu_and by eauto. auto. + } + } + exists v; split; auto. + cbn. + rewrite H. + reflexivity. Qed. Lemma make_andlimm_correct: @@ -633,14 +699,17 @@ Proof. - (* mul 2*) InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. - (* divs *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divimm_correct; auto. + assert (e#r2 = Vint n2). { clear H0. InvApproxRegs; SimplVM; auto. } + apply make_divimm_correct; auto. + congruence. - (* divu *) assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. apply make_divuimm_correct; auto. + congruence. - (* modu *) assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. apply make_moduimm_correct; auto. + congruence. - (* and 1 *) rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. - (* and 2 *) @@ -680,12 +749,15 @@ Proof. - (* divl *) assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. apply make_divlimm_correct; auto. + congruence. - (* divlu *) assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. apply make_divluimm_correct; auto. + congruence. - (* modlu *) assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. apply make_modluimm_correct; auto. + congruence. - (* andl 1 *) rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. - (* andl 2 *) diff --git a/riscV/Machregs.v b/riscV/Machregs.v index d8bb4a4b..d469e594 100644 --- a/riscV/Machregs.v +++ b/riscV/Machregs.v @@ -194,6 +194,17 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_inline_asm txt sg clob => destroyed_by_clobber clob | EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil + | EF_builtin name sg => + if string_dec name "__builtin_clz" + || string_dec name "__builtin_clzl" + || string_dec name "__builtin_clzll" then + R5 :: R8 :: R9 :: nil + else if string_dec name "__builtin_ctz" + || string_dec name "__builtin_ctzl" + || string_dec name "__builtin_ctzll" then + R6 :: R8 :: R9 :: nil + else + nil | _ => nil end. @@ -213,6 +224,20 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list( | EF_builtin name sg => if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) + else if string_dec name "__builtin_clz" + || string_dec name "__builtin_clzl" then + (Some R5 :: nil, Some R7 :: nil) + else if string_dec name "__builtin_clzll" then + if Archi.ptr64 + then (Some R5 :: nil, Some R7 :: nil) + else (Some R6 :: Some R5 :: nil, Some R7 :: nil) + else if string_dec name "__builtin_ctz" + || string_dec name "__builtin_ctzl" then + (Some R6 :: nil, Some R7 :: nil) + else if string_dec name "__builtin_ctzll" then + if Archi.ptr64 + then (Some R6 :: nil, Some R7 :: nil) + else (Some R6 :: Some R5 :: nil, Some R7 :: nil) else (nil, nil) | _ => diff --git a/riscV/Machregsaux.ml b/riscV/Machregsaux.ml index 07097eaf..840943e7 100644 --- a/riscV/Machregsaux.ml +++ b/riscV/Machregsaux.ml @@ -12,25 +12,7 @@ (** Auxiliary functions on machine registers *) -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - let is_scratch_register r = false - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = Conventions1.is_callee_save r let class_of_type = function | AST.Tint | AST.Tlong -> 0 diff --git a/riscV/Machregsaux.mli b/riscV/Machregsaux.mli index d7117c21..01b0f9fd 100644 --- a/riscV/Machregsaux.mli +++ b/riscV/Machregsaux.mli @@ -12,9 +12,6 @@ (** Auxiliary functions on machine registers *) -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool val class_of_type: AST.typ -> int @@ -241,10 +241,10 @@ Definition eval_operation | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) - | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 - | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 - | Omod, v1 :: v2 :: nil => Val.mods v1 v2 - | Omodu, v1 :: v2 :: nil => Val.modu v1 v2 + | Odiv, v1 :: v2 :: nil => Some (Val.maketotal (Val.divs v1 v2)) + | Odivu, v1 :: v2 :: nil => Some (Val.maketotal (Val.divu v1 v2)) + | Omod, v1 :: v2 :: nil => Some (Val.maketotal (Val.mods v1 v2)) + | Omodu, v1 :: v2 :: nil => Some (Val.maketotal (Val.modu v1 v2)) | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) @@ -257,7 +257,7 @@ Definition eval_operation | Oshrimm n, v1 :: nil => Some (Val.shr v1 (Vint n)) | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshrximm n, v1::nil => Some (Val.maketotal (Val.shrx v1 (Vint n))) | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) | Ohighlong, v1::nil => Some (Val.hiword v1) @@ -270,10 +270,10 @@ Definition eval_operation | Omull, v1::v2::nil => Some (Val.mull v1 v2) | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) - | Odivl, v1::v2::nil => Val.divls v1 v2 - | Odivlu, v1::v2::nil => Val.divlu v1 v2 - | Omodl, v1::v2::nil => Val.modls v1 v2 - | Omodlu, v1::v2::nil => Val.modlu v1 v2 + | Odivl, v1::v2::nil => Some (Val.maketotal (Val.divls v1 v2)) + | Odivlu, v1::v2::nil => Some (Val.maketotal (Val.divlu v1 v2)) + | Omodl, v1::v2::nil => Some (Val.maketotal (Val.modls v1 v2)) + | Omodlu, v1::v2::nil => Some (Val.maketotal (Val.modlu v1 v2)) | Oandl, v1::v2::nil => Some(Val.andl v1 v2) | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) | Oorl, v1::v2::nil => Some(Val.orl v1 v2) @@ -286,7 +286,7 @@ Definition eval_operation | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) - | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) + | Oshrxlimm n, v1::nil => Some (Val.maketotal (Val.shrxl v1 (Vint n))) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) @@ -301,22 +301,22 @@ Definition eval_operation | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 - | Ointofsingle, v1::nil => Val.intofsingle v1 - | Ointuofsingle, v1::nil => Val.intuofsingle v1 - | Osingleofint, v1::nil => Val.singleofint v1 - | Osingleofintu, v1::nil => Val.singleofintu v1 - | Olongoffloat, v1::nil => Val.longoffloat v1 - | Olonguoffloat, v1::nil => Val.longuoffloat v1 - | Ofloatoflong, v1::nil => Val.floatoflong v1 - | Ofloatoflongu, v1::nil => Val.floatoflongu v1 - | Olongofsingle, v1::nil => Val.longofsingle v1 - | Olonguofsingle, v1::nil => Val.longuofsingle v1 - | Osingleoflong, v1::nil => Val.singleoflong v1 - | Osingleoflongu, v1::nil => Val.singleoflongu v1 + | Ointoffloat, v1::nil => Some (Val.maketotal (Val.intoffloat v1)) + | Ointuoffloat, v1::nil => Some (Val.maketotal (Val.intuoffloat v1)) + | Ofloatofint, v1::nil => Some (Val.maketotal (Val.floatofint v1)) + | Ofloatofintu, v1::nil => Some (Val.maketotal (Val.floatofintu v1)) + | Ointofsingle, v1::nil => Some (Val.maketotal (Val.intofsingle v1)) + | Ointuofsingle, v1::nil => Some (Val.maketotal (Val.intuofsingle v1)) + | Osingleofint, v1::nil => Some (Val.maketotal (Val.singleofint v1)) + | Osingleofintu, v1::nil => Some (Val.maketotal (Val.singleofintu v1)) + | Olongoffloat, v1::nil => Some (Val.maketotal (Val.longoffloat v1)) + | Olonguoffloat, v1::nil => Some (Val.maketotal (Val.longuoffloat v1)) + | Ofloatoflong, v1::nil => Some (Val.maketotal (Val.floatoflong v1)) + | Ofloatoflongu, v1::nil => Some (Val.maketotal (Val.floatoflongu v1)) + | Olongofsingle, v1::nil => Some (Val.maketotal (Val.longofsingle v1)) + | Olonguofsingle, v1::nil => Some (Val.maketotal (Val.longuofsingle v1)) + | Osingleoflong, v1::nil => Some (Val.maketotal (Val.singleoflong v1)) + | Osingleoflongu, v1::nil => Some (Val.maketotal (Val.singleoflongu v1)) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) | _, _ => None end. @@ -539,15 +539,17 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1... - destruct v0; destruct v1... (* div, divu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero); inv H2... + - destruct v0; destruct v1; cbn; trivial. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr (-2147483648)) && Int.eq i0 Int.mone); cbn; trivial. + - destruct v0; destruct v1; cbn; trivial. + destruct (Int.eq i0 Int.zero); cbn; trivial. (* mod, modu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero); inv H2... + - destruct v0; destruct v1; cbn; trivial. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr (-2147483648)) && Int.eq i0 Int.mone); cbn; trivial. + - destruct v0; destruct v1; cbn; trivial. + destruct (Int.eq i0 Int.zero); cbn; trivial. (* and, andimm *) - destruct v0; destruct v1... - destruct v0... @@ -567,7 +569,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... (* shrx *) - - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + - destruct v0; cbn; trivial. + destruct (Int.ltu n (Int.repr 31)); cbn; trivial. (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -588,15 +591,19 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1... - destruct v0; destruct v1... (* divl, divlu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero); inv H2... + - destruct v0; destruct v1; cbn; trivial. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr (-9223372036854775808)) && + Int64.eq i0 Int64.mone); cbn; trivial. + - destruct v0; destruct v1; cbn; trivial. + destruct (Int64.eq i0 Int64.zero); cbn; trivial. (* modl, modlu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero); inv H2... + - destruct v0; destruct v1; cbn; trivial. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr (-9223372036854775808)) && + Int64.eq i0 Int64.mone); cbn; trivial. + - destruct v0; destruct v1; cbn; trivial. + destruct (Int64.eq i0 Int64.zero); cbn; trivial. (* andl, andlimm *) - destruct v0; destruct v1... - destruct v0... @@ -616,7 +623,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... (* shrxl *) - - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + - destruct v0; cbn; trivial. + destruct (Int.ltu n (Int.repr 63)); cbn; trivial. (* negf, absf *) - destruct v0... - destruct v0... @@ -639,50 +647,47 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0... - destruct v0... (* intoffloat, intuoffloat *) - - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + - destruct v0; cbn; trivial. + destruct (Float.to_int f); cbn; trivial. + - destruct v0; cbn; trivial. + destruct (Float.to_intu f); cbn; trivial. (* floatofint, floatofintu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* intofsingle, intuofsingle *) - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... + - destruct v0; cbn; trivial. + destruct (Float32.to_int f); cbn; trivial. + - destruct v0; cbn; trivial. + destruct (Float32.to_intu f); cbn; trivial. (* singleofint, singleofintu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* longoffloat, longuoffloat *) - - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2... + - destruct v0; cbn; trivial. + destruct (Float.to_long f); cbn; trivial. + - destruct v0; cbn; trivial. + destruct (Float.to_longu f); cbn; trivial. (* floatoflong, floatoflongu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* longofsingle, longuofsingle *) - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2... + - destruct v0; cbn; trivial. + destruct (Float32.to_long f); cbn; trivial. + - destruct v0; cbn; trivial. + destruct (Float32.to_longu f); cbn; trivial. (* singleoflong, singleoflongu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m)... destruct b... Qed. - +(* This should not be simplified to "false" because it breaks proofs elsewhere. *) Definition is_trapping_op (op : operation) := match op with - | Odiv | Odivl | Odivu | Odivlu - | Omod | Omodl | Omodu | Omodlu - | Oshrximm _ | Oshrxlimm _ - | Ointoffloat | Ointuoffloat - | Ointofsingle | Ointuofsingle - | Olongoffloat | Olonguoffloat - | Olongofsingle | Olonguofsingle - | Osingleofint | Osingleofintu - | Osingleoflong | Osingleoflongu - | Ofloatofint | Ofloatofintu - | Ofloatoflong | Ofloatoflongu => true + | Omove => false | _ => false end. - Definition args_of_operation op := if eq_operation op Omove @@ -872,6 +877,16 @@ Proof. unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. +Lemma op_valid_pointer_eq: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + intros MEM; destruct cond; repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. +Qed. + (** Global variables mentioned in an operation or addressing mode *) Definition globals_addressing (addr: addressing) : list ident := @@ -1033,19 +1048,29 @@ Proof. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. (* div, divu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + || Int.eq i (Int.repr (-2147483648)) && Int.eq i0 Int.mone); cbn. + apply Val.val_inject_undef. + apply Val.inject_int. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. + destruct (Int.eq i0 Int.zero); cbn. + apply Val.val_inject_undef. + apply Val.inject_int. (* mod, modu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + || Int.eq i (Int.repr (-2147483648)) && Int.eq i0 Int.mone); cbn. + apply Val.val_inject_undef. + apply Val.inject_int. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. + destruct (Int.eq i0 Int.zero); cbn. + apply Val.val_inject_undef. + apply Val.inject_int. (* and, andimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1065,8 +1090,10 @@ Proof. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. (* shrx *) - - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + - inv H4; cbn; try apply Val.val_inject_undef. + destruct (Int.ltu n (Int.repr 31)); cbn. + apply Val.inject_int. + apply Val.val_inject_undef. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1085,19 +1112,31 @@ Proof. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. (* divl, divlu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + || Int64.eq i (Int64.repr (-9223372036854775808)) && + Int64.eq i0 Int64.mone); cbn. + apply Val.val_inject_undef. + apply Val.inject_long. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. + destruct (Int64.eq i0 Int64.zero); cbn. + apply Val.val_inject_undef. + apply Val.inject_long. (* modl, modlu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + || Int64.eq i (Int64.repr (-9223372036854775808)) && + Int64.eq i0 Int64.mone); cbn. + apply Val.val_inject_undef. + apply Val.inject_long. + - inv H4; inv H2; cbn. + all: try apply Val.val_inject_undef. + destruct (Int64.eq i0 Int64.zero); cbn. + apply Val.val_inject_undef. + apply Val.inject_long. (* andl, andlimm *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1116,9 +1155,11 @@ Proof. (* shru, shruimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shrx *) - - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + (* shrx *) + - inv H4; cbn; try apply Val.val_inject_undef. + destruct (Int.ltu n (Int.repr 63)); cbn. + apply Val.inject_long. + apply Val.val_inject_undef. (* negf, absf *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1141,37 +1182,37 @@ Proof. - inv H4; simpl; auto. - inv H4; simpl; auto. (* intoffloat, intuoffloat *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. + - inv H4; cbn; auto. + destruct (Float.to_int f0); cbn; auto. + - inv H4; cbn; auto. + destruct (Float.to_intu f0); cbn; auto. (* floatofint, floatofintu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; auto. + - inv H4; cbn; auto. (* intofsingle, intuofsingle *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. + - inv H4; cbn; auto. + destruct (Float32.to_int f0); cbn; auto. + - inv H4; cbn; auto. + destruct (Float32.to_intu f0); cbn; auto. (* singleofint, singleofintu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; auto. + - inv H4; cbn; auto. (* longoffloat, longuoffloat *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2. - exists (Vlong i); auto. + - inv H4; cbn; auto. + destruct (Float.to_long f0); cbn; auto. + - inv H4; cbn; auto. + destruct (Float.to_longu f0); cbn; auto. (* floatoflong, floatoflongu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; auto. + - inv H4; cbn; auto. (* longofsingle, longuofsingle *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2. - exists (Vlong i); auto. + - inv H4; cbn; auto. + destruct (Float32.to_long f0); cbn; auto. + - inv H4; cbn; auto. + destruct (Float32.to_longu f0); cbn; auto. (* singleoflong, singleoflongu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; cbn; auto. + - inv H4; cbn; auto. (* cmp *) - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. diff --git a/riscV/OpWeights.ml b/riscV/OpWeights.ml new file mode 100644 index 00000000..75a913c6 --- /dev/null +++ b/riscV/OpWeights.ml @@ -0,0 +1,161 @@ +open Op;; +open PrepassSchedulingOracleDeps;; + +module Rocket = + struct + (* Attempt at modeling the Rocket core *) + + let resource_bounds = [| 1 |];; + let nr_non_pipelined_units = 1;; (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu + | Omull | Omullhs | Omullhu -> 4 + + | Onegf -> 1 (*r [rd = - r1] *) + | Oabsf (*r [rd = abs(r1)] *) + | Oaddf (*r [rd = r1 + r2] *) + | Osubf (*r [rd = r1 - r2] *) + | Omulf -> 6 (*r [rd = r1 * r2] *) + | Onegfs -> 1 (*r [rd = - r1] *) + | Oabsfs (*r [rd = abs(r1)] *) + | Oaddfs (*r [rd = r1 + r2] *) + | Osubfs (*r [rd = r1 - r2] *) + | Omulfs -> 4 (*r [rd = r1 * r2] *) + | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle -> 4 (*r [rd] is [r1] extended to double-precision float *) + (*c Conversions between int and float: *) + | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu -> 6 (*r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu -> 6 (*r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) + + | Odiv | Odivu | Odivl | Odivlu -> 16 + | Odivfs -> 35 + | Odivf -> 50 + + | Ocmp cond -> + (match cond with + | Ccomp _ + | Ccompu _ + | Ccompimm _ + | Ccompuimm _ + | Ccompl _ + | Ccomplu _ + | Ccomplimm _ + | Ccompluimm _ -> 1 + | Ccompf _ + | Cnotcompf _ -> 6 + | Ccompfs _ + | Cnotcompfs _ -> 4) + | _ -> 1;; + + let resources_of_op (op : operation) (nargs : int) = resource_bounds;; + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |];; + + let resources_of_cond (cond : condition) (nargs : int) = resource_bounds;; + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; + let latency_of_call _ _ = 6;; + + let resources_of_load trap chunk addressing nargs = resource_bounds;; + + let resources_of_store chunk addressing nargs = resource_bounds;; + + let resources_of_call _ _ = resource_bounds;; + let resources_of_builtin _ = resource_bounds;; + end;; + +module SweRV_EH1 = + struct + (* Attempt at modeling SweRV EH1 + [| issues ; LSU ; multiplier |] *) + let resource_bounds = [| 2 ; 1; 1 |];; + let nr_non_pipelined_units = 1;; (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu + | Omull | Omullhs | Omullhu -> 3 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | _ -> 1;; + + let resources_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu + | Omull | Omullhs | Omullhu -> [| 1 ; 0 ; 1 |] + | Odiv | Odivu | Odivl | Odivlu -> [| 0 ; 0; 0 |] + | _ -> [| 1; 0; 0; 0 |];; + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |];; + + let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |];; + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; + let latency_of_call _ _ = 6;; + + let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |];; + + let resources_of_store chunk addressing nargs = [| 1; 1; 0 |];; + + let resources_of_call _ _ = resource_bounds;; + let resources_of_builtin _ = resource_bounds;; + end;; + +let get_opweights () : opweights = + match !Clflags.option_mtune with + | "rocket" | "" -> + { + pipelined_resource_bounds = Rocket.resource_bounds; + nr_non_pipelined_units = Rocket.nr_non_pipelined_units; + latency_of_op = Rocket.latency_of_op; + resources_of_op = Rocket.resources_of_op; + non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; + latency_of_load = Rocket.latency_of_load; + resources_of_load = Rocket.resources_of_load; + resources_of_store = Rocket.resources_of_store; + resources_of_cond = Rocket.resources_of_cond; + latency_of_call = Rocket.latency_of_call; + resources_of_call = Rocket.resources_of_call; + resources_of_builtin = Rocket.resources_of_builtin + } + | "SweRV_EH1" | "EH1" -> + { + pipelined_resource_bounds = SweRV_EH1.resource_bounds; + nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; + latency_of_op = SweRV_EH1.latency_of_op; + resources_of_op = SweRV_EH1.resources_of_op; + non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; + latency_of_load = SweRV_EH1.latency_of_load; + resources_of_load = SweRV_EH1.resources_of_load; + resources_of_store = SweRV_EH1.resources_of_store; + resources_of_cond = SweRV_EH1.resources_of_cond; + latency_of_call = SweRV_EH1.latency_of_call; + resources_of_call = SweRV_EH1.resources_of_call; + resources_of_builtin = SweRV_EH1.resources_of_builtin + } + | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);; diff --git a/riscV/PrepassSchedulingOracle.ml b/riscV/PrepassSchedulingOracle.ml new file mode 120000 index 00000000..912e9ffa --- /dev/null +++ b/riscV/PrepassSchedulingOracle.ml @@ -0,0 +1 @@ +../aarch64/PrepassSchedulingOracle.ml
\ No newline at end of file diff --git a/riscV/PrepassSchedulingOracleDeps.ml b/riscV/PrepassSchedulingOracleDeps.ml new file mode 120000 index 00000000..1e955b85 --- /dev/null +++ b/riscV/PrepassSchedulingOracleDeps.ml @@ -0,0 +1 @@ +../aarch64/PrepassSchedulingOracleDeps.ml
\ No newline at end of file diff --git a/riscV/SelectLongproof.v b/riscV/SelectLongproof.v index d47b6d64..0fc578bf 100644 --- a/riscV/SelectLongproof.v +++ b/riscV/SelectLongproof.v @@ -455,6 +455,10 @@ Proof. unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_divls_base; eauto. TrivialExists. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. @@ -462,6 +466,10 @@ Proof. unfold modls_base; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_modls_base; eauto. TrivialExists. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. @@ -469,6 +477,10 @@ Proof. unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_divlu_base; eauto. TrivialExists. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. @@ -476,6 +488,10 @@ Proof. unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_modlu_base; eauto. TrivialExists. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_shrxlimm: @@ -490,33 +506,9 @@ Proof. - subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. - TrivialExists. -(* - intros. unfold shrxlimm. destruct Archi.splitlong eqn:SL. -+ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. -+ destruct x; simpl in H0; try discriminate. - destruct (Int.ltu n (Int.repr 63)) eqn:LTU; inv H0. - predSpec Int.eq Int.eq_spec n Int.zero. - - subst n. exists (Vlong i); split; auto. rewrite Int64.shrx'_zero. auto. - - assert (NZ: Int.unsigned n <> 0). - { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } - assert (LT: 0 <= Int.unsigned n < 63) by (apply Int.ltu_inv in LTU; assumption). - assert (LTU2: Int.ltu (Int.sub Int64.iwordsize' n) Int64.iwordsize' = true). - { unfold Int.ltu; apply zlt_true. - unfold Int.sub. change (Int.unsigned Int64.iwordsize') with 64. - rewrite Int.unsigned_repr. omega. - assert (64 < Int.max_unsigned) by reflexivity. omega. } - assert (X: eval_expr ge sp e m le - (Eop (Oshrlimm (Int.repr (Int64.zwordsize - 1))) (a ::: Enil)) - (Vlong (Int64.shr' i (Int.repr (Int64.zwordsize - 1))))). - { EvalOp. } - assert (Y: eval_expr ge sp e m le (shrxlimm_inner a n) - (Vlong (Int64.shru' (Int64.shr' i (Int.repr (Int64.zwordsize - 1))) (Int.sub Int64.iwordsize' n)))). - { EvalOp. simpl. rewrite LTU2. auto. } - TrivialExists. - constructor. EvalOp. simpl; eauto. constructor. - simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int64.shrx'_shr_2 by auto. reflexivity. - change (Int.unsigned Int64.iwordsize') with 64; omega. -*) + cbn. + rewrite H0. + reflexivity. Qed. Theorem eval_cmplu: @@ -566,6 +558,7 @@ Proof. unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_longoffloat; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. @@ -573,6 +566,7 @@ Proof. unfold longuoffloat; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_longuoffloat; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. @@ -580,6 +574,7 @@ Proof. unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_floatoflong; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. @@ -587,6 +582,7 @@ Proof. unfold floatoflongu; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_floatoflongu; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. @@ -594,6 +590,7 @@ Proof. unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_longofsingle; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. @@ -601,6 +598,7 @@ Proof. unfold longuofsingle; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_longuofsingle; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. @@ -608,6 +606,7 @@ Proof. unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_singleoflong; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. @@ -615,6 +614,7 @@ Proof. unfold singleoflongu; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_singleoflongu; eauto. TrivialExists. + cbn; rewrite H0; reflexivity. Qed. End CMCONSTR. diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v index 7f2014dc..1d13702a 100644 --- a/riscV/SelectOpproof.v +++ b/riscV/SelectOpproof.v @@ -506,7 +506,12 @@ Theorem eval_divs_base: Val.divs x y = Some z -> exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold divs_base. exists z; split. EvalOp. auto. + intros. unfold divs_base. exists z; split. EvalOp. + 2: apply Val.lessdef_refl. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_mods_base: @@ -516,7 +521,12 @@ Theorem eval_mods_base: Val.mods x y = Some z -> exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold mods_base. exists z; split. EvalOp. auto. + intros. unfold mods_base. exists z; split. EvalOp. + 2: apply Val.lessdef_refl. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_divu_base: @@ -526,7 +536,12 @@ Theorem eval_divu_base: Val.divu x y = Some z -> exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold divu_base. exists z; split. EvalOp. auto. + intros. unfold divu_base. exists z; split. EvalOp. + 2: apply Val.lessdef_refl. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_modu_base: @@ -536,7 +551,12 @@ Theorem eval_modu_base: Val.modu x y = Some z -> exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. Proof. - intros. unfold modu_base. exists z; split. EvalOp. auto. + intros. unfold modu_base. exists z; split. EvalOp. + 2: apply Val.lessdef_refl. + cbn. + rewrite H1. + cbn. + trivial. Qed. Theorem eval_shrximm: @@ -553,34 +573,12 @@ Proof. replace (Int.shrx i Int.zero) with i. auto. unfold Int.shrx, Int.divs. rewrite Int.shl_zero. change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. - econstructor; split. EvalOp. auto. -(* - intros. destruct x; simpl in H0; try discriminate. - destruct (Int.ltu n (Int.repr 31)) eqn:LTU; inv H0. - unfold shrximm. - predSpec Int.eq Int.eq_spec n Int.zero. - - subst n. exists (Vint i); split; auto. - unfold Int.shrx, Int.divs. rewrite Z.quot_1_r. rewrite Int.repr_signed. auto. - - assert (NZ: Int.unsigned n <> 0). - { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } - assert (LT: 0 <= Int.unsigned n < 31) by (apply Int.ltu_inv in LTU; assumption). - assert (LTU2: Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize = true). - { unfold Int.ltu; apply zlt_true. - unfold Int.sub. change (Int.unsigned Int.iwordsize) with 32. - rewrite Int.unsigned_repr. omega. - assert (32 < Int.max_unsigned) by reflexivity. omega. } - assert (X: eval_expr ge sp e m le - (Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) (a ::: Enil)) - (Vint (Int.shr i (Int.repr (Int.zwordsize - 1))))). - { EvalOp. } - assert (Y: eval_expr ge sp e m le (shrximm_inner a n) - (Vint (Int.shru (Int.shr i (Int.repr (Int.zwordsize - 1))) (Int.sub Int.iwordsize n)))). - { EvalOp. simpl. rewrite LTU2. auto. } - TrivialExists. - constructor. EvalOp. simpl; eauto. constructor. - simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int.shrx_shr_2 by auto. reflexivity. - change (Int.unsigned Int.iwordsize) with 32; omega. -*) + econstructor; split. EvalOp. + cbn. + rewrite H0. + cbn. + reflexivity. + apply Val.lessdef_refl. Qed. Theorem eval_shl: binary_constructor_sound shl Val.shl. @@ -790,6 +788,7 @@ Theorem eval_intoffloat: exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold intoffloat. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_intuoffloat: @@ -799,6 +798,7 @@ Theorem eval_intuoffloat: exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold intuoffloat. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_floatofintu: @@ -810,6 +810,7 @@ Proof. intros until y; unfold floatofintu. case (floatofintu_match a); intros. InvEval. simpl in H0. TrivialExists. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_floatofint: @@ -821,6 +822,7 @@ Proof. intros until y; unfold floatofint. case (floatofint_match a); intros. InvEval. simpl in H0. TrivialExists. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_intofsingle: @@ -830,6 +832,7 @@ Theorem eval_intofsingle: exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. Proof. intros; unfold intofsingle. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleofint: @@ -839,6 +842,7 @@ Theorem eval_singleofint: exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. Proof. intros; unfold singleofint; TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_intuofsingle: @@ -848,6 +852,7 @@ Theorem eval_intuofsingle: exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. Proof. intros; unfold intuofsingle. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleofintu: @@ -857,6 +862,7 @@ Theorem eval_singleofintu: exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. Proof. intros; unfold intuofsingle. TrivialExists. + cbn. rewrite H0. reflexivity. Qed. Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index 5670b5fe..f4b7b4d6 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -13,6 +13,7 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op RTL ValueDomain. +Require Import Zbits. (** Value analysis for RISC V operators *) @@ -59,10 +60,10 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omul, v1::v2::nil => mul v1 v2 | Omulhs, v1::v2::nil => mulhs v1 v2 | Omulhu, v1::v2::nil => mulhu v1 v2 - | Odiv, v1::v2::nil => divs v1 v2 - | Odivu, v1::v2::nil => divu v1 v2 - | Omod, v1::v2::nil => mods v1 v2 - | Omodu, v1::v2::nil => modu v1 v2 + | Odiv, v1::v2::nil => divs_total v1 v2 + | Odivu, v1::v2::nil => divu_total v1 v2 + | Omod, v1::v2::nil => mods_total v1 v2 + | Omodu, v1::v2::nil => modu_total v1 v2 | Oand, v1::v2::nil => and v1 v2 | Oandimm n, v1::nil => and v1 (I n) | Oor, v1::v2::nil => or v1 v2 @@ -88,10 +89,10 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omull, v1::v2::nil => mull v1 v2 | Omullhs, v1::v2::nil => mullhs v1 v2 | Omullhu, v1::v2::nil => mullhu v1 v2 - | Odivl, v1::v2::nil => divls v1 v2 - | Odivlu, v1::v2::nil => divlu v1 v2 - | Omodl, v1::v2::nil => modls v1 v2 - | Omodlu, v1::v2::nil => modlu v1 v2 + | Odivl, v1::v2::nil => divls_total v1 v2 + | Odivlu, v1::v2::nil => divlu_total v1 v2 + | Omodl, v1::v2::nil => modls_total v1 v2 + | Omodlu, v1::v2::nil => modlu_total v1 v2 | Oandl, v1::v2::nil => andl v1 v2 | Oandlimm n, v1::nil => andl v1 (L n) | Oorl, v1::v2::nil => orl v1 v2 @@ -119,20 +120,20 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Odivfs, v1::v2::nil => divfs v1 v2 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 - | Ointoffloat, v1::nil => intoffloat v1 - | Ointuoffloat, v1::nil => intuoffloat v1 + | Ointoffloat, v1::nil => intoffloat_total v1 + | Ointuoffloat, v1::nil => intuoffloat_total v1 | Ofloatofint, v1::nil => floatofint v1 | Ofloatofintu, v1::nil => floatofintu v1 - | Ointofsingle, v1::nil => intofsingle v1 - | Ointuofsingle, v1::nil => intuofsingle v1 + | Ointofsingle, v1::nil => intofsingle_total v1 + | Ointuofsingle, v1::nil => intuofsingle_total v1 | Osingleofint, v1::nil => singleofint v1 | Osingleofintu, v1::nil => singleofintu v1 - | Olongoffloat, v1::nil => longoffloat v1 - | Olonguoffloat, v1::nil => longuoffloat v1 + | Olongoffloat, v1::nil => longoffloat_total v1 + | Olonguoffloat, v1::nil => longuoffloat_total v1 | Ofloatoflong, v1::nil => floatoflong v1 | Ofloatoflongu, v1::nil => floatoflongu v1 - | Olongofsingle, v1::nil => longofsingle v1 - | Olonguofsingle, v1::nil => longuofsingle v1 + | Olongofsingle, v1::nil => longofsingle_total v1 + | Olonguofsingle, v1::nil => longuofsingle_total v1 | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) diff --git a/runtime/Makefile b/runtime/Makefile index ea3c914f..6f70fa87 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -38,6 +38,8 @@ OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \ vararg.o endif +AR=ar + OBJS+=write_profiling_table.o LIB=libcompcert.a @@ -59,7 +61,7 @@ endif $(LIB): $(OBJS) rm -f $(LIB) - ar rcs $(LIB) $(OBJS) + $(AR) rcs $(LIB) $(OBJS) %.o: %.s $(CASMRUNTIME) -o $@ $^ diff --git a/runtime/kvx/ccomp_k1c_fixes.h b/runtime/kvx/ccomp_k1c_fixes.h deleted file mode 120000 index b640c96e..00000000 --- a/runtime/kvx/ccomp_k1c_fixes.h +++ /dev/null @@ -1 +0,0 @@ -../include/ccomp_k1c_fixes.h
\ No newline at end of file diff --git a/runtime/x86_64/i64_dtou.S b/runtime/x86_64/i64_dtou.S index cc822d67..7f12ae88 100644 --- a/runtime/x86_64/i64_dtou.S +++ b/runtime/x86_64/i64_dtou.S @@ -39,13 +39,13 @@ // Conversion float -> unsigned long FUNCTION(__compcert_i64_dtou) - ucomisd .LC1(%rip), %xmm0 + ucomisd .LC1(%rip), FP_ARG_1 jnb 1f - cvttsd2siq %xmm0, %rax + cvttsd2siq FP_ARG_1, INT_RES ret -1: subsd .LC1(%rip), %xmm0 - cvttsd2siq %xmm0, %rax - addq .LC2(%rip), %rax +1: subsd .LC1(%rip), FP_ARG_1 + cvttsd2siq FP_ARG_1, INT_RES + addq .LC2(%rip), INT_RES ret .p2align 3 diff --git a/runtime/x86_64/i64_utod.S b/runtime/x86_64/i64_utod.S index 62e6e484..4d4870fc 100644 --- a/runtime/x86_64/i64_utod.S +++ b/runtime/x86_64/i64_utod.S @@ -39,18 +39,18 @@ // Conversion unsigned long -> double-precision float FUNCTION(__compcert_i64_utod) - testq %rdi, %rdi + testq INT_ARG_1, INT_ARG_1 js 1f - pxor %xmm0, %xmm0 // if < 2^63, - cvtsi2sdq %rdi, %xmm0 // convert as if signed + pxor FP_RES, FP_RES // if < 2^63, + cvtsi2sdq INT_ARG_1, FP_RES // convert as if signed ret 1: // if >= 2^63, use round-to-odd trick - movq %rdi, %rax + movq INT_ARG_1, %rax shrq %rax - andq $1, %rdi - orq %rdi, %rax // (arg >> 1) | (arg & 1) - pxor %xmm0, %xmm0 - cvtsi2sdq %rax, %xmm0 // convert as if signed - addsd %xmm0, %xmm0 // multiply result by 2.0 + andq $1, INT_ARG_1 + orq INT_ARG_1, %rax // (arg >> 1) | (arg & 1) + pxor FP_RES, FP_RES + cvtsi2sdq %rax, FP_RES // convert as if signed + addsd FP_RES, FP_RES // multiply result by 2.0 ret ENDFUNCTION(__compcert_i64_utod) diff --git a/runtime/x86_64/i64_utof.S b/runtime/x86_64/i64_utof.S index 63a33920..0e878121 100644 --- a/runtime/x86_64/i64_utof.S +++ b/runtime/x86_64/i64_utof.S @@ -39,18 +39,18 @@ // Conversion unsigned long -> single-precision float FUNCTION(__compcert_i64_utof) - testq %rdi, %rdi + testq INT_ARG_1, INT_ARG_1 js 1f - pxor %xmm0, %xmm0 // if < 2^63, - cvtsi2ssq %rdi, %xmm0 // convert as if signed + pxor FP_RES, FP_RES // if < 2^63, + cvtsi2ssq INT_ARG_1, FP_RES // convert as if signed ret 1: // if >= 2^63, use round-to-odd trick - movq %rdi, %rax + movq INT_ARG_1, %rax shrq %rax - andq $1, %rdi - orq %rdi, %rax // (arg >> 1) | (arg & 1) - pxor %xmm0, %xmm0 - cvtsi2ssq %rax, %xmm0 // convert as if signed - addss %xmm0, %xmm0 // multiply result by 2.0 + andq $1, INT_ARG_1 + orq INT_ARG_1, %rax // (arg >> 1) | (arg & 1) + pxor FP_RES, FP_RES + cvtsi2ssq %rax, FP_RES // convert as if signed + addss FP_RES, FP_RES // multiply result by 2.0 ret ENDFUNCTION(__compcert_i64_utof) diff --git a/runtime/x86_64/sysdeps.h b/runtime/x86_64/sysdeps.h index e9d456af..aacef8f0 100644 --- a/runtime/x86_64/sysdeps.h +++ b/runtime/x86_64/sysdeps.h @@ -63,13 +63,25 @@ _##f: #if defined(SYS_cygwin) -#define GLOB(x) _##x +#define GLOB(x) x #define FUNCTION(f) \ .text; \ - .globl _##f; \ + .globl f; \ .align 16; \ -_##f: +f: #define ENDFUNCTION(f) #endif + +// Names for argument and result registers + +#if defined(SYS_cygwin) +#define INT_ARG_1 %rcx +#else +#define INT_ARG_1 %rdi +#endif +#define FP_ARG_1 %xmm0 +#define INT_RES %rax +#define FP_RES %xmm0 + diff --git a/runtime/x86_64/vararg.S b/runtime/x86_64/vararg.S index 9c0d787b..c5225b34 100644 --- a/runtime/x86_64/vararg.S +++ b/runtime/x86_64/vararg.S @@ -34,6 +34,12 @@ // Helper functions for variadic functions <stdarg.h>. x86_64 version. +#include "sysdeps.h" + +// ELF ABI + +#if defined(SYS_linux) || defined(SYS_bsd) || defined(SYS_macosx) + // typedef struct { // unsigned int gp_offset; // unsigned int fp_offset; @@ -60,8 +66,6 @@ // unsigned long long __compcert_va_int64(va_list ap); // double __compcert_va_float64(va_list ap); -#include "sysdeps.h" - FUNCTION(__compcert_va_int32) movl 0(%rdi), %edx // edx = gp_offset cmpl $48, %edx @@ -146,3 +150,58 @@ FUNCTION(__compcert_va_saveregs) movaps %xmm7, 160(%r10) 1: ret ENDFUNCTION(__compcert_va_saveregs) + +#endif + +// Windows ABI + +#if defined(SYS_cygwin) + +// typedef void * va_list; +// unsigned int __compcert_va_int32(va_list * ap); +// unsigned long long __compcert_va_int64(va_list * ap); +// double __compcert_va_float64(va_list * ap); + +FUNCTION(__compcert_va_int32) // %rcx = pointer to argument pointer + movq 0(%rcx), %rdx // %rdx = current argument pointer + movl 0(%rdx), %eax // load the int32 value there + addq $8, %rdx // increment argument pointer by 8 + movq %rdx, 0(%rcx) + ret +ENDFUNCTION(__compcert_va_int32) + +FUNCTION(__compcert_va_int64) // %rcx = pointer to argument pointer + movq 0(%rcx), %rdx // %rdx = current argument pointer + movq 0(%rdx), %rax // load the int64 value there + addq $8, %rdx // increment argument pointer by 8 + movq %rdx, 0(%rcx) + ret +ENDFUNCTION(__compcert_va_int64) + +FUNCTION(__compcert_va_float64) // %rcx = pointer to argument pointer + movq 0(%rcx), %rdx // %rdx = current argument pointer + movsd 0(%rdx), %xmm0 // load the float64 value there + addq $8, %rdx // increment argument pointer by 8 + movq %rdx, 0(%rcx) + ret +ENDFUNCTION(__compcert_va_float64) + +FUNCTION(__compcert_va_composite) + jmp GLOB(__compcert_va_int64) // by-ref convention, FIXME +ENDFUNCTION(__compcert_va_composite) + +// Save arguments passed in register in the stack at beginning of vararg +// function. The caller of the vararg function reserved 32 bytes of stack +// just for this purpose. +// FP arguments are passed both in FP registers and integer registers, +// so it's enough to save the integer registers used for parameter passing. + +FUNCTION(__compcert_va_saveregs) + movq %rcx, 16(%rsp) + movq %rdx, 24(%rsp) + movq %r8, 32(%rsp) + movq %r9, 40(%rsp) + ret +ENDFUNCTION(__compcert_va_saveregs) + +#endif diff --git a/kvx/InstructionScheduler.ml b/scheduling/InstructionScheduler.ml index eab0b21a..eab0b21a 100644 --- a/kvx/InstructionScheduler.ml +++ b/scheduling/InstructionScheduler.ml diff --git a/kvx/InstructionScheduler.mli b/scheduling/InstructionScheduler.mli index 85e2a5c6..fb7af3f6 100644 --- a/kvx/InstructionScheduler.mli +++ b/scheduling/InstructionScheduler.mli @@ -33,6 +33,12 @@ type problem = { (** Print problem for human readability. *) val print_problem : out_channel -> problem -> unit;; +(** Get the number of instructions in a problem *) +val get_nr_instructions : problem -> int;; + +(** Get the number of resources in a problem *) +val get_nr_resources : problem -> int;; + (** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) type solution = int array diff --git a/scheduling/RTLpath.v b/scheduling/RTLpath.v new file mode 100644 index 00000000..35512652 --- /dev/null +++ b/scheduling/RTLpath.v @@ -0,0 +1,1067 @@ +(** We introduce a data-structure extending the RTL CFG into a control-flow graph over "traces" (in the sense of "trace-scheduling") + Here, we use the word "path" instead of "trace" because "trace" has already a meaning in CompCert: + a "path" is simply a list of successive nodes in the CFG (modulo some additional wellformness conditions). + + Actually, we extend syntactically the notion of RTL programs with a structure of "path_map": + this gives an alternative view of the CFG -- where "nodes" are paths instead of simple instructions. + Our wellformness condition on paths express that: + - the CFG on paths is wellformed: any successor of a given path points to another path (possibly the same). + - execution of a paths only emit single events. + + We represent each path only by a natural: the number of nodes in the path. These nodes are recovered from a static notion of "default successor". + This notion of path is thus incomplete. For example, if a path contains a whole loop (and for example, unrools it several times), + then this loop must be a suffix of the path. + + However: it is sufficient in order to represent superblocks (each superblock being represented as a path). + A superblock decomposition of the CFG exactly corresponds to the case where each node is in at most one path. + + Our goal is to provide two bisimulable semantics: + - one is simply the RTL semantics + - the other is based on a notion of "path-step": each path is executed in a single step. + + Remark that all analyses on RTL programs should thus be appliable for "free" also for RTLpath programs ! +*) + +Require Import Coqlib Maps. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL Linking. + +Declare Scope option_monad_scope. + +Notation "'SOME' X <- A 'IN' B" := (match A with Some X => B | None => None end) + (at level 200, X ident, A at level 100, B at level 200) + : option_monad_scope. + +Notation "'ASSERT' A 'IN' B" := (if A then B else None) + (at level 200, A at level 100, B at level 200) + : option_monad_scope. + +Local Open Scope option_monad_scope. + +(** * Syntax of RTLpath programs *) + +(** Internal instruction = instruction with a default successor in a path. *) + +Definition default_succ (i: instruction): option node := + match i with + | Inop s => Some s + | Iop op args res s => Some s + | Iload _ chunk addr args dst s => Some s + | Istore chunk addr args src s => Some s + | Icond cond args ifso ifnot _ => Some ifnot + | _ => None (* TODO: we could choose a successor for jumptable ? *) + end. + +Definition early_exit (i: instruction): option node := (* FIXME: for jumptable, replace [node] by [list node] *) + match i with + | Icond cond args ifso ifnot _ => Some ifso + | _ => None + end. + +(** Our notion of path. + + We do not formally require that the set of path is a partition of the CFG. + path may have intersections ! + + Moreover, we do not formally require that path have a single entry-point (a superblock structure) + + But, in practice, these properties are probably necessary in order to ensure the success of dynamic verification of scheduling. + + Here: we only require that each exit-point of a path is the entry-point of a path + (and that internal node of a path are internal instructions) +*) + + +(* By convention, we say that node [n] is the entry-point of a path if it is a key of the path_map. + + Such a path of entry [n] is defined from a natural [path] representing the [path] default-successors of [n]. + + Remark: a path can loop several times in the CFG. + +*) + +Record path_info := { + psize: nat; (* number minus 1 of instructions in the path *) + input_regs: Regset.t; + (** Registers that are used (as input_regs) by the "fallthrough successors" of the path *) + (** This field is not used by the verificator, but is helpful for the superblock scheduler *) + output_regs: Regset.t +}. + +Definition path_map: Type := PTree.t path_info. + +Definition path_entry (*c:code*) (pm: path_map) (n: node): Prop + := pm!n <> None (*/\ c!n <> None*). + +Inductive wellformed_path (c:code) (pm: path_map): nat -> node -> Prop := + | wf_last_node i pc: + c!pc = Some i -> + (forall n, List.In n (successors_instr i) -> path_entry (*c*) pm n) -> + wellformed_path c pm 0 pc + | wf_internal_node path i pc pc': + c!pc = Some i -> + default_succ i = Some pc' -> + (forall n, early_exit i = Some n -> path_entry (*c*) pm n) -> + wellformed_path c pm path pc' -> + wellformed_path c pm (S path) pc. + +(* all paths defined from the path_map are wellformed *) +Definition wellformed_path_map (c:code) (pm: path_map): Prop := + forall n path, pm!n = Some path -> wellformed_path c pm path.(psize) n. + +(** We "extend" the notion of RTL program with the additional structure for path. + + There is thus a trivial "forgetful functor" from RTLpath programs to RTL ones. +*) + +Record function : Type := + { fn_RTL:> RTL.function; + fn_path: path_map; + (* condition 1 below: the entry-point of the code is an entry-point of a path *) + fn_entry_point_wf: path_entry (*fn_RTL.(fn_code)*) fn_path fn_RTL.(fn_entrypoint); + (* condition 2 below: the path_map is well-formed *) + fn_path_wf: wellformed_path_map fn_RTL.(fn_code) fn_path + }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition fundef_RTL (fu: fundef) : RTL.fundef := + match fu with + | Internal f => Internal f.(fn_RTL) + | External ef => External ef + end. +Coercion fundef_RTL: fundef >-> RTL.fundef. + +Definition transf_program (p: program) : RTL.program := transform_program fundef_RTL p. +Coercion transf_program: program >-> RTL.program. + +(** * Path-step semantics of RTLpath programs *) + +(* Semantics of internal instructions (mimicking RTL semantics) *) + +Record istate := mk_istate { icontinue: bool; ipc: node; irs: regset; imem: mem }. + +(* FIXME - prediction *) +(* Internal step through the path *) +Definition istep (ge: RTL.genv) (i: instruction) (sp: val) (rs: regset) (m: mem): option istate := + match i with + | Inop pc' => Some (mk_istate true pc' rs m) + | Iop op args res pc' => + SOME v <- eval_operation ge sp op rs##args m IN + Some (mk_istate true pc' (rs#res <- v) m) + | Iload TRAP chunk addr args dst pc' => + SOME a <- eval_addressing ge sp addr rs##args IN + SOME v <- Mem.loadv chunk m a IN + Some (mk_istate true pc' (rs#dst <- v) m) + | Iload NOTRAP chunk addr args dst pc' => + let default_state := mk_istate true pc' rs#dst <- (default_notrap_load_value chunk) m in + match (eval_addressing ge sp addr rs##args) with + | None => Some default_state + | Some a => match (Mem.loadv chunk m a) with + | None => Some default_state + | Some v => Some (mk_istate true pc' (rs#dst <- v) m) + end + end + | Istore chunk addr args src pc' => + SOME a <- eval_addressing ge sp addr rs##args IN + SOME m' <- Mem.storev chunk m a rs#src IN + Some (mk_istate true pc' rs m') + | Icond cond args ifso ifnot _ => + SOME b <- eval_condition cond rs##args m IN + Some (mk_istate (negb b) (if b then ifso else ifnot) rs m) + | _ => None (* TODO jumptable ? *) + end. + +(** Execution of a path in a single step *) + +(* Executes until a state [st] is reached where st.(continue) is false *) +Fixpoint isteps ge (path:nat) (f: function) sp rs m pc: option istate := + match path with + | O => Some (mk_istate true pc rs m) + | S p => + SOME i <- (fn_code f)!pc IN + SOME st <- istep ge i sp rs m IN + if (icontinue st) then + isteps ge p f sp (irs st) (imem st) (ipc st) + else + Some st + end. + +Definition find_function (pge: genv) (ros: reg + ident) (rs: regset) : option fundef := + match ros with + | inl r => Genv.find_funct pge rs#r + | inr symb => + match Genv.find_symbol pge symb with + | None => None + | Some b => Genv.find_funct_ptr pge b + end + end. + +Inductive stackframe : Type := + | Stackframe + (res: reg) (**r where to store the result *) + (f: function) (**r calling function *) + (sp: val) (**r stack pointer in calling function *) + (pc: node) (**r program point in calling function *) + (rs: regset) (**r register state in calling function *) + . + +Definition stf_RTL (st: stackframe): RTL.stackframe := + match st with + | Stackframe res f sp pc rs => RTL.Stackframe res f sp pc rs + end. + +Fixpoint stack_RTL (stack: list stackframe): list RTL.stackframe := + match stack with + | nil => nil + | cons stf stack' => cons (stf_RTL stf) (stack_RTL stack') + end. + +Inductive state : Type := + | State + (stack: list stackframe) (**r call stack *) + (f: function) (**r current function *) + (sp: val) (**r stack pointer *) + (pc: node) (**r current program point in [c] *) + (rs: regset) (**r register state *) + (m: mem) (**r memory state *) + | Callstate + (stack: list stackframe) (**r call stack *) + (f: fundef) (**r function to call *) + (args: list val) (**r arguments to the call *) + (m: mem) (**r memory state *) + | Returnstate + (stack: list stackframe) (**r call stack *) + (v: val) (**r return value for the call *) + (m: mem) (**r memory state *) + . + +Definition state_RTL (s: state): RTL.state := + match s with + | State stack f sp pc rs m => RTL.State (stack_RTL stack) f sp pc rs m + | Callstate stack f args m => RTL.Callstate (stack_RTL stack) f args m + | Returnstate stack v m => RTL.Returnstate (stack_RTL stack) v m + end. +Coercion state_RTL: state >-> RTL.state. + +(* Used to execute the last instruction of a path (isteps is only in charge of executing the instructions before the last) *) +Inductive path_last_step ge pge stack (f: function): val -> node -> regset -> mem -> trace -> state -> Prop := + | exec_istate i sp pc rs m st: + (fn_code f)!pc = Some i -> + istep ge i sp rs m = Some st -> + path_last_step ge pge stack f sp pc rs m + E0 (State stack f sp (ipc st) (irs st) (imem st)) + | exec_Icall sp pc rs m sig ros args res pc' fd: + (fn_code f)!pc = Some(Icall sig ros args res pc') -> + find_function pge ros rs = Some fd -> + funsig fd = sig -> + path_last_step ge pge stack f sp pc rs m + E0 (Callstate (Stackframe res f sp pc' rs :: stack) fd rs##args m) + | exec_Itailcall stk pc rs m sig ros args fd m': + (fn_code f)!pc = Some(Itailcall sig ros args) -> + find_function pge ros rs = Some fd -> + funsig fd = sig -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + path_last_step ge pge stack f (Vptr stk Ptrofs.zero) pc rs m + E0 (Callstate stack fd rs##args m') + | exec_Ibuiltin sp pc rs m ef args res pc' vargs t vres m': + (fn_code f)!pc = Some(Ibuiltin ef args res pc') -> + eval_builtin_args ge (fun r => rs#r) sp m args vargs -> + external_call ef ge vargs m t vres m' -> + path_last_step ge pge stack f sp pc rs m + t (State stack f sp pc' (regmap_setres res vres rs) m') + | exec_Ijumptable sp pc rs m arg tbl n pc': (* TODO remove jumptable from here ? *) + (fn_code f)!pc = Some(Ijumptable arg tbl) -> + rs#arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> + path_last_step ge pge stack f sp pc rs m + E0 (State stack f sp pc' rs m) + | exec_Ireturn stk pc rs m or m': + (fn_code f)!pc = Some(Ireturn or) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + path_last_step ge pge stack f (Vptr stk Ptrofs.zero) pc rs m + E0 (Returnstate stack (regmap_optget or Vundef rs) m'). + +(* Executes an entire path *) +Inductive path_step ge pge (path:nat) stack f sp rs m pc: trace -> state -> Prop := + | exec_early_exit st: + isteps ge path f sp rs m pc = Some st -> + (icontinue st) = false -> + path_step ge pge path stack f sp rs m pc E0 (State stack f sp (ipc st) (irs st) (imem st)) + | exec_normal_exit st t s: + isteps ge path f sp rs m pc = Some st -> + (icontinue st) = true -> + path_last_step ge pge stack f sp (ipc st) (irs st) (imem st) t s -> + path_step ge pge path stack f sp rs m pc t s. + +(* Either internal path execution, or the usual exec_function / exec_return borrowed from RTL *) +Inductive step ge pge: state -> trace -> state -> Prop := + | exec_path path stack f sp rs m pc t s: + (fn_path f)!pc = Some path -> + path_step ge pge path.(psize) stack f sp rs m pc t s -> + step ge pge (State stack f sp pc rs m) t s + | exec_function_internal s f args m m' stk: + Mem.alloc m 0 (fn_RTL f).(fn_stacksize) = (m', stk) -> + step ge pge (Callstate s (Internal f) args m) + E0 (State s + f + (Vptr stk Ptrofs.zero) + f.(fn_entrypoint) + (init_regs args f.(fn_params)) + m') + | exec_function_external s ef args res t m m': + external_call ef ge args m t res m' -> + step ge pge (Callstate s (External ef) args m) + t (Returnstate s res m') + | exec_return res f sp pc rs s vres m: + step ge pge (Returnstate (Stackframe res f sp pc rs :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) m). + +Inductive initial_state (p:program) : state -> Prop := + initial_state_intro (b : block) (f : fundef) (m0 : mem): + Genv.init_mem p = Some m0 -> + Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b -> + Genv.find_funct_ptr (Genv.globalenv p) b = Some f -> + funsig f = signature_main -> initial_state p (Callstate nil f nil m0). + +Definition final_state (st: state) (i:int): Prop + := RTL.final_state st i. + +Definition semantics (p: program) := + Semantics (step (Genv.globalenv (transf_program p))) (initial_state p) final_state (Genv.globalenv p). + +(** * Proving the bisimulation between (semantics p) and (RTL.semantics p). *) + +(** ** Preliminaries: simple tactics for option-monad *) + +Lemma destruct_SOME A B (P: option B -> Prop) (e: option A) (f: A -> option B): + (forall x, e = Some x -> P (f x)) -> (e = None -> P None) -> (P (SOME x <- e IN f x)). +Proof. + intros; destruct e; simpl; auto. +Qed. + +Lemma destruct_ASSERT B (P: option B -> Prop) (e: bool) (x: option B): + (e = true -> P x) -> (e = false -> P None) -> (P (ASSERT e IN x)). +Proof. + intros; destruct e; simpl; auto. +Qed. + +Ltac inversion_SOME x := + try (eapply destruct_SOME; [ let x := fresh x in intro x | simpl; try congruence ]). + +Ltac inversion_ASSERT := + try (eapply destruct_ASSERT; [ idtac | simpl; try congruence ]). + +Ltac simplify_someHyp := + match goal with + | H: None = Some _ |- _ => inversion H; clear H; subst + | H: Some _ = None |- _ => inversion H; clear H; subst + | H: ?t = ?t |- _ => clear H + | H: Some _ = Some _ |- _ => inversion H; clear H; subst + | H: Some _ <> None |- _ => clear H + | H: None <> Some _ |- _ => clear H + | H: _ = Some _ |- _ => (try rewrite !H in * |- *); generalize H; clear H + | H: _ = None |- _ => (try rewrite !H in * |- *); generalize H; clear H + end. + +Ltac explore_destruct := + repeat (match goal with + | [H: ?expr = ?val |- context[match ?expr with | _ => _ end]] => rewrite H + | [H: match ?var with | _ => _ end |- _] => destruct var + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | _ => discriminate + end). + +Ltac simplify_someHyps := + repeat (simplify_someHyp; simpl in * |- *). + +Ltac try_simplify_someHyps := + try (intros; simplify_someHyps; eauto). + +(* TODO: try to improve this tactic with a better control over names and inversion *) +Ltac simplify_SOME x := + (repeat inversion_SOME x); try_simplify_someHyps. + +(** ** The easy way: Forward simulation of RTLpath by RTL + +This way can be viewed as a correctness property: all transitions in RTLpath are valid RTL transitions ! + +*) + +Local Hint Resolve RTL.exec_Inop RTL.exec_Iop RTL.exec_Iload RTL.exec_Istore RTL.exec_Icond RTL.exec_Iload_notrap1 RTL.exec_Iload_notrap2: core. + +(* istep reflects RTL.step *) +Lemma istep_correct ge i stack (f:function) sp rs m st : + istep ge i sp rs m = Some st -> + forall pc, (fn_code f)!pc = Some i -> + RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + destruct i; simpl; try congruence; simplify_SOME x. + 1-3: explore_destruct; simplify_SOME x. +Qed. + +Local Hint Resolve star_refl: core. + +(* isteps reflects a star relation on RTL.step *) +Lemma isteps_correct ge path stack f sp: forall rs m pc st, + isteps ge path f sp rs m pc = Some st -> + star RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + induction path; simpl; try_simplify_someHyps. + inversion_SOME i; intros Hi. + inversion_SOME st0; intros Hst0. + destruct (icontinue st0) eqn:cont. + + intros; eapply star_step. + - eapply istep_correct; eauto. + - simpl; eauto. + - auto. + + intros; simplify_someHyp; eapply star_step. + - eapply istep_correct; eauto. + - simpl; eauto. + - auto. +Qed. + +Lemma isteps_correct_early_exit ge path stack f sp: forall rs m pc st, + isteps ge path f sp rs m pc = Some st -> + st.(icontinue) = false -> + plus RTL.step ge (State stack f sp pc rs m) E0 (State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + destruct path; simpl; try_simplify_someHyps; try congruence. + inversion_SOME i; intros Hi. + inversion_SOME st0; intros Hst0. + destruct (icontinue st0) eqn:cont. + + intros; eapply plus_left. + - eapply istep_correct; eauto. + - eapply isteps_correct; eauto. + - auto. + + intros X; inversion X; subst. + eapply plus_one. + eapply istep_correct; eauto. +Qed. + +Local Hint Resolve list_forall2_nil match_globdef_fun linkorder_refl match_globvar_intro: core. + +Section CORRECTNESS. + +Variable p: program. + +Lemma match_prog_RTL: match_program (fun _ f tf => tf = fundef_RTL f) eq p (transf_program p). +Proof. + eapply match_transform_program; eauto. +Qed. + +Let pge := Genv.globalenv p. +Let ge := Genv.globalenv (transf_program p). + +Lemma senv_preserved: Senv.equiv pge ge. +Proof (Genv.senv_match match_prog_RTL). + +Lemma symbols_preserved s: Genv.find_symbol ge s = Genv.find_symbol pge s. +Proof (Genv.find_symbol_match match_prog_RTL s). + +Lemma find_function_RTL_match ros rs fd: + find_function pge ros rs = Some fd -> RTL.find_function ge ros rs = Some (fundef_RTL fd). +Proof. + destruct ros; simpl. + + intro; exploit (Genv.find_funct_match match_prog_RTL); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; auto. + + rewrite symbols_preserved. + destruct (Genv.find_symbol pge i); simpl; try congruence. + intro; exploit (Genv.find_funct_ptr_match match_prog_RTL); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; auto. +Qed. + +Local Hint Resolve istep_correct RTL.exec_Ibuiltin RTL.exec_Ijumptable RTL.exec_Ireturn RTL.exec_Icall RTL.exec_Itailcall find_function_RTL_match: core. + +Lemma path_last_step_correct stack f sp pc rs m t s: + path_last_step ge pge stack f sp pc rs m t s -> + RTL.step ge (State stack f sp pc rs m) t s. +Proof. + destruct 1; try (eapply istep_correct); simpl; eauto. +Qed. + +Lemma path_step_correct path stack f sp pc rs m t s: + path_step ge pge path stack f sp rs m pc t s -> + plus RTL.step ge (State stack f sp pc rs m) t s. +Proof. + destruct 1. + + eapply isteps_correct_early_exit; eauto. + + eapply plus_right. + eapply isteps_correct; eauto. + eapply path_last_step_correct; eauto. + auto. +Qed. + +Local Hint Resolve plus_one RTL.exec_function_internal RTL.exec_function_external RTL.exec_return: core. + +Lemma step_correct s t s': step ge pge s t s' -> plus RTL.step ge s t s'. +Proof. + destruct 1; try (eapply path_step_correct); simpl; eauto. +Qed. + +Theorem RTLpath_correct: forward_simulation (semantics p) (RTL.semantics p). +Proof. + eapply forward_simulation_plus with (match_states := fun s1 s2 => s2 = state_RTL s1); simpl; auto. + - apply senv_preserved. + - destruct 1; intros; eexists; intuition eauto. econstructor; eauto. + + apply (Genv.init_mem_match match_prog_RTL); auto. + + rewrite (Genv.find_symbol_match match_prog_RTL). + rewrite (match_program_main match_prog_RTL); eauto. + + exploit (Genv.find_funct_ptr_match match_prog_RTL); eauto. + intros (cunit & tf0 & XX); intuition subst; eauto. + - unfold final_state; intros; subst; eauto. + - intros; subst. eexists; intuition. + eapply step_correct; eauto. +Qed. + +End CORRECTNESS. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +(* Definition transf_program : RTLpath.program -> RTL.program := transform_program fundef_RTL. + +Lemma transf_program_proj: forall p, transf_program (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. *) + + +(** The hard way: Forward simulation of RTL by RTLpath + +This way can be viewed as a completeness property: all transitions in RTL can be represented as RTLpath transitions ! + +*) + +(* This lemma is probably needed to compose a pass from RTL -> RTLpath with other passes.*) +Lemma match_RTL_prog {LA: Linker fundef} {LV: Linker unit} p: match_program (fun _ f tf => f = fundef_RTL tf) eq (transf_program p) p. +Proof. + unfold match_program, match_program_gen; intuition. + unfold transf_program at 2; simpl. + generalize (prog_defs p). + induction l as [|a l]; simpl; eauto. + destruct a; simpl. + intros; eapply list_forall2_cons; eauto. + unfold match_ident_globdef; simpl; intuition; destruct g as [f|v]; simpl; eauto. + eapply match_globdef_var. destruct v; eauto. +Qed. + +(* Theory of wellformed paths *) + +Fixpoint nth_default_succ (c: code) (path:nat) (pc: node): option node := + match path with + | O => Some pc + | S path' => + SOME i <- c!pc IN + SOME pc' <- default_succ i IN + nth_default_succ c path' pc' + end. + +Lemma wellformed_suffix_path c pm path path': + (path' <= path)%nat -> + forall pc, wellformed_path c pm path pc -> + exists pc', nth_default_succ c (path-path') pc = Some pc' /\ wellformed_path c pm path' pc'. +Proof. + induction 1 as [|m]. + + intros. enough (path'-path'=0)%nat as ->; [simpl;eauto|omega]. + + intros pc WF; enough (S m-path'=S (m-path'))%nat as ->; [simpl;eauto|omega]. + inversion WF; subst; clear WF; intros; simplify_someHyps. + intros; simplify_someHyps; eauto. +Qed. + +Definition nth_default_succ_inst (c: code) (path:nat) pc: option instruction := + SOME pc <- nth_default_succ c path pc IN + c!pc. + +Lemma final_node_path f path pc: + (fn_path f)!pc = Some path -> + exists i, nth_default_succ_inst (fn_code f) path.(psize) pc = Some i + /\ (forall n, List.In n (successors_instr i) -> path_entry (*fn_code f*) (fn_path f) n). +Proof. + intros; exploit fn_path_wf; eauto. + intro WF. + set (ps:=path.(psize)). + exploit (wellformed_suffix_path (fn_code f) (fn_path f) ps O); omega || eauto. + destruct 1 as (pc' & NTH_SUCC & WF'); auto. + assert (ps - 0 = ps)%nat as HH by omega. rewrite HH in NTH_SUCC. clear HH. + unfold nth_default_succ_inst. + inversion WF'; clear WF'; subst. simplify_someHyps; eauto. +Qed. + +Lemma internal_node_path path f path0 pc: + (fn_path f)!pc = (Some path0) -> + (path < path0.(psize))%nat -> + exists i pc', + nth_default_succ_inst (fn_code f) path pc = Some i /\ + default_succ i = Some pc' /\ + (forall n, early_exit i = Some n -> path_entry (*fn_code f*) (fn_path f) n). +Proof. + intros; exploit fn_path_wf; eauto. + set (ps:=path0.(psize)). + intro WF; exploit (wellformed_suffix_path (fn_code f) (fn_path f) ps (ps-path)); eauto. { omega. } + destruct 1 as (pc' & NTH_SUCC & WF'). + assert (ps - (ps - path) = path)%nat as HH by omega. rewrite HH in NTH_SUCC. clear HH. + unfold nth_default_succ_inst. + inversion WF'; clear WF'; subst. { omega. } + simplify_someHyps; eauto. +Qed. + +Lemma initialize_path (*c*) pm n: path_entry (*c*) pm n -> exists path, pm!n = Some path. +Proof. + unfold path_entry; destruct pm!n; eauto. intuition congruence. +Qed. +Local Hint Resolve fn_entry_point_wf: core. +Local Opaque path_entry. + +Lemma istep_successors ge i sp rs m st: + istep ge i sp rs m = Some st -> + In (ipc st) (successors_instr i). +Proof. + destruct i; simpl; try congruence; simplify_SOME x. + all: explore_destruct; simplify_SOME x. +Qed. + +Lemma istep_normal_exit ge i sp rs m st: + istep ge i sp rs m = Some st -> + st.(icontinue) = true -> + default_succ i = Some st.(ipc). +Proof. + destruct i; simpl; try congruence; simplify_SOME x. + all: explore_destruct; simplify_SOME x. +Qed. + +Lemma isteps_normal_exit ge path f sp: forall rs m pc st, + st.(icontinue) = true -> + isteps ge path f sp rs m pc = Some st -> + nth_default_succ (fn_code f) path pc = Some st.(ipc). +Proof. + induction path; simpl. { try_simplify_someHyps. } + intros rs m pc st CONT; try_simplify_someHyps. + inversion_SOME i; intros Hi. + inversion_SOME st0; intros Hst0. + destruct (icontinue st0) eqn:X; try congruence. + try_simplify_someHyps. + intros; erewrite istep_normal_exit; eauto. +Qed. + + +(* TODO: the three following lemmas could maybe simplified by introducing an auxiliary + left-recursive definition equivalent to isteps ? +*) +Lemma isteps_step_right ge path f sp: forall rs m pc st i, + isteps ge path f sp rs m pc = Some st -> + st.(icontinue) = true -> + (fn_code f)!(st.(ipc)) = Some i -> + istep ge i sp st.(irs) st.(imem) = isteps ge (S path) f sp rs m pc. +Proof. + induction path. + + simpl; intros; try_simplify_someHyps. simplify_SOME st. + destruct st as [b]; destruct b; simpl; auto. + + intros rs m pc st i H. + simpl in H. + generalize H; clear H; simplify_SOME xx. + destruct (icontinue xx0) eqn: CONTxx0. + * intros; erewrite IHpath; eauto. + * intros; congruence. +Qed. + +Lemma isteps_inversion_early ge path f sp: forall rs m pc st, + isteps ge path f sp rs m pc = Some st -> + (icontinue st)=false -> + exists st0 i path0, + (path > path0)%nat /\ + isteps ge path0 f sp rs m pc = Some st0 /\ + st0.(icontinue) = true /\ + (fn_code f)!(st0.(ipc)) = Some i /\ + istep ge i sp st0.(irs) st0.(imem) = Some st. +Proof. + induction path as [|path]; simpl. + - intros; try_simplify_someHyps; try congruence. + - intros rs m pc st; inversion_SOME i; inversion_SOME st0. + destruct (icontinue st0) eqn: CONT. + + intros STEP PC STEPS CONT0. exploit IHpath; eauto. + clear STEPS. + intros (st1 & i0 & path0 & BOUND & STEP1 & CONT1 & X1 & X2); auto. + exists st1. exists i0. exists (S path0). intuition. + simpl; try_simplify_someHyps. + rewrite CONT. auto. + + intros; try_simplify_someHyps; try congruence. + eexists. exists i. exists O; simpl. intuition eauto. + omega. +Qed. + +Lemma isteps_resize ge path0 path1 f sp rs m pc st: + (path0 <= path1)%nat -> + isteps ge path0 f sp rs m pc = Some st -> + (icontinue st)=false -> + isteps ge path1 f sp rs m pc = Some st. +Proof. + induction 1 as [|path1]; simpl; auto. + intros PSTEP CONT. exploit IHle; auto. clear PSTEP IHle H path0. + generalize rs m pc st CONT; clear rs m pc st CONT. + induction path1 as [|path]; simpl; auto. + - intros; try_simplify_someHyps; try congruence. + - intros rs m pc st; inversion_SOME i; inversion_SOME st0; intros; try_simplify_someHyps. + destruct (icontinue st0) eqn: CONT0; eauto. +Qed. + +(* FIXME - add prediction *) +Inductive is_early_exit pc: instruction -> Prop := + | Icond_early_exit cond args ifnot predict: + is_early_exit pc (Icond cond args pc ifnot predict) + . (* TODO add jumptable here ? *) + +Lemma istep_early_exit ge i sp rs m st : + istep ge i sp rs m = Some st -> + st.(icontinue) = false -> + st.(irs) = rs /\ st.(imem) = m /\ is_early_exit st.(ipc) i. +Proof. + Local Hint Resolve Icond_early_exit: core. + destruct i; simpl; try congruence; simplify_SOME b; simpl; try congruence. + all: explore_destruct; simplify_SOME b; try discriminate. +Qed. + +Section COMPLETENESS. + +Variable p: program. + +Let pge := Genv.globalenv p. +Let ge := Genv.globalenv (transf_program p). + +Lemma find_funct_ptr_RTL_preserv b f: + Genv.find_funct_ptr ge b = Some f -> (exists f0, Genv.find_funct_ptr pge b = Some f0 /\ f = f0). +Proof. + intros; exploit (Genv.find_funct_ptr_match (match_RTL_prog p)); eauto. + destruct 1 as (cunit & tf & X & Y & Z); subst. + eauto. +Qed. + +Lemma find_RTL_function_match ros rs fd: + RTL.find_function ge ros rs = Some fd -> exists fd', fd = fundef_RTL fd' /\ find_function pge ros rs = Some fd'. +Proof. + destruct ros; simpl. + + intro; exploit (Genv.find_funct_match (match_RTL_prog p)); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; eauto. + + rewrite (symbols_preserved p); unfold pge. + destruct (Genv.find_symbol (Genv.globalenv p) i); simpl; try congruence. + intro; exploit find_funct_ptr_RTL_preserv; eauto. + intros (tf & H1 & H2); subst; eauto. +Qed. + + +(** *** Definition of well-formed stacks and of match_states *) +Definition wf_stf (st: stackframe): Prop := + match st with + | Stackframe res f sp pc rs => path_entry (*f.(fn_code)*) f.(fn_path) pc + end. + +Definition wf_stackframe (stack: list stackframe): Prop := + forall st, List.In st stack -> wf_stf st. + +Lemma wf_stackframe_nil: wf_stackframe nil. +Proof. + unfold wf_stackframe; simpl. tauto. +Qed. +Local Hint Resolve wf_stackframe_nil: core. + +Lemma wf_stackframe_cons st stack: + wf_stackframe (st::stack) <-> (wf_stf st) /\ wf_stackframe stack. +Proof. + unfold wf_stackframe; simpl; intuition (subst; auto). +Qed. + +Definition stack_of (s: state): list stackframe := + match s with + | State stack f sp pc rs m => stack + | Callstate stack f args m => stack + | Returnstate stack v m => stack + end. + +Definition is_inst (s: RTL.state): bool := + match s with + | RTL.State stack f sp pc rs m => true + | _ => false + end. + +Inductive match_inst_states_goal (idx: nat) (s1:RTL.state): state -> Prop := + | State_match path stack f sp pc rs m s2: + (fn_path f)!pc = Some path -> + (idx <= path.(psize))%nat -> + isteps ge (path.(psize)-idx) f sp rs m pc = Some s2 -> + s1 = State stack f sp s2.(ipc) s2.(irs) s2.(imem) -> + match_inst_states_goal idx s1 (State stack f sp pc rs m). + +Definition match_inst_states (idx: nat) (s1:RTL.state) (s2:state): Prop := + if is_inst s1 then match_inst_states_goal idx s1 s2 else s1 = state_RTL s2. + +Definition match_states (idx: nat) (s1:RTL.state) (s2:state): Prop := + match_inst_states idx s1 s2 + /\ wf_stackframe (stack_of s2). + +(** *** Auxiliary lemmas of completeness *) +Lemma istep_complete t i stack f sp rs m pc s': + RTL.step ge (State stack f sp pc rs m) t s' -> + (fn_code f)!pc = Some i -> + default_succ i <> None -> + t = E0 /\ exists st, istep ge i sp rs m = Some st /\ s'=(State stack f sp st.(ipc) st.(irs) st.(imem)). +Proof. + intros H X; inversion H; simpl; subst; try rewrite X in * |-; clear X; simplify_someHyps; try congruence; + (split; auto); simplify_someHyps; eexists; split; simplify_someHyps; eauto. + all: explore_destruct; simplify_SOME a. +Qed. + +Lemma stuttering path idx stack f sp rs m pc st t s1': + isteps ge (path.(psize)-(S idx)) f sp rs m pc = Some st -> + (fn_path f)!pc = Some path -> + (S idx <= path.(psize))%nat -> + st.(icontinue) = true -> + RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> + t = E0 /\ match_inst_states idx s1' (State stack f sp pc rs m). +Proof. + intros PSTEP PATH BOUND CONT RSTEP; exploit (internal_node_path (path.(psize)-(S idx))); omega || eauto. + intros (i & pc' & Hi & Hpc & DUM). + unfold nth_default_succ_inst in Hi. + erewrite isteps_normal_exit in Hi; eauto. + exploit istep_complete; congruence || eauto. + intros (SILENT & st0 & STEP0 & EQ). + intuition; subst; unfold match_inst_states; simpl. + intros; refine (State_match _ _ path stack f sp pc rs m _ PATH _ _ _); simpl; omega || eauto. + set (ps:=path.(psize)). enough (ps - idx = S (ps - (S idx)))%nat as ->; try omega. + erewrite <- isteps_step_right; eauto. +Qed. + +Lemma normal_exit path stack f sp rs m pc st t s1': + isteps ge path.(psize) f sp rs m pc = Some st -> + (fn_path f)!pc = Some path -> + st.(icontinue) = true -> + RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> + wf_stackframe stack -> + exists s2', + (path_last_step ge pge stack f sp st.(ipc) st.(irs) st.(imem)) t s2' + /\ (exists idx', match_states idx' s1' s2'). +Proof. + Local Hint Resolve istep_successors list_nth_z_in: core. (* Hint for path_entry proofs *) + intros PSTEP PATH CONT RSTEP WF; exploit (final_node_path f path); eauto. + intros (i & Hi & SUCCS). + unfold nth_default_succ_inst in Hi. + erewrite isteps_normal_exit in Hi; eauto. + destruct (default_succ i) eqn:Hn0. + + (* exec_istate *) + exploit istep_complete; congruence || eauto. + intros (SILENT & st0 & STEP0 & EQ); subst. + exploit (exec_istate ge pge); eauto. + eexists; intuition eauto. + unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) (ipc st0)) as (path0 & Hpath0); eauto. + exists (path0.(psize)); intuition eauto. + econstructor; eauto. + * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. + * simpl; eauto. + + generalize Hi; inversion RSTEP; clear RSTEP; subst; (repeat (simplify_someHyp; simpl in * |- * )); try congruence; eauto. + - (* Icall *) + intros; exploit find_RTL_function_match; eauto. + intros (fd' & MATCHfd & Hfd'); subst. + exploit (exec_Icall ge pge); eauto. + eexists; intuition eauto. + eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. + rewrite wf_stackframe_cons; intuition simpl; eauto. + - (* Itailcall *) + intros; exploit find_RTL_function_match; eauto. + intros (fd' & MATCHfd & Hfd'); subst. + exploit (exec_Itailcall ge pge); eauto. + eexists; intuition eauto. + eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. + - (* Ibuiltin *) + intros; exploit exec_Ibuiltin; eauto. + eexists; intuition eauto. + unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) pc') as (path0 & Hpath0); eauto. + exists path0.(psize); intuition eauto. + econstructor; eauto. + * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. + * simpl; eauto. + - (* Ijumptable *) + intros; exploit exec_Ijumptable; eauto. + eexists; intuition eauto. + unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) pc') as (path0 & Hpath0); eauto. + exists path0.(psize); intuition eauto. + econstructor; eauto. + * enough (path0.(psize)-path0.(psize)=0)%nat as ->; simpl; eauto || omega. + * simpl; eauto. + - (* Ireturn *) + intros; exploit exec_Ireturn; eauto. + eexists; intuition eauto. + eexists O; unfold match_states, match_inst_states; simpl; intuition eauto. +Qed. + +Lemma path_step_complete stack f sp rs m pc t s1' idx path st: + isteps ge (path.(psize)-idx) f sp rs m pc = Some st -> + (fn_path f)!pc = Some path -> + (idx <= path.(psize))%nat -> + RTL.step ge (State stack f sp st.(ipc) st.(irs) st.(imem)) t s1' -> + wf_stackframe stack -> + exists idx' s2', + (path_step ge pge path.(psize) stack f sp rs m pc t s2' + \/ (t = E0 /\ s2'=(State stack f sp pc rs m) /\ (idx' < idx)%nat) + \/ (exists path', path_step ge pge path.(psize) stack f sp rs m pc E0 (State stack f sp st.(ipc) st.(irs) st.(imem)) + /\ (fn_path f)!(ipc st) = Some path' /\ path'.(psize) = O + /\ path_step ge pge path'.(psize) stack f sp st.(irs) st.(imem) st.(ipc) t s2') + ) + /\ match_states idx' s1' s2'. +Proof. + Local Hint Resolve exec_early_exit exec_normal_exit: core. + intros PSTEP PATH BOUND RSTEP WF; destruct (st.(icontinue)) eqn: CONT. + destruct idx as [ | idx]. + + (* path_step on normal_exit *) + assert (path.(psize)-0=path.(psize))%nat as HH by omega. rewrite HH in PSTEP. clear HH. + exploit normal_exit; eauto. + intros (s2' & LSTEP & (idx' & MATCH)). + exists idx'; exists s2'; intuition eauto. + + (* stuttering step *) + exploit stuttering; eauto. + unfold match_states; exists idx; exists (State stack f sp pc rs m); + intuition. + + (* one or two path_step on early_exit *) + exploit (isteps_resize ge (path.(psize) - idx)%nat path.(psize)); eauto; try omega. + clear PSTEP; intros PSTEP. + (* TODO for clarification: move the assert below into a separate lemma *) + assert (HPATH0: exists path0, (fn_path f)!(ipc st) = Some path0). + { clear RSTEP. + exploit isteps_inversion_early; eauto. + intros (st0 & i & path0 & BOUND0 & PSTEP0 & CONT0 & PC0 & STEP0). + exploit istep_early_exit; eauto. + intros (X1 & X2 & EARLY_EXIT). + destruct st as [cont pc0 rs0 m0]; simpl in * |- *; intuition subst. + exploit (internal_node_path path0); omega || eauto. + intros (i' & pc' & Hi' & Hpc' & ENTRY). + unfold nth_default_succ_inst in Hi'. + erewrite isteps_normal_exit in Hi'; eauto. + clear pc' Hpc' STEP0 PSTEP0 BOUND0; try_simplify_someHyps; intros. + destruct EARLY_EXIT as [cond args ifnot]; simpl in ENTRY; + destruct (initialize_path (*fn_code f*) (fn_path f) pc0); eauto. + } + destruct HPATH0 as (path1 & Hpath1). + destruct (path1.(psize)) as [|ps] eqn:Hpath1size. + * (* two step case *) + exploit (normal_exit path1); try rewrite Hpath1size; simpl; eauto. + simpl; intros (s2' & LSTEP & (idx' & MATCH)). + exists idx'. exists s2'. constructor; auto. + right. right. eexists; intuition eauto. + (* now, prove the last step *) + rewrite Hpath1size; exploit exec_normal_exit. 4:{ eauto. } + - simpl; eauto. + - simpl; eauto. + - simpl; eauto. + * (* single step case *) + exploit (stuttering path1 ps stack f sp (irs st) (imem st) (ipc st)); simpl; auto. + - { rewrite Hpath1size; enough (S ps-S ps=0)%nat as ->; try omega. simpl; eauto. } + - omega. + - simpl; eauto. + - simpl; eauto. + - intuition subst. + repeat eexists; intuition eauto. +Qed. + +Lemma step_noninst_complete s1 t s1' s2: + is_inst s1 = false -> + s1 = state_RTL s2 -> + RTL.step ge s1 t s1' -> + wf_stackframe (stack_of s2) -> + exists s2', step ge pge s2 t s2' /\ exists idx, match_states idx s1' s2'. +Proof. + intros H0 H1 H2 WFSTACK; destruct s2; subst; simpl in * |- *; try congruence; + inversion H2; clear H2; subst; try_simplify_someHyps; try congruence. + + (* exec_function_internal *) + destruct f; simpl in H3; inversion H3; subst; clear H3. + eexists; constructor 1. + * eapply exec_function_internal; eauto. + * unfold match_states, match_inst_states; simpl. + destruct (initialize_path (*fn_code f*) (fn_path f) (fn_entrypoint (fn_RTL f))) as (path & Hpath); eauto. + exists path.(psize). constructor; auto. + econstructor; eauto. + - set (ps:=path.(psize)). enough (ps-ps=O)%nat as ->; simpl; eauto. + omega. + - simpl; auto. + + (* exec_function_external *) + destruct f; simpl in H3 |-; inversion H3; subst; clear H3. + eexists; constructor 1. + * apply exec_function_external; eauto. + * unfold match_states, match_inst_states; simpl. exists O; auto. + + (* exec_return *) + destruct stack eqn: Hstack; simpl in H1; inversion H1; clear H1; subst. + destruct s0 eqn: Hs0; simpl in H0; inversion H0; clear H0; subst. + eexists; constructor 1. + * apply exec_return. + * unfold match_states, match_inst_states; simpl. + rewrite wf_stackframe_cons in WFSTACK. + destruct WFSTACK as (H0 & H1); simpl in H0. + destruct (initialize_path (*fn_code f0*) (fn_path f0) pc0) as (path & Hpath); eauto. + exists path.(psize). constructor; auto. + econstructor; eauto. + - set (ps:=path.(psize)). enough (ps-ps=O)%nat as ->; simpl; eauto. + omega. + - simpl; auto. +Qed. + +(** *** The main completeness lemma and the simulation theorem...*) +Lemma step_complete s1 t s1' idx s2: + match_states idx s1 s2 -> + RTL.step ge s1 t s1' -> + exists idx' s2', (plus (step ge) pge s2 t s2' \/ (t = E0 /\ s2=s2' /\ (idx' < idx)%nat)) /\ match_states idx' s1' s2'. +Proof. + Local Hint Resolve plus_one plus_two exec_path: core. + unfold match_states at 1, match_inst_states. intros (IS_INST & WFSTACK). destruct (is_inst s1) eqn: His1. + - clear His1; destruct IS_INST as [path stack f sp pc rs m s2 X X0 X1 X2]; auto; subst; simpl in * |- *. + intros STEP; exploit path_step_complete; eauto. + intros (idx' & s2' & H0 & H1). + eexists; eexists; eauto. + destruct H0 as [H0|[H0|(path'&H0)]]; intuition subst; eauto. + - intros; exploit step_noninst_complete; eauto. + intros (s2' & STEP & (idx0 & MATCH)). + exists idx0; exists s2'; intuition auto. +Qed. + +Theorem RTLpath_complete: forward_simulation (RTL.semantics p) (semantics p). +Proof. + eapply (Forward_simulation (L1:=RTL.semantics p) (L2:=semantics p) lt match_states). + constructor 1; simpl. + - apply lt_wf. + - unfold match_states, match_inst_states. destruct 1; simpl; exists O. + destruct (find_funct_ptr_RTL_preserv b f) as (f0 & X1 & X2); subst; eauto. + exists (Callstate nil f0 nil m0). simpl; split; try econstructor; eauto. + + apply (Genv.init_mem_match (match_RTL_prog p)); auto. + + rewrite (Genv.find_symbol_match (match_RTL_prog p)). + rewrite (match_program_main (match_RTL_prog p)); eauto. + - unfold final_state, match_states, match_inst_states. intros i s1 s2 r (H0 & H1) H2; destruct H2. + destruct s2; simpl in * |- *; inversion H0; subst. + constructor. + - Local Hint Resolve star_refl: core. + intros; exploit step_complete; eauto. + destruct 1 as (idx' & s2' & X). + exists idx'. exists s2'. intuition (subst; eauto). + - intros id; destruct (senv_preserved p); simpl in * |-. intuition. +Qed. + +End COMPLETENESS. diff --git a/scheduling/RTLpathLivegen.v b/scheduling/RTLpathLivegen.v new file mode 100644 index 00000000..1f0ebe3c --- /dev/null +++ b/scheduling/RTLpathLivegen.v @@ -0,0 +1,290 @@ +(** Building a RTLpath program with liveness annotation. +*) + + +Require Import Coqlib. +Require Import Maps. +Require Import Lattice. +Require Import AST. +Require Import Op. +Require Import Registers. +Require Import Globalenvs Smallstep RTL RTLpath. +Require Import Bool Errors. +Require Import Program. + +Local Open Scope lazy_bool_scope. + +Local Open Scope option_monad_scope. + +Axiom build_path_map: RTL.function -> path_map. + +Extract Constant build_path_map => "RTLpathLivegenaux.build_path_map". + +Fixpoint list_mem (rl: list reg) (alive: Regset.t) {struct rl}: bool := + match rl with + | nil => true + | r1 :: rs => Regset.mem r1 alive &&& list_mem rs alive + end. + +Definition exit_checker {A} (pm: path_map) (alive: Regset.t) (pc: node) (v:A): option A := + SOME path <- pm!pc IN + ASSERT Regset.subset path.(input_regs) alive IN + Some v. + +Lemma exit_checker_path_entry A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res: + exit_checker pm alive pc v = Some res -> path_entry pm pc. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; simpl; congruence. +Qed. + +Lemma exit_checker_res A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res: + exit_checker pm alive pc v = Some res -> v=res. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; try_simplify_someHyps. + inversion_ASSERT; try_simplify_someHyps. +Qed. + +(* FIXME - what about trap? *) +Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option (Regset.t * node) := + match i with + | Inop pc' => Some (alive, pc') + | Iop op args dst pc' => + ASSERT list_mem args alive IN + Some (Regset.add dst alive, pc') + | Iload _ chunk addr args dst pc' => + ASSERT list_mem args alive IN + Some (Regset.add dst alive, pc') + | Istore chunk addr args src pc' => + ASSERT Regset.mem src alive IN + ASSERT list_mem args alive IN + Some (alive, pc') + | Icond cond args ifso ifnot _ => + ASSERT list_mem args alive IN + exit_checker pm alive ifso (alive, ifnot) + | _ => None (* TODO jumptable ? *) + end. + + +Local Hint Resolve exit_checker_path_entry: core. + +Lemma iinst_checker_path_entry (pm: path_map) (alive: Regset.t) (i: instruction) res pc: + iinst_checker pm alive i = Some res -> + early_exit i = Some pc -> path_entry pm pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst. + inversion_ASSERT; try_simplify_someHyps. +Qed. + +Lemma iinst_checker_default_succ (pm: path_map) (alive: Regset.t) (i: instruction) res pc: + iinst_checker pm alive i = Some res -> + pc = snd res -> + default_succ i = Some pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst; + repeat (inversion_ASSERT); try_simplify_someHyps. + intros; exploit exit_checker_res; eauto. + intros; subst. simpl; auto. +Qed. + +Fixpoint ipath_checker (ps:nat) (f: RTL.function) (pm: path_map) (alive: Regset.t) (pc:node): option (Regset.t * node) := + match ps with + | O => Some (alive, pc) + | S p => + SOME i <- f.(fn_code)!pc IN + SOME res <- iinst_checker pm alive i IN + ipath_checker p f pm (fst res) (snd res) + end. + +Lemma ipath_checker_wellformed f pm ps: forall alive pc res, + ipath_checker ps f pm alive pc = Some res -> + wellformed_path f.(fn_code) pm 0 (snd res) -> + wellformed_path f.(fn_code) pm ps pc. +Proof. + induction ps; simpl; try_simplify_someHyps. + inversion_SOME i; inversion_SOME res'. + intros. eapply wf_internal_node; eauto. + * eapply iinst_checker_default_succ; eauto. + * intros; eapply iinst_checker_path_entry; eauto. +Qed. + +Definition reg_option_mem (or: option reg) (alive: Regset.t) := + match or with None => true | Some r => Regset.mem r alive end. + +Definition reg_sum_mem (ros: reg + ident) (alive: Regset.t) := + match ros with inl r => Regset.mem r alive | inr s => true end. + +(* NB: definition following [regmap_setres] in [RTL.step] semantics *) +Definition reg_builtin_res (res: builtin_res reg) (alive: Regset.t): Regset.t := + match res with + | BR r => Regset.add r alive + | _ => alive + end. + +Fixpoint exit_list_checker (pm: path_map) (alive: Regset.t) (l: list node): bool := + match l with + | nil => true + | pc::l' => exit_checker pm alive pc tt &&& exit_list_checker pm alive l' + end. + +Lemma lazy_and_Some_true A (o: option A) (b: bool): o &&& b = true <-> (exists v, o = Some v) /\ b = true. +Proof. + destruct o; simpl; intuition. + - eauto. + - firstorder. try_simplify_someHyps. +Qed. + +Lemma lazy_and_Some_tt_true (o: option unit) (b: bool): o &&& b = true <-> o = Some tt /\ b = true. +Proof. + intros; rewrite lazy_and_Some_true; firstorder. + destruct x; auto. +Qed. + + +Lemma exit_list_checker_correct pm alive l pc: + exit_list_checker pm alive l = true -> List.In pc l -> exit_checker pm alive pc tt = Some tt. +Proof. + intros EXIT PC; induction l; intuition. + simpl in * |-. rewrite lazy_and_Some_tt_true in EXIT. + firstorder (subst; eauto). +Qed. + +Local Hint Resolve exit_list_checker_correct: core. + +Definition inst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option unit := + match i with + | Icall sig ros args res pc' => + ASSERT list_mem args alive IN + ASSERT reg_sum_mem ros alive IN + exit_checker pm (Regset.add res alive) pc' tt + | Itailcall sig ros args => + ASSERT list_mem args alive IN + ASSERT reg_sum_mem ros alive IN + Some tt + | Ibuiltin ef args res pc' => + ASSERT list_mem (params_of_builtin_args args) alive IN + exit_checker pm (reg_builtin_res res alive) pc' tt + | Ijumptable arg tbl => + ASSERT Regset.mem arg alive IN + ASSERT exit_list_checker pm alive tbl IN + Some tt + | Ireturn optarg => + ASSERT (reg_option_mem optarg) alive IN + Some tt + | _ => + SOME res <- iinst_checker pm alive i IN + exit_checker pm (fst res) (snd res) tt + end. + +Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive: Regset.t) (i: instruction): + inst_checker pm alive i = Some tt -> + c!pc = Some i -> wellformed_path c pm 0 pc. +Proof. + intros CHECK PC. eapply wf_last_node; eauto. + clear c pc PC. intros pc PC. + destruct i; simpl in * |- *; intuition (subst; eauto); + try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). + intros X; exploit exit_checker_res; eauto. + clear X. intros; subst; eauto. +Qed. + +Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := + SOME res <- ipath_checker (path.(psize)) f pm (path.(input_regs)) pc IN + SOME i <- f.(fn_code)!(snd res) IN + inst_checker pm (fst res) i. + +Lemma path_checker_wellformed f pm pc path: + path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. +Proof. + unfold path_checker. + inversion_SOME res. + inversion_SOME i. + intros; eapply ipath_checker_wellformed; eauto. + eapply inst_checker_wellformed; eauto. +Qed. + +Fixpoint list_path_checker f pm (l:list (node*path_info)): bool := + match l with + | nil => true + | (pc, path)::l' => + path_checker f pm pc path &&& list_path_checker f pm l' + end. + +Lemma list_path_checker_correct f pm l: + list_path_checker f pm l = true -> forall e, List.In e l -> path_checker f pm (fst e) (snd e) = Some tt. +Proof. + intros CHECKER e H; induction l as [|(pc & path) l]; intuition. + simpl in * |- *. rewrite lazy_and_Some_tt_true in CHECKER. intuition (subst; auto). +Qed. + +Definition function_checker (f: RTL.function) pm: bool := + pm!(f.(fn_entrypoint)) &&& list_path_checker f pm (PTree.elements pm). + +Lemma function_checker_correct f pm pc path: + function_checker f pm = true -> + pm!pc = Some path -> + path_checker f pm pc path = Some tt. +Proof. + unfold function_checker; rewrite lazy_and_Some_true. + intros (ENTRY & PATH) PC. + exploit list_path_checker_correct; eauto. + - eapply PTree.elements_correct; eauto. + - simpl; auto. +Qed. + +Lemma function_checker_wellformed_path_map f pm: + function_checker f pm = true -> wellformed_path_map f.(fn_code) pm. +Proof. + unfold wellformed_path_map. + intros; eapply path_checker_wellformed; eauto. + intros; eapply function_checker_correct; eauto. +Qed. + +Lemma function_checker_path_entry f pm: + function_checker f pm = true -> path_entry pm (f.(fn_entrypoint)). +Proof. + unfold function_checker; rewrite lazy_and_Some_true; + unfold path_entry. firstorder congruence. +Qed. + +Definition liveness_ok_function (f: function): Prop := + forall pc path, f.(fn_path)!pc = Some path -> path_checker f f.(fn_path) pc path = Some tt. + +Program Definition transf_function (f: RTL.function): { r: res function | forall f', r = OK f' -> liveness_ok_function f' /\ f'.(fn_RTL) = f } := + let pm := build_path_map f in + match function_checker f pm with + | true => OK {| fn_RTL := f; fn_path := pm |} + | false => Error(msg "RTLpathGen: function_checker failed") + end. +Obligation 1. + apply function_checker_path_entry; auto. +Qed. +Obligation 2. + apply function_checker_wellformed_path_map; auto. +Qed. +Obligation 3. + unfold liveness_ok_function; simpl; intros; intuition. + apply function_checker_correct; auto. +Qed. + +Definition transf_fundef (f: RTL.fundef) : res fundef := + transf_partial_fundef (fun f => ` (transf_function f)) f. + +Inductive liveness_ok_fundef: fundef -> Prop := + | liveness_ok_Internal f: liveness_ok_function f -> liveness_ok_fundef (Internal f) + | liveness_ok_External ef: liveness_ok_fundef (External ef). + +Lemma transf_fundef_correct f f': + transf_fundef f = OK f' -> (liveness_ok_fundef f') /\ fundef_RTL f' = f. +Proof. + intros TRANSF; destruct f; simpl; monadInv TRANSF. + - destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. apply liveness_ok_Internal; auto. + - intuition. apply liveness_ok_External; auto. +Qed. + +Definition transf_program (p: RTL.program) : res program := + transform_partial_program transf_fundef p. + diff --git a/scheduling/RTLpathLivegenaux.ml b/scheduling/RTLpathLivegenaux.ml new file mode 100644 index 00000000..ab921954 --- /dev/null +++ b/scheduling/RTLpathLivegenaux.ml @@ -0,0 +1,279 @@ +open RTL +open RTLpath +open Registers +open Maps +open Camlcoq +open Datatypes +open Kildall +open Lattice +open DebugPrint + +let get_some = function +| None -> failwith "Got None instead of Some _" +| Some thing -> thing + +let successors_inst = function +| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> [n] +| Icond (_,_,n1,n2,_) -> [n1; n2] +| Ijumptable (_,l) -> l +| Itailcall _ | Ireturn _ -> [] + +let predicted_successor = function +| Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> Some n +| Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> None +| Icond (_,_,n1,n2,p) -> ( + match p with + | Some true -> Some n1 + | Some false -> Some n2 + | None -> None ) +| Ijumptable _ | Itailcall _ | Ireturn _ -> None + +let non_predicted_successors i = + match predicted_successor i with + | None -> successors_inst i + | Some n -> List.filter (fun n' -> n != n') (successors_inst i) + +let rec list_to_regset = function + | [] -> Regset.empty + | r::l -> Regset.add r (list_to_regset l) + +let get_input_regs i = + let empty = Regset.empty in + match i with + | Inop _ -> empty + | Iop (_,lr,_,_) | Iload (_,_,_,lr,_,_) | Icond (_,lr,_,_,_) -> list_to_regset lr + | Istore (_,_,lr,r,_) -> Regset.add r (list_to_regset lr) + | Icall (_, ri, lr, _, _) | Itailcall (_, ri, lr) -> begin + let rs = list_to_regset lr in + match ri with + | Coq_inr _ -> rs + | Coq_inl r -> Regset.add r rs + end + | Ibuiltin (_, lbr, _, _) -> list_to_regset @@ AST.params_of_builtin_args lbr + | Ijumptable (r, _) -> Regset.add r empty + | Ireturn opr -> (match opr with Some r -> Regset.add r empty | None -> empty) + +let get_output_reg i = + match i with + | Inop _ | Istore _ | Icond _ | Itailcall _ | Ijumptable _ | Ireturn _ -> None + | Iop (_, _, r, _) | Iload (_, _, _, _, r, _) | Icall (_, _, _, r, _) -> Some r + | Ibuiltin (_, _, brr, _) -> (match brr with AST.BR r -> Some r | _ -> None) + +(* adapted from Linearizeaux.get_join_points *) +let get_join_points code entry = + let reached = ref (PTree.map (fun n i -> false) code) in + let reached_twice = ref (PTree.map (fun n i -> false) code) in + let rec traverse pc = + if get_some @@ PTree.get pc !reached then begin + if not (get_some @@ PTree.get pc !reached_twice) then + reached_twice := PTree.set pc true !reached_twice + end else begin + reached := PTree.set pc true !reached; + traverse_succs (successors_inst @@ get_some @@ PTree.get pc code) + end + and traverse_succs = function + | [] -> () + | [pc] -> traverse pc + | pc :: l -> traverse pc; traverse_succs l + in traverse entry; !reached_twice + +(* Does not set the input_regs and liveouts field *) +let get_path_map code entry join_points = + let visited = ref (PTree.map (fun n i -> false) code) in + let path_map = ref PTree.empty in + let rec dig_path e = + let psize = ref (-1) in + let path_successors = ref [] in + let rec dig_path_rec n : (path_info * node list) option = + if not (get_some @@ PTree.get n !visited) then + let inst = get_some @@ PTree.get n code in + begin + visited := PTree.set n true !visited; + psize := !psize + 1; + let successor = match predicted_successor inst with + | None -> None + | Some n' -> if get_some @@ PTree.get n' join_points then None else Some n' + in match successor with + | Some n' -> begin + path_successors := !path_successors @ non_predicted_successors inst; + dig_path_rec n' + end + | None -> Some ({ psize = (Camlcoq.Nat.of_int !psize); + input_regs = Regset.empty; output_regs = Regset.empty }, + !path_successors @ successors_inst inst) + end + else None + in match dig_path_rec e with + | None -> () + | Some ret -> + let (path_info, succs) = ret in + begin + path_map := PTree.set e path_info !path_map; + List.iter dig_path succs + end + in begin + dig_path entry; + !path_map + end + +let transfer f pc after = let open Liveness in + match PTree.get pc f.fn_code with + | Some i -> + (match i with + | Inop _ -> after + | Iop (_, args, res, _) -> + reg_list_live args (Regset.remove res after) + | Iload (_, _, _, args, dst, _) -> + reg_list_live args (Regset.remove dst after) + | Istore (_, _, args, src, _) -> + reg_list_live args (Regset.add src after) + | Icall (_, ros, args, res, _) -> + reg_list_live args (reg_sum_live ros (Regset.remove res after)) + | Itailcall (_, ros, args) -> + reg_list_live args (reg_sum_live ros Regset.empty) + | Ibuiltin (_, args, res, _) -> + reg_list_live (AST.params_of_builtin_args args) + (reg_list_dead (AST.params_of_builtin_res res) after) + | Icond (_, args, _, _, _) -> + reg_list_live args after + | Ijumptable (arg, _) -> + Regset.add arg after + | Ireturn optarg -> + reg_option_live optarg Regset.empty) + | None -> Regset.empty + +module RegsetLat = LFSet(Regset) + +module DS = Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward) + +let analyze f = + let liveouts = get_some @@ DS.fixpoint f.fn_code successors_instr (transfer f) in + PTree.map (fun n _ -> let lo = PMap.get n liveouts in transfer f n lo) f.fn_code + +(** OLD CODE - If needed to have our own kildall + +let transfer after = let open Liveness in function + | Inop _ -> after + | Iop (_, args, res, _) -> + reg_list_live args (Regset.remove res after) + | Iload (_, _, _, args, dst, _) -> + reg_list_live args (Regset.remove dst after) + | Istore (_, _, args, src, _) -> + reg_list_live args (Regset.add src after) + | Icall (_, ros, args, res, _) -> + reg_list_live args (reg_sum_live ros (Regset.remove res after)) + | Itailcall (_, ros, args) -> + reg_list_live args (reg_sum_live ros Regset.empty) + | Ibuiltin (_, args, res, _) -> + reg_list_live (AST.params_of_builtin_args args) + (reg_list_dead (AST.params_of_builtin_res res) after) + | Icond (_, args, _, _, _) -> + reg_list_live args after + | Ijumptable (arg, _) -> + Regset.add arg after + | Ireturn optarg -> + reg_option_live optarg Regset.empty + +let get_last_nodes f = + let visited = ref (PTree.map (fun n i -> false) f.fn_code) in + let rec step n = + let inst = get_some @@ PTree.get n f.fn_code in + let successors = successors_inst inst in + if get_some @@ PTree.get n !visited then [] + else begin + +let analyze f = + let liveness = ref (PTree.map (fun n i -> None) f.fn_code) in + let predecessors = Duplicateaux.get_predecessors_rtl f.fn_code in + let last_nodes = get_last_nodes f in + let rec step liveout n = (* liveout is the input_regs from the successor *) + let inst = get_some @@ PTree.get n f.fn_code in + let continue = ref true in + let alive = match get_some @@ PTree.get n !liveness with + | None -> transfer liveout inst + | Some pre_alive -> begin + let union = Regset.union pre_alive liveout in + let new_alive = transfer union inst in + (if Regset.equal pre_alive new_alive then continue := false); + new_alive + end + in begin + liveness := PTree.set n (Some alive) !liveness; + if !continue then + let preds = get_some @@ PTree.get n predecessors in + List.iter (step alive) preds + end + in begin + List.iter (step Regset.empty) last_nodes; + let liveness_noopt = PTree.map (fun n i -> get_some i) !liveness in + begin + debug_flag := true; + dprintf "Liveness: "; print_ptree_regset liveness_noopt; dprintf "\n"; + debug_flag := false; + liveness_noopt + end + end +*) + +let rec traverse code n size = + let inst = get_some @@ PTree.get n code in + if (size == 0) then inst + else + let n' = get_some @@ predicted_successor inst in + traverse code n' (size-1) + +let get_outputs liveness code n pi = + let last_instruction = traverse code n (Camlcoq.Nat.to_int pi.psize) in + let path_last_successors = successors_inst last_instruction in + let list_input_regs = List.map ( + fun n -> get_some @@ PTree.get n liveness + ) path_last_successors in + List.fold_left Regset.union Regset.empty list_input_regs + +let set_pathmap_liveness f pm = + let liveness = analyze f in + let new_pm = ref PTree.empty in + let code = f.fn_code in + begin + debug "Liveness: "; print_ptree_regset liveness; debug "\n"; + List.iter (fun (n, pi) -> + let inputs = get_some @@ PTree.get n liveness in + let outputs = get_outputs liveness code n pi in + new_pm := PTree.set n + {psize=pi.psize; input_regs=inputs; output_regs=outputs} !new_pm + ) (PTree.elements pm); + !new_pm + end + +let print_path_info pi = begin + debug "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); + debug "input_regs="; + print_regset pi.input_regs; + debug "; output_regs="; + print_regset pi.output_regs; + debug ")" +end + +let print_path_map path_map = begin + debug "["; + List.iter (fun (n,pi) -> + debug "\n\t"; + debug "%d: " (P.to_int n); + print_path_info pi + ) (PTree.elements path_map); + debug "]" +end + +let build_path_map f = + let code = f.fn_code in + let entry = f.fn_entrypoint in + let join_points = get_join_points code entry in + let path_map = set_pathmap_liveness f @@ get_path_map code entry join_points in + begin + debug "Join points: "; + print_true_nodes join_points; + debug "\nPath map: "; + print_path_map path_map; + debug "\n"; + path_map + end diff --git a/scheduling/RTLpathLivegenproof.v b/scheduling/RTLpathLivegenproof.v new file mode 100644 index 00000000..c6125985 --- /dev/null +++ b/scheduling/RTLpathLivegenproof.v @@ -0,0 +1,736 @@ +(** Proofs of the liveness properties from the liveness checker of RTLpathLivengen. +*) + + +Require Import Coqlib. +Require Import Maps. +Require Import Lattice. +Require Import AST. +Require Import Op. +Require Import Registers. +Require Import Globalenvs Smallstep RTL RTLpath RTLpathLivegen. +Require Import Bool Errors Linking Values Events. +Require Import Program. + +Definition match_prog (p: RTL.program) (tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. + +Section PRESERVATION. + +Variables prog: RTL.program. +Variables tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tpge := Genv.globalenv tprog. +Let tge := Genv.globalenv (RTLpath.transf_program tprog). + +Lemma symbols_preserved s: Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + rewrite <- (Genv.find_symbol_match TRANSL). + apply (Genv.find_symbol_match (match_prog_RTL tprog)). +Qed. + +Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. + +Lemma senv_preserved: Senv.equiv ge tge. +Proof. + eapply senv_transitivity. { eapply (Genv.senv_match TRANSL). } + eapply RTLpath.senv_preserved. +Qed. + +Lemma function_ptr_preserved v f: Genv.find_funct_ptr ge v = Some f -> + exists tf, Genv.find_funct_ptr tpge v = Some tf /\ transf_fundef f = OK tf. +Proof. + intros; apply (Genv.find_funct_ptr_transf_partial TRANSL); eauto. +Qed. + + +Lemma function_ptr_RTL_preserved v f: Genv.find_funct_ptr ge v = Some f -> Genv.find_funct_ptr tge v = Some f. +Proof. + intros; exploit function_ptr_preserved; eauto. + intros (tf & Htf & TRANS). + exploit (Genv.find_funct_ptr_match (match_prog_RTL tprog)); eauto. + intros (cunit & tf0 & X & Y & DUM); subst. + unfold tge. rewrite X. + exploit transf_fundef_correct; eauto. + intuition subst; auto. +Qed. + +Lemma find_function_preserved ros rs fd: + RTL.find_function ge ros rs = Some fd -> RTL.find_function tge ros rs = Some fd. +Proof. + intros H; assert (X: exists tfd, find_function tpge ros rs = Some tfd /\ fd = fundef_RTL tfd). + * destruct ros; simpl in * |- *. + + intros; exploit (Genv.find_funct_match TRANSL); eauto. + intros (cuint & tf & H1 & H2 & H3); subst; repeat econstructor; eauto. + exploit transf_fundef_correct; eauto. + intuition auto. + + rewrite <- (Genv.find_symbol_match TRANSL) in H. + unfold tpge. destruct (Genv.find_symbol _ i); simpl; try congruence. + exploit function_ptr_preserved; eauto. + intros (tf & H1 & H2); subst; repeat econstructor; eauto. + exploit transf_fundef_correct; eauto. + intuition auto. + * destruct X as (tf & X1 & X2); subst. + eapply find_function_RTL_match; eauto. +Qed. + + +Local Hint Resolve symbols_preserved senv_preserved: core. + +Lemma transf_program_RTL_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics (RTLpath.transf_program tprog)). +Proof. + eapply forward_simulation_step with (match_states:=fun (s1 s2:RTL.state) => s1=s2); simpl; eauto. + - eapply senv_preserved. + - (* initial states *) + intros s1 INIT. destruct INIT as [b f m0 ge0 INIT SYMB PTR SIG]. eexists; intuition eauto. + econstructor; eauto. + + intros; eapply (Genv.init_mem_match (match_prog_RTL tprog)). apply (Genv.init_mem_match TRANSL); auto. + + rewrite symbols_preserved. + replace (prog_main (RTLpath.transf_program tprog)) with (prog_main prog). + * eapply SYMB. + * erewrite (match_program_main (match_prog_RTL tprog)). erewrite (match_program_main TRANSL); auto. + + exploit function_ptr_RTL_preserved; eauto. + - intros; subst; auto. + - intros s t s2 STEP s1 H; subst. + eexists; intuition. + destruct STEP. + + (* Inop *) eapply exec_Inop; eauto. + + (* Iop *) eapply exec_Iop; eauto. + erewrite eval_operation_preserved; eauto. + + (* Iload *) eapply exec_Iload; eauto. + all: erewrite eval_addressing_preserved; eauto. + + (* Iload notrap1 *) eapply exec_Iload_notrap1; eauto. + all: erewrite eval_addressing_preserved; eauto. + + (* Iload notrap2 *) eapply exec_Iload_notrap2; eauto. + all: erewrite eval_addressing_preserved; eauto. + + (* Istore *) eapply exec_Istore; eauto. + all: erewrite eval_addressing_preserved; eauto. + + (* Icall *) + eapply RTL.exec_Icall; eauto. + eapply find_function_preserved; eauto. + + (* Itailcall *) + eapply RTL.exec_Itailcall; eauto. + eapply find_function_preserved; eauto. + + (* Ibuiltin *) + eapply RTL.exec_Ibuiltin; eauto. + * eapply eval_builtin_args_preserved; eauto. + * eapply external_call_symbols_preserved; eauto. + + (* Icond *) + eapply exec_Icond; eauto. + + (* Ijumptable *) + eapply RTL.exec_Ijumptable; eauto. + + (* Ireturn *) + eapply RTL.exec_Ireturn; eauto. + + (* exec_function_internal *) + eapply RTL.exec_function_internal; eauto. + + (* exec_function_external *) + eapply RTL.exec_function_external; eauto. + eapply external_call_symbols_preserved; eauto. + + (* exec_return *) + eapply RTL.exec_return; eauto. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTLpath.semantics tprog). +Proof. + eapply compose_forward_simulations. + + eapply transf_program_RTL_correct. + + eapply RTLpath_complete. +Qed. + + +(* Properties used in hypothesis of [RTLpathLiveproofs.step_eqlive] theorem *) +Theorem all_fundef_liveness_ok b f: + Genv.find_funct_ptr tpge b = Some f -> liveness_ok_fundef f. +Proof. + unfold match_prog, match_program in TRANSL. + unfold Genv.find_funct_ptr, tpge; simpl; intro X. + destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. + destruct y as [tf0|]; try congruence. + inversion X as [H1]. subst. clear X. + remember (@Gfun fundef unit f) as f2. + destruct H as [ctx' f1 f2 H0|]; try congruence. + inversion Heqf2 as [H2]. subst; clear Heqf2. + exploit transf_fundef_correct; eauto. + intuition. +Qed. + +End PRESERVATION. + +Local Open Scope lazy_bool_scope. +Local Open Scope option_monad_scope. + +Local Notation ext alive := (fun r => Regset.In r alive). + +Lemma regset_add_spec live r1 r2: Regset.In r1 (Regset.add r2 live) <-> (r1 = r2 \/ Regset.In r1 live). +Proof. + destruct (Pos.eq_dec r1 r2). + - subst. intuition; eapply Regset.add_1; auto. + - intuition. + * right. eapply Regset.add_3; eauto. + * eapply Regset.add_2; auto. +Qed. + +Definition eqlive_reg (alive: Regset.elt -> Prop) (rs1 rs2: regset): Prop := + forall r, (alive r) -> rs1#r = rs2#r. + +Lemma eqlive_reg_refl alive rs: eqlive_reg alive rs rs. +Proof. + unfold eqlive_reg; auto. +Qed. + +Lemma eqlive_reg_symmetry alive rs1 rs2: eqlive_reg alive rs1 rs2 -> eqlive_reg alive rs2 rs1. +Proof. + unfold eqlive_reg; intros; symmetry; auto. +Qed. + +Lemma eqlive_reg_trans alive rs1 rs2 rs3: eqlive_reg alive rs1 rs2 -> eqlive_reg alive rs2 rs3 -> eqlive_reg alive rs1 rs3. +Proof. + unfold eqlive_reg; intros H0 H1 r H. rewrite H0; eauto. +Qed. + +Lemma eqlive_reg_update (alive: Regset.elt -> Prop) rs1 rs2 r v: eqlive_reg (fun r1 => r1 <> r /\ alive r1) rs1 rs2 -> eqlive_reg alive (rs1 # r <- v) (rs2 # r <- v). +Proof. + unfold eqlive_reg; intros EQLIVE r0 ALIVE. + destruct (Pos.eq_dec r r0) as [H|H]. + - subst. rewrite! Regmap.gss. auto. + - rewrite! Regmap.gso; auto. +Qed. + +Lemma eqlive_reg_monotonic (alive1 alive2: Regset.elt -> Prop) rs1 rs2: eqlive_reg alive2 rs1 rs2 -> (forall r, alive1 r -> alive2 r) -> eqlive_reg alive1 rs1 rs2. +Proof. + unfold eqlive_reg; intuition. +Qed. + +Lemma eqlive_reg_triv rs1 rs2: (forall r, rs1#r = rs2#r) <-> eqlive_reg (fun _ => True) rs1 rs2. +Proof. + unfold eqlive_reg; intuition. +Qed. + +Lemma eqlive_reg_triv_trans alive rs1 rs2 rs3: eqlive_reg alive rs1 rs2 -> (forall r, rs2#r = rs3#r) -> eqlive_reg alive rs1 rs3. +Proof. + rewrite eqlive_reg_triv; intros; eapply eqlive_reg_trans; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; eauto. +Qed. + +Local Hint Resolve Regset.mem_2 Regset.subset_2: core. + +Lemma lazy_and_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. +Proof. + destruct b1; simpl; intuition. +Qed. + +Lemma list_mem_correct (rl: list reg) (alive: Regset.t): + list_mem rl alive = true -> forall r, List.In r rl -> ext alive r. +Proof. + induction rl; simpl; try rewrite lazy_and_true; intuition subst; auto. +Qed. + +Lemma eqlive_reg_list (alive: Regset.elt -> Prop) args rs1 rs2: eqlive_reg alive rs1 rs2 -> (forall r, List.In r args -> (alive r)) -> rs1##args = rs2##args. +Proof. + induction args; simpl; auto. + intros EQLIVE ALIVE; rewrite IHargs; auto. + unfold eqlive_reg in EQLIVE. + rewrite EQLIVE; auto. +Qed. + +Lemma eqlive_reg_listmem (alive: Regset.t) args rs1 rs2: eqlive_reg (ext alive) rs1 rs2 -> list_mem args alive = true -> rs1##args = rs2##args. +Proof. + intros; eapply eqlive_reg_list; eauto. + intros; eapply list_mem_correct; eauto. +Qed. + +Record eqlive_istate alive (st1 st2: istate): Prop := + { eqlive_continue: icontinue st1 = icontinue st2; + eqlive_ipc: ipc st1 = ipc st2; + eqlive_irs: eqlive_reg alive (irs st1) (irs st2); + eqlive_imem: (imem st1) = (imem st2) }. + +Lemma iinst_checker_eqlive ge sp pm alive i res rs1 rs2 m st1: + eqlive_reg (ext alive) rs1 rs2 -> + iinst_checker pm alive i = Some res -> + istep ge i sp rs1 m = Some st1 -> + exists st2, istep ge i sp rs2 m = Some st2 /\ eqlive_istate (ext (fst res)) st1 st2. +Proof. + intros EQLIVE. + destruct i; simpl; try_simplify_someHyps. + - (* Inop *) + repeat (econstructor; eauto). + - (* Iop *) + inversion_ASSERT; try_simplify_someHyps. + inversion_SOME v. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + - (* Iload *) + inversion_ASSERT; try_simplify_someHyps. + destruct t. (* TODO - simplify that proof ? *) + + inversion_SOME a0. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + inversion_SOME v; try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto. + destruct (eval_addressing _ _ _ _). + * destruct (Memory.Mem.loadv _ _ _). + ** intros. inv H1. repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + ** intros. inv H1. repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + * intros. inv H1. repeat (econstructor; simpl; eauto). + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + intros r0; rewrite regset_add_spec. + intuition. + - (* Istore *) + (repeat inversion_ASSERT); try_simplify_someHyps. + inversion_SOME a0. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + rewrite <- (EQLIVE r); auto. + inversion_SOME v; try_simplify_someHyps. + try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + - (* Icond *) + inversion_ASSERT. + inversion_SOME b. intros EVAL. + intros ARGS; erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + exploit exit_checker_res; eauto. + intro; subst; simpl. auto. +Qed. + +Lemma iinst_checker_istep_continue ge sp pm alive i res rs m st: + iinst_checker pm alive i = Some res -> + istep ge i sp rs m = Some st -> + icontinue st = true -> + (snd res)=(ipc st). +Proof. + intros; exploit iinst_checker_default_succ; eauto. + erewrite istep_normal_exit; eauto. + congruence. +Qed. + +Lemma exit_checker_eqlive A (pm: path_map) (alive: Regset.t) (pc: node) (v:A) res rs1 rs2: + exit_checker pm alive pc v = Some res -> + eqlive_reg (ext alive) rs1 rs2 -> + exists path, pm!pc = Some path /\ eqlive_reg (ext path.(input_regs)) rs1 rs2. +Proof. + unfold exit_checker. + inversion_SOME path. + inversion_ASSERT. try_simplify_someHyps. + repeat (econstructor; eauto). + intros; eapply eqlive_reg_monotonic; eauto. + intros; exploit Regset.subset_2; eauto. +Qed. + +Lemma iinst_checker_eqlive_stopped ge sp pm alive i res rs1 rs2 m st1: + eqlive_reg (ext alive) rs1 rs2 -> + istep ge i sp rs1 m = Some st1 -> + iinst_checker pm alive i = Some res -> + icontinue st1 = false -> + exists path st2, pm!(ipc st1) = Some path /\ istep ge i sp rs2 m = Some st2 /\ eqlive_istate (ext path.(input_regs)) st1 st2. +Proof. + intros EQLIVE. + set (tmp := istep ge i sp rs2). + destruct i; simpl; try_simplify_someHyps; repeat (inversion_ASSERT || inversion_SOME b); try_simplify_someHyps; try congruence. + 1-3: explore_destruct; simpl; try_simplify_someHyps; repeat (inversion_ASSERT || inversion_SOME b); try_simplify_someHyps; try congruence. + (* Icond *) + unfold tmp; clear tmp; simpl. + intros EVAL; erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + destruct b eqn:EQb; simpl in * |-; try congruence. + intros; exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE2). + repeat (econstructor; simpl; eauto). +Qed. + +Lemma ipath_checker_eqlive_normal ge ps (f:function) sp pm: forall alive pc res rs1 rs2 m st1, + eqlive_reg (ext alive) rs1 rs2 -> + ipath_checker ps f pm alive pc = Some res -> + isteps ge ps f sp rs1 m pc = Some st1 -> + icontinue st1 = true -> + exists st2, isteps ge ps f sp rs2 m pc = Some st2 /\ eqlive_istate (ext (fst res)) st1 st2. +Proof. + induction ps as [|ps]; simpl; try_simplify_someHyps. + - repeat (econstructor; simpl; eauto). + - inversion_SOME i; try_simplify_someHyps. + inversion_SOME res0. + inversion_SOME st0. + intros. + exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP & [CONT PC RS MEM]). + try_simplify_someHyps. + rewrite <- CONT, <- MEM, <- PC. + destruct (icontinue st0) eqn:CONT'. + * intros; exploit iinst_checker_istep_continue; eauto. + rewrite <- PC; intros X; rewrite X in * |-. eauto. + * try_simplify_someHyps. + congruence. +Qed. + +Lemma ipath_checker_isteps_continue ge ps (f:function) sp pm: forall alive pc res rs m st, + ipath_checker ps f pm alive pc = Some res -> + isteps ge ps f sp rs m pc = Some st -> + icontinue st = true -> + (snd res)=(ipc st). +Proof. + induction ps as [|ps]; simpl; try_simplify_someHyps. + inversion_SOME i; try_simplify_someHyps. + inversion_SOME res0. + inversion_SOME st0. + destruct (icontinue st0) eqn:CONT'. + - intros; exploit iinst_checker_istep_continue; eauto. + intros EQ; rewrite EQ in * |-; clear EQ; eauto. + - try_simplify_someHyps; congruence. +Qed. + +Lemma ipath_checker_eqlive_stopped ge ps (f:function) sp pm: forall alive pc res rs1 rs2 m st1, + eqlive_reg (ext alive) rs1 rs2 -> + ipath_checker ps f pm alive pc = Some res -> + isteps ge ps f sp rs1 m pc = Some st1 -> + icontinue st1 = false -> + exists path st2, pm!(ipc st1) = Some path /\ isteps ge ps f sp rs2 m pc = Some st2 /\ eqlive_istate (ext path.(input_regs)) st1 st2. +Proof. + induction ps as [|ps]; simpl; try_simplify_someHyps; try congruence. + inversion_SOME i; try_simplify_someHyps. + inversion_SOME res0. + inversion_SOME st0. + intros. + destruct (icontinue st0) eqn:CONT'; try_simplify_someHyps; intros. + * intros; exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP & [CONT PC RS MEM]). + exploit iinst_checker_istep_continue; eauto. + intros PC'. + try_simplify_someHyps. + rewrite PC', <- CONT, <- MEM, <- PC, CONT'. + eauto. + * intros; exploit iinst_checker_eqlive_stopped; eauto. + intros EQLIVE; generalize EQLIVE; destruct 1 as (path & st2 & PATH & ISTEP & [CONT PC RS MEM]). + try_simplify_someHyps. + rewrite <- CONT, <- MEM, <- PC, CONT'. + try_simplify_someHyps. +Qed. + +Inductive eqlive_stackframes: stackframe -> stackframe -> Prop := + | eqlive_stackframes_intro path res f sp pc rs1 rs2 + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: forall v, eqlive_reg (ext path.(input_regs)) (rs1 # res <- v) (rs2 # res <- v)): + eqlive_stackframes (Stackframe res f sp pc rs1) (Stackframe res f sp pc rs2). + +Inductive eqlive_states: state -> state -> Prop := + | eqlive_states_intro + path st1 st2 f sp pc rs1 rs2 m + (STACKS: list_forall2 eqlive_stackframes st1 st2) + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: eqlive_reg (ext path.(input_regs)) rs1 rs2): + eqlive_states (State st1 f sp pc rs1 m) (State st2 f sp pc rs2 m) + | eqlive_states_call st1 st2 f args m + (LIVE: liveness_ok_fundef f) + (STACKS: list_forall2 eqlive_stackframes st1 st2): + eqlive_states (Callstate st1 f args m) (Callstate st2 f args m) + | eqlive_states_return st1 st2 v m + (STACKS: list_forall2 eqlive_stackframes st1 st2): + eqlive_states (Returnstate st1 v m) (Returnstate st2 v m). + + +Section LivenessProperties. + +Variable prog: program. + +Let pge := Genv.globalenv prog. +Let ge := Genv.globalenv (RTLpath.transf_program prog). + +Hypothesis all_fundef_liveness_ok: forall b f, + Genv.find_funct_ptr pge b = Some f -> + liveness_ok_fundef f. + +Lemma find_funct_liveness_ok v fd: + Genv.find_funct pge v = Some fd -> liveness_ok_fundef fd. +Proof. + unfold Genv.find_funct. + destruct v; try congruence. + destruct (Integers.Ptrofs.eq_dec _ _); try congruence. + eapply all_fundef_liveness_ok; eauto. +Qed. + +Lemma find_function_liveness_ok ros rs f: + find_function pge ros rs = Some f -> liveness_ok_fundef f. +Proof. + destruct ros as [r|i]; simpl. + - intros; eapply find_funct_liveness_ok; eauto. + - destruct (Genv.find_symbol pge i); try congruence. + eapply all_fundef_liveness_ok; eauto. +Qed. + +Lemma find_function_eqlive alive ros rs1 rs2: + eqlive_reg (ext alive) rs1 rs2 -> + reg_sum_mem ros alive = true -> + find_function pge ros rs1 = find_function pge ros rs2. +Proof. + intros EQLIVE. + destruct ros; simpl; auto. + intros H; erewrite (EQLIVE r); eauto. +Qed. + +Lemma inst_checker_from_iinst_checker i sp rs m st pm alive: + istep ge i sp rs m = Some st -> + inst_checker pm alive i = (SOME res <- iinst_checker pm alive i IN exit_checker pm (fst res) (snd res) tt). +Proof. + destruct i; simpl; try congruence. +Qed. + +Lemma exit_checker_eqlive_ext1 (pm: path_map) (alive: Regset.t) (pc: node) r rs1 rs2: + exit_checker pm (Regset.add r alive) pc tt = Some tt -> + eqlive_reg (ext alive) rs1 rs2 -> + exists path, pm!pc = Some path /\ (forall v, eqlive_reg (ext path.(input_regs)) (rs1 # r <- v) (rs2 # r <- v)). +Proof. + unfold exit_checker. + inversion_SOME path. + inversion_ASSERT. try_simplify_someHyps. + repeat (econstructor; eauto). + intros; eapply eqlive_reg_update; eauto. + eapply eqlive_reg_monotonic; eauto. + intros r0 [X1 X2]; exploit Regset.subset_2; eauto. + rewrite regset_add_spec. intuition subst. +Qed. + +Local Hint Resolve in_or_app: local. +Lemma eqlive_eval_builtin_args alive rs1 rs2 sp m args vargs: + eqlive_reg alive rs1 rs2 -> + Events.eval_builtin_args ge (fun r => rs1 # r) sp m args vargs -> + (forall r, List.In r (params_of_builtin_args args) -> alive r) -> + Events.eval_builtin_args ge (fun r => rs2 # r) sp m args vargs. +Proof. + unfold Events.eval_builtin_args. + intros EQLIVE; induction 1 as [|a1 al b1 bl EVAL1 EVALL]; simpl. + { econstructor; eauto. } + intro X. + assert (X1: eqlive_reg (fun r => In r (params_of_builtin_arg a1)) rs1 rs2). + { eapply eqlive_reg_monotonic; eauto with local. } + lapply IHEVALL; eauto with local. + clear X IHEVALL; intro X. econstructor; eauto. + generalize X1; clear EVALL X1 X. + induction EVAL1; simpl; try (econstructor; eauto; fail). + - intros X1; erewrite X1; [ econstructor; eauto | eauto ]. + - intros; econstructor. + + eapply IHEVAL1_1; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. + + eapply IHEVAL1_2; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. + - intros; econstructor. + + eapply IHEVAL1_1; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. + + eapply IHEVAL1_2; eauto. + eapply eqlive_reg_monotonic; eauto. + simpl; intros; eauto with local. +Qed. + +Lemma exit_checker_eqlive_builtin_res (pm: path_map) (alive: Regset.t) (pc: node) rs1 rs2 (res:builtin_res reg): + exit_checker pm (reg_builtin_res res alive) pc tt = Some tt -> + eqlive_reg (ext alive) rs1 rs2 -> + exists path, pm!pc = Some path /\ (forall vres, eqlive_reg (ext path.(input_regs)) (regmap_setres res vres rs1) (regmap_setres res vres rs2)). +Proof. + destruct res; simpl. + - intros; exploit exit_checker_eqlive_ext1; eauto. + - intros; exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE). + eexists; intuition eauto. + - intros; exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE). + eexists; intuition eauto. +Qed. + +Lemma exit_list_checker_eqlive (pm: path_map) (alive: Regset.t) (tbl: list node) rs1 rs2 pc: forall n, + exit_list_checker pm alive tbl = true -> + eqlive_reg (ext alive) rs1 rs2 -> + list_nth_z tbl n = Some pc -> + exists path, pm!pc = Some path /\ eqlive_reg (ext path.(input_regs)) rs1 rs2. +Proof. + induction tbl; simpl. + - intros; try congruence. + - intros n; rewrite lazy_and_Some_tt_true; destruct (zeq n 0) eqn: Hn. + * try_simplify_someHyps; intuition. + exploit exit_checker_eqlive; eauto. + * intuition. eapply IHtbl; eauto. +Qed. + +Lemma inst_checker_eqlive (f: function) sp alive pc i rs1 rs2 m stk1 stk2 t s1: + list_forall2 eqlive_stackframes stk1 stk2 -> + eqlive_reg (ext alive) rs1 rs2 -> + liveness_ok_function f -> + (fn_code f) ! pc = Some i -> + path_last_step ge pge stk1 f sp pc rs1 m t s1 -> + inst_checker (fn_path f) alive i = Some tt -> + exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. +Proof. + intros STACKS EQLIVE LIVENESS PC; + destruct 1 as [i' sp pc rs1 m st1| + sp pc rs1 m sig ros args res pc' fd| + st1 pc rs1 m sig ros args fd m'| + sp pc rs1 m ef args res pc' vargs t vres m'| + sp pc rs1 m arg tbl n pc' | + st1 pc rs1 m optr m']; + try_simplify_someHyps. + + (* istate *) + intros PC ISTEP. erewrite inst_checker_from_iinst_checker; eauto. + inversion_SOME res. + intros. + destruct (icontinue st1) eqn: CONT. + - (* CONT => true *) + exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + exploit exit_checker_eqlive; eauto. + intros (path & PATH & EQLIVE2). + eapply eqlive_states_intro; eauto. + erewrite <- iinst_checker_istep_continue; eauto. + - (* CONT => false *) + intros; exploit iinst_checker_eqlive_stopped; eauto. + destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + eapply eqlive_states_intro; eauto. + + (* Icall *) + repeat inversion_ASSERT. intros. + exploit exit_checker_eqlive_ext1; eauto. + intros (path & PATH & EQLIVE2). + eexists; split. + - eapply exec_Icall; eauto. + erewrite <- find_function_eqlive; eauto. + - erewrite eqlive_reg_listmem; eauto. + eapply eqlive_states_call; eauto. + eapply find_function_liveness_ok; eauto. + repeat (econstructor; eauto). + + (* Itailcall *) + repeat inversion_ASSERT. intros. + eexists; split. + - eapply exec_Itailcall; eauto. + erewrite <- find_function_eqlive; eauto. + - erewrite eqlive_reg_listmem; eauto. + eapply eqlive_states_call; eauto. + eapply find_function_liveness_ok; eauto. + + (* Ibuiltin *) + repeat inversion_ASSERT. intros. + exploit exit_checker_eqlive_builtin_res; eauto. + intros (path & PATH & EQLIVE2). + eexists; split. + - eapply exec_Ibuiltin; eauto. + eapply eqlive_eval_builtin_args; eauto. + intros; eapply list_mem_correct; eauto. + - repeat (econstructor; simpl; eauto). + + (* Ijumptable *) + repeat inversion_ASSERT. intros. + exploit exit_list_checker_eqlive; eauto. + intros (path & PATH & EQLIVE2). + eexists; split. + - eapply exec_Ijumptable; eauto. + erewrite <- EQLIVE; eauto. + - repeat (econstructor; simpl; eauto). + + (* Ireturn *) + repeat inversion_ASSERT. intros. + eexists; split. + - eapply exec_Ireturn; eauto. + - destruct optr; simpl in * |- *. + * erewrite (EQLIVE r); eauto. + eapply eqlive_states_return; eauto. + * eapply eqlive_states_return; eauto. +Qed. + +Lemma path_step_eqlive path stk1 f sp rs1 m pc t s1 stk2 rs2: + path_step ge pge (psize path) stk1 f sp rs1 m pc t s1 -> + list_forall2 eqlive_stackframes stk1 stk2 -> + eqlive_reg (ext (input_regs path)) rs1 rs2 -> + liveness_ok_function f -> + (fn_path f) ! pc = Some path -> + exists s2, path_step ge pge (psize path) stk2 f sp rs2 m pc t s2 /\ eqlive_states s1 s2. +Proof. + intros STEP STACKS EQLIVE LIVE PC. + unfold liveness_ok_function in LIVE. + exploit LIVE; eauto. + unfold path_checker. + inversion_SOME res; (* destruct res as [alive pc']. *) intros ICHECK. (* simpl. *) + inversion_SOME i; intros PC'. + destruct STEP as [st ISTEPS CONT|]. + - (* early_exit *) + intros; exploit ipath_checker_eqlive_stopped; eauto. + destruct 1 as (path2 & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + eapply eqlive_states_intro; eauto. + - (* normal_exit *) + intros; exploit ipath_checker_eqlive_normal; eauto. + destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). + exploit ipath_checker_isteps_continue; eauto. + intros PC3; rewrite <- PC3, <- PC2 in * |-. + exploit inst_checker_eqlive; eauto. + intros (s2 & LAST_STEP & EQLIVE2). + eexists; split; eauto. + eapply exec_normal_exit; eauto. + rewrite <- PC3, <- MEM; auto. +Qed. + +Theorem step_eqlive t s1 s1' s2: + step ge pge s1 t s1' -> + eqlive_states s1 s2 -> + exists s2', step ge pge s2 t s2' /\ eqlive_states s1' s2'. +Proof. + destruct 1 as [path stack f sp rs m pc t s PATH STEP | | | ]. + - intros EQLIVE; inv EQLIVE; simplify_someHyps. + intro PATH. + exploit path_step_eqlive; eauto. + intros (s2 & STEP2 & EQUIV2). + eexists; split; eauto. + eapply exec_path; eauto. + - intros EQLIVE; inv EQLIVE; inv LIVE. + exploit initialize_path. { eapply fn_entry_point_wf. } + intros (path & Hpath). + eexists; split. + * eapply exec_function_internal; eauto. + * eapply eqlive_states_intro; eauto. + eapply eqlive_reg_refl. + - intros EQLIVE; inv EQLIVE. + eexists; split. + * eapply exec_function_external; eauto. + * eapply eqlive_states_return; eauto. + - intros EQLIVE; inv EQLIVE. + inversion STACKS as [|s1 st1 s' s2 STACK STACKS']; subst; clear STACKS. + inv STACK. + exists (State s2 f sp pc (rs2 # res <- vres) m); split. + * apply exec_return. + * eapply eqlive_states_intro; eauto. +Qed. + +End LivenessProperties. diff --git a/scheduling/RTLpathSE_impl.v b/scheduling/RTLpathSE_impl.v new file mode 100644 index 00000000..38930a75 --- /dev/null +++ b/scheduling/RTLpathSE_impl.v @@ -0,0 +1,1509 @@ +(** Implementation and refinement of the symbolic execution *) + +Require Import Coqlib Maps Floats. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL RTLpath. +Require Import Errors. +Require Import RTLpathSE_theory RTLpathLivegenproof. +Require Import Axioms RTLpathSE_simu_specs. + +Local Open Scope error_monad_scope. +Local Open Scope option_monad_scope. + +Require Import Impure.ImpHCons. +Import Notations. +Import HConsing. + +Local Open Scope impure. +Local Open Scope hse. + +Import ListNotations. +Local Open Scope list_scope. + +Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := RET tt. (* TO REMOVE DEBUG INFO *) +(* Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := DO s <~ k x;; println ("DEBUG simu_check:" +; s). (* TO INSERT DEBUG INFO *) *) + +Definition DEBUG (s: pstring): ?? unit := XDEBUG tt (fun _ => RET s). + +(** * Implementation of Data-structure use in Hash-consing *) + +Definition hsval_get_hid (hsv: hsval): hashcode := + match hsv with + | HSinput _ hid => hid + | HSop _ _ hid => hid + | HSload _ _ _ _ _ hid => hid + end. + +Definition list_hsval_get_hid (lhsv: list_hsval): hashcode := + match lhsv with + | HSnil hid => hid + | HScons _ _ hid => hid + end. + +Definition hsmem_get_hid (hsm: hsmem): hashcode := + match hsm with + | HSinit hid => hid + | HSstore _ _ _ _ _ hid => hid + end. + +Definition hsval_set_hid (hsv: hsval) (hid: hashcode): hsval := + match hsv with + | HSinput r _ => HSinput r hid + | HSop o lhsv _ => HSop o lhsv hid + | HSload hsm trap chunk addr lhsv _ => HSload hsm trap chunk addr lhsv hid + end. + +Definition list_hsval_set_hid (lhsv: list_hsval) (hid: hashcode): list_hsval := + match lhsv with + | HSnil _ => HSnil hid + | HScons hsv lhsv _ => HScons hsv lhsv hid + end. + +Definition hsmem_set_hid (hsm: hsmem) (hid: hashcode): hsmem := + match hsm with + | HSinit _ => HSinit hid + | HSstore hsm chunk addr lhsv srce _ => HSstore hsm chunk addr lhsv srce hid + end. + + +Lemma hsval_set_hid_correct x y ge sp rs0 m0: + hsval_set_hid x unknown_hid = hsval_set_hid y unknown_hid -> + seval_hsval ge sp x rs0 m0 = seval_hsval ge sp y rs0 m0. +Proof. + destruct x, y; intro H; inversion H; subst; simpl; auto. +Qed. +Local Hint Resolve hsval_set_hid_correct: core. + +Lemma list_hsval_set_hid_correct x y ge sp rs0 m0: + list_hsval_set_hid x unknown_hid = list_hsval_set_hid y unknown_hid -> + seval_list_hsval ge sp x rs0 m0 = seval_list_hsval ge sp y rs0 m0. +Proof. + destruct x, y; intro H; inversion H; subst; simpl; auto. +Qed. +Local Hint Resolve list_hsval_set_hid_correct: core. + +Lemma hsmem_set_hid_correct x y ge sp rs0 m0: + hsmem_set_hid x unknown_hid = hsmem_set_hid y unknown_hid -> + seval_hsmem ge sp x rs0 m0 = seval_hsmem ge sp y rs0 m0. +Proof. + destruct x, y; intro H; inversion H; subst; simpl; auto. +Qed. +Local Hint Resolve hsmem_set_hid_correct: core. + +(** Now, we build the hash-Cons value from a "hash_eq". + + Informal specification: + [hash_eq] must be consistent with the "hashed" constructors defined above. + + We expect that hashinfo values in the code of these "hashed" constructors verify: + (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) +*) + + +Definition hsval_hash_eq (sv1 sv2: hsval): ?? bool := + match sv1, sv2 with + | HSinput r1 _, HSinput r2 _ => struct_eq r1 r2 (* NB: really need a struct_eq here ? *) + | HSop op1 lsv1 _, HSop op2 lsv2 _ => + DO b1 <~ phys_eq lsv1 lsv2;; + if b1 + then struct_eq op1 op2 (* NB: really need a struct_eq here ? *) + else RET false + | HSload sm1 trap1 chk1 addr1 lsv1 _, HSload sm2 trap2 chk2 addr2 lsv2 _ => + DO b1 <~ phys_eq lsv1 lsv2;; + DO b2 <~ phys_eq sm1 sm2;; + DO b3 <~ struct_eq trap1 trap2;; + DO b4 <~ struct_eq chk1 chk2;; + if b1 && b2 && b3 && b4 + then struct_eq addr1 addr2 + else RET false + | _,_ => RET false + end. + + +Lemma and_true_split a b: a && b = true <-> a = true /\ b = true. +Proof. + destruct a; simpl; intuition. +Qed. + +Lemma hsval_hash_eq_correct x y: + WHEN hsval_hash_eq x y ~> b THEN + b = true -> hsval_set_hid x unknown_hid = hsval_set_hid y unknown_hid. +Proof. + destruct x, y; wlp_simplify; try (rewrite !and_true_split in *); intuition; subst; try congruence. +Qed. +Global Opaque hsval_hash_eq. +Local Hint Resolve hsval_hash_eq_correct: wlp. + +Definition list_hsval_hash_eq (lsv1 lsv2: list_hsval): ?? bool := + match lsv1, lsv2 with + | HSnil _, HSnil _ => RET true + | HScons sv1 lsv1' _, HScons sv2 lsv2' _ => + DO b <~ phys_eq lsv1' lsv2';; + if b + then phys_eq sv1 sv2 + else RET false + | _,_ => RET false + end. + +Lemma list_hsval_hash_eq_correct x y: + WHEN list_hsval_hash_eq x y ~> b THEN + b = true -> list_hsval_set_hid x unknown_hid = list_hsval_set_hid y unknown_hid. +Proof. + destruct x, y; wlp_simplify; try (rewrite !and_true_split in *); intuition; subst; try congruence. +Qed. +Global Opaque list_hsval_hash_eq. +Local Hint Resolve list_hsval_hash_eq_correct: wlp. + +Definition hsmem_hash_eq (sm1 sm2: hsmem): ?? bool := + match sm1, sm2 with + | HSinit _, HSinit _ => RET true + | HSstore sm1 chk1 addr1 lsv1 sv1 _, HSstore sm2 chk2 addr2 lsv2 sv2 _ => + DO b1 <~ phys_eq lsv1 lsv2;; + DO b2 <~ phys_eq sm1 sm2;; + DO b3 <~ phys_eq sv1 sv2;; + DO b4 <~ struct_eq chk1 chk2;; + if b1 && b2 && b3 && b4 + then struct_eq addr1 addr2 + else RET false + | _,_ => RET false + end. + +Lemma hsmem_hash_eq_correct x y: + WHEN hsmem_hash_eq x y ~> b THEN + b = true -> hsmem_set_hid x unknown_hid = hsmem_set_hid y unknown_hid. +Proof. + destruct x, y; wlp_simplify; try (rewrite !and_true_split in *); intuition; subst; try congruence. +Qed. +Global Opaque hsmem_hash_eq. +Local Hint Resolve hsmem_hash_eq_correct: wlp. + + +Definition hSVAL: hashP hsval := {| hash_eq := hsval_hash_eq; get_hid:=hsval_get_hid; set_hid:=hsval_set_hid |}. +Definition hLSVAL: hashP list_hsval := {| hash_eq := list_hsval_hash_eq; get_hid:= list_hsval_get_hid; set_hid:= list_hsval_set_hid |}. +Definition hSMEM: hashP hsmem := {| hash_eq := hsmem_hash_eq; get_hid:= hsmem_get_hid; set_hid:= hsmem_set_hid |}. + +Program Definition mk_hash_params: Dict.hash_params hsval := + {| + Dict.test_eq := phys_eq; + Dict.hashing := fun (ht: hsval) => RET (hsval_get_hid ht); + Dict.log := fun hv => + DO hv_name <~ string_of_hashcode (hsval_get_hid hv);; + println ("unexpected undef behavior of hashcode:" +; (CamlStr hv_name)) |}. +Obligation 1. + wlp_simplify. +Qed. + +(** ** various auxiliary (trivial lemmas) *) +Lemma hsilocal_refines_sreg ge sp rs0 m0 hst st: + hsilocal_refines ge sp rs0 m0 hst st -> hsok_local ge sp rs0 m0 hst -> forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (si_sreg st r) rs0 m0. +Proof. + unfold hsilocal_refines; intuition. +Qed. +Local Hint Resolve hsilocal_refines_sreg: core. + +Lemma hsilocal_refines_valid_pointer ge sp rs0 m0 hst st: + hsilocal_refines ge sp rs0 m0 hst st -> forall m b ofs, seval_smem ge sp st.(si_smem) rs0 m0 = Some m -> Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs. +Proof. + unfold hsilocal_refines; intuition. +Qed. +Local Hint Resolve hsilocal_refines_valid_pointer: core. + +Lemma hsilocal_refines_smem_refines ge sp rs0 m0 hst st: + hsilocal_refines ge sp rs0 m0 hst st -> hsok_local ge sp rs0 m0 hst -> smem_refines ge sp rs0 m0 (hsi_smem hst) (st.(si_smem)). +Proof. + unfold hsilocal_refines; intuition. +Qed. +Local Hint Resolve hsilocal_refines_smem_refines: core. + +Lemma hsistate_refines_dyn_exits ge sp rs0 m0 hst st: + hsistate_refines_dyn ge sp rs0 m0 hst st -> hsiexits_refines_dyn ge sp rs0 m0 (hsi_exits hst) (si_exits st). +Proof. + unfold hsistate_refines_dyn; intuition. +Qed. +Local Hint Resolve hsistate_refines_dyn_exits: core. + +Lemma hsistate_refines_dyn_local ge sp rs0 m0 hst st: + hsistate_refines_dyn ge sp rs0 m0 hst st -> hsilocal_refines ge sp rs0 m0 (hsi_local hst) (si_local st). +Proof. + unfold hsistate_refines_dyn; intuition. +Qed. +Local Hint Resolve hsistate_refines_dyn_local: core. + +Lemma hsistate_refines_dyn_nested ge sp rs0 m0 hst st: + hsistate_refines_dyn ge sp rs0 m0 hst st -> nested_sok ge sp rs0 m0 (si_local st) (si_exits st). +Proof. + unfold hsistate_refines_dyn; intuition. +Qed. +Local Hint Resolve hsistate_refines_dyn_nested: core. + +(** * Implementation of symbolic execution *) +Section CanonBuilding. + +Variable hC_hsval: hashinfo hsval -> ?? hsval. + +Hypothesis hC_hsval_correct: forall hs, + WHEN hC_hsval hs ~> hs' THEN forall ge sp rs0 m0, + seval_hsval ge sp (hdata hs) rs0 m0 = seval_hsval ge sp hs' rs0 m0. + +Variable hC_list_hsval: hashinfo list_hsval -> ?? list_hsval. +Hypothesis hC_list_hsval_correct: forall lh, + WHEN hC_list_hsval lh ~> lh' THEN forall ge sp rs0 m0, + seval_list_hsval ge sp (hdata lh) rs0 m0 = seval_list_hsval ge sp lh' rs0 m0. + +Variable hC_hsmem: hashinfo hsmem -> ?? hsmem. +Hypothesis hC_hsmem_correct: forall hm, + WHEN hC_hsmem hm ~> hm' THEN forall ge sp rs0 m0, + seval_hsmem ge sp (hdata hm) rs0 m0 = seval_hsmem ge sp hm' rs0 m0. + +(* First, we wrap constructors for hashed values !*) + +Definition reg_hcode := 1. +Definition op_hcode := 2. +Definition load_hcode := 3. + +Definition hSinput_hcodes (r: reg) := + DO hc <~ hash reg_hcode;; + DO hv <~ hash r;; + RET [hc;hv]. +Extraction Inline hSinput_hcodes. + +Definition hSinput (r:reg): ?? hsval := + DO hv <~ hSinput_hcodes r;; + hC_hsval {| hdata:=HSinput r unknown_hid; hcodes :=hv; |}. + +Lemma hSinput_correct r: + WHEN hSinput r ~> hv THEN forall ge sp rs0 m0, + sval_refines ge sp rs0 m0 hv (Sinput r). +Proof. + wlp_simplify. +Qed. +Global Opaque hSinput. +Local Hint Resolve hSinput_correct: wlp. + +Definition hSop_hcodes (op:operation) (lhsv: list_hsval) := + DO hc <~ hash op_hcode;; + DO hv <~ hash op;; + RET [hc;hv;list_hsval_get_hid lhsv]. +Extraction Inline hSop_hcodes. + +Definition hSop (op:operation) (lhsv: list_hsval): ?? hsval := + DO hv <~ hSop_hcodes op lhsv;; + hC_hsval {| hdata:=HSop op lhsv unknown_hid; hcodes :=hv |}. + +Lemma hSop_correct op lhsv: + WHEN hSop op lhsv ~> hv THEN forall ge sp rs0 m0 lsv sm m + (MEM: seval_smem ge sp sm rs0 m0 = Some m) + (MVALID: forall b ofs, Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (LR: list_sval_refines ge sp rs0 m0 lhsv lsv), + sval_refines ge sp rs0 m0 hv (Sop op lsv sm). +Proof. + wlp_simplify. + rewrite <- H, MEM, LR. + destruct (seval_list_sval _ _ lsv _); try congruence. + eapply op_valid_pointer_eq; eauto. +Qed. +Global Opaque hSop. +Local Hint Resolve hSop_correct: wlp. + +Definition hSload_hcodes (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval):= + DO hc <~ hash load_hcode;; + DO hv1 <~ hash trap;; + DO hv2 <~ hash chunk;; + DO hv3 <~ hash addr;; + RET [hc; hsmem_get_hid hsm; hv1; hv2; hv3; list_hsval_get_hid lhsv]. +Extraction Inline hSload_hcodes. + +Definition hSload (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval): ?? hsval := + DO hv <~ hSload_hcodes hsm trap chunk addr lhsv;; + hC_hsval {| hdata := HSload hsm trap chunk addr lhsv unknown_hid; hcodes := hv |}. + +Lemma hSload_correct hsm trap chunk addr lhsv: + WHEN hSload hsm trap chunk addr lhsv ~> hv THEN forall ge sp rs0 m0 lsv sm + (LR: list_sval_refines ge sp rs0 m0 lhsv lsv) + (MR: smem_refines ge sp rs0 m0 hsm sm), + sval_refines ge sp rs0 m0 hv (Sload sm trap chunk addr lsv). +Proof. + wlp_simplify. + rewrite <- LR, <- MR. + auto. +Qed. +Global Opaque hSload. +Local Hint Resolve hSload_correct: wlp. + +Definition hSnil (_: unit): ?? list_hsval := + hC_list_hsval {| hdata := HSnil unknown_hid; hcodes := nil |}. + +Lemma hSnil_correct: + WHEN hSnil() ~> hv THEN forall ge sp rs0 m0, + list_sval_refines ge sp rs0 m0 hv Snil. +Proof. + wlp_simplify. +Qed. +Global Opaque hSnil. +Local Hint Resolve hSnil_correct: wlp. + +Definition hScons (hsv: hsval) (lhsv: list_hsval): ?? list_hsval := + hC_list_hsval {| hdata := HScons hsv lhsv unknown_hid; hcodes := [hsval_get_hid hsv; list_hsval_get_hid lhsv] |}. + +Lemma hScons_correct hsv lhsv: + WHEN hScons hsv lhsv ~> lhsv' THEN forall ge sp rs0 m0 sv lsv + (VR: sval_refines ge sp rs0 m0 hsv sv) + (LR: list_sval_refines ge sp rs0 m0 lhsv lsv), + list_sval_refines ge sp rs0 m0 lhsv' (Scons sv lsv). +Proof. + wlp_simplify. + rewrite <- VR, <- LR. + auto. +Qed. +Global Opaque hScons. +Local Hint Resolve hScons_correct: wlp. + +Definition hSinit (_: unit): ?? hsmem := + hC_hsmem {| hdata := HSinit unknown_hid; hcodes := nil |}. + +Lemma hSinit_correct: + WHEN hSinit() ~> hm THEN forall ge sp rs0 m0, + smem_refines ge sp rs0 m0 hm Sinit. +Proof. + wlp_simplify. +Qed. +Global Opaque hSinit. +Local Hint Resolve hSinit_correct: wlp. + +Definition hSstore_hcodes (hsm: hsmem) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval) (srce: hsval):= + DO hv1 <~ hash chunk;; + DO hv2 <~ hash addr;; + RET [hsmem_get_hid hsm; hv1; hv2; list_hsval_get_hid lhsv; hsval_get_hid srce]. +Extraction Inline hSstore_hcodes. + +Definition hSstore (hsm: hsmem) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval) (srce: hsval): ?? hsmem := + DO hv <~ hSstore_hcodes hsm chunk addr lhsv srce;; + hC_hsmem {| hdata := HSstore hsm chunk addr lhsv srce unknown_hid; hcodes := hv |}. + +Lemma hSstore_correct hsm chunk addr lhsv hsv: + WHEN hSstore hsm chunk addr lhsv hsv ~> hsm' THEN forall ge sp rs0 m0 lsv sm sv + (LR: list_sval_refines ge sp rs0 m0 lhsv lsv) + (MR: smem_refines ge sp rs0 m0 hsm sm) + (VR: sval_refines ge sp rs0 m0 hsv sv), + smem_refines ge sp rs0 m0 hsm' (Sstore sm chunk addr lsv sv). +Proof. + wlp_simplify. + rewrite <- LR, <- MR, <- VR. + auto. +Qed. +Global Opaque hSstore. +Local Hint Resolve hSstore_correct: wlp. + +Definition hsi_sreg_get (hst: PTree.t hsval) r: ?? hsval := + match PTree.get r hst with + | None => hSinput r + | Some sv => RET sv + end. + +Lemma hsi_sreg_get_correct hst r: + WHEN hsi_sreg_get hst r ~> hsv THEN forall ge sp rs0 m0 (f: reg -> sval) + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + sval_refines ge sp rs0 m0 hsv (f r). +Proof. + unfold hsi_sreg_eval, hsi_sreg_proj; wlp_simplify; rewrite <- RR; try_simplify_someHyps. +Qed. +Global Opaque hsi_sreg_get. +Local Hint Resolve hsi_sreg_get_correct: wlp. + +Fixpoint hlist_args (hst: PTree.t hsval) (l: list reg): ?? list_hsval := + match l with + | nil => hSnil() + | r::l => + DO v <~ hsi_sreg_get hst r;; + DO lhsv <~ hlist_args hst l;; + hScons v lhsv + end. + +Lemma hlist_args_correct hst l: + WHEN hlist_args hst l ~> lhsv THEN forall ge sp rs0 m0 (f: reg -> sval) + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + list_sval_refines ge sp rs0 m0 lhsv (list_sval_inj (List.map f l)). +Proof. + induction l; wlp_simplify. +Qed. +Global Opaque hlist_args. +Local Hint Resolve hlist_args_correct: wlp. + +(** ** Assignment of memory *) +Definition hslocal_set_smem (hst:hsistate_local) hm := + {| hsi_smem := hm; + hsi_ok_lsval := hsi_ok_lsval hst; + hsi_sreg:= hsi_sreg hst + |}. + +Lemma sok_local_set_mem ge sp rs0 m0 st sm: + sok_local ge sp rs0 m0 (slocal_set_smem st sm) + <-> (sok_local ge sp rs0 m0 st /\ seval_smem ge sp sm rs0 m0 <> None). +Proof. + unfold slocal_set_smem, sok_local; simpl; intuition (subst; eauto). +Qed. + +Lemma hsok_local_set_mem ge sp rs0 m0 hst hsm: + (seval_hsmem ge sp (hsi_smem hst) rs0 m0 = None -> seval_hsmem ge sp hsm rs0 m0 = None) -> + hsok_local ge sp rs0 m0 (hslocal_set_smem hst hsm) + <-> (hsok_local ge sp rs0 m0 hst /\ seval_hsmem ge sp hsm rs0 m0 <> None). +Proof. + unfold hslocal_set_smem, hsok_local; simpl; intuition. +Qed. + +Lemma hslocal_set_mem_correct ge sp rs0 m0 hst st hsm sm: + (seval_hsmem ge sp (hsi_smem hst) rs0 m0 = None -> seval_hsmem ge sp hsm rs0 m0 = None) -> + (forall m b ofs, seval_smem ge sp sm rs0 m0 = Some m -> Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) -> + hsilocal_refines ge sp rs0 m0 hst st -> + (hsok_local ge sp rs0 m0 hst -> smem_refines ge sp rs0 m0 hsm sm) -> + hsilocal_refines ge sp rs0 m0 (hslocal_set_smem hst hsm) (slocal_set_smem st sm). +Proof. + intros PRESERV SMVALID (OKEQ & SMEMEQ' & REGEQ & MVALID) SMEMEQ. + split; rewrite! hsok_local_set_mem; simpl; eauto; try tauto. + rewrite sok_local_set_mem. + intuition congruence. +Qed. + +Definition hslocal_store (hst: hsistate_local) chunk addr args src: ?? hsistate_local := + let pt := hst.(hsi_sreg) in + DO hargs <~ hlist_args pt args;; + DO hsrc <~ hsi_sreg_get pt src;; + DO hm <~ hSstore hst chunk addr hargs hsrc;; + RET (hslocal_set_smem hst hm). + +Lemma hslocal_store_correct hst chunk addr args src: + WHEN hslocal_store hst chunk addr args src ~> hst' THEN forall ge sp rs0 m0 st + (REF: hsilocal_refines ge sp rs0 m0 hst st), + hsilocal_refines ge sp rs0 m0 hst' (slocal_store st chunk addr args src). +Proof. + wlp_simplify. + eapply hslocal_set_mem_correct; simpl; eauto. + + intros X; erewrite H1; eauto. + rewrite X. simplify_SOME z. + + unfold hsilocal_refines in *; + simplify_SOME z; intuition. + erewrite <- Mem.storev_preserv_valid; [| eauto]. + eauto. + + unfold hsilocal_refines in *; intuition eauto. +Qed. +Global Opaque hslocal_store. +Local Hint Resolve hslocal_store_correct: wlp. + +(** ** Assignment of local state *) + +Definition hsist_set_local (hst: hsistate) (pc: node) (hnxt: hsistate_local): hsistate := + {| hsi_pc := pc; hsi_exits := hst.(hsi_exits); hsi_local:= hnxt |}. + +Lemma hsist_set_local_correct_stat hst st pc hnxt nxt: + hsistate_refines_stat hst st -> + hsistate_refines_stat (hsist_set_local hst pc hnxt) (sist_set_local st pc nxt). +Proof. + unfold hsistate_refines_stat; simpl; intuition. +Qed. + +Lemma hsist_set_local_correct_dyn ge sp rs0 m0 hst st pc hnxt nxt: + hsistate_refines_dyn ge sp rs0 m0 hst st -> + hsilocal_refines ge sp rs0 m0 hnxt nxt -> + (sok_local ge sp rs0 m0 nxt -> sok_local ge sp rs0 m0 (si_local st)) -> + hsistate_refines_dyn ge sp rs0 m0 (hsist_set_local hst pc hnxt) (sist_set_local st pc nxt). +Proof. + unfold hsistate_refines_dyn; simpl. + intros (EREF & LREF & NESTED) LREFN SOK; intuition. + destruct NESTED as [|st0 se lse TOP NEST]; econstructor; simpl; auto. +Qed. + +(** ** Assignment of registers *) + +(** locally new symbolic values during symbolic execution *) +Inductive root_sval: Type := +| Rop (op: operation) +| Rload (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) +. + +Definition root_apply (rsv: root_sval) (lr: list reg) (st: sistate_local): sval := + let lsv := list_sval_inj (List.map (si_sreg st) lr) in + let sm := si_smem st in + match rsv with + | Rop op => Sop op lsv sm + | Rload trap chunk addr => Sload sm trap chunk addr lsv + end. +Coercion root_apply: root_sval >-> Funclass. + +Definition root_happly (rsv: root_sval) (lr: list reg) (hst: hsistate_local) : ?? hsval := + DO lhsv <~ hlist_args hst lr;; + match rsv with + | Rop op => hSop op lhsv + | Rload trap chunk addr => hSload hst trap chunk addr lhsv + end. + +Lemma root_happly_correct (rsv: root_sval) lr hst: + WHEN root_happly rsv lr hst ~> hv' THEN forall ge sp rs0 m0 st + (REF:hsilocal_refines ge sp rs0 m0 hst st) + (OK:hsok_local ge sp rs0 m0 hst), + sval_refines ge sp rs0 m0 hv' (rsv lr st). +Proof. + unfold hsilocal_refines, root_apply, root_happly; destruct rsv; wlp_simplify. + unfold sok_local in *. + generalize (H0 ge sp rs0 m0 (list_sval_inj (map (si_sreg st) lr)) (si_smem st)); clear H0. + destruct (seval_smem ge sp (si_smem st) rs0 m0) as [m|] eqn:X; eauto. + intuition congruence. +Qed. +Global Opaque root_happly. +Hint Resolve root_happly_correct: wlp. + +Local Open Scope lazy_bool_scope. + +(* NB: return [false] if the rsv cannot fail *) +Definition may_trap (rsv: root_sval) (lr: list reg): bool := + match rsv with + | Rop op => is_trapping_op op ||| negb (Nat.eqb (length lr) (args_of_operation op)) (* cf. lemma is_trapping_op_sound *) + | Rload TRAP _ _ => true + | _ => false + end. + +Lemma lazy_orb_negb_false (b1 b2:bool): + (b1 ||| negb b2) = false <-> (b1 = false /\ b2 = true). +Proof. + unfold negb; explore; simpl; intuition (try congruence). +Qed. + +Lemma seval_list_sval_length ge sp rs0 m0 (f: reg -> sval) (l:list reg): + forall l', seval_list_sval ge sp (list_sval_inj (List.map f l)) rs0 m0 = Some l' -> + Datatypes.length l = Datatypes.length l'. +Proof. + induction l. + - simpl. intros. inv H. reflexivity. + - simpl. intros. destruct (seval_sval _ _ _ _ _); [|discriminate]. + destruct (seval_list_sval _ _ _ _ _) eqn:SLS; [|discriminate]. inv H. simpl. + erewrite IHl; eauto. +Qed. + +Lemma may_trap_correct (ge: RTL.genv) (sp:val) (rsv: root_sval) (rs0: regset) (m0: mem) (lr: list reg) st: + may_trap rsv lr = false -> + seval_list_sval ge sp (list_sval_inj (List.map (si_sreg st) lr)) rs0 m0 <> None -> + seval_smem ge sp (si_smem st) rs0 m0 <> None -> + seval_sval ge sp (rsv lr st) rs0 m0 <> None. +Proof. + destruct rsv; simpl; try congruence. + - rewrite lazy_orb_negb_false. intros (TRAP1 & TRAP2) OK1 OK2. + explore; try congruence. + eapply is_trapping_op_sound; eauto. + erewrite <- seval_list_sval_length; eauto. + apply Nat.eqb_eq in TRAP2. + assumption. + - intros X OK1 OK2. + explore; try congruence. +Qed. + +(** simplify a symbolic value before assignment to a register *) +Definition simplify (rsv: root_sval) (lr: list reg) (hst: hsistate_local): ?? hsval := + match rsv with + | Rop op => + match is_move_operation op lr with + | Some arg => hsi_sreg_get hst arg (** optimization of Omove *) + | None => + DO lhsv <~ hlist_args hst lr;; + hSop op lhsv + end + | Rload _ chunk addr => + DO lhsv <~ hlist_args hst lr;; + hSload hst NOTRAP chunk addr lhsv + end. + +Lemma simplify_correct rsv lr hst: + WHEN simplify rsv lr hst ~> hv THEN forall ge sp rs0 m0 st + (REF: hsilocal_refines ge sp rs0 m0 hst st) + (OK0: hsok_local ge sp rs0 m0 hst) + (OK1: seval_sval ge sp (rsv lr st) rs0 m0 <> None), + sval_refines ge sp rs0 m0 hv (rsv lr st). +Proof. + destruct rsv; simpl; auto. + - (* Rop *) + destruct (is_move_operation _ _) eqn: Hmove; wlp_simplify. + + exploit is_move_operation_correct; eauto. + intros (Hop & Hlsv); subst; simpl in *. + simplify_SOME z. + * erewrite H; eauto. + * try_simplify_someHyps; congruence. + * congruence. + + clear Hmove. + generalize (H0 ge sp rs0 m0 (list_sval_inj (map (si_sreg st) lr)) (si_smem st)); clear H0. + destruct (seval_smem ge sp (si_smem st) rs0 m0) as [m|] eqn:X; eauto. + intro H0; clear H0; simplify_SOME z; congruence. (* absurd case *) + - (* Rload *) + destruct trap; wlp_simplify. + erewrite H0; eauto. + erewrite H; eauto. + erewrite hsilocal_refines_smem_refines; eauto. + destruct (seval_list_sval _ _ _ _) as [args|] eqn: Hargs; try congruence. + destruct (eval_addressing _ _ _ _) as [a|] eqn: Ha; try congruence. + destruct (seval_smem _ _ _ _) as [m|] eqn: Hm; try congruence. + destruct (Mem.loadv _ _ _); try congruence. +Qed. +Global Opaque simplify. +Local Hint Resolve simplify_correct: wlp. + +Definition red_PTree_set (r: reg) (hsv: hsval) (hst: PTree.t hsval): PTree.t hsval := + match hsv with + | HSinput r' _ => + if Pos.eq_dec r r' + then PTree.remove r' hst + else PTree.set r hsv hst + | _ => PTree.set r hsv hst + end. + +Lemma red_PTree_set_correct (r r0:reg) hsv hst ge sp rs0 m0: + hsi_sreg_eval ge sp (red_PTree_set r hsv hst) r0 rs0 m0 = hsi_sreg_eval ge sp (PTree.set r hsv hst) r0 rs0 m0. +Proof. + destruct hsv; simpl; auto. + destruct (Pos.eq_dec r r1); auto. + subst; unfold hsi_sreg_eval, hsi_sreg_proj. + destruct (Pos.eq_dec r0 r1); auto. + - subst; rewrite PTree.grs, PTree.gss; simpl; auto. + - rewrite PTree.gro, PTree.gso; simpl; auto. +Qed. + +Lemma red_PTree_set_refines (r r0:reg) hsv hst sv st ge sp rs0 m0: + hsilocal_refines ge sp rs0 m0 hst st -> + sval_refines ge sp rs0 m0 hsv sv -> + hsok_local ge sp rs0 m0 hst -> + hsi_sreg_eval ge sp (red_PTree_set r hsv hst) r0 rs0 m0 = seval_sval ge sp (if Pos.eq_dec r r0 then sv else si_sreg st r0) rs0 m0. +Proof. + intros; rewrite red_PTree_set_correct. + exploit hsilocal_refines_sreg; eauto. + unfold hsi_sreg_eval, hsi_sreg_proj. + destruct (Pos.eq_dec r r0); auto. + - subst. rewrite PTree.gss; simpl; auto. + - rewrite PTree.gso; simpl; eauto. +Qed. + +Lemma sok_local_set_sreg (rsv:root_sval) ge sp rs0 m0 st r lr: + sok_local ge sp rs0 m0 (slocal_set_sreg st r (rsv lr st)) + <-> (sok_local ge sp rs0 m0 st /\ seval_sval ge sp (rsv lr st) rs0 m0 <> None). +Proof. + unfold slocal_set_sreg, sok_local; simpl; split. + + intros ((SVAL0 & PRE) & SMEM & SVAL). + repeat (split; try tauto). + - intros r0; generalize (SVAL r0); clear SVAL; destruct (Pos.eq_dec r r0); try congruence. + - generalize (SVAL r); clear SVAL; destruct (Pos.eq_dec r r); try congruence. + + intros ((PRE & SMEM & SVAL0) & SVAL). + repeat (split; try tauto; eauto). + intros r0; destruct (Pos.eq_dec r r0); try congruence. +Qed. + +Definition hslocal_set_sreg (hst: hsistate_local) (r: reg) (rsv: root_sval) (lr: list reg): ?? hsistate_local := + DO ok_lhsv <~ + (if may_trap rsv lr + then DO hv <~ root_happly rsv lr hst;; + XDEBUG hv (fun hv => DO hv_name <~ string_of_hashcode (hsval_get_hid hv);; RET ("-- insert undef behavior of hashcode:" +; (CamlStr hv_name))%string);; + RET (hv::(hsi_ok_lsval hst)) + else RET (hsi_ok_lsval hst));; + DO simp <~ simplify rsv lr hst;; + RET {| hsi_smem := hst; + hsi_ok_lsval := ok_lhsv; + hsi_sreg := red_PTree_set r simp (hsi_sreg hst) |}. + +Lemma hslocal_set_sreg_correct hst r rsv lr: + WHEN hslocal_set_sreg hst r rsv lr ~> hst' THEN forall ge sp rs0 m0 st + (REF: hsilocal_refines ge sp rs0 m0 hst st), + hsilocal_refines ge sp rs0 m0 hst' (slocal_set_sreg st r (rsv lr st)). +Proof. + wlp_simplify. + + (* may_trap ~> true *) + assert (X: sok_local ge sp rs0 m0 (slocal_set_sreg st r (rsv lr st)) <-> + hsok_local ge sp rs0 m0 {| hsi_smem := hst; hsi_ok_lsval := exta :: hsi_ok_lsval hst; hsi_sreg := red_PTree_set r exta0 hst |}). + { rewrite sok_local_set_sreg; generalize REF. + intros (OKeq & MEM & REG & MVALID); rewrite OKeq; clear OKeq. + unfold hsok_local; simpl; intuition (subst; eauto); + erewrite <- H0 in *; eauto; unfold hsok_local; simpl; intuition eauto. + } + unfold hsilocal_refines; simpl; split; auto. + rewrite <- X, sok_local_set_sreg. intuition eauto. + - destruct REF; intuition eauto. + - generalize REF; intros (OKEQ & _). rewrite OKEQ in * |-; erewrite red_PTree_set_refines; eauto. + + (* may_trap ~> false *) + assert (X: sok_local ge sp rs0 m0 (slocal_set_sreg st r (rsv lr st)) <-> + hsok_local ge sp rs0 m0 {| hsi_smem := hst; hsi_ok_lsval := hsi_ok_lsval hst; hsi_sreg := red_PTree_set r exta hst |}). + { + rewrite sok_local_set_sreg; generalize REF. + intros (OKeq & MEM & REG & MVALID); rewrite OKeq. + unfold hsok_local; simpl; intuition (subst; eauto). + assert (X0:hsok_local ge sp rs0 m0 hst). { unfold hsok_local; intuition. } + exploit may_trap_correct; eauto. + * intro X1; eapply seval_list_sval_inj_not_none; eauto. + assert (X2: sok_local ge sp rs0 m0 st). { intuition. } + unfold sok_local in X2; intuition eauto. + * rewrite <- MEM; eauto. + } + unfold hsilocal_refines; simpl; split; auto. + rewrite <- X, sok_local_set_sreg. intuition eauto. + - destruct REF; intuition eauto. + - generalize REF; intros (OKEQ & _). rewrite OKEQ in * |-; erewrite red_PTree_set_refines; eauto. +Qed. +Global Opaque hslocal_set_sreg. +Local Hint Resolve hslocal_set_sreg_correct: wlp. + +(** ** Execution of one instruction *) + +Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) := + match i with + | Inop pc' => + RET (Some (hsist_set_local hst pc' hst.(hsi_local))) + | Iop op args dst pc' => + DO next <~ hslocal_set_sreg hst.(hsi_local) dst (Rop op) args;; + RET (Some (hsist_set_local hst pc' next)) + | Iload trap chunk addr args dst pc' => + DO next <~ hslocal_set_sreg hst.(hsi_local) dst (Rload trap chunk addr) args;; + RET (Some (hsist_set_local hst pc' next)) + | Istore chunk addr args src pc' => + DO next <~ hslocal_store hst.(hsi_local) chunk addr args src;; + RET (Some (hsist_set_local hst pc' next)) + | Icond cond args ifso ifnot _ => + let prev := hst.(hsi_local) in + DO vargs <~ hlist_args prev args ;; + let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in + RET (Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |}) + | _ => RET None (* TODO jumptable ? *) + end. + + +Remark hsiexec_inst_None_correct i hst: + WHEN hsiexec_inst i hst ~> o THEN forall st, o = None -> siexec_inst i st = None. +Proof. + destruct i; wlp_simplify; congruence. +Qed. + +Lemma seval_condition_refines hst st ge sp cond hargs args rs m: + hsok_local ge sp rs m hst -> + hsilocal_refines ge sp rs m hst st -> + list_sval_refines ge sp rs m hargs args -> + hseval_condition ge sp cond hargs (hsi_smem hst) rs m + = seval_condition ge sp cond args (si_smem st) rs m. + Proof. + intros HOK (_ & MEMEQ & _) LR. unfold hseval_condition, seval_condition. + rewrite LR, <- MEMEQ; auto. +Qed. + +Lemma sok_local_set_sreg_simp (rsv:root_sval) ge sp rs0 m0 st r lr: + sok_local ge sp rs0 m0 (slocal_set_sreg st r (rsv lr st)) + -> sok_local ge sp rs0 m0 st. +Proof. + rewrite sok_local_set_sreg; intuition. +Qed. + +Local Hint Resolve hsist_set_local_correct_stat: core. + +Lemma hsiexec_inst_correct i hst: + WHEN hsiexec_inst i hst ~> o THEN forall hst' st, + o = Some hst' -> + exists st', siexec_inst i st = Some st' + /\ (forall (REF:hsistate_refines_stat hst st), hsistate_refines_stat hst' st') + /\ (forall ge sp rs0 m0 (REF:hsistate_refines_dyn ge sp rs0 m0 hst st), hsistate_refines_dyn ge sp rs0 m0 hst' st'). +Proof. + destruct i; simpl; wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + - (* refines_dyn Iop *) + eapply hsist_set_local_correct_dyn; eauto. + generalize (sok_local_set_sreg_simp (Rop o)); simpl; eauto. + - (* refines_dyn Iload *) + eapply hsist_set_local_correct_dyn; eauto. + generalize (sok_local_set_sreg_simp (Rload t0 m a)); simpl; eauto. + - (* refines_dyn Istore *) + eapply hsist_set_local_correct_dyn; eauto. + unfold sok_local; simpl; intuition. + - (* refines_stat Icond *) + unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. + constructor; simpl; eauto. + constructor. + - (* refines_dyn Icond *) + destruct REF as (EXREF & LREF & NEST). + split. + + constructor; simpl; auto. + constructor; simpl; auto. + intros; erewrite seval_condition_refines; eauto. + + split; simpl; auto. + destruct NEST as [|st0 se lse TOP NEST]; + econstructor; simpl; auto; constructor; auto. +Qed. +Global Opaque hsiexec_inst. +Local Hint Resolve hsiexec_inst_correct: wlp. + + +Definition some_or_fail {A} (o: option A) (msg: pstring): ?? A := + match o with + | Some x => RET x + | None => FAILWITH msg + end. + +Fixpoint hsiexec_path (path:nat) (f: function) (hst: hsistate): ?? hsistate := + match path with + | O => RET hst + | S p => + let pc := hst.(hsi_pc) in + XDEBUG pc (fun pc => DO name_pc <~ string_of_Z (Zpos pc);; RET ("- sym exec node: " +; name_pc)%string);; + DO i <~ some_or_fail ((fn_code f)!pc) "hsiexec_path.internal_error.1";; + DO ohst1 <~ hsiexec_inst i hst;; + DO hst1 <~ some_or_fail ohst1 "hsiexec_path.internal_error.2";; + hsiexec_path p f hst1 + end. + +Lemma hsiexec_path_correct path f: forall hst, + WHEN hsiexec_path path f hst ~> hst' THEN forall st + (RSTAT:hsistate_refines_stat hst st), + exists st', siexec_path path f st = Some st' + /\ hsistate_refines_stat hst' st' + /\ (forall ge sp rs0 m0 (REF:hsistate_refines_dyn ge sp rs0 m0 hst st), hsistate_refines_dyn ge sp rs0 m0 hst' st'). +Proof. + induction path; wlp_simplify; try_simplify_someHyps. clear IHpath. + generalize RSTAT; intros (PCEQ & _) INSTEQ. + rewrite <- PCEQ, INSTEQ; simpl. + exploit H0; eauto. clear H0. + intros (st0 & SINST & ISTAT & IDYN); erewrite SINST. + exploit H1; eauto. clear H1. + intros (st' & SPATH & PSTAT & PDYN). + eexists; intuition eauto. +Qed. +Global Opaque hsiexec_path. +Local Hint Resolve hsiexec_path_correct: wlp. + +Fixpoint hbuiltin_arg (hst: PTree.t hsval) (arg : builtin_arg reg): ?? builtin_arg hsval := + match arg with + | BA r => + DO v <~ hsi_sreg_get hst r;; + RET (BA v) + | BA_int n => RET (BA_int n) + | BA_long n => RET (BA_long n) + | BA_float f0 => RET (BA_float f0) + | BA_single s => RET (BA_single s) + | BA_loadstack chunk ptr => RET (BA_loadstack chunk ptr) + | BA_addrstack ptr => RET (BA_addrstack ptr) + | BA_loadglobal chunk id ptr => RET (BA_loadglobal chunk id ptr) + | BA_addrglobal id ptr => RET (BA_addrglobal id ptr) + | BA_splitlong ba1 ba2 => + DO v1 <~ hbuiltin_arg hst ba1;; + DO v2 <~ hbuiltin_arg hst ba2;; + RET (BA_splitlong v1 v2) + | BA_addptr ba1 ba2 => + DO v1 <~ hbuiltin_arg hst ba1;; + DO v2 <~ hbuiltin_arg hst ba2;; + RET (BA_addptr v1 v2) + end. + +Lemma hbuiltin_arg_correct hst arg: + WHEN hbuiltin_arg hst arg ~> hargs THEN forall ge sp rs0 m0 (f: reg -> sval) + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + seval_builtin_sval ge sp (builtin_arg_map hsval_proj hargs) rs0 m0 = seval_builtin_sval ge sp (builtin_arg_map f arg) rs0 m0. +Proof. + induction arg; wlp_simplify. + + erewrite H; eauto. + + erewrite H; eauto. + erewrite H0; eauto. + + erewrite H; eauto. + erewrite H0; eauto. +Qed. +Global Opaque hbuiltin_arg. +Local Hint Resolve hbuiltin_arg_correct: wlp. + +Fixpoint hbuiltin_args (hst: PTree.t hsval) (args: list (builtin_arg reg)): ?? list (builtin_arg hsval) := + match args with + | nil => RET nil + | a::l => + DO ha <~ hbuiltin_arg hst a;; + DO hl <~ hbuiltin_args hst l;; + RET (ha::hl) + end. + +Lemma hbuiltin_args_correct hst args: + WHEN hbuiltin_args hst args ~> hargs THEN forall ge sp rs0 m0 (f: reg -> sval) + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + bargs_refines ge sp rs0 m0 hargs (List.map (builtin_arg_map f) args). +Proof. + unfold bargs_refines, seval_builtin_args; induction args; wlp_simplify. + erewrite H; eauto. + erewrite H0; eauto. +Qed. +Global Opaque hbuiltin_args. +Local Hint Resolve hbuiltin_args_correct: wlp. + +Definition hsum_left (hst: PTree.t hsval) (ros: reg + ident): ?? (hsval + ident) := + match ros with + | inl r => DO hr <~ hsi_sreg_get hst r;; RET (inl hr) + | inr s => RET (inr s) + end. + +Lemma hsum_left_correct hst ros: + WHEN hsum_left hst ros ~> hsi THEN forall ge sp rs0 m0 (f: reg -> sval) + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + sum_refines ge sp rs0 m0 hsi (sum_left_map f ros). +Proof. + unfold sum_refines; destruct ros; wlp_simplify. +Qed. +Global Opaque hsum_left. +Local Hint Resolve hsum_left_correct: wlp. + +Definition hsexec_final (i: instruction) (hst: PTree.t hsval): ?? hsfval := + match i with + | Icall sig ros args res pc => + DO svos <~ hsum_left hst ros;; + DO sargs <~ hlist_args hst args;; + RET (HScall sig svos sargs res pc) + | Itailcall sig ros args => + DO svos <~ hsum_left hst ros;; + DO sargs <~ hlist_args hst args;; + RET (HStailcall sig svos sargs) + | Ibuiltin ef args res pc => + DO sargs <~ hbuiltin_args hst args;; + RET (HSbuiltin ef sargs res pc) + | Ijumptable reg tbl => + DO sv <~ hsi_sreg_get hst reg;; + RET (HSjumptable sv tbl) + | Ireturn or => + match or with + | Some r => DO hr <~ hsi_sreg_get hst r;; RET (HSreturn (Some hr)) + | None => RET (HSreturn None) + end + | _ => RET (HSnone) + end. + +Lemma hsexec_final_correct (hsl: hsistate_local) i: + WHEN hsexec_final i hsl ~> hsf THEN forall ge sp rs0 m0 sl + (OK: hsok_local ge sp rs0 m0 hsl) + (REF: hsilocal_refines ge sp rs0 m0 hsl sl), + hfinal_refines ge sp rs0 m0 hsf (sexec_final i sl). +Proof. + destruct i; wlp_simplify; try econstructor; simpl; eauto. +Qed. +Global Opaque hsexec_final. +Local Hint Resolve hsexec_final_correct: wlp. + +Definition init_hsistate_local (_:unit): ?? hsistate_local + := DO hm <~ hSinit ();; + RET {| hsi_smem := hm; hsi_ok_lsval := nil; hsi_sreg := PTree.empty hsval |}. + +Lemma init_hsistate_local_correct: + WHEN init_hsistate_local () ~> hsl THEN forall ge sp rs0 m0, + hsilocal_refines ge sp rs0 m0 hsl init_sistate_local. +Proof. + unfold hsilocal_refines; wlp_simplify. + - unfold hsok_local; simpl; intuition. erewrite H in *; congruence. + - unfold hsok_local, sok_local; simpl in *; intuition; try congruence. + - unfold hsi_sreg_eval, hsi_sreg_proj. rewrite PTree.gempty. reflexivity. + - try_simplify_someHyps. +Qed. +Global Opaque init_hsistate_local. +Local Hint Resolve init_hsistate_local_correct: wlp. + +Definition init_hsistate pc: ?? hsistate + := DO hst <~ init_hsistate_local ();; + RET {| hsi_pc := pc; hsi_exits := nil; hsi_local := hst |}. + +Lemma init_hsistate_correct pc: + WHEN init_hsistate pc ~> hst THEN + hsistate_refines_stat hst (init_sistate pc) + /\ forall ge sp rs0 m0, hsistate_refines_dyn ge sp rs0 m0 hst (init_sistate pc). +Proof. + unfold hsistate_refines_stat, hsistate_refines_dyn, hsiexits_refines_dyn; wlp_simplify; constructor. +Qed. +Global Opaque init_hsistate. +Local Hint Resolve init_hsistate_correct: wlp. + +Definition hsexec (f: function) (pc:node): ?? hsstate := + DO path <~ some_or_fail ((fn_path f)!pc) "hsexec.internal_error.1";; + DO hinit <~ init_hsistate pc;; + DO hst <~ hsiexec_path path.(psize) f hinit;; + DO i <~ some_or_fail ((fn_code f)!(hst.(hsi_pc))) "hsexec.internal_error.2";; + DO ohst <~ hsiexec_inst i hst;; + match ohst with + | Some hst' => RET {| hinternal := hst'; hfinal := HSnone |} + | None => DO hsvf <~ hsexec_final i hst.(hsi_local);; + RET {| hinternal := hst; hfinal := hsvf |} + end. + +Lemma hsexec_correct_aux f pc: + WHEN hsexec f pc ~> hst THEN + exists st, sexec f pc = Some st /\ hsstate_refines hst st. +Proof. + unfold hsstate_refines, sexec; wlp_simplify. + - (* Some *) + rewrite H; clear H. + exploit H0; clear H0; eauto. + intros (st0 & EXECPATH & SREF & DREF). + rewrite EXECPATH; clear EXECPATH. + generalize SREF. intros (EQPC & _). + rewrite <- EQPC, H3; clear H3. + exploit H4; clear H4; eauto. + intros (st' & EXECL & SREF' & DREF'). + try_simplify_someHyps. + eexists; intuition (simpl; eauto). + constructor. + - (* None *) + rewrite H; clear H H4. + exploit H0; clear H0; eauto. + intros (st0 & EXECPATH & SREF & DREF). + rewrite EXECPATH; clear EXECPATH. + generalize SREF. intros (EQPC & _). + rewrite <- EQPC, H3; clear H3. + erewrite hsiexec_inst_None_correct; eauto. + eexists; intuition (simpl; eauto). +Qed. + +Global Opaque hsexec. + +End CanonBuilding. + +(** Correction of concrete symbolic execution wrt abstract symbolic execution *) +Theorem hsexec_correct + (hC_hsval : hashinfo hsval -> ?? hsval) + (hC_list_hsval : hashinfo list_hsval -> ?? list_hsval) + (hC_hsmem : hashinfo hsmem -> ?? hsmem) + (f : function) + (pc : node): + WHEN hsexec hC_hsval hC_list_hsval hC_hsmem f pc ~> hst THEN forall + (hC_hsval_correct: forall hs, + WHEN hC_hsval hs ~> hs' THEN forall ge sp rs0 m0, + seval_sval ge sp (hsval_proj (hdata hs)) rs0 m0 = + seval_sval ge sp (hsval_proj hs') rs0 m0) + (hC_list_hsval_correct: forall lh, + WHEN hC_list_hsval lh ~> lh' THEN forall ge sp rs0 m0, + seval_list_sval ge sp (hsval_list_proj (hdata lh)) rs0 m0 = + seval_list_sval ge sp (hsval_list_proj lh') rs0 m0) + (hC_hsmem_correct: forall hm, + WHEN hC_hsmem hm ~> hm' THEN forall ge sp rs0 m0, + seval_smem ge sp (hsmem_proj (hdata hm)) rs0 m0 = + seval_smem ge sp (hsmem_proj hm') rs0 m0), + exists st : sstate, sexec f pc = Some st /\ hsstate_refines hst st. +Proof. + wlp_simplify. + eapply hsexec_correct_aux; eauto. +Qed. +Local Hint Resolve hsexec_correct: wlp. + +(** * Implementing the simulation test with concrete hash-consed symbolic execution *) + +Definition phys_check {A} (x y:A) (msg: pstring): ?? unit := + DO b <~ phys_eq x y;; + assert_b b msg;; + RET tt. + +Definition struct_check {A} (x y: A) (msg: pstring): ?? unit := + DO b <~ struct_eq x y;; + assert_b b msg;; + RET tt. + +Lemma struct_check_correct {A} (a b: A) msg: + WHEN struct_check a b msg ~> _ THEN + a = b. +Proof. wlp_simplify. Qed. +Global Opaque struct_check. +Hint Resolve struct_check_correct: wlp. + +Definition option_eq_check {A} (o1 o2: option A): ?? unit := + match o1, o2 with + | Some x1, Some x2 => phys_check x1 x2 "option_eq_check: data physically differ" + | None, None => RET tt + | _, _ => FAILWITH "option_eq_check: structure differs" + end. + +Lemma option_eq_check_correct A (o1 o2: option A): WHEN option_eq_check o1 o2 ~> _ THEN o1=o2. +Proof. + wlp_simplify. +Qed. +Global Opaque option_eq_check. +Hint Resolve option_eq_check_correct:wlp. + +Import PTree. + +Fixpoint PTree_eq_check {A} (d1 d2: PTree.t A): ?? unit := + match d1, d2 with + | Leaf, Leaf => RET tt + | Node l1 o1 r1, Node l2 o2 r2 => + option_eq_check o1 o2;; + PTree_eq_check l1 l2;; + PTree_eq_check r1 r2 + | _, _ => FAILWITH "PTree_eq_check: some key is absent" + end. + +Lemma PTree_eq_check_correct A d1: forall (d2: t A), + WHEN PTree_eq_check d1 d2 ~> _ THEN forall x, PTree.get x d1 = PTree.get x d2. +Proof. + induction d1 as [|l1 Hl1 o1 r1 Hr1]; destruct d2 as [|l2 o2 r2]; simpl; + wlp_simplify. destruct x; simpl; auto. +Qed. +Global Opaque PTree_eq_check. +Local Hint Resolve PTree_eq_check_correct: wlp. + +Fixpoint PTree_frame_eq_check {A} (frame: list positive) (d1 d2: PTree.t A): ?? unit := + match frame with + | nil => RET tt + | k::l => + option_eq_check (PTree.get k d1) (PTree.get k d2);; + PTree_frame_eq_check l d1 d2 + end. + +Lemma PTree_frame_eq_check_correct A l (d1 d2: t A): + WHEN PTree_frame_eq_check l d1 d2 ~> _ THEN forall x, List.In x l -> PTree.get x d1 = PTree.get x d2. +Proof. + induction l as [|k l]; simpl; wlp_simplify. + subst; auto. +Qed. +Global Opaque PTree_frame_eq_check. +Local Hint Resolve PTree_frame_eq_check_correct: wlp. + +Definition hsilocal_simu_check hst1 hst2 : ?? unit := + DEBUG("? last check");; + phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_simu_check: hsi_smem sets aren't equiv";; + PTree_eq_check (hsi_sreg hst1) (hsi_sreg hst2);; + Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; + DEBUG("=> last check: OK"). + +Lemma hsilocal_simu_check_correct hst1 hst2: + WHEN hsilocal_simu_check hst1 hst2 ~> _ THEN + hsilocal_simu_spec None hst1 hst2. +Proof. + unfold hsilocal_simu_spec; wlp_simplify. +Qed. +Hint Resolve hsilocal_simu_check_correct: wlp. +Global Opaque hsilocal_simu_check. + +Definition hsilocal_frame_simu_check frame hst1 hst2 : ?? unit := + DEBUG("? frame check");; + phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_frame_simu_check: hsi_smem sets aren't equiv";; + PTree_frame_eq_check frame (hsi_sreg hst1) (hsi_sreg hst2);; + Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; + DEBUG("=> frame check: OK"). + +Lemma setoid_in {A: Type} (a: A): forall l, + SetoidList.InA (fun x y => x = y) a l -> + In a l. +Proof. + induction l; intros; inv H. + - constructor. reflexivity. + - right. auto. +Qed. + +Lemma regset_elements_in r rs: + Regset.In r rs -> + In r (Regset.elements rs). +Proof. + intros. exploit Regset.elements_1; eauto. intro SIN. + apply setoid_in. assumption. +Qed. +Local Hint Resolve regset_elements_in: core. + +Lemma hsilocal_frame_simu_check_correct hst1 hst2 alive: + WHEN hsilocal_frame_simu_check (Regset.elements alive) hst1 hst2 ~> _ THEN + hsilocal_simu_spec (Some alive) hst1 hst2. +Proof. + unfold hsilocal_simu_spec; wlp_simplify. symmetry; eauto. +Qed. +Hint Resolve hsilocal_frame_simu_check_correct: wlp. +Global Opaque hsilocal_frame_simu_check. + +Definition revmap_check_single (dm: PTree.t node) (n tn: node) : ?? unit := + DO res <~ some_or_fail (dm ! tn) "revmap_check_single: no mapping for tn";; + struct_check n res "revmap_check_single: n and res are physically different". + +Lemma revmap_check_single_correct dm pc1 pc2: + WHEN revmap_check_single dm pc1 pc2 ~> _ THEN + dm ! pc2 = Some pc1. +Proof. + wlp_simplify. congruence. +Qed. +Hint Resolve revmap_check_single_correct: wlp. +Global Opaque revmap_check_single. + +Definition hsiexit_simu_check (dm: PTree.t node) (f: RTLpath.function) (hse1 hse2: hsistate_exit): ?? unit := + struct_check (hsi_cond hse1) (hsi_cond hse2) "hsiexit_simu_check: conditions do not match";; + phys_check (hsi_scondargs hse1) (hsi_scondargs hse2) "hsiexit_simu_check: args do not match";; + revmap_check_single dm (hsi_ifso hse1) (hsi_ifso hse2);; + DO path <~ some_or_fail ((fn_path f) ! (hsi_ifso hse1)) "hsiexit_simu_check: internal error";; + hsilocal_frame_simu_check (Regset.elements path.(input_regs)) (hsi_elocal hse1) (hsi_elocal hse2). + +Lemma hsiexit_simu_check_correct dm f hse1 hse2: + WHEN hsiexit_simu_check dm f hse1 hse2 ~> _ THEN + hsiexit_simu_spec dm f hse1 hse2. +Proof. + unfold hsiexit_simu_spec; wlp_simplify. +Qed. +Hint Resolve hsiexit_simu_check_correct: wlp. +Global Opaque hsiexit_simu_check. + +Fixpoint hsiexits_simu_check (dm: PTree.t node) (f: RTLpath.function) (lhse1 lhse2: list hsistate_exit) := + match lhse1,lhse2 with + | nil, nil => RET tt + | hse1 :: lhse1, hse2 :: lhse2 => + hsiexit_simu_check dm f hse1 hse2;; + hsiexits_simu_check dm f lhse1 lhse2 + | _, _ => FAILWITH "siexists_simu_check: lengths do not match" + end. + +Lemma hsiexits_simu_check_correct dm f: forall le1 le2, + WHEN hsiexits_simu_check dm f le1 le2 ~> _ THEN + hsiexits_simu_spec dm f le1 le2. +Proof. + unfold hsiexits_simu_spec; induction le1; simpl; destruct le2; wlp_simplify; constructor; eauto. +Qed. +Hint Resolve hsiexits_simu_check_correct: wlp. +Global Opaque hsiexits_simu_check. + +Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsistate) := + hsiexits_simu_check dm f (hsi_exits hst1) (hsi_exits hst2);; + hsilocal_simu_check (hsi_local hst1) (hsi_local hst2). + +Lemma hsistate_simu_check_correct dm f hst1 hst2: + WHEN hsistate_simu_check dm f hst1 hst2 ~> _ THEN + hsistate_simu_spec dm f hst1 hst2. +Proof. + unfold hsistate_simu_spec; wlp_simplify. +Qed. +Hint Resolve hsistate_simu_check_correct: wlp. +Global Opaque hsistate_simu_check. + + +Fixpoint revmap_check_list (dm: PTree.t node) (ln ln': list node): ?? unit := + match ln, ln' with + | nil, nil => RET tt + | n::ln, n'::ln' => + revmap_check_single dm n n';; + revmap_check_list dm ln ln' + | _, _ => FAILWITH "revmap_check_list: lists have different lengths" + end. + +Lemma revmap_check_list_correct dm: forall lpc lpc', + WHEN revmap_check_list dm lpc lpc' ~> _ THEN + ptree_get_list dm lpc' = Some lpc. +Proof. + induction lpc. + - destruct lpc'; wlp_simplify. + - destruct lpc'; wlp_simplify. try_simplify_someHyps. +Qed. +Global Opaque revmap_check_list. +Hint Resolve revmap_check_list_correct: wlp. + + +Definition svos_simu_check (svos1 svos2: hsval + ident) := + match svos1, svos2 with + | inl sv1, inl sv2 => phys_check sv1 sv2 "svos_simu_check: sval mismatch" + | inr id1, inr id2 => phys_check id1 id2 "svos_simu_check: symbol mismatch" + | _, _ => FAILWITH "svos_simu_check: type mismatch" + end. + +Lemma svos_simu_check_correct svos1 svos2: + WHEN svos_simu_check svos1 svos2 ~> _ THEN + svos1 = svos2. +Proof. + destruct svos1; destruct svos2; wlp_simplify. +Qed. +Global Opaque svos_simu_check. +Hint Resolve svos_simu_check_correct: wlp. + + +Fixpoint builtin_arg_simu_check (bs bs': builtin_arg hsval) := + match bs with + | BA sv => + match bs' with + | BA sv' => phys_check sv sv' "builtin_arg_simu_check: sval mismatch" + | _ => FAILWITH "builtin_arg_simu_check: BA mismatch" + end + | BA_splitlong lo hi => + match bs' with + | BA_splitlong lo' hi' => + builtin_arg_simu_check lo lo';; + builtin_arg_simu_check hi hi' + | _ => FAILWITH "builtin_arg_simu_check: BA_splitlong mismatch" + end + | BA_addptr b1 b2 => + match bs' with + | BA_addptr b1' b2' => + builtin_arg_simu_check b1 b1';; + builtin_arg_simu_check b2 b2' + | _ => FAILWITH "builtin_arg_simu_check: BA_addptr mismatch" + end + | bs => struct_check bs bs' "builtin_arg_simu_check: basic mismatch" + end. + +Lemma builtin_arg_simu_check_correct: forall bs1 bs2, + WHEN builtin_arg_simu_check bs1 bs2 ~> _ THEN + builtin_arg_map hsval_proj bs1 = builtin_arg_map hsval_proj bs2. +Proof. + induction bs1. + all: try (wlp_simplify; subst; reflexivity). + all: destruct bs2; wlp_simplify; congruence. +Qed. +Global Opaque builtin_arg_simu_check. +Hint Resolve builtin_arg_simu_check_correct: wlp. + +Fixpoint list_builtin_arg_simu_check lbs1 lbs2 := + match lbs1, lbs2 with + | nil, nil => RET tt + | bs1::lbs1, bs2::lbs2 => + builtin_arg_simu_check bs1 bs2;; + list_builtin_arg_simu_check lbs1 lbs2 + | _, _ => FAILWITH "list_builtin_arg_simu_check: length mismatch" + end. + +Lemma list_builtin_arg_simu_check_correct: forall lbs1 lbs2, + WHEN list_builtin_arg_simu_check lbs1 lbs2 ~> _ THEN + List.map (builtin_arg_map hsval_proj) lbs1 = List.map (builtin_arg_map hsval_proj) lbs2. +Proof. + induction lbs1; destruct lbs2; wlp_simplify. congruence. +Qed. +Global Opaque list_builtin_arg_simu_check. +Hint Resolve list_builtin_arg_simu_check_correct: wlp. + +Definition sfval_simu_check (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (fv1 fv2: hsfval) := + match fv1, fv2 with + | HSnone, HSnone => revmap_check_single dm pc1 pc2 + | HScall sig1 svos1 lsv1 res1 pc1, HScall sig2 svos2 lsv2 res2 pc2 => + revmap_check_single dm pc1 pc2;; + phys_check sig1 sig2 "sfval_simu_check: Scall different signatures";; + phys_check res1 res2 "sfval_simu_check: Scall res do not match";; + svos_simu_check svos1 svos2;; + phys_check lsv1 lsv2 "sfval_simu_check: Scall args do not match" + | HStailcall sig1 svos1 lsv1, HStailcall sig2 svos2 lsv2 => + phys_check sig1 sig2 "sfval_simu_check: Stailcall different signatures";; + svos_simu_check svos1 svos2;; + phys_check lsv1 lsv2 "sfval_simu_check: Stailcall args do not match" + | HSbuiltin ef1 lbs1 br1 pc1, HSbuiltin ef2 lbs2 br2 pc2 => + revmap_check_single dm pc1 pc2;; + phys_check ef1 ef2 "sfval_simu_check: builtin ef do not match";; + phys_check br1 br2 "sfval_simu_check: builtin br do not match";; + list_builtin_arg_simu_check lbs1 lbs2 + | HSjumptable sv ln, HSjumptable sv' ln' => + revmap_check_list dm ln ln';; + phys_check sv sv' "sfval_simu_check: Sjumptable sval do not match" + | HSreturn osv1, HSreturn osv2 => + option_eq_check osv1 osv2 + | _, _ => FAILWITH "sfval_simu_check: structure mismatch" + end. + +Lemma sfval_simu_check_correct dm f opc1 opc2 fv1 fv2: + WHEN sfval_simu_check dm f opc1 opc2 fv1 fv2 ~> _ THEN + hfinal_simu_spec dm f opc1 opc2 fv1 fv2. +Proof. + unfold hfinal_simu_spec; destruct fv1; destruct fv2; wlp_simplify; try congruence. +Qed. +Hint Resolve sfval_simu_check_correct: wlp. +Global Opaque sfval_simu_check. + +Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := + hsistate_simu_check dm f (hinternal hst1) (hinternal hst2);; + sfval_simu_check dm f (hsi_pc hst1) (hsi_pc hst2) (hfinal hst1) (hfinal hst2). + +Lemma hsstate_simu_check_correct dm f hst1 hst2: + WHEN hsstate_simu_check dm f hst1 hst2 ~> _ THEN + hsstate_simu_spec dm f hst1 hst2. +Proof. + unfold hsstate_simu_spec; wlp_simplify. +Qed. +Hint Resolve hsstate_simu_check_correct: wlp. +Global Opaque hsstate_simu_check. + +Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node): ?? unit := + let (pc2, pc1) := m in + (* creating the hash-consing tables *) + DO hC_sval <~ hCons hSVAL;; + DO hC_list_hsval <~ hCons hLSVAL;; + DO hC_hsmem <~ hCons hSMEM;; + let hsexec := hsexec hC_sval.(hC) hC_list_hsval.(hC) hC_hsmem.(hC) in + (* performing the hash-consed executions *) + XDEBUG pc1 (fun pc => DO name_pc <~ string_of_Z (Zpos pc);; RET ("entry-point of input superblock: " +; name_pc)%string);; + DO hst1 <~ hsexec f pc1;; + XDEBUG pc2 (fun pc => DO name_pc <~ string_of_Z (Zpos pc);; RET ("entry-point of output superblock: " +; name_pc)%string);; + DO hst2 <~ hsexec tf pc2;; + (* comparing the executions *) + hsstate_simu_check dm f hst1 hst2. + +Lemma simu_check_single_correct dm tf f pc1 pc2: + WHEN simu_check_single dm f tf (pc2, pc1) ~> _ THEN + sexec_simu dm f tf pc1 pc2. +Proof. + unfold sexec_simu; wlp_simplify. + exploit H2; clear H2. 1-3: wlp_simplify. + intros (st2 & SEXEC2 & REF2). try_simplify_someHyps. + exploit H3; clear H3. 1-3: wlp_simplify. + intros (st3 & SEXEC3 & REF3). try_simplify_someHyps. + eexists. split; eauto. + intros ctx. + eapply hsstate_simu_spec_correct; eauto. +Qed. +Global Opaque simu_check_single. +Global Hint Resolve simu_check_single_correct: wlp. + +Fixpoint simu_check_rec (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) lm : ?? unit := + match lm with + | nil => RET tt + | m :: lm => + simu_check_single dm f tf m;; + simu_check_rec dm f tf lm + end. + +Lemma simu_check_rec_correct dm f tf lm: + WHEN simu_check_rec dm f tf lm ~> _ THEN + forall pc1 pc2, In (pc2, pc1) lm -> sexec_simu dm f tf pc1 pc2. +Proof. + induction lm; wlp_simplify. + match goal with + | X: (_,_) = (_,_) |- _ => inversion X; subst + end. + subst; eauto. +Qed. +Global Opaque simu_check_rec. +Global Hint Resolve simu_check_rec_correct: wlp. + +Definition imp_simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function): ?? unit := + simu_check_rec dm f tf (PTree.elements dm);; + DEBUG("simu_check OK!"). + +Local Hint Resolve PTree.elements_correct: core. +Lemma imp_simu_check_correct dm f tf: + WHEN imp_simu_check dm f tf ~> _ THEN + forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2. +Proof. + wlp_simplify. +Qed. +Global Opaque imp_simu_check. +Global Hint Resolve imp_simu_check_correct: wlp. + +Program Definition aux_simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function): ?? bool := + DO r <~ + (TRY + imp_simu_check dm f tf;; + RET true + CATCH_FAIL s, _ => + println ("simu_check_failure:" +; s);; + RET false + ENSURE (fun b => b=true -> forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2));; + RET (`r). +Obligation 1. + split; wlp_simplify. discriminate. +Qed. + +Lemma aux_simu_check_correct dm f tf: + WHEN aux_simu_check dm f tf ~> b THEN + b=true -> forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2. +Proof. + unfold aux_simu_check; wlp_simplify. + destruct exta; simpl; auto. +Qed. + +(* Coerce aux_simu_check into a pure function (this is a little unsafe like all oracles in CompCert). *) + +Import UnsafeImpure. + +Definition simu_check (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) : res unit := + match unsafe_coerce (aux_simu_check dm f tf) with + | Some true => OK tt + | _ => Error (msg "simu_check has failed") + end. + +Lemma simu_check_correct dm f tf: + simu_check dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + sexec_simu dm f tf pc1 pc2. +Proof. + unfold simu_check. + destruct (unsafe_coerce (aux_simu_check dm f tf)) as [[|]|] eqn:Hres; simpl; try discriminate. + intros; eapply aux_simu_check_correct; eauto. + eapply unsafe_coerce_not_really_correct; eauto. +Qed.
\ No newline at end of file diff --git a/scheduling/RTLpathSE_simu_specs.v b/scheduling/RTLpathSE_simu_specs.v new file mode 100644 index 00000000..c9e272c0 --- /dev/null +++ b/scheduling/RTLpathSE_simu_specs.v @@ -0,0 +1,889 @@ +(** Low-level specifications of the simulation tests by symbolic execution with hash-consing *) + +Require Import Coqlib Maps Floats. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL RTLpath. +Require Import Errors. +Require Import RTLpathSE_theory RTLpathLivegenproof. +Require Import Axioms. + +Local Open Scope error_monad_scope. +Local Open Scope option_monad_scope. + +Require Export Impure.ImpHCons. + +Import ListNotations. +Local Open Scope list_scope. + +(** * Auxilary notions on simulation tests *) + +Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := + forall is1, ssem_local (the_ge1 ctx) (the_sp ctx) sl1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) -> + exists is2, ssem_local (the_ge2 ctx) (the_sp ctx) sl2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) + /\ istate_simu f dm is1 is2. + +(* a kind of negation of sabort_local *) +Definition sok_local (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) (st: sistate_local): Prop := + (st.(si_pre) ge sp rs0 m0) + /\ seval_smem ge sp st.(si_smem) rs0 m0 <> None + /\ forall (r: reg), seval_sval ge sp (si_sreg st r) rs0 m0 <> None. + +Lemma ssem_local_sok ge sp rs0 m0 st rs m: + ssem_local ge sp st rs0 m0 rs m -> sok_local ge sp rs0 m0 st. +Proof. + unfold sok_local, ssem_local. + intuition congruence. +Qed. + +Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof_context f) (se1 se2: sistate_exit) := + (sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1) -> + (seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond se1) (si_scondargs se1) + (si_smem (si_elocal se1)) (the_rs0 ctx) (the_m0 ctx)) = + (seval_condition (the_ge2 ctx) (the_sp ctx) (si_cond se2) (si_scondargs se2) + (si_smem (si_elocal se2)) (the_rs0 ctx) (the_m0 ctx))) + /\ forall is1, + icontinue is1 = false -> + ssem_exit (the_ge1 ctx) (the_sp ctx) se1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) (ipc is1) -> + exists is2, + ssem_exit (the_ge2 ctx) (the_sp ctx) se2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) (ipc is2) + /\ istate_simu f dm is1 is2. + +Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := + list_forall2 (siexit_simu dm f ctx) lse1 lse2. + + +(** * Implementation of Data-structure use in Hash-consing *) + +(** ** Implementation of symbolic values/symbolic memories with hash-consing data *) + +Inductive hsval := + | HSinput (r: reg) (hid: hashcode) + | HSop (op: operation) (lhsv: list_hsval) (hid: hashcode) (** NB: does not depend on the memory ! *) + | HSload (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval) (hid: hashcode) +with list_hsval := + | HSnil (hid: hashcode) + | HScons (hsv: hsval) (lhsv: list_hsval) (hid: hashcode) +with hsmem := + | HSinit (hid: hashcode) + | HSstore (hsm: hsmem) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval) (srce: hsval) (hid:hashcode). + +Scheme hsval_mut := Induction for hsval Sort Prop +with list_hsval_mut := Induction for list_hsval Sort Prop +with hsmem_mut := Induction for hsmem Sort Prop. + + + +(** Symbolic final value -- from hash-consed values + It does not seem useful to hash-consed these final values (because they are final). +*) +Inductive hsfval := + | HSnone + | HScall (sig: signature) (svos: hsval + ident) (lsv: list_hsval) (res: reg) (pc: node) + | HStailcall (sig: signature) (svos: hsval + ident) (lsv: list_hsval) + | HSbuiltin (ef: external_function) (sargs: list (builtin_arg hsval)) (res: builtin_res reg) (pc: node) + | HSjumptable (sv: hsval) (tbl: list node) + | HSreturn (res: option hsval) +. + +(** * gives the semantics of hash-consed symbolic values *) +Fixpoint hsval_proj hsv := + match hsv with + | HSinput r _ => Sinput r + | HSop op hl _ => Sop op (hsval_list_proj hl) Sinit (** NB: use the initial memory of the path ! *) + | HSload hm t chk addr hl _ => Sload (hsmem_proj hm) t chk addr (hsval_list_proj hl) + end +with hsval_list_proj hl := + match hl with + | HSnil _ => Snil + | HScons hv hl _ => Scons (hsval_proj hv) (hsval_list_proj hl) + end +with hsmem_proj hm := + match hm with + | HSinit _ => Sinit + | HSstore hm chk addr hl hv _ => Sstore (hsmem_proj hm) chk addr (hsval_list_proj hl) (hsval_proj hv) + end. + +Declare Scope hse. +Local Open Scope hse. + + +(** We use a Notation instead a Definition, in order to get more automation "for free" *) +Notation "'seval_hsval' ge sp hsv" := (seval_sval ge sp (hsval_proj hsv)) + (only parsing, at level 0, ge at next level, sp at next level, hsv at next level): hse. +Notation "'seval_list_hsval' ge sp lhv" := (seval_list_sval ge sp (hsval_list_proj lhv)) + (only parsing, at level 0, ge at next level, sp at next level, lhv at next level): hse. +Notation "'seval_hsmem' ge sp hsm" := (seval_smem ge sp (hsmem_proj hsm)) + (only parsing, at level 0, ge at next level, sp at next level, hsm at next level): hse. + +Notation "'sval_refines' ge sp rs0 m0 hv sv" := (seval_hsval ge sp hv rs0 m0 = seval_sval ge sp sv rs0 m0) + (only parsing, at level 0, ge at next level, sp at next level, rs0 at next level, m0 at next level, hv at next level, sv at next level): hse. +Notation "'list_sval_refines' ge sp rs0 m0 lhv lsv" := (seval_list_hsval ge sp lhv rs0 m0 = seval_list_sval ge sp lsv rs0 m0) + (only parsing, at level 0, ge at next level, sp at next level, rs0 at next level, m0 at next level, lhv at next level, lsv at next level): hse. +Notation "'smem_refines' ge sp rs0 m0 hm sm" := (seval_hsmem ge sp hm rs0 m0 = seval_smem ge sp sm rs0 m0) + (only parsing, at level 0, ge at next level, sp at next level, rs0 at next level, m0 at next level, hm at next level, sm at next level): hse. + + +(** ** Implementation of symbolic states (with hash-consing) *) + +(** *** Syntax and semantics of symbolic internal local states + +The semantics is given by the refinement relation [hsilocal_refines] wrt to (abstract) symbolic internal local states + +*) + +(* NB: "h" stands for hash-consing *) +Record hsistate_local := + { + (** [hsi_smem] represents the current smem symbolic evaluations. + (we also recover the history of smem in hsi_smem) *) + hsi_smem:> hsmem; + (** For the values in registers: + 1) we store a list of sval evaluations + 2) we encode the symbolic regset by a PTree *) + hsi_ok_lsval: list hsval; + hsi_sreg:> PTree.t hsval + }. + +Definition hsi_sreg_proj (hst: PTree.t hsval) r: sval := + match PTree.get r hst with + | None => Sinput r + | Some hsv => hsval_proj hsv + end. + +Definition hsi_sreg_eval ge sp hst r := seval_sval ge sp (hsi_sreg_proj hst r). + +Definition hsok_local ge sp rs0 m0 (hst: hsistate_local) : Prop := + (forall hsv, List.In hsv (hsi_ok_lsval hst) -> seval_hsval ge sp hsv rs0 m0 <> None) + /\ (seval_hsmem ge sp (hst.(hsi_smem)) rs0 m0 <> None). + +(* refinement link between a (st: sistate_local) and (hst: hsistate_local) *) +Definition hsilocal_refines ge sp rs0 m0 (hst: hsistate_local) (st: sistate_local) := + (sok_local ge sp rs0 m0 st <-> hsok_local ge sp rs0 m0 hst) + /\ (hsok_local ge sp rs0 m0 hst -> smem_refines ge sp rs0 m0 (hsi_smem hst) (st.(si_smem))) + /\ (hsok_local ge sp rs0 m0 hst -> forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (si_sreg st r) rs0 m0) + /\ (* the below invariant allows to evaluate operations in the initial memory of the path instead of the current memory *) + (forall m b ofs, seval_smem ge sp st.(si_smem) rs0 m0 = Some m -> Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + . + +(** *** Syntax and semantics of symbolic exit states *) +Record hsistate_exit := mk_hsistate_exit + { hsi_cond: condition; hsi_scondargs: list_hsval; hsi_elocal: hsistate_local; hsi_ifso: node }. + +(** NB: we split the refinement relation between a "static" part -- independendent of the initial context + and a "dynamic" part -- that depends on it +*) +Definition hsiexit_refines_stat (hext: hsistate_exit) (ext: sistate_exit): Prop := + hsi_ifso hext = si_ifso ext. + +Definition hseval_condition ge sp cond hcondargs hmem rs0 m0 := + seval_condition ge sp cond (hsval_list_proj hcondargs) (hsmem_proj hmem) rs0 m0. + +Lemma hseval_condition_preserved ge ge' sp cond args mem rs0 m0: + (forall s : ident, Genv.find_symbol ge' s = Genv.find_symbol ge s) -> + hseval_condition ge sp cond args mem rs0 m0 = hseval_condition ge' sp cond args mem rs0 m0. +Proof. + intros. unfold hseval_condition. erewrite seval_condition_preserved; [|eapply H]. + reflexivity. +Qed. + +Definition hsiexit_refines_dyn ge sp rs0 m0 (hext: hsistate_exit) (ext: sistate_exit): Prop := + hsilocal_refines ge sp rs0 m0 (hsi_elocal hext) (si_elocal ext) + /\ (hsok_local ge sp rs0 m0 (hsi_elocal hext) -> + hseval_condition ge sp (hsi_cond hext) (hsi_scondargs hext) (hsi_smem (hsi_elocal hext)) rs0 m0 + = seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs0 m0). + +Definition hsiexits_refines_stat lhse lse := + list_forall2 hsiexit_refines_stat lhse lse. + +Definition hsiexits_refines_dyn ge sp rs0 m0 lhse se := + list_forall2 (hsiexit_refines_dyn ge sp rs0 m0) lhse se. + + +(** *** Syntax and Semantics of symbolic internal state *) + +Record hsistate := { hsi_pc: node; hsi_exits: list hsistate_exit; hsi_local: hsistate_local }. + +(* expresses the "monotony" of sok_local along sequences *) +Inductive nested_sok ge sp rs0 m0: sistate_local -> list sistate_exit -> Prop := + nsok_nil st: nested_sok ge sp rs0 m0 st nil + | nsok_cons st se lse: + (sok_local ge sp rs0 m0 st -> sok_local ge sp rs0 m0 (si_elocal se)) -> + nested_sok ge sp rs0 m0 (si_elocal se) lse -> + nested_sok ge sp rs0 m0 st (se::lse). + +Lemma nested_sok_prop ge sp st sle rs0 m0: + nested_sok ge sp rs0 m0 st sle -> + sok_local ge sp rs0 m0 st -> + forall se, In se sle -> sok_local ge sp rs0 m0 (si_elocal se). +Proof. + induction 1; simpl; intuition (subst; eauto). +Qed. + +Lemma nested_sok_elocal ge sp rs0 m0 st2 exits: + nested_sok ge sp rs0 m0 st2 exits -> + forall st1, (sok_local ge sp rs0 m0 st1 -> sok_local ge sp rs0 m0 st2) -> + nested_sok ge sp rs0 m0 st1 exits. +Proof. + induction 1; [intros; constructor|]. + intros. constructor; auto. +Qed. + +Lemma nested_sok_tail ge sp rs0 m0 st lx exits: + is_tail lx exits -> + nested_sok ge sp rs0 m0 st exits -> + nested_sok ge sp rs0 m0 st lx. +Proof. + induction 1; [auto|]. + intros. inv H0. eapply IHis_tail. eapply nested_sok_elocal; eauto. +Qed. + +Definition hsistate_refines_stat (hst: hsistate) (st:sistate): Prop := + hsi_pc hst = si_pc st + /\ hsiexits_refines_stat (hsi_exits hst) (si_exits st). + +Definition hsistate_refines_dyn ge sp rs0 m0 (hst: hsistate) (st:sistate): Prop := + hsiexits_refines_dyn ge sp rs0 m0 (hsi_exits hst) (si_exits st) + /\ hsilocal_refines ge sp rs0 m0 (hsi_local hst) (si_local st) + /\ nested_sok ge sp rs0 m0 (si_local st) (si_exits st) (* invariant necessary to prove "monotony" of sok_local along execution *) + . + +(** *** Syntax and Semantics of symbolic state *) + +Definition hfinal_proj (hfv: hsfval) : sfval := + match hfv with + | HSnone => Snone + | HScall s hvi hlv r pc => Scall s (sum_left_map hsval_proj hvi) (hsval_list_proj hlv) r pc + | HStailcall s hvi hlv => Stailcall s (sum_left_map hsval_proj hvi) (hsval_list_proj hlv) + | HSbuiltin ef lbh br pc => Sbuiltin ef (List.map (builtin_arg_map hsval_proj) lbh) br pc + | HSjumptable hv ln => Sjumptable (hsval_proj hv) ln + | HSreturn oh => Sreturn (option_map hsval_proj oh) + end. + +Section HFINAL_REFINES. + +Variable ge: RTL.genv. +Variable sp: val. +Variable rs0: regset. +Variable m0: mem. + +Definition option_refines (ohsv: option hsval) (osv: option sval) := + match ohsv, osv with + | Some hsv, Some sv => sval_refines ge sp rs0 m0 hsv sv + | None, None => True + | _, _ => False + end. + +Definition sum_refines (hsi: hsval + ident) (si: sval + ident) := + match hsi, si with + | inl hv, inl sv => sval_refines ge sp rs0 m0 hv sv + | inr id, inr id' => id = id' + | _, _ => False + end. + +Definition bargs_refines (hargs: list (builtin_arg hsval)) (args: list (builtin_arg sval)): Prop := + seval_list_builtin_sval ge sp (List.map (builtin_arg_map hsval_proj) hargs) rs0 m0 = seval_list_builtin_sval ge sp args rs0 m0. + +Inductive hfinal_refines: hsfval -> sfval -> Prop := + | hsnone_ref: hfinal_refines HSnone Snone + | hscall_ref: forall hros ros hargs args s r pc, + sum_refines hros ros -> + list_sval_refines ge sp rs0 m0 hargs args -> + hfinal_refines (HScall s hros hargs r pc) (Scall s ros args r pc) + | hstailcall_ref: forall hros ros hargs args s, + sum_refines hros ros -> + list_sval_refines ge sp rs0 m0 hargs args -> + hfinal_refines (HStailcall s hros hargs) (Stailcall s ros args) + | hsbuiltin_ref: forall ef lbha lba br pc, + bargs_refines lbha lba -> + hfinal_refines (HSbuiltin ef lbha br pc) (Sbuiltin ef lba br pc) + | hsjumptable_ref: forall hsv sv lpc, + sval_refines ge sp rs0 m0 hsv sv -> hfinal_refines (HSjumptable hsv lpc) (Sjumptable sv lpc) + | hsreturn_ref: forall ohsv osv, + option_refines ohsv osv -> hfinal_refines (HSreturn ohsv) (Sreturn osv). + +End HFINAL_REFINES. + + +Record hsstate := { hinternal:> hsistate; hfinal: hsfval }. + +Definition hsstate_refines (hst: hsstate) (st:sstate): Prop := + hsistate_refines_stat (hinternal hst) (internal st) + /\ (forall ge sp rs0 m0, hsistate_refines_dyn ge sp rs0 m0 (hinternal hst) (internal st)) + /\ (forall ge sp rs0 m0, hsok_local ge sp rs0 m0 (hsi_local (hinternal hst)) -> hfinal_refines ge sp rs0 m0 (hfinal hst) (final st)) + . + +(** * Intermediate specifications of the simulation tests *) + +(** ** Specification of the simulation test on [hsistate_local]. + It is motivated by [hsilocal_simu_spec_correct theorem] below +*) +Definition hsilocal_simu_spec (oalive: option Regset.t) (hst1 hst2: hsistate_local) := + List.incl (hsi_ok_lsval hst2) (hsi_ok_lsval hst1) + /\ (forall r, (match oalive with Some alive => Regset.In r alive | _ => True end) -> PTree.get r hst2 = PTree.get r hst1) + /\ hsi_smem hst1 = hsi_smem hst2. + +Definition seval_sval_partial ge sp rs0 m0 hsv := + match seval_hsval ge sp hsv rs0 m0 with + | Some v => v + | None => Vundef + end. + +Definition select_first (ox oy: option val) := + match ox with + | Some v => Some v + | None => oy + end. + +(** If the register was computed by hrs, evaluate the symbolic value from hrs. + Else, take the value directly from rs0 *) +Definition seval_partial_regset ge sp rs0 m0 hrs := + let hrs_eval := PTree.map1 (seval_sval_partial ge sp rs0 m0) hrs in + (fst rs0, PTree.combine select_first hrs_eval (snd rs0)). + +Lemma seval_partial_regset_get ge sp rs0 m0 hrs r: + (seval_partial_regset ge sp rs0 m0 hrs) # r = + match (hrs ! r) with Some sv => seval_sval_partial ge sp rs0 m0 sv | None => (rs0 # r) end. +Proof. + unfold seval_partial_regset. unfold Regmap.get. simpl. + rewrite PTree.gcombine; [| simpl; reflexivity]. rewrite PTree.gmap1. + destruct (hrs ! r); simpl; [reflexivity|]. + destruct ((snd rs0) ! r); reflexivity. +Qed. + +Lemma ssem_local_refines_hok ge sp rs0 m0 hst st rs m: + ssem_local ge sp st rs0 m0 rs m -> hsilocal_refines ge sp rs0 m0 hst st -> hsok_local ge sp rs0 m0 hst. +Proof. + intros H0 (H1 & _ & _). apply H1. eapply ssem_local_sok. eauto. +Qed. + +Lemma hsilocal_simu_spec_nofail ge1 ge2 of sp rs0 m0 hst1 hst2: + hsilocal_simu_spec of hst1 hst2 -> + (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> + hsok_local ge1 sp rs0 m0 hst1 -> + hsok_local ge2 sp rs0 m0 hst2. +Proof. + intros (RSOK & _ & MEMOK) GFS (OKV & OKM). constructor. + - intros sv INS. apply RSOK in INS. apply OKV in INS. erewrite seval_preserved; eauto. + - erewrite MEMOK in OKM. erewrite smem_eval_preserved; eauto. +Qed. + +Theorem hsilocal_simu_spec_correct hst1 hst2 of ge1 ge2 sp rs0 m0 rs m st1 st2: + hsilocal_simu_spec of hst1 hst2 -> + hsilocal_refines ge1 sp rs0 m0 hst1 st1 -> + hsilocal_refines ge2 sp rs0 m0 hst2 st2 -> + (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> + ssem_local ge1 sp st1 rs0 m0 rs m -> + match of with + | None => ssem_local ge2 sp st2 rs0 m0 rs m + | Some alive => + let rs' := seval_partial_regset ge2 sp rs0 m0 (hsi_sreg hst2) + in ssem_local ge2 sp st2 rs0 m0 rs' m /\ eqlive_reg (fun r => Regset.In r alive) rs rs' + end. +Proof. + intros CORE HREF1 HREF2 GFS SEML. + refine (modusponens _ _ (ssem_local_refines_hok _ _ _ _ _ _ _ _ _ _) _); eauto. + intro HOK1. + refine (modusponens _ _ (hsilocal_simu_spec_nofail _ _ _ _ _ _ _ _ _ _ _) _); eauto. + intro HOK2. + destruct SEML as (PRE & MEMEQ & RSEQ). + assert (SIPRE: si_pre st2 ge2 sp rs0 m0). { destruct HREF2 as (OKEQ & _ & _). rewrite <- OKEQ in HOK2. apply HOK2. } + assert (SMEMEVAL: seval_smem ge2 sp (si_smem st2) rs0 m0 = Some m). { + destruct HREF2 as (_ & MEMEQ2 & _). destruct HREF1 as (_ & MEMEQ1 & _). + destruct CORE as (_ & _ & MEMEQ3). + rewrite <- MEMEQ2; auto. rewrite <- MEMEQ3. + erewrite smem_eval_preserved; [| eapply GFS]. + rewrite MEMEQ1; auto. } + destruct of as [alive |]. + - constructor. + + constructor; [assumption | constructor; [assumption|]]. + destruct HREF2 as (B & _ & A & _). + (** B is used for the auto below. *) + assert (forall r : positive, hsi_sreg_eval ge2 sp hst2 r rs0 m0 = seval_sval ge2 sp (si_sreg st2 r) rs0 m0) by auto. + intro r. rewrite <- H. clear H. + generalize (A HOK2 r). unfold hsi_sreg_eval. + rewrite seval_partial_regset_get. + unfold hsi_sreg_proj. + destruct (hst2 ! r) eqn:HST2; [| simpl; reflexivity]. + unfold seval_sval_partial. generalize HOK2; rewrite <- B; intros (_ & _ & C) D. + assert (seval_sval ge2 sp (hsval_proj h) rs0 m0 <> None) by congruence. + destruct (seval_sval ge2 sp _ rs0 m0); [reflexivity | contradiction]. + + intros r ALIVE. destruct HREF2 as (_ & _ & A & _). destruct HREF1 as (_ & _ & B & _). + destruct CORE as (_ & C & _). rewrite seval_partial_regset_get. + assert (OPT: forall (x y: val), Some x = Some y -> x = y) by congruence. + destruct (hst2 ! r) eqn:HST2; apply OPT; clear OPT. + ++ unfold seval_sval_partial. + assert (seval_sval ge2 sp (hsval_proj h) rs0 m0 = hsi_sreg_eval ge2 sp hst2 r rs0 m0). { + unfold hsi_sreg_eval, hsi_sreg_proj. rewrite HST2. reflexivity. } + rewrite H. clear H. unfold hsi_sreg_eval, hsi_sreg_proj. rewrite C; [|assumption]. + erewrite seval_preserved; [| eapply GFS]. + unfold hsi_sreg_eval, hsi_sreg_proj in B; rewrite B; [|assumption]. rewrite RSEQ. reflexivity. + ++ rewrite <- RSEQ. rewrite <- B; [|assumption]. unfold hsi_sreg_eval, hsi_sreg_proj. + rewrite <- C; [|assumption]. rewrite HST2. reflexivity. + - constructor; [|constructor]. + + destruct HREF2 as (OKEQ & _ & _). rewrite <- OKEQ in HOK2. apply HOK2. + + destruct HREF2 as (_ & MEMEQ2 & _). destruct HREF1 as (_ & MEMEQ1 & _). + destruct CORE as (_ & _ & MEMEQ3). + rewrite <- MEMEQ2; auto. rewrite <- MEMEQ3. + erewrite smem_eval_preserved; [| eapply GFS]. + rewrite MEMEQ1; auto. + + intro r. destruct HREF2 as (_ & _ & A & _). destruct HREF1 as (_ & _ & B & _). + destruct CORE as (_ & C & _). rewrite <- A; auto. unfold hsi_sreg_eval, hsi_sreg_proj. + rewrite C; [|auto]. erewrite seval_preserved; [| eapply GFS]. + unfold hsi_sreg_eval, hsi_sreg_proj in B; rewrite B; auto. +Qed. + +(** ** Specification of the simulation test on [hsistate_exit]. + It is motivated by [hsiexit_simu_spec_correct theorem] below +*) +Definition hsiexit_simu_spec dm f (hse1 hse2: hsistate_exit) := + (exists path, (fn_path f) ! (hsi_ifso hse1) = Some path + /\ hsilocal_simu_spec (Some path.(input_regs)) (hsi_elocal hse1) (hsi_elocal hse2)) + /\ dm ! (hsi_ifso hse2) = Some (hsi_ifso hse1) + /\ hsi_cond hse1 = hsi_cond hse2 + /\ hsi_scondargs hse1 = hsi_scondargs hse2. + +Definition hsiexit_simu dm f (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, + hsiexit_refines_stat hse1 se1 -> + hsiexit_refines_stat hse2 se2 -> + hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> + hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> + siexit_simu dm f ctx se1 se2. + +Lemma hsiexit_simu_spec_nofail dm f hse1 hse2 ge1 ge2 sp rs m: + hsiexit_simu_spec dm f hse1 hse2 -> + (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> + hsok_local ge1 sp rs m (hsi_elocal hse1) -> + hsok_local ge2 sp rs m (hsi_elocal hse2). +Proof. + intros CORE GFS HOK1. + destruct CORE as ((p & _ & CORE') & _ & _ & _). + eapply hsilocal_simu_spec_nofail; eauto. +Qed. + +Theorem hsiexit_simu_spec_correct dm f hse1 hse2 ctx: + hsiexit_simu_spec dm f hse1 hse2 -> + hsiexit_simu dm f ctx hse1 hse2. +Proof. + intros SIMUC st1 st2 HREF1 HREF2 HDYN1 HDYN2. + assert (SEVALC: + sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal st1) -> + (seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond st1) (si_scondargs st1) (si_smem (si_elocal st1)) + (the_rs0 ctx) (the_m0 ctx)) = + (seval_condition (the_ge2 ctx) (the_sp ctx) (si_cond st2) (si_scondargs st2) (si_smem (si_elocal st2)) + (the_rs0 ctx) (the_m0 ctx))). + { destruct HDYN1 as ((OKEQ1 & _) & SCOND1). + rewrite OKEQ1; intro OK1. rewrite <- SCOND1 by assumption. clear SCOND1. + generalize (genv_match ctx). + intro GFS; exploit hsiexit_simu_spec_nofail; eauto. + destruct HDYN2 as (_ & SCOND2). intro OK2. rewrite <- SCOND2 by assumption. clear OK1 OK2 SCOND2. + destruct SIMUC as ((path & _ & LSIMU) & _ & CONDEQ & ARGSEQ). destruct LSIMU as (_ & _ & MEMEQ). + rewrite CONDEQ. rewrite ARGSEQ. rewrite MEMEQ. erewrite <- hseval_condition_preserved; eauto. + } + constructor; [assumption|]. intros is1 ICONT SSEME. + assert (OK1: sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal st1)). { + destruct SSEME as (_ & SSEML & _). eapply ssem_local_sok; eauto. } + assert (HOK1: hsok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (hsi_elocal hse1)). { + destruct HDYN1 as (LREF & _). destruct LREF as (OKEQ & _ & _). rewrite <- OKEQ. assumption. } + exploit hsiexit_simu_spec_nofail. 2: eapply ctx. all: eauto. intro HOK2. + destruct SSEME as (SCOND & SLOC & PCEQ). destruct SIMUC as ((path & PATH & LSIMU) & REVEQ & _ & _); eauto. + destruct HDYN1 as (LREF1 & _). destruct HDYN2 as (LREF2 & _). + exploit hsilocal_simu_spec_correct; eauto; [apply ctx|]. simpl. + intros (SSEML & EQREG). + eexists (mk_istate (icontinue is1) (si_ifso st2) _ (imem is1)). simpl. constructor. + - constructor; intuition congruence || eauto. + - unfold istate_simu. rewrite ICONT. + simpl. assert (PCEQ': hsi_ifso hse1 = ipc is1) by congruence. + exists path. constructor; [|constructor]; [congruence| |congruence]. + constructor; [|constructor]; simpl; auto. +Qed. + +Remark hsiexit_simu_siexit dm f ctx hse1 hse2 se1 se2: + hsiexit_simu dm f ctx hse1 hse2 -> + hsiexit_refines_stat hse1 se1 -> + hsiexit_refines_stat hse2 se2 -> + hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> + hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> + siexit_simu dm f ctx se1 se2. +Proof. + auto. +Qed. + +(** ** Specification of the simulation test on [list hsistate_exit]. + It is motivated by [hsiexit_simu_spec_correct theorem] below +*) + +Definition hsiexits_simu dm f (ctx: simu_proof_context f) (lhse1 lhse2: list hsistate_exit): Prop := + list_forall2 (hsiexit_simu dm f ctx) lhse1 lhse2. + +Definition hsiexits_simu_spec dm f lhse1 lhse2: Prop := + list_forall2 (hsiexit_simu_spec dm f) lhse1 lhse2. + +Theorem hsiexits_simu_spec_correct dm f lhse1 lhse2 ctx: + hsiexits_simu_spec dm f lhse1 lhse2 -> + hsiexits_simu dm f ctx lhse1 lhse2. +Proof. + induction 1; [constructor|]. + constructor; [|apply IHlist_forall2; assumption]. + apply hsiexit_simu_spec_correct; assumption. +Qed. + + +Lemma siexits_simu_all_fallthrough dm f ctx: forall lse1 lse2, + siexits_simu dm f lse1 lse2 ctx -> + all_fallthrough (the_ge1 ctx) (the_sp ctx) lse1 (the_rs0 ctx) (the_m0 ctx) -> + (forall se1, In se1 lse1 -> sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1)) -> + all_fallthrough (the_ge2 ctx) (the_sp ctx) lse2 (the_rs0 ctx) (the_m0 ctx). +Proof. + induction 1; [unfold all_fallthrough; contradiction|]; simpl. + intros X OK ext INEXT. eapply all_fallthrough_revcons in X. destruct X as (SEVAL & ALLFU). + apply IHlist_forall2 in ALLFU. + - destruct H as (CONDSIMU & _). + inv INEXT; [|eauto]. + erewrite <- CONDSIMU; eauto. + - intros; intuition. +Qed. + + +Lemma siexits_simu_all_fallthrough_upto dm f ctx lse1 lse2: + siexits_simu dm f lse1 lse2 ctx -> + forall ext1 lx1, + (forall se1, In se1 lx1 -> sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1)) -> + all_fallthrough_upto_exit (the_ge1 ctx) (the_sp ctx) ext1 lx1 lse1 (the_rs0 ctx) (the_m0 ctx) -> + exists ext2 lx2, + all_fallthrough_upto_exit (the_ge2 ctx) (the_sp ctx) ext2 lx2 lse2 (the_rs0 ctx) (the_m0 ctx) + /\ length lx1 = length lx2. +Proof. + induction 1. + - intros ext lx1. intros OK H. destruct H as (ITAIL & ALLFU). eapply is_tail_false in ITAIL. contradiction. + - simpl; intros ext lx1 OK ALLFUE. + destruct ALLFUE as (ITAIL & ALLFU). inv ITAIL. + + eexists; eexists. + constructor; [| eapply list_forall2_length; eauto]. + constructor; [econstructor | eapply siexits_simu_all_fallthrough; eauto]. + + exploit IHlist_forall2. + * intuition. apply OK. eassumption. + * constructor; eauto. + * intros (ext2 & lx2 & ALLFUE2 & LENEQ). + eexists; eexists. constructor; eauto. + eapply all_fallthrough_upto_exit_cons; eauto. +Qed. + + +Lemma hsiexits_simu_siexits dm f ctx lhse1 lhse2: + hsiexits_simu dm f ctx lhse1 lhse2 -> + forall lse1 lse2, + hsiexits_refines_stat lhse1 lse1 -> + hsiexits_refines_stat lhse2 lse2 -> + hsiexits_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse1 lse1 -> + hsiexits_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse2 lse2 -> + siexits_simu dm f lse1 lse2 ctx. +Proof. + induction 1. + - intros. inv H. inv H0. constructor. + - intros lse1 lse2 SREF1 SREF2 DREF1 DREF2. inv SREF1. inv SREF2. inv DREF1. inv DREF2. + constructor; [| eapply IHlist_forall2; eauto]. + eapply hsiexit_simu_siexit; eauto. +Qed. + + +(** ** Specification of the simulation test on [hsistate]. + It is motivated by [hsistate_simu_spec_correct theorem] below +*) + +Definition hsistate_simu_spec dm f (hse1 hse2: hsistate) := + list_forall2 (hsiexit_simu_spec dm f) (hsi_exits hse1) (hsi_exits hse2) + /\ hsilocal_simu_spec None (hsi_local hse1) (hsi_local hse2). + +Definition hsistate_simu dm f (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, + hsistate_refines_stat hst1 st1 -> + hsistate_refines_stat hst2 st2 -> + hsistate_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst1 st1 -> + hsistate_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst2 st2 -> + sistate_simu dm f st1 st2 ctx. + +Lemma list_forall2_nth_error {A} (l1 l2: list A) P: + list_forall2 P l1 l2 -> + forall x1 x2 n, + nth_error l1 n = Some x1 -> + nth_error l2 n = Some x2 -> + P x1 x2. +Proof. + induction 1. + - intros. rewrite nth_error_nil in H. discriminate. + - intros x1 x2 n. destruct n as [|n]; simpl. + + intros. inv H1. inv H2. assumption. + + apply IHlist_forall2. +Qed. + +Lemma is_tail_length {A} (l1 l2: list A): + is_tail l1 l2 -> + (length l1 <= length l2)%nat. +Proof. + induction l2. + - intro. destruct l1; auto. apply is_tail_false in H. contradiction. + - intros ITAIL. inv ITAIL; auto. + apply IHl2 in H1. clear IHl2. simpl. omega. +Qed. + +Lemma is_tail_nth_error {A} (l1 l2: list A) x: + is_tail (x::l1) l2 -> + nth_error l2 ((length l2) - length l1 - 1) = Some x. +Proof. + induction l2. + - intro ITAIL. apply is_tail_false in ITAIL. contradiction. + - intros ITAIL. assert (length (a::l2) = S (length l2)) by auto. rewrite H. clear H. + assert (forall n n', ((S n) - n' - 1)%nat = (n - n')%nat) by (intros; omega). rewrite H. clear H. + inv ITAIL. + + assert (forall n, (n - n)%nat = 0%nat) by (intro; omega). rewrite H. + simpl. reflexivity. + + exploit IHl2; eauto. intros. clear IHl2. + assert (forall n n', (n > n')%nat -> (n - n')%nat = S (n - n' - 1)%nat) by (intros; omega). + exploit (is_tail_length (x::l1)); eauto. intro. simpl in H2. + assert ((length l2 > length l1)%nat) by omega. clear H2. + rewrite H0; auto. +Qed. + +Theorem hsistate_simu_spec_correct dm f hst1 hst2 ctx: + hsistate_simu_spec dm f hst1 hst2 -> + hsistate_simu dm f hst1 hst2 ctx. +Proof. + intros (ESIMU & LSIMU) st1 st2 (PCREF1 & EREF1) (PCREF2 & EREF2) DREF1 DREF2 is1 SEMI. + destruct DREF1 as (DEREF1 & LREF1 & NESTED). destruct DREF2 as (DEREF2 & LREF2 & _). + exploit hsiexits_simu_spec_correct; eauto. intro HESIMU. + unfold ssem_internal in SEMI. destruct (icontinue _) eqn:ICONT. + - destruct SEMI as (SSEML & PCEQ & ALLFU). + exploit hsilocal_simu_spec_correct; eauto; [apply ctx|]. simpl. intro SSEML2. + exists (mk_istate (icontinue is1) (si_pc st2) (irs is1) (imem is1)). constructor. + + unfold ssem_internal. simpl. rewrite ICONT. constructor; [assumption | constructor; [reflexivity |]]. + eapply siexits_simu_all_fallthrough; eauto. + * eapply hsiexits_simu_siexits; eauto. + * eapply nested_sok_prop; eauto. + eapply ssem_local_sok; eauto. + + unfold istate_simu. rewrite ICONT. constructor; [simpl; assumption | constructor; [| reflexivity]]. + constructor. + - destruct SEMI as (ext & lx & SSEME & ALLFU). + assert (SESIMU: siexits_simu dm f (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). + exploit siexits_simu_all_fallthrough_upto; eauto. + * destruct ALLFU as (ITAIL & ALLF). + exploit nested_sok_tail; eauto. intros NESTED2. + inv NESTED2. destruct SSEME as (_ & SSEML & _). eapply ssem_local_sok in SSEML. + eapply nested_sok_prop; eauto. + * intros (ext2 & lx2 & ALLFU2 & LENEQ). + assert (EXTSIMU: siexit_simu dm f ctx ext ext2). { + eapply list_forall2_nth_error; eauto. + - destruct ALLFU as (ITAIL & _). eapply is_tail_nth_error; eauto. + - destruct ALLFU2 as (ITAIL & _). eapply is_tail_nth_error in ITAIL. + assert (LENEQ': length (si_exits st1) = length (si_exits st2)) by (eapply list_forall2_length; eauto). + congruence. } + destruct EXTSIMU as (CONDEVAL & EXTSIMU). + apply EXTSIMU in SSEME; [|assumption]. clear EXTSIMU. destruct SSEME as (is2 & SSEME2 & ISIMU). + exists (mk_istate (icontinue is1) (ipc is2) (irs is2) (imem is2)). constructor. + + unfold ssem_internal. simpl. rewrite ICONT. exists ext2, lx2. constructor; assumption. + + unfold istate_simu in *. rewrite ICONT in *. destruct ISIMU as (path & PATHEQ & ISIMULIVE & DMEQ). + destruct ISIMULIVE as (CONTEQ & REGEQ & MEMEQ). + exists path. repeat (constructor; auto). +Qed. + + +(** ** Specification of the simulation test on [sfval]. + It is motivated by [hfinal_simu_spec_correct theorem] below +*) + + +Definition final_simu_spec (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (f1 f2: sfval): Prop := + match f1 with + | Scall sig1 svos1 lsv1 res1 pc1 => + match f2 with + | Scall sig2 svos2 lsv2 res2 pc2 => + dm ! pc2 = Some pc1 /\ sig1 = sig2 /\ svos1 = svos2 /\ lsv1 = lsv2 /\ res1 = res2 + | _ => False + end + | Sbuiltin ef1 lbs1 br1 pc1 => + match f2 with + | Sbuiltin ef2 lbs2 br2 pc2 => + dm ! pc2 = Some pc1 /\ ef1 = ef2 /\ lbs1 = lbs2 /\ br1 = br2 + | _ => False + end + | Sjumptable sv1 lpc1 => + match f2 with + | Sjumptable sv2 lpc2 => + ptree_get_list dm lpc2 = Some lpc1 /\ sv1 = sv2 + | _ => False + end + | Snone => + match f2 with + | Snone => dm ! pc2 = Some pc1 + | _ => False + end + (* Stailcall, Sreturn *) + | _ => f1 = f2 + end. + +Definition hfinal_simu_spec (dm: PTree.t node) (f: RTLpath.function) (pc1 pc2: node) (hf1 hf2: hsfval): Prop := + final_simu_spec dm f pc1 pc2 (hfinal_proj hf1) (hfinal_proj hf2). + +Lemma svident_simu_refl f ctx s: + svident_simu f ctx s s. +Proof. + destruct s; constructor; [| reflexivity]. + erewrite <- seval_preserved; [| eapply ctx]. constructor. +Qed. + +Lemma list_proj_refines_eq ge ge' sp rs0 m0 lsv lhsv: + (forall s, Genv.find_symbol ge s = Genv.find_symbol ge' s) -> + list_sval_refines ge sp rs0 m0 lhsv lsv -> + forall lhsv' lsv', + list_sval_refines ge' sp rs0 m0 lhsv' lsv' -> + hsval_list_proj lhsv = hsval_list_proj lhsv' -> + seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv' rs0 m0. +Proof. + intros GFS H lhsv' lsv' H' H0. + erewrite <- H, H0. + erewrite list_sval_eval_preserved; eauto. +Qed. + +Lemma seval_builtin_sval_preserved ge ge' sp sv rs0 m0: + (forall s : ident, Genv.find_symbol ge' s = Genv.find_symbol ge s) -> + seval_builtin_sval ge sp sv rs0 m0 = + seval_builtin_sval ge' sp sv rs0 m0. +Proof. + induction sv; intro FIND; cbn. + all: try (erewrite seval_preserved by eauto); trivial. + all: erewrite IHsv1 by eauto; erewrite IHsv2 by eauto; reflexivity. +Qed. + +Lemma seval_list_builtin_sval_preserved ge ge' sp lsv rs0 m0: + (forall s : ident, Genv.find_symbol ge' s = Genv.find_symbol ge s) -> + seval_list_builtin_sval ge sp lsv rs0 m0 = + seval_list_builtin_sval ge' sp lsv rs0 m0. +Proof. + induction lsv; intro FIND; cbn. { trivial. } + erewrite seval_builtin_sval_preserved by eauto. + erewrite IHlsv by eauto. + reflexivity. +Qed. + +Lemma barg_proj_refines_eq ge ge' sp rs0 m0: + (forall s, Genv.find_symbol ge s = Genv.find_symbol ge' s) -> + forall lhsv lsv, bargs_refines ge sp rs0 m0 lhsv lsv -> + forall lhsv' lsv', bargs_refines ge' sp rs0 m0 lhsv' lsv' -> + List.map (builtin_arg_map hsval_proj) lhsv = List.map (builtin_arg_map hsval_proj) lhsv' -> + seval_list_builtin_sval ge sp lsv rs0 m0 = seval_list_builtin_sval ge' sp lsv' rs0 m0. +Proof. + unfold bargs_refines; intros GFS lhsv lsv H lhsv' lsv' H' H0. + erewrite <- H, H0. + erewrite seval_list_builtin_sval_preserved; eauto. +Qed. + +Lemma sval_refines_proj ge ge' sp rs m hsv sv hsv' sv': + (forall s, Genv.find_symbol ge s = Genv.find_symbol ge' s) -> + sval_refines ge sp rs m hsv sv -> + sval_refines ge' sp rs m hsv' sv' -> + hsval_proj hsv = hsval_proj hsv' -> + seval_sval ge sp sv rs m = seval_sval ge' sp sv' rs m. +Proof. + intros GFS REF REF' PROJ. + rewrite <- REF, PROJ. + erewrite <- seval_preserved; eauto. +Qed. + +Theorem hfinal_simu_spec_correct dm f ctx opc1 opc2 hf1 hf2 f1 f2: + hfinal_simu_spec dm f opc1 opc2 hf1 hf2 -> + hfinal_refines (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hf1 f1 -> + hfinal_refines (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hf2 f2 -> + sfval_simu dm f opc1 opc2 ctx f1 f2. +Proof. + assert (GFS: forall s : ident, Genv.find_symbol (the_ge1 ctx) s = Genv.find_symbol (the_ge2 ctx) s) by apply ctx. + intros CORE FREF1 FREF2. + destruct hf1; inv FREF1. + (* Snone *) + - destruct hf2; try contradiction. inv FREF2. + inv CORE. constructor. assumption. + (* Scall *) + - rename H5 into SREF1. rename H6 into LREF1. + destruct hf2; try contradiction. inv FREF2. + rename H5 into SREF2. rename H6 into LREF2. + destruct CORE as (PCEQ & ? & ? & ? & ?). subst. + rename H0 into SVOSEQ. rename H1 into LSVEQ. + constructor; [assumption | |]. + + destruct svos. + * destruct svos0; try discriminate. destruct ros; try contradiction. + destruct ros0; try contradiction. constructor. + simpl in SVOSEQ. inv SVOSEQ. + simpl in SREF1. simpl in SREF2. + rewrite <- SREF1. rewrite <- SREF2. + erewrite <- seval_preserved; [| eapply GFS]. congruence. + * destruct svos0; try discriminate. destruct ros; try contradiction. + destruct ros0; try contradiction. constructor. + simpl in SVOSEQ. inv SVOSEQ. congruence. + + erewrite list_proj_refines_eq; eauto. + (* Stailcall *) + - rename H3 into SREF1. rename H4 into LREF1. + destruct hf2; try (inv CORE; fail). inv FREF2. + rename H4 into LREF2. rename H3 into SREF2. + inv CORE. rename H1 into SVOSEQ. rename H2 into LSVEQ. + constructor. + + destruct svos. (** Copy-paste from Scall *) + * destruct svos0; try discriminate. destruct ros; try contradiction. + destruct ros0; try contradiction. constructor. + simpl in SVOSEQ. inv SVOSEQ. + simpl in SREF1. simpl in SREF2. + rewrite <- SREF1. rewrite <- SREF2. + erewrite <- seval_preserved; [| eapply GFS]. congruence. + * destruct svos0; try discriminate. destruct ros; try contradiction. + destruct ros0; try contradiction. constructor. + simpl in SVOSEQ. inv SVOSEQ. congruence. + + erewrite list_proj_refines_eq; eauto. + (* Sbuiltin *) + - rename H4 into BREF1. destruct hf2; try (inv CORE; fail). inv FREF2. + rename H4 into BREF2. inv CORE. destruct H0 as (? & ? & ?). subst. + rename H into PCEQ. rename H1 into ARGSEQ. constructor; [assumption|]. + erewrite barg_proj_refines_eq; eauto. constructor. + (* Sjumptable *) + - rename H2 into SREF1. destruct hf2; try contradiction. inv FREF2. + rename H2 into SREF2. destruct CORE as (A & B). constructor; [assumption|]. + erewrite sval_refines_proj; eauto. + (* Sreturn *) + - rename H0 into SREF1. + destruct hf2; try discriminate. inv CORE. + inv FREF2. destruct osv; destruct res; inv SREF1. + + destruct res0; try discriminate. destruct osv0; inv H1. + constructor. simpl in H0. inv H0. erewrite sval_refines_proj; eauto. + + destruct res0; try discriminate. destruct osv0; inv H1. constructor. +Qed. + + +(** ** Specification of the simulation test on [hsstate]. + It is motivated by [hsstate_simu_spec_correct theorem] below +*) + +Definition hsstate_simu_spec (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := + hsistate_simu_spec dm f (hinternal hst1) (hinternal hst2) + /\ hfinal_simu_spec dm f (hsi_pc (hinternal hst1)) (hsi_pc (hinternal hst2)) (hfinal hst1) (hfinal hst2). + +Definition hsstate_simu dm f (hst1 hst2: hsstate) ctx: Prop := + forall st1 st2, + hsstate_refines hst1 st1 -> + hsstate_refines hst2 st2 -> sstate_simu dm f st1 st2 ctx. + +Theorem hsstate_simu_spec_correct dm f ctx hst1 hst2: + hsstate_simu_spec dm f hst1 hst2 -> + hsstate_simu dm f hst1 hst2 ctx. +Proof. + intros (SCORE & FSIMU) st1 st2 (SREF1 & DREF1 & FREF1) (SREF2 & DREF2 & FREF2). + generalize SCORE. intro SIMU; eapply hsistate_simu_spec_correct in SIMU; eauto. + constructor; auto. + intros is1 SEM1 CONT1. + unfold hsistate_simu in SIMU. exploit SIMU; clear SIMU; eauto. + unfold istate_simu, ssem_internal in *; intros (is2 & SEM2 & SIMU). + rewrite! CONT1 in *. destruct SIMU as (CONT2 & _). + rewrite! CONT1, <- CONT2 in *. + destruct SEM1 as (SEM1 & _ & _). + destruct SEM2 as (SEM2 & _ & _). + eapply hfinal_simu_spec_correct in FSIMU; eauto. + - destruct SREF1 as (PC1 & _). destruct SREF2 as (PC2 & _). rewrite <- PC1. rewrite <- PC2. + eapply FSIMU. + - eapply FREF1. exploit DREF1. intros (_ & (OK & _) & _). rewrite <- OK. eapply ssem_local_sok; eauto. + - eapply FREF2. exploit DREF2. intros (_ & (OK & _) & _). rewrite <- OK. eapply ssem_local_sok; eauto. +Qed. diff --git a/scheduling/RTLpathSE_theory.v b/scheduling/RTLpathSE_theory.v new file mode 100644 index 00000000..4c492ecd --- /dev/null +++ b/scheduling/RTLpathSE_theory.v @@ -0,0 +1,1897 @@ +(* A theory of symbolic execution on RTLpath + +NB: an efficient implementation with hash-consing will be defined in RTLpathSE_impl.v + +*) + +Require Import Coqlib Maps Floats. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL RTLpath. +Require Import Errors Duplicate. + +Local Open Scope error_monad_scope. + +(* Enhanced from kvx/Asmblockgenproof.v *) +Ltac explore_hyp := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => (let EQ1 := fresh "EQ" in (destruct var eqn:EQ1; try discriminate)) + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + | [ H : Some _ = Some _ |- _ ] => inv H + | [ x : unit |- _ ] => destruct x + end. + +Ltac explore := explore_hyp; + repeat match goal with + | [ |- context[if ?b then _ else _] ] => (let EQ1 := fresh "IEQ" in destruct b eqn:EQ1) + | [ |- context[match ?m with | _ => _ end] ] => (let DEQ1 := fresh "DEQ" in destruct m eqn:DEQ1) + | [ |- context[match ?m as _ return _ with | _ => _ end]] => (let DREQ1 := fresh "DREQ" in destruct m eqn:DREQ1) + end. + +(* Ltac explore := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => (let EQ1 := fresh "EQ" in (destruct var eqn:EQ1; try discriminate)) + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => (let EQ1 := fresh "IEQ" in destruct b eqn:EQ1) + | [ |- context[match ?m with | _ => _ end] ] => (let DEQ1 := fresh "DEQ" in destruct m eqn:DEQ1) + | [ |- context[match ?m as _ return _ with | _ => _ end]] => (let DREQ1 := fresh "DREQ" in destruct m eqn:DREQ1) + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + | [ H : Some _ = Some _ |- _ ] => inv H + | [ x : unit |- _ ] => destruct x + end. *) + +(** * Syntax and semantics of symbolic values *) + +(* symbolic value *) +Inductive sval := + | Sinput (r: reg) + | Sop (op:operation) (lsv: list_sval) (sm: smem) + | Sload (sm: smem) (trap: trapping_mode) (chunk:memory_chunk) (addr:addressing) (lsv:list_sval) +with list_sval := + | Snil + | Scons (sv: sval) (lsv: list_sval) +(* symbolic memory *) +with smem := + | Sinit + | Sstore (sm: smem) (chunk:memory_chunk) (addr:addressing) (lsv:list_sval) (srce: sval). + +Scheme sval_mut := Induction for sval Sort Prop +with list_sval_mut := Induction for list_sval Sort Prop +with smem_mut := Induction for smem Sort Prop. + +Fixpoint list_sval_inj (l: list sval): list_sval := + match l with + | nil => Snil + | v::l => Scons v (list_sval_inj l) + end. + +Local Open Scope option_monad_scope. + +Fixpoint seval_sval (ge: RTL.genv) (sp:val) (sv: sval) (rs0: regset) (m0: mem): option val := + match sv with + | Sinput r => Some (rs0#r) + | Sop op l sm => + SOME args <- seval_list_sval ge sp l rs0 m0 IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + eval_operation ge sp op args m + | Sload sm trap chunk addr lsv => + match trap with + | TRAP => + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + SOME a <- eval_addressing ge sp addr args IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + Mem.loadv chunk m a + | NOTRAP => + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + match (eval_addressing ge sp addr args) with + | None => Some (default_notrap_load_value chunk) + | Some a => + SOME m <- seval_smem ge sp sm rs0 m0 IN + match (Mem.loadv chunk m a) with + | None => Some (default_notrap_load_value chunk) + | Some val => Some val + end + end + end + end +with seval_list_sval (ge: RTL.genv) (sp:val) (lsv: list_sval) (rs0: regset) (m0: mem): option (list val) := + match lsv with + | Snil => Some nil + | Scons sv lsv' => + SOME v <- seval_sval ge sp sv rs0 m0 IN + SOME lv <- seval_list_sval ge sp lsv' rs0 m0 IN + Some (v::lv) + end +with seval_smem (ge: RTL.genv) (sp:val) (sm: smem) (rs0: regset) (m0: mem): option mem := + match sm with + | Sinit => Some m0 + | Sstore sm chunk addr lsv srce => + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + SOME a <- eval_addressing ge sp addr args IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + SOME sv <- seval_sval ge sp srce rs0 m0 IN + Mem.storev chunk m a sv + end. + +(* Syntax and Semantics of local symbolic internal states *) +(* [si_pre] is a precondition on initial ge, sp, rs0, m0 *) +Record sistate_local := { si_pre: RTL.genv -> val -> regset -> mem -> Prop; si_sreg: reg -> sval; si_smem: smem }. + +(* Predicate on which (rs, m) is a possible final state after evaluating [st] on (rs0, m0) *) +Definition ssem_local (ge: RTL.genv) (sp:val) (st: sistate_local) (rs0: regset) (m0: mem) (rs: regset) (m: mem): Prop := + st.(si_pre) ge sp rs0 m0 + /\ seval_smem ge sp st.(si_smem) rs0 m0 = Some m + /\ forall (r:reg), seval_sval ge sp (st.(si_sreg) r) rs0 m0 = Some (rs#r). + +Definition sabort_local (ge: RTL.genv) (sp:val) (st: sistate_local) (rs0: regset) (m0: mem): Prop := + ~(st.(si_pre) ge sp rs0 m0) + \/ seval_smem ge sp st.(si_smem) rs0 m0 = None + \/ exists (r: reg), seval_sval ge sp (st.(si_sreg) r) rs0 m0 = None. + +(* Syntax and semantics of symbolic exit states *) +Record sistate_exit := mk_sistate_exit + { si_cond: condition; si_scondargs: list_sval; si_elocal: sistate_local; si_ifso: node }. + +Definition seval_condition ge sp (cond: condition) (lsv: list_sval) (sm: smem) rs0 m0 : option bool := + SOME args <- seval_list_sval ge sp lsv rs0 m0 IN + SOME m <- seval_smem ge sp sm rs0 m0 IN + eval_condition cond args m. + +Definition all_fallthrough ge sp (lx: list sistate_exit) rs0 m0: Prop := + forall ext, List.In ext lx -> + seval_condition ge sp ext.(si_cond) ext.(si_scondargs) ext.(si_elocal).(si_smem) rs0 m0 = Some false. + +Lemma all_fallthrough_revcons ge sp ext rs m lx: + all_fallthrough ge sp (ext::lx) rs m -> + seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs m = Some false + /\ all_fallthrough ge sp lx rs m. +Proof. + intros ALLFU. constructor. + - assert (In ext (ext::lx)) by (constructor; auto). apply ALLFU in H. assumption. + - intros ext' INEXT. assert (In ext' (ext::lx)) by (apply in_cons; auto). + apply ALLFU in H. assumption. +Qed. + +(** Semantic of an exit in pseudo code: + if si_cond (si_condargs) + si_elocal; goto if_so + else () +*) + +Definition ssem_exit (ge: RTL.genv) (sp: val) (ext: sistate_exit) (rs: regset) (m: mem) rs' m' (pc': node) : Prop := + seval_condition ge sp (si_cond ext) (si_scondargs ext) ext.(si_elocal).(si_smem) rs m = Some true + /\ ssem_local ge sp (si_elocal ext) rs m rs' m' + /\ (si_ifso ext) = pc'. + +(* Either an abort on the condition evaluation OR an abort on the sistate_local IF the condition was true *) +Definition sabort_exit (ge: RTL.genv) (sp: val) (ext: sistate_exit) (rs: regset) (m: mem) : Prop := + let sev_cond := seval_condition ge sp (si_cond ext) (si_scondargs ext) ext.(si_elocal).(si_smem) rs m in + sev_cond = None + \/ (sev_cond = Some true /\ sabort_local ge sp ext.(si_elocal) rs m). + +(** * Syntax and Semantics of symbolic internal state *) +Record sistate := { si_pc: node; si_exits: list sistate_exit; si_local: sistate_local }. + +Definition all_fallthrough_upto_exit ge sp ext lx' lx rs m : Prop := + is_tail (ext::lx') lx /\ all_fallthrough ge sp lx' rs m. + +(** Semantic of a sistate in pseudo code: + si_exit1; si_exit2; ...; si_exitn; + si_local; goto si_pc *) + +(* Note: in RTLpath, is.(icontinue) = false iff we took an early exit *) + +Definition ssem_internal (ge: RTL.genv) (sp:val) (st: sistate) (rs: regset) (m: mem) (is: istate): Prop := + if (is.(icontinue)) + then + ssem_local ge sp st.(si_local) rs m is.(irs) is.(imem) + /\ st.(si_pc) = is.(ipc) + /\ all_fallthrough ge sp st.(si_exits) rs m + else exists ext lx, + ssem_exit ge sp ext rs m is.(irs) is.(imem) is.(ipc) + /\ all_fallthrough_upto_exit ge sp ext lx st.(si_exits) rs m. + +Definition sabort (ge: RTL.genv) (sp: val) (st: sistate) (rs: regset) (m: mem): Prop := + (* No early exit was met but we aborted on the si_local *) + (all_fallthrough ge sp st.(si_exits) rs m /\ sabort_local ge sp st.(si_local) rs m) + (* OR we aborted on an evaluation of one of the early exits *) + \/ (exists ext lx, all_fallthrough_upto_exit ge sp ext lx st.(si_exits) rs m /\ sabort_exit ge sp ext rs m). + +Definition ssem_internal_opt ge sp (st: sistate) rs0 m0 (ois: option istate): Prop := + match ois with + | Some is => ssem_internal ge sp st rs0 m0 is + | None => sabort ge sp st rs0 m0 + end. + +Definition ssem_internal_opt2 ge sp (ost: option sistate) rs0 m0 (ois: option istate) : Prop := + match ost with + | Some st => ssem_internal_opt ge sp st rs0 m0 ois + | None => ois=None + end. + +(** * An internal state represents a parallel program ! + + We prove below that the semantics [ssem_internal_opt] is deterministic. + + *) + +Definition istate_eq ist1 ist2 := + ist1.(icontinue) = ist2.(icontinue) /\ + ist1.(ipc) = ist2.(ipc) /\ + (forall r, (ist1.(irs)#r) = ist2.(irs)#r) /\ + ist1.(imem) = ist2.(imem). + +Lemma all_fallthrough_noexit ge sp ext lx rs0 m0 rs m pc: + ssem_exit ge sp ext rs0 m0 rs m pc -> + In ext lx -> + all_fallthrough ge sp lx rs0 m0 -> + False. +Proof. + Local Hint Resolve is_tail_in: core. + intros SSEM INE ALLF. + destruct SSEM as (SSEM & SSEM'). + unfold all_fallthrough in ALLF. rewrite ALLF in SSEM; eauto. + discriminate. +Qed. + +Lemma ssem_internal_exclude_incompatible_continue ge sp st rs m is1 is2: + is1.(icontinue) = true -> + is2.(icontinue) = false -> + ssem_internal ge sp st rs m is1 -> + ssem_internal ge sp st rs m is2 -> + False. +Proof. + Local Hint Resolve all_fallthrough_noexit: core. + unfold ssem_internal. + intros CONT1 CONT2. + rewrite CONT1, CONT2; simpl. + intuition eauto. + destruct H0 as (ext & lx & SSEME & ALLFU). + destruct ALLFU as (ALLFU & ALLFU'). + eapply all_fallthrough_noexit; eauto. +Qed. + +Lemma ssem_internal_determ_continue ge sp st rs m is1 is2: + ssem_internal ge sp st rs m is1 -> + ssem_internal ge sp st rs m is2 -> + is1.(icontinue) = is2.(icontinue). +Proof. + Local Hint Resolve ssem_internal_exclude_incompatible_continue: core. + destruct (Bool.bool_dec is1.(icontinue) is2.(icontinue)) as [|H]; auto. + intros H1 H2. assert (absurd: False); intuition. + destruct (icontinue is1) eqn: His1, (icontinue is2) eqn: His2; eauto. +Qed. + +Lemma ssem_local_determ ge sp st rs0 m0 rs1 m1 rs2 m2: + ssem_local ge sp st rs0 m0 rs1 m1 -> + ssem_local ge sp st rs0 m0 rs2 m2 -> + (forall r, rs1#r = rs2#r) /\ m1 = m2. +Proof. + unfold ssem_local. intuition try congruence. + generalize (H5 r); rewrite H4; congruence. +Qed. + +(* TODO: lemma to move in Coqlib *) +Lemma is_tail_bounded_total {A} (l1 l2 l3: list A): is_tail l1 l3 -> is_tail l2 l3 + -> is_tail l1 l2 \/ is_tail l2 l1. +Proof. + Local Hint Resolve is_tail_cons: core. + induction 1 as [|i l1 l3 T1 IND]; simpl; auto. + intros T2; inversion T2; subst; auto. +Qed. + +Lemma exit_cond_determ ge sp rs0 m0 l1 l2: + is_tail l1 l2 -> forall ext1 lx1 ext2 lx2, + l1=(ext1 :: lx1) -> + l2=(ext2 :: lx2) -> + all_fallthrough ge sp lx1 rs0 m0 -> + seval_condition ge sp (si_cond ext1) (si_scondargs ext1) (si_smem (si_elocal ext1)) rs0 m0 = Some true -> + all_fallthrough ge sp lx2 rs0 m0 -> + ext1=ext2. +Proof. + destruct 1 as [l1|i l1 l3 T1]; intros ext1 lx1 ext2 lx2 EQ1 EQ2; subst; + inversion EQ2; subst; auto. + intros D1 EVAL NYE. + Local Hint Resolve is_tail_in: core. + unfold all_fallthrough in NYE. + rewrite NYE in EVAL; eauto. + try congruence. +Qed. + +Lemma ssem_exit_determ ge sp ext rs0 m0 rs1 m1 pc1 rs2 m2 pc2: + ssem_exit ge sp ext rs0 m0 rs1 m1 pc1 -> + ssem_exit ge sp ext rs0 m0 rs2 m2 pc2 -> + pc1 = pc2 /\ (forall r, rs1#r = rs2#r) /\ m1 = m2. +Proof. + Local Hint Resolve exit_cond_determ eq_sym: core. + intros SSEM1 SSEM2. destruct SSEM1 as (SEVAL1 & SLOC1 & PCEQ1). destruct SSEM2 as (SEVAL2 & SLOC2 & PCEQ2). subst. + destruct (ssem_local_determ ge sp (si_elocal ext) rs0 m0 rs1 m1 rs2 m2); auto. +Qed. + +Remark is_tail_inv_left {A: Type} (a a': A) l l': + is_tail (a::l) (a'::l') -> + (a = a' /\ l = l') \/ (In a l' /\ is_tail l (a'::l')). +Proof. + intros. inv H. + - left. eauto. + - right. econstructor. + + eapply is_tail_in; eauto. + + eapply is_tail_cons_left; eauto. +Qed. + +Lemma ssem_internal_determ ge sp st rs m is1 is2: + ssem_internal ge sp st rs m is1 -> + ssem_internal ge sp st rs m is2 -> + istate_eq is1 is2. +Proof. + unfold istate_eq. + intros SEM1 SEM2. + exploit (ssem_internal_determ_continue ge sp st rs m is1 is2); eauto. + intros CONTEQ. unfold ssem_internal in * |-. rewrite CONTEQ in * |- *. + destruct (icontinue is2). + - destruct (ssem_local_determ ge sp (si_local st) rs m (irs is1) (imem is1) (irs is2) (imem is2)); + intuition (try congruence). + - destruct SEM1 as (ext1 & lx1 & SSEME1 & ALLFU1). destruct SEM2 as (ext2 & lx2 & SSEME2 & ALLFU2). + destruct ALLFU1 as (ALLFU1 & ALLFU1'). destruct ALLFU2 as (ALLFU2 & ALLFU2'). + destruct SSEME1 as (SSEME1 & SSEME1' & SSEME1''). destruct SSEME2 as (SSEME2 & SSEME2' & SSEME2''). + assert (X:ext1=ext2). + { destruct (is_tail_bounded_total (ext1 :: lx1) (ext2 :: lx2) (si_exits st)) as [TAIL|TAIL]; eauto. } + subst. destruct (ssem_local_determ ge sp (si_elocal ext2) rs m (irs is1) (imem is1) (irs is2) (imem is2)); auto. + intuition. congruence. +Qed. + +Lemma ssem_local_exclude_sabort_local ge sp loc rs m rs' m': + ssem_local ge sp loc rs m rs' m' -> +(* all_fallthrough ge sp (si_exits st) rs m -> *) + sabort_local ge sp loc rs m -> + False. +Proof. + intros SIML (* ALLF *) ABORT. inv SIML. destruct H0 as (H0 & H0'). + inversion ABORT as [ABORT1 | [ABORT2 | ABORT3]]; [ | | inv ABORT3]; congruence. +Qed. + +(* TODO: remove this JUNK ? +Lemma ssem_local_exclude_sabort_exit ge sp st ext lx rs m rs' m': + ssem_local ge sp (si_local st) rs m rs' m' -> + all_fallthrough ge sp (si_exits st) rs m -> + is_tail (ext :: lx) (si_exits st) -> + sabort_exit ge sp ext rs m -> + False. +Proof. + intros SSEML ALLF TAIL ABORT. + inv ABORT. + - exploit ALLF; eauto. congruence. + - (* FIXME Problem : if we have a ssem_local, this means we ONLY evaluated the conditions, + but we NEVER actually evaluated the si_elocal from the sistate_exit ! So we cannot prove + a lack of abort on the si_elocal.. We must change the definitions *) +Abort. +*) + +Lemma ssem_local_exclude_sabort ge sp st rs m rs' m': + ssem_local ge sp (si_local st) rs m rs' m' -> + all_fallthrough ge sp (si_exits st) rs m -> + sabort ge sp st rs m -> + False. +Proof. + intros SIML ALLF ABORT. + inv ABORT. + - intuition; eapply ssem_local_exclude_sabort_local; eauto. + - destruct H as (ext & lx & ALLFU & SABORT). + destruct ALLFU as (TAIL & _). eapply is_tail_in in TAIL. + eapply ALLF in TAIL. + destruct SABORT as [CONDFAIL | (CONDTRUE & ABORTL)]; congruence. +Qed. + +Lemma ssem_exit_fallthrough_upto_exit ge sp ext ext' lx lx' exits rs m rs' m' pc': + ssem_exit ge sp ext rs m rs' m' pc' -> + all_fallthrough_upto_exit ge sp ext lx exits rs m -> + all_fallthrough_upto_exit ge sp ext' lx' exits rs m -> + is_tail (ext'::lx') (ext::lx). +Proof. + intros SSEME ALLFU ALLFU'. + destruct ALLFU as (ISTAIL & ALLFU). destruct ALLFU' as (ISTAIL' & ALLFU'). + destruct (is_tail_bounded_total (ext::lx) (ext'::lx') exits); eauto. + inv H. + - econstructor; eauto. + - eapply is_tail_in in H2. eapply ALLFU' in H2. + destruct SSEME as (SEVAL & _). congruence. +Qed. + +Lemma ssem_exit_exclude_sabort_exit ge sp ext rs m rs' m' pc': + ssem_exit ge sp ext rs m rs' m' pc' -> + sabort_exit ge sp ext rs m -> + False. +Proof. + intros A B. destruct A as (A & A' & A''). inv B. + - congruence. + - destruct H as (_ & H). eapply ssem_local_exclude_sabort_local; eauto. +Qed. + +Lemma ssem_exit_exclude_sabort ge sp ext st lx rs m rs' m' pc': + ssem_exit ge sp ext rs m rs' m' pc' -> + all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs m -> + sabort ge sp st rs m -> + False. +Proof. + intros SSEM ALLFU ABORT. + inv ABORT. + - destruct H as (ALLF & _). destruct ALLFU as (TAIL & _). + eapply is_tail_in in TAIL. + destruct SSEM as (SEVAL & _ & _). + eapply ALLF in TAIL. congruence. + - destruct H as (ext' & lx' & ALLFU' & ABORT). + exploit ssem_exit_fallthrough_upto_exit; eauto. intros ITAIL. + destruct ALLFU as (ALLFU1 & ALLFU2). destruct ALLFU' as (ALLFU1' & ALLFU2'). + exploit (is_tail_inv_left ext' ext lx' lx); eauto. intro. inv H. + + inv H0. eapply ssem_exit_exclude_sabort_exit; eauto. + + destruct H0 as (INE & TAIL). eapply ALLFU2 in INE. destruct ABORT as [ABORT | (ABORT & ABORT')]; congruence. +Qed. + +Lemma ssem_internal_exclude_sabort ge sp st rs m is: + sabort ge sp st rs m -> + ssem_internal ge sp st rs m is -> False. +Proof. + intros ABORT SEM. + unfold ssem_internal in SEM. destruct icontinue. + - destruct SEM as (SEM1 & SEM2 & SEM3). + eapply ssem_local_exclude_sabort; eauto. + - destruct SEM as (ext & lx & SEM1 & SEM2). eapply ssem_exit_exclude_sabort; eauto. +Qed. + +Definition istate_eq_opt ist1 oist := + exists ist2, oist = Some ist2 /\ istate_eq ist1 ist2. + +Lemma ssem_internal_opt_determ ge sp st rs m ois is: + ssem_internal_opt ge sp st rs m ois -> + ssem_internal ge sp st rs m is -> + istate_eq_opt is ois. +Proof. + destruct ois as [is1|]; simpl; eauto. + - intros; eexists; intuition; eapply ssem_internal_determ; eauto. + - intros; exploit ssem_internal_exclude_sabort; eauto. destruct 1. +Qed. + +(** * Symbolic execution of one internal step *) + +Definition slocal_set_sreg (st:sistate_local) (r:reg) (sv:sval) := + {| si_pre:=(fun ge sp rs m => seval_sval ge sp (st.(si_sreg) r) rs m <> None /\ (st.(si_pre) ge sp rs m)); + si_sreg:=fun y => if Pos.eq_dec r y then sv else st.(si_sreg) y; + si_smem:= st.(si_smem)|}. + +Definition slocal_set_smem (st:sistate_local) (sm:smem) := + {| si_pre:=(fun ge sp rs m => seval_smem ge sp st.(si_smem) rs m <> None /\ (st.(si_pre) ge sp rs m)); + si_sreg:= st.(si_sreg); + si_smem:= sm |}. + +Definition sist_set_local (st: sistate) (pc: node) (nxt: sistate_local): sistate := + {| si_pc := pc; si_exits := st.(si_exits); si_local:= nxt |}. + +Definition slocal_store st chunk addr args src : sistate_local := + let args := list_sval_inj (List.map (si_sreg st) args) in + let src := si_sreg st src in + let sm := Sstore (si_smem st) chunk addr args src + in slocal_set_smem st sm. + +Definition siexec_inst (i: instruction) (st: sistate): option sistate := + match i with + | Inop pc' => + Some (sist_set_local st pc' st.(si_local)) + | Iop op args dst pc' => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let next := slocal_set_sreg prev dst (Sop op vargs prev.(si_smem)) in + Some (sist_set_local st pc' next) + | Iload trap chunk addr args dst pc' => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let next := slocal_set_sreg prev dst (Sload prev.(si_smem) trap chunk addr vargs) in + Some (sist_set_local st pc' next) + | Istore chunk addr args src pc' => + let next := slocal_store st.(si_local) chunk addr args src in + Some (sist_set_local st pc' next) + | Icond cond args ifso ifnot _ => + let prev := st.(si_local) in + let vargs := list_sval_inj (List.map prev.(si_sreg) args) in + let ex := {| si_cond:=cond; si_scondargs:=vargs; si_elocal := prev; si_ifso := ifso |} in + Some {| si_pc := ifnot; si_exits := ex::st.(si_exits); si_local := prev |} + | _ => None (* TODO jumptable ? *) + end. + +Lemma seval_list_sval_inj ge sp l rs0 m0 (sreg: reg -> sval) rs: + (forall r : reg, seval_sval ge sp (sreg r) rs0 m0 = Some (rs # r)) -> + seval_list_sval ge sp (list_sval_inj (map sreg l)) rs0 m0 = Some (rs ## l). +Proof. + intros H; induction l as [|r l]; simpl; auto. + inversion_SOME v. + inversion_SOME lv. + generalize (H r). + try_simplify_someHyps. +Qed. + +Lemma slocal_set_sreg_preserves_sabort_local ge sp st rs0 m0 r sv: + sabort_local ge sp st rs0 m0 -> + sabort_local ge sp (slocal_set_sreg st r sv) rs0 m0. +Proof. + unfold sabort_local. simpl; intuition. + destruct H as [r1 H]. destruct (Pos.eq_dec r r1) as [TEST|TEST] eqn: HTEST. + - subst; rewrite H; intuition. + - right. right. exists r1. rewrite HTEST. auto. +Qed. + +Lemma slocal_set_smem_preserves_sabort_local ge sp st rs0 m0 m: + sabort_local ge sp st rs0 m0 -> + sabort_local ge sp (slocal_set_smem st m) rs0 m0. +Proof. + unfold sabort_local. simpl; intuition. +Qed. + +Lemma all_fallthrough_upto_exit_cons ge sp ext lx ext' exits rs m: + all_fallthrough_upto_exit ge sp ext lx exits rs m -> + all_fallthrough_upto_exit ge sp ext lx (ext'::exits) rs m. +Proof. + intros. inv H. econstructor; eauto. +Qed. + +Lemma all_fallthrough_cons ge sp exits rs m ext: + all_fallthrough ge sp exits rs m -> + seval_condition ge sp (si_cond ext) (si_scondargs ext) (si_smem (si_elocal ext)) rs m = Some false -> + all_fallthrough ge sp (ext::exits) rs m. +Proof. + intros. unfold all_fallthrough in *. intros. + inv H1; eauto. +Qed. + +Lemma siexec_inst_preserves_sabort i ge sp rs m st st': + siexec_inst i st = Some st' -> + sabort ge sp st rs m -> sabort ge sp st' rs m. +Proof. + intros SISTEP ABORT. + destruct i; simpl in SISTEP; try discriminate; inv SISTEP; unfold sabort; simpl. + (* NOP *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* OP *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. eapply slocal_set_sreg_preserves_sabort_local; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* LOAD *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. eapply slocal_set_sreg_preserves_sabort_local; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* STORE *) + * destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - left. constructor; eauto. eapply slocal_set_smem_preserves_sabort_local; eauto. + - right. exists ext0, lx0. constructor; eauto. + (* COND *) + * remember ({| si_cond := _; si_scondargs := _; si_elocal := _; si_ifso := _ |}) as ext. + destruct ABORT as [(ALLF & ABORTL) | (ext0 & lx0 & ALLFU & ABORTE)]. + - destruct (seval_condition ge sp (si_cond ext) (si_scondargs ext) + (si_smem (si_elocal ext)) rs m) eqn:SEVAL; [destruct b|]. + (* case true *) + + right. exists ext, (si_exits st). + constructor. + ++ constructor. econstructor; eauto. eauto. + ++ unfold sabort_exit. right. constructor; eauto. + subst. simpl. eauto. + (* case false *) + + left. constructor; eauto. eapply all_fallthrough_cons; eauto. + (* case None *) + + right. exists ext, (si_exits st). constructor. + ++ constructor. econstructor; eauto. eauto. + ++ unfold sabort_exit. left. eauto. + - right. exists ext0, lx0. constructor; eauto. eapply all_fallthrough_upto_exit_cons; eauto. +Qed. + +Lemma siexec_inst_WF i st: + siexec_inst i st = None -> default_succ i = None. +Proof. + destruct i; simpl; unfold sist_set_local; simpl; congruence. +Qed. + +Lemma siexec_inst_default_succ i st st': + siexec_inst i st = Some st' -> default_succ i = Some (st'.(si_pc)). +Proof. + destruct i; simpl; unfold sist_set_local; simpl; try congruence; + intro H; inversion_clear H; simpl; auto. +Qed. + + +Lemma seval_list_sval_inj_not_none ge sp st rs0 m0: forall l, + (forall r, List.In r l -> seval_sval ge sp (si_sreg st r) rs0 m0 = None -> False) -> + seval_list_sval ge sp (list_sval_inj (map (si_sreg st) l)) rs0 m0 = None -> False. +Proof. + induction l. + - intuition discriminate. + - intros ALLR. simpl. + inversion_SOME v. + + intro SVAL. inversion_SOME lv; [discriminate|]. + assert (forall r : reg, In r l -> seval_sval ge sp (si_sreg st r) rs0 m0 = None -> False). + { intros r INR. eapply ALLR. right. assumption. } + intro SVALLIST. intro. eapply IHl; eauto. + + intros. exploit (ALLR a); simpl; eauto. +Qed. + +Lemma siexec_inst_correct ge sp i st rs0 m0 rs m: + ssem_local ge sp st.(si_local) rs0 m0 rs m -> + all_fallthrough ge sp st.(si_exits) rs0 m0 -> + ssem_internal_opt2 ge sp (siexec_inst i st) rs0 m0 (istep ge i sp rs m). +Proof. + intros (PRE & MEM & REG) NYE. + destruct i; simpl; auto. + + (* Nop *) + constructor; [|constructor]; simpl; auto. + constructor; auto. + + (* Op *) + inversion_SOME v; intros OP; simpl. + - constructor; [|constructor]; simpl; auto. + constructor; simpl; auto. + * constructor; auto. congruence. + * constructor; auto. + intro r0. destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst. rewrite Regmap.gss; simpl; auto. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + - left. constructor; simpl; auto. + unfold sabort_local. right. right. + simpl. exists r. destruct (Pos.eq_dec r r); try congruence. + simpl. erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + + (* LOAD *) + inversion_SOME a0; intro ADD. + { inversion_SOME v; intros LOAD; simpl. + - explore_destruct; unfold ssem_internal, ssem_local; simpl; intuition. + * unfold ssem_internal. simpl. constructor; [|constructor]; auto. + constructor; constructor; simpl; auto. congruence. intro r0. + destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst; rewrite Regmap.gss; simpl. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + * unfold ssem_internal. simpl. constructor; [|constructor]; auto. + constructor; constructor; simpl; auto. congruence. intro r0. + destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst; rewrite Regmap.gss; simpl. + inversion_SOME args; intros ARGS. + 2: { exploit seval_list_sval_inj_not_none; eauto; intuition congruence. } + exploit seval_list_sval_inj; eauto. intro ARGS'. erewrite ARGS in ARGS'. inv ARGS'. rewrite ADD. + inversion_SOME m2. intro SMEM. + assert (m = m2) by congruence. subst. rewrite LOAD. reflexivity. + - explore_destruct; unfold sabort, sabort_local; simpl. + * unfold sabort. simpl. left. constructor; auto. + right. right. exists r. simpl. destruct (Pos.eq_dec r r); try congruence. + simpl. erewrite seval_list_sval_inj; simpl; auto. + rewrite ADD; simpl; auto. try_simplify_someHyps. + * unfold ssem_internal. simpl. constructor; [|constructor]; auto. + constructor; constructor; simpl; auto. congruence. intro r0. + destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst; rewrite Regmap.gss; simpl. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + } { rewrite ADD. destruct t. + - simpl. left; eauto. simpl. econstructor; eauto. + right. right. simpl. exists r. destruct (Pos.eq_dec r r); [|contradiction]. + simpl. inversion_SOME args. intro SLS. + eapply seval_list_sval_inj in REG. rewrite REG in SLS. inv SLS. + rewrite ADD. reflexivity. + - simpl. constructor; [|constructor]; simpl; auto. + constructor; simpl; constructor; auto; [congruence|]. + intro r0. destruct (Pos.eq_dec r r0); [|rewrite Regmap.gso; auto]. + subst. simpl. rewrite Regmap.gss. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + } + + (* STORE *) + inversion_SOME a0; intros ADD. + { inversion_SOME m'; intros STORE; simpl. + - unfold ssem_internal, ssem_local; simpl; intuition. + * congruence. + * erewrite seval_list_sval_inj; simpl; auto. + erewrite REG. + try_simplify_someHyps. + - unfold sabort, sabort_local; simpl. + left. constructor; auto. right. left. + erewrite seval_list_sval_inj; simpl; auto. + erewrite REG. + try_simplify_someHyps. } + { unfold sabort, sabort_local; simpl. + left. constructor; auto. right. left. + erewrite seval_list_sval_inj; simpl; auto. + erewrite ADD; simpl; auto. } + + (* COND *) + Local Hint Resolve is_tail_refl: core. + Local Hint Unfold ssem_local: core. + inversion_SOME b; intros COND. + { destruct b; simpl; unfold ssem_internal, ssem_local; simpl. + - remember (mk_sistate_exit _ _ _ _) as ext. exists ext, (si_exits st). + constructor; constructor; subst; simpl; auto. + unfold seval_condition. subst; simpl. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. + - intuition. unfold all_fallthrough in * |- *. simpl. + intuition. subst. simpl. + unfold seval_condition. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. } + { unfold sabort. simpl. right. + remember (mk_sistate_exit _ _ _ _) as ext. exists ext, (si_exits st). + constructor; [constructor; subst; simpl; auto|]. + left. subst; simpl; auto. + unfold seval_condition. + erewrite seval_list_sval_inj; simpl; auto. + try_simplify_someHyps. } +Qed. + + +Lemma siexec_inst_correct_None ge sp i st rs0 m0 rs m: + ssem_local ge sp (st.(si_local)) rs0 m0 rs m -> + siexec_inst i st = None -> + istep ge i sp rs m = None. +Proof. + intros (PRE & MEM & REG). + destruct i; simpl; unfold sist_set_local, ssem_internal, ssem_local; simpl; try_simplify_someHyps. +Qed. + +(** * Symbolic execution of the internal steps of a path *) +Fixpoint siexec_path (path:nat) (f: function) (st: sistate): option sistate := + match path with + | O => Some st + | S p => + SOME i <- (fn_code f)!(st.(si_pc)) IN + SOME st1 <- siexec_inst i st IN + siexec_path p f st1 + end. + +Lemma siexec_inst_add_exits i st st': + siexec_inst i st = Some st' -> + ( si_exits st' = si_exits st \/ exists ext, si_exits st' = ext :: si_exits st ). +Proof. + destruct i; simpl; intro SISTEP; inversion_clear SISTEP; unfold siexec_inst; simpl; (discriminate || eauto). +Qed. + +Lemma siexec_inst_preserves_allfu ge sp ext lx rs0 m0 st st' i: + all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs0 m0 -> + siexec_inst i st = Some st' -> + all_fallthrough_upto_exit ge sp ext lx (si_exits st') rs0 m0. +Proof. + intros ALLFU SISTEP. destruct ALLFU as (ISTAIL & ALLF). + constructor; eauto. + destruct i; simpl in SISTEP; inversion_clear SISTEP; simpl; (discriminate || eauto). +Qed. + +Lemma siexec_path_correct_false ge sp f rs0 m0 st' is: + forall path, + is.(icontinue)=false -> + forall st, ssem_internal ge sp st rs0 m0 is -> + siexec_path path f st = Some st' -> + ssem_internal ge sp st' rs0 m0 is. +Proof. + induction path; simpl. + - intros. congruence. + - intros ICF st SSEM STEQ'. + destruct ((fn_code f) ! (si_pc st)) eqn:FIC; [|discriminate]. + destruct (siexec_inst _ _) eqn:SISTEP; [|discriminate]. + eapply IHpath. 3: eapply STEQ'. eauto. + unfold ssem_internal in SSEM. rewrite ICF in SSEM. + destruct SSEM as (ext & lx & SEXIT & ALLFU). + unfold ssem_internal. rewrite ICF. exists ext, lx. + constructor; auto. eapply siexec_inst_preserves_allfu; eauto. +Qed. + +Lemma siexec_path_preserves_sabort ge sp path f rs0 m0 st': forall st, + siexec_path path f st = Some st' -> + sabort ge sp st rs0 m0 -> sabort ge sp st' rs0 m0. +Proof. + Local Hint Resolve siexec_inst_preserves_sabort: core. + induction path; simpl. + + unfold sist_set_local; try_simplify_someHyps. + + intros st; inversion_SOME i. + inversion_SOME st1; eauto. +Qed. + +Lemma siexec_path_WF path f: forall st, + siexec_path path f st = None -> nth_default_succ (fn_code f) path st.(si_pc) = None. +Proof. + induction path; simpl. + + unfold sist_set_local. intuition congruence. + + intros st; destruct ((fn_code f) ! (si_pc st)); simpl; try tauto. + destruct (siexec_inst i st) as [st1|] eqn: Hst1; simpl. + - intros; erewrite siexec_inst_default_succ; eauto. + - intros; erewrite siexec_inst_WF; eauto. +Qed. + +Lemma siexec_path_default_succ path f st': forall st, + siexec_path path f st = Some st' -> nth_default_succ (fn_code f) path st.(si_pc) = Some st'.(si_pc). +Proof. + induction path; simpl. + + unfold sist_set_local. intros st H. inversion_clear H; simpl; try congruence. + + intros st; destruct ((fn_code f) ! (si_pc st)); simpl; try congruence. + destruct (siexec_inst i st) as [st1|] eqn: Hst1; simpl; try congruence. + intros; erewrite siexec_inst_default_succ; eauto. +Qed. + +Lemma siexec_path_correct_true ge sp path (f:function) rs0 m0: forall st is, + is.(icontinue)=true -> + ssem_internal ge sp st rs0 m0 is -> + nth_default_succ (fn_code f) path st.(si_pc) <> None -> + ssem_internal_opt2 ge sp (siexec_path path f st) rs0 m0 + (isteps ge path f sp is.(irs) is.(imem) is.(ipc)) + . +Proof. + Local Hint Resolve siexec_path_correct_false siexec_path_preserves_sabort siexec_path_WF: core. + induction path; simpl. + + intros st is CONT INV WF; + unfold ssem_internal, sist_set_local in * |- *; + try_simplify_someHyps. simpl. + destruct is; simpl in * |- *; subst; intuition auto. + + intros st is CONT; unfold ssem_internal at 1; rewrite CONT. + intros (LOCAL & PC & NYE) WF. + rewrite <- PC. + inversion_SOME i; intro Hi; rewrite Hi in WF |- *; simpl; auto. + exploit siexec_inst_correct; eauto. + inversion_SOME st1; intros Hst1; erewrite Hst1; simpl. + - inversion_SOME is1; intros His1;rewrite His1; simpl. + * destruct (icontinue is1) eqn:CONT1. + (* icontinue is0 = true *) + intros; eapply IHpath; eauto. + destruct i; simpl in * |- *; unfold sist_set_local in * |- *; try_simplify_someHyps. + (* icontinue is0 = false -> EARLY EXIT *) + destruct (siexec_path path f st1) as [st2|] eqn: Hst2; simpl; eauto. + destruct WF. erewrite siexec_inst_default_succ; eauto. + (* try_simplify_someHyps; eauto. *) + * destruct (siexec_path path f st1) as [st2|] eqn: Hst2; simpl; eauto. + - intros His1;rewrite His1; simpl; auto. +Qed. + +(** REM: in the following two unused lemmas *) + +Lemma siexec_path_right_assoc_decompose f path: forall st st', + siexec_path (S path) f st = Some st' -> + exists st0, siexec_path path f st = Some st0 /\ siexec_path 1%nat f st0 = Some st'. +Proof. + induction path; simpl; eauto. + intros st st'. + inversion_SOME i1. + inversion_SOME st1. + try_simplify_someHyps; eauto. +Qed. + +Lemma siexec_path_right_assoc_compose f path: forall st st0 st', + siexec_path path f st = Some st0 -> + siexec_path 1%nat f st0 = Some st' -> + siexec_path (S path) f st = Some st'. +Proof. + induction path. + + intros st st0 st' H. simpl in H. + try_simplify_someHyps; auto. + + intros st st0 st'. + assert (X:exists x, x=(S path)); eauto. + destruct X as [x X]. + intros H1 H2. rewrite <- X. + generalize H1; clear H1. simpl. + inversion_SOME i1. intros Hi1; rewrite Hi1. + inversion_SOME st1. intros Hst1; rewrite Hst1. + subst; eauto. +Qed. + +(** * Symbolic (final) value of a path *) +Inductive sfval := + | Snone + | Scall (sig:signature) (svos: sval + ident) (lsv:list_sval) (res:reg) (pc:node) + (* NB: [res] the return register is hard-wired ! Is it restrictive ? *) + | Stailcall: signature -> sval + ident -> list_sval -> sfval + | Sbuiltin (ef:external_function) (sargs: list (builtin_arg sval)) (res: builtin_res reg) (pc:node) + | Sjumptable (sv: sval) (tbl: list node) + | Sreturn: option sval -> sfval +. + +Definition sfind_function (pge: RTLpath.genv) (ge: RTL.genv) (sp: val) (svos : sval + ident) (rs0: regset) (m0: mem): option fundef := + match svos with + | inl sv => SOME v <- seval_sval ge sp sv rs0 m0 IN Genv.find_funct pge v + | inr symb => SOME b <- Genv.find_symbol pge symb IN Genv.find_funct_ptr pge b + end. + +Section SEVAL_BUILTIN_ARG. (* adapted from Events.v *) + +Variable ge: RTL.genv. +Variable sp: val. +Variable m: mem. +Variable rs0: regset. +Variable m0: mem. + +Inductive seval_builtin_arg: builtin_arg sval -> val -> Prop := + | seval_BA: forall x v, + seval_sval ge sp x rs0 m0 = Some v -> + seval_builtin_arg (BA x) v + | seval_BA_int: forall n, + seval_builtin_arg (BA_int n) (Vint n) + | seval_BA_long: forall n, + seval_builtin_arg (BA_long n) (Vlong n) + | seval_BA_float: forall n, + seval_builtin_arg (BA_float n) (Vfloat n) + | seval_BA_single: forall n, + seval_builtin_arg (BA_single n) (Vsingle n) + | seval_BA_loadstack: forall chunk ofs v, + Mem.loadv chunk m (Val.offset_ptr sp ofs) = Some v -> + seval_builtin_arg (BA_loadstack chunk ofs) v + | seval_BA_addrstack: forall ofs, + seval_builtin_arg (BA_addrstack ofs) (Val.offset_ptr sp ofs) + | seval_BA_loadglobal: forall chunk id ofs v, + Mem.loadv chunk m (Senv.symbol_address ge id ofs) = Some v -> + seval_builtin_arg (BA_loadglobal chunk id ofs) v + | seval_BA_addrglobal: forall id ofs, + seval_builtin_arg (BA_addrglobal id ofs) (Senv.symbol_address ge id ofs) + | seval_BA_splitlong: forall hi lo vhi vlo, + seval_builtin_arg hi vhi -> seval_builtin_arg lo vlo -> + seval_builtin_arg (BA_splitlong hi lo) (Val.longofwords vhi vlo) + | seval_BA_addptr: forall a1 a2 v1 v2, + seval_builtin_arg a1 v1 -> seval_builtin_arg a2 v2 -> + seval_builtin_arg (BA_addptr a1 a2) + (if Archi.ptr64 then Val.addl v1 v2 else Val.add v1 v2). + +Definition seval_builtin_args (al: list (builtin_arg sval)) (vl: list val) : Prop := + list_forall2 seval_builtin_arg al vl. + +Lemma seval_builtin_arg_determ: + forall a v, seval_builtin_arg a v -> forall v', seval_builtin_arg a v' -> v' = v. +Proof. + induction 1; intros v' EV; inv EV; try congruence. + f_equal; eauto. + apply IHseval_builtin_arg1 in H3. apply IHseval_builtin_arg2 in H5. subst; auto. +Qed. + +Lemma eval_builtin_args_determ: + forall al vl, seval_builtin_args al vl -> forall vl', seval_builtin_args al vl' -> vl' = vl. +Proof. + induction 1; intros v' EV; inv EV; f_equal; eauto using seval_builtin_arg_determ. +Qed. + +End SEVAL_BUILTIN_ARG. + +Inductive ssem_final (pge: RTLpath.genv) (ge: RTL.genv) (sp:val) (npc: node) stack (f: function) (rs0: regset) (m0: mem): sfval -> regset -> mem -> trace -> state -> Prop := + | exec_Snone rs m: + ssem_final pge ge sp npc stack f rs0 m0 Snone rs m E0 (State stack f sp npc rs m) + | exec_Scall rs m sig svos lsv args res pc fd: + sfind_function pge ge sp svos rs0 m0 = Some fd -> + funsig fd = sig -> + seval_list_sval ge sp lsv rs0 m0 = Some args -> + ssem_final pge ge sp npc stack f rs0 m0 (Scall sig svos lsv res pc) rs m + E0 (Callstate (Stackframe res f sp pc rs :: stack) fd args m) + | exec_Stailcall stk rs m sig svos args fd m' lsv: + sfind_function pge ge sp svos rs0 m0 = Some fd -> + funsig fd = sig -> + sp = Vptr stk Ptrofs.zero -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + seval_list_sval ge sp lsv rs0 m0 = Some args -> + ssem_final pge ge sp npc stack f rs0 m0 (Stailcall sig svos lsv) rs m + E0 (Callstate stack fd args m') + | exec_Sbuiltin m' rs m vres res pc t sargs ef vargs: + seval_builtin_args ge sp m rs0 m0 sargs vargs -> + external_call ef ge vargs m t vres m' -> + ssem_final pge ge sp npc stack f rs0 m0 (Sbuiltin ef sargs res pc) rs m + t (State stack f sp pc (regmap_setres res vres rs) m') + | exec_Sjumptable sv tbl pc' n rs m: + seval_sval ge sp sv rs0 m0 = Some (Vint n) -> + list_nth_z tbl (Int.unsigned n) = Some pc' -> + ssem_final pge ge sp npc stack f rs0 m0 (Sjumptable sv tbl) rs m + E0 (State stack f sp pc' rs m) + | exec_Sreturn stk osv rs m m' v: + sp = (Vptr stk Ptrofs.zero) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + match osv with Some sv => seval_sval ge sp sv rs0 m0 | None => Some Vundef end = Some v -> + ssem_final pge ge sp npc stack f rs0 m0 (Sreturn osv) rs m + E0 (Returnstate stack v m') +. + +Record sstate := { internal:> sistate; final: sfval }. + +Inductive ssem pge (ge: RTL.genv) (sp:val) (st: sstate) stack f (rs0: regset) (m0: mem): trace -> state -> Prop := + | ssem_early is: + is.(icontinue) = false -> + ssem_internal ge sp st rs0 m0 is -> + ssem pge ge sp st stack f rs0 m0 E0 (State stack f sp is.(ipc) is.(irs) is.(imem)) + | ssem_normal is t s: + is.(icontinue) = true -> + ssem_internal ge sp st rs0 m0 is -> + ssem_final pge ge sp st.(si_pc) stack f rs0 m0 st.(final) is.(irs) is.(imem) t s -> + ssem pge ge sp st stack f rs0 m0 t s + . + +(* NB: generic function that could be put into [AST] file *) +Fixpoint builtin_arg_map {A B} (f: A -> B) (arg: builtin_arg A) : builtin_arg B := + match arg with + | BA x => BA (f x) + | BA_int n => BA_int n + | BA_long n => BA_long n + | BA_float f => BA_float f + | BA_single s => BA_single s + | BA_loadstack chunk ptr => BA_loadstack chunk ptr + | BA_addrstack ptr => BA_addrstack ptr + | BA_loadglobal chunk id ptr => BA_loadglobal chunk id ptr + | BA_addrglobal id ptr => BA_addrglobal id ptr + | BA_splitlong ba1 ba2 => BA_splitlong (builtin_arg_map f ba1) (builtin_arg_map f ba2) + | BA_addptr ba1 ba2 => BA_addptr (builtin_arg_map f ba1) (builtin_arg_map f ba2) + end. + +Lemma seval_builtin_arg_correct ge sp rs m rs0 m0 sreg: forall arg varg, + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + eval_builtin_arg ge (fun r => rs # r) sp m arg varg -> + seval_builtin_arg ge sp m rs0 m0 (builtin_arg_map sreg arg) varg. +Proof. + induction arg. + all: try (intros varg SEVAL BARG; inv BARG; constructor; congruence). + - intros varg SEVAL BARG. inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. + - intros varg SEVAL BARG. inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. +Qed. + +Lemma seval_builtin_args_correct ge sp rs m rs0 m0 sreg args vargs: + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + eval_builtin_args ge (fun r => rs # r) sp m args vargs -> + seval_builtin_args ge sp m rs0 m0 (map (builtin_arg_map sreg) args) vargs. +Proof. + induction 2. + - constructor. + - simpl. constructor; [| assumption]. + eapply seval_builtin_arg_correct; eauto. +Qed. + +Lemma seval_builtin_arg_complete ge sp rs m rs0 m0 sreg: forall arg varg, + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + seval_builtin_arg ge sp m rs0 m0 (builtin_arg_map sreg arg) varg -> + eval_builtin_arg ge (fun r => rs # r) sp m arg varg. +Proof. + induction arg. + all: intros varg SEVAL BARG; try (inv BARG; constructor; congruence). + - inv BARG. rewrite SEVAL in H0. inv H0. constructor. + - inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. + - inv BARG. simpl. constructor. + eapply IHarg1; eauto. eapply IHarg2; eauto. +Qed. + +Lemma seval_builtin_args_complete ge sp rs m rs0 m0 sreg: forall args vargs, + (forall r, seval_sval ge sp (sreg r) rs0 m0 = Some rs # r) -> + seval_builtin_args ge sp m rs0 m0 (map (builtin_arg_map sreg) args) vargs -> + eval_builtin_args ge (fun r => rs # r) sp m args vargs. +Proof. + induction args. + - simpl. intros. inv H0. constructor. + - intros vargs SEVAL BARG. simpl in BARG. inv BARG. + constructor; [| eapply IHargs; eauto]. + eapply seval_builtin_arg_complete; eauto. +Qed. + +(** * Symbolic execution of final step *) +Definition sexec_final (i: instruction) (prev: sistate_local): sfval := + match i with + | Icall sig ros args res pc => + let svos := sum_left_map prev.(si_sreg) ros in + let sargs := list_sval_inj (List.map prev.(si_sreg) args) in + Scall sig svos sargs res pc + | Itailcall sig ros args => + let svos := sum_left_map prev.(si_sreg) ros in + let sargs := list_sval_inj (List.map prev.(si_sreg) args) in + Stailcall sig svos sargs + | Ibuiltin ef args res pc => + let sargs := List.map (builtin_arg_map prev.(si_sreg)) args in + Sbuiltin ef sargs res pc + | Ireturn or => + let sor := SOME r <- or IN Some (prev.(si_sreg) r) in + Sreturn sor + | Ijumptable reg tbl => + let sv := prev.(si_sreg) reg in + Sjumptable sv tbl + | _ => Snone + end. + +Lemma sexec_final_correct pge ge sp i (f:function) pc st stack rs0 m0 t rs m s: + (fn_code f) ! pc = Some i -> + pc = st.(si_pc) -> + ssem_local ge sp (si_local st) rs0 m0 rs m -> + path_last_step ge pge stack f sp pc rs m t s -> + siexec_inst i st = None -> + ssem_final pge ge sp pc stack f rs0 m0 (sexec_final i (si_local st)) rs m t s. +Proof. + intros PC1 PC2 (PRE&MEM®) LAST. destruct LAST; subst; try_simplify_someHyps; simpl. + + (* Snone *) intro Hi; destruct i; simpl in Hi |- *; unfold sist_set_local in Hi; try congruence. + + (* Icall *) intros; eapply exec_Scall; auto. + - destruct ros; simpl in * |- *; auto. + rewrite REG; auto. + - erewrite seval_list_sval_inj; simpl; auto. + + (* Itailcall *) intros. eapply exec_Stailcall; auto. + - destruct ros; simpl in * |- *; auto. + rewrite REG; auto. + - erewrite seval_list_sval_inj; simpl; auto. + + (* Ibuiltin *) intros. eapply exec_Sbuiltin; eauto. + eapply seval_builtin_args_correct; eauto. + + (* Ijumptable *) intros. eapply exec_Sjumptable; eauto. congruence. + + (* Ireturn *) intros; eapply exec_Sreturn; simpl; eauto. + destruct or; simpl; auto. +Qed. + +Lemma sexec_final_complete i (f:function) pc st ge pge sp stack rs0 m0 t rs m s: + (fn_code f) ! pc = Some i -> + pc = st.(si_pc) -> + ssem_local ge sp (si_local st) rs0 m0 rs m -> + ssem_final pge ge sp pc stack f rs0 m0 (sexec_final i (si_local st)) rs m t s -> + siexec_inst i st = None -> + path_last_step ge pge stack f sp pc rs m t s. +Proof. + intros PC1 PC2 (PRE&MEM®) LAST HSIS. + destruct i as [ (* Inop *) | (* Iop *) | (* Iload *) | (* Istore *) + | (* Icall *) sig ros args res pc' + | (* Itailcall *) sig ros args + | (* Ibuiltin *) ef bargs br pc' + | (* Icond *) + | (* Ijumptable *) jr tbl + | (*Ireturn*) or]; + subst; try_simplify_someHyps; try (unfold sist_set_local in HSIS; try congruence); + inversion LAST; subst; clear LAST; simpl in * |- *. + + (* Icall *) + erewrite seval_list_sval_inj in * |- ; simpl; try_simplify_someHyps; auto. + intros; eapply exec_Icall; eauto. + destruct ros; simpl in * |- *; auto. + rewrite REG in * |- ; auto. + + (* Itailcall *) + intros HPC SMEM. erewrite seval_list_sval_inj in H10; auto. inv H10. + eapply exec_Itailcall; eauto. + destruct ros; simpl in * |- *; auto. + rewrite REG in * |- ; auto. + + (* Ibuiltin *) intros HPC SMEM. + eapply exec_Ibuiltin; eauto. + eapply seval_builtin_args_complete; eauto. + + (* Ijumptable *) intros HPC SMEM. + eapply exec_Ijumptable; eauto. + congruence. + + (* Ireturn *) + intros; subst. enough (v=regmap_optget or Vundef rs) as ->. + * eapply exec_Ireturn; eauto. + * intros; destruct or; simpl; congruence. +Qed. + +(** * Main function of the symbolic execution *) + +Definition init_sistate_local := {| si_pre:= fun _ _ _ _ => True; si_sreg:= fun r => Sinput r; si_smem:= Sinit |}. + +Definition init_sistate pc := {| si_pc:= pc; si_exits:=nil; si_local:= init_sistate_local |}. + +Lemma init_ssem_internal ge sp pc rs m: ssem_internal ge sp (init_sistate pc) rs m (mk_istate true pc rs m). +Proof. + unfold ssem_internal, ssem_local, all_fallthrough; simpl. intuition. +Qed. + +Definition sexec (f: function) (pc:node): option sstate := + SOME path <- (fn_path f)!pc IN + SOME st <- siexec_path path.(psize) f (init_sistate pc) IN + SOME i <- (fn_code f)!(st.(si_pc)) IN + Some (match siexec_inst i st with + | Some st' => {| internal := st'; final := Snone |} + | None => {| internal := st; final := sexec_final i st.(si_local) |} + end). + +Lemma final_node_path_simpl f path pc: + (fn_path f)!pc = Some path -> nth_default_succ_inst (fn_code f) path.(psize) pc <> None. +Proof. + intros; exploit final_node_path; eauto. + intros (i & NTH & DUM). + congruence. +Qed. + +Lemma symb_path_last_step i st st' ge pge stack (f:function) sp pc rs m t s: + (fn_code f) ! pc = Some i -> + pc = st.(si_pc) -> + siexec_inst i st = Some st' -> + path_last_step ge pge stack f sp pc rs m t s -> + exists mk_istate, + istep ge i sp rs m = Some mk_istate + /\ t = E0 + /\ s = (State stack f sp mk_istate.(ipc) mk_istate.(RTLpath.irs) mk_istate.(imem)). +Proof. + intros PC1 PC2 Hst' LAST; destruct LAST; subst; try_simplify_someHyps; simpl. +Qed. + +(* NB: each concrete execution can be executed on the symbolic state (produced from [sexec]) +(sexec is a correct over-approximation) +*) +Theorem sexec_correct f pc pge ge sp path stack rs m t s: + (fn_path f)!pc = Some path -> + path_step ge pge path.(psize) stack f sp rs m pc t s -> + exists st, sexec f pc = Some st /\ ssem pge ge sp st stack f rs m t s. +Proof. + Local Hint Resolve init_ssem_internal: core. + intros PATH STEP; unfold sexec; rewrite PATH; simpl. + lapply (final_node_path_simpl f path pc); eauto. intro WF. + exploit (siexec_path_correct_true ge sp path.(psize) f rs m (init_sistate pc) (mk_istate true pc rs m)); simpl; eauto. + { intros ABS. apply WF; unfold nth_default_succ_inst. rewrite ABS; auto. } + (destruct (nth_default_succ_inst (fn_code f) path.(psize) pc) as [i|] eqn: Hi; [clear WF|congruence]). + destruct STEP as [sti STEPS CONT|sti t s STEPS CONT LAST]; + (* intro Hst *) + (rewrite STEPS; unfold ssem_internal_opt2; destruct (siexec_path _ _ _) as [st|] eqn: Hst; try congruence); + (* intro SEM *) + (simpl; unfold ssem_internal; simpl; rewrite CONT; intro SEM); + (* intro Hi' *) + ( assert (Hi': (fn_code f) ! (si_pc st) = Some i); + [ unfold nth_default_succ_inst in Hi; + exploit siexec_path_default_succ; eauto; simpl; + intros DEF; rewrite DEF in Hi; auto + | clear Hi; rewrite Hi' ]); + (* eexists *) + (eexists; constructor; eauto). + - (* early *) + eapply ssem_early; eauto. + unfold ssem_internal; simpl; rewrite CONT. + destruct (siexec_inst i st) as [st'|] eqn: Hst'; simpl; eauto. + destruct SEM as (ext & lx & SEM & ALLFU). exists ext, lx. + constructor; auto. eapply siexec_inst_preserves_allfu; eauto. + - destruct SEM as (SEM & PC & HNYE). + destruct (siexec_inst i st) as [st'|] eqn: Hst'; simpl. + + (* normal on Snone *) + rewrite <- PC in LAST. + exploit symb_path_last_step; eauto; simpl. + intros (mk_istate & ISTEP & Ht & Hs); subst. + exploit siexec_inst_correct; eauto. simpl. + erewrite Hst', ISTEP; simpl. + clear LAST CONT STEPS PC SEM HNYE Hst Hi' Hst' ISTEP st sti i. + intro SEM; destruct (mk_istate.(icontinue)) eqn: CONT. + { (* icontinue mk_istate = true *) + eapply ssem_normal; simpl; eauto. + unfold ssem_internal in SEM. + rewrite CONT in SEM. + destruct SEM as (SEM & PC & HNYE). + rewrite <- PC. + eapply exec_Snone. } + { eapply ssem_early; eauto. } + + (* normal non-Snone instruction *) + eapply ssem_normal; eauto. + * unfold ssem_internal; simpl; rewrite CONT; intuition. + * simpl. eapply sexec_final_correct; eauto. + rewrite PC; auto. +Qed. + +(* TODO: déplacer les trucs sur equiv_stackframe dans RTLpath ? *) +Inductive equiv_stackframe: stackframe -> stackframe -> Prop := + | equiv_stackframe_intro res f sp pc rs1 rs2 + (EQUIV: forall r : positive, rs1 !! r = rs2 !! r): + equiv_stackframe (Stackframe res f sp pc rs1) (Stackframe res f sp pc rs2). + +Inductive equiv_state: state -> state -> Prop := + | State_equiv stack f sp pc rs1 m rs2 + (EQUIV: forall r, rs1#r = rs2#r): + equiv_state (State stack f sp pc rs1 m) (State stack f sp pc rs2 m) + | Call_equiv stk stk' f args m + (STACKS: list_forall2 equiv_stackframe stk stk'): + equiv_state (Callstate stk f args m) (Callstate stk' f args m) + | Return_equiv stk stk' v m + (STACKS: list_forall2 equiv_stackframe stk stk'): + equiv_state (Returnstate stk v m) (Returnstate stk' v m). + +Lemma equiv_stackframe_refl stf: equiv_stackframe stf stf. +Proof. + destruct stf. constructor; auto. +Qed. + +Lemma equiv_stack_refl stk: list_forall2 equiv_stackframe stk stk. +Proof. + Local Hint Resolve equiv_stackframe_refl: core. + induction stk; simpl; constructor; auto. +Qed. + +Lemma equiv_state_refl s: equiv_state s s. +Proof. + Local Hint Resolve equiv_stack_refl: core. + induction s; simpl; constructor; auto. +Qed. + +(* +Lemma equiv_stackframe_trans stf1 stf2 stf3: + equiv_stackframe stf1 stf2 -> equiv_stackframe stf2 stf3 -> equiv_stackframe stf1 stf3. +Proof. + destruct 1; intros EQ; inv EQ; try econstructor; eauto. + intros; eapply eq_trans; eauto. +Qed. + +Lemma equiv_stack_trans stk1 stk2: + list_forall2 equiv_stackframe stk1 stk2 -> + forall stk3, list_forall2 equiv_stackframe stk2 stk3 -> + list_forall2 equiv_stackframe stk1 stk3. +Proof. + Local Hint Resolve equiv_stackframe_trans. + induction 1; intros stk3 EQ; inv EQ; econstructor; eauto. +Qed. + +Lemma equiv_state_trans s1 s2 s3: equiv_state s1 s2 -> equiv_state s2 s3 -> equiv_state s1 s3. +Proof. + Local Hint Resolve equiv_stack_trans. + destruct 1; intros EQ; inv EQ; econstructor; eauto. + intros; eapply eq_trans; eauto. +Qed. +*) + +Lemma regmap_setres_eq (rs rs': regset) res vres: + (forall r, rs # r = rs' # r) -> + forall r, (regmap_setres res vres rs) # r = (regmap_setres res vres rs') # r. +Proof. + intros RSEQ r. destruct res; simpl; try congruence. + destruct (peq x r). + - subst. repeat (rewrite Regmap.gss). reflexivity. + - repeat (rewrite Regmap.gso); auto. +Qed. + +Lemma ssem_final_equiv pge ge sp (f:function) st sv stack rs0 m0 t rs1 rs2 m s: + ssem_final pge ge sp st stack f rs0 m0 sv rs1 m t s -> + (forall r, rs1#r = rs2#r) -> + exists s', equiv_state s s' /\ ssem_final pge ge sp st stack f rs0 m0 sv rs2 m t s'. +Proof. + Local Hint Resolve equiv_stack_refl: core. + destruct 1. + - (* Snone *) intros; eexists; econstructor. + + eapply State_equiv; eauto. + + eapply exec_Snone. + - (* Scall *) + intros; eexists; econstructor. + 2: { eapply exec_Scall; eauto. } + apply Call_equiv; auto. + repeat (constructor; auto). + - (* Stailcall *) + intros; eexists; econstructor; [| eapply exec_Stailcall; eauto]. + apply Call_equiv; auto. + - (* Sbuiltin *) + intros; eexists; econstructor; [| eapply exec_Sbuiltin; eauto]. + constructor. eapply regmap_setres_eq; eauto. + - (* Sjumptable *) + intros; eexists; econstructor; [| eapply exec_Sjumptable; eauto]. + constructor. assumption. + - (* Sreturn *) + intros; eexists; econstructor; [| eapply exec_Sreturn; eauto]. + eapply equiv_state_refl; eauto. +Qed. + +Lemma siexec_inst_early_exit_absurd i st st' ge sp rs m rs' m' pc': + siexec_inst i st = Some st' -> + (exists ext lx, ssem_exit ge sp ext rs m rs' m' pc' /\ + all_fallthrough_upto_exit ge sp ext lx (si_exits st) rs m) -> + all_fallthrough ge sp (si_exits st') rs m -> + False. +Proof. + intros SIEXEC (ext & lx & SSEME & ALLFU) ALLF. destruct ALLFU as (TAIL & _). + exploit siexec_inst_add_exits; eauto. destruct 1 as [SIEQ | (ext0 & SIEQ)]. + - rewrite SIEQ in *. eapply all_fallthrough_noexit. eauto. 2: eapply ALLF. eapply is_tail_in. eassumption. + - rewrite SIEQ in *. eapply all_fallthrough_noexit. eauto. 2: eapply ALLF. eapply is_tail_in. + constructor. eassumption. +Qed. + +Lemma is_tail_false {A: Type}: forall (l: list A) a, is_tail (a::l) nil -> False. +Proof. + intros. eapply is_tail_incl in H. unfold incl in H. pose (H a). + assert (In a (a::l)) by (constructor; auto). assert (In a nil) by auto. apply in_nil in H1. + contradiction. +Qed. + +Lemma cons_eq_false {A: Type}: forall (l: list A) a, + a :: l = l -> False. +Proof. + induction l; intros. + - discriminate. + - inv H. apply IHl in H2. contradiction. +Qed. + +Lemma app_cons_nil_eq {A: Type}: forall l' l (a:A), + (l' ++ a :: nil) ++ l = l' ++ a::l. +Proof. + induction l'; intros. + - simpl. reflexivity. + - simpl. rewrite IHl'. reflexivity. +Qed. + +Lemma app_eq_false {A: Type}: forall l (l': list A) a, + l' ++ a :: l = l -> False. +Proof. + induction l; intros. + - apply app_eq_nil in H. destruct H as (_ & H). apply cons_eq_false in H. contradiction. + - destruct l' as [|a' l']. + + simpl in H. apply cons_eq_false in H. contradiction. + + rewrite <- app_comm_cons in H. inv H. + apply (IHl (l' ++ (a0 :: nil)) a). rewrite app_cons_nil_eq. assumption. +Qed. + +Lemma is_tail_false_gen {A: Type}: forall (l: list A) l' a, is_tail (l'++(a::l)) l -> False. +Proof. + induction l. + - intros. destruct l' as [|a' l']. + + simpl in H. apply is_tail_false in H. contradiction. + + rewrite <- app_comm_cons in H. apply is_tail_false in H. contradiction. + - intros. inv H. + + apply app_eq_false in H2. contradiction. + + apply (IHl (l' ++ (a0 :: nil)) a). rewrite app_cons_nil_eq. assumption. +Qed. + +Lemma is_tail_eq {A: Type}: forall (l l': list A), + is_tail l' l -> + is_tail l l' -> + l = l'. +Proof. + destruct l as [|a l]; intros l' ITAIL ITAIL'. + - destruct l' as [|i' l']; auto. apply is_tail_false in ITAIL. contradiction. + - inv ITAIL; auto. + destruct l' as [|i' l']. { apply is_tail_false in ITAIL'. contradiction. } + exploit is_tail_trans. eapply ITAIL'. eauto. intro ABSURD. + apply (is_tail_false_gen l nil a) in ABSURD. contradiction. +Qed. + +(* NB: each execution of a symbolic state (produced from [sexec]) represents a concrete execution + (sexec is exact). +*) +Theorem sexec_exact f pc pge ge sp path stack st rs m t s1: + (fn_path f)!pc = Some path -> + sexec f pc = Some st -> + ssem pge ge sp st stack f rs m t s1 -> + exists s2, path_step ge pge path.(psize) stack f sp rs m pc t s2 /\ + equiv_state s1 s2. +Proof. + Local Hint Resolve init_ssem_internal: core. + unfold sexec; intros PATH SSTEP SEM; rewrite PATH in SSTEP. + lapply (final_node_path_simpl f path pc); eauto. intro WF. + exploit (siexec_path_correct_true ge sp path.(psize) f rs m (init_sistate pc) (mk_istate true pc rs m)); simpl; eauto. + { intros ABS. apply WF; unfold nth_default_succ_inst. rewrite ABS; auto. } + (destruct (nth_default_succ_inst (fn_code f) path.(psize) pc) as [i|] eqn: Hi; [clear WF|congruence]). + unfold nth_default_succ_inst in Hi. + destruct (siexec_path path.(psize) f (init_sistate pc)) as [st0|] eqn: Hst0; simpl. + 2:{ (* absurd case *) + exploit siexec_path_WF; eauto. + simpl; intros NDS; rewrite NDS in Hi; congruence. } + exploit siexec_path_default_succ; eauto; simpl. + intros NDS; rewrite NDS in Hi. + rewrite Hi in SSTEP. + intros ISTEPS. try_simplify_someHyps. + destruct (siexec_inst i st0) as [st'|] eqn:Hst'; simpl. + + (* exit on Snone instruction *) + assert (SEM': t = E0 /\ exists is, ssem_internal ge sp st' rs m is + /\ s1 = (State stack f sp (if (icontinue is) then (si_pc st') else (ipc is)) (irs is) (imem is))). + { destruct SEM as [is CONT SEM|is t s CONT SEM1 SEM2]; simpl in * |- *. + - repeat (econstructor; eauto). + rewrite CONT; eauto. + - inversion SEM2. repeat (econstructor; eauto). + rewrite CONT; eauto. } + clear SEM; subst. destruct SEM' as [X (is & SEM & X')]; subst. + intros. + destruct (isteps ge (psize path) f sp rs m pc) as [is0|] eqn:RISTEPS; simpl in *. + * unfold ssem_internal in ISTEPS. destruct (icontinue is0) eqn: ICONT0. + ** (* icontinue is0=true: path_step by normal_exit *) + destruct ISTEPS as (SEMis0&H1&H2). + rewrite H1 in * |-. + exploit siexec_inst_correct; eauto. + rewrite Hst'; simpl. + intros; exploit ssem_internal_opt_determ; eauto. + destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). + eexists. econstructor 1. + *** eapply exec_normal_exit; eauto. + eapply exec_istate; eauto. + *** rewrite EQ1. + enough ((ipc st) = (if icontinue st then si_pc st' else ipc is)) as ->. + { rewrite EQ2, EQ4. eapply State_equiv; auto. } + destruct (icontinue st) eqn:ICONT; auto. + exploit siexec_inst_default_succ; eauto. + erewrite istep_normal_exit; eauto. + try_simplify_someHyps. + ** (* The concrete execution has not reached "i" => early exit *) + unfold ssem_internal in SEM. + destruct (icontinue is) eqn:ICONT. + { destruct SEM as (SEML & SIPC & ALLF). + exploit siexec_inst_early_exit_absurd; eauto. contradiction. } + + eexists. econstructor 1. + *** eapply exec_early_exit; eauto. + *** destruct ISTEPS as (ext & lx & SSEME & ALLFU). destruct SEM as (ext' & lx' & SSEME' & ALLFU'). + eapply siexec_inst_preserves_allfu in ALLFU; eauto. + exploit ssem_exit_fallthrough_upto_exit; eauto. + exploit ssem_exit_fallthrough_upto_exit. eapply SSEME. eapply ALLFU. eapply ALLFU'. + intros ITAIL ITAIL'. apply is_tail_eq in ITAIL; auto. clear ITAIL'. + inv ITAIL. exploit ssem_exit_determ. eapply SSEME. eapply SSEME'. intros (IPCEQ & IRSEQ & IMEMEQ). + rewrite <- IPCEQ. rewrite <- IMEMEQ. constructor. congruence. + * (* The concrete execution has not reached "i" => abort case *) + eapply siexec_inst_preserves_sabort in ISTEPS; eauto. + exploit ssem_internal_exclude_sabort; eauto. contradiction. + + destruct SEM as [is CONT SEM|is t s CONT SEM1 SEM2]; simpl in * |- *. + - (* early exit *) + intros. + exploit ssem_internal_opt_determ; eauto. + destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). + eexists. econstructor 1. + * eapply exec_early_exit; eauto. + * rewrite EQ2, EQ4; eapply State_equiv. auto. + - (* normal exit non-Snone instruction *) + intros. + exploit ssem_internal_opt_determ; eauto. + destruct 1 as (st & Hst & EQ1 & EQ2 & EQ3 & EQ4). + unfold ssem_internal in SEM1. + rewrite CONT in SEM1. destruct SEM1 as (SEM1 & PC0 & NYE0). + exploit ssem_final_equiv; eauto. + clear SEM2; destruct 1 as (s' & Ms' & SEM2). + rewrite ! EQ4 in * |-; clear EQ4. + rewrite ! EQ2 in * |-; clear EQ2. + exists s'; intuition. + eapply exec_normal_exit; eauto. + eapply sexec_final_complete; eauto. + * congruence. + * unfold ssem_local in * |- *. + destruct SEM1 as (A & B & C). constructor; [|constructor]; eauto. + intro r. congruence. + * congruence. +Qed. + +(** * Simulation of RTLpath code w.r.t symbolic execution *) + +Section SymbValPreserved. + +Variable ge ge': RTL.genv. + +Hypothesis symbols_preserved_RTL: forall s, Genv.find_symbol ge' s = Genv.find_symbol ge s. + +Hypothesis senv_preserved_RTL: Senv.equiv ge ge'. + +Lemma senv_find_symbol_preserved id: + Senv.find_symbol ge id = Senv.find_symbol ge' id. +Proof. + destruct senv_preserved_RTL as (A & B & C). congruence. +Qed. + +Lemma senv_symbol_address_preserved id ofs: + Senv.symbol_address ge id ofs = Senv.symbol_address ge' id ofs. +Proof. + unfold Senv.symbol_address. rewrite senv_find_symbol_preserved. + reflexivity. +Qed. + +Lemma seval_preserved sp sv rs0 m0: + seval_sval ge sp sv rs0 m0 = seval_sval ge' sp sv rs0 m0. +Proof. + Local Hint Resolve symbols_preserved_RTL: core. + induction sv using sval_mut with (P0 := fun lsv => seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv rs0 m0) + (P1 := fun sm => seval_smem ge sp sm rs0 m0 = seval_smem ge' sp sm rs0 m0); simpl; auto. + + rewrite IHsv; clear IHsv. destruct (seval_list_sval _ _ _ _); auto. + rewrite IHsv0; clear IHsv0. destruct (seval_smem _ _ _ _); auto. + erewrite eval_operation_preserved; eauto. + + rewrite IHsv0; clear IHsv0. destruct (seval_list_sval _ _ _ _); auto. + erewrite <- eval_addressing_preserved; eauto. + destruct (eval_addressing _ sp _ _); auto. + rewrite IHsv; auto. + + rewrite IHsv; clear IHsv. destruct (seval_sval _ _ _ _); auto. + rewrite IHsv0; auto. + + rewrite IHsv0; clear IHsv0. destruct (seval_list_sval _ _ _ _); auto. + erewrite <- eval_addressing_preserved; eauto. + destruct (eval_addressing _ sp _ _); auto. + rewrite IHsv; clear IHsv. destruct (seval_smem _ _ _ _); auto. + rewrite IHsv1; auto. +Qed. + +Lemma seval_builtin_arg_preserved sp m rs0 m0: + forall bs varg, + seval_builtin_arg ge sp m rs0 m0 bs varg -> + seval_builtin_arg ge' sp m rs0 m0 bs varg. +Proof. + induction 1. + all: try (constructor; auto). + - rewrite <- seval_preserved. assumption. + - rewrite <- senv_symbol_address_preserved. assumption. + - rewrite senv_symbol_address_preserved. eapply seval_BA_addrglobal. +Qed. + +Lemma seval_builtin_args_preserved sp m rs0 m0 lbs vargs: + seval_builtin_args ge sp m rs0 m0 lbs vargs -> + seval_builtin_args ge' sp m rs0 m0 lbs vargs. +Proof. + induction 1; constructor; eauto. + eapply seval_builtin_arg_preserved; auto. +Qed. + +Lemma list_sval_eval_preserved sp lsv rs0 m0: + seval_list_sval ge sp lsv rs0 m0 = seval_list_sval ge' sp lsv rs0 m0. +Proof. + induction lsv; simpl; auto. + rewrite seval_preserved. destruct (seval_sval _ _ _ _); auto. + rewrite IHlsv; auto. +Qed. + +Lemma smem_eval_preserved sp sm rs0 m0: + seval_smem ge sp sm rs0 m0 = seval_smem ge' sp sm rs0 m0. +Proof. + induction sm; simpl; auto. + rewrite list_sval_eval_preserved. destruct (seval_list_sval _ _ _ _); auto. + erewrite <- eval_addressing_preserved; eauto. + destruct (eval_addressing _ sp _ _); auto. + rewrite IHsm; clear IHsm. destruct (seval_smem _ _ _ _); auto. + rewrite seval_preserved; auto. +Qed. + +Lemma seval_condition_preserved sp cond lsv sm rs0 m0: + seval_condition ge sp cond lsv sm rs0 m0 = seval_condition ge' sp cond lsv sm rs0 m0. +Proof. + unfold seval_condition. + rewrite list_sval_eval_preserved. destruct (seval_list_sval _ _ _ _); auto. + rewrite smem_eval_preserved; auto. +Qed. + +End SymbValPreserved. + +Require Import RTLpathLivegen RTLpathLivegenproof. + +(** * DEFINITION OF SIMULATION BETWEEN (ABSTRACT) SYMBOLIC EXECUTIONS +*) + +Definition istate_simulive alive (srce: PTree.t node) (is1 is2: istate): Prop := + is1.(icontinue) = is2.(icontinue) + /\ eqlive_reg alive is1.(irs) is2.(irs) + /\ is1.(imem) = is2.(imem). + +Definition istate_simu f (srce: PTree.t node) is1 is2: Prop := + if is1.(icontinue) then + (* TODO: il faudra raffiner le (fun _ => True) si on veut autoriser l'oracle à + ajouter du "code mort" sur des registres non utilisés (loop invariant code motion à la David) + Typiquement, pour connaître la frame des registres vivants, il faudra faire une propagation en arrière + sur la dernière instruction du superblock. *) + istate_simulive (fun _ => True) srce is1 is2 + else + exists path, f.(fn_path)!(is1.(ipc)) = Some path + /\ istate_simulive (fun r => Regset.In r path.(input_regs)) srce is1 is2 + /\ srce!(is2.(ipc)) = Some is1.(ipc). + +Record simu_proof_context {f1: RTLpath.function} := { + liveness_hyps: liveness_ok_function f1; + the_ge1: RTL.genv; + the_ge2: RTL.genv; + genv_match: forall s, Genv.find_symbol the_ge1 s = Genv.find_symbol the_ge2 s; + the_sp: val; + the_rs0: regset; + the_m0: mem +}. +Arguments simu_proof_context: clear implicits. + +(* NOTE: a pure semantic definition on [sistate], for a total freedom in refinements *) +Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) (st1 st2: sistate) (ctx: simu_proof_context f): Prop := + forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) st1 (the_rs0 ctx) (the_m0 ctx) is1 -> + exists is2, ssem_internal (the_ge2 ctx) (the_sp ctx) st2 (the_rs0 ctx) (the_m0 ctx) is2 + /\ istate_simu f dm is1 is2. + +Inductive svident_simu (f: RTLpath.function) (ctx: simu_proof_context f): (sval + ident) -> (sval + ident) -> Prop := + | Sleft_simu sv1 sv2: + (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) = (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) + -> svident_simu f ctx (inl sv1) (inl sv2) + | Sright_simu id1 id2: + id1 = id2 + -> svident_simu f ctx (inr id1) (inr id2) + . + + +Fixpoint ptree_get_list (pt: PTree.t node) (lp: list positive) : option (list positive) := + match lp with + | nil => Some nil + | p1::lp => SOME p2 <- pt!p1 IN + SOME lp2 <- (ptree_get_list pt lp) IN + Some (p2 :: lp2) + end. + +Lemma ptree_get_list_nth dm p2: forall lp2 lp1, + ptree_get_list dm lp2 = Some lp1 -> + forall n, list_nth_z lp2 n = Some p2 -> + exists p1, + list_nth_z lp1 n = Some p1 /\ dm ! p2 = Some p1. +Proof. + induction lp2. + - simpl. intros. inv H. simpl in *. discriminate. + - intros lp1 PGL n LNZ. simpl in PGL. explore. + inv LNZ. destruct (zeq n 0) eqn:ZEQ. + + subst. inv H0. exists n0. simpl; constructor; auto. + + exploit IHlp2; eauto. intros (p1 & LNZ & DMEQ). + eexists. simpl. rewrite ZEQ. + constructor; eauto. +Qed. + +Lemma ptree_get_list_nth_rev dm p1: forall lp2 lp1, + ptree_get_list dm lp2 = Some lp1 -> + forall n, list_nth_z lp1 n = Some p1 -> + exists p2, + list_nth_z lp2 n = Some p2 /\ dm ! p2 = Some p1. +Proof. + induction lp2. + - simpl. intros. inv H. simpl in *. discriminate. + - intros lp1 PGL n LNZ. simpl in PGL. explore. + inv LNZ. destruct (zeq n 0) eqn:ZEQ. + + subst. inv H0. exists a. simpl; constructor; auto. + + exploit IHlp2; eauto. intros (p2 & LNZ & DMEQ). + eexists. simpl. rewrite ZEQ. + constructor; eauto. congruence. +Qed. + +Fixpoint seval_builtin_sval ge sp bsv rs0 m0 := + match bsv with + | BA sv => SOME v <- seval_sval ge sp sv rs0 m0 IN Some (BA v) + | BA_splitlong sv1 sv2 => + SOME v1 <- seval_builtin_sval ge sp sv1 rs0 m0 IN + SOME v2 <- seval_builtin_sval ge sp sv2 rs0 m0 IN + Some (BA_splitlong v1 v2) + | BA_addptr sv1 sv2 => + SOME v1 <- seval_builtin_sval ge sp sv1 rs0 m0 IN + SOME v2 <- seval_builtin_sval ge sp sv2 rs0 m0 IN + Some (BA_addptr v1 v2) + | BA_int i => Some (BA_int i) + | BA_long l => Some (BA_long l) + | BA_float f => Some (BA_float f) + | BA_single s => Some (BA_single s) + | BA_loadstack chk ptr => Some (BA_loadstack chk ptr) + | BA_addrstack ptr => Some (BA_addrstack ptr) + | BA_loadglobal chk id ptr => Some (BA_loadglobal chk id ptr) + | BA_addrglobal id ptr => Some (BA_addrglobal id ptr) + end. + + +Fixpoint seval_list_builtin_sval ge sp lbsv rs0 m0 := + match lbsv with + | nil => Some nil + | bsv::lbsv => SOME v <- seval_builtin_sval ge sp bsv rs0 m0 IN + SOME lv <- seval_list_builtin_sval ge sp lbsv rs0 m0 IN + Some (v::lv) + end. + +Lemma seval_list_builtin_sval_nil ge sp rs0 m0 lbs2: + seval_list_builtin_sval ge sp lbs2 rs0 m0 = Some nil -> + lbs2 = nil. +Proof. + destruct lbs2; simpl; auto. + intros. destruct (seval_builtin_sval _ _ _ _ _); + try destruct (seval_list_builtin_sval _ _ _ _ _); discriminate. +Qed. + +Lemma seval_builtin_sval_arg (ge:RTL.genv) sp rs0 m0 bs: + forall ba m v, + seval_builtin_sval ge sp bs rs0 m0 = Some ba -> + eval_builtin_arg ge (fun id => id) sp m ba v -> + seval_builtin_arg ge sp m rs0 m0 bs v. +Proof. + induction bs; simpl; + try (intros ba m v H; inversion H; subst; clear H; + intros H; inversion H; subst; + econstructor; auto; fail). + - intros ba m v; destruct (seval_sval _ _ _ _ _) eqn: SV; + intros H; inversion H; subst; clear H. + intros H; inversion H; subst. + econstructor; auto. + - intros ba m v. + destruct (seval_builtin_sval _ _ bs1 _ _) eqn: SV1; try congruence. + destruct (seval_builtin_sval _ _ bs2 _ _) eqn: SV2; try congruence. + intros H; inversion H; subst; clear H. + intros H; inversion H; subst. + econstructor; eauto. + - intros ba m v. + destruct (seval_builtin_sval _ _ bs1 _ _) eqn: SV1; try congruence. + destruct (seval_builtin_sval _ _ bs2 _ _) eqn: SV2; try congruence. + intros H; inversion H; subst; clear H. + intros H; inversion H; subst. + econstructor; eauto. +Qed. + +Lemma seval_builtin_arg_sval ge sp m rs0 m0 v: forall bs, + seval_builtin_arg ge sp m rs0 m0 bs v -> + exists ba, + seval_builtin_sval ge sp bs rs0 m0 = Some ba + /\ eval_builtin_arg ge (fun id => id) sp m ba v. +Proof. + induction 1. + all: try (eexists; constructor; [simpl; reflexivity | constructor]). + 2-3: try assumption. + - eexists. constructor. + + simpl. rewrite H. reflexivity. + + constructor. + - destruct IHseval_builtin_arg1 as (ba1 & A1 & B1). + destruct IHseval_builtin_arg2 as (ba2 & A2 & B2). + eexists. constructor. + + simpl. rewrite A1. rewrite A2. reflexivity. + + constructor; assumption. + - destruct IHseval_builtin_arg1 as (ba1 & A1 & B1). + destruct IHseval_builtin_arg2 as (ba2 & A2 & B2). + eexists. constructor. + + simpl. rewrite A1. rewrite A2. reflexivity. + + constructor; assumption. +Qed. + +Lemma seval_builtin_sval_args (ge:RTL.genv) sp rs0 m0 lbs: + forall lba m v, + seval_list_builtin_sval ge sp lbs rs0 m0 = Some lba -> + list_forall2 (eval_builtin_arg ge (fun id => id) sp m) lba v -> + seval_builtin_args ge sp m rs0 m0 lbs v. +Proof. + unfold seval_builtin_args; induction lbs; simpl; intros lba m v. + - intros H; inversion H; subst; clear H. + intros H; inversion H. econstructor. + - destruct (seval_builtin_sval _ _ _ _ _) eqn:SV; try congruence. + destruct (seval_list_builtin_sval _ _ _ _ _) eqn: SVL; try congruence. + intros H; inversion H; subst; clear H. + intros H; inversion H; subst; clear H. + econstructor; eauto. + eapply seval_builtin_sval_arg; eauto. +Qed. + +Lemma seval_builtin_args_sval ge sp m rs0 m0 lv: forall lbs, + seval_builtin_args ge sp m rs0 m0 lbs lv -> + exists lba, + seval_list_builtin_sval ge sp lbs rs0 m0 = Some lba + /\ list_forall2 (eval_builtin_arg ge (fun id => id) sp m) lba lv. +Proof. + induction 1. + - eexists. constructor. + + simpl. reflexivity. + + constructor. + - destruct IHlist_forall2 as (lba & A & B). + apply seval_builtin_arg_sval in H. destruct H as (ba & A' & B'). + eexists. constructor. + + simpl. rewrite A'. rewrite A. reflexivity. + + constructor; assumption. +Qed. + +Lemma seval_builtin_sval_correct ge sp m rs0 m0: forall bs1 v bs2, + seval_builtin_arg ge sp m rs0 m0 bs1 v -> + (seval_builtin_sval ge sp bs1 rs0 m0) = (seval_builtin_sval ge sp bs2 rs0 m0) -> + seval_builtin_arg ge sp m rs0 m0 bs2 v. +Proof. + intros. exploit seval_builtin_arg_sval; eauto. + intros (ba & X1 & X2). + eapply seval_builtin_sval_arg; eauto. + congruence. +Qed. + +Lemma seval_list_builtin_sval_correct ge sp m rs0 m0 vargs: forall lbs1, + seval_builtin_args ge sp m rs0 m0 lbs1 vargs -> + forall lbs2, (seval_list_builtin_sval ge sp lbs1 rs0 m0) = (seval_list_builtin_sval ge sp lbs2 rs0 m0) -> + seval_builtin_args ge sp m rs0 m0 lbs2 vargs. +Proof. + intros. exploit seval_builtin_args_sval; eauto. + intros (ba & X1 & X2). + eapply seval_builtin_sval_args; eauto. + congruence. +Qed. + +(* NOTE: we need to mix semantical simulation and syntactic definition on [sfval] in order to abstract the [match_states] *) +Inductive sfval_simu (dm: PTree.t node) (f: RTLpath.function) (opc1 opc2: node) (ctx: simu_proof_context f): sfval -> sfval -> Prop := + | Snone_simu: + dm!opc2 = Some opc1 -> + sfval_simu dm f opc1 opc2 ctx Snone Snone + | Scall_simu sig svos1 svos2 lsv1 lsv2 res pc1 pc2: + dm!pc2 = Some pc1 -> + svident_simu f ctx svos1 svos2 -> + (seval_list_sval (the_ge1 ctx) (the_sp ctx) lsv1 (the_rs0 ctx) (the_m0 ctx)) + = (seval_list_sval (the_ge2 ctx) (the_sp ctx) lsv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Scall sig svos1 lsv1 res pc1) (Scall sig svos2 lsv2 res pc2) + | Stailcall_simu sig svos1 svos2 lsv1 lsv2: + svident_simu f ctx svos1 svos2 -> + (seval_list_sval (the_ge1 ctx) (the_sp ctx) lsv1 (the_rs0 ctx) (the_m0 ctx)) + = (seval_list_sval (the_ge2 ctx) (the_sp ctx) lsv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Stailcall sig svos1 lsv1) (Stailcall sig svos2 lsv2) + | Sbuiltin_simu ef lbs1 lbs2 br pc1 pc2: + dm!pc2 = Some pc1 -> + (seval_list_builtin_sval (the_ge1 ctx) (the_sp ctx) lbs1 (the_rs0 ctx) (the_m0 ctx)) + = (seval_list_builtin_sval (the_ge2 ctx) (the_sp ctx) lbs2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Sbuiltin ef lbs1 br pc1) (Sbuiltin ef lbs2 br pc2) + | Sjumptable_simu sv1 sv2 lpc1 lpc2: + ptree_get_list dm lpc2 = Some lpc1 -> + (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) + = (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Sjumptable sv1 lpc1) (Sjumptable sv2 lpc2) + | Sreturn_simu_none: sfval_simu dm f opc1 opc2 ctx (Sreturn None) (Sreturn None) + | Sreturn_simu_some sv1 sv2: + (seval_sval (the_ge1 ctx) (the_sp ctx) sv1 (the_rs0 ctx) (the_m0 ctx)) + = (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) -> + sfval_simu dm f opc1 opc2 ctx (Sreturn (Some sv1)) (Sreturn (Some sv2)). + +Definition sstate_simu dm f (s1 s2: sstate) (ctx: simu_proof_context f): Prop := + sistate_simu dm f s1.(internal) s2.(internal) ctx + /\ forall is1, + ssem_internal (the_ge1 ctx) (the_sp ctx) s1 (the_rs0 ctx) (the_m0 ctx) is1 -> + is1.(icontinue) = true -> + sfval_simu dm f s1.(si_pc) s2.(si_pc) ctx s1.(final) s2.(final). + +Definition sexec_simu dm (f1 f2: RTLpath.function) pc1 pc2: Prop := + forall st1, sexec f1 pc1 = Some st1 -> + exists st2, sexec f2 pc2 = Some st2 /\ forall ctx, sstate_simu dm f1 st1 st2 ctx. diff --git a/scheduling/RTLpathScheduler.v b/scheduling/RTLpathScheduler.v new file mode 100644 index 00000000..beab405f --- /dev/null +++ b/scheduling/RTLpathScheduler.v @@ -0,0 +1,330 @@ +(** RTLpath Scheduling from an external oracle. + +This module is inspired from [Duplicate] and [Duplicateproof] + +*) + +Require Import AST Linking Values Maps Globalenvs Smallstep Registers. +Require Import Coqlib Maps Events Errors Op. +Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory RTLpathSE_impl. + + +Notation "'ASSERT' A 'WITH' MSG 'IN' B" := (if A then B else Error (msg MSG)) + (at level 200, A at level 100, B at level 200) + : error_monad_scope. + +Local Open Scope error_monad_scope. +Local Open Scope positive_scope. + +(** External oracle returning the new RTLpath function and a mapping of new path_entries to old path_entries + +NB: the new RTLpath function is generated from the fn_code, the fn_entrypoint and the fn_path +It requires to check that the path structure is wf ! + +*) + +(* Returns: new code, new entrypoint, new pathmap, revmap + * Indeed, the entrypoint might not be the same if the entrypoint node is moved further down + * a path ; same reasoning for the pathmap *) +Axiom untrusted_scheduler: RTLpath.function -> code * node * path_map * (PTree.t node). + +Extract Constant untrusted_scheduler => "RTLpathScheduleraux.scheduler". + +Program Definition function_builder (tfr: RTL.function) (tpm: path_map) : + { r : res RTLpath.function | forall f', r = OK f' -> fn_RTL f' = tfr} := + match RTLpathLivegen.function_checker tfr tpm with + | false => Error (msg "In function_builder: (tfr, tpm) is not wellformed") + | true => OK {| fn_RTL := tfr; fn_path := tpm |} + end. +Next Obligation. + apply function_checker_path_entry. auto. +Defined. Next Obligation. + apply function_checker_wellformed_path_map. auto. +Defined. + +Definition entrypoint_check (dm: PTree.t node) (fr tfr: RTL.function) : res unit := + match dm ! (fn_entrypoint tfr) with + | None => Error (msg "No mapping for (entrypoint tfr)") + | Some etp => if (Pos.eq_dec (fn_entrypoint fr) etp) then OK tt + else Error (msg "Entrypoints do not match") + end. + +Lemma entrypoint_check_correct fr tfr dm: + entrypoint_check dm fr tfr = OK tt -> + dm ! (fn_entrypoint tfr) = Some (fn_entrypoint fr). +Proof. + unfold entrypoint_check. explore; try discriminate. congruence. +Qed. + +Definition path_entry_check_single (pm tpm: path_map) (m: node * node) := + let (pc2, pc1) := m in + match (tpm ! pc2) with + | None => Error (msg "pc2 isn't an entry of tpm") + | Some _ => + match (pm ! pc1) with + | None => Error (msg "pc1 isn't an entry of pm") + | Some _ => OK tt + end + end. + +Lemma path_entry_check_single_correct pm tpm pc1 pc2: + path_entry_check_single pm tpm (pc2, pc1) = OK tt -> + path_entry tpm pc2 /\ path_entry pm pc1. +Proof. + unfold path_entry_check_single. intro. explore. + constructor; congruence. +Qed. + +(* Inspired from Duplicate.verify_mapping_rec *) +Fixpoint path_entry_check_rec (pm tpm: path_map) lm := + match lm with + | nil => OK tt + | m :: lm => do u1 <- path_entry_check_single pm tpm m; + do u2 <- path_entry_check_rec pm tpm lm; + OK tt + end. + +Lemma path_entry_check_rec_correct pm tpm pc1 pc2: forall lm, + path_entry_check_rec pm tpm lm = OK tt -> + In (pc2, pc1) lm -> + path_entry tpm pc2 /\ path_entry pm pc1. +Proof. + induction lm. + - simpl. intuition. + - simpl. intros. explore. destruct H0. + + subst. eapply path_entry_check_single_correct; eauto. + + eapply IHlm; assumption. +Qed. + +Definition path_entry_check (dm: PTree.t node) (pm tpm: path_map) := path_entry_check_rec pm tpm (PTree.elements dm). + +Lemma path_entry_check_correct dm pm tpm: + path_entry_check dm pm tpm = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + path_entry tpm pc2 /\ path_entry pm pc1. +Proof. + unfold path_entry_check. intros. eapply PTree.elements_correct in H0. + eapply path_entry_check_rec_correct; eassumption. +Qed. + +Definition function_equiv_checker (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) : res unit := + let pm := fn_path f in + let fr := fn_RTL f in + let tpm := fn_path tf in + let tfr := fn_RTL tf in + do _ <- entrypoint_check dm fr tfr; + do _ <- path_entry_check dm pm tpm; + do _ <- simu_check dm f tf; + OK tt. + +Lemma function_equiv_checker_entrypoint f tf dm: + function_equiv_checker dm f tf = OK tt -> + dm ! (fn_entrypoint tf) = Some (fn_entrypoint f). +Proof. + unfold function_equiv_checker. intros. explore. + eapply entrypoint_check_correct; eauto. +Qed. + +Lemma function_equiv_checker_pathentry1 f tf dm: + function_equiv_checker dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + path_entry (fn_path tf) pc2. +Proof. + unfold function_equiv_checker. intros. explore. + exploit path_entry_check_correct. eassumption. all: eauto. intuition. +Qed. + +Lemma function_equiv_checker_pathentry2 f tf dm: + function_equiv_checker dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + path_entry (fn_path f) pc1. +Proof. + unfold function_equiv_checker. intros. explore. + exploit path_entry_check_correct. eassumption. all: eauto. intuition. +Qed. + +Lemma function_equiv_checker_correct f tf dm: + function_equiv_checker dm f tf = OK tt -> + forall pc1 pc2, dm ! pc2 = Some pc1 -> + sexec_simu dm f tf pc1 pc2. +Proof. + unfold function_equiv_checker. intros. explore. + eapply simu_check_correct; eauto. +Qed. + +Definition verified_scheduler (f: RTLpath.function) : res (RTLpath.function * (PTree.t node)) := + let (tctetpm, dm) := untrusted_scheduler f in + let (tcte, tpm) := tctetpm in + let (tc, te) := tcte in + let tfr := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in + do tf <- proj1_sig (function_builder tfr tpm); + do tt <- function_equiv_checker dm f tf; + OK (tf, dm). + +Theorem verified_scheduler_correct f tf dm: + verified_scheduler f = OK (tf, dm) -> + fn_sig f = fn_sig tf + /\ fn_params f = fn_params tf + /\ fn_stacksize f = fn_stacksize tf + /\ dm ! (fn_entrypoint tf) = Some (fn_entrypoint f) + /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> path_entry (fn_path f) pc1) + /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> path_entry (fn_path tf) pc2) + /\ (forall pc1 pc2, dm ! pc2 = Some pc1 -> sexec_simu dm f tf pc1 pc2) +. +Proof. + intros VERIF. unfold verified_scheduler in VERIF. explore. + Local Hint Resolve function_equiv_checker_entrypoint + function_equiv_checker_pathentry1 function_equiv_checker_pathentry2 + function_equiv_checker_correct: core. + destruct (function_builder _ _) as [res H]; simpl in * |- *; auto. + apply H in EQ2. rewrite EQ2. simpl. + repeat (constructor; eauto). + - exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. +Qed. + +Record match_function (dupmap: PTree.t node) (f1 f2: RTLpath.function): Prop := { + preserv_fnsig: fn_sig f1 = fn_sig f2; + preserv_fnparams: fn_params f1 = fn_params f2; + preserv_fnstacksize: fn_stacksize f1 = fn_stacksize f2; + preserv_entrypoint: dupmap!(f2.(fn_entrypoint)) = Some f1.(fn_entrypoint); + dupmap_path_entry1: forall pc1 pc2, dupmap!pc2 = Some pc1 -> path_entry (fn_path f1) pc1; + dupmap_path_entry2: forall pc1 pc2, dupmap!pc2 = Some pc1 -> path_entry (fn_path f2) pc2; + dupmap_correct: forall pc1 pc2, dupmap!pc2 = Some pc1 -> sexec_simu dupmap f1 f2 pc1 pc2; +}. + +Program Definition transf_function (f: RTLpath.function): + { r : res RTLpath.function | forall f', r = OK f' -> exists dm, match_function dm f f'} := + match (verified_scheduler f) with + | Error e => Error e + | OK (tf, dm) => OK tf + end. +Next Obligation. + exploit verified_scheduler_correct; eauto. + intros (A & B & C & D & E & F & G (* & H *)). + exists dm. econstructor; eauto. +Defined. + +Theorem match_function_preserves f f' dm: + match_function dm f f' -> + fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'. +Proof. + intros. + destruct H as [SIG PARAM SIZE ENTRY CORRECT]. + intuition. +Qed. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef (fun f => proj1_sig (transf_function f)) f. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. + +(** * Preservation proof *) + +Local Notation ext alive := (fun r => Regset.In r alive). + +Inductive match_fundef: RTLpath.fundef -> RTLpath.fundef -> Prop := + | match_Internal dupmap f f': match_function dupmap f f' -> match_fundef (Internal f) (Internal f') + | match_External ef: match_fundef (External ef) (External ef). + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + | match_stackframe_intro dupmap res f sp pc rs1 rs2 f' pc' path + (TRANSF: match_function dupmap f f') + (DUPLIC: dupmap!pc' = Some pc) + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: forall v, eqlive_reg (ext path.(input_regs)) (rs1 # res <- v) (rs2 # res <- v)): + match_stackframes (Stackframe res f sp pc rs1) (Stackframe res f' sp pc' rs2). + +Inductive match_states: state -> state -> Prop := + | match_states_intro dupmap st f sp pc rs1 rs2 m st' f' pc' path + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: match_function dupmap f f') + (DUPLIC: dupmap!pc' = Some pc) + (LIVE: liveness_ok_function f) + (PATH: f.(fn_path)!pc = Some path) + (EQUIV: eqlive_reg (ext path.(input_regs)) rs1 rs2): + match_states (State st f sp pc rs1 m) (State st' f' sp pc' rs2 m) + | match_states_call st st' f f' args m + (STACKS: list_forall2 match_stackframes st st') + (TRANSF: match_fundef f f') + (LIVE: liveness_ok_fundef f): + match_states (Callstate st f args m) (Callstate st' f' args m) + | match_states_return st st' v m + (STACKS: list_forall2 match_stackframes st st'): + match_states (Returnstate st v m) (Returnstate st' v m). + +Lemma match_stackframes_equiv stf1 stf2 stf3: + match_stackframes stf1 stf2 -> equiv_stackframe stf2 stf3 -> match_stackframes stf1 stf3. +Proof. + destruct 1; intros EQ; inv EQ; try econstructor; eauto. + intros; eapply eqlive_reg_trans; eauto. + rewrite eqlive_reg_triv in * |-. + eapply eqlive_reg_update. + eapply eqlive_reg_monotonic; eauto. + simpl; auto. +Qed. + +Lemma match_stack_equiv stk1 stk2: + list_forall2 match_stackframes stk1 stk2 -> + forall stk3, list_forall2 equiv_stackframe stk2 stk3 -> + list_forall2 match_stackframes stk1 stk3. +Proof. + Local Hint Resolve match_stackframes_equiv: core. + induction 1; intros stk3 EQ; inv EQ; econstructor; eauto. +Qed. + +Lemma match_states_equiv s1 s2 s3: match_states s1 s2 -> equiv_state s2 s3 -> match_states s1 s3. +Proof. + Local Hint Resolve match_stack_equiv: core. + destruct 1; intros EQ; inv EQ; econstructor; eauto. + intros; eapply eqlive_reg_triv_trans; eauto. +Qed. + +Lemma eqlive_match_stackframes stf1 stf2 stf3: + eqlive_stackframes stf1 stf2 -> match_stackframes stf2 stf3 -> match_stackframes stf1 stf3. +Proof. + destruct 1; intros MS; inv MS; try econstructor; eauto. + try_simplify_someHyps. intros; eapply eqlive_reg_trans; eauto. +Qed. + +Lemma eqlive_match_stack stk1 stk2: + list_forall2 eqlive_stackframes stk1 stk2 -> + forall stk3, list_forall2 match_stackframes stk2 stk3 -> + list_forall2 match_stackframes stk1 stk3. +Proof. + induction 1; intros stk3 MS; inv MS; econstructor; eauto. + eapply eqlive_match_stackframes; eauto. +Qed. + +Lemma eqlive_match_states s1 s2 s3: eqlive_states s1 s2 -> match_states s2 s3 -> match_states s1 s3. +Proof. + Local Hint Resolve eqlive_match_stack: core. + destruct 1; intros MS; inv MS; try_simplify_someHyps; econstructor; eauto. + eapply eqlive_reg_trans; eauto. +Qed. + +Lemma eqlive_stackframes_refl stf1 stf2: match_stackframes stf1 stf2 -> eqlive_stackframes stf1 stf1. +Proof. + destruct 1; econstructor; eauto. + intros; eapply eqlive_reg_refl; eauto. +Qed. + +Lemma eqlive_stacks_refl stk1 stk2: + list_forall2 match_stackframes stk1 stk2 -> list_forall2 eqlive_stackframes stk1 stk1. +Proof. + induction 1; simpl; econstructor; eauto. + eapply eqlive_stackframes_refl; eauto. +Qed. + +Lemma transf_fundef_correct f f': + transf_fundef f = OK f' -> match_fundef f f'. +Proof. + intros TRANSF; destruct f; simpl; monadInv TRANSF. + + destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. + eapply match_Internal; eauto. + + eapply match_External. +Qed. + diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml new file mode 100644 index 00000000..a294d0b5 --- /dev/null +++ b/scheduling/RTLpathScheduleraux.ml @@ -0,0 +1,331 @@ +open RTLpath +open RTL +open Maps +open RTLpathLivegenaux +open Registers +open Camlcoq +open Machine +open DebugPrint + +let config = Machine.config + +type superblock = { + instructions: P.t array; (* pointers to code instructions *) + (* each predicted Pcb has its attached liveins *) + (* This is indexed by the pc value *) + liveins: Regset.t PTree.t; + (* Union of the input_regs of the last successors *) + output_regs: Regset.t; + typing: RTLtyping.regenv +} + +let print_superblock sb code = + let insts = sb.instructions in + let li = sb.liveins in + let outs = sb.output_regs in + begin + debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n"; + debug " liveins = "; print_ptree_regset li; debug "\n"; + debug " output_regs = "; print_regset outs; debug "}" + end + +let print_superblocks lsb code = + let rec f = function + | [] -> () + | sb :: lsb -> (print_superblock sb code; debug ",\n"; f lsb) + in begin + debug "[\n"; + f lsb; + debug "]" + end + +let get_superblocks code entry pm typing = + let visited = ref (PTree.map (fun n i -> false) code) in + let rec get_superblocks_rec pc = + let liveins = ref (PTree.empty) in + let rec follow pc n = + let inst = get_some @@ PTree.get pc code in + if (n == 0) then begin + (match (non_predicted_successors inst) with + | [pcout] -> + let live = (get_some @@ PTree.get pcout pm).input_regs in + liveins := PTree.set pc live !liveins + | _ -> ()); + ([pc], successors_inst inst) + end else + let nexts_from_exit = match (non_predicted_successors inst) with + | [pcout] -> + let live = (get_some @@ PTree.get pcout pm).input_regs in begin + liveins := PTree.set pc live !liveins; + [pcout] + end + | [] -> [] + | _ -> failwith "Having more than one non_predicted_successor is not handled" + in match (predicted_successor inst) with + | None -> failwith "Incorrect path" + | Some succ -> + let (insts, nexts) = follow succ (n-1) in (pc :: insts, nexts_from_exit @ nexts) + in if (get_some @@ PTree.get pc !visited) then [] + else begin + visited := PTree.set pc true !visited; + let pi = get_some @@ PTree.get pc pm in + let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in + let superblock = { instructions = Array.of_list insts; liveins = !liveins; + output_regs = pi.output_regs; typing = typing } in + superblock :: (List.concat @@ List.map get_superblocks_rec nexts) + end + in let lsb = get_superblocks_rec entry in begin + (* debug_flag := true; *) + debug "Superblocks identified:"; print_superblocks lsb code; debug "\n"; + (* debug_flag := false; *) + lsb +end + +(* TODO David *) +let schedule_superblock sb code = + if not !Clflags.option_fprepass + then sb.instructions + else + (* let old_flag = !debug_flag in + debug_flag := true; + print_endline "ORIGINAL SUPERBLOCK"; + print_superblock sb code; + debug_flag := old_flag; *) + let nr_instr = Array.length sb.instructions in + let trailer_length = + match PTree.get (sb.instructions.(nr_instr-1)) code with + | None -> 0 + | Some ii -> + match predicted_successor ii with + | Some _ -> 0 + | None -> 1 in + match PrepassSchedulingOracle.schedule_sequence + (Array.map (fun i -> + (match PTree.get i code with + | Some ii -> ii + | None -> failwith "RTLpathScheduleraux.schedule_superblock"), + (match PTree.get i sb.liveins with + | Some s -> s + | None -> Regset.empty)) + (Array.sub sb.instructions 0 (nr_instr-trailer_length))) with + | None -> sb.instructions + | Some order -> + let ins' = + Array.append + (Array.map (fun i -> sb.instructions.(i)) order) + (Array.sub sb.instructions (nr_instr-trailer_length) trailer_length) in + (* Printf.printf "REORDERED SUPERBLOCK %d\n" (Array.length ins'); + debug_flag := true; + print_instructions (Array.to_list ins') code; + debug_flag := old_flag; + flush stdout; *) + assert ((Array.length sb.instructions) = (Array.length ins')); + (*sb.instructions; *) + ins';; + + (* stub2: reverse function *) + (* + let reversed = Array.of_list @@ List.rev @@ Array.to_list (sb.instructions) in + let tmp = reversed.(0) in + let last_index = Array.length reversed - 1 in + begin + reversed.(0) <- reversed.(last_index); + reversed.(last_index) <- tmp; + reversed + end *) + (* stub: identity function *) + +(** + * Perform basic checks on the new order : + * - must have the same length as the old order + * - non basic instructions (call, tailcall, return, jumptable, non predicted CB) must not move + *) +let check_order code old_order new_order = begin + assert ((Array.length old_order) == (Array.length new_order)); + let length = Array.length new_order in + if length > 0 then + let last_inst = Array.get old_order (length - 1) in + let instr = get_some @@ PTree.get last_inst code in + match predicted_successor instr with + | None -> + if (last_inst != Array.get new_order (length - 1)) then + failwith "The last instruction of the superblock is not basic, but was moved" + | _ -> () +end + +type sinst = + (* Each middle instruction has a direct successor *) + (* A Smid can be the last instruction of a superblock, but a Send cannot be moved *) + | Smid of RTL.instruction * node + | Send of RTL.instruction + +let rinst_to_sinst inst = + match inst with + | Inop n -> Smid(inst, n) + | Iop (_,_,_,n) -> Smid(inst, n) + | Iload (_,_,_,_,_,n) -> Smid(inst, n) + | Istore (_,_,_,_,n) -> Smid(inst, n) + | Icond (_,_,n1,n2,p) -> ( + match p with + | Some true -> Smid(inst, n1) + | Some false -> Smid(inst, n2) + | None -> Send(inst) + ) + | Icall _ | Ibuiltin _ | Ijumptable _ | Itailcall _ | Ireturn _ -> Send(inst) + +let change_predicted_successor s = function + | Smid(i, n) -> Smid(i, s) + | Send _ -> failwith "Called change_predicted_successor on Send. Are you trying to move a non-basic instruction in the middle of the block?" + +(* Forwards the successor changes into an RTL instruction *) +let sinst_to_rinst = function + | Smid(inst, s) -> ( + match inst with + | Inop n -> Inop s + | Iop (a,b,c,n) -> Iop (a,b,c,s) + | Iload (a,b,c,d,e,n) -> Iload (a,b,c,d,e,s) + | Istore (a,b,c,d,n) -> Istore (a,b,c,d,s) + | Icond (a,b,n1,n2,p) -> ( + match p with + | Some true -> Icond(a, b, s, n2, p) + | Some false -> Icond(a, b, n1, s, p) + | None -> failwith "Non predicted Icond as a middle instruction!" + ) + | _ -> failwith "That instruction shouldn't be a middle instruction" + ) + | Send i -> i + +let is_a_cb = function Icond _ -> true | _ -> false +let is_a_load = function Iload _ -> true | _ -> false + +let find_array arr n = + let index = ref None in + begin + Array.iteri (fun i n' -> + if n = n' then + match !index with + | Some _ -> failwith "More than one element present" + | None -> index := Some i + ) arr; + !index + end + +let rec hashedset_from_list = function + | [] -> HashedSet.PSet.empty + | n::ln -> HashedSet.PSet.add n (hashedset_from_list ln) + +let hashedset_map f hs = hashedset_from_list @@ List.map f @@ HashedSet.PSet.elements hs + +let apply_schedule code sb new_order = + let tc = ref code in + let old_order = sb.instructions in + let count_cbs order code = + let current_cbs = ref HashedSet.PSet.empty in + let cbs_above = ref PTree.empty in + Array.iter (fun n -> + let inst = get_some @@ PTree.get n code in + if is_a_cb inst then current_cbs := HashedSet.PSet.add n !current_cbs + else if is_a_load inst then cbs_above := PTree.set n !current_cbs !cbs_above + ) order; + !cbs_above + in let fmap n = + let index = get_some @@ find_array new_order n in + old_order.(index) + in begin + check_order code old_order new_order; + (* First pass - modify the positions, nothing else *) + Array.iteri (fun i n' -> + let inst' = get_some @@ PTree.get n' code in + let iend = Array.length old_order - 1 in + let new_inst = + if (i == iend) then + let final_inst_node = Array.get old_order iend in + let sinst' = rinst_to_sinst inst' in + match sinst' with + (* The below assert fails if a Send is in the middle of the original superblock *) + | Send i -> (assert (final_inst_node == n'); i) + | Smid _ -> + let final_inst = get_some @@ PTree.get final_inst_node code in + match rinst_to_sinst final_inst with + | Smid (_, s') -> sinst_to_rinst @@ change_predicted_successor s' sinst' + | Send _ -> assert(false) (* should have failed earlier *) + else + sinst_to_rinst + (* this will fail if the moved instruction is a Send *) + @@ change_predicted_successor (Array.get old_order (i+1)) + @@ rinst_to_sinst inst' + in tc := PTree.set (Array.get old_order i) new_inst !tc + ) new_order; + (* Second pass - turn the loads back into trapping when it was not needed *) + (* 1) We remember which CBs are "above" a given load *) + let cbs_above = count_cbs old_order code in + (* 2) We do the same for new_order *) + let cbs_above' = count_cbs (Array.map fmap new_order) !tc in + (* 3) We examine each load, turn it back into trapping if cbs_above is included in cbs_above' *) + Array.iter (fun n -> + let n' = fmap n in + let inst' = get_some @@ PTree.get n' !tc in + match inst' with + | Iload (t,a,b,c,d,s) -> + let pset = hashedset_map fmap @@ get_some @@ PTree.get n cbs_above in + let pset' = get_some @@ PTree.get n' cbs_above' in + if HashedSet.PSet.is_subset pset pset' then tc := PTree.set n' (Iload (AST.TRAP,a,b,c,d,s)) !tc + else assert !config.has_non_trapping_loads + | _ -> () + ) old_order; + !tc + end + +let turn_all_loads_nontrap sb code = + if not !config.has_non_trapping_loads then code + else begin + let code' = ref code in + Array.iter (fun n -> + let inst = get_some @@ PTree.get n code in + match inst with + | Iload (t,a,b,c,d,s) -> code' := PTree.set n (Iload (AST.NOTRAP,a,b,c,d,s)) !code' + | _ -> () + ) sb.instructions; + !code' + end + +let rec do_schedule code = function + | [] -> code + | sb :: lsb -> + (* Trick: instead of turning loads into non trap as needed.. + * First, we turn them all into non-trap. + * Then, we turn back those who didn't need to be turned, into TRAP again + * This is because the scheduler (rightfully) refuses to schedule ahead of a branch + * operations that might trap *) + let code' = turn_all_loads_nontrap sb code in + let schedule = schedule_superblock sb code' in + let new_code = apply_schedule code' sb schedule in + begin + (* debug_flag := true; *) + debug "Old Code: "; print_code code; + debug "\nSchedule to apply: "; print_arrayp schedule; + debug "\nNew Code: "; print_code new_code; + debug "\n"; + (* debug_flag := false; *) + do_schedule new_code lsb + end + +let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK" + +let scheduler f = + let code = f.fn_RTL.fn_code in + let id_ptree = PTree.map (fun n i -> n) (f.fn_path) in + let entry = f.fn_RTL.fn_entrypoint in + let pm = f.fn_path in + let typing = get_ok @@ RTLtyping.type_function f.fn_RTL in + let lsb = get_superblocks code entry pm typing in + begin + (* debug_flag := true; *) + debug "Pathmap:\n"; debug "\n"; + print_path_map pm; + debug "Superblocks:\n"; + print_superblocks lsb code; debug "\n"; + (* debug_flag := false; *) + let tc = do_schedule code lsb in + (((tc, entry), pm), id_ptree) + end diff --git a/scheduling/RTLpathSchedulerproof.v b/scheduling/RTLpathSchedulerproof.v new file mode 100644 index 00000000..4ba197b0 --- /dev/null +++ b/scheduling/RTLpathSchedulerproof.v @@ -0,0 +1,363 @@ +Require Import AST Linking Values Maps Globalenvs Smallstep Registers. +Require Import Coqlib Maps Events Errors Op. +Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory. +Require Import RTLpathScheduler. + +Definition match_prog (p tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: program. +Variable tprog: program. + +Hypothesis TRANSL: match_prog prog tprog. + +Let pge := Genv.globalenv prog. +Let tpge := Genv.globalenv tprog. + +Hypothesis all_fundef_liveness_ok: forall b fd, Genv.find_funct_ptr pge b = Some fd -> liveness_ok_fundef fd. + +Lemma symbols_preserved s: Genv.find_symbol tpge s = Genv.find_symbol pge s. +Proof. + rewrite <- (Genv.find_symbol_match TRANSL). reflexivity. +Qed. + +Lemma senv_preserved: + Senv.equiv pge tpge. +Proof. + eapply (Genv.senv_match TRANSL). +Qed. + +Lemma functions_preserved: + forall (v: val) (f: fundef), + Genv.find_funct pge v = Some f -> + exists tf cunit, transf_fundef f = OK tf /\ Genv.find_funct tpge v = Some tf /\ linkorder cunit prog. +Proof. + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & A & B & C). + repeat eexists; intuition eauto. + + unfold incl; auto. + + eapply linkorder_refl. +Qed. + +Lemma function_ptr_preserved: + forall v f, + Genv.find_funct_ptr pge v = Some f -> + exists tf, + Genv.find_funct_ptr tpge v = Some tf /\ transf_fundef f = OK tf. +Proof. + intros. + exploit (Genv.find_funct_ptr_transf_partial TRANSL); eauto. +Qed. + +Lemma function_sig_preserved: + forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. +Proof. + intros. destruct f. + - simpl in H. monadInv H. + destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. + symmetry. + eapply match_function_preserves. + eassumption. + - simpl in H. monadInv H. reflexivity. +Qed. + +Theorem transf_initial_states: + forall s1, initial_state prog s1 -> + exists s2, initial_state tprog s2 /\ match_states s1 s2. +Proof. + intros. inv H. + exploit function_ptr_preserved; eauto. intros (tf & FIND & TRANSF). + exists (Callstate nil tf nil m0). + split. + - econstructor; eauto. + + intros; apply (Genv.init_mem_match TRANSL); assumption. + + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. + symmetry. eapply match_program_main. eauto. + + destruct f. + * monadInv TRANSF. rewrite <- H3. + destruct (transf_function f) as [res H]; simpl in * |- *; auto. + destruct (H _ EQ). + intuition subst; auto. + symmetry; eapply match_function_preserves. eassumption. + * monadInv TRANSF. assumption. + - constructor; eauto. + + constructor. + + apply transf_fundef_correct; auto. +(* + eapply all_fundef_liveness_ok; eauto. *) +Qed. + +Theorem transf_final_states s1 s2 r: + final_state s1 r -> match_states s1 s2 -> final_state s2 r. +Proof. + unfold final_state. + intros H; inv H. + intros H; inv H; simpl in * |- *; try congruence. + inv H1. + destruct st; simpl in * |- *; try congruence. + inv STACKS. constructor. +Qed. + + +Let ge := Genv.globalenv (RTLpath.transf_program prog). +Let tge := Genv.globalenv (RTLpath.transf_program tprog). + +Lemma senv_sym x y: Senv.equiv x y -> Senv.equiv y x. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. + +Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z. +Proof. + unfold Senv.equiv. intuition congruence. +Qed. + +Lemma senv_preserved_RTL: + Senv.equiv ge tge. +Proof. + eapply senv_transitivity. { eapply senv_sym; eapply RTLpath.senv_preserved. } + eapply senv_transitivity. { eapply senv_preserved. } + eapply RTLpath.senv_preserved. +Qed. + +Lemma symbols_preserved_RTL s: Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + unfold tge, ge. erewrite RTLpath.symbols_preserved; eauto. + rewrite symbols_preserved. + erewrite RTLpath.symbols_preserved; eauto. +Qed. + +Program Definition mkctx sp rs0 m0 {f1: RTLpath.function} (hyp: liveness_ok_function f1) + : simu_proof_context f1 + := {| the_ge1:= ge; the_ge2 := tge; the_sp:=sp; the_rs0:=rs0; the_m0:=m0 |}. +Obligation 2. + erewrite symbols_preserved_RTL. eauto. +Qed. + +Lemma s_find_function_preserved f sp svos1 svos2 rs0 m0 fd + (LIVE: liveness_ok_function f): + (svident_simu f (mkctx sp rs0 m0 LIVE) svos1 svos2) -> + sfind_function pge ge sp svos1 rs0 m0 = Some fd -> + exists fd', sfind_function tpge tge sp svos2 rs0 m0 = Some fd' + /\ transf_fundef fd = OK fd' + /\ liveness_ok_fundef fd. +Proof. + Local Hint Resolve symbols_preserved_RTL: core. + unfold sfind_function. intros [sv1 sv2 SIMU|]; simpl in *. + + rewrite !(seval_preserved ge tge) in *; eauto. + destruct (seval_sval _ _ _ _); try congruence. + erewrite <- SIMU; try congruence. clear SIMU. + intros; exploit functions_preserved; eauto. + intros (fd' & cunit & (X1 & X2 & X3)). eexists. + repeat split; eauto. + eapply find_funct_liveness_ok; eauto. +(* intros. eapply all_fundef_liveness_ok; eauto. *) + + subst. rewrite symbols_preserved. destruct (Genv.find_symbol _ _); try congruence. + intros; exploit function_ptr_preserved; eauto. + intros (fd' & X). eexists. intuition eauto. +(* intros. eapply all_fundef_liveness_ok; eauto. *) +Qed. + +Lemma sistate_simu f dupmap sp st st' rs m is + (LIVE: liveness_ok_function f): + ssem_internal ge sp st rs m is -> + sistate_simu dupmap f st st' (mkctx sp rs m LIVE)-> + exists is', + ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap is is'. +Proof. + intros SEM X; eapply X; eauto. +Qed. + +Lemma seval_builtin_sval_preserved sp rs m: + forall bs, seval_builtin_sval ge sp bs rs m = seval_builtin_sval tge sp bs rs m. +Proof. + induction bs. + all: try (simpl; try reflexivity; erewrite seval_preserved by eapply symbols_preserved_RTL; reflexivity). + all: simpl; rewrite IHbs1; rewrite IHbs2; reflexivity. +Qed. + +Lemma seval_list_builtin_sval_preserved sp rs m: + forall lbs, + seval_list_builtin_sval ge sp lbs rs m = seval_list_builtin_sval tge sp lbs rs m. +Proof. + induction lbs; [simpl; reflexivity|]. + simpl. rewrite seval_builtin_sval_preserved. rewrite IHlbs. + reflexivity. +Qed. + +Lemma ssem_final_simu dm f f' stk stk' sp st st' rs0 m0 sv sv' rs m t s + (LIVE: liveness_ok_function f): + match_function dm f f' -> + list_forall2 match_stackframes stk stk' -> + (* s_istate_simu f dupmap st st' -> *) + sfval_simu dm f st.(si_pc) st'.(si_pc) (mkctx sp rs0 m0 LIVE) sv sv' -> + ssem_final pge ge sp st.(si_pc) stk f rs0 m0 sv rs m t s -> + exists s', ssem_final tpge tge sp st'.(si_pc) stk' f' rs0 m0 sv' rs m t s' /\ match_states s s'. +Proof. + Local Hint Resolve transf_fundef_correct: core. + intros FUN STK (* SIS *) SFV. destruct SFV; intros SEM; inv SEM; simpl in *. + - (* Snone *) + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + eapply eqlive_reg_refl. + - (* Scall *) + exploit s_find_function_preserved; eauto. + intros (fd' & FIND & TRANSF & LIVE'). + erewrite <- function_sig_preserved; eauto. + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + + eapply eq_trans; try eassumption; auto. + + simpl. repeat (econstructor; eauto). + - (* Stailcall *) + exploit s_find_function_preserved; eauto. + intros (fd' & FIND & TRANSF & LIVE'). + erewrite <- function_sig_preserved; eauto. + eexists; split; econstructor; eauto. + + erewrite <- preserv_fnstacksize; eauto. + + eapply eq_trans; try eassumption; auto. + - (* Sbuiltin *) + pose senv_preserved_RTL as SRTL. + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + + eapply seval_builtin_args_preserved; eauto. + eapply seval_list_builtin_sval_correct; eauto. + rewrite H0. + erewrite seval_list_builtin_sval_preserved; eauto. + + eapply external_call_symbols_preserved; eauto. + + eapply eqlive_reg_refl. + - (* Sjumptable *) + exploit ptree_get_list_nth_rev; eauto. intros (p2 & LNZ & DM). + exploit initialize_path. { eapply dupmap_path_entry1; eauto. } + intros (path & PATH). + eexists; split; econstructor; eauto. + + eapply eq_trans; try eassumption; auto. + + eapply eqlive_reg_refl. + - (* Sreturn *) + eexists; split; econstructor; eauto. + erewrite <- preserv_fnstacksize; eauto. + - (* Sreturn bis *) + eexists; split; econstructor; eauto. + + erewrite <- preserv_fnstacksize; eauto. + + rewrite <- H. erewrite <- seval_preserved; eauto. +Qed. + +(* The main theorem on simulation of symbolic states ! *) +Theorem ssem_sstate_simu dm f f' stk stk' sp st st' rs m t s: + match_function dm f f' -> + liveness_ok_function f -> + list_forall2 match_stackframes stk stk' -> + ssem pge ge sp st stk f rs m t s -> + (forall ctx: simu_proof_context f, sstate_simu dm f st st' ctx) -> + exists s', ssem tpge tge sp st' stk' f' rs m t s' /\ match_states s s'. +Proof. + intros MFUNC LIVE STACKS SEM SIMU. + destruct (SIMU (mkctx sp rs m LIVE)) as (SIMU1 & SIMU2); clear SIMU. + destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl. + - (* sem_early *) + exploit sistate_simu; eauto. + unfold istate_simu; rewrite CONT. + intros (is' & SEM' & (path & PATH & (CONT' & RS' & M') & PC')). + exists (State stk' f' sp (ipc is') (irs is') (imem is')). + split. + + eapply ssem_early; auto. congruence. + + rewrite M'. econstructor; eauto. + - (* sem_normal *) + exploit sistate_simu; eauto. + unfold istate_simu; rewrite CONT. + intros (is' & SEM' & (CONT' & RS' & M')(* & DMEQ *)). + rewrite <- eqlive_reg_triv in RS'. + exploit ssem_final_simu; eauto. + clear SEM2; intros (s0 & SEM2 & MATCH0). + exploit ssem_final_equiv; eauto. + clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s1 & EQ & SEM2). + exists s1; split. + + eapply ssem_normal; eauto. + + eapply match_states_equiv; eauto. +Qed. + +Lemma exec_path_simulation dupmap path stk stk' f f' sp rs m pc pc' t s: + (fn_path f)!pc = Some path -> + path_step ge pge path.(psize) stk f sp rs m pc t s -> + list_forall2 match_stackframes stk stk' -> + dupmap ! pc' = Some pc -> + match_function dupmap f f' -> + liveness_ok_function f -> + exists path' s', (fn_path f')!pc' = Some path' /\ path_step tge tpge path'.(psize) stk' f' sp rs m pc' t s' /\ match_states s s'. +Proof. + intros PATH STEP STACKS DUPPC MATCHF LIVE. + exploit initialize_path. { eapply dupmap_path_entry2; eauto. } + intros (path' & PATH'). + exists path'. + exploit (sexec_correct f pc pge ge sp path stk rs m t s); eauto. + intros (st & SYMB & SEM); clear STEP. + exploit dupmap_correct; eauto. + clear SYMB; intros (st' & SYMB & SIMU). + exploit ssem_sstate_simu; eauto. + intros (s0 & SEM0 & MATCH). + exploit sexec_exact; eauto. + intros (s' & STEP' & EQ). + exists s'; intuition. + eapply match_states_equiv; eauto. +Qed. + +Lemma step_simulation s1 t s1' s2: + step ge pge s1 t s1' -> + match_states s1 s2 -> + exists s2', + step tge tpge s2 t s2' + /\ match_states s1' s2'. +Proof. + Local Hint Resolve eqlive_stacks_refl transf_fundef_correct: core. + destruct 1 as [path stack f sp rs m pc t s PATH STEP | | | ]; intros MS; inv MS. +(* exec_path *) + - try_simplify_someHyps. intros. + exploit path_step_eqlive; eauto. (* { intros. eapply all_fundef_liveness_ok; eauto. } *) + clear STEP EQUIV rs; intros (s2 & STEP & EQLIVE). + exploit exec_path_simulation; eauto. + clear STEP; intros (path' & s' & PATH' & STEP' & MATCH'). + exists s'; split. + + eapply exec_path; eauto. + + eapply eqlive_match_states; eauto. +(* exec_function_internal *) + - inv LIVE. + exploit initialize_path. { eapply (fn_entry_point_wf f). } + destruct 1 as (path & PATH). + inversion TRANSF as [f0 xf tf MATCHF|]; subst. eexists. split. + + eapply exec_function_internal. erewrite <- preserv_fnstacksize; eauto. + + erewrite preserv_fnparams; eauto. + econstructor; eauto. + { apply preserv_entrypoint; auto. } + { apply eqlive_reg_refl. } +(* exec_function_external *) + - inversion TRANSF as [|]; subst. eexists. split. + + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved_RTL. + + constructor. assumption. +(* exec_return *) + - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split. + + constructor. + + inv H1. econstructor; eauto. +Qed. + +Theorem transf_program_correct: + forward_simulation (semantics prog) (semantics tprog). +Proof. + eapply forward_simulation_step with match_states. + - eapply senv_preserved. + - eapply transf_initial_states. + - intros; eapply transf_final_states; eauto. + - intros; eapply step_simulation; eauto. +Qed. + +End PRESERVATION. diff --git a/scheduling/RTLpathproof.v b/scheduling/RTLpathproof.v new file mode 100644 index 00000000..20eded97 --- /dev/null +++ b/scheduling/RTLpathproof.v @@ -0,0 +1,50 @@ +Require Import Coqlib Maps. +Require Import AST Integers Values Events Memory Globalenvs Smallstep. +Require Import Op Registers. +Require Import RTL Linking. +Require Import RTLpath. + +Definition match_prog (p: RTLpath.program) (tp: RTL.program) := + match_program (fun ctx f tf => tf = fundef_RTL f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + + +Section PRESERVATION. + +Variable prog: RTLpath.program. +Variable tprog: RTL.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (RTLpath.semantics prog) (RTL.semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. subst. + eapply RTLpath_correct. +Qed. + +End PRESERVATION. + + diff --git a/kvx/abstractbb/AbstractBasicBlocksDef.v b/scheduling/abstractbb/AbstractBasicBlocksDef.v index 6960f363..34d72de1 100644 --- a/kvx/abstractbb/AbstractBasicBlocksDef.v +++ b/scheduling/abstractbb/AbstractBasicBlocksDef.v @@ -273,23 +273,26 @@ with list_term := Scheme term_mut := Induction for term Sort Prop with list_term_mut := Induction for list_term Sort Prop. +Declare Scope pattern_scope. +Declare Scope term_scope. Bind Scope pattern_scope with term. Delimit Scope term_scope with term. Delimit Scope pattern_scope with pattern. +Local Open Scope pattern_scope. + Notation "[ ]" := (LTnil _) (format "[ ]"): pattern_scope. -Notation "[ x ]" := (LTcons x [] _): pattern_scope. +Notation "[ x ]" := (LTcons x [ ] _): pattern_scope. Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil _) _) .. _) _): pattern_scope. Notation "o @ l" := (App o l _) (at level 50, no associativity): pattern_scope. Import HConsingDefs. Notation "[ ]" := (LTnil unknown_hid) (format "[ ]"): term_scope. -Notation "[ x ]" := (LTcons x [] unknown_hid): term_scope. +Notation "[ x ]" := (LTcons x []%term unknown_hid): term_scope. Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil unknown_hid) unknown_hid) .. unknown_hid) unknown_hid): term_scope. Notation "o @ l" := (App o l unknown_hid) (at level 50, no associativity): term_scope. -Local Open Scope pattern_scope. Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := match t with @@ -370,7 +373,7 @@ Qed. Hint Resolve intro_fail_correct: wlp. (** The default reduction of a term to a pseudo-term *) -Definition identity_fail (t: term):= intro_fail [t] t. +Definition identity_fail (t: term):= intro_fail (t::nil) t. Lemma identity_fail_correct (t: term): match_pt t (identity_fail t). Proof. @@ -382,8 +385,8 @@ Hint Resolve identity_fail_correct: wlp. (** The reduction for constant term *) Definition nofail (is_constant: op -> bool) (t: term):= match t with - | Input x _ => intro_fail ([])%list t - | o @ [] => if is_constant o then (intro_fail ([])%list t) else (identity_fail t) + | Input x _ => intro_fail nil t + | o @ [] => if is_constant o then (intro_fail nil t) else (identity_fail t) | _ => identity_fail t end. diff --git a/kvx/abstractbb/ImpSimuTest.v b/scheduling/abstractbb/ImpSimuTest.v index b1a3b985..6b64e1d8 100644 --- a/kvx/abstractbb/ImpSimuTest.v +++ b/scheduling/abstractbb/ImpSimuTest.v @@ -23,9 +23,8 @@ Require Export Impure.ImpHCons. (**r Import the Impure library. See https://gith Export Notations. Import HConsing. - +Require Import Coq.Bool.Bool. Require Export SeqSimuTheory. - Require Import PArith. @@ -35,6 +34,8 @@ Import ListNotations. Local Open Scope list_scope. +Definition FULL_DEBUG_DUMP : bool := false. (* print debug traces, even if the verifier succeeds. *) + (** * Interface of (impure) equality tests for operators *) Module Type ImpParam. @@ -673,8 +674,8 @@ Hypothesis hco_term_correct: forall t, WHEN hco_term.(hC) t ~> t' THEN forall ge Variable hco_list: hashConsing list_term. Hypothesis hco_list_correct: forall t, WHEN hco_list.(hC) t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. -Variable print_error_end: hsmem -> hsmem -> ?? unit. -Variable print_error: pstring -> ?? unit. +Variable print_end_error: hsmem -> hsmem -> ?? unit. +Variable print_dump: (option pstring) -> ?? unit. Variable check_failpreserv: bool. Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) @@ -687,20 +688,23 @@ Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := DO d2 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; DO b <~ Dict.eq_test d1 d2 ;; if b then ( - if check_failpreserv then ( + (if check_failpreserv then let hp := mk_hash_params dbg_failpreserv in failure_in_failpreserv.(set)(true);; - Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; - RET true - ) else RET false + Sets.assert_list_incl hp d2.(hpre) d1.(hpre) + else RET tt);; + (if FULL_DEBUG_DUMP then + print_dump None (* not an error... *) + else RET tt);; + RET check_failpreserv ) else ( - print_error_end d1 d2 ;; + print_end_error d1 d2 ;; RET false ) CATCH_FAIL s, _ => DO b <~ failure_in_failpreserv.(get)();; if b then RET false - else print_error s;; RET false + else print_dump (Some s);; RET false ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; RET (`r). Obligation 1. @@ -773,12 +777,16 @@ Definition msg_unknow_term: pstring := "unknown term". Definition msg_number: pstring := "on 2nd bblock -- on inst num ". Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock (INTERNAL ERROR: this error is expected to be detected before!!!)". -Definition print_error_end (_ _: hsmem): ?? unit +Definition print_end_error (_ _: hsmem): ?? unit := println (msg_prefix +; msg_error_on_end). -Definition print_error (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - println (msg_prefix +; msg_number +; n +; " -- " +; s). +Definition print_error (log: logger unit) (os: option pstring): ?? unit + := match os with + | Some s => + DO n <~ log_info log ();; + println (msg_prefix +; msg_number +; n +; " -- " +; s) + | None => RET tt + end. Definition failpreserv_error (_: term): ?? unit := println (msg_prefix +; msg_notfailpreserv). @@ -808,7 +816,7 @@ Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := (log_insert log) hco_term _ hco_list _ - print_error_end + print_end_error (print_error log) true (* check_failpreserv *) failpreserv_error @@ -905,7 +913,6 @@ with string_of_list_term (l: list_term): ?? pstring := RET (st +; ";" +; sl) end. - End PrettryPrint. @@ -948,7 +955,7 @@ Definition print_tables gdi ext exl: ?? unit := iterall exl (fun head _ pl => print_list gdi head pl.(hdata));; println "----------------". -Definition print_final_debug gdi (d1 d2: hsmem): ?? unit +Definition print_final_debug gdi (d1 d2: hsmem): ?? unit := DO b <~ Dict.not_eq_witness d1 d2 ;; match b with | Some x => @@ -986,39 +993,44 @@ Definition print_witness gdi cr (*msg*) := | None => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" end. - -Definition print_error_end1 gdi hct hcl (d1 d2:hsmem): ?? unit +Definition print_end_error1 gdi hct hcl (d1 d2:hsmem): ?? unit := println "- GRAPH of 1st bblock";; DO ext <~ export hct ();; DO exl <~ export hcl ();; print_tables gdi ext exl;; - print_error_end d1 d2;; + print_end_error d1 d2;; print_final_debug gdi d1 d2. -Definition print_error1 gdi hct hcl cr log s : ?? unit +Definition print_dump1 gdi hct hcl cr log os : ?? unit := println "- GRAPH of 1st bblock";; DO ext <~ export hct ();; DO exl <~ export hcl ();; print_tables gdi ext exl;; - print_error log s;; - print_witness gdi cr (*"1st"*). - + print_error log os;; + match os with + | Some _ => print_witness gdi cr (*"1st"*) + | None => RET tt + end. Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". -Definition print_error_end2 gdi hct hcl (d1 d2:hsmem): ?? unit +Definition print_end_error2 gdi hct hcl (d1 d2:hsmem): ?? unit := println (msg_prefix +; msg_error_on_end);; println "- GRAPH of 2nd bblock";; DO ext <~ export hct ();; DO exl <~ export hcl ();; print_tables gdi ext exl. -Definition print_error2 gdi hct hcl cr (log: logger unit) (s:pstring): ?? unit +Definition print_dump2 gdi hct hcl cr (log: logger unit) (os:option pstring): ?? unit := DO n <~ log_info log ();; DO ext <~ export hct ();; DO exl <~ export hcl ();; - println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; - print_witness gdi cr (*"2nd"*);; + match os with + | Some s => + println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; + print_witness gdi cr (*"2nd"*) + | None => RET tt + end;; println "- GRAPH of 2nd bblock";; print_tables gdi ext exl. @@ -1051,21 +1063,25 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO cr <~ make_cref None;; DO hco_term <~ mk_annot (hCons hpt);; DO hco_list <~ mk_annot (hCons hplt);; - DO result1 <~ g_bblock_simu_test + (if FULL_DEBUG_DUMP then + println("");; + println("-- START simu checker --") + else RET tt);; + DO result1 <~ (g_bblock_simu_test (log_assign dict_info log1) (log_new_term (msg_term cr)) (hlog log1 hco_term hco_list) (log_insert log2) hco_term _ hco_list _ - (print_error_end1 dict_info.(D.get) hco_term hco_list) - (print_error1 dict_info.(D.get) hco_term hco_list cr log2) + (print_end_error1 dict_info.(D.get) hco_term hco_list) + (print_dump1 dict_info.(D.get) hco_term hco_list cr log2) true failpreserv_error - p1 p2;; - if result1 - then RET true - else + p1 p2);; + if (if FULL_DEBUG_DUMP then false else result1) + then RET true + else ( DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; @@ -1080,31 +1096,35 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := (log_insert log2) hco_term _ hco_list _ - (print_error_end2 dict_info.(D.get) hco_term hco_list) - (print_error2 dict_info.(D.get) hco_term hco_list cr log2) + (print_end_error2 dict_info.(D.get) hco_term hco_list) + (print_dump2 dict_info.(D.get) hco_term hco_list cr log2) false (fun _ => RET tt) p2 p1;; - if result2 - then ( - println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; - RET false - ) else RET false - . + if FULL_DEBUG_DUMP then + println("-- END simu checker --");; + println("");; + RET result1 + else if result2 + then ( + println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; + RET false + ) else RET false + ). Obligation 1. - generalize (hCons_correct _ _ _ H0); clear H0. + generalize (hCons_correct _ _ _ H1); clear H1. wlp_simplify. Qed. Obligation 2. - generalize (hCons_correct _ _ _ H); clear H. + generalize (hCons_correct _ _ _ H0); clear H0. wlp_simplify. Qed. Obligation 3. - generalize (hCons_correct _ _ _ H0); clear H0. + generalize (hCons_correct _ _ _ H1); clear H1. wlp_simplify. Qed. Obligation 4. - generalize (hCons_correct _ _ _ H); clear H. + generalize (hCons_correct _ _ _ H0); clear H0. wlp_simplify. Qed. diff --git a/kvx/abstractbb/Parallelizability.v b/scheduling/abstractbb/Parallelizability.v index e5d21434..afa4b9fd 100644 --- a/kvx/abstractbb/Parallelizability.v +++ b/scheduling/abstractbb/Parallelizability.v @@ -299,7 +299,7 @@ Proof. induction i as [|[y e] i']; cbn. - intros m tmp H x H0; inversion_clear H; auto. - intros m tmp H x (H1 & H2); destruct (exp_eval ge e tmp old); cbn; try congruence. - cutrewrite (m x = assign m y v x); eauto. + replace (m x) with (assign m y v x); eauto. rewrite assign_diff; auto. Qed. @@ -514,13 +514,13 @@ Proof. induction i as [|[x e] i']; cbn; auto. intros m tmp1 tmp2; rewrite disjoint_cons_l, disjoint_app_l. intros (H1 & H2 & H3) H6 H7. - cutrewrite (exp_eval ge e tmp1 old1 = exp_eval ge e tmp2 old2). + replace (exp_eval ge e tmp1 old1) with (exp_eval ge e tmp2 old2). - destruct (exp_eval ge e tmp2 old2); auto. eapply IHi'; eauto. cbn; intros x0 H0; unfold assign. destruct (R.eq_dec x x0); cbn; auto. - unfold disjoint in H2; apply exp_frame_correct. - intros;apply H6; auto. - intros;apply H7; auto. + intros;rewrite H6; auto. + intros;rewrite H7; auto. Qed. (** * Parallelizability *) diff --git a/kvx/abstractbb/README.md b/scheduling/abstractbb/README.md index 69e5defc..69e5defc 100644 --- a/kvx/abstractbb/README.md +++ b/scheduling/abstractbb/README.md diff --git a/kvx/abstractbb/SeqSimuTheory.v b/scheduling/abstractbb/SeqSimuTheory.v index df6b9963..df6b9963 100644 --- a/kvx/abstractbb/SeqSimuTheory.v +++ b/scheduling/abstractbb/SeqSimuTheory.v diff --git a/kvx/lib/ForwardSimulationBlock.v b/scheduling/postpass_lib/ForwardSimulationBlock.v index 61466dad..cc6ecdd8 100644 --- a/kvx/lib/ForwardSimulationBlock.v +++ b/scheduling/postpass_lib/ForwardSimulationBlock.v @@ -25,7 +25,7 @@ Require Import Coqlib. Require Import Events. Require Import Globalenvs. Require Import Smallstep. - +Require Import Lia. Local Open Scope nat_scope. @@ -43,8 +43,8 @@ Lemma starN_split n s t s': exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. Proof. induction 1; cbn. - + intros m k H; assert (X: m=0); try omega. - assert (X0: k=0); try omega. + + intros m k H; assert (X: m=0); try lia. + assert (X0: k=0); try lia. subst; repeat (eapply ex_intro); intuition eauto. + intros m; destruct m as [| m']; cbn. - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. @@ -119,10 +119,10 @@ Proof. intros t [H1 H2] H3 H4. destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. constructor 1. - + omega. - + cutrewrite (dist_end_block head - dist_end_block next = S (dist_end_block head - dist_end_block previous)). + + lia. + + replace (dist_end_block head - dist_end_block next) with (S (dist_end_block head - dist_end_block previous)). - eapply starN_tailstep; eauto. - - omega. + - lia. Qed. Lemma follows_in_block_init (head current: state L1): @@ -131,10 +131,10 @@ Proof. intros t H3 H4. destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. constructor 1. - + omega. - + cutrewrite (dist_end_block head - dist_end_block current = 1). + + lia. + + replace (dist_end_block head - dist_end_block current) with 1. - eapply starN_tailstep; eauto. - - omega. + - lia. Qed. @@ -156,10 +156,10 @@ Proof. destruct s as [rs ms Hs]. cbn. destruct ms as [ms|]; unfold head; cbn; auto. constructor 1. - omega. - cutrewrite ((dist_end_block rs - dist_end_block rs)%nat=O). + lia. + replace (dist_end_block rs - dist_end_block rs)%nat with O. + apply starN_refl; auto. - + omega. + + lia. Qed. Inductive is_well_memorized (s s': memostate): Prop := @@ -259,7 +259,7 @@ Proof. constructor 1. destruct (simu_end_block (head s1) t (real s1') s2) as (s2' & H3 & H4); auto. * destruct (head_followed s1) as [H4 H3]. - cutrewrite (dist_end_block (head s1) - dist_end_block (real s1) = dist_end_block (head s1)) in H3; try omega. + replace (dist_end_block (head s1) - dist_end_block (real s1)) with (dist_end_block (head s1)) in H3; try lia. eapply starN_tailstep; eauto. * unfold head; rewrite H2; cbn. intuition eauto. Qed. diff --git a/kvx/lib/Machblock.v b/scheduling/postpass_lib/Machblock.v index 404c2a96..404c2a96 100644 --- a/kvx/lib/Machblock.v +++ b/scheduling/postpass_lib/Machblock.v diff --git a/kvx/lib/Machblockgen.v b/scheduling/postpass_lib/Machblockgen.v index 3d5d7b2c..5a2f2a61 100644 --- a/kvx/lib/Machblockgen.v +++ b/scheduling/postpass_lib/Machblockgen.v @@ -155,11 +155,11 @@ Proof. + intros; eapply Tr_add_label; eauto. destruct i; cbn in * |- *; congruence. + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. * eapply Tr_add_basic; eauto. - * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. + * replace (add_basic bi empty_bblock) with (add_to_new_bblock (MB_basic bi)); auto. rewrite Heqti; eapply Tr_end_block; eauto. rewrite <- Heqti. eapply End_basic. congruence. + intros. - cutrewrite (cfi_bblock cfi = add_to_new_bblock (MB_cfi cfi)); auto. + replace (cfi_bblock cfi) with (add_to_new_bblock (MB_cfi cfi)); auto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <- Heqti. eapply End_cfi. congruence. Qed. diff --git a/kvx/lib/Machblockgenproof.v b/scheduling/postpass_lib/Machblockgenproof.v index fc722887..d121a54b 100644 --- a/kvx/lib/Machblockgenproof.v +++ b/scheduling/postpass_lib/Machblockgenproof.v @@ -190,7 +190,7 @@ Proof. intros H H0 H1. unfold find_label. remember (is_label l _) as b. - cutrewrite (b = false); auto. + replace b with false; auto. subst; unfold is_label. destruct i; cbn in * |- *; try (destruct (in_dec l nil); intuition). inversion H. @@ -286,7 +286,7 @@ Lemma find_label_preserved: Mach.find_label l (Mach.fn_code f) = Some c -> exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). Proof. - intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. + intros. replace (fn_code (transf_function f)) with (trans_code (Mach.fn_code f)); eauto. apply find_label_transcode_preserved; auto. Qed. @@ -661,7 +661,7 @@ Proof. inversion H1; subst; clear H1. inversion_clear H0; cbn. - (* function_internal*) - cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. + replace (trans_code (Mach.fn_code f0)) with (fn_code (transf_function f0)); eauto. eapply exec_function_internal; eauto. rewrite <- parent_sp_preserved; eauto. rewrite <- parent_ra_preserved; eauto. @@ -733,12 +733,12 @@ Proof. intro H; destruct c as [|i' c]. { inversion H. } remember (trans_inst i) as ti. destruct ti as [lbl|bi|cfi]. - - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2: ( destruct i; cbn in * |- *; try congruence ). + - (*i=lbl *) replace (i ) with (Mlabel lbl). 2: ( destruct i; cbn in * |- *; try congruence ). exists nil; cbn; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. - cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. + replace ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)) with ((add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <-Heqti. @@ -748,7 +748,7 @@ Proof. - (*i=cfi*) destruct i; try(cbn in Heqti; congruence). all: exists (add_to_new_bblock (MB_cfi cfi)::nil); exists b; - cutrewrite ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; + replace ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)) with ((add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; rewrite Heqti; eapply Tr_end_block; eauto; rewrite <-Heqti; @@ -765,21 +765,6 @@ Proof. eauto. Qed. -(* FIXME: these two lemma should go into [Coqlib.v] *) -Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). -Proof. - induction l1; cbn; auto with coqlib. -Qed. -Hint Resolve is_tail_app: coqlib. - -Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. -Proof. - induction l1; cbn; auto with coqlib. - intros l2 l3 H; inversion H; eauto with coqlib. -Qed. -Hint Resolve is_tail_app_inv: coqlib. - - Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> exists b, is_tail (b :: trans_code c) (trans_code c2). Proof. diff --git a/test/aarch64/README.md b/test/aarch64/README.md new file mode 100644 index 00000000..f943489c --- /dev/null +++ b/test/aarch64/README.md @@ -0,0 +1,15 @@ +# Testing the Machblock --> Asmblock translation +1. Get the reference version of compcert-aarch in the father's directory if this repo (checkout `aarch64-ref`) +2. Compile both repo for aarch64 +3. CD in this folder (`test/aarch64`) +4. Launch `./asmb_aarch64_gen_test.sh` + +## Options +The script takes following options : +- `-c` to clear generated files at the end +- `-w` to suppress warnings from Compcert + +## Tests files +The variable `DIRS` in the script takes the list of directories containing c files. +The tests under `test/aarch64/c` are simpler and useful to debug only one feature at a time. +Most of them comes from [here](https://cis.temple.edu/~ingargio/cis71/code/). diff --git a/test/aarch64/c/add_return.c b/test/aarch64/c/add_return.c new file mode 100644 index 00000000..c29aeb16 --- /dev/null +++ b/test/aarch64/c/add_return.c @@ -0,0 +1 @@ +int main(int r) { return r+1; } diff --git a/test/aarch64/c/addresses.c b/test/aarch64/c/addresses.c new file mode 100644 index 00000000..e3cb5201 --- /dev/null +++ b/test/aarch64/c/addresses.c @@ -0,0 +1,32 @@ +/* addresses.c -- Playing with addresses of variables and their contents: + * what is done by C with variables, addresses, and values. + */ + +#include <stdio.h> + +void moo(int a, int * b); + +int main(void) { + int x; + int *y; + + x=1; + y=&x; + printf("Address of x = %d, value of x = %d\n", &x, x); + printf("Address of y = %d, value of y = %d, value of *y = %d\n", &y, y, *y); + moo(9,y); +} + +void moo(int a, int *b){ + printf("Address of a = %d, value of a = %d\n", &a, a); + printf("Address of b = %d, value of b = %d, value of *b = %d\n", &b, b, *b); +} + +/* Output from running this program on my computer: + +Address of x = 536869640, value of x = 1 +Address of y = 536869632, value of y = 536869640, value of *y = 1 +Address of a = 536869608, value of a = 9 +Address of b = 536869600, value of b = 536869640, value of *b = 1 + + */ diff --git a/test/aarch64/c/arith.c b/test/aarch64/c/arith.c new file mode 100644 index 00000000..02df141b --- /dev/null +++ b/test/aarch64/c/arith.c @@ -0,0 +1,16 @@ +int main(int num1, int num2) +{ + int sum, sub, mult, mod; + float div; + + /* + * Perform all arithmetic operations + */ + sum = num1 + num2; + sub = num1 - num2; + mult = num1 * num2; + div = (float)num1 / num2; + mod = num1 % num2; + + return sum + sub + mult + div + mod; +} diff --git a/test/aarch64/c/arith_print.c b/test/aarch64/c/arith_print.c new file mode 100644 index 00000000..d404a151 --- /dev/null +++ b/test/aarch64/c/arith_print.c @@ -0,0 +1,19 @@ +int main() +{ + int num1 = 2; + int num2 = 4; + int sum, sub, mult, mod; + float div; + + /* + * Perform all arithmetic operations + */ + sum = num1 + num2; + sub = num1 - num2; + mult = num1 * num2; + div = (float)num1 / num2; + mod = num1 % num2; + + printf("%d", sum + sub + mult + div + mod); + return; +} diff --git a/test/aarch64/c/armstrong.c b/test/aarch64/c/armstrong.c new file mode 100644 index 00000000..c5d838f9 --- /dev/null +++ b/test/aarch64/c/armstrong.c @@ -0,0 +1,21 @@ +int main() +{ + int n,sum,i,t,a,z; + + for(i = 1; i <= 500; i++) + { + t = i; // as we need to retain the original number + sum = 0; + while(t != 0) + { + a = t%10; + sum += a*a*a; + t = t/10; + } + + if(sum == i) + z += i; + } + + return 0; +} diff --git a/test/aarch64/c/array1.c b/test/aarch64/c/array1.c new file mode 100644 index 00000000..5840ca66 --- /dev/null +++ b/test/aarch64/c/array1.c @@ -0,0 +1,64 @@ +/* array1.c -- Simple operations with arrays. + */ + +#include <stdio.h> +#define N 10 + +void oneWay(void); +void anotherWay(void); + +int main(void) { + printf("\noneWay:\n"); + oneWay(); + printf("\nantherWay:\n"); + anotherWay(); +} + +/*Array initialized with aggregate */ +void oneWay(void) { + int vect[N] = {1,2,3,4,5,6,7,8,9,0}; + int i; + + for (i=0; i<N; i++) + printf("i = %2d vect[i] = %2d\n", i, vect[i]); +} + +/*Array initialized with loop */ +void anotherWay(void) { + int vect[N]; + int i; + + for (i=0; i<N; i++) + vect[i] = i+1; + + for (i=0; i<N; i++) + printf("i = %2d vect[i] = %2d\n", i, vect[i]); +} + +/* The output of this program is + +oneWay: +i = 0 vect[i] = 1 +i = 1 vect[i] = 2 +i = 2 vect[i] = 3 +i = 3 vect[i] = 4 +i = 4 vect[i] = 5 +i = 5 vect[i] = 6 +i = 6 vect[i] = 7 +i = 7 vect[i] = 8 +i = 8 vect[i] = 9 +i = 9 vect[i] = 0 + +antherWay: +i = 0 vect[i] = 1 +i = 1 vect[i] = 2 +i = 2 vect[i] = 3 +i = 3 vect[i] = 4 +i = 4 vect[i] = 5 +i = 5 vect[i] = 6 +i = 6 vect[i] = 7 +i = 7 vect[i] = 8 +i = 8 vect[i] = 9 +i = 9 vect[i] = 10 + + */ diff --git a/test/aarch64/c/array2.c b/test/aarch64/c/array2.c new file mode 100644 index 00000000..389e1596 --- /dev/null +++ b/test/aarch64/c/array2.c @@ -0,0 +1,74 @@ +/* array2.c -- Read/writing/reversing integer arrays + */ + +#include <stdio.h> + +#define NMAX 10 + +void intSwap(int *x, int *y); +int getIntArray(int a[], int nmax, int sentinel); +void printIntArray(int a[], int n); +void reverseIntArray(int a[], int n); + +int main(void) { + int x[NMAX]; + int hmny; + + hmny = getIntArray(x, NMAX, 0); + printf("The array was: \n"); + printIntArray(x,hmny); + reverseIntArray(x,hmny); + printf("after reverse it is:\n"); + printIntArray(x,hmny); +} + +void intSwap(int *x, int *y) + /* It swaps the content of x and y */ +{ + int temp = *x; + *x = *y; + *y = temp; +} + +void printIntArray(int a[], int n) + /* n is the number of elements in the array a. + * These values are printed out, five per line. */ +{ + int i; + + for (i=0; i<n; ){ + printf("\t%d ", a[i++]); + if (i%5==0) + printf("\n"); + } + printf("\n"); +} + +int getIntArray(int a[], int nmax, int sentinel) + /* It reads up to nmax integers and stores then in a; sentinel + * terminates input. */ +{ + int n = 0; + int temp; + + do { + printf("Enter integer [%d to terminate] : ", sentinel); + scanf("%d", &temp); + if (temp==sentinel) break; + if (n==nmax) + printf("array is full\n"); + else + a[n++] = temp; + }while (1); + return n; +} + +void reverseIntArray(int a[], int n) + /* It reverse the order of the first n elements of a */ +{ + int i; + + for(i=0;i<n/2;i++){ + intSwap(&a[i],&a[n-i-1]); + } +} diff --git a/test/aarch64/c/biggest_of_3_int.c b/test/aarch64/c/biggest_of_3_int.c new file mode 100644 index 00000000..346908fc --- /dev/null +++ b/test/aarch64/c/biggest_of_3_int.c @@ -0,0 +1,10 @@ +int main(int a, int b, int c) { + if ((a > b) && (a > c)) { + return a; + } else if (b > c) { + return b; + } else { + return c; + } + return 0; +} diff --git a/test/aarch64/c/bitwise1.c b/test/aarch64/c/bitwise1.c new file mode 100644 index 00000000..d20641de --- /dev/null +++ b/test/aarch64/c/bitwise1.c @@ -0,0 +1,8 @@ +int main() +{ + int x = 6, y = 4; + x = x^y; + y = x^876987^x | y << 42; + + return ~x^y; +} diff --git a/test/aarch64/c/cpintarray.c b/test/aarch64/c/cpintarray.c new file mode 100644 index 00000000..8049fdfb --- /dev/null +++ b/test/aarch64/c/cpintarray.c @@ -0,0 +1,108 @@ +/* cpintarray.c -- Example showing how addresses and arrays are alike + */ + +#include <stdio.h> +#define SIZE 8 + +void cpIntArray(int *a, int *b, int n) +/*It copies n integers starting at b into a*/ +{ + for(;n>0;n--) + *a++=*b++; +} + + +void printIntArray(int a[], int n) + /* n is the number of elements in the array a. + * These values are printed out, five per line. */ +{ + int i; + + for (i=0; i<n; ){ + printf("\t%d ", a[i++]); + if (i%5==0) + printf("\n"); + } + printf("\n"); +} + +int getIntArray(int a[], int nmax, int sentinel) + /* It reads up to nmax integers and stores then in a; sentinel + * terminates input. */ +{ + int n = 0; + int temp; + + do { + printf("Enter integer [%d to terminate] : ", sentinel); + scanf("%d", &temp); + if (temp==sentinel) break; + if (n==nmax) + printf("array is full\n"); + else + a[n++] = temp; + }while (1); + return n; +} + +int main(void){ + int x[SIZE], nx; + int y[SIZE], ny; + + printf("Read the x array:\n"); + nx = getIntArray(x,SIZE,0); + printf("The x array is:\n"); + printIntArray(x,nx); + + printf("Read the y array:\n"); + ny = getIntArray(y,SIZE,0); + printf("The y array is:\n"); + printIntArray(y,ny); + + cpIntArray(x+2,y+3,4); + /*Notice the expression 'x+2'. x is interpreted as the address for + the beginning of the x array. +2 sais to increment that address + by two units, in accordance with the type of x, which is + an integer array. Thus we move from x to two integer locations + past it, that is to the location of x[2]. The same reasoning applied + to 'y+3'. + */ + printf("Printing x after having copied 4 elements\n" + "from y starting at y[3] into x starting at x[2]\n"); + printIntArray(x,nx); +} + +/* Here is the interaction in a run of this program: + +Read the x array: +Enter integer [0 to terminate] : 1 +Enter integer [0 to terminate] : 3 +Enter integer [0 to terminate] : 5 +Enter integer [0 to terminate] : 7 +Enter integer [0 to terminate] : 9 +Enter integer [0 to terminate] : 11 +Enter integer [0 to terminate] : 13 +Enter integer [0 to terminate] : 15 +Enter integer [0 to terminate] : 0 +The x array is: + 1 3 5 7 9 + 11 13 15 +Read the y array: +Enter integer [0 to terminate] : 2 +Enter integer [0 to terminate] : 4 +Enter integer [0 to terminate] : 6 +Enter integer [0 to terminate] : 8 +Enter integer [0 to terminate] : 10 +Enter integer [0 to terminate] : 12 +Enter integer [0 to terminate] : 14 +Enter integer [0 to terminate] : 16 +Enter integer [0 to terminate] : 0 +The y array is: + 2 4 6 8 10 + 12 14 16 +Printing x after having copied 4 elements +from y starting at y[3] into x starting at x[2] + 1 3 8 10 12 + 14 13 15 + + */ diff --git a/test/aarch64/c/enum1.c b/test/aarch64/c/enum1.c new file mode 100644 index 00000000..d1f6b48d --- /dev/null +++ b/test/aarch64/c/enum1.c @@ -0,0 +1,52 @@ +/* enum1.c -- Starting to use enumerated types: Printing for each + * day of the week, today, yesterday, and tomorrow, both + * as a string and as a number. + */ + +#include <stdio.h> + +/* Introducing an enumerated data type */ +enum days {monday,tuesday,wednesday,thursday,friday,saturday,sunday}; +typedef enum days days; // This allows us to use "days" as an abbreviation + // for "enum days" + +/* Two useful functions */ +days yesterday(days today){ + return (today+6)%7; +} +days tomorrow(days today){ + return (today+1)%7; +} + +// A useful array: thedays is an array of constant (i.e you cannot +// modify them) pointers to constant (i.e. you cannot modify them) strings +const char * const thedays[] = + {"monday", "tuesday", "wednesday", "thursday", + "friday", "saturday", "sunday"}; + +int main(void){ + days today; + + printf("today \tyesterday \ttomorrow\n" + "============================================\n"); + for (today=monday;today<=sunday;today++) + printf("%s = %d \t %s = %d \t %s = %d\n", + thedays[today], today, + thedays[yesterday(today)], yesterday(today), + thedays[tomorrow(today)], tomorrow(today)); +} + +/* + The output is: + +today yesterday tomorrow +============================================ +monday = 0 sunday = 6 tuesday = 1 +tuesday = 1 monday = 0 wednesday = 2 +wednesday = 2 tuesday = 1 thursday = 3 +thursday = 3 wednesday = 2 friday = 4 +friday = 4 thursday = 3 saturday = 5 +saturday = 5 friday = 4 sunday = 6 +sunday = 6 saturday = 5 monday = 0 + +*/ diff --git a/test/aarch64/c/enum2.c b/test/aarch64/c/enum2.c new file mode 100644 index 00000000..a18acb80 --- /dev/null +++ b/test/aarch64/c/enum2.c @@ -0,0 +1,50 @@ +/* enum2.c -- Starting to use enumerated types: Printing for each + * day of the week, today, yesterday, and tomorrow, both + * as a string and as a number. We use typedef + */ + +#include <stdio.h> + +/* Introducing an enumerated data type */ +typedef enum {monday,tuesday,wednesday,thursday,friday,saturday,sunday} days; + +/* Two useful functions */ +days yesterday(days today); +days tomorrow(days today); + +char *thedays[] = {"monday", "tuesday", "wednesday", "thursday", + "friday", "saturday", "sunday"}; + +int main(void){ + days today; + + printf("today \tyesterday \ttomorrow\n" + "============================================\n"); + for (today=monday;today<=sunday;today++) + printf("%s = %d \t %s = %d \t %s = %d\n", + thedays[today], today, + thedays[yesterday(today)], yesterday(today), + thedays[tomorrow(today)], tomorrow(today)); +} + +days yesterday(days today){ + return (today+6)%7; +} +days tomorrow(days today){ + return (today+1)%7; +} + +/* + The output is: + +today yesterday tomorrow +============================================ +monday = 0 sunday = 6 tuesday = 1 +tuesday = 1 monday = 0 wednesday = 2 +wednesday = 2 tuesday = 1 thursday = 3 +thursday = 3 wednesday = 2 friday = 4 +friday = 4 thursday = 3 saturday = 5 +saturday = 5 friday = 4 sunday = 6 +sunday = 6 saturday = 5 monday = 0 + +*/ diff --git a/test/aarch64/c/floop.c b/test/aarch64/c/floop.c new file mode 100644 index 00000000..30270892 --- /dev/null +++ b/test/aarch64/c/floop.c @@ -0,0 +1,8 @@ +int main(int x) +{ + int y = 4; + int s = 23; + for(int i = 0; i <= x; i++) + y << s; + return y; +} diff --git a/test/aarch64/c/floor.c b/test/aarch64/c/floor.c new file mode 100644 index 00000000..33a57af3 --- /dev/null +++ b/test/aarch64/c/floor.c @@ -0,0 +1,29 @@ +int main(int n) +{ + int x = 1, i; + + /* for positive values */ + if (n > 0) + { + for (; x <= n >> 1;) + { + x = x << 1; + } + n = x; + } + /* for negative values */ + else + { + n = ~n; + n = n + 1; + for (; x <= n >> 1;) + { + x = x << 1; + } + x = x << 1; + x = ~x; + x = x + 1; + n = x; + } + return n; +} diff --git a/test/aarch64/c/funcs.c b/test/aarch64/c/funcs.c new file mode 100644 index 00000000..49e610d6 --- /dev/null +++ b/test/aarch64/c/funcs.c @@ -0,0 +1,36 @@ +/* funcs.c -- More examples of functions + */ + +#include <stdio.h> + +int getint(void); /*It prompts user to enter an integer, which it returns*/ + +int getmax(int a, int b, int c); /*It returns value of largest of a, b, c*/ + +/* Main program: Using the various functions */ +int main (void) { + int x, y, z; + + x = getint(); + y = getint(); + z = getint(); + printf("The largest of %d, %d, and %d is %d\n", x, y, z, getmax(x,y,z)); +} + +int getint(void) { + int a; + + printf("Please enter an integer > "); + scanf("%d", &a); + return(a); +} + +int getmax(int a, int b, int c){ + int m = a; + + if (m<b) + m = b; + if (m<c) + m = c; + return(m); +} diff --git a/test/aarch64/c/hello.c b/test/aarch64/c/hello.c new file mode 100644 index 00000000..0279269e --- /dev/null +++ b/test/aarch64/c/hello.c @@ -0,0 +1,6 @@ +#include <stdio.h> + +int main(void) { + printf("Hello World!\n"); + return 0; +} diff --git a/test/aarch64/c/if.c b/test/aarch64/c/if.c new file mode 100644 index 00000000..7d2e249a --- /dev/null +++ b/test/aarch64/c/if.c @@ -0,0 +1,7 @@ +int main(int x) +{ + if (x > 27) + return 11; + else x--; + return x; +} diff --git a/test/aarch64/c/msb_pos.c b/test/aarch64/c/msb_pos.c new file mode 100644 index 00000000..f2e7fe09 --- /dev/null +++ b/test/aarch64/c/msb_pos.c @@ -0,0 +1,20 @@ +/* Function to find the MSB bit position */ +int main(int n) +{ + int i = 0, bit; + while (i < 32) + { + bit = n & 0x80000000; + if (bit == -0x80000000) + { + bit = 1; + } + + if (bit == 1) + break; + + n = n << 1; + i++; + } + return i; +} diff --git a/test/aarch64/c/power2.c b/test/aarch64/c/power2.c new file mode 100644 index 00000000..64707df9 --- /dev/null +++ b/test/aarch64/c/power2.c @@ -0,0 +1,42 @@ +/* power2.c -- Print out powers of 2: 1, 2, 4, 8, .. up to 2^N + */ + +#include <stdio.h> +#define N 16 + +int main(void) { + int n; /* The current exponent */ + int val = 1; /* The current power of 2 */ + + printf("\t n \t 2^n\n"); + printf("\t================\n"); + for (n=0; n<=N; n++) { + printf("\t%3d \t %6d\n", n, val); + val = 2*val; + } + return 0; +} + +/* It prints out : + + n 2^n + ================ + 0 1 + 1 2 + 2 4 + 3 8 + 4 16 + 5 32 + 6 64 + 7 128 + 8 256 + 9 512 + 10 1024 + 11 2048 + 12 4096 + 13 8192 + 14 16384 + 15 32768 + 16 65536 + +*/ diff --git a/test/aarch64/c/prime.c b/test/aarch64/c/prime.c new file mode 100644 index 00000000..6c51db32 --- /dev/null +++ b/test/aarch64/c/prime.c @@ -0,0 +1,23 @@ +/* prime1.c It prompts the user to enter an integer N. It prints out + * if it is a prime or not. If not, it prints out a factor of N. + */ + +#include <stdio.h> + +int main(int n) { + int i; + int flag; + + flag = 1; + for (i=2; (i<(n/2)) && flag; ) { /* May be we do not need to test + values of i greater than the square root of n? */ + if ((n % i) == 0) /* If true n is divisible by i */ + flag = 0; + else + i++; + } + + if (flag) + return 1; + return 0; +} diff --git a/test/aarch64/c/random.c b/test/aarch64/c/random.c new file mode 100644 index 00000000..50aa5737 --- /dev/null +++ b/test/aarch64/c/random.c @@ -0,0 +1,50 @@ +/* Generating random number sequences using the formula (linear congruence) + x[k+1] = (a*x[k] + c)mod m + where a, c, and m are parameters set by the user and passed as command line + parameters together with a seed i.e. x[0] + As a simple example try a=7, c=1, m=13, and seed=5 + A more sophisticated selection would be a=69069, c=0, + m=2^32=4294967296, and seed=31 + It will print out, in a sort of random order, up to m-1 distinct values. + Then it loops. + */ + +#include <stdio.h> +#include <unistd.h> +#include <stdlib.h> + +static long seed = 13; +static long a; +static long c; +static long m; + +void random_init(long s) { + if (s != 0) seed = s; +} + +long random() { + seed = (a*seed + c)%m; + return seed; + } + +int main(int argc, char * argv[]) { + if (argc != 5) { + printf("usage: %s a, c, m, seed\n", argv[0]); + return 1; + } + a = atoi(argv[1]); + c = atoi(argv[2]); + m = atoi(argv[3]); + long s = atoi(argv[4]); + random_init(s); + int k; + for (k = 0; k < m-1; k++) { + printf("%8ld", random()); + if (k % 8 == 7) { // after 8 elements go to a new line + printf("\n"); + sleep(1); // sleep for a second + } + } + printf("\n"); + return 0; +} diff --git a/test/aarch64/c/simple_op.c b/test/aarch64/c/simple_op.c new file mode 100644 index 00000000..7c43b081 --- /dev/null +++ b/test/aarch64/c/simple_op.c @@ -0,0 +1,8 @@ +int main(int argc, char ** argv) +{ + int n, m; + n = n + 1; + n = n * 7; + n / (8 - 2); + return n; +} diff --git a/test/aarch64/c/wloop.c b/test/aarch64/c/wloop.c new file mode 100644 index 00000000..5ba67419 --- /dev/null +++ b/test/aarch64/c/wloop.c @@ -0,0 +1,8 @@ +int main(int x) +{ + int y = 4; + int s = 23; + while(s < x) + y << s; + return y; +} diff --git a/test/aarch64/gen_tests/asmb_aarch64_gen_test.sh b/test/aarch64/gen_tests/asmb_aarch64_gen_test.sh new file mode 100755 index 00000000..38235f14 --- /dev/null +++ b/test/aarch64/gen_tests/asmb_aarch64_gen_test.sh @@ -0,0 +1,106 @@ +#!/bin/bash + +CLEAN=0 +WOFF=0 +while getopts ':cw' 'OPTKEY'; do + case ${OPTKEY} in + c) CLEAN=1;; + w) WOFF=1;; + esac +done + +DIRS=( + ../c/*.c # Special simple tests + #../../c/*.c + ../../clightgen/*.c + #../../compression/*.c + ../../cse2/*.c + + # Monniaux test directory + ../../monniaux/binary_search/*.c + ../../monniaux/complex/*.c + #../../monniaux/crypto-algorithms/*.c # Warnings + ../../monniaux/cse2/*.c + #../../monniaux/des/*.c # Unsupported feature? + ../../monniaux/expect/*.c + ../../monniaux/fill_buffer/*.c + ../../monniaux/genann/*.c + #../../monniaux/heptagon_radio_transmitter/*.c # Warnings + ../../monniaux/idea/*.c + ../../monniaux/jumptable/*.c + ../../monniaux/licm/*.c + ../../monniaux/longjmp/*.c + ../../monniaux/loop/*.c + ../../monniaux/lustrev4_lustrec_heater_control/*.c + ../../monniaux/lustrev4_lv4_heater_control/*.c + ../../monniaux/lustrev4_lv6-en-2cgc_heater_control/*.c + #../../monniaux/lustrev6-carlightV2/*.c # Warnings + #../../monniaux/lustrev6-convertible-2cgc/*.c # Unsupported feature? + #../../monniaux/lustrev6-convertible-en-2cgc/*.c + #../../monniaux/lustrev6-convertible/*.c # Warnings + ../../monniaux/madd/*.c + #../../monniaux/math/*.c # Unsupported feature? + ../../monniaux/memcpy/*.c + #../../monniaux/micro-bunzip/*.c # Warnings + ../../monniaux/moves/*.c + ../../monniaux/multithreaded_volatile/*.c + ../../monniaux/nand/*.c + #../../monniaux/ncompress/*.c # Warnings + ../../monniaux/number_theoretic_transform/*.c + ../../monniaux/predicated/*.c + ../../monniaux/regalloc/*.c + ../../monniaux/rotate/*.c + ../../monniaux/scheduling/*.c + ../../monniaux/send_through/*.c + ../../monniaux/tiny-AES-c/*.c + ../../monniaux/varargs/*.c + ../../monniaux/xor_and_mat/*.c + #../../monniaux/zlib-1.2.11/*.c # Warnings +) +#FILES=../c/*.c +CCOMP_BBLOCKS="../../../ccomp -fno-postpass" +CCOMP_REF="../../../../CompCert_kvx/ccomp" +COUNT=0 + +if [ $WOFF -eq 1 ] +then + CCOMP_BBLOCKS="${CCOMP_BBLOCKS} -w" + CCOMP_REF="${CCOMP_REF} -w" +fi + +for files in ${DIRS[@]} +do + for f in $files + do + BNAME=$(basename -s .c $f) + SNAME="$BNAME".s + SREFNAME="$BNAME"_ref.s + ./$CCOMP_BBLOCKS -S $f -o $SNAME + ./$CCOMP_REF -dmach -S $f -o $SREFNAME + #diff -I '^//*' <(cut -c-5 $SNAME) <(cut -c-5 $SREFNAME) > /dev/null 2>&1 + diff -I '^//*' $SNAME $SREFNAME > /dev/null 2>&1 + + error=$? + if [ $error -eq 0 ] + then + echo "[$BNAME] OK" + COUNT=$((COUNT + 1)) + elif [ $error -eq 1 ] + then + echo "[$BNAME] FAIL" + diff -I '^//*' -y $SNAME $SREFNAME + exit 1 + else + echo "[$BNAME] FAIL" + echo "[WARNING] There was something wrong with the diff command !" + exit 1 + fi + done +done + +echo "[TOTAL] $COUNT tests PASSED" + +if [ $CLEAN -eq 1 ] +then + rm *.s *.mach +fi diff --git a/test/aarch64/postpass_tests/postpass_exec_c_test.sh b/test/aarch64/postpass_tests/postpass_exec_c_test.sh new file mode 100755 index 00000000..73422990 --- /dev/null +++ b/test/aarch64/postpass_tests/postpass_exec_c_test.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +CLEAN=0 +WOFF=0 +SRC="" +while getopts ':cwi:' 'OPTKEY'; do + case ${OPTKEY} in + c) CLEAN=1;; + w) WOFF=1;; + i) SRC=${OPTARG};; + esac +done + +CCOMP="../../../ccomp -static" + +if [ $WOFF -eq 1 ] +then + CCOMP="${CCOMP} -w" +fi + +BNAME=$(basename -s .c $SRC) +SNAME="$BNAME".s +SREFNAME="$BNAME"_ref.s +ENAME="$BNAME" +EREFNAME="$BNAME"_ref +./$CCOMP -S $SRC -o $SNAME +./$CCOMP -fno-postpass -S $SRC -o $SREFNAME +./$CCOMP $SRC -o $ENAME +./$CCOMP -fno-postpass $SRC -o $EREFNAME + +#diff -I '^//*' -y $SNAME $SREFNAME + +if [ $CLEAN -eq 1 ] +then + rm $SNAME $SREFNAME $ENAME $EREFNAME +fi diff --git a/test/c/Makefile b/test/c/Makefile index 9b42563a..85ffef43 100644 --- a/test/c/Makefile +++ b/test/c/Makefile @@ -1,7 +1,13 @@ include ../../Makefile.config CCOMP=../../ccomp +<<<<<<< HEAD CCOMPFLAGS=$(CCOMPOPTS) -stdlib ../../runtime -dc -dclight -dasm $(SSA_MODE) +======= +# TODO - temporary +# CCOMPOPTS:=$(CCOMPOPTS) -fall-loads-nontrap -fduplicate 2 -fprepass +CCOMPFLAGS=$(CCOMPOPTS) -stdlib ../../runtime -dc -dclight -dasm +>>>>>>> origin/kvx-work CFLAGS+=-O2 -Wall EXECUTE:=timeout --signal=SIGTERM 20s $(EXECUTE) diff --git a/test/clightgen/Makefile b/test/clightgen/Makefile index 0607e2fa..f0e9d961 100644 --- a/test/clightgen/Makefile +++ b/test/clightgen/Makefile @@ -5,8 +5,12 @@ ARCHDIRS=$(ARCH) else ARCHDIRS=$(ARCH)_$(BITSIZE) $(ARCH) endif -RECDIRS=lib common $(ARCHDIRS) cfrontend flocq exportclight -COQINCLUDES=$(foreach d, $(RECDIRS), -R ../../$(d) compcert.$(d)) +RECDIRS := lib common $(ARCHDIRS) cfrontend exportclight +COQINCLUDES := $(foreach d, $(RECDIRS), -R ../../$(d) compcert.$(d)) +ifeq ($(LIBRARY_FLOCQ),local) +COQINCLUDES += -R ../../flocq Flocq +endif + CLIGHTGEN=../../clightgen COQC=coqc @@ -22,6 +26,14 @@ SRC+=aes.c almabench.c binarytrees.c bisect.c chomp.c fannkuch.c fft.c \ SRC+=arrays.c eval.c gmllexer.c gmlparser.c intersect.c light.c main.c \ matrix.c memory.c object.c render.c simplify.c surface.c vector.c +CFLAGS=-DSYSTEM_$(SYSTEM) + +aes.vo almabench.vo binarytrees.vo bisect.vo chomp.vo: CFLAGS += -short-idents + +fft.vo fftsp.vo fftw.vo fib.vo integr.vo knucleotide.vo: CFLAGS += -short-idents -normalize + +qsort.vo sha1.vo sha3.vo siphash24.vo spectral.vo vmach.vo: CFLAGS += -normalize + all: $(SRC:.c=.vo) test: @@ -41,4 +53,4 @@ test: .SECONDARY: $(SRC:.c=.v) clean: - rm -f *.v *.vo .*.aux + rm -f *.v *.vo* .*.aux diff --git a/test/clightgen/annotations.c b/test/clightgen/annotations.c new file mode 100644 index 00000000..e91c7fbc --- /dev/null +++ b/test/clightgen/annotations.c @@ -0,0 +1,8 @@ +int f(int x, long y) +{ +#if !defined(SYSTEM_macosx) && !defined(SYSTEM_cygwin) + __builtin_ais_annot("x is %e1, y is %e2", x, y); +#endif + __builtin_annot("x is %1, y is %2", x, y); + return __builtin_annot_intval("x was here: %1", x); +} diff --git a/test/monniaux/picosat-965/onefile/picosat.c b/test/monniaux/picosat-965/onefile/picosat.c new file mode 100644 index 00000000..e1c18438 --- /dev/null +++ b/test/monniaux/picosat-965/onefile/picosat.c @@ -0,0 +1,25 @@ +typedef struct b b; +b *a; +struct b { + int c; + int d, **clshead; + int **ahead; + unsigned h; +} i; +b *j(); +int k(); +int main() { + a = j(); + k(a); +} +#define e(f) f - g->c +static void m(b *g, int *l) { + if (g) + *g->ahead = l; +} +b *j() { return &i; } +int k(b *g) { + if (g->d) + m(g, e(g->clshead[-1])); + return g->h; +} diff --git a/test/monniaux/picosat-965/onefile/testcmp.sh b/test/monniaux/picosat-965/onefile/testcmp.sh new file mode 100755 index 00000000..2228c675 --- /dev/null +++ b/test/monniaux/picosat-965/onefile/testcmp.sh @@ -0,0 +1,146 @@ +DEFINES="-DNALARM -DNZIP -DNGETRUSAGE -DNDEBUG" +COMPCERT=/local/monniaux/Kalray/mppa-RTLpathSE-verif-hash-junk +DATA=$COMPCERT/test/monniaux/picosat-965/tiny.dat +CCOMP="$COMPCERT/ccomp -fbitfields -fduplicate 2 -fall-loads-nontrap $DEFINES" +GCC="kvx-cos-gcc -O -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC0="gcc -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC1="gcc -O -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC2="gcc -O -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror -fsanitize=undefined -fsanitize=address $DEFINES" +HOSTCC3="gcc -O3 -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC4="clang -Wimplicit -Wuninitialized -Werror $DEFINES" +HOSTCC5="clang -Wimplicit -Wuninitialized -Werror -fsanitize=undefined -fsanitize=address $DEFINES" +CFILES="picosat.c" +SIMU="kvx-cluster --timeout=100000 -- " + +if ! $HOSTCC0 $CFILES -o picosat.cc0.host ; +then exit 30 ; +fi + +if ! $HOSTCC1 $CFILES -o picosat.cc1.host ; +then exit 31 ; +fi + +if ! $HOSTCC2 $CFILES -o picosat.cc2.host ; +then exit 32 ; +fi + +if ! $HOSTCC3 $CFILES -o picosat.cc3.host ; +then exit 33 ; +fi + +if ! $HOSTCC4 $CFILES -o picosat.cc4.host ; +then exit 34 ; +fi + +if ! $HOSTCC5 $CFILES -o picosat.cc5.host ; +then exit 35 ; +fi + +timeout 1 ./picosat.cc0.host $DATA 2>&1 > picosat.cc0.out +if [ $? -ge 100 ]; +then exit 40 ; +fi + +timeout 1 ./picosat.cc1.host $DATA 2>&1 > picosat.cc1.out +if [ $? -ge 100 ]; +then exit 41 ; +fi + +timeout 1 valgrind --log-file=picosat.cc0.valgrind.log ./picosat.cc0.host $DATA 2>&1 > picosat.cc0.valgrind.out +if [ $? -ge 100 ]; +then exit 50 ; +fi + +timeout 1 valgrind --log-file=picosat.cc1.valgrind.log ./picosat.cc1.host $DATA 2>&1 > picosat.cc1.valgrind.out +if [ $? -ge 100 ]; +then exit 51 ; +fi + +timeout 1 ./picosat.cc2.host $DATA 2>&1 > picosat.cc2.out +if [ $? -ge 100 ]; +then exit 42 ; +fi + +timeout 1 ./picosat.cc3.host $DATA 2>&1 > picosat.cc3.out +if [ $? -ge 100 ]; +then exit 43 ; +fi + +timeout 1 ./picosat.cc4.host $DATA 2>&1 > picosat.cc4.out +if [ $? -ge 100 ]; +then exit 44 ; +fi + +timeout 1 ./picosat.cc5.host $DATA 2>&1 > picosat.cc5.out +if [ $? -ge 100 ]; +then exit 45 ; +fi + +if ! cmp picosat.cc0.out picosat.cc1.out ; +then exit 60 ; +fi + +if ! cmp picosat.cc0.out picosat.cc0.valgrind.out ; +then exit 70 ; +fi + +if ! cmp picosat.cc1.out picosat.cc1.valgrind.out ; +then exit 61 ; +fi + +if ! cmp picosat.cc1.out picosat.cc2.out ; +then exit 62 ; +fi + +if ! cmp picosat.cc1.out picosat.cc3.out ; +then exit 63 ; +fi + +if ! $GCC $CFILES -o picosat.gcc.target ; +then exit 1 ; +fi + +if ! $CCOMP $CFILES -o picosat.ccomp.target ; +then exit 2 ; +fi + +if ! $CCOMP -fprepass -fprepass= list $CFILES -o picosat.prepass.target ; +then exit 3 ; +fi + +$SIMU ./picosat.gcc.target $DATA 2>&1 > picosat.gcc.out +if [ $? -ge 100 ]; +then exit 4 ; +fi + +if ! cmp picosat.gcc.out picosat.cc1.out ; +then exit 13 ; +fi + +if grep timeout picosat.gcc.out ; +then exit 8 ; +fi + +$SIMU ./picosat.ccomp.target $DATA 2>&1 > picosat.ccomp.out +if [ $? -ge 100 ]; +then exit 5 ; +fi + +if grep timeout picosat.ccomp.out ; +then exit 9 ; +fi + +if ! cmp picosat.gcc.out picosat.ccomp.out ; +then exit 6 ; +fi + +$SIMU ./picosat.prepass.target $DATA 2>&1 > picosat.prepass.out +if [ $? -ge 100 ]; +then exit 0 ; +fi + +if cmp picosat.gcc.out picosat.prepass.out ; +then exit 7 ; +fi + +exit 0 diff --git a/test/monniaux/picosat-965/small.dat b/test/monniaux/picosat-965/small.dat new file mode 100644 index 00000000..accb9054 --- /dev/null +++ b/test/monniaux/picosat-965/small.dat @@ -0,0 +1,2 @@ +p cnf 1 1 +1 0 diff --git a/test/monniaux/picosat-965/tiny.dat b/test/monniaux/picosat-965/tiny.dat new file mode 100644 index 00000000..1d89b303 --- /dev/null +++ b/test/monniaux/picosat-965/tiny.dat @@ -0,0 +1,2 @@ +p cnf 0 1 +0 diff --git a/test/monniaux/reduced_picosat/reduced_picosat.c b/test/monniaux/reduced_picosat/reduced_picosat.c new file mode 100644 index 00000000..eb9fdaf8 --- /dev/null +++ b/test/monniaux/reduced_picosat/reduced_picosat.c @@ -0,0 +1,23 @@ +typedef struct b b; +b *a; +struct b { + int c; + int d, **clshead; + int **ahead; + unsigned h; +} glob; +int k(); +int main() { + a = &glob; + k(a); +} +#define e(f) f - g->c +static void m(b *g, int *l) { + if (g) + *g->ahead = l; +} +int k(b *g) { + if (g->d) + m(g, e(g->clshead[-1])); + return g->h; +} diff --git a/test/monniaux/reduced_picosat/test_a.s b/test/monniaux/reduced_picosat/test_a.s new file mode 100644 index 00000000..c14cc8f9 --- /dev/null +++ b/test/monniaux/reduced_picosat/test_a.s @@ -0,0 +1,10 @@ + .text + .global dummyload + .type dummyload, @function +dummyload: + make $r0 = 0 + ;; + ld.s $r0 = -8[$r0] + ret + ;; + .size dummyload, .-dummyload diff --git a/test/monniaux/reduced_picosat/test_b.c b/test/monniaux/reduced_picosat/test_b.c new file mode 100644 index 00000000..a0fe625b --- /dev/null +++ b/test/monniaux/reduced_picosat/test_b.c @@ -0,0 +1,9 @@ +#include <stdio.h> +#include <stdint.h> +#include <inttypes.h> + +extern uint64_t dummyload(void); + +int main() { + printf("%" PRIu64 "\n", dummyload()); +} diff --git a/test/monniaux/reduced_picosat/testcmp.sh b/test/monniaux/reduced_picosat/testcmp.sh new file mode 100755 index 00000000..8dc93de9 --- /dev/null +++ b/test/monniaux/reduced_picosat/testcmp.sh @@ -0,0 +1,146 @@ +DEFINES="-DNALARM -DNZIP -DNGETRUSAGE -DNDEBUG" +COMPCERT=/home/monniaux/work/Kalray/mppa-RTLpathSE-verif-hash-junk +DATA=$COMPCERT/test/monniaux/picosat-965/tiny.dat +CCOMP="$COMPCERT/ccomp -fbitfields -fduplicate 2 -fall-loads-nontrap $DEFINES" +GCC="kvx-cos-gcc -O -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC0="gcc -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC1="gcc -O -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC2="gcc -O -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror -fsanitize=undefined -fsanitize=address $DEFINES" +HOSTCC3="gcc -O3 -Wimplicit -Wuninitialized -Wmaybe-uninitialized -Werror $DEFINES" +HOSTCC4="/usr/bin/clang -Wimplicit -Wuninitialized -Werror $DEFINES" +HOSTCC5="/usr/bin/clang -Wimplicit -Wuninitialized -Werror -fsanitize=undefined -fsanitize=address $DEFINES" +CFILES="reduced_picosat.c" +SIMU="kvx-cluster --timeout=10000000 -- " + +if ! $HOSTCC0 $CFILES -o picosat.cc0.host ; +then exit 30 ; +fi + +if ! $HOSTCC1 $CFILES -o picosat.cc1.host ; +then exit 31 ; +fi + +if ! $HOSTCC2 $CFILES -o picosat.cc2.host ; +then exit 32 ; +fi + +if ! $HOSTCC3 $CFILES -o picosat.cc3.host ; +then exit 33 ; +fi + +if ! $HOSTCC4 $CFILES -o picosat.cc4.host ; +then exit 34 ; +fi + +if ! $HOSTCC5 $CFILES -o picosat.cc5.host ; +then exit 35 ; +fi + +timeout 1 ./picosat.cc0.host $DATA 2>&1 > picosat.cc0.out +if [ $? -ge 100 ]; +then exit 40 ; +fi + +timeout 1 ./picosat.cc1.host $DATA 2>&1 > picosat.cc1.out +if [ $? -ge 100 ]; +then exit 41 ; +fi + +timeout 1 valgrind --log-file=picosat.cc0.valgrind.log ./picosat.cc0.host $DATA 2>&1 > picosat.cc0.valgrind.out +if [ $? -ge 100 ]; +then exit 50 ; +fi + +timeout 1 valgrind --log-file=picosat.cc1.valgrind.log ./picosat.cc1.host $DATA 2>&1 > picosat.cc1.valgrind.out +if [ $? -ge 100 ]; +then exit 51 ; +fi + +timeout 1 ./picosat.cc2.host $DATA 2>&1 > picosat.cc2.out +if [ $? -ge 100 ]; +then exit 42 ; +fi + +timeout 1 ./picosat.cc3.host $DATA 2>&1 > picosat.cc3.out +if [ $? -ge 100 ]; +then exit 43 ; +fi + +timeout 1 ./picosat.cc4.host $DATA 2>&1 > picosat.cc4.out +if [ $? -ge 100 ]; +then exit 44 ; +fi + +timeout 1 ./picosat.cc5.host $DATA 2>&1 > picosat.cc5.out +if [ $? -ge 100 ]; +then exit 45 ; +fi + +if ! cmp picosat.cc0.out picosat.cc1.out ; +then exit 60 ; +fi + +if ! cmp picosat.cc0.out picosat.cc0.valgrind.out ; +then exit 70 ; +fi + +if ! cmp picosat.cc1.out picosat.cc1.valgrind.out ; +then exit 61 ; +fi + +if ! cmp picosat.cc1.out picosat.cc2.out ; +then exit 62 ; +fi + +if ! cmp picosat.cc1.out picosat.cc3.out ; +then exit 63 ; +fi + +if ! $GCC $CFILES -o picosat.gcc.target ; +then exit 1 ; +fi + +if ! $CCOMP $CFILES -o picosat.ccomp.target ; +then exit 2 ; +fi + +if ! $CCOMP -fprepass -fprepass= list $CFILES -o picosat.prepass.target ; +then exit 3 ; +fi + +$SIMU ./picosat.gcc.target $DATA 2>&1 > picosat.gcc.out +if [ $? -ge 100 ]; +then exit 4 ; +fi + +if ! cmp picosat.gcc.out picosat.cc1.out ; +then exit 13 ; +fi + +if grep timeout picosat.gcc.out ; +then exit 8 ; +fi + +$SIMU ./picosat.ccomp.target $DATA 2>&1 > picosat.ccomp.out +if [ $? -ge 100 ]; +then exit 5 ; +fi + +if grep timeout picosat.ccomp.out ; +then exit 9 ; +fi + +if ! cmp picosat.gcc.out picosat.ccomp.out ; +then exit 6 ; +fi + +$SIMU ./picosat.prepass.target $DATA 2>&1 > picosat.prepass.out +if [ $? -ge 100 ]; +then exit 0 ; +fi + +if cmp picosat.gcc.out picosat.prepass.out ; +then exit 7 ; +fi + +exit 0 diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index cd0b1be4..cab957c0 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -21,15 +21,15 @@ MEASURES?=time ALL_CFLAGS+=-Wall -D__KVX_COS__ -DMAX_MEASURES=$(MAX_MEASURES) #ALL_CFLAGS+=-g ALL_GCCFLAGS+=$(ALL_CFLAGS) -std=c99 -Wextra -Werror=implicit -ALL_CCOMPFLAGS+=$(ALL_CFLAGS) +ALL_CCOMPFLAGS+=$(ALL_CFLAGS) # -fprofile-use= ../compcert_profiling.dat # The compilers -KVX_CC?=kvx-cos-gcc +KVX_CC?=kvx-elf-gcc KVX_CCOMP?=ccomp # Command to execute #EXECUTE_CYCLES?=timeout --signal=SIGTERM 3m kvx-cluster --syscall=libstd_scalls.so --cycle-based -- -EXECUTE_CYCLES?=kvx-cluster --syscall=libstd_scalls.so --cycle-based -- +EXECUTE_CYCLES?=kvx-cluster --enable-cache --syscall=libstd_scalls.so --cycle-based -- # You can define up to GCC4FLAGS and CCOMP4FLAGS GCC0FLAGS?=$(ALL_GCCFLAGS) -O0 @@ -37,11 +37,11 @@ GCC1FLAGS?=$(ALL_GCCFLAGS) -O1 GCC2FLAGS?=$(ALL_GCCFLAGS) -O2 GCC3FLAGS?=$(ALL_GCCFLAGS) -O3 GCC4FLAGS?= -CCOMP0FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fno-postpass -CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fpostpass= greedy -CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fno-if-conversion -CCOMP3FLAGS?=$(ALL_CCOMPFLAGS) -O2 -CCOMP4FLAGS?=$(ALL_CCOMPFLAGS) -O2 -ssa on +CCOMP0FLAGS?=$(ALL_CCOMPFLAGS) -O2 +CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fprepass= list +CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) -O2 -funrollsingle 30 +CCOMP3FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fprepass= list -funrollsingle 30 +CCOMP4FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fprepass= zigzag # Prefix names GCC0PREFIX?=.gcc.o0 @@ -49,11 +49,11 @@ GCC1PREFIX?=.gcc.o1 GCC2PREFIX?=.gcc.o2 GCC3PREFIX?=.gcc.o3 GCC4PREFIX?= -CCOMP0PREFIX?=.ccomp.nobundle -CCOMP1PREFIX?=.ccomp.greedy -CCOMP2PREFIX?=.ccomp.noif -CCOMP3PREFIX?=.ccomp -CCOMP4PREFIX?= +CCOMP0PREFIX?=.ccomp +CCOMP1PREFIX?=.ccomp.prepass_list +CCOMP2PREFIX?=.ccomp.unrollsingle_30 +CCOMP3PREFIX?=.ccomp.prepass_list-unrollsingle_30 +CCOMP4PREFIX?=.ccomp.prepass_zigzag # List of outfiles, updated by gen_rules OUTFILES:= diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile index 24dd19c3..f9efd5a0 100644 --- a/test/monniaux/yarpgen/Makefile +++ b/test/monniaux/yarpgen/Makefile @@ -39,6 +39,20 @@ TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(M TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX)) TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) # $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX)) +# FIXME - test000089 fails in CI in arm and armhf because of memory consumption during register allocation being too high +# Removing it from the pool +BADID:=89 +TESTS_C:=$(filter-out $(shell seq --format $(PREFIX)/func.c $(BADID) $(BADID)),$(TESTS_C)) +TESTS_C:=$(filter-out $(shell seq --format $(PREFIX)/driver.c $(BADID) $(BADID)),$(TESTS_C)) +TESTS_C:=$(filter-out $(shell seq --format $(PREFIX)/init.c $(BADID) $(BADID)),$(TESTS_C)) +TESTS_C:=$(filter-out $(shell seq --format $(PREFIX)/hash.c $(BADID) $(BADID)),$(TESTS_C)) +TESTS_C:=$(filter-out $(shell seq --format $(PREFIX)/check.c $(BADID) $(BADID)),$(TESTS_C)) +TESTS_C:=$(filter-out $(shell seq --format $(PREFIX)/init.h $(BADID) $(BADID)),$(TESTS_C)) +TESTS_CMP:=$(filter-out $(shell seq --format $(PREFIX)/example.target.cmp $(BADID) $(BADID)),$(TESTS_CMP)) +TESTS_GCC_HOST_OUT:=$(filter-out $(shell seq --format $(PREFIX)/example.gcc.host.out $(BADID) $(BADID)),$(TESTS_GCC_HOST_OUT)) +TESTS_CCOMP_TARGET_OUT:=$(filter-out $(shell seq --format $(PREFIX)/example.ccomp.target.out $(BADID) $(BADID)),$(TESTS_CCOMP_TARGET_OUT)) +TESTS_GCC_TARGET_OUT:=$(filter-out $(shell seq --format $(PREFIX)/example.gcc.target.out $(BADID) $(BADID)),$(TESTS_GCC_TARGET_OUT)) + all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_CMP) $(TESTS_C) tests_c: $(TESTS_C) diff --git a/test/regression/Makefile b/test/regression/Makefile index ffb62cdd..2ab3fad5 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -1,6 +1,8 @@ include ../../Makefile.config CCOMP=../../ccomp +# TODO - temporary +# CCOMPOPTS:=$(CCOMPOPTS) -fall-loads-nontrap -fduplicate 2 -fprepass CCOMPFLAGS=$(CCOMPOPTS) -stdlib ../../runtime \ -dparse -dc -dclight -dasm -fall \ -DARCH_$(ARCH) -DMODEL_$(MODEL) \ @@ -24,9 +26,8 @@ TESTS?=int32 int64 floats floats-basics floats-lit \ TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ bitfields5 bitfields6 bitfields7 bitfields8 \ - builtins-$(ARCH) alignas \ - varargs1 varargs2 varargs3 sections alias aligned\ - packedstruct1 packedstruct2 + builtins-common builtins-$(ARCH) packedstruct1 packedstruct2 alignas \ + varargs1 varargs2 varargs3 sections alias aligned ifeq ($(ARCH),kvx) TESTS_COMP:=$(filter-out packedstruct1,$(TESTS_COMP)) diff --git a/test/regression/Results/builtins-aarch64 b/test/regression/Results/builtins-aarch64 index c70432d8..7e3575e5 100644 --- a/test/regression/Results/builtins-aarch64 +++ b/test/regression/Results/builtins-aarch64 @@ -1,14 +1,7 @@ -bswap(12345678) = 78563412 -bswap16(1234) = 3412 -bswap64(123456789abcdef0) = f0debc9a78563412 -clz(12345678) = 3 -clzll(12345678) = 35 -clzll(1234567812345678) = 3 cls(1234567) = 10 cls(-9999) = 17 clsll(1234567) = 42 clsll(-9999) = 49 -fsqrt(3.141590) = 1.772453 fmadd(3.141590, 2.718000, 1.414000) = 9.952842 fmsub(3.141590, 2.718000, 1.414000) = -7.124842 fnmadd(3.141590, 2.718000, 1.414000) = -9.952842 diff --git a/test/regression/Results/builtins-arm b/test/regression/Results/builtins-arm index f637fb16..bfdad28d 100644 --- a/test/regression/Results/builtins-arm +++ b/test/regression/Results/builtins-arm @@ -1,9 +1,3 @@ -bswap(12345678) = 78563412 -bswap16(1234) = 3412 -clz(12345678) = 3 -clzll(12345678) = 35 -clzll(1234567812345678) = 3 -clzll(78563412) = 33 fsqrt(3.141590) = 1.772453 read_16_rev = 3412 read_32_rev = efbeadde diff --git a/test/regression/Results/builtins-common b/test/regression/Results/builtins-common new file mode 100644 index 00000000..8adf7bfb --- /dev/null +++ b/test/regression/Results/builtins-common @@ -0,0 +1,393 @@ +bswap(12345678) = 78563412 +bswap16(1234) = 3412 +bswap64(123456789abcdef0) = f0debc9a78563412 +clz(ffffffff) = 0 +clz(80000000) = 0 +clz(7fffffff) = 1 +clz(40000000) = 1 +clz(3fffffff) = 2 +clz(20000000) = 2 +clz(1fffffff) = 3 +clz(10000000) = 3 +clz(0fffffff) = 4 +clz(08000000) = 4 +clz(07ffffff) = 5 +clz(04000000) = 5 +clz(03ffffff) = 6 +clz(02000000) = 6 +clz(01ffffff) = 7 +clz(01000000) = 7 +clz(00ffffff) = 8 +clz(00800000) = 8 +clz(007fffff) = 9 +clz(00400000) = 9 +clz(003fffff) = 10 +clz(00200000) = 10 +clz(001fffff) = 11 +clz(00100000) = 11 +clz(000fffff) = 12 +clz(00080000) = 12 +clz(0007ffff) = 13 +clz(00040000) = 13 +clz(0003ffff) = 14 +clz(00020000) = 14 +clz(0001ffff) = 15 +clz(00010000) = 15 +clz(0000ffff) = 16 +clz(00008000) = 16 +clz(00007fff) = 17 +clz(00004000) = 17 +clz(00003fff) = 18 +clz(00002000) = 18 +clz(00001fff) = 19 +clz(00001000) = 19 +clz(00000fff) = 20 +clz(00000800) = 20 +clz(000007ff) = 21 +clz(00000400) = 21 +clz(000003ff) = 22 +clz(00000200) = 22 +clz(000001ff) = 23 +clz(00000100) = 23 +clz(000000ff) = 24 +clz(00000080) = 24 +clz(0000007f) = 25 +clz(00000040) = 25 +clz(0000003f) = 26 +clz(00000020) = 26 +clz(0000001f) = 27 +clz(00000010) = 27 +clz(0000000f) = 28 +clz(00000008) = 28 +clz(00000007) = 29 +clz(00000004) = 29 +clz(00000003) = 30 +clz(00000002) = 30 +clz(00000001) = 31 +clz(00000001) = 31 +clzll(ffffffffffffffff) = 0 +clzll(8000000000000000) = 0 +clzll(7fffffffffffffff) = 1 +clzll(4000000000000000) = 1 +clzll(3fffffffffffffff) = 2 +clzll(2000000000000000) = 2 +clzll(1fffffffffffffff) = 3 +clzll(1000000000000000) = 3 +clzll(0fffffffffffffff) = 4 +clzll(0800000000000000) = 4 +clzll(07ffffffffffffff) = 5 +clzll(0400000000000000) = 5 +clzll(03ffffffffffffff) = 6 +clzll(0200000000000000) = 6 +clzll(01ffffffffffffff) = 7 +clzll(0100000000000000) = 7 +clzll(00ffffffffffffff) = 8 +clzll(0080000000000000) = 8 +clzll(007fffffffffffff) = 9 +clzll(0040000000000000) = 9 +clzll(003fffffffffffff) = 10 +clzll(0020000000000000) = 10 +clzll(001fffffffffffff) = 11 +clzll(0010000000000000) = 11 +clzll(000fffffffffffff) = 12 +clzll(0008000000000000) = 12 +clzll(0007ffffffffffff) = 13 +clzll(0004000000000000) = 13 +clzll(0003ffffffffffff) = 14 +clzll(0002000000000000) = 14 +clzll(0001ffffffffffff) = 15 +clzll(0001000000000000) = 15 +clzll(0000ffffffffffff) = 16 +clzll(0000800000000000) = 16 +clzll(00007fffffffffff) = 17 +clzll(0000400000000000) = 17 +clzll(00003fffffffffff) = 18 +clzll(0000200000000000) = 18 +clzll(00001fffffffffff) = 19 +clzll(0000100000000000) = 19 +clzll(00000fffffffffff) = 20 +clzll(0000080000000000) = 20 +clzll(000007ffffffffff) = 21 +clzll(0000040000000000) = 21 +clzll(000003ffffffffff) = 22 +clzll(0000020000000000) = 22 +clzll(000001ffffffffff) = 23 +clzll(0000010000000000) = 23 +clzll(000000ffffffffff) = 24 +clzll(0000008000000000) = 24 +clzll(0000007fffffffff) = 25 +clzll(0000004000000000) = 25 +clzll(0000003fffffffff) = 26 +clzll(0000002000000000) = 26 +clzll(0000001fffffffff) = 27 +clzll(0000001000000000) = 27 +clzll(0000000fffffffff) = 28 +clzll(0000000800000000) = 28 +clzll(00000007ffffffff) = 29 +clzll(0000000400000000) = 29 +clzll(00000003ffffffff) = 30 +clzll(0000000200000000) = 30 +clzll(00000001ffffffff) = 31 +clzll(0000000100000000) = 31 +clzll(00000000ffffffff) = 32 +clzll(0000000080000000) = 32 +clzll(000000007fffffff) = 33 +clzll(0000000040000000) = 33 +clzll(000000003fffffff) = 34 +clzll(0000000020000000) = 34 +clzll(000000001fffffff) = 35 +clzll(0000000010000000) = 35 +clzll(000000000fffffff) = 36 +clzll(0000000008000000) = 36 +clzll(0000000007ffffff) = 37 +clzll(0000000004000000) = 37 +clzll(0000000003ffffff) = 38 +clzll(0000000002000000) = 38 +clzll(0000000001ffffff) = 39 +clzll(0000000001000000) = 39 +clzll(0000000000ffffff) = 40 +clzll(0000000000800000) = 40 +clzll(00000000007fffff) = 41 +clzll(0000000000400000) = 41 +clzll(00000000003fffff) = 42 +clzll(0000000000200000) = 42 +clzll(00000000001fffff) = 43 +clzll(0000000000100000) = 43 +clzll(00000000000fffff) = 44 +clzll(0000000000080000) = 44 +clzll(000000000007ffff) = 45 +clzll(0000000000040000) = 45 +clzll(000000000003ffff) = 46 +clzll(0000000000020000) = 46 +clzll(000000000001ffff) = 47 +clzll(0000000000010000) = 47 +clzll(000000000000ffff) = 48 +clzll(0000000000008000) = 48 +clzll(0000000000007fff) = 49 +clzll(0000000000004000) = 49 +clzll(0000000000003fff) = 50 +clzll(0000000000002000) = 50 +clzll(0000000000001fff) = 51 +clzll(0000000000001000) = 51 +clzll(0000000000000fff) = 52 +clzll(0000000000000800) = 52 +clzll(00000000000007ff) = 53 +clzll(0000000000000400) = 53 +clzll(00000000000003ff) = 54 +clzll(0000000000000200) = 54 +clzll(00000000000001ff) = 55 +clzll(0000000000000100) = 55 +clzll(00000000000000ff) = 56 +clzll(0000000000000080) = 56 +clzll(000000000000007f) = 57 +clzll(0000000000000040) = 57 +clzll(000000000000003f) = 58 +clzll(0000000000000020) = 58 +clzll(000000000000001f) = 59 +clzll(0000000000000010) = 59 +clzll(000000000000000f) = 60 +clzll(0000000000000008) = 60 +clzll(0000000000000007) = 61 +clzll(0000000000000004) = 61 +clzll(0000000000000003) = 62 +clzll(0000000000000002) = 62 +clzll(0000000000000001) = 63 +clzll(0000000000000001) = 63 +ctz(00000001) = 0 +ctz(ffffffff) = 0 +ctz(00000002) = 1 +ctz(fffffffe) = 1 +ctz(00000004) = 2 +ctz(fffffffc) = 2 +ctz(00000008) = 3 +ctz(fffffff8) = 3 +ctz(00000010) = 4 +ctz(fffffff0) = 4 +ctz(00000020) = 5 +ctz(ffffffe0) = 5 +ctz(00000040) = 6 +ctz(ffffffc0) = 6 +ctz(00000080) = 7 +ctz(ffffff80) = 7 +ctz(00000100) = 8 +ctz(ffffff00) = 8 +ctz(00000200) = 9 +ctz(fffffe00) = 9 +ctz(00000400) = 10 +ctz(fffffc00) = 10 +ctz(00000800) = 11 +ctz(fffff800) = 11 +ctz(00001000) = 12 +ctz(fffff000) = 12 +ctz(00002000) = 13 +ctz(ffffe000) = 13 +ctz(00004000) = 14 +ctz(ffffc000) = 14 +ctz(00008000) = 15 +ctz(ffff8000) = 15 +ctz(00010000) = 16 +ctz(ffff0000) = 16 +ctz(00020000) = 17 +ctz(fffe0000) = 17 +ctz(00040000) = 18 +ctz(fffc0000) = 18 +ctz(00080000) = 19 +ctz(fff80000) = 19 +ctz(00100000) = 20 +ctz(fff00000) = 20 +ctz(00200000) = 21 +ctz(ffe00000) = 21 +ctz(00400000) = 22 +ctz(ffc00000) = 22 +ctz(00800000) = 23 +ctz(ff800000) = 23 +ctz(01000000) = 24 +ctz(ff000000) = 24 +ctz(02000000) = 25 +ctz(fe000000) = 25 +ctz(04000000) = 26 +ctz(fc000000) = 26 +ctz(08000000) = 27 +ctz(f8000000) = 27 +ctz(10000000) = 28 +ctz(f0000000) = 28 +ctz(20000000) = 29 +ctz(e0000000) = 29 +ctz(40000000) = 30 +ctz(c0000000) = 30 +ctz(80000000) = 31 +ctz(80000000) = 31 +ctzll(0000000000000001) = 0 +ctzll(ffffffffffffffff) = 0 +ctzll(0000000000000002) = 1 +ctzll(fffffffffffffffe) = 1 +ctzll(0000000000000004) = 2 +ctzll(fffffffffffffffc) = 2 +ctzll(0000000000000008) = 3 +ctzll(fffffffffffffff8) = 3 +ctzll(0000000000000010) = 4 +ctzll(fffffffffffffff0) = 4 +ctzll(0000000000000020) = 5 +ctzll(ffffffffffffffe0) = 5 +ctzll(0000000000000040) = 6 +ctzll(ffffffffffffffc0) = 6 +ctzll(0000000000000080) = 7 +ctzll(ffffffffffffff80) = 7 +ctzll(0000000000000100) = 8 +ctzll(ffffffffffffff00) = 8 +ctzll(0000000000000200) = 9 +ctzll(fffffffffffffe00) = 9 +ctzll(0000000000000400) = 10 +ctzll(fffffffffffffc00) = 10 +ctzll(0000000000000800) = 11 +ctzll(fffffffffffff800) = 11 +ctzll(0000000000001000) = 12 +ctzll(fffffffffffff000) = 12 +ctzll(0000000000002000) = 13 +ctzll(ffffffffffffe000) = 13 +ctzll(0000000000004000) = 14 +ctzll(ffffffffffffc000) = 14 +ctzll(0000000000008000) = 15 +ctzll(ffffffffffff8000) = 15 +ctzll(0000000000010000) = 16 +ctzll(ffffffffffff0000) = 16 +ctzll(0000000000020000) = 17 +ctzll(fffffffffffe0000) = 17 +ctzll(0000000000040000) = 18 +ctzll(fffffffffffc0000) = 18 +ctzll(0000000000080000) = 19 +ctzll(fffffffffff80000) = 19 +ctzll(0000000000100000) = 20 +ctzll(fffffffffff00000) = 20 +ctzll(0000000000200000) = 21 +ctzll(ffffffffffe00000) = 21 +ctzll(0000000000400000) = 22 +ctzll(ffffffffffc00000) = 22 +ctzll(0000000000800000) = 23 +ctzll(ffffffffff800000) = 23 +ctzll(0000000001000000) = 24 +ctzll(ffffffffff000000) = 24 +ctzll(0000000002000000) = 25 +ctzll(fffffffffe000000) = 25 +ctzll(0000000004000000) = 26 +ctzll(fffffffffc000000) = 26 +ctzll(0000000008000000) = 27 +ctzll(fffffffff8000000) = 27 +ctzll(0000000010000000) = 28 +ctzll(fffffffff0000000) = 28 +ctzll(0000000020000000) = 29 +ctzll(ffffffffe0000000) = 29 +ctzll(0000000040000000) = 30 +ctzll(ffffffffc0000000) = 30 +ctzll(0000000080000000) = 31 +ctzll(ffffffff80000000) = 31 +ctzll(0000000100000000) = 32 +ctzll(ffffffff00000000) = 32 +ctzll(0000000200000000) = 33 +ctzll(fffffffe00000000) = 33 +ctzll(0000000400000000) = 34 +ctzll(fffffffc00000000) = 34 +ctzll(0000000800000000) = 35 +ctzll(fffffff800000000) = 35 +ctzll(0000001000000000) = 36 +ctzll(fffffff000000000) = 36 +ctzll(0000002000000000) = 37 +ctzll(ffffffe000000000) = 37 +ctzll(0000004000000000) = 38 +ctzll(ffffffc000000000) = 38 +ctzll(0000008000000000) = 39 +ctzll(ffffff8000000000) = 39 +ctzll(0000010000000000) = 40 +ctzll(ffffff0000000000) = 40 +ctzll(0000020000000000) = 41 +ctzll(fffffe0000000000) = 41 +ctzll(0000040000000000) = 42 +ctzll(fffffc0000000000) = 42 +ctzll(0000080000000000) = 43 +ctzll(fffff80000000000) = 43 +ctzll(0000100000000000) = 44 +ctzll(fffff00000000000) = 44 +ctzll(0000200000000000) = 45 +ctzll(ffffe00000000000) = 45 +ctzll(0000400000000000) = 46 +ctzll(ffffc00000000000) = 46 +ctzll(0000800000000000) = 47 +ctzll(ffff800000000000) = 47 +ctzll(0001000000000000) = 48 +ctzll(ffff000000000000) = 48 +ctzll(0002000000000000) = 49 +ctzll(fffe000000000000) = 49 +ctzll(0004000000000000) = 50 +ctzll(fffc000000000000) = 50 +ctzll(0008000000000000) = 51 +ctzll(fff8000000000000) = 51 +ctzll(0010000000000000) = 52 +ctzll(fff0000000000000) = 52 +ctzll(0020000000000000) = 53 +ctzll(ffe0000000000000) = 53 +ctzll(0040000000000000) = 54 +ctzll(ffc0000000000000) = 54 +ctzll(0080000000000000) = 55 +ctzll(ff80000000000000) = 55 +ctzll(0100000000000000) = 56 +ctzll(ff00000000000000) = 56 +ctzll(0200000000000000) = 57 +ctzll(fe00000000000000) = 57 +ctzll(0400000000000000) = 58 +ctzll(fc00000000000000) = 58 +ctzll(0800000000000000) = 59 +ctzll(f800000000000000) = 59 +ctzll(1000000000000000) = 60 +ctzll(f000000000000000) = 60 +ctzll(2000000000000000) = 61 +ctzll(e000000000000000) = 61 +ctzll(4000000000000000) = 62 +ctzll(c000000000000000) = 62 +ctzll(8000000000000000) = 63 +ctzll(8000000000000000) = 63 +fabs(3.141590) = 3.141590 +fabs(-3.141590) = 3.141590 +fabsf(7.250000) = 7.250000 +fabsf(-7.250000) = 7.250000 +fsqrt(3.141590) = 1.772453 +sqrt(3.141590) = 1.772453 diff --git a/test/regression/Results/builtins-common-kvx b/test/regression/Results/builtins-common-kvx new file mode 100644 index 00000000..fad75e7c --- /dev/null +++ b/test/regression/Results/builtins-common-kvx @@ -0,0 +1,391 @@ +bswap(12345678) = 78563412 +bswap16(1234) = 3412 +bswap64(123456789abcdef0) = f0debc9a78563412 +clz(ffffffff) = 0 +clz(80000000) = 0 +clz(7fffffff) = 1 +clz(40000000) = 1 +clz(3fffffff) = 2 +clz(20000000) = 2 +clz(1fffffff) = 3 +clz(10000000) = 3 +clz(0fffffff) = 4 +clz(08000000) = 4 +clz(07ffffff) = 5 +clz(04000000) = 5 +clz(03ffffff) = 6 +clz(02000000) = 6 +clz(01ffffff) = 7 +clz(01000000) = 7 +clz(00ffffff) = 8 +clz(00800000) = 8 +clz(007fffff) = 9 +clz(00400000) = 9 +clz(003fffff) = 10 +clz(00200000) = 10 +clz(001fffff) = 11 +clz(00100000) = 11 +clz(000fffff) = 12 +clz(00080000) = 12 +clz(0007ffff) = 13 +clz(00040000) = 13 +clz(0003ffff) = 14 +clz(00020000) = 14 +clz(0001ffff) = 15 +clz(00010000) = 15 +clz(0000ffff) = 16 +clz(00008000) = 16 +clz(00007fff) = 17 +clz(00004000) = 17 +clz(00003fff) = 18 +clz(00002000) = 18 +clz(00001fff) = 19 +clz(00001000) = 19 +clz(00000fff) = 20 +clz(00000800) = 20 +clz(000007ff) = 21 +clz(00000400) = 21 +clz(000003ff) = 22 +clz(00000200) = 22 +clz(000001ff) = 23 +clz(00000100) = 23 +clz(000000ff) = 24 +clz(00000080) = 24 +clz(0000007f) = 25 +clz(00000040) = 25 +clz(0000003f) = 26 +clz(00000020) = 26 +clz(0000001f) = 27 +clz(00000010) = 27 +clz(0000000f) = 28 +clz(00000008) = 28 +clz(00000007) = 29 +clz(00000004) = 29 +clz(00000003) = 30 +clz(00000002) = 30 +clz(00000001) = 31 +clz(00000001) = 31 +clzll(ffffffffffffffff) = 0 +clzll(8000000000000000) = 0 +clzll(7fffffffffffffff) = 1 +clzll(4000000000000000) = 1 +clzll(3fffffffffffffff) = 2 +clzll(2000000000000000) = 2 +clzll(1fffffffffffffff) = 3 +clzll(1000000000000000) = 3 +clzll(0fffffffffffffff) = 4 +clzll(0800000000000000) = 4 +clzll(07ffffffffffffff) = 5 +clzll(0400000000000000) = 5 +clzll(03ffffffffffffff) = 6 +clzll(0200000000000000) = 6 +clzll(01ffffffffffffff) = 7 +clzll(0100000000000000) = 7 +clzll(00ffffffffffffff) = 8 +clzll(0080000000000000) = 8 +clzll(007fffffffffffff) = 9 +clzll(0040000000000000) = 9 +clzll(003fffffffffffff) = 10 +clzll(0020000000000000) = 10 +clzll(001fffffffffffff) = 11 +clzll(0010000000000000) = 11 +clzll(000fffffffffffff) = 12 +clzll(0008000000000000) = 12 +clzll(0007ffffffffffff) = 13 +clzll(0004000000000000) = 13 +clzll(0003ffffffffffff) = 14 +clzll(0002000000000000) = 14 +clzll(0001ffffffffffff) = 15 +clzll(0001000000000000) = 15 +clzll(0000ffffffffffff) = 16 +clzll(0000800000000000) = 16 +clzll(00007fffffffffff) = 17 +clzll(0000400000000000) = 17 +clzll(00003fffffffffff) = 18 +clzll(0000200000000000) = 18 +clzll(00001fffffffffff) = 19 +clzll(0000100000000000) = 19 +clzll(00000fffffffffff) = 20 +clzll(0000080000000000) = 20 +clzll(000007ffffffffff) = 21 +clzll(0000040000000000) = 21 +clzll(000003ffffffffff) = 22 +clzll(0000020000000000) = 22 +clzll(000001ffffffffff) = 23 +clzll(0000010000000000) = 23 +clzll(000000ffffffffff) = 24 +clzll(0000008000000000) = 24 +clzll(0000007fffffffff) = 25 +clzll(0000004000000000) = 25 +clzll(0000003fffffffff) = 26 +clzll(0000002000000000) = 26 +clzll(0000001fffffffff) = 27 +clzll(0000001000000000) = 27 +clzll(0000000fffffffff) = 28 +clzll(0000000800000000) = 28 +clzll(00000007ffffffff) = 29 +clzll(0000000400000000) = 29 +clzll(00000003ffffffff) = 30 +clzll(0000000200000000) = 30 +clzll(00000001ffffffff) = 31 +clzll(0000000100000000) = 31 +clzll(00000000ffffffff) = 32 +clzll(0000000080000000) = 32 +clzll(000000007fffffff) = 33 +clzll(0000000040000000) = 33 +clzll(000000003fffffff) = 34 +clzll(0000000020000000) = 34 +clzll(000000001fffffff) = 35 +clzll(0000000010000000) = 35 +clzll(000000000fffffff) = 36 +clzll(0000000008000000) = 36 +clzll(0000000007ffffff) = 37 +clzll(0000000004000000) = 37 +clzll(0000000003ffffff) = 38 +clzll(0000000002000000) = 38 +clzll(0000000001ffffff) = 39 +clzll(0000000001000000) = 39 +clzll(0000000000ffffff) = 40 +clzll(0000000000800000) = 40 +clzll(00000000007fffff) = 41 +clzll(0000000000400000) = 41 +clzll(00000000003fffff) = 42 +clzll(0000000000200000) = 42 +clzll(00000000001fffff) = 43 +clzll(0000000000100000) = 43 +clzll(00000000000fffff) = 44 +clzll(0000000000080000) = 44 +clzll(000000000007ffff) = 45 +clzll(0000000000040000) = 45 +clzll(000000000003ffff) = 46 +clzll(0000000000020000) = 46 +clzll(000000000001ffff) = 47 +clzll(0000000000010000) = 47 +clzll(000000000000ffff) = 48 +clzll(0000000000008000) = 48 +clzll(0000000000007fff) = 49 +clzll(0000000000004000) = 49 +clzll(0000000000003fff) = 50 +clzll(0000000000002000) = 50 +clzll(0000000000001fff) = 51 +clzll(0000000000001000) = 51 +clzll(0000000000000fff) = 52 +clzll(0000000000000800) = 52 +clzll(00000000000007ff) = 53 +clzll(0000000000000400) = 53 +clzll(00000000000003ff) = 54 +clzll(0000000000000200) = 54 +clzll(00000000000001ff) = 55 +clzll(0000000000000100) = 55 +clzll(00000000000000ff) = 56 +clzll(0000000000000080) = 56 +clzll(000000000000007f) = 57 +clzll(0000000000000040) = 57 +clzll(000000000000003f) = 58 +clzll(0000000000000020) = 58 +clzll(000000000000001f) = 59 +clzll(0000000000000010) = 59 +clzll(000000000000000f) = 60 +clzll(0000000000000008) = 60 +clzll(0000000000000007) = 61 +clzll(0000000000000004) = 61 +clzll(0000000000000003) = 62 +clzll(0000000000000002) = 62 +clzll(0000000000000001) = 63 +clzll(0000000000000001) = 63 +ctz(00000001) = 0 +ctz(ffffffff) = 0 +ctz(00000002) = 1 +ctz(fffffffe) = 1 +ctz(00000004) = 2 +ctz(fffffffc) = 2 +ctz(00000008) = 3 +ctz(fffffff8) = 3 +ctz(00000010) = 4 +ctz(fffffff0) = 4 +ctz(00000020) = 5 +ctz(ffffffe0) = 5 +ctz(00000040) = 6 +ctz(ffffffc0) = 6 +ctz(00000080) = 7 +ctz(ffffff80) = 7 +ctz(00000100) = 8 +ctz(ffffff00) = 8 +ctz(00000200) = 9 +ctz(fffffe00) = 9 +ctz(00000400) = 10 +ctz(fffffc00) = 10 +ctz(00000800) = 11 +ctz(fffff800) = 11 +ctz(00001000) = 12 +ctz(fffff000) = 12 +ctz(00002000) = 13 +ctz(ffffe000) = 13 +ctz(00004000) = 14 +ctz(ffffc000) = 14 +ctz(00008000) = 15 +ctz(ffff8000) = 15 +ctz(00010000) = 16 +ctz(ffff0000) = 16 +ctz(00020000) = 17 +ctz(fffe0000) = 17 +ctz(00040000) = 18 +ctz(fffc0000) = 18 +ctz(00080000) = 19 +ctz(fff80000) = 19 +ctz(00100000) = 20 +ctz(fff00000) = 20 +ctz(00200000) = 21 +ctz(ffe00000) = 21 +ctz(00400000) = 22 +ctz(ffc00000) = 22 +ctz(00800000) = 23 +ctz(ff800000) = 23 +ctz(01000000) = 24 +ctz(ff000000) = 24 +ctz(02000000) = 25 +ctz(fe000000) = 25 +ctz(04000000) = 26 +ctz(fc000000) = 26 +ctz(08000000) = 27 +ctz(f8000000) = 27 +ctz(10000000) = 28 +ctz(f0000000) = 28 +ctz(20000000) = 29 +ctz(e0000000) = 29 +ctz(40000000) = 30 +ctz(c0000000) = 30 +ctz(80000000) = 31 +ctz(80000000) = 31 +ctzll(0000000000000001) = 0 +ctzll(ffffffffffffffff) = 0 +ctzll(0000000000000002) = 1 +ctzll(fffffffffffffffe) = 1 +ctzll(0000000000000004) = 2 +ctzll(fffffffffffffffc) = 2 +ctzll(0000000000000008) = 3 +ctzll(fffffffffffffff8) = 3 +ctzll(0000000000000010) = 4 +ctzll(fffffffffffffff0) = 4 +ctzll(0000000000000020) = 5 +ctzll(ffffffffffffffe0) = 5 +ctzll(0000000000000040) = 6 +ctzll(ffffffffffffffc0) = 6 +ctzll(0000000000000080) = 7 +ctzll(ffffffffffffff80) = 7 +ctzll(0000000000000100) = 8 +ctzll(ffffffffffffff00) = 8 +ctzll(0000000000000200) = 9 +ctzll(fffffffffffffe00) = 9 +ctzll(0000000000000400) = 10 +ctzll(fffffffffffffc00) = 10 +ctzll(0000000000000800) = 11 +ctzll(fffffffffffff800) = 11 +ctzll(0000000000001000) = 12 +ctzll(fffffffffffff000) = 12 +ctzll(0000000000002000) = 13 +ctzll(ffffffffffffe000) = 13 +ctzll(0000000000004000) = 14 +ctzll(ffffffffffffc000) = 14 +ctzll(0000000000008000) = 15 +ctzll(ffffffffffff8000) = 15 +ctzll(0000000000010000) = 16 +ctzll(ffffffffffff0000) = 16 +ctzll(0000000000020000) = 17 +ctzll(fffffffffffe0000) = 17 +ctzll(0000000000040000) = 18 +ctzll(fffffffffffc0000) = 18 +ctzll(0000000000080000) = 19 +ctzll(fffffffffff80000) = 19 +ctzll(0000000000100000) = 20 +ctzll(fffffffffff00000) = 20 +ctzll(0000000000200000) = 21 +ctzll(ffffffffffe00000) = 21 +ctzll(0000000000400000) = 22 +ctzll(ffffffffffc00000) = 22 +ctzll(0000000000800000) = 23 +ctzll(ffffffffff800000) = 23 +ctzll(0000000001000000) = 24 +ctzll(ffffffffff000000) = 24 +ctzll(0000000002000000) = 25 +ctzll(fffffffffe000000) = 25 +ctzll(0000000004000000) = 26 +ctzll(fffffffffc000000) = 26 +ctzll(0000000008000000) = 27 +ctzll(fffffffff8000000) = 27 +ctzll(0000000010000000) = 28 +ctzll(fffffffff0000000) = 28 +ctzll(0000000020000000) = 29 +ctzll(ffffffffe0000000) = 29 +ctzll(0000000040000000) = 30 +ctzll(ffffffffc0000000) = 30 +ctzll(0000000080000000) = 31 +ctzll(ffffffff80000000) = 31 +ctzll(0000000100000000) = 32 +ctzll(ffffffff00000000) = 32 +ctzll(0000000200000000) = 33 +ctzll(fffffffe00000000) = 33 +ctzll(0000000400000000) = 34 +ctzll(fffffffc00000000) = 34 +ctzll(0000000800000000) = 35 +ctzll(fffffff800000000) = 35 +ctzll(0000001000000000) = 36 +ctzll(fffffff000000000) = 36 +ctzll(0000002000000000) = 37 +ctzll(ffffffe000000000) = 37 +ctzll(0000004000000000) = 38 +ctzll(ffffffc000000000) = 38 +ctzll(0000008000000000) = 39 +ctzll(ffffff8000000000) = 39 +ctzll(0000010000000000) = 40 +ctzll(ffffff0000000000) = 40 +ctzll(0000020000000000) = 41 +ctzll(fffffe0000000000) = 41 +ctzll(0000040000000000) = 42 +ctzll(fffffc0000000000) = 42 +ctzll(0000080000000000) = 43 +ctzll(fffff80000000000) = 43 +ctzll(0000100000000000) = 44 +ctzll(fffff00000000000) = 44 +ctzll(0000200000000000) = 45 +ctzll(ffffe00000000000) = 45 +ctzll(0000400000000000) = 46 +ctzll(ffffc00000000000) = 46 +ctzll(0000800000000000) = 47 +ctzll(ffff800000000000) = 47 +ctzll(0001000000000000) = 48 +ctzll(ffff000000000000) = 48 +ctzll(0002000000000000) = 49 +ctzll(fffe000000000000) = 49 +ctzll(0004000000000000) = 50 +ctzll(fffc000000000000) = 50 +ctzll(0008000000000000) = 51 +ctzll(fff8000000000000) = 51 +ctzll(0010000000000000) = 52 +ctzll(fff0000000000000) = 52 +ctzll(0020000000000000) = 53 +ctzll(ffe0000000000000) = 53 +ctzll(0040000000000000) = 54 +ctzll(ffc0000000000000) = 54 +ctzll(0080000000000000) = 55 +ctzll(ff80000000000000) = 55 +ctzll(0100000000000000) = 56 +ctzll(ff00000000000000) = 56 +ctzll(0200000000000000) = 57 +ctzll(fe00000000000000) = 57 +ctzll(0400000000000000) = 58 +ctzll(fc00000000000000) = 58 +ctzll(0800000000000000) = 59 +ctzll(f800000000000000) = 59 +ctzll(1000000000000000) = 60 +ctzll(f000000000000000) = 60 +ctzll(2000000000000000) = 61 +ctzll(e000000000000000) = 61 +ctzll(4000000000000000) = 62 +ctzll(c000000000000000) = 62 +ctzll(8000000000000000) = 63 +ctzll(8000000000000000) = 63 +fabs(3.141590) = 3.141590 +fabs(-3.141590) = 3.141590 +fabsf(7.250000) = 7.250000 +fabsf(-7.250000) = 7.250000 diff --git a/test/regression/Results/builtins-powerpc b/test/regression/Results/builtins-powerpc index a3c63ad6..a37bfc63 100644 --- a/test/regression/Results/builtins-powerpc +++ b/test/regression/Results/builtins-powerpc @@ -1,16 +1,7 @@ mulhw(12345678, deadbeef) = fda16776 mulhwu(12345678, deadbeef) = fd5bdee -clz(12345678) = 3 -clzll(12345678) = 35 -clzll(1234567812345678) = 3 -clzll(78563412) = 33 -bswap(12345678) = 78563412 -bswap16(1234) = 3412 fmadd(3.141590, 2.718000, 1.414000) = 9.952842 fmsub(3.141590, 2.718000, 1.414000) = 7.124842 -fabs(3.141590) = 3.141590 -fabs(-3.141590) = 3.141590 -fsqrt(3.141590) = 1.772453 frsqrte(3.141590) = OK fres(3.141590) = OK fsel(3.141590, 2.718000, 1.414000) = 2.718000 diff --git a/test/regression/Results/builtins-riscV b/test/regression/Results/builtins-riscV index 1576b252..a14b7677 100644 --- a/test/regression/Results/builtins-riscV +++ b/test/regression/Results/builtins-riscV @@ -1,12 +1,6 @@ -bswap16(1234) = 3412 -bswap32(12345678) = 78563412 -bswap64(123456789abcdef0) = f0debc9a78563412 fmadd(3.141590, 2.718000, 1.414000) = 9.952842 fmsub(3.141590, 2.718000, 1.414000) = 7.124842 fnmadd(3.141590, 2.718000, 1.414000) = -9.952842 fnmsub(3.141590, 2.718000, 1.414000) = -7.124842 -fabs(3.141590) = 3.141590 -fabs(-3.141590) = 3.141590 -fsqrt(3.141590) = 1.772453 fmax(3.141590, 2.718000) = 3.141590 fmin(3.141590, 2.718000) = 2.718000 diff --git a/test/regression/Results/builtins-x86 b/test/regression/Results/builtins-x86 index 393ac1fd..7cd8838b 100644 --- a/test/regression/Results/builtins-x86 +++ b/test/regression/Results/builtins-x86 @@ -1,15 +1,3 @@ -bswap(12345678) = 78563412 -bswap16(1234) = 3412 -bswap64(123456789abcdef0) = f0debc9a78563412 -clz(12345678) = 3 -clzll(12345678) = 35 -clzll(1234567812345678) = 3 -clzll(78563412) = 33 -ctz(1234) = 2 -ctzll(1234567812345678) = 3 -ctzll(1234567800000000) = 35 -ctzll(78563412) = 1 -fsqrt(3.141590) = 1.772453 fmin(3.141590, 2.718000) = 2.718000 fmax(3.141590, 2.718000) = 3.141590 read_16_rev = 3412 diff --git a/test/regression/builtins-aarch64.c b/test/regression/builtins-aarch64.c index 2cfa2d09..671f65e3 100644 --- a/test/regression/builtins-aarch64.c +++ b/test/regression/builtins-aarch64.c @@ -1,43 +1,25 @@ -/* Fun with builtin functions */ +/* AArch64-specific builtin functions */ #include <stdio.h> int main(int argc, char ** argv) { - unsigned int x = 0x12345678; - unsigned int y = 0xDEADBEEF; - unsigned long long xx = 0x1234567812345678ULL; - unsigned long long yy = 0x1234567800000000ULL; - unsigned long long zz = 0x123456789ABCDEF0ULL; - unsigned z; double a = 3.14159; double b = 2.718; double c = 1.414; - unsigned short s = 0x1234; signed int u = 1234567; signed int v = -9999; - printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); - printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); - printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz)); - printf("clz(%x) = %d\n", x, __builtin_clz(x)); - printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); - printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); printf("cls(%d) = %d\n", u, __builtin_cls(u)); printf("cls(%d) = %d\n", v, __builtin_cls(v)); printf("clsll(%lld) = %d\n", (signed long long) u, __builtin_clsll(u)); printf("clsll(%lld) = %d\n", (signed long long) v, __builtin_clsll(v)); - printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c)); printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c)); printf("fnmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmadd(a, b, c)); printf("fnmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmsub(a, b, c)); - /* Make sure that ignoring the result of a builtin - doesn't cause an internal error */ - (void) __builtin_bswap(x); - (void) __builtin_fsqrt(a); return 0; } diff --git a/test/regression/builtins-arm.c b/test/regression/builtins-arm.c index d06e8e5e..85b611e8 100644 --- a/test/regression/builtins-arm.c +++ b/test/regression/builtins-arm.c @@ -1,10 +1,9 @@ -/* Fun with builtins */ +/* ARM-specific builtins */ #include <stdio.h> unsigned int x = 0x12345678; unsigned int y = 0xDEADBEEF; -unsigned long long xx = 0x1234567812345678ULL; double a = 3.14159; unsigned short s = 0x1234; @@ -12,13 +11,6 @@ int main(int argc, char ** argv) { unsigned z; - printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); - printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); - printf("clz(%x) = %d\n", x, __builtin_clz(x)); - printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); - printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); - z = __builtin_bswap(x); - printf("clzll(%lx) = %d\n", z, __builtin_clzll(z)); printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); printf ("read_16_rev = %x\n", __builtin_read16_reversed(&s)); diff --git a/test/regression/builtins-common.c b/test/regression/builtins-common.c new file mode 100644 index 00000000..72839a61 --- /dev/null +++ b/test/regression/builtins-common.c @@ -0,0 +1,58 @@ +/* Builtin functions that are implemented on all target processors */ + +#include <stdio.h> + +unsigned int x = 0x12345678; +unsigned int y = 0xDEADBEEF; +unsigned long long xx = 0x123456789ABCDEF0ULL; +double a = 3.14159; +double b = 2.718; +double c = 1.414; +float f = 7.25; +unsigned short s = 0x1234; + +int main(int argc, char ** argv) +{ + printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); + printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); + printf("bswap64(%llx) = %llx\n", xx, __builtin_bswap64(xx)); + for (int i = 0; i < 32; i++) { + unsigned z = 0xFFFFFFFFU >> i; + printf("clz(%08x) = %d\n", z, __builtin_clz(z)); + z = 0x80000000U >> i; + printf("clz(%08x) = %d\n", z, __builtin_clz(z)); + } + for (int i = 0; i < 64; i++) { + unsigned long long z = 0xFFFFFFFFFFFFFFFFULL >> i; + printf("clzll(%016llx) = %d\n", z, __builtin_clzll(z)); + z = 0x8000000000000000ULL >> i; + printf("clzll(%016llx) = %d\n", z, __builtin_clzll(z)); + } + for (int i = 0; i < 32; i++) { + unsigned z = 1U << i; + printf("ctz(%08x) = %d\n", z, __builtin_ctz(z)); + z = 0xFFFFFFFFU << i; + printf("ctz(%08x) = %d\n", z, __builtin_ctz(z)); + } + for (int i = 0; i < 64; i++) { + unsigned long long z = 1ULL << i; + printf("ctzll(%016llx) = %d\n", z, __builtin_ctzll(z)); + z = 0xFFFFFFFFFFFFFFFFULL << i; + printf("ctzll(%016llx) = %d\n", z, __builtin_ctzll(z)); + } + printf("fabs(%f) = %f\n", a, __builtin_fabs(a)); + printf("fabs(%f) = %f\n", -a, __builtin_fabs(-a)); + printf("fabsf(%f) = %f\n", f, __builtin_fabsf(f)); + printf("fabsf(%f) = %f\n", -f, __builtin_fabsf(-f)); +#ifndef __KVX__ // no builtin FSQRT or SQRT on KVX + printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); + printf("sqrt(%f) = %f\n", a, __builtin_sqrt(a)); +#endif + + /* Make sure that ignoring the result of a builtin + doesn't cause an internal error */ + (void) __builtin_bswap(x); + (void) __builtin_fsqrt(a); + (void) __builtin_sel(a > 0.0, x, y); + return 0; +} diff --git a/test/regression/builtins-powerpc.c b/test/regression/builtins-powerpc.c index 8fd5818b..55809106 100644 --- a/test/regression/builtins-powerpc.c +++ b/test/regression/builtins-powerpc.c @@ -1,4 +1,4 @@ -/* Fun with builtins */ +/* PowerPC-specific builtins */ #include <stdio.h> #include <math.h> @@ -11,7 +11,6 @@ char * check_relative_error(double exact, double actual, double precision) unsigned int x = 0x12345678; unsigned int y = 0xDEADBEEF; -unsigned long long xx = 0x1234567812345678ULL; double a = 3.14159; double b = 2.718; double c = 1.414; @@ -23,19 +22,9 @@ int main(int argc, char ** argv) printf("mulhw(%x, %x) = %x\n", x, y, __builtin_mulhw(x, y)); printf("mulhwu(%x, %x) = %x\n", x, y, __builtin_mulhwu(x, y)); - printf("clz(%x) = %d\n", x, __builtin_clz(x)); - printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); - printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); - z = __builtin_bswap(x); - printf("clzll(%lx) = %d\n", z, __builtin_clzll(z)); - printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); - printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c)); printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c)); - printf("fabs(%f) = %f\n", a, __builtin_fabs(a)); - printf("fabs(%f) = %f\n", -a, __builtin_fabs(-a)); - printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); printf("frsqrte(%f) = %s\n", a, check_relative_error(1.0 / sqrt(a), __builtin_frsqrte(a), 1./32.)); printf("fres(%f) = %s\n", diff --git a/test/regression/builtins-riscV.c b/test/regression/builtins-riscV.c index c34fdf2c..acd98e49 100644 --- a/test/regression/builtins-riscV.c +++ b/test/regression/builtins-riscV.c @@ -1,4 +1,4 @@ -/* Fun with builtins */ +/* RISC-V specific builtin functions */ #include <stdio.h> @@ -11,20 +11,11 @@ double c = 1.414; int main(int argc, char ** argv) { - printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); - printf("bswap32(%x) = %x\n", x, __builtin_bswap32(x)); - printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz)); printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c)); printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c)); printf("fnmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmadd(a, b, c)); printf("fnmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmsub(a, b, c)); - printf("fabs(%f) = %f\n", a, __builtin_fabs(a)); - printf("fabs(%f) = %f\n", -a, __builtin_fabs(-a)); - printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); printf("fmax(%f, %f) = %f\n", a, b, __builtin_fmax(a, b)); printf("fmin(%f, %f) = %f\n", a, b, __builtin_fmin(a, b)); - /* Make sure that ignoring the result of a builtin - doesn't cause an internal error */ - (void) __builtin_fsqrt(a); return 0; } diff --git a/test/regression/builtins-x86.c b/test/regression/builtins-x86.c index 6233f9fd..05d3ab93 100644 --- a/test/regression/builtins-x86.c +++ b/test/regression/builtins-x86.c @@ -4,9 +4,6 @@ unsigned int x = 0x12345678; unsigned int y = 0xDEADBEEF; -unsigned long long xx = 0x1234567812345678ULL; -unsigned long long yy = 0x1234567800000000ULL; -unsigned long long zz = 0x123456789ABCDEF0ULL; double a = 3.14159; double b = 2.718; double c = 1.414; @@ -14,22 +11,6 @@ unsigned short s = 0x1234; int main(int argc, char ** argv) { - unsigned z; - - printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); - printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); - printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz)); - printf("clz(%x) = %d\n", x, __builtin_clz(x)); - printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); - printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); - z = __builtin_bswap(x); - printf("clzll(%lx) = %d\n", z, __builtin_clzll(z)); - printf("ctz(%x) = %d\n", s, __builtin_ctz(s)); - printf("ctzll(%llx) = %d\n", xx, __builtin_ctzll(xx)); - printf("ctzll(%llx) = %d\n", yy, __builtin_ctzll(yy)); - printf("ctzll(%lx) = %d\n", z, __builtin_ctzll(z)); - - printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); printf("fmin(%f, %f) = %f\n", a, b, __builtin_fmin(a, b)); printf("fmax(%f, %f) = %f\n", a, b, __builtin_fmax(a, b)); diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index d8e13d48..561e4272 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -25,10 +25,10 @@ TOTAL, Always, Require, (Some "Renumbering"), "Renumber"; PARTIAL, (Option "optim_CSE"), Require, (Some "CSE"), "CSE"; PARTIAL, Always, NoRequire, (Some "Static Prediction + inverting conditions"), "Staticpredict"; PARTIAL, Always, NoRequire, (Some "Unrolling one iteration out of innermost loops"), "Unrollsingle"; -TOTAL, Always, NoRequire, (Some "Renumbering pre unroll"), "Renumber"; -PARTIAL, Always, NoRequire, (Some "Unrolling the body of innermost loops"), "Unrollbody"; TOTAL, Always, NoRequire, (Some "Renumbering pre tail duplication"), "Renumber"; PARTIAL, Always, NoRequire, (Some "Performing tail duplication"), "Tailduplicate"; +TOTAL, Always, NoRequire, (Some "Renumbering pre unrolling"), "Renumber"; +PARTIAL, Always, NoRequire, (Some "Unrolling the body of innermost loops"), "Unrollbody"; TOTAL, Always, NoRequire, (Some "Renumbering pre constprop"), "Renumber"; TOTAL, (Option "optim_constprop"), Require, (Some "Constant propagation"), "Constprop"; TOTAL, Always, NoRequire, (Some "Renumbering pre CSE"), "Renumber"; @@ -68,6 +68,9 @@ PARTIAL, (Option "optim_redundancy"), Require, (Some "Redundancy elimination"), let post_rtl_passes = [| + PARTIAL, Always, Require, (Some "RTLpath generation"), "RTLpathLivegen", Noprint; + PARTIAL, Always, Require, (Some "Prepass scheduling"), "RTLpathScheduler", Noprint; + TOTAL, Always, Require, (Some "Projection to RTL"), "RTLpath", (Print (Printf.sprintf "RTL %d" ((Array.length rtl_passes) + 1))); PARTIAL, Always, Require, (Some "Register allocation"), "Allocation", (Print "LTL 1"); PARTIAL, Always, Require, (Some "Branch tunneling"), "Tunneling", (Print "LTL 2"); PARTIAL, Always, Require, (Some "CFG linearization"), "Linearize", Noprint; diff --git a/tools/modorder.ml b/tools/modorder.ml index d1203568..7ca6a9e9 100644 --- a/tools/modorder.ml +++ b/tools/modorder.ml @@ -84,7 +84,7 @@ let filename_suffix s = let emit_dependencies deps targets = let rec dsort target suff = - match (try Some(Hashtbl.find deps target) with Not_found -> None) with + match Hashtbl.find_opt deps target with | None -> () | Some node -> match node.status with @@ -279,6 +279,7 @@ Inductive instruction: Type := | Pmaxsd (rd: freg) (r2: freg) | Pminsd (rd: freg) (r2: freg) | Pmovb_rm (rd: ireg) (a: addrmode) + | Pmovq_rf (rd: ireg) (r1: freg) | Pmovsq_mr (a: addrmode) (rs: freg) | Pmovsq_rm (rd: freg) (a: addrmode) | Pmovsb @@ -998,6 +999,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmaxsd _ _ | Pminsd _ _ | Pmovb_rm _ _ + | Pmovq_rf _ _ | Pmovsq_rm _ _ | Pmovsq_mr _ _ | Pmovsb diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index ad667e3d..20f5d170 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -44,7 +44,7 @@ let stack_alignment () = 16 let _Plea (r, addr) = if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr) -(* SP adjustment to allocate or free a stack frame *) +(* SP adjustment to allocate or free a stack frame. *) let align n a = if n >= 0 then (n + a - 1) land (-a) else n land (-a) @@ -56,7 +56,7 @@ let sp_adjustment_32 sz = (* The top 4 bytes have already been allocated by the "call" instruction. *) sz - 4 -let sp_adjustment_64 sz = +let sp_adjustment_elf64 sz = let sz = Z.to_int sz in if is_current_function_variadic() then begin (* If variadic, add room for register save area, which must be 16-aligned *) @@ -73,6 +73,13 @@ let sp_adjustment_64 sz = (sz - 8, -1) end +let sp_adjustment_win64 sz = + let sz = Z.to_int sz in + (* Preserve proper alignment of the stack *) + let sz = align sz 16 in + (* The top 8 bytes have already been allocated by the "call" instruction. *) + sz - 8 + (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack locations; generate no code; @@ -256,7 +263,7 @@ let expand_builtin_va_start_32 r = emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs))); emit (Pmovl_mr (linear_addr r _0z, RAX)) -let expand_builtin_va_start_64 r = +let expand_builtin_va_start_elf64 r = if not (is_current_function_variadic ()) then invalid_arg "Fatal error: va_start used in non-vararg function"; let (ir, fr, ofs) = @@ -287,6 +294,17 @@ let expand_builtin_va_start_64 r = emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area))); emit (Pmovq_mr (linear_addr r _16z, RAX)) +let expand_builtin_va_start_win64 r = + if not (is_current_function_variadic ()) then + invalid_arg "Fatal error: va_start used in non-vararg function"; + let num_args = + List.length (get_current_function_args()) in + let ofs = + Int64.(add !current_function_stacksize + (mul 8L (of_int num_args))) in + emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 ofs))); + emit (Pmovq_mr (linear_addr r _0z, RAX)) + (* FMA operations *) (* vfmadd<i><j><k> r1, r2, r3 performs r1 := ri * rj + rk @@ -378,11 +396,7 @@ let expand_builtin_inline name args res = emit (Paddl_ri(res, coqint_of_camlint 32l)); emit (Plabel lbl2) (* Float arithmetic *) - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> - if a1 <> res then - emit (Pmovsd_ff (res,a1)); - emit (Pabsd res) (* This ensures that need_masks is set to true *) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> + | ("__builtin_fsqrt" | "__builtin_sqrt"), [BA(FR a1)], BR(FR res) -> emit (Psqrtsd (res,a1)) | "__builtin_fmax", [BA(FR a1); BA(FR a2)], BR(FR res) -> if res = a1 then @@ -467,8 +481,8 @@ let expand_builtin_inline name args res = (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> assert (a = RDX); - if Archi.ptr64 - then expand_builtin_va_start_64 a + if Archi.win64 then expand_builtin_va_start_win64 a + else if Archi.ptr64 then expand_builtin_va_start_elf64 a else expand_builtin_va_start_32 a (* Synchronization *) | "__builtin_membar", [], _ -> @@ -480,24 +494,66 @@ let expand_builtin_inline name args res = | _ -> raise (Error ("unrecognized builtin " ^ name)) -(* Calls to variadic functions for x86-64: register AL must contain +(* Calls to variadic functions for x86-64 ELF: register AL must contain the number of XMM registers used for parameter passing. To be on - the safe side. do the same if the called function is + the safe side, do the same if the called function is unprototyped. *) -let set_al sg = - if Archi.ptr64 && (sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto) then begin +let fixup_funcall_elf64 sg = + if sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto then begin let (ir, fr, ofs) = next_arg_locations 0 0 0 sg.sig_args in emit (Pmovl_ri (RAX, coqint_of_camlint (Int32.of_int fr))) end +(* Calls to variadic functions for x86-64 Windows: + FP arguments passed in FP registers must also be passed in integer + registers. +*) + +let rec copy_fregs_to_iregs args fr ir = + match (ir, fr, args) with + | (i1 :: ir, f1 :: fr, (Tfloat | Tsingle) :: args) -> + emit (Pmovq_rf (i1, f1)); + copy_fregs_to_iregs args fr ir + | (i1 :: ir, f1 :: fr, _ :: args) -> + copy_fregs_to_iregs args fr ir + | _ -> + () + +let fixup_funcall_win64 sg = + if sg.sig_cc.cc_vararg then + copy_fregs_to_iregs sg.sig_args [XMM0; XMM1; XMM2; XMM3] [RCX; RDX; R8; R9] + +let fixup_funcall sg = + if Archi.ptr64 + then if Archi.win64 + then fixup_funcall_win64 sg + else fixup_funcall_elf64 sg + else () + (* Expansion of instructions *) let expand_instruction instr = match instr with | Pallocframe (sz, ofs_ra, ofs_link) -> - if Archi.ptr64 then begin - let (sz, save_regs) = sp_adjustment_64 sz in + if Archi.win64 then begin + let sz = sp_adjustment_win64 sz in + if is_current_function_variadic() then + (* Save parameters passed in registers in reserved stack area *) + emit (Pcall_s (intern_string "__compcert_va_saveregs", + {sig_args = []; sig_res = Tvoid; sig_cc = cc_default})); + (* Allocate frame *) + let sz' = Z.of_uint sz in + emit (Psubl_ri (RSP, sz')); + emit (Pcfi_adjust sz'); + (* Stack chaining *) + let addr1 = linear_addr RSP (Z.of_uint (sz + 8)) in + let addr2 = linear_addr RSP ofs_link in + emit (Pleaq (RAX,addr1)); + emit (Pmovq_mr (addr2, RAX)); + current_function_stacksize := Int64.of_int (sz + 8) + end else if Archi.ptr64 then begin + let (sz, save_regs) = sp_adjustment_elf64 sz in (* Allocate frame *) let sz' = Z.of_uint sz in emit (Psubq_ri (RSP, sz')); @@ -529,15 +585,18 @@ let expand_instruction instr = PrintAsmaux.current_function_stacksize := Int32.of_int sz end | Pfreeframe(sz, ofs_ra, ofs_link) -> - if Archi.ptr64 then begin - let (sz, _) = sp_adjustment_64 sz in + if Archi.win64 then begin + let sz = sp_adjustment_win64 sz in + emit (Paddq_ri (RSP, Z.of_uint sz)) + end else if Archi.ptr64 then begin + let (sz, _) = sp_adjustment_elf64 sz in emit (Paddq_ri (RSP, Z.of_uint sz)) end else begin let sz = sp_adjustment_32 sz in emit (Paddl_ri (RSP, Z.of_uint sz)) end | Pjmp_s(_, sg) | Pjmp_r(_, sg) | Pcall_s(_, sg) | Pcall_r(_, sg) -> - set_al sg; + fixup_funcall sg; emit instr | Pbuiltin (ef,args, res) -> begin diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml index e7f714c7..a16f3ef7 100644 --- a/x86/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -19,8 +19,12 @@ open C let (va_list_type, va_list_scalar, size_va_list) = if Archi.ptr64 then - (* Actually a struct passed by reference; equivalent to 3 64-bit words *) - (TArray(TInt(IULong, []), Some 3L, []), false, 3*8) + if Archi.win64 then + (* Just a pointer *) + (TPtr(TVoid [], []), true, 8) + else + (* Actually a struct passed by reference; equivalent to 3 64-bit words *) + (TArray(TInt(IULong, []), Some 3L, []), false, 3*8) else (* Just a pointer *) (TPtr(TVoid [], []), true, 4) @@ -30,19 +34,6 @@ let builtins = { "__builtin_va_list", va_list_type; ]; builtin_functions = [ - (* Integer arithmetic *) - "__builtin_clz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_clzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_clzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); - "__builtin_ctz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_ctzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_ctzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); (* Float arithmetic *) "__builtin_fmax", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); diff --git a/x86/CSE2deps.v b/x86/CSE2deps.v index a4b47a5c..757966b8 100644 --- a/x86/CSE2deps.v +++ b/x86/CSE2deps.v @@ -32,5 +32,7 @@ Definition may_overlap chunk addr args chunk' addr' args' := if peq symb symb' then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) else false + | (Ainstack ofs), (Ainstack ofs'), _, _ => + negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) | _, _, _, _ => true end. diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v index fd088962..e181b8f4 100644 --- a/x86/CSE2depsproof.v +++ b/x86/CSE2depsproof.v @@ -20,11 +20,79 @@ Require Import Registers Op RTL. Require Import CSE2 CSE2deps. Require Import Lia. +Lemma ptrofs_modulus : + Ptrofs.modulus = if Archi.ptr64 + then 18446744073709551616 + else 4294967296. +Proof. + reflexivity. +Qed. + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. Variable sp : val. +Section STACK_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Ainstack ofsw) nil = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Ainstack ofsr) nil = Some addrr. + + Lemma stack_load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + inv ADDRR. + inv ADDRW. + + destruct sp; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + all: try rewrite ptrofs_modulus in *. + all: destruct Archi.ptr64. + + all: intuition lia. + Qed. + + Theorem stack_load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply stack_load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End STACK_WRITE. + Section MEMORY_WRITE. Variable m m2 : mem. Variable chunkw chunkr : memory_chunk. @@ -237,7 +305,7 @@ Proof. intros until rs. intros ADDR ADDR' OVERLAP STORE. destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) +- (* Aindexed / Aindexed *) destruct args as [ | base [ | ]]. 1,3: discriminate. destruct args' as [ | base' [ | ]]. 1,3: discriminate. simpl in OVERLAP. @@ -247,8 +315,7 @@ Proof. 2: discriminate. simpl in *. eapply load_store_away; eassumption. - } - { (* Aglobal / Aglobal *) +- (* Aglobal / Aglobal *) destruct args. 2: discriminate. destruct args'. 2: discriminate. simpl in *. @@ -259,7 +326,14 @@ Proof. eapply load_store_glob_away; eassumption. } eapply load_store_diff_globals; eassumption. - } +- (* Ainstack / Ainstack *) + destruct args. 2: discriminate. + destruct args'. 2: discriminate. + cbn in OVERLAP. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + cbn in *. + eapply stack_load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. Qed. End SOUNDNESS. diff --git a/x86/ConstpropOp.vp b/x86/ConstpropOp.vp index ada8d54a..dd4b839a 100644 --- a/x86/ConstpropOp.vp +++ b/x86/ConstpropOp.vp @@ -17,11 +17,10 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats. Require Import Op Registers. Require Import ValueDomain ValueAOp. +Require SelectOp. (** * Converting known values to constants *) -Parameter symbol_is_external: ident -> bool. (**r See [SelectOp] *) - Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a. Definition const_for_result (a: aval) : option operation := @@ -31,7 +30,7 @@ Definition const_for_result (a: aval) : option operation := | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None | Ptr(Gl id ofs) => - if symbol_is_external id then + if SelectOp.symbol_is_external id then if Ptrofs.eq ofs Ptrofs.zero then Some (Oindirectsymbol id) else None else Some (Olea_ptr (Aglobal id ofs)) diff --git a/x86/ConstpropOpproof.v b/x86/ConstpropOpproof.v index 6d2df9c1..82179fa4 100644 --- a/x86/ConstpropOpproof.v +++ b/x86/ConstpropOpproof.v @@ -107,7 +107,7 @@ Proof. - (* pointer *) destruct p; try discriminate; SimplVM. + (* global *) - destruct (symbol_is_external id). + destruct (SelectOp.symbol_is_external id). * revert H2; predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero; intros EQ; inv EQ. exists (Genv.symbol_address ge id Ptrofs.zero); auto. * inv H2. exists (Genv.symbol_address ge id ofs); split. diff --git a/x86/Conventions1.v b/x86/Conventions1.v index d9f5b8fa..b4cb233e 100644 --- a/x86/Conventions1.v +++ b/x86/Conventions1.v @@ -32,40 +32,44 @@ Definition is_callee_save (r: mreg) : bool := match r with | AX | CX | DX => false | BX | BP => true - | SI | DI => negb Archi.ptr64 (**r callee-save in 32 bits but not in 64 bits *) + | SI | DI => negb Archi.ptr64 || Archi.win64 (**r callee-save in ELF 64 bits *) | R8 | R9 | R10 | R11 => false | R12 | R13 | R14 | R15 => true | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => false - | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => false + | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => Archi.win64 | FP0 => false end. Definition int_caller_save_regs := if Archi.ptr64 - then AX :: CX :: DX :: SI :: DI :: R8 :: R9 :: R10 :: R11 :: nil + then if Archi.win64 + then AX :: CX :: DX :: R8 :: R9 :: R10 :: R11 :: nil + else AX :: CX :: DX :: SI :: DI :: R8 :: R9 :: R10 :: R11 :: nil else AX :: CX :: DX :: nil. Definition float_caller_save_regs := if Archi.ptr64 - then X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: - X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: nil + then if Archi.win64 + then X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: nil + else X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: + X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: nil else X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. Definition int_callee_save_regs := if Archi.ptr64 - then BX :: BP :: R12 :: R13 :: R14 :: R15 :: nil + then if Archi.win64 + then BX :: SI :: DI :: BP :: R12 :: R13 :: R14 :: R15 :: nil + else BX :: BP :: R12 :: R13 :: R14 :: R15 :: nil else BX :: SI :: DI :: BP :: nil. -Definition float_callee_save_regs : list mreg := nil. +Definition float_callee_save_regs := + if Archi.ptr64 && Archi.win64 + then X6 :: X7 :: X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: nil + else nil. Definition destroyed_at_call := List.filter (fun r => negb (is_callee_save r)) all_mregs. -Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *) -Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *) - -Definition callee_save_type := mreg_type. - Definition is_float_reg (r: mreg) := match r with | AX | BX | CX | DX | SI | DI | BP @@ -74,6 +78,11 @@ Definition is_float_reg (r: mreg) := | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 | FP0 => true end. +Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *) +Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *) + +Definition callee_save_type := mreg_type. + (** * Function calling conventions *) (** The functions in this section determine the locations (machine registers @@ -182,7 +191,7 @@ Fixpoint loc_arguments_32 :: loc_arguments_32 tys (ofs + typesize ty) end. -(** In the x86-64 ABI: +(** In the x86-64 ELF ABI: - The first 6 integer arguments are passed in registers [DI], [SI], [DX], [CX], [R8], [R9]. - The first 8 floating-point arguments are passed in registers [X0] to [X7]. - Extra arguments are passed on the stack, in [Outgoing] slots. @@ -190,26 +199,62 @@ Fixpoint loc_arguments_32 of data is used in a slot. *) -Definition int_param_regs := DI :: SI :: DX :: CX :: R8 :: R9 :: nil. -Definition float_param_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. +Definition int_param_regs_elf64 := DI :: SI :: DX :: CX :: R8 :: R9 :: nil. +Definition float_param_regs_elf64 := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. -Fixpoint loc_arguments_64 +Fixpoint loc_arguments_elf64 (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) := match tyl with | nil => nil | (Tint | Tlong | Tany32 | Tany64) as ty :: tys => - match list_nth_z int_param_regs ir with + match list_nth_z int_param_regs_elf64 ir with | None => - One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2) + One (S Outgoing ofs ty) :: loc_arguments_elf64 tys ir fr (ofs + 2) | Some ireg => - One (R ireg) :: loc_arguments_64 tys (ir + 1) fr ofs + One (R ireg) :: loc_arguments_elf64 tys (ir + 1) fr ofs end | (Tfloat | Tsingle) as ty :: tys => - match list_nth_z float_param_regs fr with + match list_nth_z float_param_regs_elf64 fr with | None => - One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2) + One (S Outgoing ofs ty) :: loc_arguments_elf64 tys ir fr (ofs + 2) | Some freg => - One (R freg) :: loc_arguments_64 tys ir (fr + 1) ofs + One (R freg) :: loc_arguments_elf64 tys ir (fr + 1) ofs + end + end. + +(** In the x86-64 Win64 ABI: +- The first 4 arguments are passed in registers [RCX], [RDX], [R8], and [R9] + (for integer arguments) and [X0] to [X3] (for floating-point arguments). + Each argument "burns" both an integer register and a FP integer. +- The first 8 floating-point arguments are passed in registers [X0] to [X7]. +- Extra arguments are passed on the stack, in [Outgoing] slots. + Consecutive stack slots are separated by 8 bytes, even if only 4 bytes + of data is used in a slot. +- Four 8-byte words are always reserved at the bottom of the outgoing area + so that the callee can use them to save the registers containing the + first four arguments. This is handled in the Stacking phase. +*) + +Definition int_param_regs_win64 := CX :: DX :: R8 :: R9 :: nil. +Definition float_param_regs_win64 := X0 :: X1 :: X2 :: X3 :: nil. + +Fixpoint loc_arguments_win64 + (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | (Tint | Tlong | Tany32 | Tany64) as ty :: tys => + match list_nth_z int_param_regs_win64 r with + | None => + One (S Outgoing ofs ty) :: loc_arguments_win64 tys r (ofs + 2) + | Some ireg => + One (R ireg) :: loc_arguments_win64 tys (r + 1) ofs + end + | (Tfloat | Tsingle) as ty :: tys => + match list_nth_z float_param_regs_win64 r with + | None => + One (S Outgoing ofs ty) :: loc_arguments_win64 tys r (ofs + 2) + | Some freg => + One (R freg) :: loc_arguments_win64 tys (r + 1) ofs end end. @@ -218,7 +263,9 @@ Fixpoint loc_arguments_64 Definition loc_arguments (s: signature) : list (rpair loc) := if Archi.ptr64 - then loc_arguments_64 s.(sig_args) 0 0 0 + then if Archi.win64 + then loc_arguments_win64 s.(sig_args) 0 0 + else loc_arguments_elf64 s.(sig_args) 0 0 0 else loc_arguments_32 s.(sig_args) 0. (** Argument locations are either caller-save registers or [Outgoing] @@ -237,9 +284,16 @@ Definition loc_argument_32_charact (ofs: Z) (l: loc) : Prop := | _ => False end. -Definition loc_argument_64_charact (ofs: Z) (l: loc) : Prop := +Definition loc_argument_elf64_charact (ofs: Z) (l: loc) : Prop := + match l with + | R r => In r int_param_regs_elf64 \/ In r float_param_regs_elf64 + | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs') + | _ => False + end. + +Definition loc_argument_win64_charact (ofs: Z) (l: loc) : Prop := match l with - | R r => In r int_param_regs \/ In r float_param_regs + | R r => In r int_param_regs_win64 \/ In r float_param_regs_win64 | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs') | _ => False end. @@ -259,37 +313,75 @@ Proof. * destruct H; split; eapply X; eauto; omega. Qed. -Remark loc_arguments_64_charact: +Remark loc_arguments_elf64_charact: forall tyl ir fr ofs p, - In p (loc_arguments_64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_64_charact ofs) p. + In p (loc_arguments_elf64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_elf64_charact ofs) p. Proof. - assert (X: forall ofs1 ofs2 l, loc_argument_64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_64_charact ofs1 l). + assert (X: forall ofs1 ofs2 l, loc_argument_elf64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_elf64_charact ofs1 l). { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } - assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_64_charact ofs1) p). + assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_elf64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_elf64_charact ofs1) p). { destruct p; simpl; intuition eauto. } assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). { intros. apply Z.divide_add_r; auto. apply Z.divide_refl. } Opaque list_nth_z. - induction tyl; simpl loc_arguments_64; intros. + induction tyl; simpl loc_arguments_elf64; intros. elim H. assert (A: forall ty, In p - match list_nth_z int_param_regs ir with - | Some ireg => One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs - | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2) + match list_nth_z int_param_regs_elf64 ir with + | Some ireg => One (R ireg) :: loc_arguments_elf64 tyl (ir + 1) fr ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_elf64 tyl ir fr (ofs + 2) end -> - forall_rpair (loc_argument_64_charact ofs) p). - { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1. + forall_rpair (loc_argument_elf64_charact ofs) p). + { intros. destruct (list_nth_z int_param_regs_elf64 ir) as [r|] eqn:E; destruct H1. subst. left. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. subst. split. omega. assumption. eapply Y; eauto. omega. } assert (B: forall ty, In p - match list_nth_z float_param_regs fr with - | Some ireg => One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs - | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2) + match list_nth_z float_param_regs_elf64 fr with + | Some ireg => One (R ireg) :: loc_arguments_elf64 tyl ir (fr + 1) ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_elf64 tyl ir fr (ofs + 2) end -> - forall_rpair (loc_argument_64_charact ofs) p). - { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1. + forall_rpair (loc_argument_elf64_charact ofs) p). + { intros. destruct (list_nth_z float_param_regs_elf64 fr) as [r|] eqn:E; destruct H1. + subst. right. eapply list_nth_z_in; eauto. + eapply IHtyl; eauto. + subst. split. omega. assumption. + eapply Y; eauto. omega. } + destruct a; eauto. +Qed. + +Remark loc_arguments_win64_charact: + forall tyl r ofs p, + In p (loc_arguments_win64 tyl r ofs) -> (2 | ofs) -> forall_rpair (loc_argument_win64_charact ofs) p. +Proof. + assert (X: forall ofs1 ofs2 l, loc_argument_win64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_win64_charact ofs1 l). + { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } + assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_win64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_win64_charact ofs1) p). + { destruct p; simpl; intuition eauto. } + assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). + { intros. apply Z.divide_add_r; auto. apply Z.divide_refl. } +Opaque list_nth_z. + induction tyl; simpl loc_arguments_win64; intros. + elim H. + assert (A: forall ty, In p + match list_nth_z int_param_regs_win64 r with + | Some ireg => One (R ireg) :: loc_arguments_win64 tyl (r + 1) ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_win64 tyl r (ofs + 2) + end -> + forall_rpair (loc_argument_win64_charact ofs) p). + { intros. destruct (list_nth_z int_param_regs_win64 r) as [r'|] eqn:E; destruct H1. + subst. left. eapply list_nth_z_in; eauto. + eapply IHtyl; eauto. + subst. split. omega. assumption. + eapply Y; eauto. omega. } + assert (B: forall ty, In p + match list_nth_z float_param_regs_win64 r with + | Some ireg => One (R ireg) :: loc_arguments_win64 tyl (r + 1) ofs + | None => One (S Outgoing ofs ty) :: loc_arguments_win64 tyl r (ofs + 2) + end -> + forall_rpair (loc_argument_win64_charact ofs) p). + { intros. destruct (list_nth_z float_param_regs_win64 r) as [r'|] eqn:E; destruct H1. subst. right. eapply list_nth_z_in; eauto. eapply IHtyl; eauto. subst. split. omega. assumption. @@ -301,18 +393,30 @@ Lemma loc_arguments_acceptable: forall (s: signature) (p: rpair loc), In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. Proof. - unfold loc_arguments; intros. destruct Archi.ptr64 eqn:SF. -- (* 64 bits *) - assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by (unfold is_callee_save; rewrite SF; decide_goal). - assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal. - assert (X: forall l, loc_argument_64_charact 0 l -> loc_argument_acceptable l). - { unfold loc_argument_64_charact, loc_argument_acceptable. + unfold loc_arguments; intros. destruct Archi.ptr64 eqn:SF; [destruct Archi.win64 eqn:W64|]. +- (* WIN 64 bits *) + assert (A: forall r, In r int_param_regs_win64 -> is_callee_save r = false) by (unfold is_callee_save; rewrite SF; decide_goal). + assert (B: forall r, In r float_param_regs_win64 -> is_callee_save r = false) by (unfold is_callee_save; decide_goal). + assert (X: forall l, loc_argument_win64_charact 0 l -> loc_argument_acceptable l). + { unfold loc_argument_win64_charact, loc_argument_acceptable. destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto. intros [C D]. split; auto. apply Z.divide_trans with 2; auto. exists (2 / typealign ty); destruct ty; reflexivity. } - exploit loc_arguments_64_charact; eauto using Z.divide_0_r. + exploit loc_arguments_win64_charact; eauto using Z.divide_0_r. unfold forall_rpair; destruct p; intuition auto. +- (* ELF 64 bits *) + assert (A: forall r, In r int_param_regs_elf64 -> is_callee_save r = false) by (unfold is_callee_save; rewrite SF, W64; decide_goal). + assert (B: forall r, In r float_param_regs_elf64 -> is_callee_save r = false) by (unfold is_callee_save; rewrite W64; decide_goal). + assert (X: forall l, loc_argument_elf64_charact 0 l -> loc_argument_acceptable l). + { unfold loc_argument_elf64_charact, loc_argument_acceptable. + destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto. + intros [C D]. split; auto. apply Z.divide_trans with 2; auto. + exists (2 / typealign ty); destruct ty; reflexivity. + } + exploit loc_arguments_elf64_charact; eauto using Z.divide_0_r. + unfold forall_rpair; destruct p; intuition auto. + - (* 32 bits *) assert (X: forall l, loc_argument_32_charact 0 l -> loc_argument_acceptable l). { destruct l as [r | [] ofs ty]; simpl; intuition auto. rewrite H2; apply Z.divide_1_l. } @@ -325,7 +429,7 @@ Hint Resolve loc_arguments_acceptable: locs. Lemma loc_arguments_main: loc_arguments signature_main = nil. Proof. - unfold loc_arguments; destruct Archi.ptr64; reflexivity. + unfold loc_arguments; destruct Archi.ptr64; auto; destruct Archi.win64; auto. Qed. (** ** Normalization of function results *) diff --git a/x86/Machregsaux.ml b/x86/Machregsaux.ml index 80066b00..840943e7 100644 --- a/x86/Machregsaux.ml +++ b/x86/Machregsaux.ml @@ -12,25 +12,7 @@ (** Auxiliary functions on machine registers *) -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - let is_scratch_register r = false - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = Conventions1.is_callee_save r let class_of_type = function | AST.Tint | AST.Tlong -> 0 diff --git a/x86/Machregsaux.mli b/x86/Machregsaux.mli index d7117c21..01b0f9fd 100644 --- a/x86/Machregsaux.mli +++ b/x86/Machregsaux.mli @@ -12,9 +12,6 @@ (** Auxiliary functions on machine registers *) -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool val class_of_type: AST.typ -> int @@ -1037,6 +1037,20 @@ Proof. auto. Qed. +Lemma op_valid_pointer_eq: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op eqn:OP; simpl; try congruence. + - intros MEM; destruct cond; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + - intro MEM; destruct c; simpl; try congruence; + repeat (destruct args; simpl; try congruence); + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. +Qed. + (** Global variables mentioned in an operation or addressing mode *) Definition globals_addressing (addr: addressing) : list ident := diff --git a/x86/PrepassSchedulingOracle.ml b/x86/PrepassSchedulingOracle.ml new file mode 100644 index 00000000..7b6a1b14 --- /dev/null +++ b/x86/PrepassSchedulingOracle.ml @@ -0,0 +1,5 @@ +open RTL +open Registers + +(* Do not do anything *) +let schedule_sequence (seqa : (instruction*Regset.t) array) = None diff --git a/x86/Stacklayout.v b/x86/Stacklayout.v index d375febf..4f68cf26 100644 --- a/x86/Stacklayout.v +++ b/x86/Stacklayout.v @@ -15,11 +15,13 @@ Require Import Coqlib. Require Import AST Memory Separation. Require Import Bounds. +Require Archi. Local Open Scope sep_scope. (** The general shape of activation records is as follows, from bottom (lowest offsets) to top: +- For the Win64 ABI: 32 reserved bytes - Space for outgoing arguments to function calls. - Back link to parent frame - Saved values of integer callee-save registers used by the function. @@ -29,11 +31,11 @@ Local Open Scope sep_scope. - Return address. *) -Definition fe_ofs_arg := 0. +Definition fe_ofs_arg := if Archi.win64 then 32 else 0. Definition make_env (b: bounds) : frame_env := let w := if Archi.ptr64 then 8 else 4 in - let olink := align (4 * b.(bound_outgoing)) w in (* back link *) + let olink := align (fe_ofs_arg + 4 * b.(bound_outgoing)) w in (* back link *) let ocs := olink + w in (* callee-saves *) let ol := align (size_callee_save_area b ocs) 8 in (* locals *) let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) @@ -61,7 +63,7 @@ Proof. Local Opaque Z.add Z.mul sepconj range. intros; simpl. set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). + set (olink := align (fe_ofs_arg + 4 * b.(bound_outgoing)) w). set (ocs := olink + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). @@ -69,8 +71,9 @@ Local Opaque Z.add Z.mul sepconj range. replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= fe_ofs_arg) by (unfold fe_ofs_arg; destruct Archi.win64; omega). assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (fe_ofs_arg + 4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). assert (olink + w <= ocs) by (unfold ocs; omega). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). @@ -87,7 +90,7 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap45. rewrite sep_swap34. (* Apply range_split and range_split2 repeatedly *) - unfold fe_ofs_arg. + apply range_drop_left with 0. omega. apply range_split_2. fold olink. omega. omega. apply range_split. omega. apply range_split_2. fold ol. omega. omega. @@ -105,15 +108,16 @@ Lemma frame_env_range: Proof. intros; simpl. set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). + set (olink := align (fe_ofs_arg + 4 * b.(bound_outgoing)) w). set (ocs := olink + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= fe_ofs_arg) by (unfold fe_ofs_arg; destruct Archi.win64; omega). assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (fe_ofs_arg + 4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). assert (olink + w <= ocs) by (unfold ocs; omega). assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). @@ -133,14 +137,14 @@ Lemma frame_env_aligned: Proof. intros; simpl. set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). + set (olink := align (fe_ofs_arg + 4 * b.(bound_outgoing)) w). set (ocs := olink + w). set (ol := align (size_callee_save_area b ocs) 8). set (ostkdata := align (ol + 4 * b.(bound_local)) 8). set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). - split. apply Z.divide_0_r. + split. exists (fe_ofs_arg / 8). unfold fe_ofs_arg; destruct Archi.win64; reflexivity. split. apply align_divides; omega. split. apply align_divides; omega. split. apply align_divides; omega. diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 38eff731..52955dcb 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -238,7 +238,7 @@ module MacOS_System : SYSTEM = if i || (not !Clflags.option_fcommon) then ".const" else "COMM" | Section_string -> ".const" | Section_literal -> ".literal8" - | Section_jumptable -> ".text" (* needed in 64 bits, not a problem in 32 bits *) + | Section_jumptable -> ".text" | Section_user(s, wr, ex) -> sprintf ".section \"%s\", %s, %s" (if wr then "__DATA" else "__TEXT") s @@ -257,32 +257,14 @@ module MacOS_System : SYSTEM = let print_align oc n = fprintf oc " .align %d\n" (log2 n) - let indirect_symbols : StringSet.t ref = ref StringSet.empty - let print_mov_rs oc rd id = - if Archi.ptr64 then begin - fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd - end else begin - let id = extern_atom id in - indirect_symbols := StringSet.add id !indirect_symbols; - fprintf oc " movl L%a$non_lazy_ptr, %a\n" raw_symbol id ireg rd - end + fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd let print_fun_info _ _ = () let print_var_info _ _ = () - let print_epilogue oc = - if not Archi.ptr64 then begin - fprintf oc " .section __IMPORT,__pointers,non_lazy_symbol_pointers\n"; - StringSet.iter - (fun s -> - fprintf oc "L%a$non_lazy_ptr:\n" raw_symbol s; - fprintf oc " .indirect_symbol %a\n" raw_symbol s; - fprintf oc " .long 0\n") - !indirect_symbols; - indirect_symbols := StringSet.empty - end + let print_epilogue oc = () let print_comm_decl oc name sz al = fprintf oc " .comm %a, %s, %d\n" @@ -298,8 +280,11 @@ module MacOS_System : SYSTEM = module Cygwin_System : SYSTEM = struct + let symbol_prefix = + if Archi.ptr64 then "" else "_" + let raw_symbol oc s = - fprintf oc "_%s" s + fprintf oc "%s%s" symbol_prefix s let symbol oc symb = raw_symbol oc (extern_atom symb) @@ -329,19 +314,39 @@ module Cygwin_System : SYSTEM = | Section_debug_str-> assert false (* Should not be used *) | Section_ais_annotation -> assert false (* Not supported for coff binaries *) - let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) + let stack_alignment = 8 + (* minimum is 4 for 32 bits, 8 for 64 bits; 8 is better for perfs *) let print_align oc n = fprintf oc " .balign %d\n" n + let indirect_symbols : StringSet.t ref = ref StringSet.empty + let print_mov_rs oc rd id = - fprintf oc " movl $%a, %a\n" symbol id ireg rd + if Archi.ptr64 then begin + let s = extern_atom id in + indirect_symbols := StringSet.add s !indirect_symbols; + fprintf oc " movq .refptr.%s(%%rip), %a\n" s ireg rd + end else begin + fprintf oc " movl $%a, %a\n" symbol id ireg rd + end let print_fun_info _ _ = () let print_var_info _ _ = () - let print_epilogue _ = () + let declare_indirect_symbol oc s = + fprintf oc " .section .rdata$.refptr.%s, \"dr\"\n" s; + fprintf oc " .globl .refptr.%s\n" s; + fprintf oc " .linkonce discard\n"; + fprintf oc ".refptr.%s:\n" s; + fprintf oc " .quad %s\n" s + + let print_epilogue oc = + if Archi.ptr64 then begin + StringSet.iter (declare_indirect_symbol oc) !indirect_symbols; + indirect_symbols := StringSet.empty + end let print_comm_decl oc name sz al = fprintf oc " .comm %a, %s, %d\n" @@ -349,7 +354,8 @@ module Cygwin_System : SYSTEM = let print_lcomm_decl oc name sz al = fprintf oc " .lcomm %a, %s, %d\n" - symbol name (Z.to_string sz) (log2 al) + symbol name (Z.to_string sz) + (if Archi.ptr64 then al else log2 al) end @@ -850,6 +856,8 @@ module Target(System: SYSTEM):TARGET = fprintf oc " minsd %a, %a\n" freg a1 freg res | Pmovb_rm (rd,a) -> fprintf oc " movb %a, %a\n" addressing a ireg8 rd + | Pmovq_rf (rd, r1) -> + fprintf oc " movq %a, %a\n" freg r1 ireg64 rd | Pmovsq_mr(a, rs) -> fprintf oc " movq %a, %a\n" freg rs addressing a | Pmovsq_rm(rd, a) -> diff --git a/x86/extractionMachdep.v b/x86/extractionMachdep.v index a29553e8..20c6a521 100644 --- a/x86/extractionMachdep.v +++ b/x86/extractionMachdep.v @@ -15,15 +15,19 @@ (* Additional extraction directives specific to the x86-64 port *) -Require SelectOp ConstpropOp. +Require Archi SelectOp. -(* SelectOp *) - -Extract Constant SelectOp.symbol_is_external => - "fun id -> Configuration.system = ""macosx"" && C2C.atom_is_extern id". +(* Archi *) -(* ConstpropOp *) +Extract Constant Archi.win64 => + "match Configuration.system with + | ""cygwin"" when ptr64 -> true + | _ -> false". -Extract Constant ConstpropOp.symbol_is_external => - "fun id -> Configuration.system = ""macosx"" && C2C.atom_is_extern id". +(* SelectOp *) +Extract Constant SelectOp.symbol_is_external => + "match Configuration.system with + | ""macosx"" -> C2C.atom_is_extern + | ""cygwin"" when Archi.ptr64 -> C2C.atom_is_extern + | _ -> (fun _ -> false)". diff --git a/x86_32/Archi.v b/x86_32/Archi.v index 4681784d..facb5879 100644 --- a/x86_32/Archi.v +++ b/x86_32/Archi.v @@ -16,9 +16,8 @@ (** Architecture-dependent parameters for x86 in 32-bit mode *) +From Flocq Require Import Binary Bits. Require Import ZArith List. -(*From Flocq*) -Require Import Binary Bits. Definition ptr64 := false. @@ -59,6 +58,9 @@ Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. +(** Which ABI to use. *) +Parameter win64: bool. (* Always false in 32 bits *) + Global Opaque ptr64 big_endian splitlong default_nan_64 choose_nan_64 default_nan_32 choose_nan_32 diff --git a/x86_64/Archi.v b/x86_64/Archi.v index 0e3c55f8..87f727bd 100644 --- a/x86_64/Archi.v +++ b/x86_64/Archi.v @@ -16,9 +16,8 @@ (** Architecture-dependent parameters for x86 in 64-bit mode *) +From Flocq Require Import Binary Bits. Require Import ZArith List. -(*From Flocq*) -Require Import Binary Bits. Definition ptr64 := true. @@ -59,6 +58,9 @@ Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. +(** Which ABI to use. *) +Parameter win64: bool. + Global Opaque ptr64 big_endian splitlong default_nan_64 choose_nan_64 default_nan_32 choose_nan_32 |