diff options
122 files changed, 5853 insertions, 4300 deletions
@@ -1,6 +1,6 @@ All files in this distribution are part of the CompCert verified compiler. -The CompCert verified compiler is Copyright by Institut National de +The CompCert verified compiler is Copyright by Institut National de Recherche en Informatique et en Automatique (INRIA) and AbsInt Angewandte Informatik GmbH. @@ -9,12 +9,12 @@ INRIA Non-Commercial License Agreement given below or under the terms of a Software Usage Agreement of AbsInt Angewandte Informatik GmbH. The latter is a separate contract document. -The INRIA Non-Commercial License Agreement is a non-free license that -grants you the right to use the CompCert verified compiler for -educational, research or evaluation purposes only, but prohibits +The INRIA Non-Commercial License Agreement is a non-free license that +grants you the right to use the CompCert verified compiler for +educational, research or evaluation purposes only, but prohibits any commercial use. -For commercial use you need a Software Usage Agreement from +For commercial use you need a Software Usage Agreement from AbsInt Angewandte Informatik GmbH. The following files in this distribution are dual-licensed both under @@ -38,7 +38,7 @@ option) any later version: cfrontend/Ctyping.v cfrontend/PrintClight.ml cfrontend/PrintCsyntax.ml - + backend/Cminor.v backend/PrintCminor.ml @@ -46,7 +46,7 @@ option) any later version: all files in the exportclight/ directory - the Archi.v, CBuiltins.ml, and extractionMachdep.v files + the Archi.v, CBuiltins.ml, and extractionMachdep.v files in directories arm, powerpc, riscV, x86, x86_32, x86_64 extraction/extraction.v @@ -64,11 +64,14 @@ non-commercial contexts, subject to the terms of the GNU General Public License. The files contained in the flocq/ directory and its subdirectories are -taken from the Flocq project, http://flocq.gforge.inria.fr/ -These files are Copyright 2010-2017 INRIA and distributed under the -terms of the GNU Lesser General Public Licence, either version 3 of -the licence, or (at your option) any later version. A copy of the GNU -Lesser General Public Licence version 3 is included below. +taken from the Flocq project, http://flocq.gforge.inria.fr/. The files +contained in the MenhirLib directory are taken from the Menhir +project, http://gallium.inria.fr/~fpottier/menhir/. The files from the +Flocq project and the files in the MenhirLib directory are Copyright +2010-2019 INRIA and distributed under the terms of the GNU Lesser +General Public Licence, either version 3 of the licence, or (at your +option) any later version. A copy of the GNU Lesser General Public +Licence version 3 is included below. The files contained in the runtime/ directory and its subdirectories are Copyright 2013-2017 INRIA and distributed under the terms of the BSD @@ -25,9 +25,10 @@ BACKENDLIB?=Asmgenproof0.v Asmgenproof1.v DIRS=lib common $(ARCHDIRS) backend cfrontend driver \ flocq/Core flocq/Prop flocq/Calc flocq/IEEE754 \ - exportclight cparser cparser/MenhirLib + exportclight MenhirLib cparser -RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight cparser +RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight \ + MenhirLib cparser COQINCLUDES=$(foreach d, $(RECDIRS), -R $(d) $(subst /,.,compcert.$(d))) @@ -64,7 +65,7 @@ VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ COMMON=Errors.v AST.v Linking.v \ Events.v Globalenvs.v Memdata.v Memtype.v Memory.v \ Values.v Smallstep.v Behaviors.v Switch.v Determinism.v Unityping.v \ - Separation.v + Separation.v Builtins0.v Builtins1.v Builtins.v # Back-end modules (in backend/, $(ARCH)/) @@ -106,16 +107,16 @@ CFRONTEND=Ctypes.v Cop.v Csyntax.v Csem.v Ctyping.v Cstrategy.v Cexec.v \ Cshmgen.v Cshmgenproof.v \ Csharpminor.v Cminorgen.v Cminorgenproof.v -# LR(1) parser validator - -PARSERVALIDATOR=Alphabet.v Interpreter_complete.v Interpreter.v \ - Validator_complete.v Automaton.v Interpreter_correct.v Main.v \ - Validator_safe.v Grammar.v Interpreter_safe.v Tuples.v - # Parser PARSER=Cabs.v Parser.v +# 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 + # Putting everything together (in driver/) DRIVER=Compopts.v Compiler.v Complements.v @@ -123,7 +124,7 @@ DRIVER=Compopts.v Compiler.v Complements.v # All source files FILES=$(VLIB) $(COMMON) $(BACKEND) $(CFRONTEND) $(DRIVER) $(FLOCQ) \ - $(PARSERVALIDATOR) $(PARSER) + $(MENHIRLIB) $(PARSER) # Generated source files @@ -145,7 +146,6 @@ ifeq ($(CLIGHTGEN),true) $(MAKE) clightgen endif - proof: $(FILES:.v=.vo) # Turn off some warnings for compiling Flocq @@ -229,7 +229,7 @@ driver/Version.ml: VERSION cparser/Parser.v: cparser/Parser.vy @rm -f $@ - $(MENHIR) $(MENHIR_FLAGS) --coq cparser/Parser.vy + $(MENHIR) --coq --coq-lib-path compcert.MenhirLib --coq-no-version-check cparser/Parser.vy @chmod a-w $@ depend: $(GENERATED) depend1 diff --git a/Makefile.extr b/Makefile.extr index d6a94d2e..c903d6fd 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -49,9 +49,10 @@ 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 -extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45 -extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45 +WARNINGS=-w +a-4-9-27 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03 +extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60 +extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60 + cparser/pre_parser.cmx: WARNINGS += -w -41 cparser/pre_parser.cmo: WARNINGS += -w -41 diff --git a/MenhirLib/Alphabet.v b/MenhirLib/Alphabet.v new file mode 100644 index 00000000..29070e3d --- /dev/null +++ b/MenhirLib/Alphabet.v @@ -0,0 +1,247 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import Omega List Syntax Relations RelationClasses. + +Local Obligation Tactic := intros. + +(** A comparable type is equiped with a [compare] function, that define an order + relation. **) +Class Comparable (A:Type) := { + compare : A -> A -> comparison; + compare_antisym : forall x y, CompOpp (compare x y) = compare y x; + compare_trans : forall x y z c, + (compare x y) = c -> (compare y z) = c -> (compare x z) = c +}. + +Theorem compare_refl {A:Type} (C: Comparable A) : + forall x, compare x x = Eq. +Proof. +intros. +pose proof (compare_antisym x x). +destruct (compare x x); intuition; try discriminate. +Qed. + +(** The corresponding order is a strict order. **) +Definition comparableLt {A:Type} (C: Comparable A) : relation A := + fun x y => compare x y = Lt. + +Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) : + StrictOrder (comparableLt C). +Proof. +apply Build_StrictOrder. +unfold Irreflexive, Reflexive, complement, comparableLt. +intros. +pose proof H. +rewrite <- compare_antisym in H. +rewrite H0 in H. +discriminate H. +unfold Transitive, comparableLt. +intros x y z. +apply compare_trans. +Qed. + +(** nat is comparable. **) +Program Instance natComparable : Comparable nat := + { compare := Nat.compare }. +Next Obligation. +symmetry. +destruct (Nat.compare x y) as [] eqn:?. +rewrite Nat.compare_eq_iff in Heqc. +destruct Heqc. +rewrite Nat.compare_eq_iff. +trivial. +rewrite <- nat_compare_lt in *. +rewrite <- nat_compare_gt in *. +trivial. +rewrite <- nat_compare_lt in *. +rewrite <- nat_compare_gt in *. +trivial. +Qed. +Next Obligation. +destruct c. +rewrite Nat.compare_eq_iff in *; destruct H; assumption. +rewrite <- nat_compare_lt in *. +apply (Nat.lt_trans _ _ _ H H0). +rewrite <- nat_compare_gt in *. +apply (gt_trans _ _ _ H H0). +Qed. + +(** A pair of comparable is comparable. **) +Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) : + Comparable (A*B) := + { compare := fun x y => + let (xa, xb) := x in let (ya, yb) := y in + match compare xa ya return comparison with + | Eq => compare xb yb + | x => x + end }. +Next Obligation. +destruct x, y. +rewrite <- (compare_antisym a a0). +rewrite <- (compare_antisym b b0). +destruct (compare a a0); intuition. +Qed. +Next Obligation. +destruct x, y, z. +destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?; +try (rewrite <- H0 in H; discriminate); +try (destruct (compare a a1) as [] eqn:?; + try (rewrite <- compare_antisym in Heqc0; + rewrite CompOpp_iff in Heqc0; + rewrite (compare_trans _ _ _ _ Heqc0 Heqc2) in Heqc1; + discriminate); + try (rewrite <- compare_antisym in Heqc1; + rewrite CompOpp_iff in Heqc1; + rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0; + discriminate); + assumption); +rewrite (compare_trans _ _ _ _ Heqc0 Heqc1); +try assumption. +apply (compare_trans _ _ _ _ H H0). +Qed. + +(** Special case of comparable, where equality is Leibniz equality. **) +Class ComparableLeibnizEq {A:Type} (C: Comparable A) := + compare_eq : forall x y, compare x y = Eq -> x = y. + +(** Boolean equality for a [Comparable]. **) +Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) := + match compare x y with + | Eq => true + | _ => false + end. + +Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableLeibnizEq C} : + forall x y, compare_eqb x y = true <-> x = y. +Proof. +unfold compare_eqb. +intuition. +apply compare_eq. +destruct (compare x y); intuition; discriminate. +destruct H. +rewrite compare_refl; intuition. +Qed. + +Instance NComparableLeibnizEq : ComparableLeibnizEq natComparable := Nat.compare_eq. + +(** A pair of ComparableLeibnizEq is ComparableLeibnizEq **) +Instance PairComparableLeibnizEq + {A:Type} {CA:Comparable A} (UA:ComparableLeibnizEq CA) + {B:Type} {CB:Comparable B} (UB:ComparableLeibnizEq CB) : + ComparableLeibnizEq (PairComparable CA CB). +Proof. +intros x y; destruct x, y; simpl. +pose proof (compare_eq a a0); pose proof (compare_eq b b0). +destruct (compare a a0); try discriminate. +intuition. +destruct H2, H0. +reflexivity. +Qed. + +(** An [Finite] type is a type with the list of all elements. **) +Class Finite (A:Type) := { + all_list : list A; + all_list_forall : forall x:A, In x all_list +}. + +(** An alphabet is both [ComparableLeibnizEq] and [Finite]. **) +Class Alphabet (A:Type) := { + AlphabetComparable :> Comparable A; + AlphabetComparableLeibnizEq :> ComparableLeibnizEq AlphabetComparable; + AlphabetFinite :> Finite A +}. + +(** The [Numbered] class provides a conveniant way to build [Alphabet] instances, + with a good computationnal complexity. It is mainly a injection from it to + [positive] **) +Class Numbered (A:Type) := { + inj : A -> positive; + surj : positive -> A; + surj_inj_compat : forall x, surj (inj x) = x; + inj_bound : positive; + inj_bound_spec : forall x, (inj x < Pos.succ inj_bound)%positive +}. + +Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A := + { AlphabetComparable := {| compare := fun x y => Pos.compare (inj x) (inj y) |}; + AlphabetFinite := + {| all_list := fst (Pos.iter + (fun '(l, p) => (surj p::l, Pos.succ p)) + ([], 1%positive) inj_bound) |} }. +Next Obligation. simpl. now rewrite <- Pos.compare_antisym. Qed. +Next Obligation. + match goal with c : comparison |- _ => destruct c end. + - rewrite Pos.compare_eq_iff in *. congruence. + - rewrite Pos.compare_lt_iff in *. eauto using Pos.lt_trans. + - rewrite Pos.compare_gt_iff in *. eauto using Pos.lt_trans. +Qed. +Next Obligation. + intros x y. unfold compare. intros Hxy. + assert (Hxy' : inj x = inj y). + (* We do not use [Pos.compare_eq_iff] directly to make sure the + proof is executable. *) + { destruct (Pos.eq_dec (inj x) (inj y)) as [|[]]; [now auto|]. + now apply Pos.compare_eq_iff. } + (* Using rewrite here leads to non-executable proofs. *) + transitivity (surj (inj x)). + { apply eq_sym, surj_inj_compat. } + transitivity (surj (inj y)); cycle 1. + { apply surj_inj_compat. } + apply f_equal, Hxy'. +Defined. +Next Obligation. + rewrite <-(surj_inj_compat x). + generalize (inj_bound_spec x). generalize (inj x). clear x. intros x. + match goal with |- ?Hx -> In ?s (fst ?p) => + assert ((Hx -> In s (fst p)) /\ snd p = Pos.succ inj_bound); [|now intuition] end. + rewrite Pos.lt_succ_r. + induction inj_bound as [|y [IH1 IH2]] using Pos.peano_ind; + (split; [intros Hx|]); simpl. + - rewrite (Pos.le_antisym _ _ Hx); auto using Pos.le_1_l. + - auto. + - rewrite Pos.iter_succ. destruct Pos.iter; simpl in *. subst. + rewrite Pos.le_lteq in Hx. destruct Hx as [?%Pos.lt_succ_r| ->]; now auto. + - rewrite Pos.iter_succ. destruct Pos.iter. simpl in IH2. subst. reflexivity. +Qed. + +(** Definitions of [FSet]/[FMap] from [Comparable] **) +Require Import OrderedTypeAlt. +Require FSetAVL. +Require FMapAVL. +Import OrderedType. + +Module Type ComparableM. + Parameter t : Type. + Declare Instance tComparable : Comparable t. +End ComparableM. + +Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt. + Definition t := C.t. + Definition compare : t -> t -> comparison := compare. + + Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_sym x y : (y?=x) = CompOpp (x?=y). + Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed. + Lemma compare_trans c x y z : + (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Proof. + apply compare_trans. + Qed. +End OrderedTypeAlt_from_ComparableM. + +Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType. + Module Alt := OrderedTypeAlt_from_ComparableM C. + Include (OrderedType_from_Alt Alt). +End OrderedType_from_ComparableM. diff --git a/cparser/MenhirLib/Automaton.v b/MenhirLib/Automaton.v index fc995298..d5a19f35 100644 --- a/cparser/MenhirLib/Automaton.v +++ b/MenhirLib/Automaton.v @@ -1,23 +1,20 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) Require Grammar. -Require Import Orders. Require Export Alphabet. -Require Export List. -Require Export Syntax. +From Coq Require Import Orders. +From Coq Require Export List Syntax. Module Type AutInit. (** The grammar of the automaton. **) @@ -102,9 +99,9 @@ Module Types(Import Init:AutInit). T term = last_symb_of_non_init_state s -> lookahead_action term | Reduce_act: production -> lookahead_action term | Fail_act: lookahead_action term. - Arguments Shift_act [term]. - Arguments Reduce_act [term]. - Arguments Fail_act [term]. + Arguments Shift_act {term}. + Arguments Reduce_act {term}. + Arguments Fail_act {term}. Inductive action := | Default_reduce_act: production -> action diff --git a/MenhirLib/Grammar.v b/MenhirLib/Grammar.v new file mode 100644 index 00000000..a371318b --- /dev/null +++ b/MenhirLib/Grammar.v @@ -0,0 +1,162 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List Syntax Orders. +Require Import Alphabet. + +(** The terminal non-terminal alphabets of the grammar. **) +Module Type Alphs. + Parameters terminal nonterminal : Type. + Declare Instance TerminalAlph: Alphabet terminal. + Declare Instance NonTerminalAlph: Alphabet nonterminal. +End Alphs. + +(** Definition of the alphabet of symbols, given the alphabet of terminals + and the alphabet of non terminals **) +Module Symbol(Import A:Alphs). + + Inductive symbol := + | T: terminal -> symbol + | NT: nonterminal -> symbol. + + Program Instance SymbolAlph : Alphabet symbol := + { AlphabetComparable := {| compare := fun x y => + match x, y return comparison with + | T _, NT _ => Gt + | NT _, T _ => Lt + | T x, T y => compare x y + | NT x, NT y => compare x y + end |}; + AlphabetFinite := {| all_list := + map T all_list++map NT all_list |} }. + Next Obligation. + destruct x; destruct y; intuition; apply compare_antisym. + Qed. + Next Obligation. + destruct x; destruct y; destruct z; intuition; try discriminate. + apply (compare_trans _ t0); intuition. + apply (compare_trans _ n0); intuition. + Qed. + Next Obligation. + intros x y. + destruct x; destruct y; try discriminate; intros. + rewrite (compare_eq t t0); now intuition. + rewrite (compare_eq n n0); now intuition. + Defined. + Next Obligation. + rewrite in_app_iff. + destruct x; [left | right]; apply in_map; apply all_list_forall. + Qed. + +End Symbol. + +(** A curryfied function with multiple parameters **) +Definition arrows_right: Type -> list Type -> Type := + fold_right (fun A B => A -> B). + +Module Type T. + Include Alphs <+ Symbol. + + (** [symbol_semantic_type] maps a symbols to the type of its semantic + values. **) + Parameter symbol_semantic_type: symbol -> Type. + + (** The type of productions identifiers **) + Parameter production : Type. + Declare Instance ProductionAlph : Alphabet production. + + (** Accessors for productions: left hand side, right hand side, + and semantic action. The semantic actions are given in the form + of curryfied functions, that take arguments in the reverse order. **) + Parameter prod_lhs: production -> nonterminal. + (* The RHS of a production is given in reversed order, so that symbols *) + Parameter prod_rhs_rev: production -> list symbol. + Parameter prod_action: + forall p:production, + arrows_right + (symbol_semantic_type (NT (prod_lhs p))) + (map symbol_semantic_type (prod_rhs_rev p)). + + (** Tokens are the atomic elements of the input stream: they contain + a terminal and a semantic value of the type corresponding to this + terminal. *) + Parameter token : Type. + Parameter token_term : token -> terminal. + Parameter token_sem : + forall tok : token, symbol_semantic_type (T (token_term tok)). +End T. + +Module Defs(Import G:T). + + (** The semantics of a grammar is defined in two stages. First, we + define the notion of parse tree, which represents one way of + recognizing a word with a head symbol. Semantic values are stored + at the leaves. + + This notion is defined in two mutually recursive flavours: + either for a single head symbol, or for a list of head symbols. *) + Inductive parse_tree: + forall (head_symbol:symbol) (word:list token), Type := + + (** Parse tree for a terminal symbol. *) + | Terminal_pt: + forall (tok:token), parse_tree (T (token_term tok)) [tok] + + (** Parse tree for a non-terminal symbol. *) + | Non_terminal_pt: + forall (prod:production) {word:list token}, + parse_tree_list (prod_rhs_rev prod) word -> + parse_tree (NT (prod_lhs prod)) word + + (* Note : the list head_symbols_rev is reversed. *) + with parse_tree_list: + forall (head_symbols_rev:list symbol) (word:list token), Type := + + | Nil_ptl: parse_tree_list [] [] + + | Cons_ptl: + forall {head_symbolsq:list symbol} {wordq:list token}, + parse_tree_list head_symbolsq wordq -> + + forall {head_symbolt:symbol} {wordt:list token}, + parse_tree head_symbolt wordt -> + + parse_tree_list (head_symbolt::head_symbolsq) (wordq++wordt). + + (** We can now finish the definition of the semantics of a grammar, + by giving the semantic value assotiated with a parse tree. *) + Fixpoint pt_sem {head_symbol word} (tree:parse_tree head_symbol word) : + symbol_semantic_type head_symbol := + match tree with + | Terminal_pt tok => token_sem tok + | Non_terminal_pt prod ptl => ptl_sem ptl (prod_action prod) + end + with ptl_sem {A head_symbols word} (tree:parse_tree_list head_symbols word) : + arrows_right A (map symbol_semantic_type head_symbols) -> A := + match tree with + | Nil_ptl => fun act => act + | Cons_ptl q t => fun act => ptl_sem q (act (pt_sem t)) + end. + + Fixpoint pt_size {head_symbol word} (tree:parse_tree head_symbol word) := + match tree with + | Terminal_pt _ => 1 + | Non_terminal_pt _ l => S (ptl_size l) + end + with ptl_size {head_symbols word} (tree:parse_tree_list head_symbols word) := + match tree with + | Nil_ptl => 0 + | Cons_ptl q t => + pt_size t + ptl_size q + end. +End Defs. diff --git a/MenhirLib/Interpreter.v b/MenhirLib/Interpreter.v new file mode 100644 index 00000000..568597ba --- /dev/null +++ b/MenhirLib/Interpreter.v @@ -0,0 +1,453 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List Syntax. +From Coq.ssr Require Import ssreflect. +Require Automaton. +Require Import Alphabet Grammar Validator_safe. + +Module Make(Import A:Automaton.T). +Module Import ValidSafe := Validator_safe.Make A. + +(** A few helpers for dependent types. *) + +(** Decidable propositions. *) +Class Decidable (P : Prop) := decide : {P} + {~P}. +Arguments decide _ {_}. + +(** A [Comparable] type has decidable equality. *) +Instance comparable_decidable_eq T `{ComparableLeibnizEq T} (x y : T) : + Decidable (x = y). +Proof. + unfold Decidable. + destruct (compare x y) eqn:EQ; [left; apply compare_eq; intuition | ..]; + right; intros ->; by rewrite compare_refl in EQ. +Defined. + +Instance list_decidable_eq T : + (forall x y : T, Decidable (x = y)) -> + (forall l1 l2 : list T, Decidable (l1 = l2)). +Proof. unfold Decidable. decide equality. Defined. + +Ltac subst_existT := + repeat + match goal with + | _ => progress subst + | H : @existT ?A ?P ?x ?y1 = @existT ?A ?P ?x ?y2 |- _ => + let DEC := fresh in + assert (DEC : forall u1 u2 : A, Decidable (u1 = u2)) by apply _; + apply Eqdep_dec.inj_pair2_eq_dec in H; [|by apply DEC]; + clear DEC + end. + +(** The interpreter is written using dependent types. In order to + avoid reducing proof terms while executing the parser, we thunk all + the propositions behind an arrow. + Note that thunkP is still in Prop so that it is erased by + extraction. + *) +Definition thunkP (P : Prop) : Prop := True -> P. + +(** Sometimes, we actually need a reduced proof in a program (for + example when using an equality to cast a value). In that case, + instead of reducing the proof we already have, we reprove the + assertion by using decidability. *) +Definition reprove {P} `{Decidable P} (p : thunkP P) : P := + match decide P with + | left p => p + | right np => False_ind _ (np (p I)) + end. + +(** Combination of reprove with eq_rect. *) +Definition cast {T : Type} (F : T -> Type) {x y : T} (eq : thunkP (x = y)) + {DEC : unit -> Decidable (x = y)}: + F x -> F y := + fun a => eq_rect x F a y (@reprove _ (DEC ()) eq). + +Lemma cast_eq T F (x : T) (eq : thunkP (x = x)) `{forall x y, Decidable (x = y)} a : + cast F eq a = a. +Proof. by rewrite /cast -Eqdep_dec.eq_rect_eq_dec. Qed. + +(** Input buffers and operations on them. **) +CoInductive buffer : Type := + Buf_cons { buf_head : token; buf_tail : buffer }. + +Delimit Scope buffer_scope with buf. +Bind Scope buffer_scope with buffer. + +Infix "::" := Buf_cons (at level 60, right associativity) : buffer_scope. + +(** Concatenation of a list and an input buffer **) +Fixpoint app_buf (l:list token) (buf:buffer) := + match l with + | nil => buf + | cons t q => (t :: app_buf q buf)%buf + end. +Infix "++" := app_buf (at level 60, right associativity) : buffer_scope. + +Lemma app_buf_assoc (l1 l2:list token) (buf:buffer) : + (l1 ++ (l2 ++ buf) = (l1 ++ l2) ++ buf)%buf. +Proof. induction l1 as [|?? IH]=>//=. rewrite IH //. Qed. + +(** The type of a non initial state: the type of semantic values associated + with the last symbol of this state. *) +Definition noninitstate_type state := + symbol_semantic_type (last_symb_of_non_init_state state). + +(** The stack of the automaton : it can be either nil or contains a non + initial state, a semantic value for the symbol associted with this state, + and a nested stack. **) +Definition stack := list (sigT noninitstate_type). (* eg. list {state & state_type state} *) + +Section Interpreter. + +Hypothesis safe: safe. + +(* Properties of the automaton deduced from safety validation. *) +Proposition shift_head_symbs: shift_head_symbs. +Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed. +Proposition goto_head_symbs: goto_head_symbs. +Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed. +Proposition shift_past_state: shift_past_state. +Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed. +Proposition goto_past_state: goto_past_state. +Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed. +Proposition reduce_ok: reduce_ok. +Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed. + +Variable init : initstate. + +(** The top state of a stack **) +Definition state_of_stack (stack:stack): state := + match stack with + | [] => init + | existT _ s _::_ => s + end. + +(** The stack of states of an automaton stack **) +Definition state_stack_of_stack (stack:stack) := + (List.map + (fun cell:sigT noninitstate_type => singleton_state_pred (projT1 cell)) + stack ++ [singleton_state_pred init])%list. + +(** The stack of symbols of an automaton stack **) +Definition symb_stack_of_stack (stack:stack) := + List.map + (fun cell:sigT noninitstate_type => last_symb_of_non_init_state (projT1 cell)) + stack. + +(** The stack invariant : it basically states that the assumptions on the + states are true. **) +Inductive stack_invariant: stack -> Prop := + | stack_invariant_constr: + forall stack, + prefix (head_symbs_of_state (state_of_stack stack)) + (symb_stack_of_stack stack) -> + prefix_pred (head_states_of_state (state_of_stack stack)) + (state_stack_of_stack stack) -> + stack_invariant_next stack -> + stack_invariant stack +with stack_invariant_next: stack -> Prop := + | stack_invariant_next_nil: + stack_invariant_next [] + | stack_invariant_next_cons: + forall state_cur st stack_rec, + stack_invariant stack_rec -> + stack_invariant_next (existT _ state_cur st::stack_rec). + +(** [pop] pops some symbols from the stack. It returns the popped semantic + values using [sem_popped] as an accumulator and discards the popped + states.**) +Fixpoint pop (symbols_to_pop:list symbol) {A:Type} (stk:stack) : + thunkP (prefix symbols_to_pop (symb_stack_of_stack stk)) -> + forall (action:arrows_right A (map symbol_semantic_type symbols_to_pop)), + stack * A. +unshelve refine + (match symbols_to_pop + return + (thunkP (prefix symbols_to_pop (symb_stack_of_stack stk))) -> + forall (action:arrows_right A (map _ symbols_to_pop)), stack * A + with + | [] => fun _ action => (stk, action) + | t::q => fun Hp action => + match stk + return thunkP (prefix (t::q) (symb_stack_of_stack stk)) -> stack * A + with + | existT _ state_cur sem::stack_rec => fun Hp => + let sem_conv := cast symbol_semantic_type _ sem in + pop q _ stack_rec _ (action sem_conv) + | [] => fun Hp => False_rect _ _ + end Hp + end). +Proof. + - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp). + - clear -Hp. abstract (specialize (Hp I); now inversion Hp). + - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp). +Defined. + +(* Equivalent declarative specification for pop, so that we avoid + (part of) the dependent types nightmare. *) +Inductive pop_spec {A:Type} : + forall (symbols_to_pop:list symbol) (stk : stack) + (action : arrows_right A (map symbol_semantic_type symbols_to_pop)) + (stk' : stack) (sem : A), + Prop := + | Nil_pop_spec stk sem : pop_spec [] stk sem stk sem + | Cons_pop_spec symbols_to_pop st stk action sem stk' res : + pop_spec symbols_to_pop stk (action sem) stk' res -> + pop_spec (last_symb_of_non_init_state st::symbols_to_pop) + (existT _ st sem :: stk) action stk' res. + +Lemma pop_spec_ok {A:Type} symbols_to_pop stk Hp action stk' res: + pop symbols_to_pop stk Hp action = (stk', res) <-> + pop_spec (A:=A) symbols_to_pop stk action stk' res. +Proof. + revert stk Hp action. + induction symbols_to_pop as [|t symbols_to_pop IH]=>stk Hp action /=. + - split. + + intros [= <- <-]. constructor. + + intros H. inversion H. by subst_existT. + - destruct stk as [|[st sem]]=>/=; [by destruct pop_subproof0|]. + remember (pop_subproof t symbols_to_pop stk st Hp) as EQ eqn:eq. clear eq. + generalize EQ. revert Hp action. rewrite <-(EQ I)=>Hp action ?. + rewrite cast_eq. rewrite IH. split. + + intros. by constructor. + + intros H. inversion H. by subst_existT. +Qed. + + +Lemma pop_preserves_invariant symbols_to_pop stk Hp A action : + stack_invariant stk -> + stack_invariant (fst (pop symbols_to_pop stk Hp (A:=A) action)). +Proof. + revert stk Hp A action. induction symbols_to_pop as [|t q IH]=>//=. + intros stk Hp A action Hi. + destruct Hi as [stack Hp' Hpp [|state st stk']]. + - destruct pop_subproof0. + - now apply IH. +Qed. + +Lemma pop_state_valid symbols_to_pop stk Hp A action lpred : + prefix_pred lpred (state_stack_of_stack stk) -> + let stk' := fst (pop symbols_to_pop stk Hp (A:=A) action) in + state_valid_after_pop (state_of_stack stk') symbols_to_pop lpred. +Proof. + revert stk Hp A action lpred. induction symbols_to_pop as [|t q IH]=>/=. + - intros stk Hp A a lpred Hpp. destruct lpred as [|pred lpred]; constructor. + inversion Hpp as [|? lpred' ? pred' Himpl Hpp' eq1 eq2]; subst. + specialize (Himpl (state_of_stack stk)). + destruct (pred' (state_of_stack stk)) as [] eqn:Heqpred'=>//. + destruct stk as [|[]]; simpl in *. + + inversion eq2; subst; clear eq2. + unfold singleton_state_pred in Heqpred'. + now rewrite compare_refl in Heqpred'; discriminate. + + inversion eq2; subst; clear eq2. + unfold singleton_state_pred in Heqpred'. + now rewrite compare_refl in Heqpred'; discriminate. + - intros stk Hp A a lpred Hpp. destruct stk as [|[] stk]=>//=. + + destruct pop_subproof0. + + destruct lpred as [|pred lpred]; [by constructor|]. + constructor. apply IH. by inversion Hpp. +Qed. + +(** [step_result] represents the result of one step of the automaton : it can + fail, accept or progress. [Fail_sr] means that the input is incorrect. + [Accept_sr] means that this is the last step of the automaton, and it + returns the semantic value of the input word. [Progress_sr] means that + some progress has been made, but new steps are needed in order to accept + a word. + + For [Accept_sr] and [Progress_sr], the result contains the new input buffer. + + [Fail_sr] means that the input word is rejected by the automaton. It is + different to [Err] (from the error monad), which mean that the automaton is + bogus and has perfomed a forbidden action. **) +Inductive step_result := + | Fail_sr: step_result + | Accept_sr: symbol_semantic_type (NT (start_nt init)) -> buffer -> step_result + | Progress_sr: stack -> buffer -> step_result. + +(** [reduce_step] does a reduce action : + - pops some elements from the stack + - execute the action of the production + - follows the goto for the produced non terminal symbol **) +Definition reduce_step stk prod (buffer : buffer) + (Hval : thunkP (valid_for_reduce (state_of_stack stk) prod)) + (Hi : thunkP (stack_invariant stk)) + : step_result. +refine + ((let '(stk', sem) as ss := pop (prod_rhs_rev prod) stk _ (prod_action prod) + return thunkP (state_valid_after_pop (state_of_stack (fst ss)) _ + (head_states_of_state (state_of_stack stk))) -> _ + in fun Hval' => + match goto_table (state_of_stack stk') (prod_lhs prod) as goto + return (thunkP (goto = None -> + match state_of_stack stk' with + | Init i => prod_lhs prod = start_nt i + | Ninit _ => False + end)) -> _ + with + | Some (exist _ state_new e) => fun _ => + let sem := eq_rect _ _ sem _ e in + Progress_sr (existT noninitstate_type state_new sem::stk') buffer + | None => fun Hval => + let sem := cast symbol_semantic_type _ sem in + Accept_sr sem buffer + end (fun _ => _)) + (fun _ => pop_state_valid _ _ _ _ _ _ _)). +Proof. + - clear -Hi Hval. + abstract (intros _; destruct Hi=>//; eapply prefix_trans; [by apply Hval|eassumption]). + - clear -Hval. + abstract (intros _; f_equal; specialize (Hval I eq_refl); destruct stk' as [|[]]=>//). + - simpl in Hval'. clear -Hval Hval'. + abstract (move : Hval => /(_ I) [_ /(_ _ (Hval' I))] Hval2 Hgoto; by rewrite Hgoto in Hval2). + - clear -Hi. abstract by destruct Hi. +Defined. + +Lemma reduce_step_stack_invariant_preserved stk prod buffer Hv Hi stk' buffer': + reduce_step stk prod buffer Hv Hi = Progress_sr stk' buffer' -> + stack_invariant stk'. +Proof. + unfold reduce_step. + match goal with + | |- context [pop ?symbols_to_pop stk ?Hp ?action] => + assert (Hi':=pop_preserves_invariant symbols_to_pop stk Hp _ action (Hi I)); + generalize (pop_state_valid symbols_to_pop stk Hp _ action) + end. + destruct pop as [stk0 sem]=>/=. simpl in Hi'. intros Hv'. + assert (Hgoto1:=goto_head_symbs (state_of_stack stk0) (prod_lhs prod)). + assert (Hgoto2:=goto_past_state (state_of_stack stk0) (prod_lhs prod)). + match goal with | |- context [fun _ : True => ?X] => generalize X end. + destruct goto_table as [[state_new e]|] eqn:EQgoto=>//. + intros _ [= <- <-]. constructor=>/=. + - constructor. eapply prefix_trans. apply Hgoto1. by destruct Hi'. + - unfold state_stack_of_stack; simpl; constructor. + + intros ?. by destruct singleton_state_pred. + + eapply prefix_pred_trans. apply Hgoto2. by destruct Hi'. + - by constructor. +Qed. + +(** One step of parsing. **) +Definition step stk buffer (Hi : thunkP (stack_invariant stk)): step_result := + match action_table (state_of_stack stk) as a return + thunkP + match a return Prop with + | Default_reduce_act prod => _ + | Lookahead_act awt => forall t : terminal, + match awt t with + | Reduce_act p => _ + | _ => True + end + end -> _ + with + | Default_reduce_act prod => fun Hv => + reduce_step stk prod buffer Hv Hi + | Lookahead_act awt => fun Hv => + match buf_head buffer with + | tok => + match awt (token_term tok) as a return + thunkP match a return Prop with Reduce_act p => _ | _ => _ end -> _ + with + | Shift_act state_new e => fun _ => + let sem_conv := eq_rect _ symbol_semantic_type (token_sem tok) _ e in + Progress_sr (existT noninitstate_type state_new sem_conv::stk) + (buf_tail buffer) + | Reduce_act prod => fun Hv => + reduce_step stk prod buffer Hv Hi + | Fail_act => fun _ => + Fail_sr + end (fun _ => Hv I (token_term tok)) + end + end (fun _ => reduce_ok _). + +Lemma step_stack_invariant_preserved stk buffer Hi stk' buffer': + step stk buffer Hi = Progress_sr stk' buffer' -> + stack_invariant stk'. +Proof. + unfold step. + generalize (reduce_ok (state_of_stack stk))=>Hred. + assert (Hshift1 := shift_head_symbs (state_of_stack stk)). + assert (Hshift2 := shift_past_state (state_of_stack stk)). + destruct action_table as [prod|awt]=>/=. + - eauto using reduce_step_stack_invariant_preserved. + - set (term := token_term (buf_head buffer)). + generalize (Hred term). clear Hred. intros Hred. + specialize (Hshift1 term). specialize (Hshift2 term). + destruct (awt term) as [state_new e|prod|]=>//. + + intros [= <- <-]. constructor=>/=. + * constructor. eapply prefix_trans. apply Hshift1. by destruct Hi. + * unfold state_stack_of_stack; simpl; constructor. + -- intros ?. by destruct singleton_state_pred. + -- eapply prefix_pred_trans. apply Hshift2. by destruct Hi. + * constructor; by apply Hi. + + eauto using reduce_step_stack_invariant_preserved. +Qed. + +(** The parsing use a [nat] fuel parameter [log_n_steps], so that we + do not have to prove terminaison, which is difficult. + + Note that [log_n_steps] is *not* the fuel in the conventionnal + sense: this parameter contains the logarithm (in base 2) of the + number of steps to perform. Hence, a value of, e.g., 50 will + usually be enough to ensure termination. *) +Fixpoint parse_fix stk buffer (log_n_steps : nat) (Hi : thunkP (stack_invariant stk)): + { sr : step_result | + forall stk' buffer', sr = Progress_sr stk' buffer' -> stack_invariant stk' } := + match log_n_steps with + | O => exist _ (step stk buffer Hi) + (step_stack_invariant_preserved _ _ Hi) + | S log_n_steps => + match parse_fix stk buffer log_n_steps Hi with + | exist _ (Progress_sr stk buffer) Hi' => + parse_fix stk buffer log_n_steps (fun _ => Hi' _ buffer eq_refl) + | sr => sr + end + end. + +(** The final result of a parsing is either a failure (the automaton + has rejected the input word), either a timeout (the automaton has + spent all the given [2^log_n_steps]), either a parsed semantic value + with a rest of the input buffer. + + Note that we do not make parse_result depend on start_nt for the + result type, so that this inductive is extracted without the use + of Obj.t in OCaml. **) +Inductive parse_result {A : Type} := + | Fail_pr: parse_result + | Timeout_pr: parse_result + | Parsed_pr: A -> buffer -> parse_result. +Global Arguments parse_result _ : clear implicits. + +Definition parse (buffer : buffer) (log_n_steps : nat): + parse_result (symbol_semantic_type (NT (start_nt init))). +refine (match proj1_sig (parse_fix [] buffer log_n_steps _) with + | Fail_sr => Fail_pr + | Accept_sr sem buffer' => Parsed_pr sem buffer' + | Progress_sr _ _ => Timeout_pr + end). +Proof. + abstract (repeat constructor; intros; by destruct singleton_state_pred). +Defined. + +End Interpreter. + +Arguments Fail_sr {init}. +Arguments Accept_sr {init} _ _. +Arguments Progress_sr {init} _ _. + +End Make. + +Module Type T(A:Automaton.T). + Include (Make A). +End T. diff --git a/MenhirLib/Interpreter_complete.v b/MenhirLib/Interpreter_complete.v new file mode 100644 index 00000000..ec69592b --- /dev/null +++ b/MenhirLib/Interpreter_complete.v @@ -0,0 +1,825 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List Syntax Arith. +From Coq.ssr Require Import ssreflect. +Require Import Alphabet Grammar. +Require Automaton Interpreter Validator_complete. + +Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A). +Module Import Valid := Validator_complete.Make A. + +(** * Completeness Proof **) + +Section Completeness_Proof. + +Hypothesis safe: Inter.ValidSafe.safe. +Hypothesis complete: complete. + +(* Properties of the automaton deduced from completeness validation. *) +Proposition nullable_stable: nullable_stable. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition first_stable: first_stable. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition start_future: start_future. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition terminal_shift: terminal_shift. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition end_reduce: end_reduce. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition start_goto: start_goto. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition non_terminal_goto: non_terminal_goto. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. +Proposition non_terminal_closed: non_terminal_closed. +Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. + +(** If the nullable predicate has been validated, then it is correct. **) +Lemma nullable_correct head word : + word = [] -> parse_tree head word -> nullable_symb head = true +with nullable_correct_list heads word : + word = [] -> + parse_tree_list heads word -> nullable_word heads = true. +Proof. + - destruct 2=>//. assert (Hnull := nullable_stable prod). + erewrite nullable_correct_list in Hnull; eauto. + - intros Hword. destruct 1=>//=. destruct (app_eq_nil _ _ Hword). + eauto using andb_true_intro. +Qed. + +(** Auxiliary lemma for first_correct. *) +Lemma first_word_set_app t word1 word2 : + TerminalSet.In t (first_word_set (word1 ++ word2)) <-> + TerminalSet.In t (first_word_set word1) \/ + TerminalSet.In t (first_word_set word2) /\ nullable_word (rev word1) = true. +Proof. + induction word1 as [|s word1 IH]=>/=. + - split; [tauto|]. move=>[/TerminalSet.empty_1 ?|[? _]]//. + - rewrite /nullable_word forallb_app /=. destruct nullable_symb=>/=. + + rewrite Bool.andb_true_r. split. + * move=>/TerminalSet.union_1. rewrite IH. + move=>[?|[?|[??]]]; auto using TerminalSet.union_2, TerminalSet.union_3. + * destruct IH. + move=>[/TerminalSet.union_1 [?|?]|[??]]; + auto using TerminalSet.union_2, TerminalSet.union_3. + + rewrite Bool.andb_false_r. by intuition. +Qed. + +(** If the first predicate has been validated, then it is correct. **) +Lemma first_correct head word t q : + word = t::q -> + parse_tree head word -> + TerminalSet.In (token_term t) (first_symb_set head) +with first_correct_list heads word t q : + word = t::q -> + parse_tree_list heads word -> + TerminalSet.In (token_term t) (first_word_set (rev' heads)). +Proof. + - intros Hword. destruct 1=>//. + + inversion Hword. subst. apply TerminalSet.singleton_2, compare_refl. + + eapply first_stable. eauto. + - intros Hword. destruct 1 as [|symq wordq ptl symt wordt pt]=>//=. + rewrite /rev' -rev_alt /= first_word_set_app /= rev_involutive rev_alt. + destruct wordq; [right|left]. + + destruct nullable_symb; eauto using TerminalSet.union_2, nullable_correct_list. + + inversion Hword. subst. fold (rev' symq). eauto. +Qed. + +(** A PTL is compatible with a stack if the top of the stack contains + data representing to this PTL. *) +Fixpoint ptl_stack_compat {symbs word} + (stk0 : stack) (ptl : parse_tree_list symbs word) (stk : stack) : Prop := + match ptl with + | Nil_ptl => stk0 = stk + | @Cons_ptl _ _ ptl sym _ pt => + match stk with + | [] => False + | existT _ _ sem::stk => + ptl_stack_compat stk0 ptl stk /\ + exists e, + sem = eq_rect _ symbol_semantic_type (pt_sem pt) _ e + end + end. + +(** .. and when a PTL is compatible with a stack, then calling the pop + function return the semantic value of this PTL. *) +Lemma pop_stack_compat_pop_spec {A symbs word} + (ptl:parse_tree_list symbs word) (stk:stack) (stk0:stack) action : + ptl_stack_compat stk0 ptl stk -> + pop_spec symbs stk action stk0 (ptl_sem (A:=A) ptl action). +Proof. + revert stk. induction ptl=>stk /= Hstk. + - subst. constructor. + - destruct stk as [|[st sem] stk]=>//. destruct Hstk as [Hstk [??]]. subst. + simpl. constructor. eauto. +Qed. + +Variable init: initstate. + +(** In order to prove compleness, we first fix a word to be parsed + together with the content of the parser at the end of the parsing. *) +Variable full_word: list token. +Variable buffer_end: buffer. + +(** Completeness is proved by following the traversal of the parse + tree which is performed by the parser. Each step of parsing + correspond to one step of traversal. In order to represent the state + of the traversal, we define the notion of "dotted" parse tree, which + is a parse tree with one dot on one of its node. The place of the + dot represents the place of the next action to be executed. + + Such a dotted parse tree is decomposed into two part: a "regular" + parse tree, which is the parse tree placed under the dot, and a + "parse tree zipper", which is the part of the parse tree placed + above the dot. Therefore, a parse tree zipper is a parse tree with a + hole. Moreover, for easier manipulation, a parse tree zipper is + represented "upside down". That is, the root of the parse tree is + actually a leaf of the zipper, while the root of the zipper is the + hole. + *) +Inductive pt_zipper: + forall (hole_symb:symbol) (hole_word:list token), Type := +| Top_ptz: + pt_zipper (NT (start_nt init)) full_word +| Cons_ptl_ptz: + forall {head_symbolsq:list symbol} {wordq:list token}, + parse_tree_list head_symbolsq wordq -> + + forall {head_symbolt:symbol} {wordt:list token}, + + ptl_zipper (head_symbolt::head_symbolsq) (wordq++wordt) -> + pt_zipper head_symbolt wordt +with ptl_zipper: + forall (hole_symbs:list symbol) (hole_word:list token), Type := +| Non_terminal_pt_ptlz: + forall {p:production} {word:list token}, + pt_zipper (NT (prod_lhs p)) word -> + ptl_zipper (prod_rhs_rev p) word + +| Cons_ptl_ptlz: + forall {head_symbolsq:list symbol} {wordq:list token}, + + forall {head_symbolt:symbol} {wordt:list token}, + parse_tree head_symbolt wordt -> + + ptl_zipper (head_symbolt::head_symbolsq) (wordq++wordt) -> + + ptl_zipper head_symbolsq wordq. + +(** A dotted parse tree is the combination of a parse tree zipper with + a parse tree. It can be intwo flavors, depending on which is the next + action to be executed (shift or reduce). *) +Inductive pt_dot: Type := +| Reduce_ptd: forall {prod word}, + parse_tree_list (prod_rhs_rev prod) word -> + pt_zipper (NT (prod_lhs prod)) word -> + pt_dot +| Shift_ptd: forall (tok : token) {symbolsq wordq}, + parse_tree_list symbolsq wordq -> + ptl_zipper (T (token_term tok)::symbolsq) (wordq++[tok]) -> + pt_dot. + +(** We can compute the full semantic value of a parse tree when + represented as a dotted ptd. *) + +Fixpoint ptlz_sem {hole_symbs hole_word} + (ptlz:ptl_zipper hole_symbs hole_word) : + (forall A, arrows_right A (map symbol_semantic_type hole_symbs) -> A) -> + (symbol_semantic_type (NT (start_nt init))) := + match ptlz with + | @Non_terminal_pt_ptlz prod _ ptz => + fun k => ptz_sem ptz (k _ (prod_action prod)) + | Cons_ptl_ptlz pt ptlz => + fun k => ptlz_sem ptlz (fun _ f => k _ (f (pt_sem pt))) + end +with ptz_sem {hole_symb hole_word} + (ptz:pt_zipper hole_symb hole_word): + symbol_semantic_type hole_symb -> symbol_semantic_type (NT (start_nt init)) := + match ptz with + | Top_ptz => fun sem => sem + | Cons_ptl_ptz ptl ptlz => + fun sem => ptlz_sem ptlz (fun _ f => ptl_sem ptl (f sem)) + end. + +Definition ptd_sem (ptd : pt_dot) := + match ptd with + | @Reduce_ptd prod _ ptl ptz => + ptz_sem ptz (ptl_sem ptl (prod_action prod)) + | Shift_ptd tok ptl ptlz => + ptlz_sem ptlz (fun _ f => ptl_sem ptl (f (token_sem tok))) + end. + +(** The buffer associated with a dotted parse tree corresponds to the + buffer left to be read by the parser when at the state represented + by the dotted parse tree. *) +Fixpoint ptlz_buffer {hole_symbs hole_word} + (ptlz:ptl_zipper hole_symbs hole_word): buffer := + match ptlz with + | Non_terminal_pt_ptlz ptz => + ptz_buffer ptz + | @Cons_ptl_ptlz _ _ _ wordt _ ptlz' => + wordt ++ ptlz_buffer ptlz' + end +with ptz_buffer {hole_symb hole_word} + (ptz:pt_zipper hole_symb hole_word): buffer := + match ptz with + | Top_ptz => buffer_end + | Cons_ptl_ptz _ ptlz => + ptlz_buffer ptlz + end. + +Definition ptd_buffer (ptd:pt_dot) := + match ptd with + | Reduce_ptd _ ptz => ptz_buffer ptz + | @Shift_ptd tok _ wordq _ ptlz => (tok::ptlz_buffer ptlz)%buf + end. + +(** We are now ready to define the main invariant of the proof of + completeness: we need to specify when a stack is compatible with a + dotted parse tree. Informally, a stack is compatible with a dotted + parse tree when it is the concatenation stack fragments which are + compatible with each of the partially recognized productions + appearing in the parse tree zipper. Moreover, the head of each of + these stack fragment contains a state which has an item predicted by + the corresponding zipper. + + More formally, the compatibility relation first needs the following + auxiliary definitions: *) +Fixpoint ptlz_prod {hole_symbs hole_word} + (ptlz:ptl_zipper hole_symbs hole_word): production := + match ptlz with + | @Non_terminal_pt_ptlz prod _ _ => prod + | Cons_ptl_ptlz _ ptlz' => ptlz_prod ptlz' + end. + +Fixpoint ptlz_future {hole_symbs hole_word} + (ptlz:ptl_zipper hole_symbs hole_word): list symbol := + match ptlz with + | Non_terminal_pt_ptlz _ => [] + | @Cons_ptl_ptlz _ _ s _ _ ptlz' => s::ptlz_future ptlz' + end. + +Fixpoint ptlz_lookahead {hole_symbs hole_word} + (ptlz:ptl_zipper hole_symbs hole_word) : terminal := + match ptlz with + | Non_terminal_pt_ptlz ptz => token_term (buf_head (ptz_buffer ptz)) + | Cons_ptl_ptlz _ ptlz' => ptlz_lookahead ptlz' + end. + +Fixpoint ptz_stack_compat {hole_symb hole_word} + (stk : stack) (ptz : pt_zipper hole_symb hole_word) : Prop := + match ptz with + | Top_ptz => stk = [] + | Cons_ptl_ptz ptl ptlz => + exists stk0, + state_has_future (state_of_stack init stk) (ptlz_prod ptlz) + (hole_symb::ptlz_future ptlz) (ptlz_lookahead ptlz) /\ + ptl_stack_compat stk0 ptl stk /\ + ptlz_stack_compat stk0 ptlz + end +with ptlz_stack_compat {hole_symbs hole_word} + (stk : stack) (ptlz : ptl_zipper hole_symbs hole_word) : Prop := + match ptlz with + | Non_terminal_pt_ptlz ptz => ptz_stack_compat stk ptz + | Cons_ptl_ptlz _ ptlz => ptlz_stack_compat stk ptlz + end. + +Definition ptd_stack_compat (ptd:pt_dot) (stk:stack): Prop := + match ptd with + | @Reduce_ptd prod _ ptl ptz => + exists stk0, + state_has_future (state_of_stack init stk) prod [] + (token_term (buf_head (ptz_buffer ptz))) /\ + ptl_stack_compat stk0 ptl stk /\ + ptz_stack_compat stk0 ptz + | Shift_ptd tok ptl ptlz => + exists stk0, + state_has_future (state_of_stack init stk) (ptlz_prod ptlz) + (T (token_term tok) :: ptlz_future ptlz) (ptlz_lookahead ptlz) /\ + ptl_stack_compat stk0 ptl stk /\ + ptlz_stack_compat stk0 ptlz + end. + +Lemma ptz_stack_compat_cons_state_has_future {symbsq wordq symbt wordt} stk + (ptl : parse_tree_list symbsq wordq) + (ptlz : ptl_zipper (symbt :: symbsq) (wordq ++ wordt)) : + ptz_stack_compat stk (Cons_ptl_ptz ptl ptlz) -> + state_has_future (state_of_stack init stk) (ptlz_prod ptlz) + (symbt::ptlz_future ptlz) (ptlz_lookahead ptlz). +Proof. move=>[stk0 [? [? ?]]] //. Qed. + +Lemma ptlz_future_ptlz_prod hole_symbs hole_word + (ptlz:ptl_zipper hole_symbs hole_word) : + rev_append (ptlz_future ptlz) hole_symbs = prod_rhs_rev (ptlz_prod ptlz). +Proof. induction ptlz=>//=. Qed. + +Lemma ptlz_future_first {symbs word} (ptlz : ptl_zipper symbs word) : + TerminalSet.In (token_term (buf_head (ptlz_buffer ptlz))) + (first_word_set (ptlz_future ptlz)) \/ + token_term (buf_head (ptlz_buffer ptlz)) = ptlz_lookahead ptlz /\ + nullable_word (ptlz_future ptlz) = true. +Proof. + induction ptlz as [|??? [|tok] pt ptlz IH]; [by auto| |]=>/=. + - rewrite (nullable_correct _ _ eq_refl pt). + destruct IH as [|[??]]; [left|right]=>/=; auto using TerminalSet.union_3. + - left. destruct nullable_symb; eauto using TerminalSet.union_2, first_correct. +Qed. + +(** We now want to define what is the next dotted parse tree which is + to be handled after one action. Such dotted parse is built in two + steps: Not only we have to perform the action by completing the + parse tree, but we also have to prepare for the following step by + moving the dot down to place it in front of the next action to be + performed. +*) +Fixpoint build_pt_dot_from_pt {symb word} + (pt : parse_tree symb word) (ptz : pt_zipper symb word) + : pt_dot := + match pt in parse_tree symb word + return pt_zipper symb word -> pt_dot + with + | Terminal_pt tok => + fun ptz => + let X := + match ptz in pt_zipper symb word + return match symb with T term => True | NT _ => False end -> + { symbsq : list symbol & + { wordq : list token & + (parse_tree_list symbsq wordq * + ptl_zipper (symb :: symbsq) (wordq ++ word))%type } } + with + | Top_ptz => fun F => False_rect _ F + | Cons_ptl_ptz ptl ptlz => fun _ => + existT _ _ (existT _ _ (ptl, ptlz)) + end I + in + Shift_ptd tok (fst (projT2 (projT2 X))) (snd (projT2 (projT2 X))) + | Non_terminal_pt prod ptl => fun ptz => + let is_notnil := + match ptl in parse_tree_list w _ + return option (match w return Prop with [] => False | _ => True end) + with + | Nil_ptl => None + | _ => Some I + end + in + match is_notnil with + | None => Reduce_ptd ptl ptz + | Some H => build_pt_dot_from_pt_rec ptl H (Non_terminal_pt_ptlz ptz) + end + end ptz +with build_pt_dot_from_pt_rec {symbs word} + (ptl : parse_tree_list symbs word) + (Hsymbs : match symbs with [] => False | _ => True end) + (ptlz : ptl_zipper symbs word) + : pt_dot := + match ptl in parse_tree_list symbs word + return match symbs with [] => False | _ => True end -> + ptl_zipper symbs word -> + pt_dot + with + | Nil_ptl => fun Hsymbs _ => False_rect _ Hsymbs + | Cons_ptl ptl' pt => fun _ => + match ptl' in parse_tree_list symbsq wordq + return parse_tree_list symbsq wordq -> + ptl_zipper (_ :: symbsq) (wordq ++ _) -> + pt_dot + with + | Nil_ptl => fun _ ptlz => + build_pt_dot_from_pt pt (Cons_ptl_ptz Nil_ptl ptlz) + | _ => fun ptl' ptlz => + build_pt_dot_from_pt_rec ptl' I (Cons_ptl_ptlz pt ptlz) + end ptl' + end Hsymbs ptlz. + +Definition build_pt_dot_from_ptl {symbs word} + (ptl : parse_tree_list symbs word) + (ptlz : ptl_zipper symbs word) + : pt_dot := + match ptlz in ptl_zipper symbs word + return parse_tree_list symbs word -> pt_dot + with + | Non_terminal_pt_ptlz ptz => fun ptl => + Reduce_ptd ptl ptz + | Cons_ptl_ptlz pt ptlz => fun ptl => + build_pt_dot_from_pt pt (Cons_ptl_ptz ptl ptlz) + end ptl. + +Definition next_ptd (ptd:pt_dot) : option pt_dot := + match ptd with + | Shift_ptd tok ptl ptlz => + Some (build_pt_dot_from_ptl (Cons_ptl ptl (Terminal_pt tok)) ptlz) + | Reduce_ptd ptl ptz => + match ptz in pt_zipper symb word + return parse_tree symb word -> _ + with + | Top_ptz => fun _ => None + | Cons_ptl_ptz ptl' ptlz => fun pt => + Some (build_pt_dot_from_ptl (Cons_ptl ptl' pt) ptlz) + end (Non_terminal_pt _ ptl) + end. + +Fixpoint next_ptd_iter (ptd:pt_dot) (log_n_steps:nat) : option pt_dot := + match log_n_steps with + | O => next_ptd ptd + | S log_n_steps => + match next_ptd_iter ptd log_n_steps with + | None => None + | Some ptd => next_ptd_iter ptd log_n_steps + end + end. + +(** We prove that these functions behave well w.r.t. semantic values. *) +Lemma sem_build_from_pt {symb word} + (pt : parse_tree symb word) (ptz : pt_zipper symb word) : + ptz_sem ptz (pt_sem pt) + = ptd_sem (build_pt_dot_from_pt pt ptz) +with sem_build_from_pt_rec {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) + Hsymbs : + ptlz_sem ptlz (fun _ f => ptl_sem ptl f) + = ptd_sem (build_pt_dot_from_pt_rec ptl Hsymbs ptlz). +Proof. + - destruct pt as [tok|prod word ptl]=>/=. + + revert ptz. generalize [tok]. + generalize (token_sem tok). generalize I. + change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1. + generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz. + + match goal with + | |- context [match ?X with Some H => _ | None => _ end] => destruct X=>// + end. + by rewrite -sem_build_from_pt_rec. + - destruct ptl; [contradiction|]. + specialize (sem_build_from_pt_rec _ _ ptl)=>/=. destruct ptl. + + by rewrite -sem_build_from_pt. + + by rewrite -sem_build_from_pt_rec. +Qed. + +Lemma sem_build_from_ptl {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) : + ptlz_sem ptlz (fun _ f => ptl_sem ptl f) + = ptd_sem (build_pt_dot_from_ptl ptl ptlz). +Proof. destruct ptlz=>//=. by rewrite -sem_build_from_pt. Qed. + +Lemma sem_next_ptd (ptd : pt_dot) : + match next_ptd ptd with + | None => True + | Some ptd' => ptd_sem ptd = ptd_sem ptd' + end. +Proof. + destruct ptd as [prod word ptl ptz|tok symbs word ptl ptlz] =>/=. + - change (ptl_sem ptl (prod_action prod)) + with (pt_sem (Non_terminal_pt prod ptl)). + generalize (Non_terminal_pt prod ptl). clear ptl. + destruct ptz as [|?? ptl ?? ptlz]=>// pt. by rewrite -sem_build_from_ptl. + - by rewrite -sem_build_from_ptl. +Qed. + +Lemma sem_next_ptd_iter (ptd : pt_dot) (log_n_steps : nat) : + match next_ptd_iter ptd log_n_steps with + | None => True + | Some ptd' => ptd_sem ptd = ptd_sem ptd' + end. +Proof. + revert ptd. + induction log_n_steps as [|log_n_steps IH]; [by apply sem_next_ptd|]=>/= ptd. + assert (IH1 := IH ptd). destruct next_ptd_iter as [ptd'|]=>//. + specialize (IH ptd'). destruct next_ptd_iter=>//. congruence. +Qed. + +(** We prove that these functions behave well w.r.t. xxx_buffer. *) +Lemma ptd_buffer_build_from_pt {symb word} + (pt : parse_tree symb word) (ptz : pt_zipper symb word) : + (word ++ ptz_buffer ptz)%buf = ptd_buffer (build_pt_dot_from_pt pt ptz) +with ptd_buffer_build_from_pt_rec {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) + Hsymbs : + (word ++ ptlz_buffer ptlz)%buf = ptd_buffer (build_pt_dot_from_pt_rec ptl Hsymbs ptlz). +Proof. + - destruct pt as [tok|prod word ptl]=>/=. + + f_equal. revert ptz. generalize [tok]. + generalize (token_sem tok). generalize I. + change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1. + generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz. + + match goal with + | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ + end. + * by rewrite -ptd_buffer_build_from_pt_rec. + * rewrite [X in (X ++ _)%buf](_ : word = []) //. clear -EQ. by destruct ptl. + - destruct ptl as [|?? ptl ?? pt]; [contradiction|]. + specialize (ptd_buffer_build_from_pt_rec _ _ ptl). + destruct ptl. + + by rewrite /= -ptd_buffer_build_from_pt. + + by rewrite -ptd_buffer_build_from_pt_rec //= app_buf_assoc. +Qed. + +Lemma ptd_buffer_build_from_ptl {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) : + ptlz_buffer ptlz = ptd_buffer (build_pt_dot_from_ptl ptl ptlz). +Proof. + destruct ptlz as [|???? pt]=>//=. by rewrite -ptd_buffer_build_from_pt. +Qed. + +(** We prove that these functions behave well w.r.t. xxx_stack_compat. *) +Lemma ptd_stack_compat_build_from_pt {symb word} + (pt : parse_tree symb word) (ptz : pt_zipper symb word) + (stk: stack) : + ptz_stack_compat stk ptz -> + ptd_stack_compat (build_pt_dot_from_pt pt ptz) stk +with ptd_stack_compat_build_from_pt_rec {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) + (stk : stack) Hsymbs : + ptlz_stack_compat stk ptlz -> + state_has_future (state_of_stack init stk) (ptlz_prod ptlz) + (rev' (prod_rhs_rev (ptlz_prod ptlz))) (ptlz_lookahead ptlz) -> + ptd_stack_compat (build_pt_dot_from_pt_rec ptl Hsymbs ptlz) stk. +Proof. + - intros Hstk. destruct pt as [tok|prod word ptl]=>/=. + + revert ptz Hstk. generalize [tok]. generalize (token_sem tok). generalize I. + change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1. + generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz. + + assert (state_has_future (state_of_stack init stk) prod + (rev' (prod_rhs_rev prod)) (token_term (buf_head (ptz_buffer ptz)))). + { revert ptz Hstk. remember (NT (prod_lhs prod)) eqn:EQ=>ptz. + destruct ptz as [|?? ptl0 ?? ptlz0]. + - intros ->. apply start_future. congruence. + - subst. intros (stk0 & Hfut & _). apply non_terminal_closed in Hfut. + specialize (Hfut prod eq_refl). + destruct (ptlz_future_first ptlz0) as [Hfirst|[Hfirst Hnull]]. + + destruct Hfut as [_ Hfut]. auto. + + destruct Hfut as [Hfut _]. by rewrite Hnull -Hfirst in Hfut. } + match goal with + | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ + end. + * by apply ptd_stack_compat_build_from_pt_rec. + * exists stk. destruct ptl=>//. + - intros Hstk Hfut. destruct ptl as [|?? ptl ?? pt]; [contradiction|]. + specialize (ptd_stack_compat_build_from_pt_rec _ _ ptl). destruct ptl. + + eapply ptd_stack_compat_build_from_pt=>//. exists stk. + split; [|split]=>//; []. + by rewrite -ptlz_future_ptlz_prod rev_append_rev /rev' -rev_alt + rev_app_distr rev_involutive in Hfut. + + by apply ptd_stack_compat_build_from_pt_rec. +Qed. + +Lemma ptd_stack_compat_build_from_ptl {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) + (stk stk0: stack) : + ptlz_stack_compat stk0 ptlz -> + ptl_stack_compat stk0 ptl stk -> + state_has_future (state_of_stack init stk) (ptlz_prod ptlz) + (ptlz_future ptlz) (ptlz_lookahead ptlz) -> + ptd_stack_compat (build_pt_dot_from_ptl ptl ptlz) stk. +Proof. + intros Hstk0 Hstk Hfut. destruct ptlz=>/=. + - eauto. + - apply ptd_stack_compat_build_from_pt=>/=. eauto. +Qed. + +(** We can now proceed by proving that the invariant is preserved by + each step of parsing. We also prove that each step of parsing + follows next_ptd. + + We start with reduce steps: *) +Lemma reduce_step_next_ptd (prod : production) (word : list token) + (ptl : parse_tree_list (prod_rhs_rev prod) word) + (ptz : pt_zipper (NT (prod_lhs prod)) word) + (stk : stack) + Hval Hi : + ptd_stack_compat (Reduce_ptd ptl ptz) stk -> + match next_ptd (Reduce_ptd ptl ptz) with + | None => + reduce_step init stk prod (ptz_buffer ptz) Hval Hi = + Accept_sr (ptd_sem (Reduce_ptd ptl ptz)) buffer_end + | Some ptd => + exists stk', + reduce_step init stk prod (ptz_buffer ptz) Hval Hi = + Progress_sr stk' (ptd_buffer ptd) /\ + ptd_stack_compat ptd stk' + end. +Proof. + intros (stk0 & _ & Hstk & Hstk0). + apply pop_stack_compat_pop_spec with (action := prod_action prod) in Hstk. + rewrite <-pop_spec_ok with (Hp := reduce_step_subproof init stk prod Hval Hi) in Hstk. + unfold reduce_step. + match goal with + | |- context [pop_state_valid init ?A stk ?B ?C ?D ?E ?F] => + generalize (pop_state_valid init A stk B C D E F) + end. + rewrite Hstk /=. intros Hv. + generalize (reduce_step_subproof1 init stk prod Hval stk0 (fun _ : True => Hv)). + clear Hval Hstk Hi Hv stk. + assert (Hgoto := fun fut prod' => + non_terminal_goto (state_of_stack init stk0) prod' (NT (prod_lhs prod)::fut)). + simpl in Hgoto. + destruct goto_table as [[st Hst]|] eqn:Hgoto'. + - intros _. + assert (match ptz with Top_ptz => False | _ => True end). + { revert ptz Hst Hstk0 Hgoto'. + generalize (eq_refl (NT (prod_lhs prod))). + generalize (NT (prod_lhs prod)) at 1 3 5. + intros nt Hnt ptz. destruct ptz=>//. injection Hnt=> <- /= Hst -> /= Hg. + assert (Hsg := start_goto init). by rewrite Hg in Hsg. } + clear Hgoto'. + + change (ptl_sem ptl (prod_action prod)) + with (pt_sem (Non_terminal_pt prod ptl)). + generalize (Non_terminal_pt prod ptl). clear ptl. + destruct ptz as [|?? ptl ? ? ptlz]=>// pt. + + subst=>/=. eexists _. split. + + f_equal. apply ptd_buffer_build_from_ptl. + + destruct Hstk0 as (stk0' & Hfut & Hstk0' & Hstk0). + apply (ptd_stack_compat_build_from_ptl _ _ _ stk0'); auto; []. + split=>//. by exists eq_refl. + - intros Hv. generalize (reduce_step_subproof0 _ prod _ (fun _ => Hv)). + intros EQnt. clear Hv Hgoto'. + + change (ptl_sem ptl (prod_action prod)) + with (pt_sem (Non_terminal_pt prod ptl)). + generalize (Non_terminal_pt prod ptl). clear ptl. destruct ptz. + + intros pt. f_equal. by rewrite cast_eq. + + edestruct Hgoto. eapply ptz_stack_compat_cons_state_has_future, Hstk0. +Qed. + +Lemma step_next_ptd (ptd : pt_dot) (stk : stack) Hi : + ptd_stack_compat ptd stk -> + match next_ptd ptd with + | None => + step safe init stk (ptd_buffer ptd) Hi = + Accept_sr (ptd_sem ptd) buffer_end + | Some ptd' => + exists stk', + step safe init stk (ptd_buffer ptd) Hi = + Progress_sr stk' (ptd_buffer ptd') /\ + ptd_stack_compat ptd' stk' + end. +Proof. + intros Hstk. unfold step. + generalize (reduce_ok safe (state_of_stack init stk)). + destruct ptd as [prod word ptl ptz|tok symbs word ptl ptlz]. + - assert (Hfut : state_has_future (state_of_stack init stk) prod [] + (token_term (buf_head (ptz_buffer ptz)))). + { destruct Hstk as (? & ? & ?)=>//. } + assert (Hact := end_reduce _ _ _ _ Hfut). + destruct action_table as [?|awt]=>Hval /=. + + subst. by apply reduce_step_next_ptd. + + set (term := token_term (buf_head (ptz_buffer ptz))) in *. + generalize (Hval term). clear Hval. destruct (awt term)=>//. subst. + intros Hval. by apply reduce_step_next_ptd. + - destruct Hstk as (stk0 & Hfut & Hstk & Hstk0). + assert (Hact := terminal_shift _ _ _ _ Hfut). simpl in Hact. clear Hfut. + destruct action_table as [?|awt]=>//= /(_ (token_term tok)). + destruct awt as [st' EQ| |]=>// _. eexists. split. + + f_equal. rewrite -ptd_buffer_build_from_ptl //. + + apply (ptd_stack_compat_build_from_ptl _ _ _ stk0); simpl; eauto. +Qed. + +(** We prove the completeness of the parser main loop. *) +Lemma parse_fix_next_ptd_iter (ptd : pt_dot) (stk : stack) (log_n_steps : nat) Hi : + ptd_stack_compat ptd stk -> + match next_ptd_iter ptd log_n_steps with + | None => + proj1_sig (parse_fix safe init stk (ptd_buffer ptd) log_n_steps Hi) = + Accept_sr (ptd_sem ptd) buffer_end + | Some ptd' => + exists stk', + proj1_sig (parse_fix safe init stk (ptd_buffer ptd) log_n_steps Hi) = + Progress_sr stk' (ptd_buffer ptd') /\ + ptd_stack_compat ptd' stk' + end. +Proof. + revert ptd stk Hi. + induction log_n_steps as [|log_n_steps IH]; [by apply step_next_ptd|]. + move => /= ptd stk Hi Hstk. assert (IH1 := IH ptd stk Hi Hstk). + assert (EQsem := sem_next_ptd_iter ptd log_n_steps). + destruct parse_fix as [sr Hi']. simpl in IH1. + destruct next_ptd_iter as [ptd'|]. + - rewrite EQsem. destruct IH1 as (stk' & -> & Hstk'). by apply IH. + - by subst. +Qed. + +(** The parser is defined by recursion over a fuel parameter. In the + completeness proof, we need to predict how much fuel is going to be + needed in order to prove that enough fuel gives rise to a successful + parsing. + + To do so, of a dotted parse tree, which is the number of actions + left to be executed before complete parsing when the current state + is represented by the dotted parse tree. *) +Fixpoint ptlz_cost {hole_symbs hole_word} + (ptlz:ptl_zipper hole_symbs hole_word) := + match ptlz with + | Non_terminal_pt_ptlz ptz => ptz_cost ptz + | Cons_ptl_ptlz pt ptlz' => pt_size pt + ptlz_cost ptlz' + end +with ptz_cost {hole_symb hole_word} (ptz:pt_zipper hole_symb hole_word) := + match ptz with + | Top_ptz => 0 + | Cons_ptl_ptz ptl ptlz' => 1 + ptlz_cost ptlz' + end. + +Definition ptd_cost (ptd:pt_dot) := + match ptd with + | Reduce_ptd ptl ptz => ptz_cost ptz + | Shift_ptd _ ptl ptlz => 1 + ptlz_cost ptlz + end. + +Lemma ptd_cost_build_from_pt {symb word} + (pt : parse_tree symb word) (ptz : pt_zipper symb word) : + pt_size pt + ptz_cost ptz = S (ptd_cost (build_pt_dot_from_pt pt ptz)) +with ptd_cost_build_from_pt_rec {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) + Hsymbs : + ptl_size ptl + ptlz_cost ptlz = ptd_cost (build_pt_dot_from_pt_rec ptl Hsymbs ptlz). +Proof. + - destruct pt as [tok|prod word ptl']=>/=. + + revert ptz. generalize [tok]. generalize (token_sem tok). generalize I. + change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1. + generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz. + + match goal with + | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ + end. + * rewrite -ptd_cost_build_from_pt_rec /= plus_n_Sm //. + * simpl. by destruct ptl'. + - destruct ptl as [|?? ptl ?? pt]; [contradiction|]. + specialize (ptd_cost_build_from_pt_rec _ _ ptl). destruct ptl. + + apply eq_add_S. rewrite -ptd_cost_build_from_pt /=. ring. + + rewrite -ptd_cost_build_from_pt_rec //=. ring. +Qed. + +Lemma ptd_cost_build_from_ptl {symbs word} + (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) : + ptlz_cost ptlz = ptd_cost (build_pt_dot_from_ptl ptl ptlz). +Proof. + destruct ptlz=>//. apply eq_add_S. rewrite -ptd_cost_build_from_pt /=. ring. +Qed. + +Lemma next_ptd_cost ptd: + match next_ptd ptd with + | None => ptd_cost ptd = 0 + | Some ptd' => ptd_cost ptd = S (ptd_cost ptd') + end. +Proof. + destruct ptd as [prod word ptl ptz|tok symbq wordq ptl ptlz] =>/=. + - generalize (Non_terminal_pt prod ptl). clear ptl. + destruct ptz as [|?? ptl ?? ptlz]=>// pt. by rewrite -ptd_cost_build_from_ptl. + - by rewrite -ptd_cost_build_from_ptl. +Qed. + +Lemma next_ptd_iter_cost ptd log_n_steps : + match next_ptd_iter ptd log_n_steps with + | None => ptd_cost ptd < 2^log_n_steps + | Some ptd' => ptd_cost ptd = 2^log_n_steps + ptd_cost ptd' + end. +Proof. + revert ptd. induction log_n_steps as [|log_n_steps IH]=>ptd /=. + - assert (Hptd := next_ptd_cost ptd). destruct next_ptd=>//. by rewrite Hptd. + - rewrite Nat.add_0_r. assert (IH1 := IH ptd). destruct next_ptd_iter as [ptd'|]. + + specialize (IH ptd'). destruct next_ptd_iter as [ptd''|]. + * by rewrite IH1 IH -!plus_assoc. + * rewrite IH1. by apply plus_lt_compat_l. + + by apply lt_plus_trans. +Qed. + +(** We now prove the top-level parsing function. The only thing that + is left to be done is the initialization. To do so, we define the + initial dotted parse tree, depending on a full (top-level) parse tree. *) + +Variable full_pt : parse_tree (NT (start_nt init)) full_word. + +Theorem parse_complete log_n_steps: + match parse safe init (full_word ++ buffer_end) log_n_steps with + | Parsed_pr sem buff => + sem = pt_sem full_pt /\ buff = buffer_end /\ pt_size full_pt <= 2^log_n_steps + | Timeout_pr => 2^log_n_steps < pt_size full_pt + | Fail_pr => False + end. +Proof. + assert (Hstk : ptd_stack_compat (build_pt_dot_from_pt full_pt Top_ptz) []) by + by apply ptd_stack_compat_build_from_pt. + unfold parse. + assert (Hparse := parse_fix_next_ptd_iter _ _ log_n_steps (parse_subproof init) Hstk). + rewrite -ptd_buffer_build_from_pt -sem_build_from_pt /= in Hparse. + assert (Hcost := next_ptd_iter_cost (build_pt_dot_from_pt full_pt Top_ptz) log_n_steps). + destruct next_ptd_iter. + - destruct Hparse as (? & -> & ?). apply (f_equal S) in Hcost. + rewrite -ptd_cost_build_from_pt Nat.add_0_r in Hcost. rewrite Hcost. + apply le_lt_n_Sm, le_plus_l. + - rewrite Hparse. split; [|split]=>//. apply lt_le_S in Hcost. + by rewrite -ptd_cost_build_from_pt Nat.add_0_r in Hcost. +Qed. + +End Completeness_Proof. + +End Make. diff --git a/MenhirLib/Interpreter_correct.v b/MenhirLib/Interpreter_correct.v new file mode 100644 index 00000000..1325f610 --- /dev/null +++ b/MenhirLib/Interpreter_correct.v @@ -0,0 +1,175 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List Syntax. +Require Import Alphabet. +Require Grammar Automaton Interpreter. +From Coq.ssr Require Import ssreflect. + +Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A). + +(** * Correctness of the interpreter **) + +(** We prove that, in any case, if the interpreter accepts returning a + semantic value, then this is a semantic value of the input **) + +Section Init. + +Variable init:initstate. + +(** [word_has_stack_semantics] relates a word with a stack, stating that the + word is a concatenation of words that have the semantic values stored in + the stack. **) +Inductive word_has_stack_semantics: + forall (word:list token) (stack:stack), Prop := + | Nil_stack_whss: word_has_stack_semantics [] [] + | Cons_stack_whss: + forall (wordq:list token) (stackq:stack), + word_has_stack_semantics wordq stackq -> + + forall (wordt:list token) (s:noninitstate) + (pt:parse_tree (last_symb_of_non_init_state s) wordt), + + word_has_stack_semantics + (wordq++wordt) (existT noninitstate_type s (pt_sem pt)::stackq). + +(** [pop] preserves the invariant **) +Lemma pop_spec_ptl A symbols_to_pop action word_stk stk (res : A) stk' : + pop_spec symbols_to_pop stk action stk' res -> + word_has_stack_semantics word_stk stk -> + exists word_stk' word_res (ptl:parse_tree_list symbols_to_pop word_res), + (word_stk' ++ word_res = word_stk)%list /\ + word_has_stack_semantics word_stk' stk' /\ + ptl_sem ptl action = res. +Proof. + intros Hspec. revert word_stk. + induction Hspec as [stk sem|symbols_to_pop st stk action sem stk' res Hspec IH]; + intros word_stk Hword_stk. + - exists word_stk, [], Nil_ptl. rewrite -app_nil_end. eauto. + - inversion Hword_stk. subst_existT. + edestruct IH as (word_stk' & word_res & ptl & ? & Hword_stk'' & ?); [eassumption|]. + subst. eexists word_stk', (word_res ++ _)%list, (Cons_ptl ptl _). + split; [|split]=>//. rewrite app_assoc //. +Qed. + +(** [reduce_step] preserves the invariant **) +Lemma reduce_step_invariant (stk:stack) (prod:production) Hv Hi word buffer : + word_has_stack_semantics word stk -> + match reduce_step init stk prod buffer Hv Hi with + | Accept_sr sem buffer_new => + exists pt : parse_tree (NT (start_nt init)) word, + buffer = buffer_new /\ pt_sem pt = sem + | Progress_sr stk' buffer_new => + buffer = buffer_new /\ word_has_stack_semantics word stk' + | Fail_sr => True + end. +Proof. + intros Hword_stk. unfold reduce_step. + match goal with + | |- context [pop_state_valid init ?stp stk ?x1 ?x2 ?x3 ?x4 ?x5] => + generalize (pop_state_valid init stp stk x1 x2 x3 x4 x5) + end. + destruct pop as [stk' sem] eqn:Hpop=>/= Hv'. + apply pop_spec_ok in Hpop. apply pop_spec_ptl with (word_stk := word) in Hpop=>//. + destruct Hpop as (word1 & word2 & ptl & <- & Hword1 & <-). + generalize (reduce_step_subproof1 init stk prod Hv stk' (fun _ : True => Hv')). + destruct goto_table as [[st' EQ]|]. + - intros _. split=>//. + change (ptl_sem ptl (prod_action prod)) with (pt_sem (Non_terminal_pt prod ptl)). + generalize (Non_terminal_pt prod ptl). rewrite ->EQ. intros pt. by constructor. + - intros Hstk'. destruct Hword1; [|by destruct Hstk']. + generalize (reduce_step_subproof0 init prod [] (fun _ : True => Hstk')). + simpl in Hstk'. rewrite -Hstk' // => EQ. rewrite cast_eq. + exists (Non_terminal_pt prod ptl). by split. +Qed. + +(** [step] preserves the invariant **) +Lemma step_invariant stk word buffer safe Hi : + word_has_stack_semantics word stk -> + match step safe init stk buffer Hi with + | Accept_sr sem buffer_new => + exists word_new (pt:parse_tree (NT (start_nt init)) word_new), + (word ++ buffer = word_new ++ buffer_new)%buf /\ + pt_sem pt = sem + | Progress_sr stk_new buffer_new => + exists word_new, + (word ++ buffer = word_new ++ buffer_new)%buf /\ + word_has_stack_semantics word_new stk_new + | Fail_sr => True + end. +Proof. + intros Hword_stk. unfold step. + generalize (reduce_ok safe (state_of_stack init stk)). + destruct action_table as [prod|awt]. + - intros Hv. + apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word buffer) in Hword_stk. + destruct reduce_step=>//. + + destruct Hword_stk as (pt & <- & <-); eauto. + + destruct Hword_stk as [<- ?]; eauto. + - destruct buffer as [tok buffer]=>/=. + move=> /(_ (token_term tok)) Hv. destruct (awt (token_term tok)) as [st EQ|prod|]=>//. + + eexists _. split; [by apply app_buf_assoc with (l2 := [_])|]. + change (token_sem tok) with (pt_sem (Terminal_pt tok)). + generalize (Terminal_pt tok). generalize [tok]. + rewrite -> EQ=>word' pt /=. by constructor. + + apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word (tok::buffer)) + in Hword_stk. + destruct reduce_step=>//. + * destruct Hword_stk as (pt & <- & <-); eauto. + * destruct Hword_stk as [<- ?]; eauto. +Qed. + +(** [step] preserves the invariant **) +Lemma parse_fix_invariant stk word buffer safe log_n_steps Hi : + word_has_stack_semantics word stk -> + match proj1_sig (parse_fix safe init stk buffer log_n_steps Hi) with + | Accept_sr sem buffer_new => + exists word_new (pt:parse_tree (NT (start_nt init)) word_new), + (word ++ buffer = word_new ++ buffer_new)%buf /\ + pt_sem pt = sem + | Progress_sr stk_new buffer_new => + exists word_new, + (word ++ buffer = word_new ++ buffer_new)%buf /\ + word_has_stack_semantics word_new stk_new + | Fail_sr => True + end. +Proof. + revert stk word buffer Hi. + induction log_n_steps as [|log_n_steps IH]=>/= stk word buffer Hi Hstk; + [by apply step_invariant|]. + assert (IH1 := IH stk word buffer Hi Hstk). + destruct parse_fix as [[] Hi']=>/=; try by apply IH1. + destruct IH1 as (word' & -> & Hstk')=>//. by apply IH. +Qed. + +(** The interpreter is correct : if it returns a semantic value, then the input + word has this semantic value. +**) +Theorem parse_correct safe buffer log_n_steps: + match parse safe init buffer log_n_steps with + | Parsed_pr sem buffer_new => + exists word_new (pt:parse_tree (NT (start_nt init)) word_new), + buffer = (word_new ++ buffer_new)%buf /\ + pt_sem pt = sem + | _ => True + end. +Proof. + unfold parse. + assert (Hparse := parse_fix_invariant [] [] buffer safe log_n_steps + (parse_subproof init)). + destruct proj1_sig=>//. apply Hparse. constructor. +Qed. + +End Init. + +End Make. diff --git a/MenhirLib/Main.v b/MenhirLib/Main.v new file mode 100644 index 00000000..f6158074 --- /dev/null +++ b/MenhirLib/Main.v @@ -0,0 +1,79 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +Require Grammar Automaton Interpreter_correct Interpreter_complete. +From Coq Require Import Syntax Arith. + +Module Make(Export Aut:Automaton.T). +Export Aut.Gram. +Export Aut.GramDefs. + +Module Import Inter := Interpreter.Make Aut. +Module Correct := Interpreter_correct.Make Aut Inter. +Module Complete := Interpreter_complete.Make Aut Inter. + +Definition complete_validator:unit->bool := Complete.Valid.is_complete. +Definition safe_validator:unit->bool := ValidSafe.is_safe. +Definition parse (safe:safe_validator ()=true) init log_n_steps buffer : + parse_result (symbol_semantic_type (NT (start_nt init))):= + parse (ValidSafe.safe_is_validator safe) init buffer log_n_steps. + +(** Correction theorem. **) +Theorem parse_correct + (safe:safe_validator ()= true) init log_n_steps buffer: + match parse safe init log_n_steps buffer with + | Parsed_pr sem buffer_new => + exists word (pt : parse_tree (NT (start_nt init)) word), + buffer = (word ++ buffer_new)%buf /\ + pt_sem pt = sem + | _ => True + end. +Proof. apply Correct.parse_correct. Qed. + +(** Completeness theorem. **) +Theorem parse_complete + (safe:safe_validator () = true) init log_n_steps word buffer_end: + complete_validator () = true -> + forall tree:parse_tree (NT (start_nt init)) word, + match parse safe init log_n_steps (word ++ buffer_end) with + | Fail_pr => False + | Parsed_pr sem_res buffer_end_res => + sem_res = pt_sem tree /\ buffer_end_res = buffer_end /\ + pt_size tree <= 2^log_n_steps + | Timeout_pr => 2^log_n_steps < pt_size tree + end. +Proof. + intros. now apply Complete.parse_complete, Complete.Valid.complete_is_validator. +Qed. + +(** Unambiguity theorem. **) +Theorem unambiguity: + safe_validator () = true -> complete_validator () = true -> inhabited token -> + forall init word, + forall (tree1 tree2:parse_tree (NT (start_nt init)) word), + pt_sem tree1 = pt_sem tree2. +Proof. + intros Hsafe Hcomp [tok] init word tree1 tree2. + pose (buf_end := cofix buf_end := (tok :: buf_end)%buf). + assert (Hcomp1 := parse_complete Hsafe init (pt_size tree1) word buf_end + Hcomp tree1). + assert (Hcomp2 := parse_complete Hsafe init (pt_size tree1) word buf_end + Hcomp tree2). + destruct parse. + - destruct Hcomp1. + - exfalso. eapply PeanoNat.Nat.lt_irrefl. etransitivity; [|apply Hcomp1]. + eapply Nat.pow_gt_lin_r. constructor. + - destruct Hcomp1 as [-> _], Hcomp2 as [-> _]. reflexivity. +Qed. + +End Make. diff --git a/MenhirLib/Validator_classes.v b/MenhirLib/Validator_classes.v new file mode 100644 index 00000000..d8063123 --- /dev/null +++ b/MenhirLib/Validator_classes.v @@ -0,0 +1,75 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List. +From Coq.ssr Require Import ssreflect. +Require Import Alphabet. + +Class IsValidator (P : Prop) (b : bool) := + is_validator : b = true -> P. +Hint Mode IsValidator + - : typeclass_instances. + +Instance is_validator_true : IsValidator True true. +Proof. done. Qed. + +Instance is_validator_false : IsValidator False false. +Proof. done. Qed. + +Instance is_validator_eq_true b : + IsValidator (b = true) b. +Proof. done. Qed. + +Instance is_validator_and P1 b1 P2 b2 `{IsValidator P1 b1} `{IsValidator P2 b2}: + IsValidator (P1 /\ P2) (if b1 then b2 else false). +Proof. by split; destruct b1, b2; apply is_validator. Qed. + +Instance is_validator_comparable_leibniz_eq A (C:Comparable A) (x y : A) : + ComparableLeibnizEq C -> + IsValidator (x = y) (compare_eqb x y). +Proof. intros ??. by apply compare_eqb_iff. Qed. + +Instance is_validator_comparable_eq_impl A `(Comparable A) (x y : A) P b : + IsValidator P b -> + IsValidator (x = y -> P) (if compare_eqb x y then b else true). +Proof. + intros Hval Val ->. rewrite /compare_eqb compare_refl in Val. auto. +Qed. + +Lemma is_validator_forall_finite A P b `(Finite A) : + (forall (x : A), IsValidator (P x) (b x)) -> + IsValidator (forall (x : A), P x) (forallb b all_list). +Proof. + move=> ? /forallb_forall Hb ?. + apply is_validator, Hb, all_list_forall. +Qed. + +(* We do not use an instance directly here, because we need somehow to + force Coq to instantiate b with a lambda. *) +Hint Extern 2 (IsValidator (forall x : ?A, _) _) => + eapply (is_validator_forall_finite _ _ (fun (x:A) => _)) + : typeclass_instances. + +(* Hint for synthetizing pattern-matching. *) +Hint Extern 2 (IsValidator (match ?u with _ => _ end) ?b0) => + let b := fresh "b" in + unshelve notypeclasses refine (let b : bool := _ in _); + [destruct u; intros; shelve|]; (* Synthetize `match .. with` in the validator. *) + unify b b0; + unfold b; destruct u; clear b + : typeclass_instances. + +(* Hint for unfolding definitions. This is necessary because many + hints for IsValidator use [Hint Extern], which do not automatically + unfold identifiers. *) +Hint Extern 100 (IsValidator ?X _) => unfold X + : typeclass_instances. diff --git a/MenhirLib/Validator_complete.v b/MenhirLib/Validator_complete.v new file mode 100644 index 00000000..ebb74500 --- /dev/null +++ b/MenhirLib/Validator_complete.v @@ -0,0 +1,394 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List Syntax Derive. +From Coq.ssr Require Import ssreflect. +Require Automaton. +Require Import Alphabet Validator_classes. + +Module Make(Import A:Automaton.T). + +(** We instantiate some sets/map. **) +Module TerminalComparableM <: ComparableM. + Definition t := terminal. + Instance tComparable : Comparable t := _. +End TerminalComparableM. +Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM. +Module StateProdPosComparableM <: ComparableM. + Definition t := (state*production*nat)%type. + Instance tComparable : Comparable t := _. +End StateProdPosComparableM. +Module StateProdPosOrderedType := + OrderedType_from_ComparableM StateProdPosComparableM. + +Module TerminalSet := FSetAVL.Make TerminalOrderedType. +Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType. + +(** Nullable predicate for symbols and list of symbols. **) +Definition nullable_symb (symbol:symbol) := + match symbol with + | NT nt => nullable_nterm nt + | _ => false + end. + +Definition nullable_word (word:list symbol) := + forallb nullable_symb word. + +(** First predicate for non terminal, symbols and list of symbols, given as FSets. **) +Definition first_nterm_set (nterm:nonterminal) := + fold_left (fun acc t => TerminalSet.add t acc) + (first_nterm nterm) TerminalSet.empty. + +Definition first_symb_set (symbol:symbol) := + match symbol with + | NT nt => first_nterm_set nt + | T t => TerminalSet.singleton t + end. + +Fixpoint first_word_set (word:list symbol) := + match word with + | [] => TerminalSet.empty + | t::q => + if nullable_symb t then + TerminalSet.union (first_symb_set t) (first_word_set q) + else + first_symb_set t + end. + +(** Small helper for finding the part of an item that is after the dot. **) +Definition future_of_prod prod dot_pos : list symbol := + (fix loop n lst := + match n with + | O => lst + | S x => match loop x lst with [] => [] | _::q => q end + end) + dot_pos (rev' (prod_rhs_rev prod)). + +(** We build a fast map to store all the items of all the states. **) +Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t := + fold_left (fun acc state => + fold_left (fun acc item => + let key := (state, prod_item item, dot_pos_item item) in + let data := fold_left (fun acc t => TerminalSet.add t acc) + (lookaheads_item item) TerminalSet.empty + in + let old := + match StateProdPosMap.find key acc with + | Some x => x | None => TerminalSet.empty + end + in + StateProdPosMap.add key (TerminalSet.union data old) acc + ) (items_of_state state) acc + ) all_list (StateProdPosMap.empty TerminalSet.t). + +(** We need to avoid computing items_map each time we need it. To that + purpose, we declare a typeclass specifying that some map is equal to + items_map. *) +Class IsItemsMap m := is_items_map : m = items_map (). + +(** Accessor. **) +Definition find_items_map items_map state prod dot_pos : TerminalSet.t := + match StateProdPosMap.find (state, prod, dot_pos) items_map with + | None => TerminalSet.empty + | Some x => x + end. + +Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) := + exists dot_pos:nat, + fut = future_of_prod prod dot_pos /\ + TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos). + +(** Iterator over items. **) +Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:= + StateProdPosMap.fold (fun key set acc => + match key with (st, p, pos) => (acc && P st p pos set)%bool end + ) items_map true. + +(** Typeclass instances for synthetizing the validator. *) + +Instance is_validator_subset S1 S2 : + IsValidator (TerminalSet.Subset S1 S2) (TerminalSet.subset S1 S2). +Proof. intros ?. by apply TerminalSet.subset_2. Qed. + +(* While the specification of the validator always quantify over + possible lookahead tokens individually, the validator usually + handles lookahead sets directly instead, for better performances. + + For instance, the validator for [state_has_future], which speaks + about one single lookahead token is a subset operation: +*) +Lemma is_validator_state_has_future_subset st prod pos lookahead lset im fut : + TerminalSet.In lookahead lset -> + fut = future_of_prod prod pos -> + IsItemsMap im -> + IsValidator (state_has_future st prod fut lookahead) + (TerminalSet.subset lset (find_items_map im st prod pos)). +Proof. + intros ? -> -> HSS%TerminalSet.subset_2. exists pos. split=>//. by apply HSS. +Qed. +(* We do not declare this lemma as an instance, and use [Hint Extern] + instead, because the typeclass mechanism has trouble instantiating + some evars if we do not explicitely call [eassumption]. *) +Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) => + eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|] +: typeclass_instances. + +(* As said previously, we manipulate lookahead terminal sets instead of + lookahead individually. Hence, when we quantify over a lookahead set + in the specification, we do not do anything in the executable + validator. + + This instance is used for [non_terminal_closed]. *) +Instance is_validator_forall_lookahead_set lset P b: + (forall lookahead, TerminalSet.In lookahead lset -> IsValidator (P lookahead) b) -> + IsValidator (forall lookahead, TerminalSet.In lookahead lset -> P lookahead) b. +Proof. unfold IsValidator. firstorder. Qed. + + +(* Dually, we sometimes still need to explicitelly iterate over a + lookahead set. This is what this lemma allows. + Used only in [end_reduce]. *) +Lemma is_validator_iterate_lset P b lookahead lset : + TerminalSet.In lookahead lset -> + IsValidator P (b lookahead) -> + IsValidator P (TerminalSet.fold (fun lookahead acc => + if acc then b lookahead else false) lset true). +Proof. + intros Hlset%TerminalSet.elements_1 Hval Val. apply Hval. + revert Val. rewrite TerminalSet.fold_1. generalize true at 1. clear -Hlset. + induction Hlset as [? l <-%compare_eq|? l ? IH]=> /= b' Val. + - destruct (b lookahead). by destruct b'. exfalso. by induction l; destruct b'. + - eauto. +Qed. +Hint Extern 100 (IsValidator _ _) => + match goal with + | H : TerminalSet.In ?lookahead ?lset |- _ => + eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H + end +: typeclass_instances. + +(* We often quantify over all the items of all the states of the + automaton. This lemma and the accompanying [Hint Resolve] + declaration allow generating the corresponding executable + validator. + + Note that it turns out that, in all the uses of this pattern, the + first thing we do for each item is pattern-matching over the + future. This lemma also embbed this pattern-matching, which makes + it possible to get the hypothesis [fut' = future_of_prod prod (S pos)] + in the non-nil branch. + + Moreover, note, again, that while the specification quantifies over + lookahead terminals individually, the code provides lookahead sets + instead. *) +Lemma is_validator_forall_items P1 b1 P2 b2 im : + IsItemsMap im -> + + (forall st prod lookahead lset pos, + TerminalSet.In lookahead lset -> + [] = future_of_prod prod pos -> + IsValidator (P1 st prod lookahead) (b1 st prod pos lset)) -> + + (forall st prod pos lookahead lset s fut', + TerminalSet.In lookahead lset -> + fut' = future_of_prod prod (S pos) -> + IsValidator (P2 st prod lookahead s fut') (b2 st prod pos lset s fut')) -> + + IsValidator (forall st prod fut lookahead, + state_has_future st prod fut lookahead -> + match fut with + | [] => P1 st prod lookahead + | s :: fut' => P2 st prod lookahead s fut' + end) + (forallb_items im (fun st prod pos lset => + match future_of_prod prod pos with + | [] => b1 st prod pos lset + | s :: fut' => b2 st prod pos lset s fut' + end)). +Proof. + intros -> Hval1 Hval2 Val st prod fut lookahead (pos & -> & Hlookahead). + rewrite /forallb_items StateProdPosMap.fold_1 in Val. + assert (match future_of_prod prod pos with + | [] => b1 st prod pos (find_items_map (items_map ()) st prod pos) + | s :: fut' => b2 st prod pos (find_items_map (items_map ()) st prod pos) s fut' + end = true). + - unfold find_items_map in *. + assert (Hfind := @StateProdPosMap.find_2 _ (items_map ()) (st, prod, pos)). + destruct StateProdPosMap.find as [lset|]; [|by edestruct (TerminalSet.empty_1); eauto]. + specialize (Hfind _ eq_refl). apply StateProdPosMap.elements_1 in Hfind. + revert Val. generalize true at 1. + induction Hfind as [[? ?] l [?%compare_eq ?]|??? IH]=>?. + + simpl in *; subst. + match goal with |- _ -> ?X = true => destruct X end; [done|]. + rewrite Bool.andb_false_r. clear. induction l as [|[[[??]?]?] l IH]=>//. + + apply IH. + - destruct future_of_prod eqn:EQ. by eapply Hval1; eauto. + eapply Hval2 with (pos := pos); eauto; []. + revert EQ. unfold future_of_prod=>-> //. +Qed. +(* We need a hint for expplicitely instantiating b1 and b2 with lambdas. *) +Hint Extern 0 (IsValidator + (forall st prod fut lookahead, + state_has_future st prod fut lookahead -> _) + _) => + eapply (is_validator_forall_items _ (fun st prod pos lset => _) + _ (fun st prod pos lset s fut' => _)) + : typeclass_instances. + +(* Used in [start_future] only. *) +Instance is_validator_forall_state_has_future im st prod : + IsItemsMap im -> + IsValidator + (forall look, state_has_future st prod (rev' (prod_rhs_rev prod)) look) + (let lookaheads := find_items_map im st prod 0 in + forallb (fun t => TerminalSet.mem t lookaheads) all_list). +Proof. + move=> -> /forallb_forall Val look. + specialize (Val look (all_list_forall _)). exists 0. split=>//. + by apply TerminalSet.mem_2. +Qed. + +(** * Validation for completeness **) + +(** The nullable predicate is a fixpoint : it is correct. **) +Definition nullable_stable := + forall p:production, + if nullable_word (prod_rhs_rev p) then + nullable_nterm (prod_lhs p) = true + else True. + +(** The first predicate is a fixpoint : it is correct. **) +Definition first_stable:= + forall (p:production), + TerminalSet.Subset (first_word_set (rev' (prod_rhs_rev p))) + (first_nterm_set (prod_lhs p)). + +(** The initial state has all the S=>.u items, where S is the start non-terminal **) +Definition start_future := + forall (init:initstate) (p:production), + prod_lhs p = start_nt init -> + forall (t:terminal), + state_has_future init p (rev' (prod_rhs_rev p)) t. + +(** If a state contains an item of the form A->_.av[[b]], where a is a + terminal, then reading an a does a [Shift_act], to a state containing + an item of the form A->_.v[[b]]. **) +Definition terminal_shift := + forall (s1:state) prod fut lookahead, + state_has_future s1 prod fut lookahead -> + match fut with + | T t::q => + match action_table s1 with + | Lookahead_act awp => + match awp t with + | Shift_act s2 _ => + state_has_future s2 prod q lookahead + | _ => False + end + | _ => False + end + | _ => True + end. + +(** If a state contains an item of the form A->_.[[a]], then either we do a + [Default_reduce_act] of the corresponding production, either a is a + terminal (ie. there is a lookahead terminal), and reading a does a + [Reduce_act] of the corresponding production. **) +Definition end_reduce := + forall (s:state) prod fut lookahead, + state_has_future s prod fut lookahead -> + match fut with + | [] => + match action_table s with + | Default_reduce_act p => p = prod + | Lookahead_act awt => + match awt lookahead with + | Reduce_act p => p = prod + | _ => False + end + end + | _ => True + end. + +Definition is_end_reduce items_map := + forallb_items items_map (fun s prod pos lset => + match future_of_prod prod pos with + | [] => + match action_table s with + | Default_reduce_act p => compare_eqb p prod + | Lookahead_act awt => + TerminalSet.fold (fun lookahead acc => + match awt lookahead with + | Reduce_act p => (acc && compare_eqb p prod)%bool + | _ => false + end) lset true + end + | _ => true + end). + +(** If a state contains an item of the form A->_.Bv[[b]], where B is a + non terminal, then the goto table says we have to go to a state containing + an item of the form A->_.v[[b]]. **) +Definition non_terminal_goto := + forall (s1:state) prod fut lookahead, + state_has_future s1 prod fut lookahead -> + match fut with + | NT nt::q => + match goto_table s1 nt with + | Some (exist _ s2 _) => + state_has_future s2 prod q lookahead + | None => False + end + | _ => True + end. + +Definition start_goto := + forall (init:initstate), + match goto_table init (start_nt init) with + | None => True + | Some _ => False + end. + +(** Closure property of item sets : if a state contains an item of the form + A->_.Bv[[b]], then for each production B->u and each terminal a of + first(vb), the state contains an item of the form B->_.u[[a]] **) +Definition non_terminal_closed := + forall s1 prod fut lookahead, + state_has_future s1 prod fut lookahead -> + match fut with + | NT nt::q => + forall p, prod_lhs p = nt -> + (if nullable_word q then + state_has_future s1 p (future_of_prod p 0) lookahead + else True) /\ + (forall lookahead2, + TerminalSet.In lookahead2 (first_word_set q) -> + state_has_future s1 p (future_of_prod p 0) lookahead2) + | _ => True + end. + +(** The automaton is complete **) +Definition complete := + nullable_stable /\ first_stable /\ start_future /\ terminal_shift + /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed. + +Derive is_complete_0 +SuchThat (forall im, IsItemsMap im -> IsValidator complete (is_complete_0 im)) +As complete_0_is_validator. +Proof. intros im. subst is_complete_0. instantiate (1:=fun im => _). apply _. Qed. + +Definition is_complete (_:unit) := is_complete_0 (items_map ()). +Lemma complete_is_validator : IsValidator complete (is_complete ()). +Proof. by apply complete_0_is_validator. Qed. + +End Make. diff --git a/MenhirLib/Validator_safe.v b/MenhirLib/Validator_safe.v new file mode 100644 index 00000000..628d2009 --- /dev/null +++ b/MenhirLib/Validator_safe.v @@ -0,0 +1,234 @@ +(****************************************************************************) +(* *) +(* Menhir *) +(* *) +(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under *) +(* the terms of the GNU Lesser General Public License as published by the *) +(* Free Software Foundation, either version 3 of the License, or (at your *) +(* option) any later version, as described in the file LICENSE. *) +(* *) +(****************************************************************************) + +From Coq Require Import List Syntax Derive. +From Coq.ssr Require Import ssreflect. +Require Automaton. +Require Import Alphabet Validator_classes. + +Module Make(Import A:Automaton.T). + +(** The singleton predicate for states **) +Definition singleton_state_pred (state:state) := + (fun state' => match compare state state' with Eq => true |_ => false end). + +(** [past_state_of_non_init_state], extended for all states. **) +Definition past_state_of_state (state:state) := + match state with + | Init _ => [] + | Ninit nis => past_state_of_non_init_state nis + end. + +(** Concatenations of last and past **) +Definition head_symbs_of_state (state:state) := + match state with + | Init _ => [] + | Ninit s => + last_symb_of_non_init_state s::past_symb_of_non_init_state s + end. +Definition head_states_of_state (state:state) := + singleton_state_pred state::past_state_of_state state. + +(** * Validation for correctness **) + +(** Prefix predicate between two lists of symbols. **) +Inductive prefix: list symbol -> list symbol -> Prop := +| prefix_nil: forall l, prefix [] l +| prefix_cons: forall l1 l2 x, prefix l1 l2 -> prefix (x::l1) (x::l2). + +(** [prefix] is transitive **) +Lemma prefix_trans: + forall (l1 l2 l3:list symbol), prefix l1 l2 -> prefix l2 l3 -> prefix l1 l3. +Proof. + intros l1 l2 l3 H1 H2. revert l3 H2. + induction H1; [now constructor|]. inversion 1. subst. constructor. eauto. +Qed. + +Fixpoint is_prefix (l1 l2:list symbol) := + match l1, l2 with + | [], _ => true + | t1::q1, t2::q2 => (compare_eqb t1 t2 && is_prefix q1 q2)%bool + | _::_, [] => false + end. + +Instance prefix_is_validator l1 l2 : IsValidator (prefix l1 l2) (is_prefix l1 l2). +Proof. + revert l2. induction l1 as [|x1 l1 IH]=>l2 Hpref. + - constructor. + - destruct l2 as [|x2 l2]=>//. + move: Hpref=> /andb_prop [/compare_eqb_iff -> /IH ?]. by constructor. +Qed. + +(** If we shift, then the known top symbols of the destination state is + a prefix of the known top symbols of the source state, with the new + symbol added. **) +Definition shift_head_symbs := + forall s, + match action_table s with + | Lookahead_act awp => forall t, + match awp t with + | Shift_act s2 _ => + prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s) + | _ => True + end + | _ => True + end. + +(** When a goto happens, then the known top symbols of the destination state + is a prefix of the known top symbols of the source state, with the new + symbol added. **) +Definition goto_head_symbs := + forall s nt, + match goto_table s nt with + | Some (exist _ s2 _) => + prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s) + | None => True + end. + +(** We have to say the same kind of checks for the assumptions about the + states stack. However, theses assumptions are predicates. So we define + a notion of "prefix" over predicates lists, that means, basically, that + an assumption entails another **) +Inductive prefix_pred: list (state->bool) -> list (state->bool) -> Prop := + | prefix_pred_nil: forall l, prefix_pred [] l + | prefix_pred_cons: forall l1 l2 f1 f2, + (forall x, implb (f2 x) (f1 x) = true) -> + prefix_pred l1 l2 -> prefix_pred (f1::l1) (f2::l2). + +(** [prefix_pred] is transitive **) +Lemma prefix_pred_trans: + forall (l1 l2 l3:list (state->bool)), + prefix_pred l1 l2 -> prefix_pred l2 l3 -> prefix_pred l1 l3. +Proof. + intros l1 l2 l3 H1 H2. revert l3 H2. + induction H1 as [|l1 l2 f1 f2 Hf2f1]; [now constructor|]. + intros l3. inversion 1 as [|??? f3 Hf3f2]. subst. constructor; [|now eauto]. + intros x. specialize (Hf3f2 x). specialize (Hf2f1 x). + repeat destruct (_ x); auto. +Qed. + +Fixpoint is_prefix_pred (l1 l2:list (state->bool)) := + match l1, l2 with + | [], _ => true + | f1::q1, f2::q2 => + (forallb (fun x => implb (f2 x) (f1 x)) all_list + && is_prefix_pred q1 q2)%bool + | _::_, [] => false + end. + +Instance prefix_pred_is_validator l1 l2 : + IsValidator (prefix_pred l1 l2) (is_prefix_pred l1 l2). +Proof. + revert l2. induction l1 as [|x1 l1 IH]=>l2 Hpref. + - constructor. + - destruct l2 as [|x2 l2]=>//. + move: Hpref=> /andb_prop [/forallb_forall ? /IH ?]. + constructor; auto using all_list_forall. +Qed. + +(** The assumptions about state stack is conserved when we shift **) +Definition shift_past_state := + forall s, + match action_table s with + | Lookahead_act awp => forall t, + match awp t with + | Shift_act s2 _ => + prefix_pred (past_state_of_non_init_state s2) + (head_states_of_state s) + | _ => True + end + | _ => True + end. + +(** The assumptions about state stack is conserved when we do a goto **) +Definition goto_past_state := + forall s nt, + match goto_table s nt with + | Some (exist _ s2 _) => + prefix_pred (past_state_of_non_init_state s2) + (head_states_of_state s) + | None => True + end. + +(** What states are possible after having popped these symbols from the + stack, given the annotation of the current state ? **) +Inductive state_valid_after_pop (s:state): + list symbol -> list (state -> bool) -> Prop := + | state_valid_after_pop_nil1: + forall p pl, p s = true -> state_valid_after_pop s [] (p::pl) + | state_valid_after_pop_nil2: + forall sl, state_valid_after_pop s sl [] + | state_valid_after_pop_cons: + forall st sq p pl, state_valid_after_pop s sq pl -> + state_valid_after_pop s (st::sq) (p::pl). + +Fixpoint is_state_valid_after_pop (state:state) (to_pop:list symbol) annot := + match annot, to_pop with + | [], _ => true + | p::_, [] => p state + | p::pl, s::sl => is_state_valid_after_pop state sl pl + end. + +Instance impl_is_state_valid_after_pop_is_validator state sl pl P b : + IsValidator P b -> + IsValidator (state_valid_after_pop state sl pl -> P) + (if is_state_valid_after_pop state sl pl then b else true). +Proof. + destruct (is_state_valid_after_pop _ sl pl) eqn:EQ. + - intros ???. by eapply is_validator. + - intros _ _ Hsvap. exfalso. induction Hsvap=>//; [simpl in EQ; congruence|]. + by destruct sl. +Qed. + +(** A state is valid for reducing a production when : + - The assumptions on the state are such that we will find the right hand + side of the production on the stack. + - We will be able to do a goto after having popped the right hand side. +**) +Definition valid_for_reduce (state:state) prod := + prefix (prod_rhs_rev prod) (head_symbs_of_state state) /\ + forall state_new, + state_valid_after_pop state_new + (prod_rhs_rev prod) (head_states_of_state state) -> + match goto_table state_new (prod_lhs prod) with + | None => + match state_new with + | Init i => prod_lhs prod = start_nt i + | Ninit _ => False + end + | _ => True + end. + +(** All the states that does a reduce are valid for reduction **) +Definition reduce_ok := + forall s, + match action_table s with + | Lookahead_act awp => + forall t, match awp t with + | Reduce_act p => valid_for_reduce s p + | _ => True + end + | Default_reduce_act p => valid_for_reduce s p + end. + +(** The automaton is safe **) +Definition safe := + shift_head_symbs /\ goto_head_symbs /\ shift_past_state /\ + goto_past_state /\ reduce_ok. + +Derive is_safe +SuchThat (IsValidator safe (is_safe ())) +As safe_is_validator. +Proof. subst is_safe. instantiate (1:=fun _ => _). apply _. Qed. + +End Make. diff --git a/arm/Archi.v b/arm/Archi.v index 39a424ec..16d6c71d 100644 --- a/arm/Archi.v +++ b/arm/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for ARM *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -34,30 +34,57 @@ Proof. unfold splitlong, ptr64; congruence. Qed. -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 false (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). + +(** Choose the first signaling NaN, if any; + otherwise choose the first NaN; + otherwise use default. *) + +Definition choose_nan (is_signaling: positive -> bool) + (default: bool * positive) + (l0: list (bool * positive)) : bool * positive := + let fix choose_snan (l1: list (bool * positive)) := + match l1 with + | nil => + match l0 with nil => default | n :: _ => n end + | ((s, p) as n) :: l1 => + if is_signaling p then n else choose_snan l1 + end + in choose_snan l0. + +Lemma choose_nan_idem: forall is_signaling default n, + choose_nan is_signaling default (n :: n :: nil) = + choose_nan is_signaling default (n :: nil). +Proof. + intros. destruct n as [s p]; unfold choose_nan; simpl. + destruct (is_signaling p); auto. +Qed. + +Definition choose_nan_64 := + choose_nan (fun p => negb (Pos.testbit p 51)) default_nan_64. + +Definition choose_nan_32 := + choose_nan (fun p => negb (Pos.testbit p 22)) default_nan_32. -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - (** Choose second NaN if pl2 is sNaN but pl1 is qNan. - In all other cases, choose first NaN *) - (Pos.testbit pl1 51 && negb (Pos.testbit pl2 51))%bool. +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. intros; apply choose_nan_idem. Qed. -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 false (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. intros; apply choose_nan_idem. Qed. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - (** Choose second NaN if pl2 is sNaN but pl1 is qNan. - In all other cases, choose first NaN *) - (Pos.testbit pl1 22 && negb (Pos.testbit pl2 22))%bool. +Definition fma_order {A: Type} (x y z: A) := (z, x, y). -Definition fpu_returns_default_qNaN := false. +Definition fma_invalid_mul_is_nan := true. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_32 choose_binop_pl_32 - fpu_returns_default_qNaN + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. (** Which ABI to use: either the standard ARM EABI with floats passed diff --git a/cparser/Builtins.mli b/arm/Builtins1.v index 7f9d78a9..f6e643d2 100644 --- a/cparser/Builtins.mli +++ b/arm/Builtins1.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* 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 *) @@ -13,13 +13,21 @@ (* *) (* *********************************************************************) -val environment: unit -> Env.t -val identifiers: unit -> C.ident list -val declarations: unit -> C.globdecl list +(** Platform-specific built-in functions *) -type t = { - typedefs: (string * C.typ) list; - functions: (string * (C.typ * C.typ list * bool)) list -} +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. -val set: t -> unit +Inductive platform_builtin : Type := . + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with end. diff --git a/arm/CBuiltins.ml b/arm/CBuiltins.ml index ec4f4aaa..d6a1ea35 100644 --- a/arm/CBuiltins.ml +++ b/arm/CBuiltins.ml @@ -18,10 +18,10 @@ open C let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", TPtr(TVoid [], []) ]; - Builtins.functions = [ + builtin_functions = [ (* Integer arithmetic *) "__builtin_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); diff --git a/arm/ConstpropOp.vp b/arm/ConstpropOp.vp index d62240ef..8555d3aa 100644 --- a/arm/ConstpropOp.vp +++ b/arm/ConstpropOp.vp @@ -20,7 +20,7 @@ Require Import Integers. Require Import Floats. Require Import Op. Require Import Registers. -Require Import ValueDomain. +Require Import ValueDomain ValueAOp. (** * Converting known values to constants *) @@ -131,6 +131,15 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := make_cmp_base c args vl end. +Definition make_select (c: condition) (ty: typ) + (r1 r2: reg) (args: list reg) (vl: list aval) := + match resolve_branch (eval_static_condition c vl) with + | Some b => (Omove, (if b then r1 else r2) :: nil) + | None => + let (c', args') := cond_strength_reduction c args vl in + (Osel c' ty, r1 :: r2 :: args') + end. + Definition make_addimm (n: int) (r: reg) := if Int.eq n Int.zero then (Omove, r :: nil) @@ -284,6 +293,7 @@ Nondetfunction op_strength_reduction | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 | Ocmp c, args, vl => make_cmp c args vl + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index 079ba2be..a4f5c29c 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -24,7 +24,7 @@ Require Import Events. Require Import Op. Require Import Registers. Require Import RTL. -Require Import ValueDomain. +Require Import ValueDomain ValueAOp ValueAnalysis. Require Import ConstpropOp. Local Transparent Archi.ptr64. @@ -234,6 +234,28 @@ Proof. - apply make_cmp_base_correct; auto. Qed. +Lemma make_select_correct: + forall c ty r1 r2 args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_select c ty r1 r2 args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v + /\ Val.lessdef (Val.select (eval_condition c rs##args m) rs#r1 rs#r2 ty) v. +Proof. + unfold make_select; intros. + destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB. +- exists (if b then rs#r1 else rs#r2); split. ++ simpl. destruct b; auto. ++ destruct (eval_condition c rs##args m) as [b'|] eqn:EC; simpl; auto. + assert (b = b'). + { eapply resolve_branch_sound; eauto. + rewrite <- EC. apply eval_static_condition_sound with bc. + subst vl. exact (aregs_sound _ _ _ args MATCH). } + subst b'. apply Val.lessdef_normalize. +- generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ. + econstructor; split. simpl; eauto. rewrite EQ; auto. +Qed. + Lemma make_addimm_correct: forall n r, let (op, args) := make_addimm n r in @@ -616,6 +638,8 @@ Proof. InvApproxRegs; SimplVM. inv H0. apply make_shruimm_correct; auto. (* cmp *) inv H0. apply make_cmp_correct; auto. +(* select *) + inv H0. apply make_select_correct; congruence. (* mulf *) InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) rs#r2). diff --git a/arm/SelectOp.vp b/arm/SelectOp.vp index e3ef3eaf..ed4c2c95 100644 --- a/arm/SelectOp.vp +++ b/arm/SelectOp.vp @@ -38,12 +38,8 @@ Require Import Coqlib. Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import OpHelpers. -Require Import CminorSel. +Require Import AST Integers Floats Builtins. +Require Import Op OpHelpers CminorSel. Local Open Scope cminorsel_scope. @@ -520,9 +516,16 @@ Nondetfunction builtin_arg (e: expr) := | _ => BA e end. +<<<<<<< HEAD (* floats *) Definition divf_base (e1: expr) (e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). Definition divfs_base (e1: expr) (e2: expr) := Eop Odivfs (e1 ::: e2 ::: Enil). +======= +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index f7dd8dd6..75d32ea3 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -13,16 +13,9 @@ (** Correctness of instruction selection for operators *) Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. +Require Import AST Integers Floats. +Require Import Values Memory Builtins Globalenvs. +Require Import Cminor Op CminorSel. Require Import SelectOp. Require Import OpHelpers OpHelpersproof. @@ -912,7 +905,6 @@ Proof. - constructor; auto. Qed. - (* floating-point division without HELPERS *) Theorem eval_divf_base: forall le a b x y, @@ -933,4 +925,17 @@ Proof. intros; unfold divfs_base. TrivialExists. Qed. + +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + End CMCONSTR. diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 3a0814e1..03e06a65 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -113,9 +113,9 @@ struct let freg_single oc r = output_string oc (single_float_reg_name r) let freg_param_single oc r = output_string oc (single_param_reg_name r) - let preg oc = function + let preg_asm oc ty = function | IR r -> ireg oc r - | FR r -> freg oc r + | FR r -> if ty = Tsingle then freg_single oc r else freg oc r | _ -> assert false (* In Thumb2 mode, some arithmetic instructions have shorter encodings @@ -480,7 +480,7 @@ struct (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false diff --git a/backend/CSE.v b/backend/CSE.v index 6d3f6f33..ecfa1f9e 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -14,7 +14,7 @@ proceeds by value numbering over extended basic blocks. *) Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. -Require Import AST Linking. +Require Import AST Linking Builtins. Require Import Values Memory. Require Import Op Registers RTL. Require Import ValueDomain ValueAnalysis CSEdomain CombineOp. @@ -444,10 +444,10 @@ Module Solver := BBlock_solver(Numbering). ([EF_external], [EF_runtime], [EF_malloc], [EF_free]). - Forget equations involving loads but keep equations over registers. This is appropriate for builtins that can modify memory, - e.g. volatile stores, or [EF_builtin] + e.g. volatile stores, or [EF_builtin] for unknown builtin functions. - Keep all equations, taking advantage of the fact that neither memory - nor registers are modified. This is appropriate for annotations - and for volatile loads. + nor registers are modified. This is appropriate for annotations, + volatile loads, and known builtin functions. *) Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numbering) := @@ -473,8 +473,13 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb match ef with | EF_external _ _ | EF_runtime _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ => empty_numbering - | EF_builtin _ _ | EF_vstore _ => + | EF_vstore _ => set_res_unknown (kill_all_loads before) res + | EF_builtin name sg => + match lookup_builtin_function name sg with + | Some bf => set_res_unknown before res + | None => set_res_unknown (kill_all_loads before) res + end | EF_memcpy sz al => match args with | dst :: src :: nil => diff --git a/backend/CSEproof.v b/backend/CSEproof.v index a60c316b..03c7ecfc 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. +Require Import Values Memory Builtins Events Globalenvs Smallstep. Require Import Op Registers RTL. Require Import ValueDomain ValueAOp ValueAnalysis. Require Import CSEdomain CombineOp CombineOpproof CSE. @@ -1129,7 +1129,9 @@ Proof. { exists valu. apply set_res_unknown_holds. eapply kill_all_loads_hold; eauto. } destruct ef. + apply CASE1. - + apply CASE3. + + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK. + ++ apply CASE2. simpl in H1; red in H1; rewrite LK in H1; inv H1. auto. + ++ apply CASE3. + apply CASE1. + apply CASE2; inv H1; auto. + apply CASE3. diff --git a/backend/Constprop.v b/backend/Constprop.v index d8211ffe..4aab7677 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -15,7 +15,7 @@ and the corresponding code rewriting. *) Require Import Coqlib Maps Integers Floats Lattice Kildall. -Require Import AST Linking. +Require Import AST Linking Builtins. Require Compopts Machregs. Require Import Op Registers RTL. Require Import Liveness ValueDomain ValueAOp ValueAnalysis. @@ -139,6 +139,30 @@ Definition builtin_strength_reduction | _ => builtin_args_strength_reduction ae al (Machregs.builtin_constraints ef) end. +(* +Definition transf_builtin + (ae: AE.t) (am: amem) (rm: romem) + (ef: external_function) + (args: list (builtin_arg reg)) (res: builtin_res reg) (s: node) := + let dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res s in + match ef, res with + | EF_builtin name sg, BR rd => + match lookup_builtin_function name sg with + | Some bf => + match eval_static_builtin_function ae am rm bf args with + | Some a => + match const_for_result a with + | Some cop => Iop cop nil rd s + | None => dfl + end + | None => dfl + end + | None => dfl + end + | _, _ => dfl + end. +*) + Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) (pc: node) (instr: instruction) := match an!!pc with @@ -176,7 +200,23 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem) | Itailcall sig ros args => Itailcall sig (transf_ros ae ros) args | Ibuiltin ef args res s => - Ibuiltin ef (builtin_strength_reduction ae ef args) res s + let dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res s in + match ef, res with + | EF_builtin name sg, BR rd => + match lookup_builtin_function name sg with + | Some bf => + match eval_static_builtin_function ae am rm bf args with + | Some a => + match const_for_result a with + | Some cop => Iop cop nil rd s + | None => dfl + end + | None => dfl + end + | None => dfl + end + | _, _ => dfl + end | Icond cond args s1 s2 => let aargs := aregs ae args in match resolve_branch (eval_static_condition cond aargs) with diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index e28519ca..a5d08a0f 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Maps Integers Floats Lattice Kildall. Require Import AST Linking. -Require Import Values Events Memory Globalenvs Smallstep. +Require Import Values Builtins Events Memory Globalenvs Smallstep. Require Compopts Machregs. Require Import Op Registers RTL. Require Import Liveness ValueDomain ValueAOp ValueAnalysis. @@ -474,19 +474,41 @@ Proof. - (* Ibuiltin *) rename pc'0 into pc. TransfInstr; intros. Opaque builtin_strength_reduction. - exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q). - exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)). + set (dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res pc') in *. + set (rm := romem_for cu) in *. + assert (DFL: (fn_code (transf_function rm f))!pc = Some dfl -> + exists (n2 : nat) (s2' : state), + step tge + (State s' (transf_function rm f) (Vptr sp0 Ptrofs.zero) pc rs' m'0) t s2' /\ + match_states n2 + (State s f (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res vres rs) m') s2'). + { + exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q). + exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)). apply REGS. eauto. eexact P. - intros (vargs'' & U & V). - exploit external_call_mem_extends; eauto. - intros [v' [m2' [A [B [C D]]]]]. + intros (vargs'' & U & V). + exploit external_call_mem_extends; eauto. + intros (v' & m2' & A & B & C & D). + econstructor; econstructor; split. + eapply exec_Ibuiltin; eauto. + eapply eval_builtin_args_preserved. eexact symbols_preserved. eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eapply match_states_succ; eauto. + apply set_res_lessdef; auto. + } + destruct ef; auto. + destruct res; auto. + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK; auto. + destruct (eval_static_builtin_function ae am rm bf args) as [a|] eqn:ES; auto. + destruct (const_for_result a) as [cop|] eqn:CR; auto. + clear DFL. simpl in H1; red in H1; rewrite LK in H1; inv H1. + exploit const_for_result_correct; eauto. + eapply eval_static_builtin_function_sound; eauto. + intros (v' & A & B). left; econstructor; econstructor; split. - eapply exec_Ibuiltin; eauto. - eapply eval_builtin_args_preserved. eexact symbols_preserved. eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eapply exec_Iop; eauto. eapply match_states_succ; eauto. - apply set_res_lessdef; auto. - + apply set_reg_lessdef; auto. - (* Icond, preserved *) rename pc'0 into pc. TransfInstr. set (ac := eval_static_condition cond (aregs ae args)). diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 46d5c3f1..902724e0 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -106,7 +106,7 @@ let flatten_blocks blks = let cmp_minpc (mpc1, _) (mpc2, _) = if mpc1 = mpc2 then 0 else if mpc1 > mpc2 then -1 else 1 in - List.flatten (List.map Pervasives.snd (List.sort cmp_minpc blks)) + List.flatten (List.map snd (List.sort cmp_minpc blks)) (* Build the enumeration *) diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index dd428808..155f5e55 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -13,7 +13,6 @@ open AST open Camlcoq -open DwarfPrinter open PrintAsmaux open Printf open Sections @@ -177,7 +176,7 @@ module Printer(Target:TARGET) = let address = Target.address end - module DebugPrinter = DwarfPrinter (DwarfTarget) + module DebugPrinter = DwarfPrinter.DwarfPrinter (DwarfTarget) end let print_program oc p = diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 7e075f04..8652b2c5 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -245,14 +245,15 @@ let print_debug_info comment print_line preg_string sp_name oc kind txt args = (** Inline assembly *) -let print_asm_argument print_preg oc modifier = function - | BA r -> print_preg oc r +let print_asm_argument print_preg oc modifier typ = function + | BA r -> print_preg oc typ r | BA_splitlong(BA hi, BA lo) -> begin match modifier with - | "R" -> print_preg oc hi - | "Q" -> print_preg oc lo - | _ -> fprintf oc "%a:%a" print_preg hi print_preg lo - (* Probably not what was intended *) + | "R" -> print_preg oc Tint hi + | "Q" -> print_preg oc Tint lo + | _ -> print_preg oc Tint hi; fprintf oc ":"; print_preg oc Tint lo + (* This case (printing a split long in full) should never + happen because of the checks done in ExtendedAsm.ml *) end | _ -> failwith "bad asm argument" @@ -265,8 +266,10 @@ let re_asm_param_1 = Str.regexp "%%\\|%[QR]?[0-9]+" let re_asm_param_2 = Str.regexp "%\\([QR]?\\)\\([0-9]+\\)" let print_inline_asm print_preg oc txt sg args res = - let operands = - if sg.sig_res = None then args else builtin_arg_of_res res :: args in + let (operands, ty_operands) = + match sg.sig_res with + | None -> (args, sg.sig_args) + | Some tres -> (builtin_arg_of_res res :: args, tres :: sg.sig_args) in let print_fragment = function | Str.Text s -> output_string oc s @@ -277,7 +280,9 @@ let print_inline_asm print_preg oc txt sg args res = let modifier = Str.matched_group 1 s and number = int_of_string (Str.matched_group 2 s) in try - print_asm_argument print_preg oc modifier (List.nth operands number) + print_asm_argument print_preg oc modifier + (List.nth ty_operands number) + (List.nth operands number) with Failure _ -> fprintf oc "<bad parameter %s>" s in List.iter print_fragment (Str.full_split re_asm_param_1 txt); diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml index f68c1267..8c255a65 100644 --- a/backend/PrintCminor.ml +++ b/backend/PrintCminor.ml @@ -16,7 +16,7 @@ (** Pretty-printer for Cminor *) open Format -open Camlcoq +open !Camlcoq open Integers open AST open PrintAST diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml index d0557073..1c449e74 100644 --- a/backend/PrintLTL.ml +++ b/backend/PrintLTL.ml @@ -112,7 +112,7 @@ let print_function pp id f = fprintf pp "%s() {\n" (extern_atom id); let instrs = List.sort - (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1) + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) (List.rev_map (fun (pc, i) -> (P.to_int pc, i)) (PTree.elements f.fn_code)) in diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml index ba336b0a..841540b6 100644 --- a/backend/PrintRTL.ml +++ b/backend/PrintRTL.ml @@ -93,7 +93,7 @@ let print_function pp id f = fprintf pp "%s(%a) {\n" (extern_atom id) regs f.fn_params; let instrs = List.sort - (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1) + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) (List.rev_map (fun (pc, i) -> (P.to_int pc, i)) (PTree.elements f.fn_code)) in diff --git a/backend/PrintXTL.ml b/backend/PrintXTL.ml index cc1f7d49..6432682a 100644 --- a/backend/PrintXTL.ml +++ b/backend/PrintXTL.ml @@ -138,7 +138,7 @@ let print_function pp ?alloc ?live f = fprintf pp "f() {\n"; let instrs = List.sort - (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1) + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) (List.map (fun (pc, i) -> (P.to_int pc, i)) (PTree.elements f.fn_code)) in diff --git a/backend/Selection.v b/backend/Selection.v index 2d407094..4ab3331e 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -24,7 +24,7 @@ Require String. Require Import Coqlib Maps. -Require Import AST Errors Integers Globalenvs Switch. +Require Import AST Errors Integers Globalenvs Builtins Switch. Require Cminor. Require Import Op CminorSel OpHelpers Cminortyping. Require Import SelectOp SplitLong SelectLong SelectDiv. @@ -162,6 +162,13 @@ Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := | Cminor.Ocmplu c => cmplu c arg1 arg2 end. +Definition sel_select (ty: typ) (cnd ifso ifnot: expr) : expr := + let (cond, args) := condition_of_expr cnd in + match SelectOp.select ty cond args ifso ifnot with + | Some a => a + | None => Econdition (condexpr_of_expr cnd) ifso ifnot + end. + (** Conversion from Cminor expression to Cminorsel expressions *) Fixpoint sel_expr (a: Cminor.expr) : expr := @@ -231,6 +238,43 @@ Definition sel_builtin_res (optid: option ident) : builtin_res ident := | Some id => BR id end. +(** Known builtin functions *) + +Function sel_known_builtin (bf: builtin_function) (args: exprlist) := + match bf, args with + | BI_platform b, _ => + SelectOp.platform_builtin b args + | BI_standard (BI_select ty), a1 ::: a2 ::: a3 ::: Enil => + Some (sel_select ty a1 a2 a3) + | BI_standard BI_fabs, a1 ::: Enil => + Some (SelectOp.absf a1) + | _, _ => + None + end. + +(** Builtin functions in general *) + +Definition sel_builtin_default (optid: option ident) (ef: external_function) + (args: list Cminor.expr) := + Sbuiltin (sel_builtin_res optid) ef + (sel_builtin_args args (Machregs.builtin_constraints ef)). + +Definition sel_builtin (optid: option ident) (ef: external_function) + (args: list Cminor.expr) := + match optid, ef with + | Some id, 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 + end + | None => sel_builtin_default optid ef args + end + | _, _ => + sel_builtin_default optid ef args + end. + (** Conversion of Cminor [switch] statements to decision trees. *) Parameter compile_switch: Z -> nat -> table -> comptree. @@ -342,16 +386,10 @@ Fixpoint sel_stmt (ki: known_idents) (env: typenv) (s: Cminor.stmt) : res stmt : OK (match classify_call fn with | Call_default => Scall optid sg (inl _ (sel_expr fn)) (sel_exprlist args) | Call_imm id => Scall optid sg (inr _ id) (sel_exprlist args) - | Call_builtin ef => (Sbuiltin (sel_builtin_res optid) ef - (sel_builtin_args args - (Machregs.builtin_constraints ef))) - (* sel_builtin_default optid ef args *) - (* THIS IS WHERE TO ACTIVATE OUR OWN BUILTINS - change sel_builtin_default to sel_builtin *) + | Call_builtin ef => sel_builtin optid ef args end) | Cminor.Sbuiltin optid ef args => - OK (Sbuiltin (sel_builtin_res optid) ef - (sel_builtin_args args (Machregs.builtin_constraints ef))) + OK (sel_builtin optid ef args) | Cminor.Stailcall sg fn args => OK (match classify_call fn with | Call_imm id => Stailcall sg (inr _ id) (sel_exprlist args) diff --git a/backend/Selectionaux.ml b/backend/Selectionaux.ml index 4e366564..60a1eccd 100644 --- a/backend/Selectionaux.ml +++ b/backend/Selectionaux.ml @@ -80,10 +80,10 @@ let fast_cmove ty = | a, m -> failwith (Printf.sprintf "fast_cmove: unknown arch %s %s" a m) (* The if-conversion heuristic depend on the - -fif-conversion and -ffavor-branchless flags. + -fif-conversion and -Obranchless flags. With [-fno-if-conversion] or [-0O], if-conversion is turned off entirely. -With [-ffavor-branchless], if-conversion is performed whenever semantically +With [-Obranchless], if-conversion is performed whenever semantically correct, regardless of how much it could cost. Otherwise (and by default), optimization is performed when it seems beneficial. @@ -111,7 +111,7 @@ instructions from the first branch. let if_conversion_heuristic cond ifso ifnot ty = if not !Clflags.option_fifconversion then false else - if !Clflags.option_ffavor_branchless then true else + if !Clflags.option_Obranchless then true else if not (fast_cmove ty) then false else let c1 = cost_expr ifso and c2 = cost_expr ifnot in c1 + c2 <= 24 && abs (c1 - c2) <= 8 diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 40db5d4b..622992e5 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -14,7 +14,8 @@ Require Import FunInd. Require Import Coqlib Maps. -Require Import AST Linking Errors Integers Values Memory Events Globalenvs Smallstep. +Require Import AST Linking Errors Integers. +Require Import Values Memory Builtins Events Globalenvs Smallstep. Require Import Switch Cminor Op CminorSel Cminortyping. Require Import OpHelpers OpHelpersproof. Require Import SelectOp SelectDiv SplitLong SelectLong Selection. @@ -217,19 +218,16 @@ Lemma eval_condition_of_expr: forall a le v b, eval_expr tge sp e m le a v -> Val.bool_of_val v b -> - let (cond, al) := condition_of_expr a in exists vl, - eval_exprlist tge sp e m le al vl - /\ eval_condition cond vl m = Some b. + eval_exprlist tge sp e m le (snd (condition_of_expr a)) vl + /\ eval_condition (fst (condition_of_expr a)) vl m = Some b. Proof. - intros until a. functional induction (condition_of_expr a); intros. -(* compare *) - inv H. simpl in H6. inv H6. apply Val.bool_of_val_of_optbool in H0. - exists vl; auto. -(* default *) - exists (v :: nil); split. - econstructor. auto. constructor. - simpl. inv H0. auto. + intros a; functional induction (condition_of_expr a); intros; simpl. +- inv H. exists vl; split; auto. + simpl in H6. inv H6. apply Val.bool_of_val_of_optbool in H0. auto. +- exists (v :: nil); split. + constructor; auto; constructor. + inv H0; simpl; auto. Qed. Lemma eval_load: @@ -354,6 +352,52 @@ Proof. exists v; split; auto. eapply eval_cmplu; eauto. Qed. +Lemma eval_sel_select: + forall le a1 a2 a3 v1 v2 v3 b ty, + eval_expr tge sp e m le a1 v1 -> + eval_expr tge sp e m le a2 v2 -> + eval_expr tge sp e m le a3 v3 -> + Val.bool_of_val v1 b -> + exists v, eval_expr tge sp e m le (sel_select ty a1 a2 a3) v + /\ Val.lessdef (Val.select (Some b) v2 v3 ty) v. +Proof. + unfold sel_select; intros. + specialize (eval_condition_of_expr _ _ _ _ H H2). + destruct (condition_of_expr a1) as [cond args]; simpl fst; simpl snd. intros (vl & A & B). + destruct (select ty cond args a2 a3) as [a|] eqn:SEL. +- eapply eval_select; eauto. +- exists (if b then v2 else v3); split. + econstructor; eauto. eapply eval_condexpr_of_expr; eauto. destruct b; auto. + apply Val.lessdef_normalize. +Qed. + +(** Known built-in functions *) + +Lemma eval_sel_known_builtin: + forall bf args a vl v le, + sel_known_builtin bf args = Some a -> + eval_exprlist tge sp e m le args vl -> + builtin_function_sem bf vl = Some v -> + exists v', eval_expr tge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros until le; intros SEL ARGS SEM. + destruct bf as [bf|bf]; simpl in SEL. +- destruct bf; try discriminate. ++ (* select *) + inv ARGS; try discriminate. inv H0; try discriminate. inv H2; try discriminate. inv H3; try discriminate. + inv SEL. + simpl in SEM. destruct v1; inv SEM. + replace (Val.normalize (if Int.eq i Int.zero then v2 else v0) t) + with (Val.select (Some (negb (Int.eq i Int.zero))) v0 v2 t) + by (destruct (Int.eq i Int.zero); reflexivity). + eapply eval_sel_select; eauto. constructor. ++ (* fabs *) + inv ARGS; try discriminate. inv H0; try discriminate. + inv SEL. + simpl in SEM; inv SEM. apply eval_absf; auto. +- eapply eval_platform_builtin; eauto. +Qed. + End CMCONSTR. (** Recognition of calls to built-in functions *) @@ -794,6 +838,51 @@ Proof. intros. destruct oid; simpl; auto. apply set_var_lessdef; auto. Qed. +Lemma sel_builtin_default_correct: + forall optid ef al sp e1 m1 vl t v m2 e1' m1' f k, + Cminor.eval_exprlist ge sp e1 m1 al vl -> + 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') + /\ env_lessdef (set_optvar optid v e1) e2' + /\ Mem.extends m2 m2'. +Proof. + intros. unfold sel_builtin_default. + 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. + econstructor. eexact A. eapply external_call_symbols_preserved. eexact senv_preserved. eexact D. + split; auto. apply sel_builtin_res_correct; auto. +Qed. + +Lemma sel_builtin_correct: + forall optid ef al sp e1 m1 vl t v m2 e1' m1' f k, + Cminor.eval_exprlist ge sp e1 m1 al vl -> + 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') + /\ env_lessdef (set_optvar optid v e1) e2' + /\ Mem.extends m2 m2'. +Proof. + intros. + 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. + exploit eval_sel_known_builtin; eauto. intros (v'' & U & V). + econstructor; exists m2'; split. + econstructor. eexact U. + split; auto. apply set_var_lessdef; auto. apply Val.lessdef_trans with v'; auto. +Qed. + (** If-conversion *) Lemma classify_stmt_sound_1: @@ -983,19 +1072,18 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := match_states (Cminor.Returnstate v k m) (Returnstate v' k' m') - | match_builtin_1: forall cunit hf ef args args' optid f sp e k m al f' e' k' m' env + | match_builtin_1: forall cunit hf ef args optid f sp e k m al f' e' k' m' env (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) (TF: sel_function (prog_defmap cunit) hf f = OK f') (TYF: type_function f = OK env) (MC: match_cont cunit hf (known_id f) env k k') - (LDA: Val.lessdef_list args args') + (EA: Cminor.eval_exprlist ge sp e m al args) (LDE: env_lessdef e e') - (ME: Mem.extends m m') - (EA: list_forall2 (CminorSel.eval_builtin_arg tge sp e' m') al args'), + (ME: Mem.extends m m'), match_states (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m) - (State f' (Sbuiltin (sel_builtin_res optid) ef al) k' sp e' m') + (State f' (sel_builtin optid ef al) k' sp e' m') | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' env (LINK: linkorder cunit prog) (HF: helper_functions_declared cunit hf) @@ -1003,11 +1091,11 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (TYF: type_function f = OK env) (MC: match_cont cunit hf (known_id f) env k k') (LDV: Val.lessdef v v') - (LDE: env_lessdef e e') + (LDE: env_lessdef (set_optvar optid v e) e') (ME: Mem.extends m m'), match_states (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m) - (State f' Sskip k' sp (set_builtin_res (sel_builtin_res optid) v' e') m'). + (State f' Sskip k' sp e' m'). Remark call_cont_commut: forall cunit hf ki env k k', @@ -1079,6 +1167,14 @@ Proof. destruct (ident_eq id id0). conclude. discriminate. Qed. +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. +Qed. + Remark find_label_commut: forall cunit hf ki env lbl s k s' k', match_cont cunit hf ki env k k' -> @@ -1093,9 +1189,12 @@ Proof. (* store *) - unfold store. destruct (addressing m (sel_expr e)); simpl; auto. (* call *) -- destruct (classify_call (prog_defmap cunit) e); simpl; auto. + destruct (classify_call (prog_defmap cunit) e); simpl; auto. + rewrite sel_builtin_nolabel; auto. (* tailcall *) -- destruct (classify_call (prog_defmap cunit) e); simpl; auto. + destruct (classify_call (prog_defmap cunit) e); simpl; auto. +(* builtin *) + rewrite sel_builtin_nolabel; auto. (* seq *) - exploit (IHs1 (Cminor.Kseq s2 k)). constructor; eauto. eauto. destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)) as [[sx kx] | ]; @@ -1189,9 +1288,7 @@ Proof. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto. + (* turned into Sbuiltin *) intros EQ. subst fd. - exploit sel_builtin_args_correct; eauto. intros [vargs' [C D]]. - right; left; split. simpl. omega. split. auto. - econstructor; eauto. + right; left; split. simpl; omega. split; auto. econstructor; eauto. - (* Stailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. @@ -1208,12 +1305,8 @@ Proof. eapply match_callstate with (cunit := cunit'); eauto. eapply call_cont_commut; eauto. - (* Sbuiltin *) - exploit sel_builtin_args_correct; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2 [A [B [C D]]]]]. - left; econstructor; split. - econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. apply sel_builtin_res_correct; auto. + exploit sel_builtin_correct; eauto. intros (e2' & m2' & P & Q & R). + left; econstructor; split. eexact P. econstructor; eauto. - (* Seq *) left; econstructor; split. constructor. @@ -1304,11 +1397,8 @@ Proof. econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* external call turned into a Sbuiltin *) - exploit external_call_mem_extends; eauto. - intros [vres' [m2 [A [B [C D]]]]]. - left; econstructor; split. - econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. + exploit sel_builtin_correct; eauto. intros (e2' & m2' & P & Q & R). + left; econstructor; split. eexact P. econstructor; eauto. - (* return *) inv MC. left; econstructor; split. @@ -1316,7 +1406,6 @@ Proof. 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. - apply sel_builtin_res_correct; auto. Qed. Lemma sel_initial_states: diff --git a/backend/SplitLongproof.v b/backend/SplitLongproof.v index 6718ba5b..df77b322 100644 --- a/backend/SplitLongproof.v +++ b/backend/SplitLongproof.v @@ -15,13 +15,39 @@ Require Import String. Require Import Coqlib Maps. Require Import AST Errors Integers Floats. -Require Import Values Memory Globalenvs Events Cminor Op CminorSel. +Require Import Values Memory Globalenvs Builtins Events Cminor Op CminorSel. Require Import OpHelpers OpHelpersproof. +Require Import Values Memory Globalenvs Builtins Events Cminor Op CminorSel. Require Import SelectOp SelectOpproof SplitLong. Local Open Scope cminorsel_scope. Local Open Scope string_scope. +<<<<<<< HEAD +======= +(** * Properties of the helper functions *) + +Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := + (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). + +Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := + helper_declared p i64_dtos "__compcert_i64_dtos" sig_f_l + /\ helper_declared p i64_dtou "__compcert_i64_dtou" sig_f_l + /\ helper_declared p i64_stod "__compcert_i64_stod" sig_l_f + /\ helper_declared p i64_utod "__compcert_i64_utod" sig_l_f + /\ helper_declared p i64_stof "__compcert_i64_stof" sig_l_s + /\ helper_declared p i64_utof "__compcert_i64_utof" sig_l_s + /\ helper_declared p i64_sdiv "__compcert_i64_sdiv" sig_ll_l + /\ helper_declared p i64_udiv "__compcert_i64_udiv" sig_ll_l + /\ helper_declared p i64_smod "__compcert_i64_smod" sig_ll_l + /\ helper_declared p i64_umod "__compcert_i64_umod" sig_ll_l + /\ helper_declared p i64_shl "__compcert_i64_shl" sig_li_l + /\ helper_declared p i64_shr "__compcert_i64_shr" sig_li_l + /\ helper_declared p i64_sar "__compcert_i64_sar" sig_li_l + /\ helper_declared p i64_umulh "__compcert_i64_umulh" sig_ll_l + /\ helper_declared p i64_smulh "__compcert_i64_smulh" sig_ll_l. + +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf (** * Correctness of the instruction selection functions for 64-bit operators *) Section CMCONSTR. @@ -34,60 +60,71 @@ Variable sp: val. Variable e: env. Variable m: mem. +<<<<<<< HEAD Ltac UseHelper := decompose [Logic.and] arith_helpers_correct; eauto. +======= +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. Lemma eval_helper: - forall le id name sg args vargs vres, + forall bf le id name sg args vargs vres, eval_exprlist ge sp e m le args vargs -> helper_declared prog id name sg -> - external_implements name sg vargs vres -> + lookup_builtin_function name sg = Some bf -> + builtin_function_sem bf vargs = Some vres -> eval_expr ge sp e m le (Eexternal id sg args) vres. Proof. intros. red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q). rewrite <- Genv.find_funct_ptr_iff in Q. - econstructor; eauto. + econstructor; eauto. + simpl. red. rewrite H1. constructor; auto. Qed. Corollary eval_helper_1: - forall le id name sg arg1 varg1 vres, + forall bf le id name sg arg1 varg1 vres, eval_expr ge sp e m le arg1 varg1 -> helper_declared prog id name sg -> - external_implements name sg (varg1::nil) vres -> + lookup_builtin_function name sg = Some bf -> + builtin_function_sem bf (varg1 :: nil) = Some vres -> eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres. Proof. intros. eapply eval_helper; eauto. constructor; auto. constructor. Qed. Corollary eval_helper_2: - forall le id name sg arg1 arg2 varg1 varg2 vres, + forall bf le id name sg arg1 arg2 varg1 varg2 vres, eval_expr ge sp e m le arg1 varg1 -> eval_expr ge sp e m le arg2 varg2 -> helper_declared prog id name sg -> - external_implements name sg (varg1::varg2::nil) vres -> + lookup_builtin_function name sg = Some bf -> + builtin_function_sem bf (varg1 :: varg2 :: nil) = Some vres -> eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres. Proof. intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor. Qed. Remark eval_builtin_1: - forall le id sg arg1 varg1 vres, + forall bf le id sg arg1 varg1 vres, eval_expr ge sp e m le arg1 varg1 -> - builtin_implements id sg (varg1::nil) vres -> + lookup_builtin_function id sg = Some bf -> + builtin_function_sem bf (varg1 :: nil) = Some vres -> eval_expr ge sp e m le (Ebuiltin (EF_builtin id sg) (arg1 ::: Enil)) vres. Proof. - intros. econstructor. econstructor. eauto. constructor. apply H0. + intros. econstructor. econstructor. eauto. constructor. + simpl. red. rewrite H0. constructor. auto. Qed. Remark eval_builtin_2: - forall le id sg arg1 arg2 varg1 varg2 vres, + forall bf le id sg arg1 arg2 varg1 varg2 vres, eval_expr ge sp e m le arg1 varg1 -> eval_expr ge sp e m le arg2 varg2 -> - builtin_implements id sg (varg1::varg2::nil) vres -> + lookup_builtin_function id sg = Some bf -> + builtin_function_sem bf (varg1 :: varg2 :: nil) = Some vres -> eval_expr ge sp e m le (Ebuiltin (EF_builtin id sg) (arg1 ::: arg2 ::: Enil)) vres. Proof. - intros. econstructor. constructor; eauto. constructor; eauto. constructor. apply H1. + intros. econstructor. constructor; eauto. constructor; eauto. constructor. + simpl. red. rewrite H1. constructor. auto. Qed. Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := @@ -336,9 +373,10 @@ Qed. Theorem eval_negl: unary_constructor_sound negl Val.negl. Proof. unfold negl; red; intros. destruct (is_longconst a) eqn:E. - econstructor; split. apply eval_longconst. +- econstructor; split. apply eval_longconst. exploit is_longconst_sound; eauto. intros EQ; subst x. simpl. auto. - econstructor; split. eapply eval_builtin_1; eauto. UseHelper. auto. +- exists (Val.negl x); split; auto. + eapply (eval_builtin_1 (BI_standard BI_negl)); eauto. Qed. Theorem eval_notl: unary_constructor_sound notl Val.notl. @@ -360,7 +398,7 @@ Theorem eval_longoffloat: exists v, eval_expr ge sp e m le (longoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold longoffloat. econstructor; split. - eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. + eapply (eval_helper_1 (BI_standard BI_i64_dtos)); eauto. DeclHelper. auto. auto. Qed. Theorem eval_longuoffloat: @@ -370,7 +408,7 @@ Theorem eval_longuoffloat: exists v, eval_expr ge sp e m le (longuoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold longuoffloat. econstructor; split. - eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. + eapply (eval_helper_1 (BI_standard BI_i64_dtou)); eauto. DeclHelper. auto. auto. Qed. Theorem eval_floatoflong: @@ -379,8 +417,9 @@ Theorem eval_floatoflong: Val.floatoflong x = Some y -> exists v, eval_expr ge sp e m le (floatoflong a) v /\ Val.lessdef y v. Proof. - intros; unfold floatoflong. econstructor; split. - eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. + intros; unfold floatoflong. exists y; split; auto. + eapply (eval_helper_1 (BI_standard BI_i64_stod)); eauto. DeclHelper. auto. + simpl. destruct x; simpl in H0; inv H0; auto. Qed. Theorem eval_floatoflongu: @@ -389,8 +428,9 @@ Theorem eval_floatoflongu: Val.floatoflongu x = Some y -> exists v, eval_expr ge sp e m le (floatoflongu a) v /\ Val.lessdef y v. Proof. - intros; unfold floatoflongu. econstructor; split. - eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. + intros; unfold floatoflongu. exists y; split; auto. + eapply (eval_helper_1 (BI_standard BI_i64_utod)); eauto. DeclHelper. auto. + simpl. destruct x; simpl in H0; inv H0; auto. Qed. Theorem eval_longofsingle: @@ -427,8 +467,9 @@ Theorem eval_singleoflong: Val.singleoflong x = Some y -> exists v, eval_expr ge sp e m le (singleoflong a) v /\ Val.lessdef y v. Proof. - intros; unfold singleoflong. econstructor; split. - eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. + intros; unfold singleoflong. exists y; split; auto. + eapply (eval_helper_1 (BI_standard BI_i64_stof)); eauto. DeclHelper. auto. + simpl. destruct x; simpl in H0; inv H0; auto. Qed. Theorem eval_singleoflongu: @@ -437,8 +478,9 @@ Theorem eval_singleoflongu: Val.singleoflongu x = Some y -> exists v, eval_expr ge sp e m le (singleoflongu a) v /\ Val.lessdef y v. Proof. - intros; unfold singleoflongu. econstructor; split. - eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto. + intros; unfold singleoflongu. exists y; split; auto. + eapply (eval_helper_1 (BI_standard BI_i64_utof)); eauto. DeclHelper. auto. + simpl. destruct x; simpl in H0; inv H0; auto. Qed. Theorem eval_andl: binary_constructor_sound andl Val.andl. @@ -565,7 +607,9 @@ Proof. simpl. erewrite <- Int64.decompose_shl_2. instantiate (1 := Int64.hiword i). rewrite Int64.ofwords_recompose. auto. auto. + (* n >= 64 *) - econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto. + econstructor; split. + eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity. + auto. Qed. Theorem eval_shll: binary_constructor_sound shll Val.shll. @@ -576,7 +620,7 @@ Proof. exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0. eapply eval_shllimm; eauto. - (* General case *) - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto. Qed. Lemma eval_shrluimm: @@ -610,7 +654,9 @@ Proof. simpl. erewrite <- Int64.decompose_shru_2. instantiate (1 := Int64.loword i). rewrite Int64.ofwords_recompose. auto. auto. + (* n >= 64 *) - econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto. + econstructor; split. + eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity. + auto. Qed. Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. @@ -621,7 +667,7 @@ Proof. exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0. eapply eval_shrluimm; eauto. - (* General case *) - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto. Qed. Lemma eval_shrlimm: @@ -659,7 +705,9 @@ Proof. erewrite <- Int64.decompose_shr_2. instantiate (1 := Int64.loword i). rewrite Int64.ofwords_recompose. auto. auto. + (* n >= 64 *) - econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto. + econstructor; split. + eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity. + auto. Qed. Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. @@ -670,7 +718,7 @@ Proof. exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0. eapply eval_shrlimm; eauto. - (* General case *) - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto. Qed. Theorem eval_addl: Archi.ptr64 = false -> binary_constructor_sound addl Val.addl. @@ -680,7 +728,7 @@ Proof. assert (DEFAULT: exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.addl x y) v). { - econstructor; split. eapply eval_builtin_2; eauto. UseHelper. auto. + econstructor; split. eapply eval_builtin_2; eauto. reflexivity. reflexivity. auto. } destruct (is_longconst a) as [p|] eqn:LC1; destruct (is_longconst b) as [q|] eqn:LC2. @@ -703,7 +751,7 @@ Proof. assert (DEFAULT: exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.subl x y) v). { - econstructor; split. eapply eval_builtin_2; eauto. UseHelper. auto. + econstructor; split. eapply eval_builtin_2; eauto. reflexivity. reflexivity. auto. } destruct (is_longconst a) as [p|] eqn:LC1; destruct (is_longconst b) as [q|] eqn:LC2. @@ -734,7 +782,7 @@ Proof. exploit eval_add. eexact E2. eexact E3. intros [v5 [E5 L5]]. exploit eval_add. eexact E5. eexact E4. intros [v6 [E6 L6]]. exists (Val.longofwords v6 (Val.loword p)); split. - EvalOp. eapply eval_builtin_2; eauto. UseHelper. + EvalOp. eapply eval_builtin_2; eauto. reflexivity. reflexivity. intros. unfold le1, p in *; subst; simpl in *. inv L3. inv L4. inv L5. simpl in L6. inv L6. simpl. f_equal. symmetry. apply Int64.decompose_mul. @@ -782,14 +830,14 @@ Theorem eval_mullhu: forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). Proof. unfold mullhu; intros; red; intros. econstructor; split; eauto. - eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper. + eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. reflexivity. reflexivity. Qed. Theorem eval_mullhs: forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). Proof. unfold mullhs; intros; red; intros. econstructor; split; eauto. - eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper. + eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. reflexivity. reflexivity. Qed. Theorem eval_shrxlimm: @@ -831,7 +879,7 @@ Theorem eval_divlu_base: exists v, eval_expr ge sp e m le (divlu_base a b) v /\ Val.lessdef z v. Proof. intros; unfold divlu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. Qed. Theorem eval_modlu_base: @@ -842,7 +890,7 @@ Theorem eval_modlu_base: exists v, eval_expr ge sp e m le (modlu_base a b) v /\ Val.lessdef z v. Proof. intros; unfold modlu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. Qed. Theorem eval_divls_base: @@ -853,7 +901,7 @@ Theorem eval_divls_base: exists v, eval_expr ge sp e m le (divls_base a b) v /\ Val.lessdef z v. Proof. intros; unfold divls_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. Qed. Theorem eval_modls_base: @@ -864,7 +912,7 @@ Theorem eval_modls_base: exists v, eval_expr ge sp e m le (modls_base a b) v /\ Val.lessdef z v. Proof. intros; unfold modls_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto. Qed. Remark decompose_cmpl_eq_zero: diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 1f80c293..8dbb67a7 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -13,7 +13,7 @@ Require Import FunInd. Require Import Coqlib Maps Integers Floats Lattice Kildall. Require Import Compopts AST Linking. -Require Import Values Memory Globalenvs Events. +Require Import Values Memory Globalenvs Builtins Events. Require Import Registers Op RTL. Require Import ValueDomain ValueAOp Liveness. @@ -78,6 +78,15 @@ Definition transfer_builtin_default let (av, am') := analyze_call am (map (abuiltin_arg ae am rm) args) in VA.State (set_builtin_res res av ae) am'. +Definition eval_static_builtin_function + (ae: aenv) (am: amem) (rm: romem) + (bf: builtin_function) (args: list (builtin_arg reg)) := + match builtin_function_sem bf + (map val_of_aval (map (abuiltin_arg ae am rm) args)) with + | Some v => aval_of_val v + | None => None + end. + Definition transfer_builtin (ae: aenv) (am: amem) (rm: romem) (ef: external_function) (args: list (builtin_arg reg)) (res: builtin_res reg) := @@ -105,6 +114,15 @@ Definition transfer_builtin | EF_annot_val _ _ _, v :: nil => let av := abuiltin_arg ae am rm v in VA.State (set_builtin_res res av ae) am + | EF_builtin name sg, _ => + match lookup_builtin_function name sg with + | Some bf => + match eval_static_builtin_function ae am rm bf args with + | Some av => VA.State (set_builtin_res res av ae) am + | None => transfer_builtin_default ae am rm args res + end + | None => transfer_builtin_default ae am rm args res + end | _, _ => transfer_builtin_default ae am rm args res end. @@ -372,6 +390,31 @@ Proof. intros. destruct res; simpl; auto. apply ematch_update; auto. Qed. +Lemma eval_static_builtin_function_sound: + forall bc ge rs sp m ae rm am (bf: builtin_function) al vl v va, + ematch bc rs ae -> + romatch bc m rm -> + mmatch bc m am -> + genv_match bc ge -> + bc sp = BCstack -> + eval_builtin_args ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl -> + eval_static_builtin_function ae am rm bf al = Some va -> + builtin_function_sem bf vl = Some v -> + vmatch bc v va. +Proof. + unfold eval_static_builtin_function; intros. + exploit abuiltin_args_sound; eauto. + set (vla := map (abuiltin_arg ae am rm) al) in *. intros VMA. + destruct (builtin_function_sem bf (map val_of_aval vla)) as [v0|] eqn:A; try discriminate. + assert (LD: Val.lessdef v0 v). + { apply val_inject_lessdef. + exploit (bs_inject _ (builtin_function_sem bf)). + apply val_inject_list_lessdef. eapply list_val_of_aval_sound; eauto. + rewrite A, H6; simpl. auto. + } + inv LD. apply aval_of_val_sound; auto. discriminate. +Qed. + (** ** Constructing block classifications *) Definition bc_nostack (bc: block_classification) : Prop := @@ -1343,6 +1386,13 @@ Proof. } unfold transfer_builtin in TR. destruct ef; auto. ++ (* builtin function *) + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK; auto. + destruct (eval_static_builtin_function ae am rm bf args) as [av|] eqn:ES; auto. + simpl in H1. red in H1. rewrite LK in H1. inv H1. + eapply sound_succ_state; eauto. simpl; auto. + apply set_builtin_res_sound; auto. + eapply eval_static_builtin_function_sound; eauto. + (* volatile load *) inv H0; auto. inv H3; auto. inv H1. exploit abuiltin_arg_sound; eauto. intros VM1. diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index f6afa836..fd3bd5ae 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -13,7 +13,7 @@ Require Import FunInd. Require Import Zwf Coqlib Maps Zbits Integers Floats Lattice. Require Import Compopts AST. -Require Import Values Memory Globalenvs Events. +Require Import Values Memory Globalenvs Builtins Events. Require Import Registers RTL. (** The abstract domains for value analysis *) @@ -3038,7 +3038,47 @@ Proof with (auto using provenance_monotone with va). - destruct (zlt n 16)... Qed. -(** Abstracting memory blocks *) +(** Analysis of known builtin functions. All we have is a dynamic semantics + as a function [list val -> option val], but we can still perform + some constant propagation. *) + +Definition val_of_aval (a: aval) : val := + match a with + | I n => Vint n + | L n => Vlong n + | F f => Vfloat f + | FS f => Vsingle f + | _ => Vundef + end. + +Definition aval_of_val (v: val) : option aval := + match v with + | Vint n => Some (I n) + | Vlong n => Some (L n) + | Vfloat f => Some (F f) + | Vsingle f => Some (FS f) + | _ => None + end. + +Lemma val_of_aval_sound: + forall v a, vmatch v a -> Val.lessdef (val_of_aval a) v. +Proof. + destruct 1; simpl; auto. +Qed. + +Corollary list_val_of_aval_sound: + forall vl al, list_forall2 vmatch vl al -> Val.lessdef_list (map val_of_aval al) vl. +Proof. + induction 1; simpl; constructor; auto using val_of_aval_sound. +Qed. + +Lemma aval_of_val_sound: + forall v a, aval_of_val v = Some a -> vmatch v a. +Proof. + intros v a E; destruct v; simpl in E; inv E; constructor. +Qed. + +(** * Abstracting memory blocks *) Inductive acontent : Type := | ACval (chunk: memory_chunk) (av: aval). diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 37527940..dbfe5e5d 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -153,14 +153,10 @@ let ais_annot_functions = true);] else [] - -let builtin_ternary suffix typ = - ("__builtin_ternary_" ^ suffix), - (typ, [TInt(IInt, []); typ; typ], false);; let builtins_generic = { - Builtins.typedefs = []; - Builtins.functions = + builtin_typedefs = []; + builtin_functions = ais_annot_functions @ [ @@ -184,15 +180,12 @@ let builtins_generic = { TPtr(TVoid [AConst], []); TInt(IULong, []); TInt(IULong, [])], - false); - (* Ternary operator *) - builtin_ternary "uint" (TInt(IUInt, [])); - builtin_ternary "ulong" (TInt(IULong, [])); - builtin_ternary "int" (TInt(IInt, [])); - builtin_ternary "long" (TInt(ILong, [])); - builtin_ternary "double" (TFloat(FDouble, [])); - builtin_ternary "float" (TFloat(FFloat, [])); - + false); + (* Selection *) + "__builtin_sel", + (TVoid [], + [TInt(C.IBool, [])], + true); (* Annotations *) "__builtin_annot", (TVoid [], @@ -336,9 +329,12 @@ let builtins_generic = { (* Add processor-dependent builtins *) -let builtins = - Builtins.({ typedefs = builtins_generic.typedefs @ CBuiltins.builtins.typedefs; - functions = builtins_generic.Builtins.functions @ CBuiltins.builtins.functions }) +let builtins = { + builtin_typedefs = + builtins_generic.builtin_typedefs @ CBuiltins.builtins.builtin_typedefs; + builtin_functions = + builtins_generic.builtin_functions @ CBuiltins.builtins.builtin_functions +} (** ** The known attributes *) @@ -632,6 +628,12 @@ and convertParams env = function | [] -> Tnil | (id, ty) :: rem -> Tcons(convertTyp env ty, convertParams env rem) +(* Convert types for the arguments to a function call. The types for + fixed arguments are taken from the function prototype. The types + for other arguments (variable-argument function or unprototyped K&R + functions) are taken from the types of the function arguments, + after default argument conversion. *) + let rec convertTypArgs env tl el = match tl, el with | _, [] -> Tnil @@ -641,6 +643,20 @@ let rec convertTypArgs env tl el = | (id, t1) :: tl, e1 :: el -> Tcons(convertTyp env t1, convertTypArgs env tl el) +(* Convert types for the arguments to inline asm statements and to + the special built-in functions __builtin_annot, __builtin_ais_annot_ + and __builtin_debug. The types are taken from the types of the + arguments, after performing the usual unary conversions. + Hence char becomes int but float remains float and is not promoted + to double. The goal is to preserve the representation of the arguments + and avoid inserting compiled code to convert the arguments. *) + +let rec convertTypAnnotArgs env = function + | [] -> Tnil + | e1 :: el -> + Tcons(convertTyp env (Cutil.unary_conversion env e1.etyp), + convertTypAnnotArgs env el) + let convertField env f = if f.fld_bitfield <> None then unsupported "bit field in struct or union (consider adding option [-fbitfields])"; @@ -881,7 +897,7 @@ let rec convertExpr env e = | {edesc = C.EVar id} :: args2 -> (id.name, args2) | _::args2 -> error "argument 2 of '__builtin_debug' must be either a string literal or a variable"; ("", args2) | [] -> assert false (* catched earlier *) in - let targs2 = convertTypArgs env [] args2 in + let targs2 = convertTypAnnotArgs env args2 in Ebuiltin( AST.EF_debug(P.of_int64 kind, intern_string text, typlist_of_typelist targs2), @@ -890,7 +906,7 @@ let rec convertExpr env e = | C.ECall({edesc = C.EVar {name = "__builtin_annot"}}, args) -> begin match args with | {edesc = C.EConst(CStr txt)} :: args1 -> - let targs1 = convertTypArgs env [] args1 in + let targs1 = convertTypAnnotArgs env args1 in Ebuiltin( AST.EF_annot(P.of_int 1,coqstring_of_camlstring txt, typlist_of_typelist targs1), targs1, convertExprList env args1, convertTyp env e.etyp) @@ -918,7 +934,7 @@ let rec convertExpr env e = let file,line = !currentLocation in let fun_name = !currentFunction in let loc_string = Printf.sprintf "# file:%s line:%d function:%s\n" file line fun_name in - let targs1 = convertTypArgs env [] args1 in + let targs1 = convertTypAnnotArgs env args1 in AisAnnot.validate_ais_annot env !currentLocation txt args1; Ebuiltin( AST.EF_annot(P.of_int 2,coqstring_of_camlstring (loc_string ^ txt), typlist_of_typelist targs1), @@ -954,6 +970,10 @@ let rec convertExpr env e = Econs(va_list_ptr dst, Econs(va_list_ptr src, Enil)), Tvoid) + | C.ECall({edesc = C.EVar {name = "__builtin_sel"}}, [arg1; arg2; arg3]) -> + ewrap (Ctyping.eselection (convertExpr env arg1) + (convertExpr env arg2) (convertExpr env arg3)) + | C.ECall({edesc = C.EVar {name = "printf"}}, args) when !Clflags.option_interp -> let targs = convertTypArgs env [] args @@ -1019,14 +1039,14 @@ let convertAsm loc env txt outputs inputs clobber = match output' with None -> TVoid [] | Some e -> e.etyp in (* Build the Ebuiltin expression *) let e = - let tinputs = convertTypArgs env [] inputs' in + let tinputs = convertTypAnnotArgs env inputs' in let toutput = convertTyp env ty_res in Ebuiltin( AST.EF_inline_asm(coqstring_of_camlstring txt', signature_of_type tinputs toutput AST.cc_default, clobber'), tinputs, convertExprList env inputs', - convertTyp env ty_res) in + toutput) in (* Add an assignment to the output, if any *) match output' with | None -> e @@ -1257,7 +1277,7 @@ let convertFundecl env (sto, id, ty, optinit) = then AST.EF_runtime(id'', sg) else if Str.string_match re_builtin id.name 0 - && List.mem_assoc id.name builtins.Builtins.functions + && List.mem_assoc id.name builtins.builtin_functions then AST.EF_builtin(id'', sg) else AST.EF_external(id'', sg) in (id', AST.Gfun(Ctypes.External(ef, args, res, cconv))) @@ -1456,7 +1476,7 @@ let convertProgram p = Hashtbl.clear decl_atom; Hashtbl.clear stringTable; Hashtbl.clear wstringTable; - let p = cleanupGlobals (Builtins.declarations() @ p) in + let p = cleanupGlobals (Env.initial_declarations() @ p) in try let env = translEnv Env.empty p in let typs = convertCompositedefs env [] p in diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 7f5fe355..e6bf2129 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -16,7 +16,7 @@ Require Import FunInd. Require Import Axioms Classical. Require Import String Coqlib Decidableplus. Require Import Errors Maps Integers Floats. -Require Import AST Values Memory Events Globalenvs Determinism. +Require Import AST Values Memory Events Globalenvs Builtins Determinism. Require Import Ctypes Cop Csyntax Csem. Require Cstrategy. @@ -501,12 +501,19 @@ Definition do_ef_debug (kind: positive) (text: ident) (targs: list typ) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := Some(w, E0, Vundef, m). +Definition do_builtin_or_external (name: string) (sg: signature) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match lookup_builtin_function name sg with + | Some bf => match builtin_function_sem bf vargs with Some v => Some(w, E0, v, m) | None => None end + | None => do_external_function name sg ge w vargs m + end. + Definition do_external (ef: external_function): world -> list val -> mem -> option (world * trace * val * mem) := match ef with | EF_external name sg => do_external_function name sg ge - | EF_builtin name sg => do_external_function name sg ge - | EF_runtime name sg => do_external_function name sg ge + | EF_builtin name sg => do_builtin_or_external name sg + | EF_runtime name sg => do_builtin_or_external name sg | EF_vload chunk => do_ef_volatile_load chunk | EF_vstore chunk => do_ef_volatile_store chunk | EF_malloc => do_ef_malloc @@ -523,17 +530,26 @@ Lemma do_ef_external_sound: do_external ef w vargs m = Some(w', t, vres, m') -> external_call ef ge vargs m t vres m' /\ possible_trace w t w'. Proof with try congruence. + intros until m'. assert (SIZE: forall v sz, do_alloc_size v = Some sz -> v = Vptrofs sz). { intros until sz; unfold Vptrofs; destruct v; simpl; destruct Archi.ptr64 eqn:SF; intros EQ; inv EQ; f_equal; symmetry; eauto with ptrofs. } - intros until m'. + assert (BF_EX: forall name sg, + do_builtin_or_external name sg w vargs m = Some (w', t, vres, m') -> + builtin_or_external_sem name sg ge vargs m t vres m' /\ possible_trace w t w'). + { unfold do_builtin_or_external, builtin_or_external_sem; intros. + destruct (lookup_builtin_function name sg ) as [bf|]. + - destruct (builtin_function_sem bf vargs) as [vres1|] eqn:BF; inv H. + split. constructor; auto. constructor. + - eapply do_external_function_sound; eauto. + } destruct ef; simpl. (* EF_external *) eapply do_external_function_sound; eauto. (* EF_builtin *) - eapply do_external_function_sound; eauto. + eapply BF_EX; eauto. (* EF_runtime *) - eapply do_external_function_sound; eauto. + eapply BF_EX; eauto. (* EF_vload *) unfold do_ef_volatile_load. destruct vargs... destruct v... destruct vargs... mydestr. destruct p as [[w'' t''] v]; mydestr. @@ -575,17 +591,26 @@ Lemma do_ef_external_complete: external_call ef ge vargs m t vres m' -> possible_trace w t w' -> do_external ef w vargs m = Some(w', t, vres, m'). Proof. + intros. assert (SIZE: forall n, do_alloc_size (Vptrofs n) = Some n). { unfold Vptrofs, do_alloc_size; intros; destruct Archi.ptr64 eqn:SF. rewrite Ptrofs.of_int64_to_int64; auto. rewrite Ptrofs.of_int_to_int; auto. } - intros. destruct ef; simpl in *. + assert (BF_EX: forall name sg, + builtin_or_external_sem name sg ge vargs m t vres m' -> + do_builtin_or_external name sg w vargs m = Some (w', t, vres, m')). + { unfold do_builtin_or_external, builtin_or_external_sem; intros. + destruct (lookup_builtin_function name sg) as [bf|]. + - inv H1. inv H0. rewrite H2. auto. + - eapply do_external_function_complete; eauto. + } + destruct ef; simpl in *. (* EF_external *) eapply do_external_function_complete; eauto. (* EF_builtin *) - eapply do_external_function_complete; eauto. + eapply BF_EX; eauto. (* EF_runtime *) - eapply do_external_function_complete; eauto. + eapply BF_EX; eauto. (* EF_vload *) inv H; unfold do_ef_volatile_load. exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto. diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index c395a2cb..782fb32a 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -1580,6 +1580,27 @@ Proof. intros. apply cast_val_casted. eapply cast_val_is_casted; eauto. Qed. +(** Moreover, casted values belong to the machine type corresponding to the + C type. *) + +Lemma val_casted_has_type: + forall v ty, val_casted v ty -> ty <> Tvoid -> Val.has_type v (typ_of_type ty). +Proof. + intros. inv H; simpl typ_of_type. +- exact I. +- exact I. +- exact I. +- exact I. +- apply Val.Vptr_has_type. +- red; unfold Tptr; rewrite H1; auto. +- red; unfold Tptr; rewrite H1; auto. +- red; unfold Tptr; rewrite H1; auto. +- red; unfold Tptr; rewrite H1; auto. +- apply Val.Vptr_has_type. +- apply Val.Vptr_has_type. +- congruence. +Qed. + (** Relation with the arithmetic conversions of ISO C99, section 6.3.1 *) Module ArithConv. diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 0c3e00de..a76a14ba 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -15,19 +15,9 @@ (** Dynamic semantics for the Compcert C language *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import AST. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. +Require Import Coqlib Errors Maps. +Require Import Integers Floats Values AST Memory Builtins Events Globalenvs. +Require Import Ctypes Cop Csyntax. Require Import Smallstep. (** * Operational semantics *) @@ -437,6 +427,59 @@ Definition not_stuck (e: expr) (m: mem) : Prop := forall k C e' , context k RV C -> e = C e' -> imm_safe k e' m. +(** ** Derived forms. *) + +(** The following are admissible reduction rules for some derived forms + of the CompCert C language. They help showing that the derived forms + make sense. *) + +Lemma red_selection: + forall v1 ty1 v2 ty2 v3 ty3 ty m b v2' v3', + ty <> Tvoid -> + bool_val v1 ty1 m = Some b -> + sem_cast v2 ty2 ty m = Some v2' -> + sem_cast v3 ty3 ty m = Some v3' -> + rred (Eselection (Eval v1 ty1) (Eval v2 ty2) (Eval v3 ty3) ty) m + E0 (Eval (if b then v2' else v3') ty) m. +Proof. + intros. unfold Eselection. + set (t := typ_of_type ty). + set (sg := mksignature (AST.Tint :: t :: t :: nil) (Some t) cc_default). + assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select t))). + { unfold sg, t; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; + simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } + set (v' := if b then v2' else v3'). + assert (C: val_casted v' ty). + { unfold v'; destruct b; eapply cast_val_is_casted; eauto. } + assert (EQ: Val.normalize v' t = v'). + { apply Val.normalize_idem. apply val_casted_has_type; auto. } + econstructor. +- constructor. rewrite cast_bool_bool_val, H0. eauto. + constructor. eauto. + constructor. eauto. + constructor. +- red. red. rewrite LK. constructor. simpl. rewrite <- EQ. + destruct b; auto. +Qed. + +Lemma ctx_selection_1: + forall k C r2 r3 ty, context k RV C -> context k RV (fun x => Eselection (C x) r2 r3 ty). +Proof. + intros. apply ctx_builtin. constructor; auto. +Qed. + +Lemma ctx_selection_2: + forall k r1 C r3 ty, context k RV C -> context k RV (fun x => Eselection r1 (C x) r3 ty). +Proof. + intros. apply ctx_builtin. constructor; constructor; auto. +Qed. + +Lemma ctx_selection_3: + forall k r1 r2 C ty, context k RV C -> context k RV (fun x => Eselection r1 r2 (C x) ty). +Proof. + intros. apply ctx_builtin. constructor; constructor; constructor; auto. +Qed. + End EXPR. (** ** Transition semantics. *) diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 00565309..c34a5e13 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -100,6 +100,18 @@ Definition Epreincr (id: incr_or_decr) (l: expr) (ty: type) := Eassignop (match id with Incr => Oadd | Decr => Osub end) l (Eval (Vint Int.one) type_int32s) (typeconv ty) ty. +(** Selection is a conditional expression that always evaluates both arms + and can be implemented by "conditional move" instructions. + It is expressed as an invocation of a builtin function. *) + +Definition Eselection (r1 r2 r3: expr) (ty: type) := + let t := typ_of_type ty in + let sg := mksignature (AST.Tint :: t :: t :: nil) (Some t) cc_default in + Ebuiltin (EF_builtin "__builtin_sel"%string sg) + (Tcons type_bool (Tcons ty (Tcons ty Tnil))) + (Econs r1 (Econs r2 (Econs r3 Enil))) + ty. + (** Extract the type part of a type-annotated expression. *) Definition typeof (a: expr) : type := diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index ba1d34fb..b92a9bac 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -18,7 +18,7 @@ Require Import String. Require Import Coqlib Maps Integers Floats Errors. Require Import AST Linking. -Require Import Values Memory Globalenvs Events. +Require Import Values Memory Globalenvs Builtins Events. Require Import Ctypes Cop Csyntax Csem. Local Open Scope error_monad_scope. @@ -392,13 +392,17 @@ Inductive wt_rvalue : expr -> Prop := classify_fun (typeof r1) = fun_case_f tyargs tyres cconv -> wt_arguments rargs tyargs -> wt_rvalue (Ecall r1 rargs tyres) - | wt_Ebuiltin: forall ef tyargs rargs, + | wt_Ebuiltin: forall ef tyargs rargs ty, wt_exprlist rargs -> wt_arguments rargs tyargs -> - (* This is specialized to builtins returning void, the only - case generated by C2C. *) - sig_res (ef_sig ef) = None -> - wt_rvalue (Ebuiltin ef tyargs rargs Tvoid) + (* This typing rule is specialized to the builtin invocations generated + by C2C, which are either __builtin_sel or builtins returning void. *) + (ty = Tvoid /\ sig_res (ef_sig ef) = None) + \/ (tyargs = Tcons type_bool (Tcons ty (Tcons ty Tnil)) + /\ let t := typ_of_type ty in + let sg := mksignature (AST.Tint :: t :: t :: nil) (Some t) cc_default in + ef = EF_builtin "__builtin_sel"%string sg) -> + wt_rvalue (Ebuiltin ef tyargs rargs ty) | wt_Eparen: forall r tycast ty, wt_rvalue r -> wt_cast (typeof r) tycast -> subtype tycast ty -> @@ -745,6 +749,12 @@ Definition ebuiltin (ef: external_function) (tyargs: typelist) (args: exprlist) then OK (Ebuiltin ef tyargs args tyres) else Error (msg "builtin: wrong type decoration"). +Definition eselection (r1 r2 r3: expr) : res expr := + do x1 <- check_rval r1; do x2 <- check_rval r2; do x3 <- check_rval r3; + do y1 <- check_bool (typeof r1); + do ty <- type_conditional (typeof r2) (typeof r3); + OK (Eselection r1 r2 r3 ty). + Definition sdo (a: expr) : res statement := do x <- check_rval a; OK (Sdo a). @@ -981,6 +991,15 @@ Proof. destruct i; auto. Qed. +Lemma wt_bool_cast: + forall ty, wt_bool ty -> wt_cast ty type_bool. +Proof. + unfold wt_bool, wt_cast; unfold classify_bool; intros. + destruct ty; simpl in *; try congruence; + try (destruct Archi.ptr64; congruence). + destruct f; congruence. +Qed. + Lemma wt_cast_int: forall i1 s1 a1 i2 s2 a2, wt_cast (Tint i1 s1 a1) (Tint i2 s2 a2). Proof. @@ -1225,6 +1244,17 @@ Proof. econstructor; eauto. eapply check_arguments_sound; eauto. Qed. +Lemma eselection_sound: + forall r1 r2 r3 a, eselection r1 r2 r3 = OK a -> + wt_expr ce e r1 -> wt_expr ce e r2 -> wt_expr ce e r3 -> wt_expr ce e a. +Proof. + intros. monadInv H. apply type_conditional_cast in EQ3. destruct EQ3. + eapply wt_Ebuiltin. + repeat (constructor; eauto with ty). + repeat (constructor; eauto with ty). apply wt_bool_cast; eauto with ty. + right; auto. +Qed. + Lemma sdo_sound: forall a s, sdo a = OK s -> wt_expr ce e a -> wt_stmt ce e rt s. Proof. @@ -1632,15 +1662,6 @@ Proof. destruct f; discriminate. Qed. -Lemma wt_bool_cast: - forall ty, wt_bool ty -> wt_cast ty type_bool. -Proof. - unfold wt_bool, wt_cast; unfold classify_bool; intros. - destruct ty; simpl in *; try congruence; - try (destruct Archi.ptr64; congruence). - destruct f; congruence. -Qed. - Lemma wt_cast_self: forall t1 t2, wt_cast t1 t2 -> wt_cast t2 t2. Proof. @@ -1725,7 +1746,27 @@ Proof. constructor; auto. - (* comma *) auto. - (* paren *) inv H3. constructor. apply H5. eapply pres_sem_cast; eauto. -- (* builtin *) subst. auto with ty. +- (* builtin *) subst. destruct H7 as [(A & B) | (A & B)]. ++ subst ty. auto with ty. ++ simpl in B. set (T := typ_of_type ty) in *. + set (sg := mksignature (AST.Tint :: T :: T :: nil) (Some T) cc_default) in *. + assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select T))). + { unfold sg, T; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ]; + simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. } + subst ef. red in H0. red in H0. rewrite LK in H0. inv H0. + inv H. inv H8. inv H9. inv H10. simpl in H1. + assert (A: val_casted v1 type_bool) by (eapply cast_val_is_casted; eauto). + inv A. + set (v' := if Int.eq n Int.zero then v4 else v2) in *. + constructor. + destruct (type_eq ty Tvoid). + subst. constructor. + inv H1. + assert (C: val_casted v' ty). + { unfold v'; destruct (Int.eq n Int.zero); eapply cast_val_is_casted; eauto. } + assert (EQ: Val.normalize v' T = v'). + { apply Val.normalize_idem. apply val_casted_has_type; auto. } + rewrite EQ. apply wt_val_casted; auto. Qed. Lemma wt_lred: @@ -1767,8 +1808,8 @@ with wt_subexprlist: wt_exprlist cenv tenv (C a) -> wt_expr_kind cenv tenv from a. Proof. - destruct 1; intros WT; auto; inv WT; eauto. - destruct 1; intros WT; inv WT; eauto. +- destruct 1; intros WT; auto; inv WT; eauto. +- destruct 1; intros WT; inv WT; eauto. Qed. Lemma typeof_context: diff --git a/common/Builtins.v b/common/Builtins.v new file mode 100644 index 00000000..c9097e86 --- /dev/null +++ b/common/Builtins.v @@ -0,0 +1,58 @@ +(* *********************************************************************) +(* *) +(* 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 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. *) +(* *) +(* *********************************************************************) + +(** Known built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Export Builtins0 Builtins1. + +Inductive builtin_function : Type := + | BI_standard (b: standard_builtin) + | BI_platform (b: platform_builtin). + +Definition builtin_function_sig (b: builtin_function) : signature := + match b with + | BI_standard b => standard_builtin_sig b + | BI_platform b => platform_builtin_sig b + end. + +Definition builtin_function_sem (b: builtin_function) : builtin_sem (proj_sig_res (builtin_function_sig b)) := + match b with + | BI_standard b => standard_builtin_sem b + | BI_platform b => platform_builtin_sem b + end. + +Definition lookup_builtin_function (name: string) (sg: signature) : option builtin_function := + match lookup_builtin standard_builtin_sig name sg standard_builtin_table with + | Some b => Some (BI_standard b) + | None => + match lookup_builtin platform_builtin_sig name sg platform_builtin_table with + | Some b => Some (BI_platform b) + | None => None + end end. + +Lemma lookup_builtin_function_sig: + forall name sg b, lookup_builtin_function name sg = Some b -> builtin_function_sig b = sg. +Proof. + unfold lookup_builtin_function; intros. + destruct (lookup_builtin standard_builtin_sig name sg standard_builtin_table) as [bs|] eqn:E. + inv H. simpl. eapply lookup_builtin_sig; eauto. + destruct (lookup_builtin platform_builtin_sig name sg platform_builtin_table) as [bp|] eqn:E'. + inv H. simpl. eapply lookup_builtin_sig; eauto. + discriminate. +Qed. + + diff --git a/common/Builtins0.v b/common/Builtins0.v new file mode 100644 index 00000000..c6a299d9 --- /dev/null +++ b/common/Builtins0.v @@ -0,0 +1,509 @@ +(* *********************************************************************) +(* *) +(* 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 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. *) +(* *) +(* *********************************************************************) + +(** Associating semantics to built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. + +(** This module provides definitions and mechanisms to associate semantics + with names of built-in functions. + + This module is independent of the target architecture. Each target + provides a [Builtins1] module that lists the built-ins semantics + appropriate for the target. +*) + +Definition val_opt_has_type (ov: option val) (t: typ) : Prop := + match ov with Some v => Val.has_type v t | None => True end. + +Definition val_opt_inject (j: meminj) (ov ov': option val) : Prop := + match ov, ov' with + | None, _ => True + | Some v, Some v' => Val.inject j v v' + | _, None => False + end. + +(** The semantics of a built-in function is a partial function + from list of values to values. + It must agree with the return type stated in the signature, + and be compatible with value injections. +*) + +Record builtin_sem (tret: typ) : Type := mkbuiltin { + bs_sem :> list val -> option val; + bs_well_typed: forall vl, + val_opt_has_type (bs_sem vl) tret; + bs_inject: forall j vl vl', + Val.inject_list j vl vl' -> val_opt_inject j (bs_sem vl) (bs_sem vl') +}. + +(** Builtin functions can be created from functions over values, such as those + from the [Values.Val] module. Proofs of well-typedness and compatibility with + injections must be provided. The constructor functions have names +- [mkbuiltin_vNt] for a [t]otal function of [N] arguments that are [v]alues, or +- [mkbuiltin_vNp] for a [p]artial function of [N] arguments that are [v]alues. +*) + +Local Unset Program Cases. + +Program Definition mkbuiltin_v1t + (tret: typ) (f: val -> val) + (WT: forall v1, Val.has_type (f v1) tret) + (INJ: forall j v1 v1', Val.inject j v1 v1' -> Val.inject j (f v1) (f v1')) := + mkbuiltin tret (fun vl => match vl with v1 :: nil => Some (f v1) | _ => None end) _ _. +Next Obligation. + red; destruct vl; auto. destruct vl; auto. +Qed. +Next Obligation. + red; inv H; auto. inv H1; auto. +Qed. + +Program Definition mkbuiltin_v2t + (tret: typ) (f: val -> val -> val) + (WT: forall v1 v2, Val.has_type (f v1 v2) tret) + (INJ: forall j v1 v1' v2 v2', + Val.inject j v1 v1' -> Val.inject j v2 v2' -> + Val.inject j (f v1 v2) (f v1' v2')) := + mkbuiltin tret (fun vl => match vl with v1 :: v2 :: nil => Some (f v1 v2) | _ => None end) _ _. +Next Obligation. + red; destruct vl; auto. destruct vl; auto. destruct vl; auto. +Qed. +Next Obligation. + red; inv H; auto. inv H1; auto. inv H2; auto. +Qed. + +Program Definition mkbuiltin_v3t + (tret: typ) (f: val -> val -> val -> val) + (WT: forall v1 v2 v3, Val.has_type (f v1 v2 v3) tret) + (INJ: forall j v1 v1' v2 v2' v3 v3', + Val.inject j v1 v1' -> Val.inject j v2 v2' -> Val.inject j v3 v3' -> + Val.inject j (f v1 v2 v3) (f v1' v2' v3')) := + mkbuiltin tret (fun vl => match vl with v1 :: v2 :: v3 :: nil => Some (f v1 v2 v3) | _ => None end) _ _. +Next Obligation. + red; destruct vl; auto. destruct vl; auto. destruct vl; auto. destruct vl; auto. +Qed. +Next Obligation. + red; inv H; auto. inv H1; auto. inv H2; auto. inv H3; auto. +Qed. + +Program Definition mkbuiltin_v1p + (tret: typ) (f: val -> option val) + (WT: forall v1, val_opt_has_type (f v1) tret) + (INJ: forall j v1 v1', + Val.inject j v1 v1' -> val_opt_inject j (f v1) (f v1')) := + mkbuiltin tret (fun vl => match vl with v1 :: nil => f v1 | _ => None end) _ _. +Next Obligation. + red; destruct vl; auto. destruct vl; auto. apply WT. +Qed. +Next Obligation. + red; inv H; auto. inv H1; auto. apply INJ; auto. +Qed. + +Program Definition mkbuiltin_v2p + (tret: typ) (f: val -> val -> option val) + (WT: forall v1 v2, val_opt_has_type (f v1 v2) tret) + (INJ: forall j v1 v1' v2 v2', + Val.inject j v1 v1' -> Val.inject j v2 v2' -> + val_opt_inject j (f v1 v2) (f v1' v2')) := + mkbuiltin tret (fun vl => match vl with v1 :: v2 :: nil => f v1 v2 | _ => None end) _ _. +Next Obligation. + red; destruct vl; auto. destruct vl; auto. destruct vl; auto. apply WT. +Qed. +Next Obligation. + red; inv H; auto. inv H1; auto. inv H2; auto. apply INJ; auto. +Qed. + +(** For numerical functions, involving only integers and floating-point numbers + but no pointer values, we can automate the proofs of well-typedness and + of compatibility with injections. *) + +(** First we define a mapping from syntactic Cminor types ([Tint], [Tfloat], etc) to semantic Coq types. *) + +Definition valty (t: typ) : Type := + match t with + | Tint => int + | Tlong => int64 + | Tfloat => float + | Tsingle => float32 + | Tany32 | Tany64 => Empty_set (**r no clear semantic meaning *) + end. + +(** We can inject and project between the numerical type [valty t] and the type [val]. *) + +Definition inj_num (t: typ) : valty t -> val := + match t with + | Tint => Vint + | Tlong => Vlong + | Tfloat => Vfloat + | Tsingle => Vsingle + | Tany32 | Tany64 => fun _ => Vundef + end. + +Definition proj_num {A: Type} (t: typ) (k0: A) (v: val): (valty t -> A) -> A := + match t with + | Tint => fun k1 => match v with Vint n => k1 n | _ => k0 end + | Tlong => fun k1 => match v with Vlong n => k1 n | _ => k0 end + | Tfloat => fun k1 => match v with Vfloat n => k1 n | _ => k0 end + | Tsingle => fun k1 => match v with Vsingle n => k1 n | _ => k0 end + | Tany32 | Tany64 => fun k1 => k0 + end. + +Lemma inj_num_wt: forall t x, Val.has_type (inj_num t x) t. +Proof. + destruct t; intros; exact I. +Qed. + +Lemma inj_num_inject: forall j t x, Val.inject j (inj_num t x) (inj_num t x). +Proof. + destruct t; intros; constructor. +Qed. + +Lemma inj_num_opt_wt: forall t x, val_opt_has_type (option_map (inj_num t) x) t. +Proof. + intros. destruct x; simpl. apply inj_num_wt. auto. +Qed. + +Lemma inj_num_opt_inject: forall j t x, + val_opt_inject j (option_map (inj_num t) x) (option_map (inj_num t) x). +Proof. + destruct x; simpl. apply inj_num_inject. auto. +Qed. + +Lemma proj_num_wt: + forall tres t k1 v, + (forall x, Val.has_type (k1 x) tres) -> + Val.has_type (proj_num t Vundef v k1) tres. +Proof. + intros. destruct t; simpl; destruct v; auto; exact I. +Qed. + +Lemma proj_num_inject: + forall j t k1 v k1' v', + (forall x, Val.inject j (k1 x) (k1' x)) -> + Val.inject j v v' -> + Val.inject j (proj_num t Vundef v k1) (proj_num t Vundef v' k1'). +Proof. + intros. destruct t; simpl; inv H0; auto. +Qed. + +Lemma proj_num_opt_wt: + forall tres t k0 k1 v, + k0 = None \/ k0 = Some Vundef -> + (forall x, val_opt_has_type (k1 x) tres) -> + val_opt_has_type (proj_num t k0 v k1) tres. +Proof. + intros. + assert (val_opt_has_type k0 tres). { destruct H; subst k0; exact I. } + destruct t; simpl; destruct v; auto. +Qed. + +Lemma proj_num_opt_inject: + forall j k0 t k1 v k1' v', + (forall ov, val_opt_inject j k0 ov) -> + (forall x, val_opt_inject j (k1 x) (k1' x)) -> + Val.inject j v v' -> + val_opt_inject j (proj_num t k0 v k1) (proj_num t k0 v' k1'). +Proof. + intros. destruct t; simpl; inv H1; auto. +Qed. + +(** Wrapping numerical functions as built-ins. The constructor functions + have names +- [mkbuiltin_nNt] for a [t]otal function of [N] numbers, or +- [mkbuiltin_vNp] for a [p]artial function of [N] numbers. + *) + +Program Definition mkbuiltin_n1t + (targ1: typ) (tres: typ) + (f: valty targ1 -> valty tres) := + mkbuiltin_v1t tres + (fun v1 => proj_num targ1 Vundef v1 (fun x => inj_num tres (f x))) + _ _. +Next Obligation. + auto using proj_num_wt, inj_num_wt. +Qed. +Next Obligation. + auto using proj_num_inject, inj_num_inject. +Qed. + +Program Definition mkbuiltin_n2t + (targ1 targ2: typ) (tres: typ) + (f: valty targ1 -> valty targ2 -> valty tres) := + mkbuiltin_v2t tres + (fun v1 v2 => + proj_num targ1 Vundef v1 (fun x1 => + proj_num targ2 Vundef v2 (fun x2 => inj_num tres (f x1 x2)))) + _ _. +Next Obligation. + auto using proj_num_wt, inj_num_wt. +Qed. +Next Obligation. + auto using proj_num_inject, inj_num_inject. +Qed. + +Program Definition mkbuiltin_n3t + (targ1 targ2 targ3: typ) (tres: typ) + (f: valty targ1 -> valty targ2 -> valty targ3 -> valty tres) := + mkbuiltin_v3t tres + (fun v1 v2 v3 => + proj_num targ1 Vundef v1 (fun x1 => + proj_num targ2 Vundef v2 (fun x2 => + proj_num targ3 Vundef v3 (fun x3 => inj_num tres (f x1 x2 x3))))) + _ _. +Next Obligation. + auto using proj_num_wt, inj_num_wt. +Qed. +Next Obligation. + auto using proj_num_inject, inj_num_inject. +Qed. + +Program Definition mkbuiltin_n1p + (targ1: typ) (tres: typ) + (f: valty targ1 -> option (valty tres)) := + mkbuiltin_v1p tres + (fun v1 => proj_num targ1 None v1 (fun x => option_map (inj_num tres) (f x))) + _ _. +Next Obligation. + auto using proj_num_opt_wt, inj_num_opt_wt. +Qed. +Next Obligation. + apply proj_num_opt_inject; auto. intros; red; auto. intros; apply inj_num_opt_inject. +Qed. + +Program Definition mkbuiltin_n2p + (targ1 targ2: typ) (tres: typ) + (f: valty targ1 -> valty targ2 -> option (valty tres)) := + mkbuiltin_v2p tres + (fun v1 v2 => + proj_num targ1 None v1 (fun x1 => + proj_num targ2 None v2 (fun x2 => option_map (inj_num tres) (f x1 x2)))) + _ _. +Next Obligation. + auto using proj_num_opt_wt, inj_num_opt_wt. +Qed. +Next Obligation. + apply proj_num_opt_inject; auto. intros; red; auto. intros. + apply proj_num_opt_inject; auto. intros; red; auto. intros. + apply inj_num_opt_inject. +Qed. + +(** Looking up builtins by name and signature *) + +Section LOOKUP. + +Context {A: Type} (sig_of: A -> signature). + +Fixpoint lookup_builtin (name: string) (sg: signature) (l: list (string * A)) : option A := + match l with + | nil => None + | (n, b) :: l => + if string_dec name n && signature_eq sg (sig_of b) + then Some b + else lookup_builtin name sg l + end. + +Lemma lookup_builtin_sig: forall name sg b l, + lookup_builtin name sg l = Some b -> sig_of b = sg. +Proof. + induction l as [ | [n b'] l ]; simpl; intros. +- discriminate. +- destruct (string_dec name n && signature_eq sg (sig_of b')) eqn:E. ++ InvBooleans. congruence. ++ auto. +Qed. + +End LOOKUP. + +(** The standard, platform-independent built-ins *) + +Inductive standard_builtin : Type := + | BI_select (t: typ) + | BI_fabs + | BI_fsqrt + | BI_negl + | BI_addl + | BI_subl + | BI_mull + | BI_i64_umulh + | BI_i64_smulh + | BI_i64_sdiv + | BI_i64_udiv + | BI_i64_smod + | BI_i64_umod + | BI_i64_shl + | BI_i64_shr + | BI_i64_sar + | BI_i64_dtos + | BI_i64_dtou + | BI_i64_stod + | BI_i64_utod + | BI_i64_stof + | BI_i64_utof. + +Local Open Scope string_scope. + +Definition standard_builtin_table : list (string * standard_builtin) := + ("__builtin_sel", BI_select Tint) + :: ("__builtin_sel", BI_select Tlong) + :: ("__builtin_sel", BI_select Tfloat) + :: ("__builtin_sel", BI_select Tsingle) + :: ("__builtin_fabs", BI_fabs) + :: ("__builtin_fsqrt", BI_fsqrt) + :: ("__builtin_negl", BI_negl) + :: ("__builtin_addl", BI_addl) + :: ("__builtin_subl", BI_subl) + :: ("__builtin_mull", BI_mull) + :: ("__compcert_i64_umulh", BI_i64_umulh) + :: ("__compcert_i64_smulh", BI_i64_smulh) + :: ("__compcert_i64_sdiv", BI_i64_sdiv) + :: ("__compcert_i64_udiv", BI_i64_udiv) + :: ("__compcert_i64_smod", BI_i64_smod) + :: ("__compcert_i64_umod", BI_i64_umod) + :: ("__compcert_i64_shl", BI_i64_shl) + :: ("__compcert_i64_shr", BI_i64_shr) + :: ("__compcert_i64_sar", BI_i64_sar) + :: ("__compcert_i64_dtos", BI_i64_dtos) + :: ("__compcert_i64_dtou", BI_i64_dtou) + :: ("__compcert_i64_stod", BI_i64_stod) + :: ("__compcert_i64_utod", BI_i64_utod) + :: ("__compcert_i64_stof", BI_i64_stof) + :: ("__compcert_i64_utof", BI_i64_utof) + :: nil. + +Definition standard_builtin_sig (b: standard_builtin) : signature := + match b with + | BI_select t => + mksignature (Tint :: t :: t :: nil) (Some t) cc_default + | BI_fabs | BI_fsqrt => + mksignature (Tfloat :: nil) (Some Tfloat) cc_default + | BI_negl => + mksignature (Tlong :: nil) (Some Tlong) cc_default + | BI_addl | BI_subl | BI_i64_umulh| BI_i64_smulh + | BI_i64_sdiv | BI_i64_udiv | BI_i64_smod | BI_i64_umod => + mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default + | BI_mull => + mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default + | BI_i64_shl | BI_i64_shr | BI_i64_sar => + mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default + | BI_i64_dtos | BI_i64_dtou => + mksignature (Tfloat :: nil) (Some Tlong) cc_default + | BI_i64_stod | BI_i64_utod => + mksignature (Tlong :: nil) (Some Tfloat) cc_default + | BI_i64_stof | BI_i64_utof => + mksignature (Tlong :: nil) (Some Tsingle) cc_default + end. + +Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (proj_sig_res (standard_builtin_sig b)) := + match b with + | BI_select t => + mkbuiltin t + (fun vargs => match vargs with + | Vint n :: v1 :: v2 :: nil => Some (Val.normalize (if Int.eq n Int.zero then v2 else v1) t) + | _ => None + end) _ _ + | BI_fabs => mkbuiltin_n1t Tfloat Tfloat Float.abs + | BI_fsqrt => mkbuiltin_n1t Tfloat Tfloat Float.sqrt + | BI_negl => mkbuiltin_n1t Tlong Tlong Int64.neg + | BI_addl => mkbuiltin_v2t Tlong Val.addl _ _ + | BI_subl => mkbuiltin_v2t Tlong Val.subl _ _ + | BI_mull => mkbuiltin_v2t Tlong Val.mull' _ _ + | BI_i64_umulh => mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhu + | BI_i64_smulh => mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhs + | BI_i64_sdiv => mkbuiltin_v2p Tlong Val.divls _ _ + | BI_i64_udiv => mkbuiltin_v2p Tlong Val.divlu _ _ + | BI_i64_smod => mkbuiltin_v2p Tlong Val.modls _ _ + | BI_i64_umod => mkbuiltin_v2p Tlong Val.modlu _ _ + | BI_i64_shl => mkbuiltin_v2t Tlong Val.shll _ _ + | BI_i64_shr => mkbuiltin_v2t Tlong Val.shrlu _ _ + | BI_i64_sar => mkbuiltin_v2t Tlong Val.shrl _ _ + | BI_i64_dtos => mkbuiltin_n1p Tfloat Tlong Float.to_long + | BI_i64_dtou => mkbuiltin_n1p Tfloat Tlong Float.to_longu + | BI_i64_stod => mkbuiltin_n1t Tlong Tfloat Float.of_long + | BI_i64_utod => mkbuiltin_n1t Tlong Tfloat Float.of_longu + | BI_i64_stof => mkbuiltin_n1t Tlong Tsingle Float32.of_long + | BI_i64_utof => mkbuiltin_n1t Tlong Tsingle Float32.of_longu + end. +Next Obligation. + red. destruct vl; auto. destruct v; auto. + destruct vl; auto. destruct vl; auto. destruct vl; auto. + apply Val.normalize_type. +Qed. +Next Obligation. + red. inv H; auto. inv H0; auto. inv H1; auto. inv H0; auto. inv H2; auto. + apply Val.normalize_inject. destruct (Int.eq i Int.zero); auto. +Qed. +Next Obligation. + unfold Val.addl, Val.has_type; destruct v1; auto; destruct v2; auto; destruct Archi.ptr64; auto. +Qed. +Next Obligation. + apply Val.addl_inject; auto. +Qed. +Next Obligation. + unfold Val.subl, Val.has_type, negb; destruct v1; auto; destruct v2; auto; + destruct Archi.ptr64; auto; destruct (eq_block b0 b1); auto. +Qed. +Next Obligation. + apply Val.subl_inject; auto. +Qed. +Next Obligation. + unfold Val.mull', Val.has_type; destruct v1; simpl; auto; destruct v2; auto. +Qed. +Next Obligation. + inv H; simpl; auto. inv H0; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct orb; exact I. +Qed. +Next Obligation. + red. inv H; simpl; auto. inv H0; auto. destruct orb; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct Int64.eq; exact I. +Qed. +Next Obligation. + red. inv H; simpl; auto. inv H0; auto. destruct Int64.eq; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct orb; exact I. +Qed. +Next Obligation. + red. inv H; simpl; auto. inv H0; auto. destruct orb; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct Int64.eq; exact I. +Qed. +Next Obligation. + red. inv H; simpl; auto. inv H0; auto. destruct Int64.eq; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct Int.ltu; auto. +Qed. +Next Obligation. + inv H; simpl; auto. inv H0; auto. destruct Int.ltu; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct Int.ltu; auto. +Qed. +Next Obligation. + inv H; simpl; auto. inv H0; auto. destruct Int.ltu; auto. +Qed. +Next Obligation. + red. destruct v1; simpl; auto. destruct v2; auto. destruct Int.ltu; auto. +Qed. +Next Obligation. + inv H; simpl; auto. inv H0; auto. destruct Int.ltu; auto. +Qed. + diff --git a/common/Events.v b/common/Events.v index 26dd505f..3fb84f49 100644 --- a/common/Events.v +++ b/common/Events.v @@ -24,6 +24,7 @@ Require Import Floats. Require Import Values. Require Import Memory. Require Import Globalenvs. +Require Import Builtins. (** * Events and traces *) @@ -1377,12 +1378,67 @@ Proof. split. constructor. auto. Qed. +(** ** Semantics of known built-in functions. *) + +(** Some built-in functions and runtime support functions have known semantics + as defined in the [Builtin] modules. + These built-in functions have no observable effects and do not access memory. *) + +Inductive known_builtin_sem (bf: builtin_function) (ge: Senv.t): + list val -> mem -> trace -> val -> mem -> Prop := + | known_builtin_sem_intro: forall vargs vres m, + builtin_function_sem bf vargs = Some vres -> + known_builtin_sem bf ge vargs m E0 vres m. + +Lemma known_builtin_ok: forall bf, + extcall_properties (known_builtin_sem bf) (builtin_function_sig bf). +Proof. + intros. set (bsem := builtin_function_sem bf). constructor; intros. +(* well typed *) +- inv H. + specialize (bs_well_typed _ bsem vargs). unfold val_opt_has_type, bsem; rewrite H0. + auto. +(* symbols *) +- inv H0. econstructor; eauto. +(* valid blocks *) +- inv H; auto. +(* perms *) +- inv H; auto. +(* readonly *) +- inv H. apply Mem.unchanged_on_refl. +(* mem extends *) +- inv H. fold bsem in H2. apply val_inject_list_lessdef in H1. + specialize (bs_inject _ bsem _ _ _ H1). + unfold val_opt_inject; rewrite H2; intros. + destruct (bsem vargs') as [vres'|] eqn:?; try contradiction. + exists vres', m1'; intuition auto using Mem.extends_refl, Mem.unchanged_on_refl. + constructor; auto. + apply val_inject_lessdef; auto. +(* mem injects *) +- inv H0. fold bsem in H3. + specialize (bs_inject _ bsem _ _ _ H2). + unfold val_opt_inject; rewrite H3; intros. + destruct (bsem vargs') as [vres'|] eqn:?; try contradiction. + exists f, vres', m1'; intuition auto using Mem.extends_refl, Mem.unchanged_on_refl. + constructor; auto. + red; intros; congruence. +(* trace length *) +- inv H; simpl; omega. +(* receptive *) +- inv H; inv H0. exists vres1, m1; constructor; auto. +(* determ *) +- inv H; inv H0. + split. constructor. intuition congruence. +Qed. + (** ** Semantics of external functions. *) -(** For functions defined outside the program ([EF_external], - [EF_builtin] and [EF_runtime]), we do not define their - semantics, but only assume that it satisfies - [extcall_properties]. *) +(** For functions defined outside the program ([EF_external]), + we do not define their semantics, but only assume that it satisfies + [extcall_properties]. + We do the same for built-in functions and runtime support functions that + are not described in [Builtins]. +*) Parameter external_functions_sem: String.string -> signature -> extcall_sem. @@ -1398,6 +1454,22 @@ Axiom inline_assembly_properties: (** ** Combined semantics of external calls *) +Definition builtin_or_external_sem name sg := + match lookup_builtin_function name sg with + | Some bf => known_builtin_sem bf + | None => external_functions_sem name sg + end. + +Lemma builtin_or_external_sem_ok: forall name sg, + extcall_properties (builtin_or_external_sem name sg) sg. +Proof. + unfold builtin_or_external_sem; intros. + destruct (lookup_builtin_function name sg) as [bf|] eqn:L. +- exploit lookup_builtin_function_sig; eauto. intros EQ; subst sg. + apply known_builtin_ok. +- apply external_functions_properties. +Qed. + (** Combining the semantics given above for the various kinds of external calls, we define the predicate [external_call] that relates: - the external function being invoked @@ -1412,8 +1484,8 @@ This predicate is used in the semantics of all CompCert languages. *) Definition external_call (ef: external_function): extcall_sem := match ef with | EF_external name sg => external_functions_sem name sg - | EF_builtin name sg => external_functions_sem name sg - | EF_runtime name sg => external_functions_sem name sg + | EF_builtin name sg => builtin_or_external_sem name sg + | EF_runtime name sg => builtin_or_external_sem name sg | EF_vload chunk => volatile_load_sem chunk | EF_vstore chunk => volatile_store_sem chunk | EF_malloc => extcall_malloc_sem @@ -1431,8 +1503,8 @@ Theorem external_call_spec: Proof. intros. unfold external_call, ef_sig; destruct ef. apply external_functions_properties. - apply external_functions_properties. - apply external_functions_properties. + apply builtin_or_external_sem_ok. + apply builtin_or_external_sem_ok. apply volatile_load_ok. apply volatile_store_ok. apply extcall_malloc_ok. @@ -591,29 +591,23 @@ else ocaml_opt_comp=false fi -MENHIR_REQUIRED=20161201 -MENHIR_NEW_API=20180530 -MENHIR_MAX=20181113 -menhir_flags='' +MENHIR_REQUIRED=20190626 echo "Testing Menhir... " | tr -d '\n' menhir_ver=`menhir --version 2>/dev/null | sed -n -e 's/^.*version \([0-9]*\).*$/\1/p'` case "$menhir_ver" in 20[0-9][0-9][0-9][0-9][0-9][0-9]) - if test "$menhir_ver" -ge $MENHIR_REQUIRED -a "$menhir_ver" -le $MENHIR_MAX; then + if test "$menhir_ver" -ge $MENHIR_REQUIRED; then echo "version $menhir_ver -- good!" - menhir_include_dir=`menhir --suggest-menhirLib` + menhir_include_dir=$(menhir --suggest-menhirLib | tr -d '\r' | tr '\\' '/') if test -z "$menhir_include_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." missingtools=true fi - if test "$menhir_ver" -ge $MENHIR_NEW_API; then - menhir_flags="--coq-lib-path compcert.cparser.MenhirLib" - fi else echo "version $menhir_ver -- UNSUPPORTED" - echo "Error: CompCert requires a version of Menhir between $MENHIR_REQUIRED and $MENHIR_MAX, included." + echo "Error: CompCert requires a version greater or equal to $MENHIR_REQUIRED." missingtools=true fi;; *) @@ -677,7 +671,8 @@ echo "-R lib compcert.lib \ -R driver compcert.driver \ -R flocq compcert.flocq \ -R exportclight compcert.exportclight \ --R cparser compcert.cparser" > _CoqProject +-R cparser compcert.cparser \ +-R MenhirLib compcert.MenhirLib" > _CoqProject case $arch in x86) echo "-R x86_${bitsize} compcert.x86_${bitsize}" >> _CoqProject @@ -699,7 +694,6 @@ SHAREDIR=$sharedir COQDEVDIR=$coqdevdir OCAML_OPT_COMP=$ocaml_opt_comp MENHIR_INCLUDES=-I "$menhir_include_dir" -MENHIR_FLAGS=$menhir_flags COMPFLAGS=-bin-annot EOF diff --git a/cparser/Builtins.ml b/cparser/Builtins.ml deleted file mode 100644 index 8eb1abfd..00000000 --- a/cparser/Builtins.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the 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. *) -(* *) -(* *********************************************************************) - -(* Compiler built-ins *) - -open C -open Cutil - -let env = ref Env.empty -let idents = ref [] -let decls = ref [] - -let environment () = !env -let identifiers () = !idents -let declarations () = List.rev !decls - -let add_typedef (s, ty) = - let (id, env') = Env.enter_typedef !env s ty in - env := env'; - idents := id :: !idents; - decls := {gdesc = Gtypedef(id, ty); gloc = no_loc} :: !decls - -let add_function (s, (res, args, va)) = - let ty = - TFun(res, - Some (List.map (fun ty -> (Env.fresh_ident "", ty)) args), - va, []) in - let (id, env') = Env.enter_ident !env s Storage_extern ty in - env := env'; - idents := id :: !idents; - decls := {gdesc = Gdecl(Storage_extern, id, ty, None); gloc = no_loc} :: !decls - -type t = { - typedefs: (string * C.typ) list; - functions: (string * (C.typ * C.typ list * bool)) list -} - -let set blt = - env := Env.empty; - idents := []; - List.iter add_typedef blt.typedefs; - List.iter add_function blt.functions diff --git a/cparser/C.mli b/cparser/C.mli index cc8d4065..15717565 100644 --- a/cparser/C.mli +++ b/cparser/C.mli @@ -264,3 +264,10 @@ and globdecl_desc = | Gpragma of string (* #pragma directive *) type program = globdecl list + +(** Builtin types and functions *) + +type builtins = { + builtin_typedefs: (string * typ) list; + builtin_functions: (string * (typ * typ list * bool)) list +} diff --git a/cparser/Cabs.v b/cparser/Cabs.v index 5865ab69..5f12e8a1 100644 --- a/cparser/Cabs.v +++ b/cparser/Cabs.v @@ -20,7 +20,7 @@ Parameter string : Type. (* OCaml's int64 type, used to represent individual characters in literals. *) Parameter char_code : Type. (* Context information. *) -Parameter cabsloc : Type. +Parameter loc : Type. Record floatInfo := { isHex_FI:bool; @@ -51,7 +51,7 @@ Inductive typeSpecifier := (* Merge all specifiers into one type *) * They also have a list of __attribute__s that appeared between the * keyword and the type name (definitions only) *) | Tstruct_union : structOrUnion -> option string -> option (list field_group) -> list attribute -> typeSpecifier - | Tenum : option string -> option (list (string * option expression * cabsloc)) -> list attribute -> typeSpecifier + | Tenum : option string -> option (list (string * option expression * loc)) -> list attribute -> typeSpecifier with storage := AUTO | STATIC | EXTERN | REGISTER | TYPEDEF @@ -87,18 +87,18 @@ with decl_type := | PROTO_OLD : decl_type -> list string -> decl_type with parameter := - | PARAM : list spec_elem -> option string -> decl_type -> list attribute -> cabsloc -> parameter + | PARAM : list spec_elem -> option string -> decl_type -> list attribute -> loc -> parameter (* The optional expression is the bitfield *) with field_group := - | Field_group : list spec_elem -> list (option name * option expression) -> cabsloc -> field_group + | Field_group : list spec_elem -> list (option name * option expression) -> 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. *) (* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *) (* the string, and decl_type will be PTR([], JUSTBASE) *) with name := - | Name : string -> decl_type -> list attribute -> cabsloc -> name + | Name : string -> decl_type -> list attribute -> loc -> name (* A variable declarator ("name") with an initializer *) with init_name := @@ -161,9 +161,9 @@ with initwhat := | ATINDEX_INIT : expression -> initwhat with attribute := - | GCC_ATTR : list gcc_attribute -> cabsloc -> attribute - | PACKED_ATTR : list expression -> cabsloc -> attribute - | ALIGNAS_ATTR : list expression -> cabsloc -> attribute + | GCC_ATTR : list gcc_attribute -> loc -> attribute + | PACKED_ATTR : list expression -> loc -> attribute + | ALIGNAS_ATTR : list expression -> loc -> attribute with gcc_attribute := | GCC_ATTR_EMPTY @@ -194,31 +194,31 @@ Definition asm_flag := (bool * list char_code)%type. ** Declaration definition (at toplevel) *) Inductive definition := - | FUNDEF : list spec_elem -> name -> list definition -> statement -> cabsloc -> definition - | DECDEF : init_name_group -> cabsloc -> definition (* global variable(s), or function prototype *) - | PRAGMA : string -> cabsloc -> 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 (* ** statements *) with statement := - | NOP : cabsloc -> statement - | COMPUTATION : expression -> cabsloc -> statement - | BLOCK : list statement -> cabsloc -> statement - | If : expression -> statement -> option statement -> cabsloc -> statement - | WHILE : expression -> statement -> cabsloc -> statement - | DOWHILE : expression -> statement -> cabsloc -> statement - | FOR : option for_clause -> option expression -> option expression -> statement -> cabsloc -> statement - | BREAK : cabsloc -> statement - | CONTINUE : cabsloc -> statement - | RETURN : option expression -> cabsloc -> statement - | SWITCH : expression -> statement -> cabsloc -> statement - | CASE : expression -> statement -> cabsloc -> statement - | DEFAULT : statement -> cabsloc -> statement - | LABEL : string -> statement -> cabsloc -> statement - | GOTO : string -> cabsloc -> statement - | ASM : list cvspec -> bool -> list char_code -> list asm_operand -> list asm_operand -> list asm_flag -> cabsloc -> statement + | NOP : loc -> statement + | COMPUTATION : expression -> loc -> statement + | BLOCK : list statement -> loc -> statement + | If : expression -> statement -> option statement -> loc -> statement + | WHILE : expression -> statement -> loc -> statement + | DOWHILE : expression -> statement -> loc -> statement + | FOR : option for_clause -> option expression -> option expression -> statement -> loc -> statement + | BREAK : loc -> statement + | CONTINUE : loc -> statement + | RETURN : option expression -> loc -> statement + | SWITCH : expression -> statement -> loc -> statement + | CASE : expression -> statement -> loc -> statement + | DEFAULT : statement -> loc -> statement + | LABEL : string -> statement -> loc -> statement + | GOTO : string -> loc -> statement + | ASM : list cvspec -> bool -> list char_code -> list asm_operand -> list asm_operand -> list asm_flag -> loc -> statement | DEFINITION : definition -> statement (*definition or declaration of a variable or type*) with for_clause := diff --git a/cparser/Cabshelper.ml b/cparser/Cabshelper.ml index 958f242c..22f3b3c7 100644 --- a/cparser/Cabshelper.ml +++ b/cparser/Cabshelper.ml @@ -16,11 +16,6 @@ open Cabs -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10; - ident = 0} - (*********** HELPER FUNCTIONS **********) let rec isStatic = function @@ -44,13 +39,13 @@ let rec isTypedef = function | _ :: rest -> isTypedef rest -let get_definitionloc (d : definition) : cabsloc = +let get_definitionloc (d : definition) : loc = match d with | FUNDEF(_, _, _, _, l) -> l | DECDEF(_, l) -> l | PRAGMA(_, l) -> l -let get_statementloc (s : statement) : cabsloc = +let get_statementloc (s : statement) : loc = begin match s with | NOP(loc) -> loc @@ -72,8 +67,8 @@ begin | ASM(_,_,_,_,_,_,loc) -> loc end -let string_of_cabsloc l = +let string_of_loc l = Printf.sprintf "%s:%d" l.filename l.lineno -let format_cabsloc pp l = +let format_loc pp l = Format.fprintf pp "%s:%d" l.filename l.lineno diff --git a/cparser/Checks.ml b/cparser/Checks.ml index a30cde7d..17caf19a 100644 --- a/cparser/Checks.ml +++ b/cparser/Checks.ml @@ -18,44 +18,68 @@ open Diagnostics open Cutil open Env -let unknown_attrs loc attrs = - let unknown attr = - let attr_class = class_of_attribute attr in - if attr_class = Attr_unknown then - warning loc Unknown_attribute - "unknown attribute '%s' ignored" (name_of_attribute attr) in - List.iter unknown attrs +(* AST traversal functions *) -let unknown_attrs_typ env loc ty = - let attr = attributes_of_type env ty in - unknown_attrs loc attr +let fold_over_stmt_loc ~(expr: 'a -> location -> exp -> 'a) + ~(decl: 'a -> location -> decl -> 'a) + (a: 'a) (s: stmt) : 'a = + let rec fold a s = + match s.sdesc with + | Sskip -> a + | Sbreak -> a + | Scontinue -> a + | Slabeled(_, s1) -> fold a s1 + | Sgoto _ -> a + | Sreturn None -> a + | Sreturn (Some e) -> expr a s.sloc e + | Sasm(_, _, outs, ins, _) -> asm_operands (asm_operands a s.sloc outs) s.sloc ins + | Sdo e -> expr a s.sloc e + | Sif (e, s1, s2) -> fold (fold (expr a s.sloc e) s1) s2 + | Sseq (s1, s2) -> fold (fold a s1) s2 + | Sfor (s1, e, s2, s3) -> fold (fold (expr (fold a s1) s.sloc e) s2) s3 + | Swhile(e, s1) -> fold (expr a s.sloc e) s1 + | Sdowhile (s1, e) -> expr (fold a s1) s.sloc e + | Sswitch (e, s1) -> fold (expr a s.sloc e) s1 + | Sblock sl -> List.fold_left fold a sl + | Sdecl d -> decl a s.sloc d + and asm_operands a loc l = + List.fold_left (fun a (_, _, e) -> expr a loc e) a l + in fold a s -let unknown_attrs_decl env loc (sto, id, ty, init) = - unknown_attrs_typ env loc ty +let iter_over_stmt_loc + ?(expr = fun loc e -> ()) + ?(decl = fun loc decl -> ()) + (s: stmt) : unit = + fold_over_stmt_loc ~expr: (fun () loc e -> expr loc e) + ~decl: (fun () loc d -> decl loc d) + () s + +let fold_over_stmt ~(expr: 'a -> exp -> 'a) + ~(decl: 'a -> location -> decl -> 'a) + (a: 'a) (s: stmt) : 'a = + fold_over_stmt_loc ~expr:(fun a _ e -> expr a e) ~decl:decl a s + +let iter_over_stmt ?(expr = fun e -> ()) + ?(decl = fun loc decl -> ()) + (s:stmt) : unit = + fold_over_stmt_loc ~expr:(fun () _ e -> expr e) + ~decl:(fun () loc d -> decl loc d) () s + +let fold_over_init ~(expr: 'a -> exp -> 'a) (a: 'a) (i: init) : 'a = + let rec fold a = function + | Init_single e -> expr a e + | Init_array il -> List.fold_left fold a il + | Init_struct (_, sl) -> List.fold_left (fun a (_,i) -> fold a i) a sl + | Init_union (_, _, ui) -> fold a ui + in fold a i -let rec unknown_attrs_stmt env s = - match s.sdesc with - | Sskip - | Sbreak - | Scontinue - | Slabeled _ - | Sgoto _ - | Sreturn _ - | Sasm _ - | Sdo _ -> () - | Sif (_,s1,s2) - | Sseq (s1,s2) -> - unknown_attrs_stmt env s1; - unknown_attrs_stmt env s2 - | Sfor (s1,e,s2,s3) -> - unknown_attrs_stmt env s1; - unknown_attrs_stmt env s2; - unknown_attrs_stmt env s3 - | Swhile(_,s) - | Sdowhile (s,_) - | Sswitch (_,s) -> unknown_attrs_stmt env s - | Sblock sl -> List.iter (unknown_attrs_stmt env) sl - | Sdecl d -> unknown_attrs_decl env s.sloc d +let iter_over_init ~(expr: exp -> unit) (i:init) : unit = + fold_over_init ~expr:(fun () e -> expr e) () i + +let fold_over_decl ~(expr: 'a -> exp -> 'a) (a: 'a) loc (sto, id, ty, init) : 'a= + match init with + | Some i -> fold_over_init ~expr a i + | None -> a let traverse_program ?(decl = fun env loc d -> ()) @@ -93,7 +117,27 @@ let traverse_program pragma env g.gloc s; env in traverse env gl in - traverse (Builtins.environment ()) p + traverse (Env.initial ()) p + +(* Unknown attributes warning *) + +let unknown_attrs loc attrs = + let unknown attr = + let attr_class = class_of_attribute attr in + if attr_class = Attr_unknown then + warning loc Unknown_attribute + "unknown attribute '%s' ignored" (name_of_attribute attr) in + List.iter unknown attrs + +let unknown_attrs_typ env loc ty = + let attr = attributes_of_type env ty in + unknown_attrs loc attr + +let unknown_attrs_decl env loc (sto, id, ty, init) = + unknown_attrs_typ env loc ty + +let unknown_attrs_stmt env s = + iter_over_stmt ~decl:(unknown_attrs_decl env) s let unknown_attrs_program p = let decl env loc d = @@ -122,6 +166,7 @@ let unknown_attrs_program p = ~enum:enum p +(* Unused variables and parameters warning *) let rec vars_used_expr env e = match e.edesc with @@ -143,83 +188,21 @@ let rec vars_used_expr env e = let env = vars_used_expr env e in List.fold_left vars_used_expr env p -and vars_used_init env = function - | Init_single e -> vars_used_expr env e - | Init_array al -> List.fold_left vars_used_init env al - | Init_struct (_,sl) -> List.fold_left (fun env (_,i) -> vars_used_init env i) env sl - | Init_union (_,_,ui) -> vars_used_init env ui - -let rec vars_used_stmt env s = - match s.sdesc with - | Sbreak - | Scontinue - | Sgoto _ - | Sreturn None - | Sskip -> env - | Sreturn (Some e) - | Sdo e -> (vars_used_expr env e) - | Sseq (s1,s2) -> - let env = vars_used_stmt env s1 in - vars_used_stmt env s2 - | Sif (e,s1,s2) -> - let env = vars_used_expr env e in - let env = vars_used_stmt env s1 in - vars_used_stmt env s2 - | Sfor (s1,e,s2,s3) -> - let env = vars_used_expr env e in - let env = vars_used_stmt env s1 in - let env = vars_used_stmt env s2 in - vars_used_stmt env s3 - | Sswitch (e,s) - | Swhile (e,s) - | Sdowhile (s,e) -> - let env = vars_used_expr env e in - vars_used_stmt env s - | Sblock sl -> List.fold_left vars_used_stmt env sl - | Sdecl (sto,id,ty,init) -> - let env = match init with - | Some init ->vars_used_init env init - | None -> env in - env - | Slabeled (lbl,s) -> vars_used_stmt env s - | Sasm (attr,str,op,op2,constr) -> - let vars_asm_op env (_,_,e) = - vars_used_expr env e in - let env = List.fold_left vars_asm_op env op in - let env = List.fold_left vars_asm_op env op2 in - env - -let unused_variable env used loc (id,ty) = +and vars_used_init env init = + fold_over_init ~expr:vars_used_expr env init + +let vars_used_stmt env s = + fold_over_stmt ~expr: vars_used_expr + ~decl: (fold_over_decl ~expr: vars_used_expr) env s + +let unused_variable env used loc (id, ty) = let attr = attributes_of_type env ty in let unused_attr = find_custom_attributes ["unused";"__unused__"] attr <> [] in if not ((IdentSet.mem id used) || unused_attr) then warning loc Unused_variable "unused variable '%s'" id.name -let rec unused_variables_stmt env used s = - match s.sdesc with - | Sbreak - | Scontinue - | Sgoto _ - | Sreturn _ - | Sskip - | Sasm _ - | Sdo _ -> () - | Sseq (s1,s2) - | Sif (_,s1,s2) -> - unused_variables_stmt env used s1; - unused_variables_stmt env used s2 - | Sfor (s1,e,s2,s3) -> - unused_variables_stmt env used s1; - unused_variables_stmt env used s2; - unused_variables_stmt env used s3 - | Slabeled (_,s) - | Sswitch (_,s) - | Swhile (_,s) - | Sdowhile (s,_) -> - unused_variables_stmt env used s - | Sblock sl -> List.iter (unused_variables_stmt env used) sl - | Sdecl (sto,id,ty,init) -> - unused_variable env used s.sloc (id,ty) +let unused_variables_stmt env used s = + iter_over_stmt ~decl:(fun loc (sto, id, ty, init) -> unused_variable env used loc (id,ty)) s let unused_variables p = let fundef env loc fd = @@ -229,3 +212,166 @@ let unused_variables p = traverse_program ~fundef:fundef p + +(* Warning for conditionals that cannot be transformed into linear code *) + +(* Compute the set of local variables that do not have their address taken *) + +let rec non_stack_locals_expr vars e = + match e.edesc with + | ECast (_,e) -> non_stack_locals_expr vars e + | EUnop (Oaddrof,e) -> + begin match e.edesc with + | EVar id -> + IdentSet.remove id vars + | _ -> vars + end + | EUnop (Oderef, e) -> + (* Special optimization *(& ...) is removed in SimplExpr *) + begin match e.edesc with + | EUnop (Oaddrof,e) -> non_stack_locals_expr vars e + | _ -> non_stack_locals_expr vars e + end + | EUnop (_, e) -> + non_stack_locals_expr vars e + | EBinop (_,e1,e2,_) -> + let vars = non_stack_locals_expr vars e1 in + non_stack_locals_expr vars e2 + | EConditional (e1,e2,e3) -> + let vars = non_stack_locals_expr vars e1 in + let vars = non_stack_locals_expr vars e2 in + non_stack_locals_expr vars e3 + | ECompound (_,init) -> non_stack_locals_init vars init + | ECall (e,p) -> + let vars = non_stack_locals_expr vars e in + List.fold_left non_stack_locals_expr vars p + | _ -> vars + +and non_stack_locals_init vars init = + fold_over_init ~expr:non_stack_locals_expr vars init + +let add_vars env vars (id,ty) = + let volatile = List.mem AVolatile (attributes_of_type env ty) in + if not volatile then + IdentSet.add id vars + else + vars + +let non_stack_locals_stmt env vars s = + let decl vars loc (sto, id, ty, init) = + let vars = match init with + | Some init -> non_stack_locals_init vars init + | None -> vars in + add_vars env vars (id,ty) in + fold_over_stmt ~expr:non_stack_locals_expr ~decl:decl + vars s + +(* Check whether an expression is safe and can be always evaluated *) + +let safe_cast env tfrom tto = + match unroll env tfrom, unroll env tto with + | (TInt _ | TPtr _ | TArray _ | TFun _ | TEnum _), + (TInt _ | TPtr _ | TEnum _) -> true + | TFloat _, TFloat _ -> true + | _, _ -> equal_types env tfrom tto + +let safe_expr vars env e = + let rec expr e = + match e.edesc with + | EConst _ | ESizeof _ | EAlignof _ | ECompound _ -> true + | EVar id -> (IdentSet.mem id vars) || not (is_scalar_type env e.etyp) + | ECast (ty, e) -> + safe_cast env e.etyp ty && expr e + | EUnop (op, e) -> + unop op e + | EBinop (op, e1, e2, ty) -> + binop op e1 e2 + | EConditional _ -> false + | ECall _ -> false + and binop op e1 e2 = + let is_long_long_type ty = + match unroll env ty with + | TInt (ILongLong, _) + | TInt (IULongLong, _) -> true + | _ -> false in + match op with + | Oadd | Osub | Omul | Oand | Oor | Oxor | Oshl | Oshr -> + expr e1 && expr e2 + | Oeq | One | Olt | Ogt | Ole | Oge -> + let not_long_long = not (is_long_long_type e1.etyp) && not (is_long_long_type e2.etyp) in + not_long_long && expr e1 && expr e2 + | _ -> false + (* x.f if f has array or struct or union type *) + and unop op e = + match op with + | Ominus | Onot | Olognot | Oplus -> expr e + | Oaddrof -> + begin match e.edesc with + (* skip &*e *) + | EUnop (Oderef, e) -> expr e + (* skip &(e.f) *) + | EUnop (Odot f, e) -> expr e + | _ -> expr e + end + (* skip *&e *) + | Oderef -> + begin match e.edesc with + | EUnop (Oaddrof,e) -> expr e + | _ -> false + end + (* e.f is okay if f has array or composite type *) + | Odot m -> + let fld = field_of_dot_access env e.etyp m in + (is_array_type env fld.fld_typ || is_composite_type env fld.fld_typ) && expr e + | _ -> false in + expr e + +(* Check expressions if they contain conditionals that cannot be transformed in + linear code. The inner_cond parameter is used to mimic the translation of short + circuit logical or and logical and as well as conditional to if statements in + SimplExpr. *) + +let rec non_linear_cond_expr inner_cond vars env loc e = + match e.edesc with + | EConst _ | ESizeof _ | EAlignof _ | EVar _ -> () + | ECast (_ , e) | EUnop (_, e)-> non_linear_cond_expr false vars env loc e + | EBinop (op, e1, e2, ty) -> + let inner_cond = match op with + | Ocomma -> inner_cond + | Ologand | Ologor -> true + | _ -> false + in + non_linear_cond_expr false vars env loc e1; + non_linear_cond_expr inner_cond vars env loc e2 + | EConditional (c, e1, e2) -> + let can_cast = safe_cast env e1.etyp e.etyp && safe_cast env e2.etyp e.etyp in + if not can_cast || inner_cond || not (safe_expr vars env e1) || not (safe_expr vars env e2) then + warning loc Non_linear_cond_expr "conditional expression may not be linearized"; + non_linear_cond_expr true vars env loc e1; + non_linear_cond_expr true vars env loc e2; + | ECompound (ty, init) -> non_linear_cond_init vars env loc init + | ECall (e, params) -> + non_linear_cond_expr false vars env loc e; + List.iter (non_linear_cond_expr false vars env loc) params + +and non_linear_cond_init vars env loc init = + iter_over_init ~expr:(non_linear_cond_expr false vars env loc) init + +let non_linear_cond_stmt vars env s = + let decl loc (sto, id, ty, init) = + match init with + | None -> () + | Some init -> non_linear_cond_init vars env loc init in + iter_over_stmt_loc ~expr:(non_linear_cond_expr false vars env) ~decl:decl s + +let non_linear_conditional p = + if active_warning Non_linear_cond_expr && !Clflags.option_Obranchless then begin + let fundef env loc fd = + let vars = List.fold_left (add_vars env) IdentSet.empty fd.fd_params in + let vars = non_stack_locals_stmt env vars fd.fd_body in + non_linear_cond_stmt vars env fd.fd_body; + in + traverse_program + ~fundef:fundef + p + end diff --git a/cparser/Checks.mli b/cparser/Checks.mli index 4d61a5b8..cfd7b04d 100644 --- a/cparser/Checks.mli +++ b/cparser/Checks.mli @@ -16,3 +16,5 @@ val unknown_attrs_program: C.program -> unit val unused_variables: C.program -> unit + +val non_linear_conditional : C.program -> unit diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 7329767a..7a2f4828 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -29,7 +29,7 @@ let no_loc = ("", -1) module Ident = struct type t = ident - let compare id1 id2 = Pervasives.compare id1.stamp id2.stamp + let compare id1 id2 = compare id1.stamp id2.stamp end module IdentSet = Set.Make(Ident) @@ -821,6 +821,11 @@ let is_composite_type env t = | TStruct _ | TUnion _ -> true | _ -> false +let is_array_type env t = + match unroll env t with + | TArray _ -> true + | _ -> false + let is_function_type env t = match unroll env t with | TFun _ -> true diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index 5a1e9af3..f6c4627d 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -166,6 +166,8 @@ val is_scalar_type : Env.t -> typ -> bool (* Is type integer, float or pointer? *) val is_composite_type : Env.t -> typ -> bool (* Is type a struct or union? *) +val is_array_type : Env.t -> typ -> bool + (* Is type an array type? *) val is_function_type : Env.t -> typ -> bool (* Is type a function type? (not pointer to function) *) val is_function_pointer_type : Env.t -> typ -> bool diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml index 51dcab47..012e4b66 100644 --- a/cparser/Diagnostics.ml +++ b/cparser/Diagnostics.ml @@ -102,6 +102,7 @@ type warning_type = | Flexible_array_extensions | Tentative_incomplete_static | Reduced_alignment + | Non_linear_cond_expr (* List of active warnings *) let active_warnings: warning_type list ref = ref [ @@ -163,6 +164,7 @@ let string_of_warning = function | Flexible_array_extensions -> "flexible-array-extensions" | Tentative_incomplete_static -> "tentative-incomplete-static" | Reduced_alignment -> "reduced-alignment" + | Non_linear_cond_expr -> "non-linear-cond-expr" (* Activate the given warning *) let activate_warning w () = @@ -216,6 +218,7 @@ let wall () = Flexible_array_extensions; Tentative_incomplete_static; Reduced_alignment; + Non_linear_cond_expr; ] let wnothing () = @@ -253,6 +256,7 @@ let werror () = Flexible_array_extensions; Tentative_incomplete_static; Reduced_alignment; + Non_linear_cond_expr; ] (* Generate the warning key for the message *) @@ -437,6 +441,7 @@ let warning_options = error_option Flexible_array_extensions @ error_option Tentative_incomplete_static @ error_option Reduced_alignment @ + error_option Non_linear_cond_expr @ [Exact ("-Wfatal-errors"), Set error_fatal; Exact ("-fdiagnostics-color"), Ignore; (* Either output supports it or no color *) Exact ("-fno-diagnostics-color"), Unset color_diagnostics; @@ -492,3 +497,6 @@ let crash exn = let no_loc = ("", -1) let file_loc file = (file,-10) + +let active_warning ty = + fst (classify_warning ty) <> SuppressedMsg diff --git a/cparser/Diagnostics.mli b/cparser/Diagnostics.mli index 6a3c11c8..0f0a0ea5 100644 --- a/cparser/Diagnostics.mli +++ b/cparser/Diagnostics.mli @@ -55,6 +55,7 @@ type warning_type = | Flexible_array_extensions (** usange of structs with flexible arrays in structs and arrays *) | Tentative_incomplete_static (** static tentative definition with incomplete type *) | Reduced_alignment (** alignment reduction *) + | Non_linear_cond_expr (** condition that cannot be linearized *) val warning : (string * int) -> warning_type -> ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a (** [warning (f,c) w fmt arg1 ... argN] formats the arguments [arg1] to [argN] as warining according to @@ -95,3 +96,6 @@ val file_loc : string -> string * int val error_summary : unit -> unit (** Print a summary containing the numbers of errors encountered *) + +val active_warning : warning_type -> bool +(** Test whether a warning is active to avoid costly checks *) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 10380152..3797164d 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -258,7 +258,7 @@ let enter_or_refine_function loc env id sto ty = (* Forward declarations *) -let elab_expr_f : (cabsloc -> Env.t -> Cabs.expression -> C.exp * Env.t) ref +let elab_expr_f : (Cabs.loc -> Env.t -> Cabs.expression -> C.exp * Env.t) ref = ref (fun _ _ _ -> assert false) let elab_funbody_f : (C.typ -> bool -> bool -> Env.t -> statement -> C.stmt) ref @@ -1802,6 +1802,42 @@ 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_sel" as a0), al) -> + begin match al with + | [a1; a2; a3] -> + let b0,env = elab env a0 in + let b1,env = elab env a1 in + let b2,env = elab env a2 in + let b3,env = elab env a3 in + if not (is_scalar_type env b1.etyp) then + error "first argument of '__builtin_sel' is not a scalar type (invalid %a)" + (print_typ env) b1.etyp; + let tyres = + match pointer_decay env b2.etyp, pointer_decay env b3.etyp with + | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> + binary_conversion env b2.etyp b3.etyp + | (TPtr(ty1, a1) as pty1), (TPtr(ty2, a2) as pty2) -> + if is_void_type env ty1 || is_void_type env ty2 then + TPtr(TVoid (add_attributes a1 a2), []) + else begin + match combine_types AttrIgnoreAll env pty1 pty2 with + | None -> + warning Pointer_type_mismatch "the second and third arguments of '__builtin_sel' have incompatible pointer types (%a and %a)" + (print_typ env) pty1 (print_typ env) pty2; + (* tolerance *) + TPtr(TVoid (add_attributes a1 a2), []) + | Some ty -> ty + end + | _, _ -> + fatal_error "wrong types (%a and %a) for the second and third arguments of '__builtin_sel'" + (print_typ env) b2.etyp (print_typ env) b3.etyp + + in + { edesc = ECall(b0, [b1; b2; b3]); etyp = tyres }, env + | _ -> + fatal_error "'__builtin_sel' expect 3 arguments" + end + | CALL(a1, al) -> let b1,env = (* Catch the old-style usage of calling a function without @@ -2708,7 +2744,7 @@ let elab_fundef genv spec name defs body loc = (* Definitions *) let elab_decdef (for_loop: bool) (local: bool) (nonstatic_inline: bool) (env: Env.t) ((spec, namelist): Cabs.init_name_group) - (loc: Cabs.cabsloc) : decl list * Env.t = + (loc: Cabs.loc) : decl list * Env.t = let (sto, inl, noret, tydef, bty, env') = elab_specifier ~only:(namelist=[]) loc env spec in (* Sanity checks on storage class *) @@ -3089,10 +3125,11 @@ let _ = elab_funbody_f := elab_funbody let elab_file prog = reset(); - let env = Builtins.environment () in + let env = Env.initial () in let elab_def env d = snd (elab_definition false false false env d) in ignore (List.fold_left elab_def env prog); let p = elaborated_program () in Checks.unused_variables p; Checks.unknown_attrs_program p; + Checks.non_linear_conditional p; p diff --git a/cparser/Elab.mli b/cparser/Elab.mli index f701e8c5..59c5efc1 100644 --- a/cparser/Elab.mli +++ b/cparser/Elab.mli @@ -18,8 +18,8 @@ val elab_file : Cabs.definition list -> C.program definitions as produced by the parser into a program in C abstract syntax. *) -val elab_int_constant : Cabs.cabsloc -> string -> int64 * C.ikind +val elab_int_constant : Cabs.loc -> string -> int64 * C.ikind val elab_float_constant : Cabs.floatInfo -> C.float_cst * C.fkind -val elab_char_constant : Cabs.cabsloc -> bool -> int64 list -> int64 +val elab_char_constant : Cabs.loc -> bool -> int64 list -> int64 (* These auxiliary functions are exported so that they can be reused in other projects that deal with C-style source languages. *) diff --git a/cparser/Env.ml b/cparser/Env.ml index 5fa4571a..4723a725 100644 --- a/cparser/Env.ml +++ b/cparser/Env.ml @@ -276,6 +276,46 @@ let add_enum env id info = let add_types env_old env_new = { env_new with env_ident = env_old.env_ident;env_scope = env_old.env_scope;} +(* Initial environment describing the built-in types and functions *) + +module Init = struct + +let env = ref empty +let idents = ref [] +let decls = ref [] + +let no_loc = ("", -1) + +let add_typedef (s, ty) = + let (id, env') = enter_typedef !env s ty in + env := env'; + idents := id :: !idents; + decls := {gdesc = Gtypedef(id, ty); gloc = no_loc} :: !decls + +let add_function (s, (res, args, va)) = + let ty = + TFun(res, + Some (List.map (fun ty -> (fresh_ident "", ty)) args), + va, []) in + let (id, env') = enter_ident !env s Storage_extern ty in + env := env'; + idents := id :: !idents; + decls := + {gdesc = Gdecl(Storage_extern, id, ty, None); gloc = no_loc} :: !decls + +end + +let initial () = !Init.env +let initial_identifiers () = !Init.idents +let initial_declarations () = List.rev !Init.decls + +let set_builtins blt = + Init.env := empty; + Init.idents := []; + Init.decls := []; + List.iter Init.add_typedef blt.builtin_typedefs; + List.iter Init.add_function blt.builtin_functions + (* Error reporting *) open Printf diff --git a/cparser/Env.mli b/cparser/Env.mli index 7ea2c514..1baab68f 100644 --- a/cparser/Env.mli +++ b/cparser/Env.mli @@ -77,3 +77,10 @@ val add_typedef : t -> C.ident -> typedef_info -> t val add_enum : t -> C.ident -> enum_info -> t val add_types : t -> t -> t + +(* Initial environment describing the builtin types and functions *) + +val initial: unit -> t +val initial_identifiers: unit -> C.ident list +val initial_declarations: unit -> C.globdecl list +val set_builtins: C.builtins -> unit diff --git a/cparser/GCC.ml b/cparser/GCC.ml index 010d12f3..458e51d3 100644 --- a/cparser/GCC.ml +++ b/cparser/GCC.ml @@ -38,10 +38,10 @@ let intPtrType = TPtr(TInt(IInt, []), []) let sizeType() = TInt(size_t_ikind(), []) let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", voidPtrType ]; - Builtins.functions = [ + builtin_functions = [ "__builtin___fprintf_chk", (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *); "__builtin___memcpy_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType(); sizeType() ], false); "__builtin___memmove_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType(); sizeType() ], false); diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index 7cf22eef..346477b5 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -20,7 +20,7 @@ open Pre_parser_aux module SSet = Set.Make(String) -let lexicon : (string, Cabs.cabsloc -> token) Hashtbl.t = Hashtbl.create 17 +let lexicon : (string, Cabs.loc -> token) Hashtbl.t = Hashtbl.create 17 let ignored_keywords : SSet.t ref = ref SSet.empty let reserved_keyword loc id = @@ -434,10 +434,7 @@ and singleline_comment = parse | _ { singleline_comment lexbuf } { - open Streams - open Specif - open Parser - open !Aut.GramDefs + open Parser.MenhirLibParser.Inter (* This is the main entry point to the lexer. *) @@ -463,8 +460,8 @@ and singleline_comment = parse curr_id := None; let loc = currentLoc lexbuf in let token = - if SSet.mem id !types_context then TYPEDEF_NAME (id, ref TypedefId, loc) - else VAR_NAME (id, ref VarId, loc) + if SSet.mem id !types_context then Pre_parser.TYPEDEF_NAME (id, ref TypedefId, loc) + else Pre_parser.VAR_NAME (id, ref VarId, loc) in Queue.push token tokens; token @@ -497,133 +494,129 @@ and singleline_comment = parse (* [tokens_stream filename text] runs the pre_parser and produces a stream of (appropriately classified) tokens. *) - let tokens_stream filename text : token coq_Stream = + let tokens_stream filename text : buffer = let tokens = Queue.create () in let buffer = ref ErrorReports.Zero in invoke_pre_parser filename text (lexer tokens buffer) buffer; - let rec compute_token_stream () = - let loop t v = - Cons (Coq_existT (t, Obj.magic v), Lazy.from_fun compute_token_stream) - in + let rec compute_buffer () = + let loop t = Buf_cons (t, Lazy.from_fun compute_buffer) in match Queue.pop tokens with - | ADD_ASSIGN loc -> loop ADD_ASSIGN't loc - | AND loc -> loop AND't loc - | ANDAND loc -> loop ANDAND't loc - | AND_ASSIGN loc -> loop AND_ASSIGN't loc - | AUTO loc -> loop AUTO't loc - | BANG loc -> loop BANG't loc - | BAR loc -> loop BAR't loc - | BARBAR loc -> loop BARBAR't loc - | UNDERSCORE_BOOL loc -> loop UNDERSCORE_BOOL't loc - | BREAK loc -> loop BREAK't loc - | BUILTIN_VA_ARG loc -> loop BUILTIN_VA_ARG't loc - | BUILTIN_OFFSETOF loc -> loop BUILTIN_OFFSETOF't loc - | CASE loc -> loop CASE't loc - | CHAR loc -> loop CHAR't loc - | COLON loc -> loop COLON't loc - | COMMA loc -> loop COMMA't loc - | CONST loc -> loop CONST't loc - | CONSTANT (cst, loc) -> loop CONSTANT't (cst, loc) - | CONTINUE loc -> loop CONTINUE't loc - | DEC loc -> loop DEC't loc - | DEFAULT loc -> loop DEFAULT't loc - | DIV_ASSIGN loc -> loop DIV_ASSIGN't loc - | DO loc -> loop DO't loc - | DOT loc -> loop DOT't loc - | DOUBLE loc -> loop DOUBLE't loc - | ELLIPSIS loc -> loop ELLIPSIS't loc - | ELSE loc -> loop ELSE't loc - | ENUM loc -> loop ENUM't loc - | EOF -> loop EOF't () - | EQ loc -> loop EQ't loc - | EQEQ loc -> loop EQEQ't loc - | EXTERN loc -> loop EXTERN't loc - | FLOAT loc -> loop FLOAT't loc - | FOR loc -> loop FOR't loc - | GEQ loc -> loop GEQ't loc - | GOTO loc -> loop GOTO't loc - | GT loc -> loop GT't loc - | HAT loc -> loop HAT't loc - | IF loc -> loop IF't loc - | INC loc -> loop INC't loc - | INLINE loc -> loop INLINE't loc - | INT loc -> loop INT't loc - | LBRACE loc -> loop LBRACE't loc - | LBRACK loc -> loop LBRACK't loc - | LEFT loc -> loop LEFT't loc - | LEFT_ASSIGN loc -> loop LEFT_ASSIGN't loc - | LEQ loc -> loop LEQ't loc - | LONG loc -> loop LONG't loc - | LPAREN loc -> loop LPAREN't loc - | LT loc -> loop LT't loc - | MINUS loc -> loop MINUS't loc - | MOD_ASSIGN loc -> loop MOD_ASSIGN't loc - | MUL_ASSIGN loc -> loop MUL_ASSIGN't loc - | NEQ loc -> loop NEQ't loc - | NORETURN loc -> loop NORETURN't loc - | OR_ASSIGN loc -> loop OR_ASSIGN't loc - | PACKED loc -> loop PACKED't loc - | PERCENT loc -> loop PERCENT't loc - | PLUS loc -> loop PLUS't loc - | PTR loc -> loop PTR't loc - | QUESTION loc -> loop QUESTION't loc - | RBRACE loc -> loop RBRACE't loc - | RBRACK loc -> loop RBRACK't loc - | REGISTER loc -> loop REGISTER't loc - | RESTRICT loc -> loop RESTRICT't loc - | RETURN loc -> loop RETURN't loc - | RIGHT loc -> loop RIGHT't loc - | RIGHT_ASSIGN loc -> loop RIGHT_ASSIGN't loc - | RPAREN loc -> loop RPAREN't loc - | SEMICOLON loc -> loop SEMICOLON't loc - | SHORT loc -> loop SHORT't loc - | SIGNED loc -> loop SIGNED't loc - | SIZEOF loc -> loop SIZEOF't loc - | SLASH loc -> loop SLASH't loc - | STAR loc -> loop STAR't loc - | STATIC loc -> loop STATIC't loc - | STRING_LITERAL (wide, str, loc) -> + | Pre_parser.ADD_ASSIGN loc -> loop (Parser.ADD_ASSIGN loc) + | Pre_parser.AND loc -> loop (Parser.AND loc) + | Pre_parser.ANDAND loc -> loop (Parser.ANDAND loc) + | Pre_parser.AND_ASSIGN loc -> loop (Parser.AND_ASSIGN loc) + | Pre_parser.AUTO loc -> loop (Parser.AUTO loc) + | Pre_parser.BANG loc -> loop (Parser.BANG loc) + | Pre_parser.BAR loc -> loop (Parser.BAR loc) + | Pre_parser.BARBAR loc -> loop (Parser.BARBAR loc) + | Pre_parser.UNDERSCORE_BOOL loc -> loop (Parser.UNDERSCORE_BOOL loc) + | Pre_parser.BREAK loc -> loop (Parser.BREAK loc) + | Pre_parser.BUILTIN_VA_ARG loc -> loop (Parser.BUILTIN_VA_ARG loc) + | Pre_parser.BUILTIN_OFFSETOF loc -> loop (Parser.BUILTIN_OFFSETOF loc) + | Pre_parser.CASE loc -> loop (Parser.CASE loc) + | Pre_parser.CHAR loc -> loop (Parser.CHAR loc) + | Pre_parser.COLON loc -> loop (Parser.COLON loc) + | Pre_parser.COMMA loc -> loop (Parser.COMMA loc) + | Pre_parser.CONST loc -> loop (Parser.CONST loc) + | Pre_parser.CONSTANT (cst, loc) -> loop (Parser.CONSTANT (cst, loc)) + | Pre_parser.CONTINUE loc -> loop (Parser.CONTINUE loc) + | Pre_parser.DEC loc -> loop (Parser.DEC loc) + | Pre_parser.DEFAULT loc -> loop (Parser.DEFAULT loc) + | Pre_parser.DIV_ASSIGN loc -> loop (Parser.DIV_ASSIGN loc) + | Pre_parser.DO loc -> loop (Parser.DO loc) + | Pre_parser.DOT loc -> loop (Parser.DOT loc) + | Pre_parser.DOUBLE loc -> loop (Parser.DOUBLE loc) + | Pre_parser.ELLIPSIS loc -> loop (Parser.ELLIPSIS loc) + | Pre_parser.ELSE loc -> loop (Parser.ELSE loc) + | Pre_parser.ENUM loc -> loop (Parser.ENUM loc) + | Pre_parser.EOF -> loop (Parser.EOF ()) + | Pre_parser.EQ loc -> loop (Parser.EQ loc) + | Pre_parser.EQEQ loc -> loop (Parser.EQEQ loc) + | Pre_parser.EXTERN loc -> loop (Parser.EXTERN loc) + | Pre_parser.FLOAT loc -> loop (Parser.FLOAT loc) + | Pre_parser.FOR loc -> loop (Parser.FOR loc) + | Pre_parser.GEQ loc -> loop (Parser.GEQ loc) + | Pre_parser.GOTO loc -> loop (Parser.GOTO loc) + | Pre_parser.GT loc -> loop (Parser.GT loc) + | Pre_parser.HAT loc -> loop (Parser.HAT loc) + | Pre_parser.IF loc -> loop (Parser.IF_ loc) + | Pre_parser.INC loc -> loop (Parser.INC loc) + | Pre_parser.INLINE loc -> loop (Parser.INLINE loc) + | Pre_parser.INT loc -> loop (Parser.INT loc) + | Pre_parser.LBRACE loc -> loop (Parser.LBRACE loc) + | Pre_parser.LBRACK loc -> loop (Parser.LBRACK loc) + | Pre_parser.LEFT loc -> loop (Parser.LEFT loc) + | Pre_parser.LEFT_ASSIGN loc -> loop (Parser.LEFT_ASSIGN loc) + | Pre_parser.LEQ loc -> loop (Parser.LEQ loc) + | Pre_parser.LONG loc -> loop (Parser.LONG loc) + | Pre_parser.LPAREN loc -> loop (Parser.LPAREN loc) + | Pre_parser.LT loc -> loop (Parser.LT loc) + | Pre_parser.MINUS loc -> loop (Parser.MINUS loc) + | Pre_parser.MOD_ASSIGN loc -> loop (Parser.MOD_ASSIGN loc) + | Pre_parser.MUL_ASSIGN loc -> loop (Parser.MUL_ASSIGN loc) + | Pre_parser.NEQ loc -> loop (Parser.NEQ loc) + | Pre_parser.NORETURN loc -> loop (Parser.NORETURN loc) + | Pre_parser.OR_ASSIGN loc -> loop (Parser.OR_ASSIGN loc) + | Pre_parser.PACKED loc -> loop (Parser.PACKED loc) + | Pre_parser.PERCENT loc -> loop (Parser.PERCENT loc) + | Pre_parser.PLUS loc -> loop (Parser.PLUS loc) + | Pre_parser.PTR loc -> loop (Parser.PTR loc) + | Pre_parser.QUESTION loc -> loop (Parser.QUESTION loc) + | Pre_parser.RBRACE loc -> loop (Parser.RBRACE loc) + | Pre_parser.RBRACK loc -> loop (Parser.RBRACK loc) + | Pre_parser.REGISTER loc -> loop (Parser.REGISTER loc) + | Pre_parser.RESTRICT loc -> loop (Parser.RESTRICT loc) + | Pre_parser.RETURN loc -> loop (Parser.RETURN loc) + | Pre_parser.RIGHT loc -> loop (Parser.RIGHT loc) + | Pre_parser.RIGHT_ASSIGN loc -> loop (Parser.RIGHT_ASSIGN loc) + | Pre_parser.RPAREN loc -> loop (Parser.RPAREN loc) + | Pre_parser.SEMICOLON loc -> loop (Parser.SEMICOLON loc) + | Pre_parser.SHORT loc -> loop (Parser.SHORT loc) + | Pre_parser.SIGNED loc -> loop (Parser.SIGNED loc) + | Pre_parser.SIZEOF loc -> loop (Parser.SIZEOF loc) + | 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.STRING_LITERAL (wide, str, loc) -> (* Merge consecutive string literals *) let rec doConcat wide str = - try - match Queue.peek tokens with - | STRING_LITERAL (wide', str', loc) -> - ignore (Queue.pop tokens); - let (wide'', str'') = doConcat wide' str' in - if str'' <> [] - then (wide || wide'', str @ str'') - else (wide, str) - | _ -> - (wide, str) - with Queue.Empty -> (wide, str) in - let (wide', str') = doConcat wide str in - loop STRING_LITERAL't ((wide', str'), loc) - | STRUCT loc -> loop STRUCT't loc - | SUB_ASSIGN loc -> loop SUB_ASSIGN't loc - | SWITCH loc -> loop SWITCH't loc - | TILDE loc -> loop TILDE't loc - | TYPEDEF loc -> loop TYPEDEF't loc - | TYPEDEF_NAME (id, typ, loc) - | VAR_NAME (id, typ, loc) -> - let terminal = match !typ with - | VarId -> VAR_NAME't - | TypedefId -> TYPEDEF_NAME't - | OtherId -> OTHER_NAME't + match Queue.peek tokens with + | Pre_parser.STRING_LITERAL (wide', str', loc) -> + ignore (Queue.pop tokens); + let (wide'', str'') = doConcat wide' str' in + if str'' <> [] + then (wide || wide'', str @ str'') + else (wide, str) + | _ -> (wide, str) + | exception Queue.Empty -> (wide, str) in - loop terminal (id, loc) - | UNION loc -> loop UNION't loc - | UNSIGNED loc -> loop UNSIGNED't loc - | VOID loc -> loop VOID't loc - | VOLATILE loc -> loop VOLATILE't loc - | WHILE loc -> loop WHILE't loc - | XOR_ASSIGN loc -> loop XOR_ASSIGN't loc - | ALIGNAS loc -> loop ALIGNAS't loc - | ALIGNOF loc -> loop ALIGNOF't loc - | ATTRIBUTE loc -> loop ATTRIBUTE't loc - | ASM loc -> loop ASM't loc - | PRAGMA (s, loc) -> loop PRAGMA't (s, loc) - | PRE_NAME _ -> assert false + let (wide', str') = doConcat wide str in + loop (Parser.STRING_LITERAL ((wide', str'), loc)) + | Pre_parser.STRUCT loc -> loop (Parser.STRUCT loc) + | Pre_parser.SUB_ASSIGN loc -> loop (Parser.SUB_ASSIGN loc) + | Pre_parser.SWITCH loc -> loop (Parser.SWITCH loc) + | Pre_parser.TILDE loc -> loop (Parser.TILDE loc) + | Pre_parser.TYPEDEF loc -> loop (Parser.TYPEDEF loc) + | Pre_parser.TYPEDEF_NAME (id, typ, loc) + | Pre_parser.VAR_NAME (id, typ, loc) -> + begin match !typ with + | VarId -> loop (Parser.VAR_NAME (id, loc)) + | TypedefId -> loop (Parser.TYPEDEF_NAME (id, loc)) + | OtherId -> loop (Parser.OTHER_NAME (id, loc)) + end + | Pre_parser.UNION loc -> loop (Parser.UNION loc) + | Pre_parser.UNSIGNED loc -> loop (Parser.UNSIGNED loc) + | Pre_parser.VOID loc -> loop (Parser.VOID loc) + | Pre_parser.VOLATILE loc -> loop (Parser.VOLATILE loc) + | Pre_parser.WHILE loc -> loop (Parser.WHILE loc) + | Pre_parser.XOR_ASSIGN loc -> loop (Parser.XOR_ASSIGN loc) + | Pre_parser.ALIGNAS loc -> loop (Parser.ALIGNAS loc) + | Pre_parser.ALIGNOF loc -> loop (Parser.ALIGNOF loc) + | Pre_parser.ATTRIBUTE loc -> loop (Parser.ATTRIBUTE loc) + | Pre_parser.ASM loc -> loop (Parser.ASM loc) + | Pre_parser.PRAGMA (s, loc) -> loop (Parser.PRAGMA (s, loc)) + | Pre_parser.PRE_NAME _ -> assert false in - Lazy.from_fun compute_token_stream + Lazy.from_fun compute_buffer } diff --git a/cparser/MenhirLib/Alphabet.v b/cparser/MenhirLib/Alphabet.v deleted file mode 100644 index a13f69b0..00000000 --- a/cparser/MenhirLib/Alphabet.v +++ /dev/null @@ -1,320 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import Int31. -Require Import Cyclic31. -Require Import Omega. -Require Import List. -Require Import Syntax. -Require Import Relations. -Require Import RelationClasses. - -Local Obligation Tactic := intros. - -(** A comparable type is equiped with a [compare] function, that define an order - relation. **) -Class Comparable (A:Type) := { - compare : A -> A -> comparison; - compare_antisym : forall x y, CompOpp (compare x y) = compare y x; - compare_trans : forall x y z c, - (compare x y) = c -> (compare y z) = c -> (compare x z) = c -}. - -Theorem compare_refl {A:Type} (C: Comparable A) : - forall x, compare x x = Eq. -Proof. -intros. -pose proof (compare_antisym x x). -destruct (compare x x); intuition; try discriminate. -Qed. - -(** The corresponding order is a strict order. **) -Definition comparableLt {A:Type} (C: Comparable A) : relation A := - fun x y => compare x y = Lt. - -Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) : - StrictOrder (comparableLt C). -Proof. -apply Build_StrictOrder. -unfold Irreflexive, Reflexive, complement, comparableLt. -intros. -pose proof H. -rewrite <- compare_antisym in H. -rewrite H0 in H. -discriminate H. -unfold Transitive, comparableLt. -intros x y z. -apply compare_trans. -Qed. - -(** nat is comparable. **) -Program Instance natComparable : Comparable nat := - { compare := Nat.compare }. -Next Obligation. -symmetry. -destruct (Nat.compare x y) as [] eqn:?. -rewrite Nat.compare_eq_iff in Heqc. -destruct Heqc. -rewrite Nat.compare_eq_iff. -trivial. -rewrite <- nat_compare_lt in *. -rewrite <- nat_compare_gt in *. -trivial. -rewrite <- nat_compare_lt in *. -rewrite <- nat_compare_gt in *. -trivial. -Qed. -Next Obligation. -destruct c. -rewrite Nat.compare_eq_iff in *; destruct H; assumption. -rewrite <- nat_compare_lt in *. -apply (Nat.lt_trans _ _ _ H H0). -rewrite <- nat_compare_gt in *. -apply (gt_trans _ _ _ H H0). -Qed. - -(** A pair of comparable is comparable. **) -Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) : - Comparable (A*B) := - { compare := fun x y => - let (xa, xb) := x in let (ya, yb) := y in - match compare xa ya return comparison with - | Eq => compare xb yb - | x => x - end }. -Next Obligation. -destruct x, y. -rewrite <- (compare_antisym a a0). -rewrite <- (compare_antisym b b0). -destruct (compare a a0); intuition. -Qed. -Next Obligation. -destruct x, y, z. -destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?; -try (rewrite <- H0 in H; discriminate); -try (destruct (compare a a1) as [] eqn:?; - try (rewrite <- compare_antisym in Heqc0; - rewrite CompOpp_iff in Heqc0; - rewrite (compare_trans _ _ _ _ Heqc0 Heqc2) in Heqc1; - discriminate); - try (rewrite <- compare_antisym in Heqc1; - rewrite CompOpp_iff in Heqc1; - rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0; - discriminate); - assumption); -rewrite (compare_trans _ _ _ _ Heqc0 Heqc1); -try assumption. -apply (compare_trans _ _ _ _ H H0). -Qed. - -(** Special case of comparable, where equality is usual equality. **) -Class ComparableUsualEq {A:Type} (C: Comparable A) := - compare_eq : forall x y, compare x y = Eq -> x = y. - -(** Boolean equality for a [Comparable]. **) -Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) := - match compare x y with - | Eq => true - | _ => false - end. - -Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableUsualEq C} : - forall x y, compare_eqb x y = true <-> x = y. -Proof. -unfold compare_eqb. -intuition. -apply compare_eq. -destruct (compare x y); intuition; discriminate. -destruct H. -rewrite compare_refl; intuition. -Qed. - -(** [Comparable] provides a decidable equality. **) -Definition compare_eqdec {A:Type} {C:Comparable A} {U:ComparableUsualEq C} (x y:A): - {x = y} + {x <> y}. -Proof. -destruct (compare x y) as [] eqn:?; [left; apply compare_eq; intuition | ..]; - right; intro; destruct H; rewrite compare_refl in Heqc; discriminate. -Defined. - -Instance NComparableUsualEq : ComparableUsualEq natComparable := Nat.compare_eq. - -(** A pair of ComparableUsualEq is ComparableUsualEq **) -Instance PairComparableUsualEq - {A:Type} {CA:Comparable A} (UA:ComparableUsualEq CA) - {B:Type} {CB:Comparable B} (UB:ComparableUsualEq CB) : - ComparableUsualEq (PairComparable CA CB). -Proof. -intros x y; destruct x, y; simpl. -pose proof (compare_eq a a0); pose proof (compare_eq b b0). -destruct (compare a a0); try discriminate. -intuition. -destruct H2, H0. -reflexivity. -Qed. - -(** An [Finite] type is a type with the list of all elements. **) -Class Finite (A:Type) := { - all_list : list A; - all_list_forall : forall x:A, In x all_list -}. - -(** An alphabet is both [ComparableUsualEq] and [Finite]. **) -Class Alphabet (A:Type) := { - AlphabetComparable :> Comparable A; - AlphabetComparableUsualEq :> ComparableUsualEq AlphabetComparable; - AlphabetFinite :> Finite A -}. - -(** The [Numbered] class provides a conveniant way to build [Alphabet] instances, - with a good computationnal complexity. It is mainly a injection from it to - [Int31] **) -Class Numbered (A:Type) := { - inj : A -> int31; - surj : int31 -> A; - surj_inj_compat : forall x, surj (inj x) = x; - inj_bound : int31; - inj_bound_spec : forall x, (phi (inj x) < phi inj_bound)%Z -}. - -Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A := - { AlphabetComparable := - {| compare := fun x y => compare31 (inj x) (inj y) |}; - AlphabetFinite := - {| all_list := fst (iter_int31 inj_bound _ - (fun p => (cons (surj (snd p)) (fst p), incr (snd p))) ([], 0%int31)) |} }. -Next Obligation. apply Zcompare_antisym. Qed. -Next Obligation. -destruct c. unfold compare31 in *. -rewrite Z.compare_eq_iff in *. congruence. -eapply Zcompare_Lt_trans. apply H. apply H0. -eapply Zcompare_Gt_trans. apply H. apply H0. -Qed. -Next Obligation. -intros x y H. unfold compare, compare31 in H. -rewrite Z.compare_eq_iff in *. -rewrite <- surj_inj_compat, <- phi_inv_phi with (inj y), <- H. -rewrite phi_inv_phi, surj_inj_compat; reflexivity. -Qed. -Next Obligation. -rewrite iter_int31_iter_nat. -pose proof (inj_bound_spec x). -match goal with |- In x (fst ?p) => destruct p as [] eqn:? end. -replace inj_bound with i in H. -revert l i Heqp x H. -induction (Z.abs_nat (phi inj_bound)); intros. -inversion Heqp; clear Heqp; subst. -rewrite spec_0 in H. pose proof (phi_bounded (inj x)). omega. -simpl in Heqp. -destruct nat_rect; specialize (IHn _ _ (eq_refl _) x); simpl in *. -inversion Heqp. subst. clear Heqp. -rewrite phi_incr in H. -pose proof (phi_bounded i0). -pose proof (phi_bounded (inj x)). -destruct (Z_lt_le_dec (Z.succ (phi i0)) (2 ^ Z.of_nat size)%Z). -rewrite Zmod_small in H by omega. -apply Zlt_succ_le, Zle_lt_or_eq in H. -destruct H; simpl; auto. left. -rewrite <- surj_inj_compat, <- phi_inv_phi with (inj x), H, phi_inv_phi; reflexivity. -replace (Z.succ (phi i0)) with (2 ^ Z.of_nat size)%Z in H by omega. -rewrite Z_mod_same_full in H. -exfalso; omega. -rewrite <- phi_inv_phi with i, <- phi_inv_phi with inj_bound; f_equal. -pose proof (phi_bounded inj_bound); pose proof (phi_bounded i). -rewrite <- Z.abs_eq with (phi i), <- Z.abs_eq with (phi inj_bound) by omega. -clear H H0 H1. -do 2 rewrite <- Zabs2Nat.id_abs. -f_equal. -revert l i Heqp. -assert (Z.abs_nat (phi inj_bound) < Z.abs_nat (2^31)). -apply Zabs_nat_lt, phi_bounded. -induction (Z.abs_nat (phi inj_bound)); intros. -inversion Heqp; reflexivity. -inversion Heqp; clear H1 H2 Heqp. -match goal with |- _ (_ (_ (snd ?p))) = _ => destruct p end. -pose proof (phi_bounded i0). -erewrite <- IHn, <- Zabs2Nat.inj_succ in H |- *; eauto; try omega. -rewrite phi_incr, Zmod_small; intuition; try omega. -apply inj_lt in H. -pose proof Z.le_le_succ_r. -do 2 rewrite Zabs2Nat.id_abs, Z.abs_eq in H; now eauto. -Qed. - -(** Previous class instances for [option A] **) -Program Instance OptionComparable {A:Type} (C:Comparable A) : Comparable (option A) := - { compare := fun x y => - match x, y return comparison with - | None, None => Eq - | None, Some _ => Lt - | Some _, None => Gt - | Some x, Some y => compare x y - end }. -Next Obligation. -destruct x, y; intuition. -apply compare_antisym. -Qed. -Next Obligation. -destruct x, y, z; try now intuition; -try (rewrite <- H in H0; discriminate). -apply (compare_trans _ _ _ _ H H0). -Qed. - -Instance OptionComparableUsualEq {A:Type} {C:Comparable A} (U:ComparableUsualEq C) : - ComparableUsualEq (OptionComparable C). -Proof. -intros x y. -destruct x, y; intuition; try discriminate. -rewrite (compare_eq a a0); intuition. -Qed. - -Program Instance OptionFinite {A:Type} (E:Finite A) : Finite (option A) := - { all_list := None :: map Some all_list }. -Next Obligation. -destruct x; intuition. -right. -apply in_map. -apply all_list_forall. -Defined. - -(** Definitions of [FSet]/[FMap] from [Comparable] **) -Require Import OrderedTypeAlt. -Require FSetAVL. -Require FMapAVL. -Import OrderedType. - -Module Type ComparableM. - Parameter t : Type. - Declare Instance tComparable : Comparable t. -End ComparableM. - -Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt. - Definition t := C.t. - Definition compare : t -> t -> comparison := compare. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym x y : (y?=x) = CompOpp (x?=y). - Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed. - Lemma compare_trans c x y z : - (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - apply compare_trans. - Qed. -End OrderedTypeAlt_from_ComparableM. - -Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType. - Module Alt := OrderedTypeAlt_from_ComparableM C. - Include (OrderedType_from_Alt Alt). -End OrderedType_from_ComparableM. diff --git a/cparser/MenhirLib/Grammar.v b/cparser/MenhirLib/Grammar.v deleted file mode 100644 index 8e427cd9..00000000 --- a/cparser/MenhirLib/Grammar.v +++ /dev/null @@ -1,166 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import List. -Require Import Syntax. -Require Import Alphabet. -Require Import Orders. -Require Tuples. - -(** The terminal non-terminal alphabets of the grammar. **) -Module Type Alphs. - Parameters terminal nonterminal : Type. - Declare Instance TerminalAlph: Alphabet terminal. - Declare Instance NonTerminalAlph: Alphabet nonterminal. -End Alphs. - -(** Definition of the alphabet of symbols, given the alphabet of terminals - and the alphabet of non terminals **) -Module Symbol(Import A:Alphs). - - Inductive symbol := - | T: terminal -> symbol - | NT: nonterminal -> symbol. - - Program Instance SymbolAlph : Alphabet symbol := - { AlphabetComparable := {| compare := fun x y => - match x, y return comparison with - | T _, NT _ => Gt - | NT _, T _ => Lt - | T x, T y => compare x y - | NT x, NT y => compare x y - end |}; - AlphabetFinite := {| all_list := - map T all_list++map NT all_list |} }. - Next Obligation. - destruct x; destruct y; intuition; apply compare_antisym. - Qed. - Next Obligation. - destruct x; destruct y; destruct z; intuition; try discriminate. - apply (compare_trans _ t0); intuition. - apply (compare_trans _ n0); intuition. - Qed. - Next Obligation. - intros x y. - destruct x; destruct y; try discriminate; intros. - rewrite (compare_eq t t0); intuition. - rewrite (compare_eq n n0); intuition. - Qed. - Next Obligation. - rewrite in_app_iff. - destruct x; [left | right]; apply in_map; apply all_list_forall. - Qed. - -End Symbol. - -Module Type T. - Export Tuples. - - Include Alphs <+ Symbol. - - (** [symbol_semantic_type] maps a symbols to the type of its semantic - values. **) - Parameter symbol_semantic_type: symbol -> Type. - - (** The type of productions identifiers **) - Parameter production : Type. - Declare Instance ProductionAlph : Alphabet production. - - (** Accessors for productions: left hand side, right hand side, - and semantic action. The semantic actions are given in the form - of curryfied functions, that take arguments in the reverse order. **) - Parameter prod_lhs: production -> nonterminal. - Parameter prod_rhs_rev: production -> list symbol. - Parameter prod_action: - forall p:production, - arrows_left - (map symbol_semantic_type (rev (prod_rhs_rev p))) - (symbol_semantic_type (NT (prod_lhs p))). - -End T. - -Module Defs(Import G:T). - - (** A token is a terminal and a semantic value for this terminal. **) - Definition token := {t:terminal & symbol_semantic_type (T t)}. - - (** A grammar creates a relation between word of tokens and semantic values. - This relation is parametrized by the head symbol. It defines the - "semantics" of the grammar. This relation is defined by a notion of - parse tree. **) - Inductive parse_tree: - forall (head_symbol:symbol) (word:list token) - (semantic_value:symbol_semantic_type head_symbol), Type := - - (** A single token has its semantic value as semantic value, for the - corresponding terminal as head symbol. **) - | Terminal_pt: - forall (t:terminal) (sem:symbol_semantic_type (T t)), - parse_tree (T t) - [existT (fun t => symbol_semantic_type (T t)) t sem] sem - - (** Given a production, if a word has a list of semantic values for the - right hand side as head symbols, then this word has the semantic value - given by the semantic action of the production for the left hand side - as head symbol.**) - | Non_terminal_pt: - forall {p:production} {word:list token} - {semantic_values:tuple (map symbol_semantic_type (rev (prod_rhs_rev p)))}, - parse_tree_list (rev (prod_rhs_rev p)) word semantic_values -> - parse_tree (NT (prod_lhs p)) word (uncurry (prod_action p) semantic_values) - - (** Basically the same relation as before, but for list of head symbols (ie. - We are building a forest of syntax trees. It is mutually recursive with the - previous relation **) - with parse_tree_list: - forall (head_symbols:list symbol) (word:list token) - (semantic_values:tuple (map symbol_semantic_type head_symbols)), - Type := - - (** The empty word has [()] as semantic for [[]] as head symbols list **) - | Nil_ptl: parse_tree_list [] [] () - - (** The cons of the semantic value for one head symbol and for a list of head - symbols **) - | Cons_ptl: - (** The semantic for the head **) - forall {head_symbolt:symbol} {wordt:list token} - {semantic_valuet:symbol_semantic_type head_symbolt}, - parse_tree head_symbolt wordt semantic_valuet -> - - (** and the semantic for the tail **) - forall {head_symbolsq:list symbol} {wordq:list token} - {semantic_valuesq:tuple (map symbol_semantic_type head_symbolsq)}, - parse_tree_list head_symbolsq wordq semantic_valuesq -> - - (** give the semantic of the cons **) - parse_tree_list - (head_symbolt::head_symbolsq) - (wordt++wordq) - (semantic_valuet, semantic_valuesq). - - - Fixpoint pt_size {head_symbol word sem} (tree:parse_tree head_symbol word sem) := - match tree with - | Terminal_pt _ _ => 1 - | Non_terminal_pt l => S (ptl_size l) - end - with ptl_size {head_symbols word sems} (tree:parse_tree_list head_symbols word sems) := - match tree with - | Nil_ptl => 0 - | Cons_ptl t q => - pt_size t + ptl_size q - end. -End Defs. diff --git a/cparser/MenhirLib/Interpreter.v b/cparser/MenhirLib/Interpreter.v deleted file mode 100644 index 4ac02693..00000000 --- a/cparser/MenhirLib/Interpreter.v +++ /dev/null @@ -1,228 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import Streams. -Require Import List. -Require Import Syntax. -Require Automaton. -Require Import Alphabet. - -Module Make(Import A:Automaton.T). - -(** The error monad **) -Inductive result (A:Type) := - | Err: result A - | OK: A -> result A. - -Arguments Err [A]. -Arguments OK [A]. - -Definition bind {A B: Type} (f: result A) (g: A -> result B): result B := - match f with - | OK x => g x - | Err => Err - end. - -Definition bind2 {A B C: Type} (f: result (A * B)) (g: A -> B -> result C): - result C := - match f with - | OK (x, y) => g x y - | Err => Err - end. - -Notation "'do' X <- A ; B" := (bind A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). - -Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) - (at level 200, X ident, Y ident, A at level 100, B at level 200). - -(** Some operations on streams **) - -(** Concatenation of a list and a stream **) -Fixpoint app_str {A:Type} (l:list A) (s:Stream A) := - match l with - | nil => s - | cons t q => Cons t (app_str q s) - end. - -Infix "++" := app_str (right associativity, at level 60). - -Lemma app_str_app_assoc {A:Type} (l1 l2:list A) (s:Stream A) : - l1 ++ (l2 ++ s) = (l1 ++ l2) ++ s. -Proof. -induction l1. -reflexivity. -simpl. -rewrite IHl1. -reflexivity. -Qed. - -(** The type of a non initial state: the type of semantic values associated - with the last symbol of this state. *) -Definition noninitstate_type state := - symbol_semantic_type (last_symb_of_non_init_state state). - -(** The stack of the automaton : it can be either nil or contains a non - initial state, a semantic value for the symbol associted with this state, - and a nested stack. **) -Definition stack := list (sigT noninitstate_type). (* eg. list {state & state_type state} *) - -Section Init. - -Variable init : initstate. - -(** The top state of a stack **) -Definition state_of_stack (stack:stack): state := - match stack with - | [] => init - | existT _ s _::_ => s - end. - -(** [pop] pops some symbols from the stack. It returns the popped semantic - values using [sem_popped] as an accumulator and discards the popped - states.**) -Fixpoint pop (symbols_to_pop:list symbol) (stack_cur:stack): - forall {A:Type} (action:arrows_right A (map symbol_semantic_type symbols_to_pop)), - result (stack * A) := - match symbols_to_pop return forall {A:Type} (action:arrows_right A (map _ symbols_to_pop)), result (stack * A) with - | [] => fun A action => OK (stack_cur, action) - | t::q => fun A action => - match stack_cur with - | existT _ state_cur sem::stack_rec => - match compare_eqdec (last_symb_of_non_init_state state_cur) t with - | left e => - let sem_conv := eq_rect _ symbol_semantic_type sem _ e in - pop q stack_rec (action sem_conv) - | right _ => Err - end - | [] => Err - end - end. - -(** [step_result] represents the result of one step of the automaton : it can - fail, accept or progress. [Fail_sr] means that the input is incorrect. - [Accept_sr] means that this is the last step of the automaton, and it - returns the semantic value of the input word. [Progress_sr] means that - some progress has been made, but new steps are needed in order to accept - a word. - - For [Accept_sr] and [Progress_sr], the result contains the new input buffer. - - [Fail_sr] means that the input word is rejected by the automaton. It is - different to [Err] (from the error monad), which mean that the automaton is - bogus and has perfomed a forbidden action. **) -Inductive step_result := - | Fail_sr: step_result - | Accept_sr: symbol_semantic_type (NT (start_nt init)) -> Stream token -> step_result - | Progress_sr: stack -> Stream token -> step_result. - -Program Definition prod_action': - forall p, - arrows_right (symbol_semantic_type (NT (prod_lhs p))) - (map symbol_semantic_type (prod_rhs_rev p)):= - fun p => - eq_rect _ (fun x => x) (prod_action p) _ _. -Next Obligation. -unfold arrows_left, arrows_right; simpl. -rewrite <- fold_left_rev_right, <- map_rev, rev_involutive. -reflexivity. -Qed. - -(** [reduce_step] does a reduce action : - - pops some elements from the stack - - execute the action of the production - - follows the goto for the produced non terminal symbol **) -Definition reduce_step stack_cur production buffer: result step_result := - do (stack_new, sem) <- - pop (prod_rhs_rev production) stack_cur (prod_action' production); - match goto_table (state_of_stack stack_new) (prod_lhs production) with - | Some (exist _ state_new e) => - let sem := eq_rect _ _ sem _ e in - OK (Progress_sr (existT noninitstate_type state_new sem::stack_new) buffer) - | None => - match stack_new with - | [] => - match compare_eqdec (prod_lhs production) (start_nt init) with - | left e => - let sem := eq_rect _ (fun nt => symbol_semantic_type (NT nt)) sem _ e in - OK (Accept_sr sem buffer) - | right _ => Err - end - | _::_ => Err - end - end. - -(** One step of parsing. **) -Definition step stack_cur buffer: result step_result := - match action_table (state_of_stack stack_cur) with - | Default_reduce_act production => - reduce_step stack_cur production buffer - | Lookahead_act awt => - match Streams.hd buffer with - | existT _ term sem => - match awt term with - | Shift_act state_new e => - let sem_conv := eq_rect _ symbol_semantic_type sem _ e in - OK (Progress_sr (existT noninitstate_type state_new sem_conv::stack_cur) - (Streams.tl buffer)) - | Reduce_act production => - reduce_step stack_cur production buffer - | Fail_action => - OK Fail_sr - end - end - end. - -(** The parsing use a [nat] parameter [n_steps], so that we do not have to prove - terminaison, which is difficult. So the result of a parsing is either - a failure (the automaton has rejected the input word), either a timeout - (the automaton has spent all the given [n_steps]), either a parsed semantic - value with a rest of the input buffer. -**) -Inductive parse_result := - | Fail_pr: parse_result - | Timeout_pr: parse_result - | Parsed_pr: symbol_semantic_type (NT (start_nt init)) -> Stream token -> parse_result. - -Fixpoint parse_fix stack_cur buffer n_steps: result parse_result:= - match n_steps with - | O => OK Timeout_pr - | S it => - do r <- step stack_cur buffer; - match r with - | Fail_sr => OK Fail_pr - | Accept_sr t buffer_new => OK (Parsed_pr t buffer_new) - | Progress_sr s buffer_new => parse_fix s buffer_new it - end - end. - -Definition parse buffer n_steps: result parse_result := - parse_fix [] buffer n_steps. - -End Init. - -Arguments Fail_sr [init]. -Arguments Accept_sr [init] _ _. -Arguments Progress_sr [init] _ _. - -Arguments Fail_pr [init]. -Arguments Timeout_pr [init]. -Arguments Parsed_pr [init] _ _. - -End Make. - -Module Type T(A:Automaton.T). - Include (Make A). -End T. diff --git a/cparser/MenhirLib/Interpreter_complete.v b/cparser/MenhirLib/Interpreter_complete.v deleted file mode 100644 index 2e64b8da..00000000 --- a/cparser/MenhirLib/Interpreter_complete.v +++ /dev/null @@ -1,686 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import Streams. -Require Import ProofIrrelevance. -Require Import Equality. -Require Import List. -Require Import Syntax. -Require Import Alphabet. -Require Import Arith. -Require Grammar. -Require Automaton. -Require Interpreter. -Require Validator_complete. - -Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A). -Module Import Valid := Validator_complete.Make A. - -(** * Completeness Proof **) - -Section Completeness_Proof. - -Hypothesis complete: complete. - -Proposition nullable_stable: nullable_stable. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition first_stable: first_stable. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition start_future: start_future. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition terminal_shift: terminal_shift. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition end_reduce: end_reduce. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition start_goto: start_goto. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition non_terminal_goto: non_terminal_goto. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. -Proposition non_terminal_closed: non_terminal_closed. -Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed. - -(** If the nullable predicate has been validated, then it is correct. **) -Lemma nullable_correct: - forall head sem word, word = [] -> - parse_tree head word sem -> nullable_symb head = true -with nullable_correct_list: - forall heads sems word, word = [] -> - parse_tree_list heads word sems -> nullable_word heads = true. -Proof with eauto. -intros. -destruct X. -congruence. -apply nullable_stable... -intros. -destruct X; simpl... -apply andb_true_intro. -apply app_eq_nil in H; destruct H; split... -Qed. - -(** If the first predicate has been validated, then it is correct. **) -Lemma first_correct: - forall head sem word t q, word = t::q -> - parse_tree head word sem -> - TerminalSet.In (projT1 t) (first_symb_set head) -with first_correct_list: - forall heads sems word t q, word = t::q -> - parse_tree_list heads word sems -> - TerminalSet.In (projT1 t) (first_word_set heads). -Proof with eauto. -intros. -destruct X. -inversion H; subst. -apply TerminalSet.singleton_2, compare_refl... -apply first_stable... -intros. -destruct X. -congruence. -simpl. -case_eq wordt; intros. -erewrite nullable_correct... -apply TerminalSet.union_3. -subst... -rewrite H0 in *; inversion H; destruct H2. -destruct (nullable_symb head_symbolt)... -apply TerminalSet.union_2... -Qed. - -Variable init: initstate. -Variable full_word: list token. -Variable buffer_end: Stream token. -Variable full_sem: symbol_semantic_type (NT (start_nt init)). - -Inductive pt_zipper: - forall (hole_symb:symbol) (hole_word:list token) - (hole_sem:symbol_semantic_type hole_symb), Type := -| Top_ptz: - pt_zipper (NT (start_nt init)) (full_word) (full_sem) -| Cons_ptl_ptz: - forall {head_symbolt:symbol} - {wordt:list token} - {semantic_valuet:symbol_semantic_type head_symbolt}, - - forall {head_symbolsq:list symbol} - {wordq:list token} - {semantic_valuesq:tuple (map symbol_semantic_type head_symbolsq)}, - parse_tree_list head_symbolsq wordq semantic_valuesq -> - - ptl_zipper (head_symbolt::head_symbolsq) (wordt++wordq) - (semantic_valuet,semantic_valuesq) -> - - pt_zipper head_symbolt wordt semantic_valuet -with ptl_zipper: - forall (hole_symbs:list symbol) (hole_word:list token) - (hole_sems:tuple (map symbol_semantic_type hole_symbs)), Type := -| Non_terminal_pt_ptlz: - forall {p:production} {word:list token} - {semantic_values:tuple (map symbol_semantic_type (rev (prod_rhs_rev p)))}, - pt_zipper (NT (prod_lhs p)) word (uncurry (prod_action p) semantic_values) -> - ptl_zipper (rev (prod_rhs_rev p)) word semantic_values - -| Cons_ptl_ptlz: - forall {head_symbolt:symbol} - {wordt:list token} - {semantic_valuet:symbol_semantic_type head_symbolt}, - parse_tree head_symbolt wordt semantic_valuet -> - - forall {head_symbolsq:list symbol} - {wordq:list token} - {semantic_valuesq:tuple (map symbol_semantic_type head_symbolsq)}, - - ptl_zipper (head_symbolt::head_symbolsq) (wordt++wordq) - (semantic_valuet,semantic_valuesq) -> - - ptl_zipper head_symbolsq wordq semantic_valuesq. - -Fixpoint ptlz_cost {hole_symbs hole_word hole_sems} - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) := - match ptlz with - | Non_terminal_pt_ptlz ptz => - ptz_cost ptz - | Cons_ptl_ptlz pt ptlz' => - ptlz_cost ptlz' - end -with ptz_cost {hole_symb hole_word hole_sem} - (ptz:pt_zipper hole_symb hole_word hole_sem) := - match ptz with - | Top_ptz => 0 - | Cons_ptl_ptz ptl ptlz' => - 1 + ptl_size ptl + ptlz_cost ptlz' - end. - -Inductive pt_dot: Type := -| Reduce_ptd: ptl_zipper [] [] () -> pt_dot -| Shift_ptd: - forall (term:terminal) (sem: symbol_semantic_type (T term)) - {symbolsq wordq semsq}, - parse_tree_list symbolsq wordq semsq -> - ptl_zipper (T term::symbolsq) (existT (fun t => symbol_semantic_type (T t)) term sem::wordq) (sem, semsq) -> - pt_dot. - -Definition ptd_cost (ptd:pt_dot) := - match ptd with - | Reduce_ptd ptlz => ptlz_cost ptlz - | Shift_ptd _ _ ptl ptlz => 1 + ptl_size ptl + ptlz_cost ptlz - end. - -Fixpoint ptlz_buffer {hole_symbs hole_word hole_sems} - (ptlz:ptl_zipper hole_symbs hole_word hole_sems): Stream token := - match ptlz with - | Non_terminal_pt_ptlz ptz => - ptz_buffer ptz - | Cons_ptl_ptlz _ ptlz' => - ptlz_buffer ptlz' - end -with ptz_buffer {hole_symb hole_word hole_sem} - (ptz:pt_zipper hole_symb hole_word hole_sem): Stream token := - match ptz with - | Top_ptz => buffer_end - | @Cons_ptl_ptz _ _ _ _ wordq _ ptl ptlz' => - wordq++ptlz_buffer ptlz' - end. - -Definition ptd_buffer (ptd:pt_dot) := - match ptd with - | Reduce_ptd ptlz => ptlz_buffer ptlz - | @Shift_ptd term sem _ wordq _ _ ptlz => - Cons (existT (fun t => symbol_semantic_type (T t)) term sem) - (wordq ++ ptlz_buffer ptlz) - end. - -Fixpoint ptlz_prod {hole_symbs hole_word hole_sems} - (ptlz:ptl_zipper hole_symbs hole_word hole_sems): production := - match ptlz with - | @Non_terminal_pt_ptlz prod _ _ _ => prod - | Cons_ptl_ptlz _ ptlz' => - ptlz_prod ptlz' - end. - -Fixpoint ptlz_past {hole_symbs hole_word hole_sems} - (ptlz:ptl_zipper hole_symbs hole_word hole_sems): list symbol := - match ptlz with - | Non_terminal_pt_ptlz _ => [] - | @Cons_ptl_ptlz s _ _ _ _ _ _ ptlz' => s::ptlz_past ptlz' - end. - -Lemma ptlz_past_ptlz_prod: - forall hole_symbs hole_word hole_sems - (ptlz:ptl_zipper hole_symbs hole_word hole_sems), - rev_append hole_symbs (ptlz_past ptlz) = prod_rhs_rev (ptlz_prod ptlz). -Proof. -fix ptlz_past_ptlz_prod 4. -destruct ptlz; simpl. -rewrite <- rev_alt, rev_involutive; reflexivity. -apply (ptlz_past_ptlz_prod _ _ _ ptlz). -Qed. - -Definition ptlz_state_compat {hole_symbs hole_word hole_sems} - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) - (state:state): Prop := - state_has_future state (ptlz_prod ptlz) hole_symbs - (projT1 (Streams.hd (ptlz_buffer ptlz))). - -Fixpoint ptlz_stack_compat {hole_symbs hole_word hole_sems} - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) - (stack:stack): Prop := - ptlz_state_compat ptlz (state_of_stack init stack) /\ - match ptlz with - | Non_terminal_pt_ptlz ptz => - ptz_stack_compat ptz stack - | @Cons_ptl_ptlz _ _ sem _ _ _ _ ptlz' => - match stack with - | [] => False - | existT _ _ sem'::stackq => - ptlz_stack_compat ptlz' stackq /\ - sem ~= sem' - end - end -with ptz_stack_compat {hole_symb hole_word hole_sem} - (ptz:pt_zipper hole_symb hole_word hole_sem) - (stack:stack): Prop := - match ptz with - | Top_ptz => stack = [] - | Cons_ptl_ptz _ ptlz' => - ptlz_stack_compat ptlz' stack - end. - -Lemma ptlz_stack_compat_ptlz_state_compat: - forall hole_symbs hole_word hole_sems - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) - (stack:stack), - ptlz_stack_compat ptlz stack -> ptlz_state_compat ptlz (state_of_stack init stack). -Proof. -destruct ptlz; simpl; intuition. -Qed. - -Definition ptd_stack_compat (ptd:pt_dot) (stack:stack): Prop := - match ptd with - | Reduce_ptd ptlz => ptlz_stack_compat ptlz stack - | Shift_ptd _ _ _ ptlz => ptlz_stack_compat ptlz stack - end. - -Fixpoint build_pt_dot {hole_symbs hole_word hole_sems} - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) - :pt_dot := - match ptl in parse_tree_list hole_symbs hole_word hole_sems - return ptl_zipper hole_symbs hole_word hole_sems -> _ - with - | Nil_ptl => fun ptlz => - Reduce_ptd ptlz - | Cons_ptl pt ptl' => - match pt in parse_tree hole_symb hole_word hole_sem - return ptl_zipper (hole_symb::_) (hole_word++_) (hole_sem,_) -> _ - with - | Terminal_pt term sem => fun ptlz => - Shift_ptd term sem ptl' ptlz - | Non_terminal_pt ptl'' => fun ptlz => - build_pt_dot ptl'' - (Non_terminal_pt_ptlz (Cons_ptl_ptz ptl' ptlz)) - end - end ptlz. - -Lemma build_pt_dot_cost: - forall hole_symbs hole_word hole_sems - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems), - ptd_cost (build_pt_dot ptl ptlz) = ptl_size ptl + ptlz_cost ptlz. -Proof. -fix build_pt_dot_cost 4. -destruct ptl; intros. -reflexivity. -destruct p. -reflexivity. -simpl; rewrite build_pt_dot_cost. -simpl; rewrite <- plus_n_Sm, Nat.add_assoc; reflexivity. -Qed. - -Lemma build_pt_dot_buffer: - forall hole_symbs hole_word hole_sems - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems), - ptd_buffer (build_pt_dot ptl ptlz) = hole_word ++ ptlz_buffer ptlz. -Proof. -fix build_pt_dot_buffer 4. -destruct ptl; intros. -reflexivity. -destruct p. -reflexivity. -simpl; rewrite build_pt_dot_buffer. -apply app_str_app_assoc. -Qed. - -Lemma ptd_stack_compat_build_pt_dot: - forall hole_symbs hole_word hole_sems - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) - (stack:stack), - ptlz_stack_compat ptlz stack -> - ptd_stack_compat (build_pt_dot ptl ptlz) stack. -Proof. -fix ptd_stack_compat_build_pt_dot 4. -destruct ptl; intros. -eauto. -destruct p. -eauto. -simpl. -apply ptd_stack_compat_build_pt_dot. -split. -apply ptlz_stack_compat_ptlz_state_compat, non_terminal_closed in H. -apply H; clear H; eauto. -destruct wordq. -right; split. -eauto. -eapply nullable_correct_list; eauto. -left. -eapply first_correct_list; eauto. -eauto. -Qed. - -Program Fixpoint pop_ptlz {hole_symbs hole_word hole_sems} - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems): - { word:_ & { sem:_ & - (pt_zipper (NT (prod_lhs (ptlz_prod ptlz))) word sem * - parse_tree (NT (prod_lhs (ptlz_prod ptlz))) word sem)%type } } := - match ptlz in ptl_zipper hole_symbs hole_word hole_sems - return parse_tree_list hole_symbs hole_word hole_sems -> - { word:_ & { sem:_ & - (pt_zipper (NT (prod_lhs (ptlz_prod ptlz))) word sem * - parse_tree (NT (prod_lhs (ptlz_prod ptlz))) word sem)%type } } - with - | @Non_terminal_pt_ptlz prod word sem ptz => fun ptl => - let sem := uncurry (prod_action prod) sem in - existT _ word (existT _ sem (ptz, Non_terminal_pt ptl)) - | Cons_ptl_ptlz pt ptlz' => fun ptl => - pop_ptlz (Cons_ptl pt ptl) ptlz' - end ptl. - -Lemma pop_ptlz_cost: - forall hole_symbs hole_word hole_sems - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems), - let 'existT _ word (existT _ sem (ptz, pt)) := pop_ptlz ptl ptlz in - ptlz_cost ptlz = ptz_cost ptz. -Proof. -fix pop_ptlz_cost 5. -destruct ptlz. -reflexivity. -simpl; apply pop_ptlz_cost. -Qed. - -Lemma pop_ptlz_buffer: - forall hole_symbs hole_word hole_sems - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems), - let 'existT _ word (existT _ sem (ptz, pt)) := pop_ptlz ptl ptlz in - ptlz_buffer ptlz = ptz_buffer ptz. -Proof. -fix pop_ptlz_buffer 5. -destruct ptlz. -reflexivity. -simpl; apply pop_ptlz_buffer. -Qed. - -Lemma pop_ptlz_pop_stack_compat_converter: - forall A hole_symbs hole_word hole_sems (ptlz:ptl_zipper hole_symbs hole_word hole_sems), - arrows_left (map symbol_semantic_type (rev (prod_rhs_rev (ptlz_prod ptlz)))) A = - arrows_left (map symbol_semantic_type hole_symbs) - (arrows_right A (map symbol_semantic_type (ptlz_past ptlz))). -Proof. -intros. -rewrite <- ptlz_past_ptlz_prod. -unfold arrows_right, arrows_left. -rewrite rev_append_rev, map_rev, map_app, map_rev, <- fold_left_rev_right, rev_involutive, fold_right_app. -rewrite fold_left_rev_right. -reflexivity. -Qed. - -Lemma pop_ptlz_pop_stack_compat: - forall hole_symbs hole_word hole_sems - (ptl:parse_tree_list hole_symbs hole_word hole_sems) - (ptlz:ptl_zipper hole_symbs hole_word hole_sems) - (stack:stack), - - ptlz_stack_compat ptlz stack -> - - let action' := - eq_rect _ (fun x=>x) (prod_action (ptlz_prod ptlz)) _ - (pop_ptlz_pop_stack_compat_converter _ _ _ _ _) - in - let 'existT _ word (existT _ sem (ptz, pt)) := pop_ptlz ptl ptlz in - match pop (ptlz_past ptlz) stack (uncurry action' hole_sems) with - | OK (stack', sem') => - ptz_stack_compat ptz stack' /\ sem = sem' - | Err => True - end. -Proof. -Opaque AlphabetComparable AlphabetComparableUsualEq. -fix pop_ptlz_pop_stack_compat 5. -destruct ptlz. intros; simpl. -split. -apply H. -eapply (f_equal (fun X => uncurry X semantic_values)). -apply JMeq_eq, JMeq_sym, JMeq_eqrect with (P:=fun x => x). -simpl; intros; destruct stack0. -destruct (proj2 H). -simpl in H; destruct H. -destruct s as (state, sem'). -destruct H0. -specialize (pop_ptlz_pop_stack_compat _ _ _ (Cons_ptl p ptl) ptlz _ H0). -destruct (pop_ptlz (Cons_ptl p ptl) ptlz) as [word [sem []]]. -destruct (compare_eqdec (last_symb_of_non_init_state state) head_symbolt); intuition. -eapply JMeq_sym, JMeq_trans, JMeq_sym, JMeq_eq in H1; [|apply JMeq_eqrect with (e:=e)]. -rewrite <- H1. -simpl in pop_ptlz_pop_stack_compat. -erewrite proof_irrelevance with (p1:=pop_ptlz_pop_stack_compat_converter _ _ _ _ _). -apply pop_ptlz_pop_stack_compat. -Transparent AlphabetComparable AlphabetComparableUsualEq. -Qed. - -Definition next_ptd (ptd:pt_dot): option pt_dot := - match ptd with - | Shift_ptd term sem ptl ptlz => - Some (build_pt_dot ptl (Cons_ptl_ptlz (Terminal_pt term sem) ptlz)) - | Reduce_ptd ptlz => - let 'existT _ _ (existT _ _ (ptz, pt)) := pop_ptlz Nil_ptl ptlz in - match ptz in pt_zipper sym _ _ return parse_tree sym _ _ -> _ with - | Top_ptz => fun pt => None - | Cons_ptl_ptz ptl ptlz' => - fun pt => Some (build_pt_dot ptl (Cons_ptl_ptlz pt ptlz')) - end pt - end. - -Lemma next_ptd_cost: - forall ptd, - match next_ptd ptd with - | None => ptd_cost ptd = 0 - | Some ptd' => ptd_cost ptd = S (ptd_cost ptd') - end. -Proof. -destruct ptd. unfold next_ptd. -pose proof (pop_ptlz_cost _ _ _ Nil_ptl p). -destruct (pop_ptlz Nil_ptl p) as [word[sem[[]]]]. -assumption. -rewrite build_pt_dot_cost. -assumption. -simpl; rewrite build_pt_dot_cost; reflexivity. -Qed. - -Lemma reduce_step_next_ptd: - forall (ptlz:ptl_zipper [] [] ()) (stack:stack), - ptlz_stack_compat ptlz stack -> - match reduce_step init stack (ptlz_prod ptlz) (ptlz_buffer ptlz) with - | OK Fail_sr => - False - | OK (Accept_sr sem buffer) => - sem = full_sem /\ buffer = buffer_end /\ next_ptd (Reduce_ptd ptlz) = None - | OK (Progress_sr stack buffer) => - match next_ptd (Reduce_ptd ptlz) with - | None => False - | Some ptd => - ptd_stack_compat ptd stack /\ buffer = ptd_buffer ptd - end - | Err => - True - end. -Proof. -intros. -unfold reduce_step, next_ptd. -apply pop_ptlz_pop_stack_compat with (ptl:=Nil_ptl) in H. -pose proof (pop_ptlz_buffer _ _ _ Nil_ptl ptlz). -destruct (pop_ptlz Nil_ptl ptlz) as [word [sem [ptz pt]]]. -rewrite H0; clear H0. -revert H. -match goal with - |- match ?p1 with Err => _ | OK _ => _ end -> match bind2 ?p2 _ with Err => _ | OK _ => _ end => - replace p1 with p2; [destruct p2 as [|[]]; intros|] -end. -assumption. -simpl. -destruct H; subst. -generalize dependent s0. -generalize (prod_lhs (ptlz_prod ptlz)); clear ptlz stack0. -dependent destruction ptz; intros. -simpl in H; subst; simpl. -pose proof start_goto; unfold Valid.start_goto in H; rewrite H. -destruct (compare_eqdec (start_nt init) (start_nt init)); intuition. -apply JMeq_eq, JMeq_eqrect with (P:=fun nt => symbol_semantic_type (NT nt)). -pose proof (ptlz_stack_compat_ptlz_state_compat _ _ _ _ _ H). -apply non_terminal_goto in H0. -destruct (goto_table (state_of_stack init s) n) as [[]|]; intuition. -apply ptd_stack_compat_build_pt_dot; simpl; intuition. -symmetry; apply JMeq_eqrect with (P:=symbol_semantic_type). -symmetry; apply build_pt_dot_buffer. -destruct s; intuition. -simpl in H; apply ptlz_stack_compat_ptlz_state_compat in H. -destruct (H0 _ _ _ H eq_refl). -generalize (pop_ptlz_pop_stack_compat_converter (symbol_semantic_type (NT (prod_lhs (ptlz_prod ptlz)))) _ _ _ ptlz). -pose proof (ptlz_past_ptlz_prod _ _ _ ptlz); simpl in H. -rewrite H; clear H. -intro; f_equal; simpl. -apply JMeq_eq. -etransitivity. -apply JMeq_eqrect with (P:=fun x => x). -symmetry. -apply JMeq_eqrect with (P:=fun x => x). -Qed. - -Lemma step_next_ptd: - forall (ptd:pt_dot) (stack:stack), - ptd_stack_compat ptd stack -> - match step init stack (ptd_buffer ptd) with - | OK Fail_sr => - False - | OK (Accept_sr sem buffer) => - sem = full_sem /\ buffer = buffer_end /\ next_ptd ptd = None - | OK (Progress_sr stack buffer) => - match next_ptd ptd with - | None => False - | Some ptd => - ptd_stack_compat ptd stack /\ buffer = ptd_buffer ptd - end - | Err => - True - end. -Proof. -intros. -destruct ptd. -pose proof (ptlz_stack_compat_ptlz_state_compat _ _ _ _ _ H). -apply end_reduce in H0. -unfold step. -destruct (action_table (state_of_stack init stack0)). -rewrite H0 by reflexivity. -apply reduce_step_next_ptd; assumption. -simpl; destruct (Streams.hd (ptlz_buffer p)); simpl in H0. -destruct (l x); intuition; rewrite H1. -apply reduce_step_next_ptd; assumption. -pose proof (ptlz_stack_compat_ptlz_state_compat _ _ _ _ _ H). -apply terminal_shift in H0. -unfold step. -destruct (action_table (state_of_stack init stack0)); intuition. -simpl; destruct (Streams.hd (ptlz_buffer p0)) as [] eqn:?. -destruct (l term); intuition. -apply ptd_stack_compat_build_pt_dot; simpl; intuition. -unfold ptlz_state_compat; simpl; destruct Heqt; assumption. -symmetry; apply JMeq_eqrect with (P:=symbol_semantic_type). -rewrite build_pt_dot_buffer; reflexivity. -Qed. - -Lemma parse_fix_complete: - forall (ptd:pt_dot) (stack:stack) (n_steps:nat), - ptd_stack_compat ptd stack -> - match parse_fix init stack (ptd_buffer ptd) n_steps with - | OK (Parsed_pr sem_res buffer_end_res) => - sem_res = full_sem /\ buffer_end_res = buffer_end /\ - S (ptd_cost ptd) <= n_steps - | OK Fail_pr => False - | OK Timeout_pr => n_steps < S (ptd_cost ptd) - | Err => True - end. -Proof. -fix parse_fix_complete 3. -destruct n_steps; intros; simpl. -apply Nat.lt_0_succ. -apply step_next_ptd in H. -pose proof (next_ptd_cost ptd). -destruct (step init stack0 (ptd_buffer ptd)) as [|[]]; simpl; intuition. -rewrite H3 in H0; rewrite H0. -apply le_n_S, Nat.le_0_l. -destruct (next_ptd ptd); intuition; subst. -eapply parse_fix_complete with (n_steps:=n_steps) in H1. -rewrite H0. -destruct (parse_fix init s (ptd_buffer p) n_steps) as [|[]]; try assumption. -apply lt_n_S; assumption. -destruct H1 as [H1 []]; split; [|split]; try assumption. -apply le_n_S; assumption. -Qed. - -Variable full_pt: parse_tree (NT (start_nt init)) full_word full_sem. - -Definition init_ptd := - match full_pt in parse_tree head full_word full_sem return - pt_zipper head full_word full_sem -> - match head return Type with | T _ => unit | NT _ => pt_dot end - with - | Terminal_pt _ _ => fun _ => () - | Non_terminal_pt ptl => - fun top => build_pt_dot ptl (Non_terminal_pt_ptlz top) - end Top_ptz. - -Lemma init_ptd_compat: - ptd_stack_compat init_ptd []. -Proof. -unfold init_ptd. -assert (ptz_stack_compat Top_ptz []) by reflexivity. -pose proof (start_future init); revert H0. -generalize dependent Top_ptz. -generalize dependent full_word. -generalize full_sem. -generalize (start_nt init). -dependent destruction full_pt0. -intros. -apply ptd_stack_compat_build_pt_dot; simpl; intuition. -apply H0; reflexivity. -Qed. - -Lemma init_ptd_cost: - S (ptd_cost init_ptd) = pt_size full_pt. -Proof. -unfold init_ptd. -assert (ptz_cost Top_ptz = 0) by reflexivity. -generalize dependent Top_ptz. -generalize dependent full_word. -generalize full_sem. -generalize (start_nt init). -dependent destruction full_pt0. -intros. -rewrite build_pt_dot_cost; simpl. -rewrite H, Nat.add_0_r; reflexivity. -Qed. - -Lemma init_ptd_buffer: - ptd_buffer init_ptd = full_word ++ buffer_end. -Proof. -unfold init_ptd. -assert (ptz_buffer Top_ptz = buffer_end) by reflexivity. -generalize dependent Top_ptz. -generalize dependent full_word. -generalize full_sem. -generalize (start_nt init). -dependent destruction full_pt0. -intros. -rewrite build_pt_dot_buffer; simpl. -rewrite H; reflexivity. -Qed. - -Theorem parse_complete n_steps: - match parse init (full_word ++ buffer_end) n_steps with - | OK (Parsed_pr sem_res buffer_end_res) => - sem_res = full_sem /\ buffer_end_res = buffer_end /\ - pt_size full_pt <= n_steps - | OK Fail_pr => False - | OK Timeout_pr => n_steps < pt_size full_pt - | Err => True - end. -Proof. -pose proof (parse_fix_complete init_ptd [] n_steps init_ptd_compat). -rewrite init_ptd_buffer, init_ptd_cost in H. -apply H. -Qed. - -End Completeness_Proof. - -End Make. diff --git a/cparser/MenhirLib/Interpreter_correct.v b/cparser/MenhirLib/Interpreter_correct.v deleted file mode 100644 index 1263d4e3..00000000 --- a/cparser/MenhirLib/Interpreter_correct.v +++ /dev/null @@ -1,228 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import Streams. -Require Import List. -Require Import Syntax. -Require Import Equality. -Require Import Alphabet. -Require Grammar. -Require Automaton. -Require Interpreter. - -Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A). - -(** * Correctness of the interpreter **) - -(** We prove that, in any case, if the interpreter accepts returning a - semantic value, then this is a semantic value of the input **) - -Section Init. - -Variable init:initstate. - -(** [word_has_stack_semantics] relates a word with a state, stating that the - word is a concatenation of words that have the semantic values stored in - the stack. **) -Inductive word_has_stack_semantics: - forall (word:list token) (stack:stack), Prop := - | Nil_stack_whss: word_has_stack_semantics [] [] - | Cons_stack_whss: - forall (wordq:list token) (stackq:stack), - word_has_stack_semantics wordq stackq -> - - forall (wordt:list token) (s:noninitstate) - (semantic_valuet:_), - inhabited (parse_tree (last_symb_of_non_init_state s) wordt semantic_valuet) -> - - word_has_stack_semantics - (wordq++wordt) (existT noninitstate_type s semantic_valuet::stackq). - -Lemma pop_invariant_converter: - forall A symbols_to_pop symbols_popped, - arrows_left (map symbol_semantic_type (rev_append symbols_to_pop symbols_popped)) A = - arrows_left (map symbol_semantic_type symbols_popped) - (arrows_right A (map symbol_semantic_type symbols_to_pop)). -Proof. -intros. -unfold arrows_right, arrows_left. -rewrite rev_append_rev, map_app, map_rev, fold_left_app. -apply f_equal. -rewrite <- fold_left_rev_right, rev_involutive. -reflexivity. -Qed. - -(** [pop] preserves the invariant **) -Lemma pop_invariant: - forall (symbols_to_pop symbols_popped:list symbol) - (stack_cur:stack) - (A:Type) - (action:arrows_left (map symbol_semantic_type (rev_append symbols_to_pop symbols_popped)) A), - forall word_stack word_popped, - forall sem_popped, - word_has_stack_semantics word_stack stack_cur -> - inhabited (parse_tree_list symbols_popped word_popped sem_popped) -> - let action' := eq_rect _ (fun x=>x) action _ (pop_invariant_converter _ _ _) in - match pop symbols_to_pop stack_cur (uncurry action' sem_popped) with - | OK (stack_new, sem) => - exists word1res word2res sem_full, - (word_stack = word1res ++ word2res)%list /\ - word_has_stack_semantics word1res stack_new /\ - sem = uncurry action sem_full /\ - inhabited ( - parse_tree_list (rev_append symbols_to_pop symbols_popped) (word2res++word_popped) sem_full) - | Err => True - end. -Proof. -induction symbols_to_pop; intros; unfold pop; fold pop. -exists word_stack, ([]:list token), sem_popped; intuition. -f_equal. -apply JMeq_eq, JMeq_eqrect with (P:=(fun x => x)). -destruct stack_cur as [|[]]; eauto. -destruct (compare_eqdec (last_symb_of_non_init_state x) a); eauto. -destruct e; simpl. -dependent destruction H. -destruct H0, H1. apply (Cons_ptl X), inhabits in X0. -specialize (IHsymbols_to_pop _ _ _ action0 _ _ _ H X0). -match goal with - IHsymbols_to_pop:match ?p1 with Err => _ | OK _ => _ end |- match ?p2 with Err => _ | OK _ => _ end => - replace p2 with p1; [destruct p1 as [|[]]|]; intuition -end. -destruct IHsymbols_to_pop as [word1res [word2res [sem_full []]]]; intuition; subst. -exists word1res. -eexists. -exists sem_full. -intuition. -rewrite <- app_assoc; assumption. -simpl; f_equal; f_equal. -apply JMeq_eq. -etransitivity. -apply JMeq_eqrect with (P:=(fun x => x)). -symmetry. -apply JMeq_eqrect with (P:=(fun x => x)). -Qed. - -(** [reduce_step] preserves the invariant **) -Lemma reduce_step_invariant (stack:stack) (prod:production): - forall word buffer, word_has_stack_semantics word stack -> - match reduce_step init stack prod buffer with - | OK (Accept_sr sem buffer_new) => - buffer = buffer_new /\ - inhabited (parse_tree (NT (start_nt init)) word sem) - | OK (Progress_sr stack_new buffer_new) => - buffer = buffer_new /\ - word_has_stack_semantics word stack_new - | Err | OK Fail_sr => True - end. -Proof with eauto. -intros. -unfold reduce_step. -pose proof (pop_invariant (prod_rhs_rev prod) [] stack (symbol_semantic_type (NT (prod_lhs prod)))). -revert H0. -generalize (pop_invariant_converter (symbol_semantic_type (NT (prod_lhs prod))) (prod_rhs_rev prod) []). -rewrite <- rev_alt. -intros. -specialize (H0 (prod_action prod) _ [] () H (inhabits Nil_ptl)). -match goal with H0:let action' := ?a in _ |- _ => replace a with (prod_action' prod) in H0 end. -simpl in H0. -destruct (pop (prod_rhs_rev prod) stack (prod_action' prod)) as [|[]]; intuition. -destruct H0 as [word1res [word2res [sem_full]]]; intuition. -destruct H4; apply Non_terminal_pt, inhabits in X. -match goal with X:inhabited (parse_tree _ _ ?u) |- _ => replace u with s0 in X end. -clear sem_full H2. -simpl; destruct (goto_table (state_of_stack init s) (prod_lhs prod)) as [[]|]; intuition; subst. -rewrite app_nil_r in X; revert s0 X; rewrite e0; intro; simpl. -constructor... -destruct s; intuition. -destruct (compare_eqdec (prod_lhs prod) (start_nt init)); intuition. -rewrite app_nil_r in X. -rewrite <- e0. -inversion H0. -destruct X; constructor... -apply JMeq_eq. -etransitivity. -apply JMeq_eqrect with (P:=(fun x => x)). -symmetry. -apply JMeq_eqrect with (P:=(fun x => x)). -Qed. - -(** [step] preserves the invariant **) -Lemma step_invariant (stack:stack) (buffer:Stream token): - forall buffer_tmp, - (exists word_old, - buffer = word_old ++ buffer_tmp /\ - word_has_stack_semantics word_old stack) -> - match step init stack buffer_tmp with - | OK (Accept_sr sem buffer_new) => - exists word_new, - buffer = word_new ++ buffer_new /\ - inhabited (parse_tree (NT (start_nt init)) word_new sem) - | OK (Progress_sr stack_new buffer_new) => - exists word_new, - buffer = word_new ++ buffer_new /\ - word_has_stack_semantics word_new stack_new - | Err | OK Fail_sr => True - end. -Proof with eauto. -intros. -destruct H, H. -unfold step. -destruct (action_table (state_of_stack init stack)). -pose proof (reduce_step_invariant stack p x buffer_tmp). -destruct (reduce_step init stack p buffer_tmp) as [|[]]; intuition; subst... -destruct buffer_tmp. -unfold Streams.hd. -destruct t. -destruct (l x0); intuition. -exists (x ++ [existT (fun t => symbol_semantic_type (T t)) x0 s])%list. -split. -now rewrite <- app_str_app_assoc; intuition. -apply Cons_stack_whss; intuition. -destruct e; simpl. -now exact (inhabits (Terminal_pt _ _)). -match goal with |- (match reduce_step init stack p ?buff with Err => _ | OK _ => _ end) => - pose proof (reduce_step_invariant stack p x buff); - destruct (reduce_step init stack p buff) as [|[]]; intuition; subst -end... -Qed. - -(** The interpreter is correct : if it returns a semantic value, then the input - word has this semantic value. -**) -Theorem parse_correct buffer n_steps: - match parse init buffer n_steps with - | OK (Parsed_pr sem buffer_new) => - exists word_new, - buffer = word_new ++ buffer_new /\ - inhabited (parse_tree (NT (start_nt init)) word_new sem) - | _ => True - end. -Proof. -unfold parse. -assert (exists w, buffer = w ++ buffer /\ word_has_stack_semantics w []). -exists ([]:list token); intuition. -now apply Nil_stack_whss. -revert H. -generalize ([]:stack), buffer at 2 3. -induction n_steps; simpl; intuition. -pose proof (step_invariant _ _ _ H). -destruct (step init s buffer0); simpl; intuition. -destruct s0; intuition. -apply IHn_steps; intuition. -Qed. - -End Init. - -End Make. diff --git a/cparser/MenhirLib/Interpreter_safe.v b/cparser/MenhirLib/Interpreter_safe.v deleted file mode 100644 index a1aa35b8..00000000 --- a/cparser/MenhirLib/Interpreter_safe.v +++ /dev/null @@ -1,275 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import Streams. -Require Import Equality. -Require Import List. -Require Import Syntax. -Require Import Alphabet. -Require Grammar. -Require Automaton. -Require Validator_safe. -Require Interpreter. - -Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A). -Module Import Valid := Validator_safe.Make A. - -(** * A correct automaton does not crash **) - -Section Safety_proof. - -Hypothesis safe: safe. - -Proposition shift_head_symbs: shift_head_symbs. -Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed. -Proposition goto_head_symbs: goto_head_symbs. -Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed. -Proposition shift_past_state: shift_past_state. -Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed. -Proposition goto_past_state: goto_past_state. -Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed. -Proposition reduce_ok: reduce_ok. -Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed. - -(** We prove that a correct automaton won't crash : the interpreter will - not return [Err] **) - -Variable init : initstate. - -(** The stack of states of an automaton stack **) -Definition state_stack_of_stack (stack:stack) := - (List.map - (fun cell:sigT noninitstate_type => singleton_state_pred (projT1 cell)) - stack ++ [singleton_state_pred init])%list. - -(** The stack of symbols of an automaton stack **) -Definition symb_stack_of_stack (stack:stack) := - List.map - (fun cell:sigT noninitstate_type => last_symb_of_non_init_state (projT1 cell)) - stack. - -(** The stack invariant : it basically states that the assumptions on the - states are true. **) -Inductive stack_invariant: stack -> Prop := - | stack_invariant_constr: - forall stack, - prefix (head_symbs_of_state (state_of_stack init stack)) - (symb_stack_of_stack stack) -> - prefix_pred (head_states_of_state (state_of_stack init stack)) - (state_stack_of_stack stack) -> - stack_invariant_next stack -> - stack_invariant stack -with stack_invariant_next: stack -> Prop := - | stack_invariant_next_nil: - stack_invariant_next [] - | stack_invariant_next_cons: - forall state_cur st stack_rec, - stack_invariant stack_rec -> - stack_invariant_next (existT _ state_cur st::stack_rec). - -(** [pop] conserves the stack invariant and does not crash - under the assumption that we can pop at this place. - Moreover, after a pop, the top state of the stack is allowed. **) -Lemma pop_stack_invariant_conserved - (symbols_to_pop:list symbol) (stack_cur:stack) A action: - stack_invariant stack_cur -> - prefix symbols_to_pop (head_symbs_of_state (state_of_stack init stack_cur)) -> - match pop symbols_to_pop stack_cur (A:=A) action with - | OK (stack_new, _) => - stack_invariant stack_new /\ - state_valid_after_pop - (state_of_stack init stack_new) symbols_to_pop - (head_states_of_state (state_of_stack init stack_cur)) - | Err => False - end. -Proof with eauto. - intros. - pose proof H. - destruct H. - revert H H0 H1 H2 H3. - generalize (head_symbs_of_state (state_of_stack init stack0)). - generalize (head_states_of_state (state_of_stack init stack0)). - revert stack0 A action. - induction symbols_to_pop; intros. - - split... - destruct l; constructor. - inversion H2; subst. - specialize (H7 (state_of_stack init stack0)). - destruct (f2 (state_of_stack init stack0)) as [] eqn:? ... - destruct stack0 as [|[]]; simpl in *. - + inversion H6; subst. - unfold singleton_state_pred in Heqb0. - now rewrite compare_refl in Heqb0; discriminate. - + inversion H6; subst. - unfold singleton_state_pred in Heqb0. - now rewrite compare_refl in Heqb0; discriminate. - - destruct stack0 as [|[]]; unfold pop. - + inversion H0; subst. - now inversion H. - + fold pop. - destruct (compare_eqdec (last_symb_of_non_init_state x) a). - * inversion H0; subst. clear H0. - inversion H; subst. clear H. - dependent destruction H3; simpl. - assert (prefix_pred (List.tl l) (state_stack_of_stack stack0)). - unfold tl; destruct l; [constructor | inversion H2]... - pose proof H. destruct H3. - specialize (IHsymbols_to_pop stack0 A (action0 n) _ _ H4 H7 H H0 H6). - revert IHsymbols_to_pop. - fold (noninitstate_type x); generalize (pop symbols_to_pop stack0 (action0 n)). - destruct r as [|[]]; intuition... - destruct l; constructor... - * apply n0. - inversion H0; subst. - inversion H; subst... -Qed. - -(** [prefix] is associative **) -Lemma prefix_ass: - forall (l1 l2 l3:list symbol), prefix l1 l2 -> prefix l2 l3 -> prefix l1 l3. -Proof. -induction l1; intros. -constructor. -inversion H; subst. -inversion H0; subst. -constructor; eauto. -Qed. - -(** [prefix_pred] is associative **) -Lemma prefix_pred_ass: - forall (l1 l2 l3:list (state->bool)), - prefix_pred l1 l2 -> prefix_pred l2 l3 -> prefix_pred l1 l3. -Proof. -induction l1; intros. -constructor. -inversion H; subst. -inversion H0; subst. -constructor; eauto. -intro. -specialize (H3 x). -specialize (H4 x). -destruct (f0 x); simpl in *; intuition. -rewrite H4 in H3; intuition. -Qed. - -(** If we have the right to reduce at this state, then the stack invariant - is conserved by [reduce_step] and [reduce_step] does not crash. **) -Lemma reduce_step_stack_invariant_conserved stack prod buff: - stack_invariant stack -> - valid_for_reduce (state_of_stack init stack) prod -> - match reduce_step init stack prod buff with - | OK (Fail_sr | Accept_sr _ _) => True - | OK (Progress_sr stack_new _) => stack_invariant stack_new - | Err => False - end. -Proof with eauto. -unfold valid_for_reduce. -intuition. -unfold reduce_step. -pose proof (pop_stack_invariant_conserved (prod_rhs_rev prod) stack _ (prod_action' prod)). -destruct (pop (prod_rhs_rev prod) stack (prod_action' prod)) as [|[]]. -apply H0... -destruct H0... -pose proof (goto_head_symbs (state_of_stack init s) (prod_lhs prod)). -pose proof (goto_past_state (state_of_stack init s) (prod_lhs prod)). -unfold bind2. -destruct H0. -specialize (H2 _ H3)... -destruct (goto_table (state_of_stack init stack0) (prod_lhs prod)) as [[]|]. -constructor. -simpl. -constructor. -eapply prefix_ass... -unfold state_stack_of_stack; simpl; constructor. -intro; destruct (singleton_state_pred x x0); reflexivity. -eapply prefix_pred_ass... -constructor... -constructor... -destruct stack0 as [|[]]... -destruct (compare_eqdec (prod_lhs prod) (start_nt init))... -apply n, H2, eq_refl. -apply H2, eq_refl. -Qed. - -(** If the automaton is safe, then the stack invariant is conserved by - [step] and [step] does not crash. **) -Lemma step_stack_invariant_conserved (stack:stack) buffer: - stack_invariant stack -> - match step init stack buffer with - | OK (Fail_sr | Accept_sr _ _) => True - | OK (Progress_sr stack_new _) => stack_invariant stack_new - | Err => False - end. -Proof with eauto. -intro. -unfold step. -pose proof (shift_head_symbs (state_of_stack init stack)). -pose proof (shift_past_state (state_of_stack init stack)). -pose proof (reduce_ok (state_of_stack init stack)). -destruct (action_table (state_of_stack init stack)). -apply reduce_step_stack_invariant_conserved... -destruct buffer as [[]]; simpl. -specialize (H0 x); specialize (H1 x); specialize (H2 x). -destruct (l x)... -destruct H. -constructor. -unfold state_of_stack. -constructor. -eapply prefix_ass... -unfold state_stack_of_stack; simpl; constructor. -intro; destruct (singleton_state_pred s0 x0)... -eapply prefix_pred_ass... -constructor... -constructor... -apply reduce_step_stack_invariant_conserved... -Qed. - -(** If the automaton is safe, then it does not crash **) -Theorem parse_no_err buffer n_steps: - parse init buffer n_steps <> Err. -Proof with eauto. -unfold parse. -assert (stack_invariant []). -constructor. -constructor. -unfold state_stack_of_stack; simpl; constructor. -intro; destruct (singleton_state_pred init x)... -constructor. -constructor. -revert H. -generalize buffer ([]:stack). -induction n_steps; simpl. -now discriminate. -intros. -pose proof (step_stack_invariant_conserved s buffer0 H). -destruct (step init s buffer0) as [|[]]; simpl... -discriminate. -discriminate. -Qed. - -(** A version of [parse] that uses safeness in order to return a - [parse_result], and not a [result parse_result] : we have proven that - parsing does not return [Err]. **) -Definition parse_with_safe (buffer:Stream token) (n_steps:nat): - parse_result init. -Proof with eauto. -pose proof (parse_no_err buffer n_steps). -destruct (parse init buffer n_steps)... -congruence. -Defined. - -End Safety_proof. - -End Make. diff --git a/cparser/MenhirLib/Main.v b/cparser/MenhirLib/Main.v deleted file mode 100644 index 1a17e988..00000000 --- a/cparser/MenhirLib/Main.v +++ /dev/null @@ -1,92 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Grammar. -Require Automaton. -Require Interpreter_safe. -Require Interpreter_correct. -Require Interpreter_complete. -Require Import Syntax. - -Module Make(Export Aut:Automaton.T). -Export Aut.Gram. -Export Aut.GramDefs. - -Module Import Inter := Interpreter.Make Aut. -Module Safe := Interpreter_safe.Make Aut Inter. -Module Correct := Interpreter_correct.Make Aut Inter. -Module Complete := Interpreter_complete.Make Aut Inter. - -Definition complete_validator:unit->bool := Complete.Valid.is_complete. -Definition safe_validator:unit->bool := Safe.Valid.is_safe. -Definition parse (safe:safe_validator ()=true) init n_steps buffer : parse_result init:= - Safe.parse_with_safe (Safe.Valid.is_safe_correct safe) init buffer n_steps. - -(** Correction theorem. **) -Theorem parse_correct - (safe:safe_validator ()= true) init n_steps buffer: - match parse safe init n_steps buffer with - | Parsed_pr sem buffer_new => - exists word, - buffer = word ++ buffer_new /\ inhabited (parse_tree (NT (start_nt init)) word sem) - | _ => True - end. -Proof. -unfold parse, Safe.parse_with_safe. -pose proof (Correct.parse_correct init buffer n_steps). -generalize (Safe.parse_no_err (Safe.Valid.is_safe_correct safe) init buffer n_steps). -destruct (Inter.parse init buffer n_steps); intros. -now destruct (n (eq_refl _)). -now destruct p; trivial. -Qed. - -(** Completeness theorem. **) -Theorem parse_complete - (safe:safe_validator () = true) init n_steps word buffer_end sem: - complete_validator () = true -> - forall tree:parse_tree (NT (start_nt init)) word sem, - match parse safe init n_steps (word ++ buffer_end) with - | Fail_pr => False - | Parsed_pr sem_res buffer_end_res => - sem_res = sem /\ buffer_end_res = buffer_end /\ pt_size tree <= n_steps - | Timeout_pr => n_steps < pt_size tree - end. -Proof. -intros. -unfold parse, Safe.parse_with_safe. -pose proof (Complete.parse_complete (Complete.Valid.is_complete_correct H) init _ buffer_end _ tree n_steps). -generalize (Safe.parse_no_err (Safe.Valid.is_safe_correct safe) init (word ++ buffer_end) n_steps). -destruct (Inter.parse init (word ++ buffer_end) n_steps); intros. -now destruct (n eq_refl). -now exact H0. -Qed. - -(** Unambiguity theorem. **) -Theorem unambiguity: - safe_validator () = true -> complete_validator () = true -> inhabited token -> - forall init word, - forall sem1 (tree1:parse_tree (NT (start_nt init)) word sem1), - forall sem2 (tree2:parse_tree (NT (start_nt init)) word sem2), - sem1 = sem2. -Proof. -intros. -destruct H1. -pose proof (parse_complete H init (pt_size tree1) word (Streams.const X) sem1) H0 tree1. -pose proof (parse_complete H init (pt_size tree1) word (Streams.const X) sem2) H0 tree2. -destruct (parse H init (pt_size tree1) (word ++ Streams.const X)); intuition. -rewrite <- H3, H1; reflexivity. -Qed. - -End Make. diff --git a/cparser/MenhirLib/Tuples.v b/cparser/MenhirLib/Tuples.v deleted file mode 100644 index 3fd2ec03..00000000 --- a/cparser/MenhirLib/Tuples.v +++ /dev/null @@ -1,49 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import List. -Require Import Coq.Program.Syntax. -Require Import Equality. - -(** A curryfied function with multiple parameters **) -Definition arrows_left: list Type -> Type -> Type := - fold_left (fun A B => B -> A). - -(** A curryfied function with multiple parameters **) -Definition arrows_right: Type -> list Type -> Type := - fold_right (fun A B => A -> B). - -(** A tuple is a heterogeneous list. For convenience, we use pairs. **) -Fixpoint tuple (types : list Type) : Type := - match types with - | nil => unit - | t::q => prod t (tuple q) - end. - -Fixpoint uncurry {args:list Type} {res:Type}: - arrows_left args res -> tuple args -> res := - match args return forall res, arrows_left args res -> tuple args -> res with - | [] => fun _ f _ => f - | t::q => fun res f p => let (d, t) := p in - (@uncurry q _ f t) d - end res. - -Lemma JMeq_eqrect: - forall (U:Type) (a b:U) (P:U -> Type) (x:P a) (e:a=b), - eq_rect a P x b e ~= x. -Proof. -destruct e. -reflexivity. -Qed. diff --git a/cparser/MenhirLib/Validator_complete.v b/cparser/MenhirLib/Validator_complete.v deleted file mode 100644 index a9823278..00000000 --- a/cparser/MenhirLib/Validator_complete.v +++ /dev/null @@ -1,542 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Automaton. -Require Import Alphabet. -Require Import List. -Require Import Syntax. - -Module Make(Import A:Automaton.T). - -(** We instantiate some sets/map. **) -Module TerminalComparableM <: ComparableM. - Definition t := terminal. - Instance tComparable : Comparable t := _. -End TerminalComparableM. -Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM. -Module StateProdPosComparableM <: ComparableM. - Definition t := (state*production*nat)%type. - Instance tComparable : Comparable t := _. -End StateProdPosComparableM. -Module StateProdPosOrderedType := - OrderedType_from_ComparableM StateProdPosComparableM. - -Module TerminalSet := FSetAVL.Make TerminalOrderedType. -Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType. - -(** Nullable predicate for symbols and list of symbols. **) -Definition nullable_symb (symbol:symbol) := - match symbol with - | NT nt => nullable_nterm nt - | _ => false - end. - -Definition nullable_word (word:list symbol) := - forallb nullable_symb word. - -(** First predicate for non terminal, symbols and list of symbols, given as FSets. **) -Definition first_nterm_set (nterm:nonterminal) := - fold_left (fun acc t => TerminalSet.add t acc) - (first_nterm nterm) TerminalSet.empty. - -Definition first_symb_set (symbol:symbol) := - match symbol with - | NT nt => first_nterm_set nt - | T t => TerminalSet.singleton t - end. - -Fixpoint first_word_set (word:list symbol) := - match word with - | [] => TerminalSet.empty - | t::q => - if nullable_symb t then - TerminalSet.union (first_symb_set t) (first_word_set q) - else - first_symb_set t - end. - -(** Small helper for finding the part of an item that is after the dot. **) -Definition future_of_prod prod dot_pos : list symbol := - (fix loop n lst := - match n with - | O => lst - | S x => match loop x lst with [] => [] | _::q => q end - end) - dot_pos (rev' (prod_rhs_rev prod)). - -(** We build a fast map to store all the items of all the states. **) -Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t := - fold_left (fun acc state => - fold_left (fun acc item => - let key := (state, prod_item item, dot_pos_item item) in - let data := fold_left (fun acc t => TerminalSet.add t acc) - (lookaheads_item item) TerminalSet.empty - in - let old := - match StateProdPosMap.find key acc with - | Some x => x | None => TerminalSet.empty - end - in - StateProdPosMap.add key (TerminalSet.union data old) acc - ) (items_of_state state) acc - ) all_list (StateProdPosMap.empty TerminalSet.t). - -(** Accessor. **) -Definition find_items_map items_map state prod dot_pos : TerminalSet.t := - match StateProdPosMap.find (state, prod, dot_pos) items_map with - | None => TerminalSet.empty - | Some x => x - end. - -Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) := - exists dot_pos:nat, - fut = future_of_prod prod dot_pos /\ - TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos). - -(** Iterator over items. **) -Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:= - StateProdPosMap.fold (fun key set acc => - match key with (st, p, pos) => (acc && P st p pos set)%bool end - ) items_map true. - -Lemma forallb_items_spec : - forall p, forallb_items (items_map ()) p = true -> - forall st prod fut lookahead, state_has_future st prod fut lookahead -> - forall P:state -> production -> list symbol -> terminal -> Prop, - (forall st prod pos set lookahead, - TerminalSet.In lookahead set -> p st prod pos set = true -> - P st prod (future_of_prod prod pos) lookahead) -> - P st prod fut lookahead. -Proof. -intros. -unfold forallb_items in H. -rewrite StateProdPosMap.fold_1 in H. -destruct H0; destruct H0. -specialize (H1 st prod x _ _ H2). -destruct H0. -apply H1. -unfold find_items_map in *. -pose proof (@StateProdPosMap.find_2 _ (items_map ()) (st, prod, x)). -destruct (StateProdPosMap.find (st, prod, x) (items_map ())); [ |destruct (TerminalSet.empty_1 H2)]. -specialize (H0 _ (eq_refl _)). -pose proof (StateProdPosMap.elements_1 H0). -revert H. -generalize true at 1. -induction H3. -destruct H. -destruct y. -simpl in H3; destruct H3. -pose proof (compare_eq (st, prod, x) k H). -destruct H3. -simpl. -generalize (p st prod x t). -induction l; simpl; intros. -rewrite Bool.andb_true_iff in H3. -intuition. -destruct a; destruct k; destruct p0. -simpl in H3. -replace (b0 && b && p s p0 n t0)%bool with (b0 && p s p0 n t0 && b)%bool in H3. -apply (IHl _ _ H3). -destruct b, b0, (p s p0 n t0); reflexivity. -intro. -apply IHInA. -Qed. - -(** * Validation for completeness **) - -(** The nullable predicate is a fixpoint : it is correct. **) -Definition nullable_stable:= - forall p:production, - nullable_word (rev (prod_rhs_rev p)) = true -> - nullable_nterm (prod_lhs p) = true. - -Definition is_nullable_stable (_:unit) := - forallb (fun p:production => - implb (nullable_word (rev' (prod_rhs_rev p))) (nullable_nterm (prod_lhs p))) - all_list. - -Property is_nullable_stable_correct : - is_nullable_stable () = true -> nullable_stable. -Proof. -unfold is_nullable_stable, nullable_stable. -intros. -rewrite forallb_forall in H. -specialize (H p (all_list_forall p)). -unfold rev' in H; rewrite <- rev_alt in H. -rewrite H0 in H; intuition. -Qed. - -(** The first predicate is a fixpoint : it is correct. **) -Definition first_stable:= - forall (p:production), - TerminalSet.Subset (first_word_set (rev (prod_rhs_rev p))) - (first_nterm_set (prod_lhs p)). - -Definition is_first_stable (_:unit) := - forallb (fun p:production => - TerminalSet.subset (first_word_set (rev' (prod_rhs_rev p))) - (first_nterm_set (prod_lhs p))) - all_list. - -Property is_first_stable_correct : - is_first_stable () = true -> first_stable. -Proof. -unfold is_first_stable, first_stable. -intros. -rewrite forallb_forall in H. -specialize (H p (all_list_forall p)). -unfold rev' in H; rewrite <- rev_alt in H. -apply TerminalSet.subset_2; intuition. -Qed. - -(** The initial state has all the S=>.u items, where S is the start non-terminal **) -Definition start_future := - forall (init:initstate) (t:terminal) (p:production), - prod_lhs p = start_nt init -> - state_has_future init p (rev (prod_rhs_rev p)) t. - -Definition is_start_future items_map := - forallb (fun init => - forallb (fun prod => - if compare_eqb (prod_lhs prod) (start_nt init) then - let lookaheads := find_items_map items_map init prod 0 in - forallb (fun t => TerminalSet.mem t lookaheads) all_list - else - true) all_list) all_list. - -Property is_start_future_correct : - is_start_future (items_map ()) = true -> start_future. -Proof. -unfold is_start_future, start_future. -intros. -rewrite forallb_forall in H. -specialize (H init (all_list_forall _)). -rewrite forallb_forall in H. -specialize (H p (all_list_forall _)). -rewrite <- compare_eqb_iff in H0. -rewrite H0 in H. -rewrite forallb_forall in H. -specialize (H t (all_list_forall _)). -exists 0. -split. -apply rev_alt. -apply TerminalSet.mem_2; eauto. -Qed. - -(** If a state contains an item of the form A->_.av[[b]], where a is a - terminal, then reading an a does a [Shift_act], to a state containing - an item of the form A->_.v[[b]]. **) -Definition terminal_shift := - forall (s1:state) prod fut lookahead, - state_has_future s1 prod fut lookahead -> - match fut with - | T t::q => - match action_table s1 with - | Lookahead_act awp => - match awp t with - | Shift_act s2 _ => - state_has_future s2 prod q lookahead - | _ => False - end - | _ => False - end - | _ => True - end. - -Definition is_terminal_shift items_map := - forallb_items items_map (fun s1 prod pos lset => - match future_of_prod prod pos with - | T t::_ => - match action_table s1 with - | Lookahead_act awp => - match awp t with - | Shift_act s2 _ => - TerminalSet.subset lset (find_items_map items_map s2 prod (S pos)) - | _ => false - end - | _ => false - end - | _ => true - end). - -Property is_terminal_shift_correct : - is_terminal_shift (items_map ()) = true -> terminal_shift. -Proof. -unfold is_terminal_shift, terminal_shift. -intros. -apply (forallb_items_spec _ H _ _ _ _ H0 (fun _ _ fut look => _)). -intros. -destruct (future_of_prod prod0 pos) as [|[]] eqn:?; intuition. -destruct (action_table st); intuition. -destruct (l0 t); intuition. -exists (S pos). -split. -unfold future_of_prod in *. -rewrite Heql; reflexivity. -apply (TerminalSet.subset_2 H2); intuition. -Qed. - -(** If a state contains an item of the form A->_.[[a]], then either we do a - [Default_reduce_act] of the corresponding production, either a is a - terminal (ie. there is a lookahead terminal), and reading a does a - [Reduce_act] of the corresponding production. **) -Definition end_reduce := - forall (s:state) prod fut lookahead, - state_has_future s prod fut lookahead -> - fut = [] -> - match action_table s with - | Default_reduce_act p => p = prod - | Lookahead_act awt => - match awt lookahead with - | Reduce_act p => p = prod - | _ => False - end - end. - -Definition is_end_reduce items_map := - forallb_items items_map (fun s prod pos lset => - match future_of_prod prod pos with - | [] => - match action_table s with - | Default_reduce_act p => compare_eqb p prod - | Lookahead_act awt => - TerminalSet.fold (fun lookahead acc => - match awt lookahead with - | Reduce_act p => (acc && compare_eqb p prod)%bool - | _ => false - end) lset true - end - | _ => true - end). - -Property is_end_reduce_correct : - is_end_reduce (items_map ()) = true -> end_reduce. -Proof. -unfold is_end_reduce, end_reduce. -intros. -revert H1. -apply (forallb_items_spec _ H _ _ _ _ H0 (fun st prod fut look => _ -> - match action_table st with - | Default_reduce_act p => p = prod - | _ => _ - end)). -intros. -rewrite H3 in H2. -destruct (action_table st); intuition. -apply compare_eqb_iff; intuition. -rewrite TerminalSet.fold_1 in H2. -revert H2. -generalize true at 1. -pose proof (TerminalSet.elements_1 H1). -induction H2. -pose proof (compare_eq _ _ H2). -destruct H4. -simpl. -assert (fold_left - (fun (a : bool) (e : TerminalSet.elt) => - match l e with - | Shift_act _ _ => false - | Reduce_act p => (a && compare_eqb p prod0)%bool - | Fail_act => false - end) l0 false = true -> False). -induction l0; intuition. -apply IHl0. -simpl in H4. -destruct (l a); intuition. -destruct (l lookahead0); intuition. -apply compare_eqb_iff. -destruct (compare_eqb p prod0); intuition. -destruct b; intuition. -simpl; intros. -eapply IHInA; eauto. -Qed. - -(** If a state contains an item of the form A->_.Bv[[b]], where B is a - non terminal, then the goto table says we have to go to a state containing - an item of the form A->_.v[[b]]. **) -Definition non_terminal_goto := - forall (s1:state) prod fut lookahead, - state_has_future s1 prod fut lookahead -> - match fut with - | NT nt::q => - match goto_table s1 nt with - | Some (exist _ s2 _) => - state_has_future s2 prod q lookahead - | None => - forall prod fut lookahead, - state_has_future s1 prod fut lookahead -> - match fut with - | NT nt'::_ => nt <> nt' - | _ => True - end - end - | _ => True - end. - -Definition is_non_terminal_goto items_map := - forallb_items items_map (fun s1 prod pos lset => - match future_of_prod prod pos with - | NT nt::_ => - match goto_table s1 nt with - | Some (exist _ s2 _) => - TerminalSet.subset lset (find_items_map items_map s2 prod (S pos)) - | None => forallb_items items_map (fun s1' prod' pos' _ => - (implb (compare_eqb s1 s1') - match future_of_prod prod' pos' with - | NT nt' :: _ => negb (compare_eqb nt nt') - | _ => true - end)%bool) - end - | _ => true - end). - -Property is_non_terminal_goto_correct : - is_non_terminal_goto (items_map ()) = true -> non_terminal_goto. -Proof. -unfold is_non_terminal_goto, non_terminal_goto. -intros. -apply (forallb_items_spec _ H _ _ _ _ H0 (fun st prod fut look => - match fut with - | NT nt :: q => - match goto_table st nt with - | Some _ => _ - | None => - forall p f l, state_has_future st p f l -> (_:Prop) - end - | _ => _ - end)). -intros. -destruct (future_of_prod prod0 pos) as [|[]] eqn:?; intuition. -destruct (goto_table st n) as [[]|]. -exists (S pos). -split. -unfold future_of_prod in *. -rewrite Heql; reflexivity. -apply (TerminalSet.subset_2 H2); intuition. -intros. -remember st in H2; revert Heqs. -apply (forallb_items_spec _ H2 _ _ _ _ H3 (fun st' prod fut look => s = st' -> match fut return Prop with [] => _ | _ => _ end)); intros. -rewrite <- compare_eqb_iff in H6; rewrite H6 in H5. -destruct (future_of_prod prod1 pos0) as [|[]]; intuition. -rewrite <- compare_eqb_iff in H7; rewrite H7 in H5. -discriminate. -Qed. - -Definition start_goto := - forall (init:initstate), goto_table init (start_nt init) = None. - -Definition is_start_goto (_:unit) := - forallb (fun (init:initstate) => - match goto_table init (start_nt init) with - | Some _ => false - | None => true - end) all_list. - -Definition is_start_goto_correct: - is_start_goto () = true -> start_goto. -Proof. -unfold is_start_goto, start_goto. -rewrite forallb_forall. -intros. -specialize (H init (all_list_forall _)). -destruct (goto_table init (start_nt init)); congruence. -Qed. - -(** Closure property of item sets : if a state contains an item of the form - A->_.Bv[[b]], then for each production B->u and each terminal a of - first(vb), the state contains an item of the form B->_.u[[a]] **) -Definition non_terminal_closed := - forall (s1:state) prod fut lookahead, - state_has_future s1 prod fut lookahead -> - match fut with - | NT nt::q => - forall (p:production) (lookahead2:terminal), - prod_lhs p = nt -> - TerminalSet.In lookahead2 (first_word_set q) \/ - lookahead2 = lookahead /\ nullable_word q = true -> - state_has_future s1 p (rev (prod_rhs_rev p)) lookahead2 - | _ => True - end. - -Definition is_non_terminal_closed items_map := - forallb_items items_map (fun s1 prod pos lset => - match future_of_prod prod pos with - | NT nt::q => - forallb (fun p => - if compare_eqb (prod_lhs p) nt then - let lookaheads := find_items_map items_map s1 p 0 in - (implb (nullable_word q) (TerminalSet.subset lset lookaheads)) && - TerminalSet.subset (first_word_set q) lookaheads - else true - )%bool all_list - | _ => true - end). - -Property is_non_terminal_closed_correct: - is_non_terminal_closed (items_map ()) = true -> non_terminal_closed. -Proof. -unfold is_non_terminal_closed, non_terminal_closed. -intros. -apply (forallb_items_spec _ H _ _ _ _ H0 (fun st prod fut look => - match fut with - | NT nt :: q => forall p l, _ -> _ -> state_has_future st _ _ _ - | _ => _ - end)). -intros. -destruct (future_of_prod prod0 pos); intuition. -destruct s; eauto; intros. -rewrite forallb_forall in H2. -specialize (H2 p (all_list_forall p)). -rewrite <- compare_eqb_iff in H3. -rewrite H3 in H2. -rewrite Bool.andb_true_iff in H2. -destruct H2. -exists 0. -split. -apply rev_alt. -destruct H4 as [|[]]; subst. -apply (TerminalSet.subset_2 H5); intuition. -rewrite H6 in H2. -apply (TerminalSet.subset_2 H2); intuition. -Qed. - -(** The automaton is complete **) -Definition complete := - nullable_stable /\ first_stable /\ start_future /\ terminal_shift - /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed. - -Definition is_complete (_:unit) := - let items_map := items_map () in - (is_nullable_stable () && is_first_stable () && is_start_future items_map && - is_terminal_shift items_map && is_end_reduce items_map && is_start_goto () && - is_non_terminal_goto items_map && is_non_terminal_closed items_map)%bool. - -Property is_complete_correct: - is_complete () = true -> complete. -Proof. -unfold is_complete, complete. -repeat rewrite Bool.andb_true_iff. -intuition. -apply is_nullable_stable_correct; assumption. -apply is_first_stable_correct; assumption. -apply is_start_future_correct; assumption. -apply is_terminal_shift_correct; assumption. -apply is_end_reduce_correct; assumption. -apply is_non_terminal_goto_correct; assumption. -apply is_start_goto_correct; assumption. -apply is_non_terminal_closed_correct; assumption. -Qed. - -End Make. diff --git a/cparser/MenhirLib/Validator_safe.v b/cparser/MenhirLib/Validator_safe.v deleted file mode 100644 index 183d661b..00000000 --- a/cparser/MenhirLib/Validator_safe.v +++ /dev/null @@ -1,414 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Automaton. -Require Import Alphabet. -Require Import List. -Require Import Syntax. - -Module Make(Import A:Automaton.T). - -(** The singleton predicate for states **) -Definition singleton_state_pred (state:state) := - (fun state' => match compare state state' with Eq => true |_ => false end). - -(** [past_state_of_non_init_state], extended for all states. **) -Definition past_state_of_state (state:state) := - match state with - | Init _ => [] - | Ninit nis => past_state_of_non_init_state nis - end. - -(** Concatenations of last and past **) -Definition head_symbs_of_state (state:state) := - match state with - | Init _ => [] - | Ninit s => - last_symb_of_non_init_state s::past_symb_of_non_init_state s - end. -Definition head_states_of_state (state:state) := - singleton_state_pred state::past_state_of_state state. - -(** * Validation for correctness **) - -(** Prefix predicate between two lists of symbols. **) -Inductive prefix: list symbol -> list symbol -> Prop := - | prefix_nil: forall l, prefix [] l - | prefix_cons: forall l1 l2 x, prefix l1 l2 -> prefix (x::l1) (x::l2). - -Fixpoint is_prefix (l1 l2:list symbol):= - match l1, l2 with - | [], _ => true - | t1::q1, t2::q2 => (compare_eqb t1 t2 && is_prefix q1 q2)%bool - | _::_, [] => false - end. - -Property is_prefix_correct (l1 l2:list symbol): - is_prefix l1 l2 = true -> prefix l1 l2. -Proof. -revert l2. -induction l1; intros. -apply prefix_nil. -unfold is_prefix in H. -destruct l2; intuition; try discriminate. -rewrite Bool.andb_true_iff in H. -destruct H. -rewrite compare_eqb_iff in H. -destruct H. -apply prefix_cons. -apply IHl1; intuition. -Qed. - -(** If we shift, then the known top symbols of the destination state is - a prefix of the known top symbols of the source state, with the new - symbol added. **) -Definition shift_head_symbs := - forall s, - match action_table s with - | Lookahead_act awp => - forall t, match awp t with - | Shift_act s2 _ => - prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s) - | _ => True - end - | _ => True - end. - -Definition is_shift_head_symbs (_:unit) := - forallb (fun s:state => - match action_table s with - | Lookahead_act awp => - forallb (fun t => - match awp t with - | Shift_act s2 _ => - is_prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s) - | _ => true - end) - all_list - | _ => true - end) - all_list. - -Property is_shift_head_symbs_correct: - is_shift_head_symbs () = true -> shift_head_symbs. -Proof. -unfold is_shift_head_symbs, shift_head_symbs. -intros. -rewrite forallb_forall in H. -specialize (H s (all_list_forall s)). -destruct (action_table s); intuition. -rewrite forallb_forall in H. -specialize (H t (all_list_forall t)). -destruct (l t); intuition. -apply is_prefix_correct; intuition. -Qed. - -(** When a goto happens, then the known top symbols of the destination state - is a prefix of the known top symbols of the source state, with the new - symbol added. **) -Definition goto_head_symbs := - forall s nt, - match goto_table s nt with - | Some (exist _ s2 _) => - prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s) - | None => True - end. - -Definition is_goto_head_symbs (_:unit) := - forallb (fun s:state => - forallb (fun nt => - match goto_table s nt with - | Some (exist _ s2 _) => - is_prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s) - | None => true - end) - all_list) - all_list. - -Property is_goto_head_symbs_correct: - is_goto_head_symbs () = true -> goto_head_symbs. -Proof. -unfold is_goto_head_symbs, goto_head_symbs. -intros. -rewrite forallb_forall in H. -specialize (H s (all_list_forall s)). -rewrite forallb_forall in H. -specialize (H nt (all_list_forall nt)). -destruct (goto_table s nt); intuition. -destruct s0. -apply is_prefix_correct; intuition. -Qed. - -(** We have to say the same kind of checks for the assumptions about the - states stack. However, theses assumptions are predicates. So we define - a notion of "prefix" over predicates lists, that means, basically, that - an assumption entails another **) -Inductive prefix_pred: list (state->bool) -> list (state->bool) -> Prop := - | prefix_pred_nil: forall l, prefix_pred [] l - | prefix_pred_cons: forall l1 l2 f1 f2, - (forall x, implb (f2 x) (f1 x) = true) -> - prefix_pred l1 l2 -> prefix_pred (f1::l1) (f2::l2). - -Fixpoint is_prefix_pred (l1 l2:list (state->bool)) := - match l1, l2 with - | [], _ => true - | f1::q1, f2::q2 => - (forallb (fun x => implb (f2 x) (f1 x)) all_list - && is_prefix_pred q1 q2)%bool - | _::_, [] => false - end. - -Property is_prefix_pred_correct (l1 l2:list (state->bool)) : - is_prefix_pred l1 l2 = true -> prefix_pred l1 l2. -Proof. -revert l2. -induction l1. -intros. -apply prefix_pred_nil. -intros. -destruct l2; intuition; try discriminate. -unfold is_prefix_pred in H. -rewrite Bool.andb_true_iff in H. -rewrite forallb_forall in H. -apply prefix_pred_cons; intuition. -apply H0. -apply all_list_forall. -Qed. - -(** The assumptions about state stack is conserved when we shift **) -Definition shift_past_state := - forall s, - match action_table s with - | Lookahead_act awp => - forall t, match awp t with - | Shift_act s2 _ => - prefix_pred (past_state_of_non_init_state s2) - (head_states_of_state s) - | _ => True - end - | _ => True - end. - -Definition is_shift_past_state (_:unit) := - forallb (fun s:state => - match action_table s with - | Lookahead_act awp => - forallb (fun t => - match awp t with - | Shift_act s2 _ => - is_prefix_pred - (past_state_of_non_init_state s2) (head_states_of_state s) - | _ => true - end) - all_list - | _ => true - end) - all_list. - -Property is_shift_past_state_correct: - is_shift_past_state () = true -> shift_past_state. -Proof. -unfold is_shift_past_state, shift_past_state. -intros. -rewrite forallb_forall in H. -specialize (H s (all_list_forall s)). -destruct (action_table s); intuition. -rewrite forallb_forall in H. -specialize (H t (all_list_forall t)). -destruct (l t); intuition. -apply is_prefix_pred_correct; intuition. -Qed. - -(** The assumptions about state stack is conserved when we do a goto **) -Definition goto_past_state := - forall s nt, - match goto_table s nt with - | Some (exist _ s2 _) => - prefix_pred (past_state_of_non_init_state s2) - (head_states_of_state s) - | None => True - end. - -Definition is_goto_past_state (_:unit) := - forallb (fun s:state => - forallb (fun nt => - match goto_table s nt with - | Some (exist _ s2 _) => - is_prefix_pred - (past_state_of_non_init_state s2) (head_states_of_state s) - | None => true - end) - all_list) - all_list. - -Property is_goto_past_state_correct : - is_goto_past_state () = true -> goto_past_state. -Proof. -unfold is_goto_past_state, goto_past_state. -intros. -rewrite forallb_forall in H. -specialize (H s (all_list_forall s)). -rewrite forallb_forall in H. -specialize (H nt (all_list_forall nt)). -destruct (goto_table s nt); intuition. -destruct s0. -apply is_prefix_pred_correct; intuition. -Qed. - -(** What states are possible after having popped these symbols from the - stack, given the annotation of the current state ? **) -Inductive state_valid_after_pop (s:state): - list symbol -> list (state -> bool) -> Prop := - | state_valid_after_pop_nil1: - forall p pl, p s = true -> state_valid_after_pop s [] (p::pl) - | state_valid_after_pop_nil2: - forall sl, state_valid_after_pop s sl [] - | state_valid_after_pop_cons: - forall st sq p pl, state_valid_after_pop s sq pl -> - state_valid_after_pop s (st::sq) (p::pl). - -Fixpoint is_state_valid_after_pop - (state:state) (to_pop:list symbol) annot := - match annot, to_pop with - | [], _ => true - | p::_, [] => p state - | p::pl, s::sl => is_state_valid_after_pop state sl pl - end. - -Property is_state_valid_after_pop_complete state sl pl : - state_valid_after_pop state sl pl -> is_state_valid_after_pop state sl pl = true. -Proof. -intro. -induction H; intuition. -destruct sl; intuition. -Qed. - -(** A state is valid for reducing a production when : - - The assumptions on the state are such that we will find the right hand - side of the production on the stack. - - We will be able to do a goto after having popped the right hand side. -**) -Definition valid_for_reduce (state:state) prod := - prefix (prod_rhs_rev prod) (head_symbs_of_state state) /\ - forall state_new, - state_valid_after_pop state_new - (prod_rhs_rev prod) (head_states_of_state state) -> - goto_table state_new (prod_lhs prod) = None -> - match state_new with - | Init i => prod_lhs prod = start_nt i - | Ninit _ => False - end. - -Definition is_valid_for_reduce (state:state) prod:= - (is_prefix (prod_rhs_rev prod) (head_symbs_of_state state) && - forallb (fun state_new => - if is_state_valid_after_pop state_new (prod_rhs_rev prod) - (head_states_of_state state) then - match goto_table state_new (prod_lhs prod) with - | Some _ => true - | None => - match state_new with - | Init i => compare_eqb (prod_lhs prod) (start_nt i) - | Ninit _ => false - end - end - else - true) - all_list)%bool. - -Property is_valid_for_reduce_correct (state:state) prod: - is_valid_for_reduce state prod = true -> valid_for_reduce state prod. -Proof. -unfold is_valid_for_reduce, valid_for_reduce. -intros. -rewrite Bool.andb_true_iff in H. -split. -apply is_prefix_correct. -intuition. -intros. -rewrite forallb_forall in H. -destruct H. -specialize (H2 state_new (all_list_forall state_new)). -rewrite is_state_valid_after_pop_complete, H1 in H2. -destruct state_new; intuition. -rewrite compare_eqb_iff in H2; intuition. -intuition. -Qed. - -(** All the states that does a reduce are valid for reduction **) -Definition reduce_ok := - forall s, - match action_table s with - | Lookahead_act awp => - forall t, match awp t with - | Reduce_act p => valid_for_reduce s p - | _ => True - end - | Default_reduce_act p => valid_for_reduce s p - end. - -Definition is_reduce_ok (_:unit) := - forallb (fun s => - match action_table s with - | Lookahead_act awp => - forallb (fun t => - match awp t with - | Reduce_act p => is_valid_for_reduce s p - | _ => true - end) - all_list - | Default_reduce_act p => is_valid_for_reduce s p - end) - all_list. - -Property is_reduce_ok_correct : - is_reduce_ok () = true -> reduce_ok. -Proof. -unfold is_reduce_ok, reduce_ok. -intros. -rewrite forallb_forall in H. -specialize (H s (all_list_forall s)). -destruct (action_table s). -apply is_valid_for_reduce_correct; intuition. -intro. -rewrite forallb_forall in H. -specialize (H t (all_list_forall t)). -destruct (l t); intuition. -apply is_valid_for_reduce_correct; intuition. -Qed. - -(** The automaton is safe **) -Definition safe := - shift_head_symbs /\ goto_head_symbs /\ shift_past_state /\ - goto_past_state /\ reduce_ok. - -Definition is_safe (_:unit) := - (is_shift_head_symbs () && is_goto_head_symbs () && is_shift_past_state () && - is_goto_past_state () && is_reduce_ok ())%bool. - -Property is_safe_correct: - is_safe () = true -> safe. -Proof. -unfold safe, is_safe. -repeat rewrite Bool.andb_true_iff. -intuition. -apply is_shift_head_symbs_correct; assumption. -apply is_goto_head_symbs_correct; assumption. -apply is_shift_past_state_correct; assumption. -apply is_goto_past_state_correct; assumption. -apply is_reduce_ok_correct; assumption. -Qed. - -End Make. diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml index 3c27f3a9..4c70c7ae 100644 --- a/cparser/PackedStructs.ml +++ b/cparser/PackedStructs.ml @@ -418,4 +418,4 @@ let program p = | _ -> false end; Hashtbl.clear byteswapped_fields; - transf_globdecls (Builtins.environment()) [] p + transf_globdecls (Env.initial()) [] p diff --git a/cparser/Parse.ml b/cparser/Parse.ml index 154e3dcf..29245083 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -56,22 +56,21 @@ let preprocessed_file transfs name sourcefile = let text = read_file sourcefile in let p = let t = parse_transformations transfs in - let rec inf = Datatypes.S inf in + let log_fuel = Camlcoq.Nat.of_int 50 in let ast : Cabs.definition list = - Obj.magic (match Timing.time "Parsing" (* The call to Lexer.tokens_stream results in the pre parsing of the entire file. This is non-negligeabe, so we cannot use Timing.time2 *) (fun () -> - Parser.translation_unit_file inf (Lexer.tokens_stream name text)) () + Parser.translation_unit_file log_fuel (Lexer.tokens_stream name text)) () with - | Parser.Parser.Inter.Fail_pr -> + | Parser.MenhirLibParser.Inter.Fail_pr -> (* Theoretically impossible : implies inconsistencies between grammars. *) - Diagnostics.fatal_error Diagnostics.no_loc "internal error while parsing" - | Parser.Parser.Inter.Timeout_pr -> assert false - | Parser.Parser.Inter.Parsed_pr (ast, _ ) -> ast) in + Diagnostics.fatal_error Diagnostics.no_loc "internal error while parsing" + | Parser.MenhirLibParser.Inter.Timeout_pr -> assert false + | Parser.MenhirLibParser.Inter.Parsed_pr (ast, _ ) -> ast) in let p1 = Timing.time "Elaboration" Elab.elab_file ast in Diagnostics.check_errors (); Timing.time2 "Emulations" transform_program t p1 name in diff --git a/cparser/Parser.vy b/cparser/Parser.vy index 79e3793d..03bfa590 100644 --- a/cparser/Parser.vy +++ b/cparser/Parser.vy @@ -15,96 +15,99 @@ %{ -Require Import Cabs. Require Import List. +Require Cabs. %} -%token<string * cabsloc> VAR_NAME TYPEDEF_NAME OTHER_NAME -%token<string * cabsloc> PRAGMA -%token<bool * list char_code * cabsloc> STRING_LITERAL -%token<constant * cabsloc> CONSTANT -%token<cabsloc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT +%token<Cabs.string * Cabs.loc> VAR_NAME TYPEDEF_NAME OTHER_NAME +%token<Cabs.string * Cabs.loc> PRAGMA +%token<bool * list Cabs.char_code * Cabs.loc> STRING_LITERAL +%token<Cabs.constant * Cabs.loc> CONSTANT +%token<Cabs.loc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT ANDAND BARBAR PLUS MINUS STAR TILDE BANG SLASH PERCENT HAT BAR QUESTION COLON AND ALIGNOF -%token<cabsloc> MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN +%token<Cabs.loc> MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN LEFT_ASSIGN RIGHT_ASSIGN AND_ASSIGN XOR_ASSIGN OR_ASSIGN -%token<cabsloc> LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE DOT COMMA - SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT AUTO REGISTER INLINE NORETURN - CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID +%token<Cabs.loc> LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE DOT COMMA + SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT AUTO REGISTER INLINE + NORETURN CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID STRUCT UNION ENUM UNDERSCORE_BOOL PACKED ALIGNAS ATTRIBUTE ASM -%token<cabsloc> CASE DEFAULT IF ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK +%token<Cabs.loc> CASE DEFAULT IF_ ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK RETURN BUILTIN_VA_ARG BUILTIN_OFFSETOF %token EOF -%type<expression * cabsloc> primary_expression postfix_expression +%type<Cabs.expression * Cabs.loc> primary_expression postfix_expression unary_expression cast_expression multiplicative_expression additive_expression shift_expression relational_expression equality_expression AND_expression exclusive_OR_expression inclusive_OR_expression logical_AND_expression logical_OR_expression conditional_expression assignment_expression constant_expression expression -%type<unary_operator * cabsloc> unary_operator -%type<binary_operator> assignment_operator -%type<list expression (* Reverse order *)> argument_expression_list -%type<definition> declaration -%type<list spec_elem * cabsloc> declaration_specifiers -%type<list spec_elem> declaration_specifiers_typespec_opt -%type<list init_name (* Reverse order *)> init_declarator_list -%type<init_name> init_declarator -%type<storage * cabsloc> storage_class_specifier -%type<typeSpecifier * cabsloc> type_specifier struct_or_union_specifier enum_specifier -%type<structOrUnion * cabsloc> struct_or_union -%type<list field_group (* Reverse order *)> struct_declaration_list -%type<field_group> struct_declaration -%type<list spec_elem * cabsloc> specifier_qualifier_list -%type<list (option name * option expression) (* Reverse order *)> struct_declarator_list -%type<option name * option expression> struct_declarator -%type<list (string * option expression * cabsloc) (* Reverse order *)> enumerator_list -%type<string * option expression * cabsloc> enumerator -%type<string * cabsloc> enumeration_constant -%type<cvspec * cabsloc> type_qualifier type_qualifier_noattr -%type<funspec * cabsloc> function_specifier -%type<name> declarator declarator_noattrend direct_declarator -%type<(decl_type -> decl_type) * cabsloc> pointer -%type<list cvspec (* Reverse order *)> type_qualifier_list -%type<list parameter * bool> parameter_type_list -%type<list parameter (* Reverse order *)> parameter_list -%type<parameter> parameter_declaration -%type<list spec_elem * decl_type> type_name -%type<decl_type> abstract_declarator direct_abstract_declarator -%type<init_expression> c_initializer -%type<list (list initwhat * init_expression) (* Reverse order *)> initializer_list -%type<list initwhat> designation -%type<list initwhat (* Reverse order *)> designator_list -%type<initwhat> designator -%type<statement> statement_dangerous statement_safe +%type<Cabs.unary_operator * Cabs.loc> unary_operator +%type<Cabs.binary_operator> assignment_operator +%type<list Cabs.expression (* Reverse order *)> argument_expression_list +%type<Cabs.definition> declaration +%type<list Cabs.spec_elem * Cabs.loc> declaration_specifiers +%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.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 +%type<list Cabs.field_group (* Reverse order *)> struct_declaration_list +%type<Cabs.field_group> struct_declaration +%type<list Cabs.spec_elem * Cabs.loc> specifier_qualifier_list +%type<list (option Cabs.name * option Cabs.expression) (* Reverse order *)> + struct_declarator_list +%type<option Cabs.name * option Cabs.expression> struct_declarator +%type<list (Cabs.string * option Cabs.expression * Cabs.loc) (* Reverse order *)> + enumerator_list +%type<Cabs.string * option Cabs.expression * Cabs.loc> enumerator +%type<Cabs.string * Cabs.loc> enumeration_constant +%type<Cabs.cvspec * Cabs.loc> type_qualifier type_qualifier_noattr +%type<Cabs.funspec * Cabs.loc> function_specifier +%type<Cabs.name> declarator declarator_noattrend direct_declarator +%type<(Cabs.decl_type -> Cabs.decl_type) * Cabs.loc> pointer +%type<list Cabs.cvspec (* Reverse order *)> type_qualifier_list +%type<list Cabs.parameter * bool> parameter_type_list +%type<list Cabs.parameter (* Reverse order *)> parameter_list +%type<Cabs.parameter> parameter_declaration +%type<list Cabs.spec_elem * Cabs.decl_type> type_name +%type<Cabs.decl_type> abstract_declarator direct_abstract_declarator +%type<Cabs.init_expression> c_initializer +%type<list (list Cabs.initwhat * Cabs.init_expression) (* Reverse order *)> + initializer_list +%type<list Cabs.initwhat> designation +%type<list Cabs.initwhat (* Reverse order *)> designator_list +%type<Cabs.initwhat> designator +%type<Cabs.statement> statement_dangerous statement_safe labeled_statement(statement_safe) labeled_statement(statement_dangerous) iteration_statement(statement_safe) iteration_statement(statement_dangerous) compound_statement -%type<list statement (* Reverse order *)> block_item_list -%type<statement> block_item expression_statement selection_statement_dangerous +%type<list Cabs.statement (* Reverse order *)> block_item_list +%type<Cabs.statement> block_item expression_statement selection_statement_dangerous selection_statement_safe jump_statement asm_statement -%type<list definition (* Reverse order *)> translation_unit -%type<definition> external_declaration function_definition -%type<list definition> declaration_list -%type<attribute * cabsloc> attribute_specifier -%type<list attribute> attribute_specifier_list -%type<gcc_attribute> gcc_attribute -%type<list gcc_attribute> gcc_attribute_list -%type<gcc_attribute_word> gcc_attribute_word -%type<list string (* Reverse order *)> identifier_list -%type<list asm_flag> asm_flags -%type<option string> asm_op_name -%type<asm_operand> asm_operand -%type<list asm_operand> asm_operands asm_operands_ne -%type<list asm_operand * list asm_operand * list asm_flag> asm_arguments -%type<list cvspec> asm_attributes - -%start<list definition> translation_unit_file +%type<list Cabs.definition (* Reverse order *)> translation_unit +%type<Cabs.definition> external_declaration function_definition +%type<list Cabs.definition> declaration_list +%type<Cabs.attribute * Cabs.loc> attribute_specifier +%type<list Cabs.attribute> attribute_specifier_list +%type<Cabs.gcc_attribute> gcc_attribute +%type<list Cabs.gcc_attribute> gcc_attribute_list +%type<Cabs.gcc_attribute_word> gcc_attribute_word +%type<list Cabs.string (* Reverse order *)> identifier_list +%type<list Cabs.asm_flag> asm_flags +%type<option Cabs.string> asm_op_name +%type<Cabs.asm_operand> asm_operand +%type<list Cabs.asm_operand> asm_operands asm_operands_ne +%type<list Cabs.asm_operand * list Cabs.asm_operand * list Cabs.asm_flag> asm_arguments +%type<list Cabs.cvspec> asm_attributes + +%start<list Cabs.definition> translation_unit_file %% (* Actual grammar *) @@ -112,12 +115,12 @@ Require Import List. (* 6.5.1 *) primary_expression: | var = VAR_NAME - { (VARIABLE (fst var), snd var) } + { (Cabs.VARIABLE (fst var), snd var) } | cst = CONSTANT - { (CONSTANT (fst cst), snd cst) } + { (Cabs.CONSTANT (fst cst), snd cst) } | str = STRING_LITERAL { let '((wide, chars), loc) := str in - (CONSTANT (CONST_STRING wide chars), loc) } + (Cabs.CONSTANT (Cabs.CONST_STRING wide chars), loc) } | loc = LPAREN expr = expression RPAREN { (fst expr, loc)} @@ -126,29 +129,30 @@ postfix_expression: | expr = primary_expression { expr } | expr = postfix_expression LBRACK index = expression RBRACK - { (INDEX (fst expr) (fst index), snd expr) } + { (Cabs.INDEX (fst expr) (fst index), snd expr) } | expr = postfix_expression LPAREN args = argument_expression_list RPAREN - { (CALL (fst expr) (rev' args), snd expr) } + { (Cabs.CALL (fst expr) (rev' args), snd expr) } | expr = postfix_expression LPAREN RPAREN - { (CALL (fst expr) [], snd expr) } + { (Cabs.CALL (fst expr) [], snd expr) } | loc = BUILTIN_VA_ARG LPAREN expr = assignment_expression COMMA ty = type_name RPAREN - { (BUILTIN_VA_ARG (fst expr) ty, loc) } + { (Cabs.BUILTIN_VA_ARG (fst expr) ty, loc) } | expr = postfix_expression DOT mem = OTHER_NAME - { (MEMBEROF (fst expr) (fst mem), snd expr) } + { (Cabs.MEMBEROF (fst expr) (fst mem), snd expr) } | expr = postfix_expression PTR mem = OTHER_NAME - { (MEMBEROFPTR (fst expr) (fst mem), snd expr) } + { (Cabs.MEMBEROFPTR (fst expr) (fst mem), snd expr) } | expr = postfix_expression INC - { (UNARY POSINCR (fst expr), snd expr) } + { (Cabs.UNARY Cabs.POSINCR (fst expr), snd expr) } | expr = postfix_expression DEC - { (UNARY POSDECR (fst expr), snd expr) } + { (Cabs.UNARY Cabs.POSDECR (fst expr), snd expr) } | loc = LPAREN typ = type_name RPAREN LBRACE init = initializer_list RBRACE - { (CAST typ (COMPOUND_INIT (rev' init)), loc) } + { (Cabs.CAST typ (Cabs.COMPOUND_INIT (rev' init)), loc) } | loc = LPAREN typ = type_name RPAREN LBRACE init = initializer_list COMMA RBRACE - { (CAST typ (COMPOUND_INIT (rev' init)), loc) } -| loc = BUILTIN_OFFSETOF LPAREN typ = type_name COMMA id = OTHER_NAME mems = designator_list RPAREN - { (BUILTIN_OFFSETOF typ ((INFIELD_INIT (fst id))::(rev mems)), loc) } + { (Cabs.CAST typ (Cabs.COMPOUND_INIT (rev' init)), loc) } +| loc = BUILTIN_OFFSETOF LPAREN typ = type_name COMMA id = OTHER_NAME + mems = designator_list RPAREN + { (Cabs.BUILTIN_OFFSETOF typ ((Cabs.INFIELD_INIT (fst id))::(rev mems)), loc) } | loc = BUILTIN_OFFSETOF LPAREN typ = type_name COMMA mem = OTHER_NAME RPAREN - { (BUILTIN_OFFSETOF typ [INFIELD_INIT (fst mem)], loc) } + { (Cabs.BUILTIN_OFFSETOF typ [Cabs.INFIELD_INIT (fst mem)], loc) } (* Semantic value is in reverse order. *) argument_expression_list: @@ -162,170 +166,171 @@ unary_expression: | expr = postfix_expression { expr } | loc = INC expr = unary_expression - { (UNARY PREINCR (fst expr), loc) } + { (Cabs.UNARY Cabs.PREINCR (fst expr), loc) } | loc = DEC expr = unary_expression - { (UNARY PREDECR (fst expr), loc) } + { (Cabs.UNARY Cabs.PREDECR (fst expr), loc) } | op = unary_operator expr = cast_expression - { (UNARY (fst op) (fst expr), snd op) } + { (Cabs.UNARY (fst op) (fst expr), snd op) } | loc = SIZEOF expr = unary_expression - { (EXPR_SIZEOF (fst expr), loc) } + { (Cabs.EXPR_SIZEOF (fst expr), loc) } | loc = SIZEOF LPAREN typ = type_name RPAREN - { (TYPE_SIZEOF typ, loc) } + { (Cabs.TYPE_SIZEOF typ, loc) } (* Non-standard *) | loc = ALIGNOF LPAREN typ = type_name RPAREN - { (ALIGNOF typ, loc) } + { (Cabs.ALIGNOF typ, loc) } unary_operator: | loc = AND - { (ADDROF, loc) } + { (Cabs.ADDROF, loc) } | loc = STAR - { (MEMOF, loc) } + { (Cabs.MEMOF, loc) } | loc = PLUS - { (PLUS, loc) } + { (Cabs.PLUS, loc) } | loc = MINUS - { (MINUS, loc) } + { (Cabs.MINUS, loc) } | loc = TILDE - { (BNOT, loc) } + { (Cabs.BNOT, loc) } | loc = BANG - { (NOT, loc) } + { (Cabs.NOT, loc) } (* 6.5.4 *) cast_expression: | expr = unary_expression { expr } | loc = LPAREN typ = type_name RPAREN expr = cast_expression - { (CAST typ (SINGLE_INIT (fst expr)), loc) } + { (Cabs.CAST typ (Cabs.SINGLE_INIT (fst expr)), loc) } (* 6.5.5 *) multiplicative_expression: | expr = cast_expression { expr } | expr1 = multiplicative_expression STAR expr2 = cast_expression - { (BINARY MUL (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.MUL (fst expr1) (fst expr2), snd expr1) } | expr1 = multiplicative_expression SLASH expr2 = cast_expression - { (BINARY DIV (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.DIV (fst expr1) (fst expr2), snd expr1) } | expr1 = multiplicative_expression PERCENT expr2 = cast_expression - { (BINARY MOD (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.MOD (fst expr1) (fst expr2), snd expr1) } (* 6.5.6 *) additive_expression: | expr = multiplicative_expression { expr } | expr1 = additive_expression PLUS expr2 = multiplicative_expression - { (BINARY ADD (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.ADD (fst expr1) (fst expr2), snd expr1) } | expr1 = additive_expression MINUS expr2 = multiplicative_expression - { (BINARY SUB (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.SUB (fst expr1) (fst expr2), snd expr1) } (* 6.5.7 *) shift_expression: | expr = additive_expression { expr } | expr1 = shift_expression LEFT expr2 = additive_expression - { (BINARY SHL (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.SHL (fst expr1) (fst expr2), snd expr1) } | expr1 = shift_expression RIGHT expr2 = additive_expression - { (BINARY SHR (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.SHR (fst expr1) (fst expr2), snd expr1) } (* 6.5.8 *) relational_expression: | expr = shift_expression { expr } | expr1 = relational_expression LT expr2 = shift_expression - { (BINARY LT (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.LT (fst expr1) (fst expr2), snd expr1) } | expr1 = relational_expression GT expr2 = shift_expression - { (BINARY GT (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.GT (fst expr1) (fst expr2), snd expr1) } | expr1 = relational_expression LEQ expr2 = shift_expression - { (BINARY LE (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.LE (fst expr1) (fst expr2), snd expr1) } | expr1 = relational_expression GEQ expr2 = shift_expression - { (BINARY GE (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.GE (fst expr1) (fst expr2), snd expr1) } (* 6.5.9 *) equality_expression: | expr = relational_expression { expr } | expr1 = equality_expression EQEQ expr2 = relational_expression - { (BINARY EQ (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.EQ (fst expr1) (fst expr2), snd expr1) } | expr1 = equality_expression NEQ expr2 = relational_expression - { (BINARY NE (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.NE (fst expr1) (fst expr2), snd expr1) } (* 6.5.10 *) AND_expression: | expr = equality_expression { expr } | expr1 = AND_expression AND expr2 = equality_expression - { (BINARY BAND (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.BAND (fst expr1) (fst expr2), snd expr1) } (* 6.5.11 *) exclusive_OR_expression: | expr = AND_expression { expr } | expr1 = exclusive_OR_expression HAT expr2 = AND_expression - { (BINARY XOR (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.XOR (fst expr1) (fst expr2), snd expr1) } (* 6.5.12 *) inclusive_OR_expression: | expr = exclusive_OR_expression { expr } | expr1 = inclusive_OR_expression BAR expr2 = exclusive_OR_expression - { (BINARY BOR (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.BOR (fst expr1) (fst expr2), snd expr1) } (* 6.5.13 *) logical_AND_expression: | expr = inclusive_OR_expression { expr } | expr1 = logical_AND_expression ANDAND expr2 = inclusive_OR_expression - { (BINARY AND (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.AND (fst expr1) (fst expr2), snd expr1) } (* 6.5.14 *) logical_OR_expression: | expr = logical_AND_expression { expr } | expr1 = logical_OR_expression BARBAR expr2 = logical_AND_expression - { (BINARY OR (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.OR (fst expr1) (fst expr2), snd expr1) } (* 6.5.15 *) conditional_expression: | expr = logical_OR_expression { expr } -| expr1 = logical_OR_expression QUESTION expr2 = expression COLON expr3 = conditional_expression - { (QUESTION (fst expr1) (fst expr2) (fst expr3), snd expr1) } +| expr1 = logical_OR_expression QUESTION expr2 = expression COLON + expr3 = conditional_expression + { (Cabs.QUESTION (fst expr1) (fst expr2) (fst expr3), snd expr1) } (* 6.5.16 *) assignment_expression: | expr = conditional_expression { expr } | expr1 = unary_expression op = assignment_operator expr2 = assignment_expression - { (BINARY op (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY op (fst expr1) (fst expr2), snd expr1) } assignment_operator: | EQ - { ASSIGN } + { Cabs.ASSIGN } | MUL_ASSIGN - { MUL_ASSIGN } + { Cabs.MUL_ASSIGN } | DIV_ASSIGN - { DIV_ASSIGN } + { Cabs.DIV_ASSIGN } | MOD_ASSIGN - { MOD_ASSIGN } + { Cabs.MOD_ASSIGN } | ADD_ASSIGN - { ADD_ASSIGN } + { Cabs.ADD_ASSIGN } | SUB_ASSIGN - { SUB_ASSIGN } + { Cabs.SUB_ASSIGN } | LEFT_ASSIGN - { SHL_ASSIGN } + { Cabs.SHL_ASSIGN } | RIGHT_ASSIGN - { SHR_ASSIGN } + { Cabs.SHR_ASSIGN } | XOR_ASSIGN - { XOR_ASSIGN } + { Cabs.XOR_ASSIGN } | OR_ASSIGN - { BOR_ASSIGN } + { Cabs.BOR_ASSIGN } | AND_ASSIGN - { BAND_ASSIGN } + { Cabs.BAND_ASSIGN } (* 6.5.17 *) expression: | expr = assignment_expression { expr } | expr1 = expression COMMA expr2 = assignment_expression - { (BINARY COMMA (fst expr1) (fst expr2), snd expr1) } + { (Cabs.BINARY Cabs.COMMA (fst expr1) (fst expr2), snd expr1) } (* 6.6 *) constant_expression: @@ -335,19 +340,19 @@ constant_expression: (* 6.7 *) declaration: | decspec = declaration_specifiers decls = init_declarator_list SEMICOLON - { DECDEF (fst decspec, rev' decls) (snd decspec) } + { Cabs.DECDEF (fst decspec, rev' decls) (snd decspec) } | decspec = declaration_specifiers SEMICOLON - { DECDEF (fst decspec, []) (snd decspec) } + { Cabs.DECDEF (fst decspec, []) (snd decspec) } declaration_specifiers_typespec_opt: | storage = storage_class_specifier rest = declaration_specifiers_typespec_opt - { SpecStorage (fst storage)::rest } + { Cabs.SpecStorage (fst storage)::rest } | typ = type_specifier rest = declaration_specifiers_typespec_opt - { SpecType (fst typ)::rest } + { Cabs.SpecType (fst typ)::rest } | qual = type_qualifier rest = declaration_specifiers_typespec_opt - { SpecCV (fst qual)::rest } + { Cabs.SpecCV (fst qual)::rest } | func = function_specifier rest = declaration_specifiers_typespec_opt - { SpecFunction (fst func)::rest } + { Cabs.SpecFunction (fst func)::rest } | /* empty */ { [] } @@ -357,16 +362,16 @@ declaration_specifiers_typespec_opt: specifier. *) declaration_specifiers: | storage = storage_class_specifier rest = declaration_specifiers - { (SpecStorage (fst storage)::fst rest, snd storage) } + { (Cabs.SpecStorage (fst storage)::fst rest, snd storage) } | typ = type_specifier rest = declaration_specifiers_typespec_opt - { (SpecType (fst typ)::rest, snd typ) } + { (Cabs.SpecType (fst typ)::rest, snd typ) } (* We have to inline type_qualifier in order to avoid a conflict. *) | qual = type_qualifier_noattr rest = declaration_specifiers - { (SpecCV (fst qual)::fst rest, snd qual) } + { (Cabs.SpecCV (fst qual)::fst rest, snd qual) } | attr = attribute_specifier rest = declaration_specifiers - { (SpecCV (CV_ATTR (fst attr))::fst rest, snd attr) } + { (Cabs.SpecCV (Cabs.CV_ATTR (fst attr))::fst rest, snd attr) } | func = function_specifier rest = declaration_specifiers - { (SpecFunction (fst func)::fst rest, snd func) } + { (Cabs.SpecFunction (fst func)::fst rest, snd func) } init_declarator_list: | init = init_declarator @@ -376,71 +381,71 @@ init_declarator_list: init_declarator: | name = declarator - { Init_name name NO_INIT } + { Cabs.Init_name name Cabs.NO_INIT } | name = declarator EQ init = c_initializer - { Init_name name init } + { Cabs.Init_name name init } (* 6.7.1 *) storage_class_specifier: | loc = TYPEDEF - { (TYPEDEF, loc) } + { (Cabs.TYPEDEF, loc) } | loc = EXTERN - { (EXTERN, loc) } + { (Cabs.EXTERN, loc) } | loc = STATIC - { (STATIC, loc) } + { (Cabs.STATIC, loc) } | loc = AUTO - { (AUTO, loc) } + { (Cabs.AUTO, loc) } | loc = REGISTER - { (REGISTER, loc) } + { (Cabs.REGISTER, loc) } (* 6.7.2 *) type_specifier: | loc = VOID - { (Tvoid, loc) } + { (Cabs.Tvoid, loc) } | loc = CHAR - { (Tchar, loc) } + { (Cabs.Tchar, loc) } | loc = SHORT - { (Tshort, loc) } + { (Cabs.Tshort, loc) } | loc = INT - { (Tint, loc) } + { (Cabs.Tint, loc) } | loc = LONG - { (Tlong, loc) } + { (Cabs.Tlong, loc) } | loc = FLOAT - { (Tfloat, loc) } + { (Cabs.Tfloat, loc) } | loc = DOUBLE - { (Tdouble, loc) } + { (Cabs.Tdouble, loc) } | loc = SIGNED - { (Tsigned, loc) } + { (Cabs.Tsigned, loc) } | loc = UNSIGNED - { (Tunsigned, loc) } + { (Cabs.Tunsigned, loc) } | loc = UNDERSCORE_BOOL - { (T_Bool, loc) } + { (Cabs.T_Bool, loc) } | spec = struct_or_union_specifier { spec } | spec = enum_specifier { spec } | id = TYPEDEF_NAME - { (Tnamed (fst id), snd id) } + { (Cabs.Tnamed (fst id), snd id) } (* 6.7.2.1 *) struct_or_union_specifier: | str_uni = struct_or_union attrs = attribute_specifier_list id = OTHER_NAME LBRACE decls = struct_declaration_list RBRACE - { (Tstruct_union (fst str_uni) (Some (fst id)) (Some (rev' decls)) attrs, + { (Cabs.Tstruct_union (fst str_uni) (Some (fst id)) (Some (rev' decls)) attrs, snd str_uni) } | str_uni = struct_or_union attrs = attribute_specifier_list LBRACE decls = struct_declaration_list RBRACE - { (Tstruct_union (fst str_uni) None (Some (rev' decls)) attrs, + { (Cabs.Tstruct_union (fst str_uni) None (Some (rev' decls)) attrs, snd str_uni) } | str_uni = struct_or_union attrs = attribute_specifier_list id = OTHER_NAME - { (Tstruct_union (fst str_uni) (Some (fst id)) None attrs, + { (Cabs.Tstruct_union (fst str_uni) (Some (fst id)) None attrs, snd str_uni) } struct_or_union: | loc = STRUCT - { (STRUCT, loc) } + { (Cabs.STRUCT, loc) } | loc = UNION - { (UNION, loc) } + { (Cabs.UNION, loc) } struct_declaration_list: | (* empty *) @@ -450,20 +455,20 @@ struct_declaration_list: struct_declaration: | decspec = specifier_qualifier_list decls = struct_declarator_list SEMICOLON - { Field_group (fst decspec) (rev' decls) (snd decspec) } + { Cabs.Field_group (fst decspec) (rev' decls) (snd decspec) } (* Extension to C99 grammar needed to parse some GNU header files. *) | decspec = specifier_qualifier_list SEMICOLON - { Field_group (fst decspec) [(None,None)] (snd decspec) } + { Cabs.Field_group (fst decspec) [(None,None)] (snd decspec) } specifier_qualifier_list: | typ = type_specifier rest = specifier_qualifier_list - { (SpecType (fst typ)::fst rest, snd typ) } + { (Cabs.SpecType (fst typ)::fst rest, snd typ) } | typ = type_specifier - { ([SpecType (fst typ)], snd typ) } + { ([Cabs.SpecType (fst typ)], snd typ) } | qual = type_qualifier rest = specifier_qualifier_list - { (SpecCV (fst qual)::fst rest, snd qual) } + { (Cabs.SpecCV (fst qual)::fst rest, snd qual) } | qual = type_qualifier - { ([SpecCV (fst qual)], snd qual) } + { ([Cabs.SpecCV (fst qual)], snd qual) } struct_declarator_list: | decl = struct_declarator @@ -483,18 +488,18 @@ struct_declarator: enum_specifier: | loc = ENUM attrs = attribute_specifier_list name = OTHER_NAME LBRACE enum_list = enumerator_list RBRACE - { (Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) } + { (Cabs.Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) } | loc = ENUM attrs = attribute_specifier_list LBRACE enum_list = enumerator_list RBRACE - { (Tenum None (Some (rev' enum_list)) attrs, loc) } + { (Cabs.Tenum None (Some (rev' enum_list)) attrs, loc) } | loc = ENUM attrs = attribute_specifier_list name = OTHER_NAME LBRACE enum_list = enumerator_list COMMA RBRACE - { (Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) } + { (Cabs.Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) } | loc = ENUM attrs = attribute_specifier_list LBRACE enum_list = enumerator_list COMMA RBRACE - { (Tenum None (Some (rev' enum_list)) attrs, loc) } + { (Cabs.Tenum None (Some (rev' enum_list)) attrs, loc) } | loc = ENUM attrs = attribute_specifier_list name = OTHER_NAME - { (Tenum (Some (fst name)) None attrs, loc) } + { (Cabs.Tenum (Some (fst name)) None attrs, loc) } enumerator_list: | enum = enumerator @@ -515,18 +520,18 @@ enumeration_constant: (* 6.7.3 *) type_qualifier_noattr: | loc = CONST - { (CV_CONST, loc) } + { (Cabs.CV_CONST, loc) } | loc = RESTRICT - { (CV_RESTRICT, loc) } + { (Cabs.CV_RESTRICT, loc) } | loc = VOLATILE - { (CV_VOLATILE, loc) } + { (Cabs.CV_VOLATILE, loc) } type_qualifier: | qual = type_qualifier_noattr { qual } (* Non-standard *) | attr = attribute_specifier - { (CV_ATTR (fst attr), snd attr) } + { (Cabs.CV_ATTR (fst attr), snd attr) } (* Non-standard *) @@ -538,13 +543,13 @@ attribute_specifier_list: attribute_specifier: | loc = ATTRIBUTE LPAREN LPAREN attr = gcc_attribute_list RPAREN RPAREN - { (GCC_ATTR (rev' attr) loc, loc) } + { (Cabs.GCC_ATTR (rev' attr) loc, loc) } | loc = PACKED LPAREN args = argument_expression_list RPAREN - { (PACKED_ATTR (rev' args) loc, loc) } + { (Cabs.PACKED_ATTR (rev' args) loc, loc) } | loc = ALIGNAS LPAREN args = argument_expression_list RPAREN - { (ALIGNAS_ATTR (rev' args) loc, loc) } + { (Cabs.ALIGNAS_ATTR (rev' args) loc, loc) } | loc = ALIGNAS LPAREN typ = type_name RPAREN - { (ALIGNAS_ATTR [ALIGNOF typ] loc, loc) } + { (Cabs.ALIGNAS_ATTR [Cabs.ALIGNOF typ] loc, loc) } gcc_attribute_list: | a = gcc_attribute @@ -554,80 +559,81 @@ gcc_attribute_list: gcc_attribute: | /* empty */ - { GCC_ATTR_EMPTY } + { Cabs.GCC_ATTR_EMPTY } | w = gcc_attribute_word - { GCC_ATTR_NOARGS w } + { Cabs.GCC_ATTR_NOARGS w } | w = gcc_attribute_word LPAREN RPAREN - { GCC_ATTR_ARGS w [] } + { Cabs.GCC_ATTR_ARGS w [] } | w = gcc_attribute_word LPAREN args = argument_expression_list RPAREN - { GCC_ATTR_ARGS w (rev' args) } + { Cabs.GCC_ATTR_ARGS w (rev' args) } gcc_attribute_word: | i = OTHER_NAME - { GCC_ATTR_IDENT (fst i) } + { Cabs.GCC_ATTR_IDENT (fst i) } | CONST - { GCC_ATTR_CONST } + { Cabs.GCC_ATTR_CONST } | PACKED - { GCC_ATTR_PACKED } + { Cabs.GCC_ATTR_PACKED } (* 6.7.4 *) function_specifier: | loc = INLINE - { (INLINE, loc) } + { (Cabs.INLINE, loc) } | loc = NORETURN - { (NORETURN, loc)} + { (Cabs.NORETURN, loc)} (* 6.7.5 *) declarator: | decl = declarator_noattrend attrs = attribute_specifier_list - { match decl with Name name typ attr loc => - Name name typ (List.app attr attrs) loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name typ (List.app attr attrs) loc } declarator_noattrend: | decl = direct_declarator { decl } | pt = pointer decl = direct_declarator - { match decl with Name name typ attr _ => - Name name ((fst pt) typ) attr (snd pt) end } + { let 'Cabs.Name name typ attr _ := decl in + Cabs.Name name ((fst pt) typ) attr (snd pt) } direct_declarator: | id = VAR_NAME - { Name (fst id) JUSTBASE [] (snd id) } + { Cabs.Name (fst id) Cabs.JUSTBASE [] (snd id) } | LPAREN decl = declarator RPAREN { decl } -| decl = direct_declarator LBRACK quallst = type_qualifier_list expr = assignment_expression RBRACK - { match decl with Name name typ attr loc => - Name name (ARRAY typ (rev' quallst) (Some (fst expr))) attr loc end } +| decl = direct_declarator LBRACK quallst = type_qualifier_list + expr = assignment_expression RBRACK + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.ARRAY typ (rev' quallst) (Some (fst expr))) attr loc } | decl = direct_declarator LBRACK expr = assignment_expression RBRACK - { match decl with Name name typ attr loc => - Name name (ARRAY typ [] (Some (fst expr))) attr loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.ARRAY typ [] (Some (fst expr))) attr loc } | decl = direct_declarator LBRACK quallst = type_qualifier_list RBRACK - { match decl with Name name typ attr loc => - Name name (ARRAY typ (rev' quallst) None) attr loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.ARRAY typ (rev' quallst) None) attr loc } | decl = direct_declarator LBRACK RBRACK - { match decl with Name name typ attr loc => - Name name (ARRAY typ [] None) attr loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.ARRAY typ [] None) attr loc } (*| direct_declarator LBRACK ... STATIC ... RBRACK | direct_declarator LBRACK STAR RBRACK*) | decl = direct_declarator LPAREN params = parameter_type_list RPAREN - { match decl with Name name typ attr loc => - Name name (PROTO typ params) attr loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.PROTO typ params) attr loc } | decl = direct_declarator LPAREN RPAREN - { match decl with Name name typ attr loc => - Name name (PROTO_OLD typ []) attr loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.PROTO_OLD typ []) attr loc } | decl = direct_declarator LPAREN params = identifier_list RPAREN - { match decl with Name name typ attr loc => - Name name (PROTO_OLD typ (rev' params)) attr loc end } + { let 'Cabs.Name name typ attr loc := decl in + Cabs.Name name (Cabs.PROTO_OLD typ (rev' params)) attr loc } pointer: | loc = STAR - { (fun typ => PTR [] typ, loc) } + { (fun typ => Cabs.PTR [] typ, loc) } | loc = STAR quallst = type_qualifier_list - { (fun typ => PTR (rev' quallst) typ, loc) } + { (fun typ => Cabs.PTR (rev' quallst) typ, loc) } | loc = STAR pt = pointer - { (fun typ => PTR [] ((fst pt) typ), loc) } + { (fun typ => Cabs.PTR [] ((fst pt) typ), loc) } | loc = STAR quallst = type_qualifier_list pt = pointer - { (fun typ => PTR (rev' quallst) ((fst pt) typ), loc) } + { (fun typ => Cabs.PTR (rev' quallst) ((fst pt) typ), loc) } type_qualifier_list: | qual = type_qualifier @@ -649,12 +655,12 @@ parameter_list: parameter_declaration: | specs = declaration_specifiers decl = declarator - { match decl with Name name typ attr _ => - PARAM (fst specs) (Some name) typ attr (snd specs) end } + { match decl with Cabs.Name name typ attr _ => + Cabs.PARAM (fst specs) (Some name) typ attr (snd specs) end } | specs = declaration_specifiers decl = abstract_declarator - { PARAM (fst specs) None decl [] (snd specs) } + { Cabs.PARAM (fst specs) None decl [] (snd specs) } | specs = declaration_specifiers - { PARAM (fst specs) None JUSTBASE [] (snd specs) } + { Cabs.PARAM (fst specs) None Cabs.JUSTBASE [] (snd specs) } identifier_list: | id = VAR_NAME @@ -665,13 +671,13 @@ identifier_list: (* 6.7.6 *) type_name: | specqual = specifier_qualifier_list - { (fst specqual, JUSTBASE) } + { (fst specqual, Cabs.JUSTBASE) } | specqual = specifier_qualifier_list typ = abstract_declarator { (fst specqual, typ) } abstract_declarator: | pt = pointer - { (fst pt) JUSTBASE } + { (fst pt) Cabs.JUSTBASE } | pt = pointer typ = direct_abstract_declarator { (fst pt) typ } | typ = direct_abstract_declarator @@ -680,41 +686,42 @@ abstract_declarator: direct_abstract_declarator: | LPAREN typ = abstract_declarator RPAREN { typ } -| typ = direct_abstract_declarator LBRACK cvspec = type_qualifier_list expr = assignment_expression RBRACK - { ARRAY typ cvspec (Some (fst expr)) } +| typ = direct_abstract_declarator LBRACK cvspec = type_qualifier_list + expr = assignment_expression RBRACK + { Cabs.ARRAY typ cvspec (Some (fst expr)) } | LBRACK cvspec = type_qualifier_list expr = assignment_expression RBRACK - { ARRAY JUSTBASE cvspec (Some (fst expr)) } + { Cabs.ARRAY Cabs.JUSTBASE cvspec (Some (fst expr)) } | typ = direct_abstract_declarator LBRACK expr = assignment_expression RBRACK - { ARRAY typ [] (Some (fst expr)) } + { Cabs.ARRAY typ [] (Some (fst expr)) } | LBRACK expr = assignment_expression RBRACK - { ARRAY JUSTBASE [] (Some (fst expr)) } + { Cabs.ARRAY Cabs.JUSTBASE [] (Some (fst expr)) } | typ = direct_abstract_declarator LBRACK cvspec = type_qualifier_list RBRACK - { ARRAY typ cvspec None } + { Cabs.ARRAY typ cvspec None } | LBRACK cvspec = type_qualifier_list RBRACK - { ARRAY JUSTBASE cvspec None } + { Cabs.ARRAY Cabs.JUSTBASE cvspec None } | typ = direct_abstract_declarator LBRACK RBRACK - { ARRAY typ [] None } + { Cabs.ARRAY typ [] None } | LBRACK RBRACK - { ARRAY JUSTBASE [] None } + { Cabs.ARRAY Cabs.JUSTBASE [] None } (*| direct_abstract_declarator? LBRACK STAR RBRACK*) (*| direct_abstract_declarator? LBRACK ... STATIC ... RBRACK*) | typ = direct_abstract_declarator LPAREN params = parameter_type_list RPAREN - { PROTO typ params } + { Cabs.PROTO typ params } | LPAREN params = parameter_type_list RPAREN - { PROTO JUSTBASE params } + { Cabs.PROTO Cabs.JUSTBASE params } | typ = direct_abstract_declarator LPAREN RPAREN - { PROTO typ ([], false) } + { Cabs.PROTO typ ([], false) } | LPAREN RPAREN - { PROTO JUSTBASE ([], false) } + { Cabs.PROTO Cabs.JUSTBASE ([], false) } (* 6.7.8 *) c_initializer: | expr = assignment_expression - { SINGLE_INIT (fst expr) } + { Cabs.SINGLE_INIT (fst expr) } | LBRACE init = initializer_list RBRACE - { COMPOUND_INIT (rev' init) } + { Cabs.COMPOUND_INIT (rev' init) } | LBRACE init = initializer_list COMMA RBRACE - { COMPOUND_INIT (rev' init) } + { Cabs.COMPOUND_INIT (rev' init) } initializer_list: | design = designation init = c_initializer @@ -738,9 +745,9 @@ designator_list: designator: | LBRACK expr = constant_expression RBRACK - { ATINDEX_INIT (fst expr) } + { Cabs.ATINDEX_INIT (fst expr) } | DOT id = OTHER_NAME - { INFIELD_INIT (fst id) } + { Cabs.INFIELD_INIT (fst id) } (* 6.8 *) statement_dangerous: @@ -768,18 +775,18 @@ statement_safe: (* 6.8.1 *) labeled_statement(last_statement): | lbl = OTHER_NAME COLON stmt = last_statement - { LABEL (fst lbl) stmt (snd lbl) } + { Cabs.LABEL (fst lbl) stmt (snd lbl) } | loc = CASE expr = constant_expression COLON stmt = last_statement - { CASE (fst expr) stmt loc } + { Cabs.CASE (fst expr) stmt loc } | loc = DEFAULT COLON stmt = last_statement - { DEFAULT stmt loc } + { Cabs.DEFAULT stmt loc } (* 6.8.2 *) compound_statement: | loc = LBRACE lst = block_item_list RBRACE - { BLOCK (rev' lst) loc } + { Cabs.BLOCK (rev' lst) loc } | loc = LBRACE RBRACE - { BLOCK [] loc } + { Cabs.BLOCK [] loc } block_item_list: | stmt = block_item @@ -789,93 +796,103 @@ block_item_list: block_item: | decl = declaration - { DEFINITION decl } + { Cabs.DEFINITION decl } | stmt = statement_dangerous { stmt } (* Non-standard *) | p = PRAGMA - { DEFINITION (PRAGMA (fst p) (snd p)) } + { Cabs.DEFINITION (Cabs.PRAGMA (fst p) (snd p)) } (* 6.8.3 *) expression_statement: | expr = expression SEMICOLON - { COMPUTATION (fst expr) (snd expr) } + { Cabs.COMPUTATION (fst expr) (snd expr) } | loc = SEMICOLON - { NOP loc } + { Cabs.NOP loc } (* 6.8.4 *) selection_statement_dangerous: -| loc = IF LPAREN expr = expression RPAREN stmt = statement_dangerous - { If (fst expr) stmt None loc } -| loc = IF LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE stmt2 = statement_dangerous - { If (fst expr) stmt1 (Some stmt2) loc } +| loc = IF_ LPAREN expr = expression RPAREN stmt = statement_dangerous + { Cabs.If (fst expr) stmt None loc } +| loc = IF_ LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE + stmt2 = statement_dangerous + { Cabs.If (fst expr) stmt1 (Some stmt2) loc } | loc = SWITCH LPAREN expr = expression RPAREN stmt = statement_dangerous - { SWITCH (fst expr) stmt loc } + { Cabs.SWITCH (fst expr) stmt loc } selection_statement_safe: -| loc = IF LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE stmt2 = statement_safe - { If (fst expr) stmt1 (Some stmt2) loc } +| loc = IF_ LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE + stmt2 = statement_safe + { Cabs.If (fst expr) stmt1 (Some stmt2) loc } | loc = SWITCH LPAREN expr = expression RPAREN stmt = statement_safe - { SWITCH (fst expr) stmt loc } + { Cabs.SWITCH (fst expr) stmt loc } (* 6.8.5 *) iteration_statement(last_statement): | loc = WHILE LPAREN expr = expression RPAREN stmt = last_statement - { WHILE (fst expr) stmt loc } + { Cabs.WHILE (fst expr) stmt loc } | loc = DO stmt = statement_dangerous WHILE LPAREN expr = expression RPAREN SEMICOLON - { DOWHILE (fst expr) stmt loc } -| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON expr3 = expression RPAREN stmt = last_statement - { FOR (Some (FC_EXP (fst expr1))) (Some (fst expr2)) (Some (fst expr3)) stmt loc } -| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON expr3 = expression RPAREN stmt = last_statement - { FOR (Some (FC_DECL decl1)) (Some (fst expr2)) (Some (fst expr3)) stmt loc } -| loc = FOR LPAREN SEMICOLON expr2 = expression SEMICOLON expr3 = expression RPAREN stmt = last_statement - { FOR None (Some (fst expr2)) (Some (fst expr3)) stmt loc } -| loc = FOR LPAREN expr1 = expression SEMICOLON SEMICOLON expr3 = expression RPAREN stmt = last_statement - { FOR (Some (FC_EXP (fst expr1))) None (Some (fst expr3)) stmt loc } -| loc = FOR LPAREN decl1 = declaration SEMICOLON expr3 = expression RPAREN stmt = last_statement - { FOR (Some (FC_DECL decl1)) None (Some (fst expr3)) stmt loc } + { Cabs.DOWHILE (fst expr) stmt loc } +| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON + expr3 = expression RPAREN stmt = last_statement + { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) (Some (fst expr2)) (Some (fst expr3)) stmt loc } +| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON + expr3 = expression RPAREN stmt = last_statement + { Cabs.FOR (Some (Cabs.FC_DECL decl1)) (Some (fst expr2)) (Some (fst expr3)) stmt loc } +| loc = FOR LPAREN SEMICOLON expr2 = expression SEMICOLON expr3 = expression RPAREN + stmt = last_statement + { Cabs.FOR None (Some (fst expr2)) (Some (fst expr3)) stmt loc } +| loc = FOR LPAREN expr1 = expression SEMICOLON SEMICOLON expr3 = expression RPAREN + stmt = last_statement + { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) None (Some (fst expr3)) stmt loc } +| loc = FOR LPAREN decl1 = declaration SEMICOLON expr3 = expression RPAREN + stmt = last_statement + { Cabs.FOR (Some (Cabs.FC_DECL decl1)) None (Some (fst expr3)) stmt loc } | loc = FOR LPAREN SEMICOLON SEMICOLON expr3 = expression RPAREN stmt = last_statement - { FOR None None (Some (fst expr3)) stmt loc } -| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON RPAREN stmt = last_statement - { FOR (Some (FC_EXP (fst expr1))) (Some (fst expr2)) None stmt loc } -| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON RPAREN stmt = last_statement - { FOR (Some (FC_DECL decl1)) (Some (fst expr2)) None stmt loc } + { Cabs.FOR None None (Some (fst expr3)) stmt loc } +| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON RPAREN + stmt = last_statement + { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) (Some (fst expr2)) None stmt loc } +| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON RPAREN + stmt = last_statement + { Cabs.FOR (Some (Cabs.FC_DECL decl1)) (Some (fst expr2)) None stmt loc } | loc = FOR LPAREN SEMICOLON expr2 = expression SEMICOLON RPAREN stmt = last_statement - { FOR None (Some (fst expr2)) None stmt loc } + { Cabs.FOR None (Some (fst expr2)) None stmt loc } | loc = FOR LPAREN expr1 = expression SEMICOLON SEMICOLON RPAREN stmt = last_statement - { FOR (Some (FC_EXP (fst expr1))) None None stmt loc } + { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) None None stmt loc } | loc = FOR LPAREN decl1 = declaration SEMICOLON RPAREN stmt = last_statement - { FOR (Some (FC_DECL decl1)) None None stmt loc } + { Cabs.FOR (Some (Cabs.FC_DECL decl1)) None None stmt loc } | loc = FOR LPAREN SEMICOLON SEMICOLON RPAREN stmt = last_statement - { FOR None None None stmt loc } + { Cabs.FOR None None None stmt loc } (* 6.8.6 *) jump_statement: | loc = GOTO id = OTHER_NAME SEMICOLON - { GOTO (fst id) loc } + { Cabs.GOTO (fst id) loc } | loc = CONTINUE SEMICOLON - { CONTINUE loc } + { Cabs.CONTINUE loc } | loc = BREAK SEMICOLON - { BREAK loc } + { Cabs.BREAK loc } | loc = RETURN expr = expression SEMICOLON - { RETURN (Some (fst expr)) loc } + { Cabs.RETURN (Some (fst expr)) loc } | loc = RETURN SEMICOLON - { RETURN None loc } + { Cabs.RETURN None loc } (* Non-standard *) asm_statement: -| loc = ASM attr = asm_attributes LPAREN template = STRING_LITERAL args = asm_arguments RPAREN SEMICOLON +| loc = ASM attr = asm_attributes LPAREN template = STRING_LITERAL args = asm_arguments + RPAREN SEMICOLON { let '(wide, chars, _) := template in let '(outputs, inputs, flags) := args in - ASM attr wide chars outputs inputs flags loc } + Cabs.ASM attr wide chars outputs inputs flags loc } asm_attributes: | /* empty */ { [] } | CONST attr = asm_attributes - { CV_CONST :: attr } + { Cabs.CV_CONST :: attr } | VOLATILE attr = asm_attributes - { CV_VOLATILE :: attr } + { Cabs.CV_VOLATILE :: attr } asm_arguments: | /* empty */ @@ -897,7 +914,7 @@ asm_operands_ne: asm_operand: | n = asm_op_name cstr = STRING_LITERAL LPAREN e = expression RPAREN - { let '(wide, s, loc) := cstr in ASMOPERAND n wide s (fst e) } + { let '(wide, s, loc) := cstr in Cabs.ASMOPERAND n wide s (fst e) } asm_op_name: | /* empty */ { None } @@ -934,7 +951,7 @@ external_declaration: { def } (* Non-standard *) | p = PRAGMA - { PRAGMA (fst p) (snd p) } + { Cabs.PRAGMA (fst p) (snd p) } (* 6.9.1 *) @@ -943,11 +960,11 @@ function_definition: decl = declarator_noattrend dlist = declaration_list stmt = compound_statement - { FUNDEF (fst specs) decl (List.rev' dlist) stmt (snd specs) } + { Cabs.FUNDEF (fst specs) decl (List.rev' dlist) stmt (snd specs) } | specs = declaration_specifiers decl = declarator stmt = compound_statement - { FUNDEF (fst specs) decl [] stmt (snd specs) } + { Cabs.FUNDEF (fst specs) decl [] stmt (snd specs) } declaration_list: | d = declaration diff --git a/cparser/Rename.ml b/cparser/Rename.ml index eb31eaf0..64412194 100644 --- a/cparser/Rename.ml +++ b/cparser/Rename.ml @@ -246,7 +246,7 @@ let rec globdecls env accu = function (* Reserve names of builtins *) let reserve_builtins () = - List.fold_left enter_public empty_env (Builtins.identifiers()) + List.fold_left enter_public empty_env (Env.initial_identifiers()) (* Reserve global declarations with public visibility *) diff --git a/cparser/Transform.ml b/cparser/Transform.ml index 0a2ce3bb..349a3155 100644 --- a/cparser/Transform.ml +++ b/cparser/Transform.ml @@ -227,4 +227,4 @@ let program in transf_globdecls env' ({g with gdesc = desc'} :: accu) gl - in transf_globdecls (Builtins.environment()) [] p + in transf_globdecls (Env.initial()) [] p diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index 66b497cc..d25f70c6 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -399,4 +399,4 @@ let rec unblock_glob env accu = function let program p = next_scope_id := 0; {gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} :: - unblock_glob (Builtins.environment()) [] p + unblock_glob (Env.initial()) [] p diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly index 71eaf419..669ecf5e 100644 --- a/cparser/pre_parser.mly +++ b/cparser/pre_parser.mly @@ -43,13 +43,13 @@ %} %token<string> PRE_NAME -%token<string * Pre_parser_aux.identifier_type ref * Cabs.cabsloc> +%token<string * Pre_parser_aux.identifier_type ref * Cabs.loc> VAR_NAME TYPEDEF_NAME -%token<Cabs.constant * Cabs.cabsloc> CONSTANT -%token<bool * int64 list * Cabs.cabsloc> STRING_LITERAL -%token<string * Cabs.cabsloc> PRAGMA +%token<Cabs.constant * Cabs.loc> CONSTANT +%token<bool * int64 list * Cabs.loc> STRING_LITERAL +%token<string * Cabs.loc> PRAGMA -%token<Cabs.cabsloc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT +%token<Cabs.loc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT ANDAND BARBAR PLUS MINUS STAR TILDE BANG SLASH PERCENT HAT BAR QUESTION COLON AND MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN LEFT_ASSIGN RIGHT_ASSIGN AND_ASSIGN XOR_ASSIGN OR_ASSIGN LPAREN RPAREN LBRACK RBRACK diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index 3498a779..f9684355 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -123,7 +123,7 @@ let insert_type ty = | TNamed (id,_) -> let typ = try let _,t = - List.find (fun a -> fst a = id.name) CBuiltins.builtins.Builtins.typedefs in + List.find (fun a -> fst a = id.name) CBuiltins.builtins.builtin_typedefs in Some (attr_aux t) with Not_found -> None in let t = { diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml index bbfcf311..9a24041b 100644 --- a/debug/DwarfPrinter.ml +++ b/debug/DwarfPrinter.ml @@ -268,7 +268,7 @@ module DwarfPrinter(Target: DWARF_TARGET): (* Print the debug_abbrev section using the previous computed abbreviations*) let print_abbrev oc = let abbrevs = Hashtbl.fold (fun s i acc -> (s,i)::acc) abbrev_mapping [] in - let abbrevs = List.sort (fun (_,a) (_,b) -> Pervasives.compare a b) abbrevs in + let abbrevs = List.sort (fun (_,a) (_,b) -> compare a b) abbrevs in section oc Section_debug_abbrev; print_label oc !abbrev_start_addr; List.iter (fun (s,id) -> @@ -685,7 +685,7 @@ module DwarfPrinter(Target: DWARF_TARGET): print_label oc line_start; list_opt s (fun () -> section oc Section_debug_str; - let s = List.sort (fun (a,_) (b,_) -> Pervasives.compare a b) s in + let s = List.sort (fun (a,_) (b,_) -> compare a b) s in List.iter (fun (id,s) -> print_label oc (loc_to_label id); fprintf oc " .asciz %S\n" s) s) diff --git a/doc/ccomp.1 b/doc/ccomp.1 index 7ccf97c8..f4919867 100644 --- a/doc/ccomp.1 +++ b/doc/ccomp.1 @@ -125,7 +125,8 @@ Enabled by default. .TP .B \-O0 Turn off most optimizations. -Synonymous to \fB\-fno\-const\-prop\fP \fB\-fno\-cse\fP \fB\-fno\-redundancy\fP \fB\-fno\-tailcalls\fP. +Synonymous to \fB\-fno\-const\-prop\fP \fB\-fno\-cse\fP \fB\-fno\-if\-conversion\fP +\fB\-fno\-inline\fP \fB\-fno\-redundancy\fP \fB\-fno\-tailcalls\fP. . .TP .BR \-O1 ", " \-O2 ", " \-O3 @@ -136,6 +137,13 @@ Synonymous for \fB\-O\fP. Optimize for code size in preference to code speed. . .TP +.B \-Obranchless +Optimize to generate fewer conditional branches and use branch-free +instruction sequences instead. When \fB-fif\-conversion\fP is +enabled, the conversion is peformed aggressively even if the resulting +code is less performant. +. +.TP .BR \-fconst\-prop ", " \-fno\-const\-prop Turn on/off global constant propagation. Enabled by default. @@ -146,6 +154,11 @@ Turn on/off common subexpression elimination. Enabled by default. . .TP +.BR \-fif\-conversion ", " \-fno\-if\-conversion +Turn on/off generation of conditional moves. +Enabled by default. +. +.TP .BR \-finline ", " \-fno\-inline Turn on/off inlining of functions. Enabled by default. @@ -433,6 +446,11 @@ Enabled by default. Declarations which do not declare anything. Enabled by default. .sp +\fInon\-linear\-cond\-expr\fP: +Conditional expression that may not be optimized to branchless code. +Only issued in \fB-Obranchless\fP mode. +Disabled by default. +.sp \fIpointer\-type\-mismatch\fP: Use of incompatible pointer types in conditional expressions. Enabled by default. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 00bbc4d5..cf1220d1 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -30,7 +30,7 @@ let option_fredundancy = ref true let option_fpostpass = ref true let option_fpostpass_sched = ref "list" let option_fifconversion = ref true -let option_ffavor_branchless = ref false +let option_Obranchless = ref false let option_falignfunctions = ref (None: int option) let option_falignbranchtargets = ref 0 let option_faligncondbranchs = ref 0 diff --git a/driver/Driver.ml b/driver/Driver.ml index 9748ebf6..05d51402 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -188,6 +188,8 @@ Processing options: -O1 Perform all optimization passes except scheduling -O2 -O3 Synonymous for -O -Os Optimize for code size in preference to code speed + -Obranchless Optimize to generate fewer conditional branches; try to produce + branch-free instruction sequences as much as possible -ftailcalls Optimize function calls in tail position [on] -fconst-prop Perform global constant propagation [on] -ffloat-const-prop <n> Control constant propagation of floats @@ -201,8 +203,6 @@ Processing options: -finline-functions-called-once Integrate functions only required by their single caller [on] -fif-conversion Perform if-conversion (generation of conditional moves) [on] - -ffavor-branchless Favor the generation of branch-free instruction sequences, - even when possibly more costly than the default [off] Code generation options: (use -fno-<opt> to turn off -f<opt>) -ffpu Use FP registers for some integer operations [on] -fsmall-data <n> Set maximal size <n> for allocation in small data area @@ -258,7 +258,11 @@ let dump_mnemonics destfile = let optimization_options = [ option_ftailcalls; option_fifconversion; option_fconstprop; option_fcse; +<<<<<<< HEAD option_fpostpass; option_fredundancy; option_finline_functions_called_once; +======= + option_fredundancy; option_finline; option_finline_functions_called_once; +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf ] let set_all opts () = List.iter (fun r -> r := true) opts @@ -312,10 +316,10 @@ let cmdline_actions = _Regexp "-O1", Self (fun _ -> set_all optimization_options (); option_fpostpass := false); _Regexp "-O[123]$", Unit (set_all optimization_options); Exact "-Os", Set option_Osize; + Exact "-Obranchless", Set option_Obranchless; Exact "-fsmall-data", Integer(fun n -> option_small_data := n); Exact "-fsmall-const", Integer(fun n -> option_small_const := n); Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n); - Exact "-ffavor-branchless", Set option_ffavor_branchless; Exact "-falign-functions", Integer(fun n -> check_align n; option_falignfunctions := Some n); Exact "-falign-branch-targets", Integer(fun n -> check_align n; option_falignbranchtargets := n); Exact "-falign-cond-branches", Integer(fun n -> check_align n; option_faligncondbranchs := n);] @ diff --git a/driver/Frontend.ml b/driver/Frontend.ml index d7162865..2584db90 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -119,7 +119,7 @@ let init () = | "mppa_k1c" -> Machine.mppa_k1c | _ -> assert false end; - Builtins.set C2C.builtins; + Env.set_builtins C2C.builtins; Cutil.declare_attributes C2C.attributes; CPragmas.initialize() diff --git a/driver/Interp.ml b/driver/Interp.ml index 6760e76c..a6841460 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -15,7 +15,7 @@ open Format open Camlcoq open AST -open Integers +open !Integers open Values open Memory open Globalenvs @@ -145,7 +145,7 @@ let print_state p (prog, ge, s) = let compare_mem m1 m2 = (* assumes nextblocks were already compared equal *) (* should permissions be taken into account? *) - Pervasives.compare m1.Mem.mem_contents m2.Mem.mem_contents + compare m1.Mem.mem_contents m2.Mem.mem_contents (* Comparing continuations *) diff --git a/exportclight/Clightgen.ml b/exportclight/Clightgen.ml index 1eb4fe03..4209975a 100644 --- a/exportclight/Clightgen.ml +++ b/exportclight/Clightgen.ml @@ -45,12 +45,7 @@ let compile_c_ast sourcename csyntax ofile = | Errors.Error msg -> fatal_error loc "%a" print_error msg in (* Dump Clight in C syntax if requested *) - if !option_dclight then begin - let ofile = Filename.chop_suffix sourcename ".c" ^ ".light.c" in - let oc = open_out ofile in - PrintClight.print_program (Format.formatter_of_out_channel oc) clight; - close_out oc - end; + PrintClight.print_if clight; (* Print Clight in Coq syntax *) let oc = open_out ofile in ExportClight.print_program (Format.formatter_of_out_channel oc) @@ -60,6 +55,12 @@ let compile_c_ast sourcename csyntax ofile = (* From C source to Clight *) let compile_c_file sourcename ifile ofile = + let set_dest dst opt ext = + dst := if !opt then Some (output_filename sourcename ".c" ext) + else None in + set_dest Cprint.destination option_dparse ".parsed.c"; + set_dest PrintCsyntax.destination option_dcmedium ".compcert.c"; + set_dest PrintClight.destination option_dclight ".light.c"; compile_c_ast sourcename (parse_c_file sourcename ifile) ofile let output_filename sourcename suff = @@ -74,7 +75,10 @@ let process_c_file sourcename = if !option_E then begin preprocess sourcename "-" end else begin - let preproname = Driveraux.tmp_file ".i" in + let preproname = if !option_dprepro then + Driveraux.output_filename sourcename ".c" ".i" + else + Driveraux.tmp_file ".i" in preprocess sourcename preproname; compile_c_file sourcename preproname ofile end @@ -100,9 +104,11 @@ Processing options: prepro_help ^ language_support_help ^ {|Tracing options: + -dprepro Save C file after preprocessing in <file>.i -dparse Save C file after parsing and elaboration in <file>.parsed.c -dc Save generated Compcert C in <file>.compcert.c -dclight Save generated Clight in <file>.light.c + -dall Save all generated intermediate files in <file>.<ext> |} ^ general_help ^ warning_help @@ -142,9 +148,16 @@ let cmdline_actions = (* Preprocessing options *) @ prepro_actions @ (* Tracing options *) - [ Exact "-dparse", Set option_dparse; - Exact "-dc", Set option_dcmedium; - Exact "-dclight", Set option_dclight;] + [ Exact "-dprepro", Set option_dprepro; + Exact "-dparse", Set option_dparse; + Exact "-dc", Set option_dcmedium; + Exact "-dclight", Set option_dclight; + Exact "-dall", Self (fun _ -> + option_dprepro := true; + option_dparse := true; + option_dcmedium := true; + option_dclight := true;); + ] @ general_options (* Diagnostic options *) @ warning_options diff --git a/extraction/extraction.v b/extraction/extraction.v index 265a5967..5a1ca0be 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -34,8 +34,11 @@ Require Clight. Require Compiler. Require Parser. Require Initializers. +<<<<<<< HEAD Require Int31. Require Asmaux. +======= +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf (* Standard lib *) Require Import ExtrOcamlBasic. @@ -141,7 +144,7 @@ Extract Constant Compiler.time => "Timing.time_coq". (*Extraction Inline Compiler.apply_total Compiler.apply_partial.*) (* Cabs *) -Extract Constant Cabs.cabsloc => +Extract Constant Cabs.loc => "{ lineno : int; filename: string; byteno: int; @@ -150,15 +153,6 @@ Extract Constant Cabs.cabsloc => Extract Inlined Constant Cabs.string => "String.t". Extract Constant Cabs.char_code => "int64". -(* Int31 *) -Extract Inductive Int31.digits => "bool" [ "false" "true" ]. -Extract Inductive Int31.int31 => "int" [ "Camlcoq.Int31.constr" ] "Camlcoq.Int31.destr". -Extract Constant Int31.twice => "Camlcoq.Int31.twice". -Extract Constant Int31.twice_plus_one => "Camlcoq.Int31.twice_plus_one". -Extract Constant Int31.compare31 => "Camlcoq.Int31.compare". -Extract Constant Int31.On => "0". -Extract Constant Int31.In => "1". - (* Processor-specific extraction directives *) Load extractionMachdep. @@ -185,9 +179,10 @@ Separate Extraction Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env Initializers.transl_init Initializers.constval - Csyntax.Eindex Csyntax.Epreincr + Csyntax.Eindex Csyntax.Epreincr Csyntax.Eselection Ctyping.typecheck_program Ctyping.epostincr Ctyping.epostdecr Ctyping.epreincr Ctyping.epredecr + Ctyping.eselection Ctypes.make_program Clight.type_of_function Conventions1.callee_save_type Conventions1.is_float_reg diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v index 0ec3a297..ac38c761 100644 --- a/flocq/IEEE754/Binary.v +++ b/flocq/IEEE754/Binary.v @@ -1839,6 +1839,127 @@ now rewrite <- cond_Zopp_negb. now destruct y as [ | | | ]. Qed. +(** Fused Multiply-Add *) + +Definition Bfma_szero m (x y z: binary_float) : bool := + let s_xy := xorb (Bsign x) (Bsign y) in (* sign of product x*y *) + if Bool.eqb s_xy (Bsign z) then s_xy + else match m with mode_DN => true | _ => false end. + +Definition Bfma fma_nan m (x y z: binary_float) := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ + | B754_infinity _, B754_zero _ + | B754_zero _, B754_infinity _ => + (* Multiplication produces NaN *) + build_nan (fma_nan x y z) + | B754_infinity sx, B754_infinity sy + | B754_infinity sx, B754_finite sy _ _ _ + | B754_finite sx _ _ _, B754_infinity sy => + let s := xorb sx sy in + (* Multiplication produces infinity with sign [s] *) + match z with + | B754_nan _ _ _ => build_nan (fma_nan x y z) + | B754_infinity sz => + if Bool.eqb s sz then z else build_nan (fma_nan x y z) + | _ => B754_infinity s + end + | B754_finite sx _ _ _, B754_zero sy + | B754_zero sx, B754_finite sy _ _ _ + | B754_zero sx, B754_zero sy => + (* Multiplication produces zero *) + match z with + | B754_nan _ _ _ => build_nan (fma_nan x y z) + | B754_zero _ => B754_zero (Bfma_szero m x y z) + | _ => z + end + | B754_finite sx mx ex _, B754_finite sy my ey _ => + (* Multiplication produces a finite, non-zero result *) + match z with + | B754_nan _ _ _ => build_nan (fma_nan x y z) + | B754_infinity sz => z + | B754_zero _ => + let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in + let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in + let '(Float _ mr er) := Fmult X Y in + binary_normalize m mr er (Bfma_szero m x y z) + | B754_finite sz mz ez _ => + let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in + let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in + let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in + let '(Float _ mr er) := Fplus (Fmult X Y) Z in + binary_normalize m mr er (Bfma_szero m x y z) + end + end. + +Theorem Bfma_correct: + forall fma_nan m x y z, + let res := (B2R x * B2R y + B2R z)%R in + is_finite x = true -> + is_finite y = true -> + is_finite z = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then + B2R (Bfma fma_nan m x y z) = round radix2 fexp (round_mode m) res /\ + is_finite (Bfma fma_nan m x y z) = true /\ + Bsign (Bfma fma_nan m x y z) = + match Rcompare res 0 with + | Eq => Bfma_szero m x y z + | Lt => true + | Gt => false + end + else + B2FF (Bfma fma_nan m x y z) = binary_overflow m (Rlt_bool res 0). +Proof. + intros. pattern (Bfma fma_nan m x y z). + match goal with |- ?p ?x => set (PROP := p) end. + set (szero := Bfma_szero m x y z). + assert (BINORM: forall mr er, F2R (Float radix2 mr er) = res -> + PROP (binary_normalize m mr er szero)). + { intros mr er E. + specialize (binary_normalize_correct m mr er szero). + change (FLT_exp (3 - emax - prec) prec) with fexp. rewrite E. tauto. + } + set (add_zero := + match z with + | B754_nan _ _ _ => build_nan (fma_nan x y z) + | B754_zero sz => B754_zero szero + | _ => z + end). + assert (ADDZERO: B2R x = 0%R \/ B2R y = 0%R -> PROP add_zero). + { + intros Z. + assert (RES: res = B2R z). + { unfold res. destruct Z as [E|E]; rewrite E, ?Rmult_0_l, ?Rmult_0_r, Rplus_0_l; auto. } + unfold PROP, add_zero; destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate. + - simpl in RES; rewrite RES; rewrite round_0 by apply valid_rnd_round_mode. + rewrite Rlt_bool_true. split. reflexivity. split. reflexivity. + rewrite Rcompare_Eq by auto. reflexivity. + rewrite Rabs_R0; apply bpow_gt_0. + - rewrite RES, round_generic, Rlt_bool_true. + split. reflexivity. split. reflexivity. + unfold B2R. destruct sz. + rewrite Rcompare_Lt. auto. apply F2R_lt_0. reflexivity. + rewrite Rcompare_Gt. auto. apply F2R_gt_0. reflexivity. + apply abs_B2R_lt_emax. apply valid_rnd_round_mode. apply generic_format_B2R. + } + destruct x as [ sx | sx | sx plx | sx mx ex Bx]; + destruct y as [ sy | sy | sy ply | sy my ey By]; + try discriminate. +- apply ADDZERO; auto. +- apply ADDZERO; auto. +- apply ADDZERO; auto. +- destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate; unfold Bfma. ++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex). + set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey). + destruct (Fmult X Y) as [mr er] eqn:FRES. + apply BINORM. unfold res. rewrite <- FRES, F2R_mult, Rplus_0_r. auto. ++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex). + set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey). + set (Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez). + destruct (Fplus (Fmult X Y) Z) as [mr er] eqn:FRES. + apply BINORM. unfold res. rewrite <- FRES, F2R_plus, F2R_mult. auto. +Qed. + (** Division *) Definition Fdiv_core_binary m1 e1 m2 e2 := diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index d94e3582..66322efb 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -335,54 +335,3 @@ let coqfloat32_of_camlfloat f = Float32.of_bits(coqint_of_camlint(Int32.bits_of_float f)) let camlfloat_of_coqfloat32 f = Int32.float_of_bits(camlint_of_coqint(Float32.to_bits f)) - -(* Int31 *) - -module Int31 = struct - -(* -let constr (b30,b29,b28,b27,b26,b25,b24, - b23,b22,b21,b20,b19,b18,b17,b16, - b15,b14,b13,b12,b11,b10,b9,b8, - b7,b6,b5,b4,b3,b2,b1,b0) = - let f i b accu = if b then accu + (1 lsl i) else accu in - f 30 b30 (f 29 b29 (f 28 b28 (f 27 b27 (f 26 b26 (f 25 b25 (f 24 b24 - (f 23 b23 (f 22 b22 (f 21 b21 (f 20 b20 (f 19 b19 (f 18 b18 (f 17 b17 (f 16 b16 - (f 15 b15 (f 14 b14 (f 13 b13 (f 12 b12 (f 11 b11 (f 10 b10 (f 9 b9 (f 8 b8 - (f 7 b7 (f 6 b6 (f 5 b5 (f 4 b4 (f 3 b3 (f 2 b2 (f 1 b1 (f 0 b0 0)))))))))))))))))))))))))))))) -*) - -let constr (b30,b29,b28,b27,b26,b25,b24, - b23,b22,b21,b20,b19,b18,b17,b16, - b15,b14,b13,b12,b11,b10,b9,b8, - b7,b6,b5,b4,b3,b2,b1,b0) = - let f i b = if b then 1 lsl i else 0 in - f 30 b30 + f 29 b29 + f 28 b28 + f 27 b27 + f 26 b26 + f 25 b25 + f 24 b24 + - f 23 b23 + f 22 b22 + f 21 b21 + f 20 b20 + f 19 b19 + f 18 b18 + f 17 b17 + f 16 b16 + - f 15 b15 + f 14 b14 + f 13 b13 + f 12 b12 + f 11 b11 + f 10 b10 + f 9 b9 + f 8 b8 + - f 7 b7 + f 6 b6 + f 5 b5 + f 4 b4 + f 3 b3 + f 2 b2 + f 1 b1 + f 0 b0 - -let destr f n = - let b i = n land (1 lsl i) <> 0 in - f (b 30) (b 29) (b 28) (b 27) (b 26) (b 25) (b 24) - (b 23) (b 22) (b 21) (b 20) (b 19) (b 18) (b 17) (b 16) - (b 15) (b 14) (b 13) (b 12) (b 11) (b 10) (b 9) (b 8) - (b 7) (b 6) (b 5) (b 4) (b 3) (b 2) (b 1) (b 0) - -let twice n = - (n lsl 1) land 0x7FFFFFFF - -let twice_plus_one n = - ((n lsl 1) land 0x7FFFFFFF) lor 1 - -let compare (x:int) (y:int) = - if x = y then Datatypes.Eq - else begin - let sx = x < 0 and sy = y < 0 in - if sx = sy then - (if x < y then Datatypes.Lt else Datatypes.Gt) - else - (if sx then Datatypes.Gt else Datatypes.Lt) - end - -end diff --git a/lib/Floats.v b/lib/Floats.v index 9540303b..7677e3c8 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -24,6 +24,7 @@ Require Import Program. Require Archi. Close Scope R_scope. +Open Scope Z_scope. Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *) Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *) @@ -93,17 +94,49 @@ Proof. destruct x as [[]|]; simpl; intros; discriminate. Qed. -(** Relation between number of bits and base-2 logarithm *) +(** Normalization of NaN payloads *) -Lemma digits2_log2: - forall p, Z.pos (Digits.digits2_pos p) = Z.succ (Z.log2 (Z.pos p)). +Lemma normalized_nan: forall prec n p, + Z.of_nat n = prec - 1 -> 1 < prec -> + nan_pl prec (Z.to_pos (P_mod_two_p p n)) = true. Proof. - assert (E: forall p, Digits.digits2_pos p = Pos.size p). - { induction p; simpl; rewrite ?IHp; auto. } - intros p. rewrite E. - destruct p; simpl; rewrite ?Pos.add_1_r; reflexivity. + intros. unfold nan_pl. apply Z.ltb_lt. rewrite Digits.Zpos_digits2_pos. + set (p' := P_mod_two_p p n). + assert (A: 0 <= p' < 2 ^ Z.of_nat n). + { rewrite <- two_power_nat_equiv; apply P_mod_two_p_range. } + assert (B: Digits.Zdigits radix2 p' <= prec - 1). + { apply Digits.Zdigits_le_Zpower. rewrite <- H. rewrite Z.abs_eq; tauto. } + destruct (zeq p' 0). +- rewrite e. simpl; auto. +- rewrite Z2Pos.id by omega. omega. Qed. +(** Transform a Nan payload to a quiet Nan payload. *) + +Definition quiet_nan_64_payload (p: positive) := + Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 51 1%positive))) 52%nat). + +Lemma quiet_nan_64_proof: forall p, nan_pl 53 (quiet_nan_64_payload p) = true. +Proof. intros; apply normalized_nan; auto; omega. Qed. + +Definition quiet_nan_64 (sp: bool * positive) : {x :float | is_nan _ _ x = true} := + let (s, p) := sp in + exist _ (B754_nan 53 1024 s (quiet_nan_64_payload p) (quiet_nan_64_proof p)) (eq_refl true). + +Definition default_nan_64 := quiet_nan_64 Archi.default_nan_64. + +Definition quiet_nan_32_payload (p: positive) := + Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 22 1%positive))) 23%nat). + +Lemma quiet_nan_32_proof: forall p, nan_pl 24 (quiet_nan_32_payload p) = true. +Proof. intros; apply normalized_nan; auto; omega. Qed. + +Definition quiet_nan_32 (sp: bool * positive) : {x :float32 | is_nan _ _ x = true} := + let (s, p) := sp in + exist _ (B754_nan 24 128 s (quiet_nan_32_payload p) (quiet_nan_32_proof p)) (eq_refl true). + +Definition default_nan_32 := quiet_nan_32 Archi.default_nan_32. + Local Notation __ := (eq_refl Datatypes.Lt). Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt). @@ -118,68 +151,44 @@ Module Float. (** The following definitions are not part of the IEEE754 standard but apply to all architectures supported by CompCert. *) -(** Transform a Nan payload to a quiet Nan payload. *) - -Lemma transform_quiet_nan_proof (p : positive) : - nan_pl 53 p = true -> - nan_pl 53 (Pos.lor p (iter_nat xO 51 1%positive)) = true. -Proof. - unfold nan_pl. intros K. - simpl. rewrite Z.ltb_lt, digits2_log2 in *. - change (Z.pos (Pos.lor p 2251799813685248)) with (Z.lor (Z.pos p) 2251799813685248%Z). - rewrite Z.log2_lor by xomega. - now apply Z.max_case. -Qed. - -Definition transform_quiet_nan s p H : {x :float | is_nan _ _ x = true} := - exist _ (B754_nan 53 1024 s _ (transform_quiet_nan_proof p H)) (eq_refl true). - (** Nan payload operations for single <-> double conversions. *) +Definition expand_nan_payload (p: positive) := Pos.shiftl_nat p 29. + Lemma expand_nan_proof (p : positive) : nan_pl 24 p = true -> - nan_pl 53 (Pos.shiftl_nat p 29) = true. + nan_pl 53 (expand_nan_payload p) = true. Proof. - unfold nan_pl. intros K. + unfold nan_pl, expand_nan_payload. intros K. rewrite Z.ltb_lt in *. unfold Pos.shiftl_nat, nat_rect, Digits.digits2_pos. fold (Digits.digits2_pos p). zify; omega. Qed. -Definition expand_nan s p H : {x | is_nan 53 1024 x = true} := - exist _ (B754_nan 53 1024 s _ (expand_nan_proof p H)) (eq_refl true). +Definition expand_nan s p H : {x | is_nan _ _ x = true} := + exist _ (B754_nan 53 1024 s (expand_nan_payload p) (expand_nan_proof p H)) (eq_refl true). Definition of_single_nan (f : float32) : { x : float | is_nan _ _ x = true } := match f with | B754_nan s p H => if Archi.float_of_single_preserves_sNaN then expand_nan s p H - else transform_quiet_nan s _ (expand_nan_proof p H) - | _ => Archi.default_nan_64 + else quiet_nan_64 (s, expand_nan_payload p) + | _ => default_nan_64 end. -Lemma reduce_nan_proof (p : positive) : - nan_pl 53 p = true -> - nan_pl 24 (Pos.shiftr_nat p 29) = true. -Proof. - unfold nan_pl. intros K. - rewrite Z.ltb_lt in *. - unfold Pos.shiftr_nat, nat_rect. - assert (H : forall x, Digits.digits2_pos (Pos.div2 x) = (Digits.digits2_pos x - 1)%positive) - by (destruct x; simpl; auto; rewrite Pplus_one_succ_r, Pos.add_sub; auto). - rewrite !H, !Pos2Z.inj_sub_max. - repeat (apply Z.max_lub_lt; [reflexivity |apply Z.lt_sub_lt_add_l]). - exact K. -Qed. - -Definition reduce_nan s p H : {x : float32 | is_nan _ _ x = true} := - exist _ (B754_nan 24 128 s _ (reduce_nan_proof p H)) (eq_refl true). +Definition reduce_nan_payload (p: positive) := + (* The [quiet_nan_64_payload p] before the right shift is redundant with + the [quiet_nan_32_payload p] performed after, in [to_single_nan]. + However the former ensures that the result of the right shift is + not 0 and therefore representable as a positive. *) + Pos.shiftr_nat (quiet_nan_64_payload p) 29. Definition to_single_nan (f : float) : { x : float32 | is_nan _ _ x = true } := match f with - | B754_nan s p H => reduce_nan s _ (transform_quiet_nan_proof p H) - | _ => Archi.default_nan_32 + | B754_nan s p H => quiet_nan_32 (s, reduce_nan_payload p) + | _ => default_nan_32 end. (** NaN payload operations for opposite and absolute value. *) @@ -187,33 +196,62 @@ Definition to_single_nan (f : float) : { x : float32 | is_nan _ _ x = true } := Definition neg_nan (f : float) : { x : float | is_nan _ _ x = true } := match f with | B754_nan s p H => exist _ (B754_nan 53 1024 (negb s) p H) (eq_refl true) - | _ => Archi.default_nan_64 + | _ => default_nan_64 end. Definition abs_nan (f : float) : { x : float | is_nan _ _ x = true } := match f with | B754_nan s p H => exist _ (B754_nan 53 1024 false p H) (eq_refl true) - | _ => Archi.default_nan_64 + | _ => default_nan_64 end. -(** The NaN payload operations for two-argument arithmetic operations - are not part of the IEEE754 standard, but all architectures of - Compcert share a similar NaN behavior, parameterized by: -- a "default" payload which occurs when an operation generates a NaN from - non-NaN arguments; -- a choice function determining which of the payload arguments to choose, - when an operation is given two NaN arguments. *) +(** When an arithmetic operation returns a NaN, the sign and payload + of this NaN are not fully specified by the IEEE standard, and vary + among the architectures supported by CompCert. However, the following + behavior applies to all the supported architectures: the payload is either +- a default payload, independent of the arguments, or +- the payload of one of the NaN arguments, if any. + +For each supported architecture, the functions [Archi.choose_nan_64] +and [Archi.choose_nan_32] determine the payload of the result as a +function of the payloads of the NaN arguments. + +Additionally, signaling NaNs are converted to quiet NaNs, as required by the standard. +*) + +Definition cons_pl (x: float) (l: list (bool * positive)) := + match x with B754_nan s p _ => (s, p) :: l | _ => l end. -Definition binop_nan (x y : float) : {x : float | is_nan 53 1024 x = true} := - if Archi.fpu_returns_default_qNaN then Archi.default_nan_64 else +Definition unop_nan (x: float) : {x : float | is_nan _ _ x = true} := + quiet_nan_64 (Archi.choose_nan_64 (cons_pl x [])). + +Definition binop_nan (x y: float) : {x : float | is_nan _ _ x = true} := + quiet_nan_64 (Archi.choose_nan_64 (cons_pl x (cons_pl y []))). + +(** For fused multiply-add, the order in which arguments are examined + to select a NaN payload varies across platforms. E.g. in [fma x y z], + x86 considers [x] first, then [y], then [z], while ARM considers [z] first, + then [x], then [y]. The corresponding permutation is defined + for each target, as function [Archi.fma_order]. *) + +Definition fma_nan_1 (x y z: float) : {x : float | is_nan _ _ x = true} := + let '(a, b, c) := Archi.fma_order x y z in + quiet_nan_64 (Archi.choose_nan_64 (cons_pl a (cons_pl b (cons_pl c [])))). + +(** One last wrinkle for fused multiply-add: [fma zero infinity nan] + can return either the quiesced [nan], or the default NaN arising out + of the invalid operation [zero * infinity]. Of our target platforms, + only ARM honors the latter case. The choice between the default NaN + and [nan] is done as in the case of two-argument arithmetic operations. *) + +Definition fma_nan (x y z: float) : {x : float | is_nan _ _ x = true} := match x, y with - | B754_nan s1 pl1 H1, B754_nan s2 pl2 H2 => - if Archi.choose_binop_pl_64 pl1 pl2 - then transform_quiet_nan s2 pl2 H2 - else transform_quiet_nan s1 pl1 H1 - | B754_nan s1 pl1 H1, _ => transform_quiet_nan s1 pl1 H1 - | _, B754_nan s2 pl2 H2 => transform_quiet_nan s2 pl2 H2 - | _, _ => Archi.default_nan_64 + | B754_infinity _, B754_zero _ | B754_zero _, B754_infinity _ => + if Archi.fma_invalid_mul_is_nan + then quiet_nan_64 (Archi.choose_nan_64 (Archi.default_nan_64 :: cons_pl z [])) + else fma_nan_1 x y z + | _, _ => + fma_nan_1 x y z end. (** ** Operations over double-precision floats *) @@ -226,6 +264,8 @@ Definition eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2} := Beq_dec _ _. Definition neg: float -> float := Bopp _ _ neg_nan. (**r opposite (change sign) *) Definition abs: float -> float := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *) +Definition sqrt: float -> float := + Bsqrt 53 1024 __ __ unop_nan mode_NE. (**r square root *) Definition add: float -> float -> float := Bplus 53 1024 __ __ binop_nan mode_NE. (**r addition *) Definition sub: float -> float -> float := @@ -234,6 +274,8 @@ Definition mul: float -> float -> float := Bmult 53 1024 __ __ binop_nan mode_NE. (**r multiplication *) Definition div: float -> float -> float := Bdiv 53 1024 __ __ binop_nan mode_NE. (**r division *) +Definition fma: float -> float -> float -> float := + Bfma 53 1024 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *) Definition compare (f1 f2: float) : option Datatypes.comparison := (**r general comparison *) Bcompare 53 1024 f1 f2. Definition cmp (c:comparison) (f1 f2: float) : bool := (**r Boolean comparison *) @@ -301,19 +343,15 @@ Ltac smart_omega := Theorem add_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x. Proof. - intros. apply Bplus_commut. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x, y; try reflexivity. - now destruct H. + intros. apply Bplus_commut. + destruct x, y; try reflexivity; now destruct H. Qed. Theorem mul_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x. Proof. - intros. apply Bmult_commut. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x, y; try reflexivity. - now destruct H. + intros. apply Bmult_commut. + destruct x, y; try reflexivity; now destruct H. Qed. (** Multiplication by 2 is diagonal addition. *) @@ -323,9 +361,8 @@ Theorem mul2_add: Proof. intros. apply Bmult2_Bplus. intros x y Hx Hy. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x as [| |sx px Nx|]; try discriminate. - now destruct y, Archi.choose_binop_pl_64. + destruct x; try discriminate. simpl. rewrite Archi.choose_nan_64_idem. + destruct y; reflexivity || discriminate. Qed. (** Divisions that can be turned into multiplication by an inverse. *) @@ -337,9 +374,8 @@ Theorem div_mul_inverse: Proof. intros. apply Bdiv_mult_inverse. 2: easy. intros x0 y0 z0 Hx Hy Hz. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x0 as [| |sx px Nx|]; try discriminate. - now destruct y0, z0. + destruct x0; try discriminate. + destruct y0, z0; reflexivity || discriminate. Qed. (** Properties of comparisons. *) @@ -413,6 +449,7 @@ Qed. to emulate the former.) *) Definition ox8000_0000 := Int.repr Int.half_modulus. (**r [0x8000_0000] *) +Definition ox7FFF_FFFF := Int.repr Int.max_signed. (**r [0x7FFF_FFFF] *) Theorem of_intu_of_int_1: forall x, @@ -443,6 +480,46 @@ Proof. compute_this (Int.unsigned ox8000_0000); smart_omega. Qed. +Theorem of_intu_of_int_3: + forall x, + of_intu x = sub (of_int (Int.and x ox7FFF_FFFF)) (of_int (Int.and x ox8000_0000)). +Proof. + intros. + set (hi := Int.and x ox8000_0000). + set (lo := Int.and x ox7FFF_FFFF). + assert (R: forall n, integer_representable 53 1024 (Int.signed n)). + { intros. pose proof (Int.signed_range n). + apply integer_representable_n; auto; smart_omega. } + unfold sub, of_int. rewrite BofZ_minus by auto. unfold of_intu. f_equal. + assert (E: Int.add hi lo = x). + { unfold hi, lo. rewrite Int.add_is_or. + - rewrite <- Int.and_or_distrib. apply Int.and_mone. + - rewrite Int.and_assoc. rewrite (Int.and_commut ox8000_0000). rewrite Int.and_assoc. + change (Int.and ox7FFF_FFFF ox8000_0000) with Int.zero. rewrite ! Int.and_zero; auto. + } + assert (RNG: 0 <= Int.unsigned lo < two_p 31). + { unfold lo. change ox7FFF_FFFF with (Int.repr (two_p 31 - 1)). rewrite <- Int.zero_ext_and by omega. + apply Int.zero_ext_range. compute_this Int.zwordsize. omega. } + assert (B: forall i, 0 <= i < Int.zwordsize -> Int.testbit ox8000_0000 i = if zeq i 31 then true else false). + { intros; unfold Int.testbit. change (Int.unsigned ox8000_0000) with (2^31). + destruct (zeq i 31). subst i; auto. apply Z.pow2_bits_false; auto. } + assert (EITHER: hi = Int.zero \/ hi = ox8000_0000). + { unfold hi; destruct (Int.testbit x 31) eqn:B31; [right|left]; + Int.bit_solve; rewrite B by auto. + - destruct (zeq i 31). subst i; rewrite B31; auto. apply andb_false_r. + - destruct (zeq i 31). subst i; rewrite B31; auto. apply andb_false_r. + } + assert (SU: - Int.signed hi = Int.unsigned hi). + { destruct EITHER as [EQ|EQ]; rewrite EQ; reflexivity. } + unfold Z.sub; rewrite SU, <- E. + unfold Int.add; rewrite Int.unsigned_repr, Int.signed_eq_unsigned. omega. + - assert (Int.max_signed = two_p 31 - 1) by reflexivity. omega. + - assert (Int.unsigned hi = 0 \/ Int.unsigned hi = two_p 31) + by (destruct EITHER as [EQ|EQ]; rewrite EQ; [left|right]; reflexivity). + assert (Int.max_unsigned = two_p 31 + two_p 31 - 1) by reflexivity. + omega. +Qed. + Theorem to_intu_to_int_1: forall x n, cmp Clt x (of_intu ox8000_0000) = true -> @@ -918,44 +995,39 @@ End Float. Module Float32. -(** ** NaN payload manipulations *) - -Lemma transform_quiet_nan_proof (p : positive) : - nan_pl 24 p = true -> - nan_pl 24 (Pos.lor p (iter_nat xO 22 1%positive)) = true. -Proof. - unfold nan_pl. intros K. - simpl. rewrite Z.ltb_lt, digits2_log2 in *. - change (Z.pos (Pos.lor p 4194304)) with (Z.lor (Z.pos p) 4194304%Z). - rewrite Z.log2_lor by xomega. - now apply Z.max_case. -Qed. - -Definition transform_quiet_nan s p H : {x : float32 | is_nan _ _ x = true} := - exist _ (B754_nan 24 128 s _ (transform_quiet_nan_proof p H)) (eq_refl true). - Definition neg_nan (f : float32) : { x : float32 | is_nan _ _ x = true } := match f with | B754_nan s p H => exist _ (B754_nan 24 128 (negb s) p H) (eq_refl true) - | _ => Archi.default_nan_32 + | _ => default_nan_32 end. Definition abs_nan (f : float32) : { x : float32 | is_nan _ _ x = true } := match f with | B754_nan s p H => exist _ (B754_nan 24 128 false p H) (eq_refl true) - | _ => Archi.default_nan_32 + | _ => default_nan_32 end. -Definition binop_nan (x y : float32) : {x : float32 | is_nan _ _ x = true} := - if Archi.fpu_returns_default_qNaN then Archi.default_nan_32 else +Definition cons_pl (x: float32) (l: list (bool * positive)) := + match x with B754_nan s p _ => (s, p) :: l | _ => l end. + +Definition unop_nan (x: float32) : {x : float32 | is_nan _ _ x = true} := + quiet_nan_32 (Archi.choose_nan_32 (cons_pl x [])). + +Definition binop_nan (x y: float32) : {x : float32 | is_nan _ _ x = true} := + quiet_nan_32 (Archi.choose_nan_32 (cons_pl x (cons_pl y []))). + +Definition fma_nan_1 (x y z: float32) : {x : float32 | is_nan _ _ x = true} := + let '(a, b, c) := Archi.fma_order x y z in + quiet_nan_32 (Archi.choose_nan_32 (cons_pl a (cons_pl b (cons_pl c [])))). + +Definition fma_nan (x y z: float32) : {x : float32 | is_nan _ _ x = true} := match x, y with - | B754_nan s1 pl1 H1, B754_nan s2 pl2 H2 => - if Archi.choose_binop_pl_32 pl1 pl2 - then transform_quiet_nan s2 pl2 H2 - else transform_quiet_nan s1 pl1 H1 - | B754_nan s1 pl1 H1, _ => transform_quiet_nan s1 pl1 H1 - | _, B754_nan s2 pl2 H2 => transform_quiet_nan s2 pl2 H2 - | _, _ => Archi.default_nan_32 + | B754_infinity _, B754_zero _ | B754_zero _, B754_infinity _ => + if Archi.fma_invalid_mul_is_nan + then quiet_nan_32 (Archi.choose_nan_32 (Archi.default_nan_32 :: cons_pl z [])) + else fma_nan_1 x y z + | _, _ => + fma_nan_1 x y z end. (** ** Operations over single-precision floats *) @@ -968,6 +1040,8 @@ Definition eq_dec: forall (f1 f2: float32), {f1 = f2} + {f1 <> f2} := Beq_dec _ Definition neg: float32 -> float32 := Bopp _ _ neg_nan. (**r opposite (change sign) *) Definition abs: float32 -> float32 := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *) +Definition sqrt: float32 -> float32 := + Bsqrt 24 128 __ __ unop_nan mode_NE. (**r square root *) Definition add: float32 -> float32 -> float32 := Bplus 24 128 __ __ binop_nan mode_NE. (**r addition *) Definition sub: float32 -> float32 -> float32 := @@ -976,6 +1050,8 @@ Definition mul: float32 -> float32 -> float32 := Bmult 24 128 __ __ binop_nan mode_NE. (**r multiplication *) Definition div: float32 -> float32 -> float32 := Bdiv 24 128 __ __ binop_nan mode_NE. (**r division *) +Definition fma: float32 -> float32 -> float32 -> float32 := + Bfma 24 128 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *) Definition compare (f1 f2: float32) : option Datatypes.comparison := (**r general comparison *) Bcompare 24 128 f1 f2. Definition cmp (c:comparison) (f1 f2: float32) : bool := (**r comparison *) @@ -1023,19 +1099,15 @@ Definition of_bits (b: int): float32 := b32_of_bits (Int.unsigned b). Theorem add_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x. Proof. - intros. apply Bplus_commut. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x, y; try reflexivity. - now destruct H. + intros. apply Bplus_commut. + destruct x, y; try reflexivity; now destruct H. Qed. Theorem mul_commut: forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x. Proof. - intros. apply Bmult_commut. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x, y; try reflexivity. - now destruct H. + intros. apply Bmult_commut. + destruct x, y; try reflexivity; now destruct H. Qed. (** Multiplication by 2 is diagonal addition. *) @@ -1045,9 +1117,8 @@ Theorem mul2_add: Proof. intros. apply Bmult2_Bplus. intros x y Hx Hy. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x as [| |sx px Nx|]; try discriminate. - now destruct y, Archi.choose_binop_pl_32. + destruct x; try discriminate. simpl. rewrite Archi.choose_nan_32_idem. + destruct y; reflexivity || discriminate. Qed. (** Divisions that can be turned into multiplication by an inverse. *) @@ -1059,9 +1130,8 @@ Theorem div_mul_inverse: Proof. intros. apply Bdiv_mult_inverse. 2: easy. intros x0 y0 z0 Hx Hy Hz. unfold binop_nan. - destruct Archi.fpu_returns_default_qNaN. easy. - destruct x0 as [| |sx px Nx|]; try discriminate. - now destruct y0, z0. + destruct x0; try discriminate. + destruct y0, z0; reflexivity || discriminate. Qed. (** Properties of comparisons. *) @@ -1218,7 +1288,7 @@ Proof. assert (C: m / 2^p = if zeq (n mod 2^p) 0 then 0 else 1). { unfold m. destruct (zeq (n mod 2^p) 0). rewrite e. apply Z.div_small. omega. - eapply Zdiv_unique with (n mod 2^p - 1). ring. omega. } + eapply Coqlib.Zdiv_unique with (n mod 2^p - 1). ring. omega. } assert (D: Z.testbit m p = if zeq (n mod 2^p) 0 then false else true). { destruct (zeq (n mod 2^p) 0). apply Z.testbit_false; auto. rewrite C; auto. diff --git a/powerpc/Archi.v b/powerpc/Archi.v index d792e4fe..ab348c14 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for PowerPC *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -37,24 +37,33 @@ Proof. reflexivity. Qed. -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 false (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +(* Always choose the first NaN argument, if any *) -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 false (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. -Definition fpu_returns_default_qNaN := false. +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, z, y). + +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := true. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_32 choose_binop_pl_32 - fpu_returns_default_qNaN + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. diff --git a/powerpc/Builtins1.v b/powerpc/Builtins1.v new file mode 100644 index 00000000..f6e643d2 --- /dev/null +++ b/powerpc/Builtins1.v @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* 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 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. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := . + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with end. diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml index 11b7aef9..e29a41f1 100644 --- a/powerpc/CBuiltins.ml +++ b/powerpc/CBuiltins.ml @@ -18,11 +18,11 @@ open C let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", TArray(TInt(IUInt, []), Some 3L, []) ]; - Builtins.functions = [ + builtin_functions = [ (* Integer arithmetic *) "__builtin_mulhw", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); diff --git a/powerpc/ConstpropOp.vp b/powerpc/ConstpropOp.vp index 2d492b66..cf1dc6e8 100644 --- a/powerpc/ConstpropOp.vp +++ b/powerpc/ConstpropOp.vp @@ -16,7 +16,7 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats. Require Import Op Registers. -Require Import ValueDomain. +Require Import ValueDomain ValueAOp. (** * Converting known values to constants *) @@ -95,6 +95,15 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := make_cmp_base c args vl end. +Definition make_select (c: condition) (ty: typ) + (r1 r2: reg) (args: list reg) (vl: list aval) := + match resolve_branch (eval_static_condition c vl) with + | Some b => (Omove, (if b then r1 else r2) :: nil) + | None => + let (c', args') := cond_strength_reduction c args vl in + (Osel c' ty, r1 :: r2 :: args') + end. + Definition make_addimm (n: int) (r: reg) := if Int.eq n Int.zero then (Omove, r :: nil) @@ -303,6 +312,7 @@ Nondetfunction op_strength_reduction | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 | Ocmp c, args, vl => make_cmp c args vl + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index fe061e5b..38daefe4 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Compopts. Require Import Integers Floats Values Memory Globalenvs Events. -Require Import Op Registers RTL ValueDomain. +Require Import Op Registers RTL ValueDomain ValueAOp ValueAnalysis. Require Import ConstpropOp. Local Transparent Archi.ptr64. @@ -211,6 +211,28 @@ Proof. - apply make_cmp_base_correct; auto. Qed. +Lemma make_select_correct: + forall c ty r1 r2 args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_select c ty r1 r2 args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v + /\ Val.lessdef (Val.select (eval_condition c rs##args m) rs#r1 rs#r2 ty) v. +Proof. + unfold make_select; intros. + destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB. +- exists (if b then rs#r1 else rs#r2); split. ++ simpl. destruct b; auto. ++ destruct (eval_condition c rs##args m) as [b'|] eqn:EC; simpl; auto. + assert (b = b'). + { eapply resolve_branch_sound; eauto. + rewrite <- EC. apply eval_static_condition_sound with bc. + subst vl. exact (aregs_sound _ _ _ args MATCH). } + subst b'. apply Val.lessdef_normalize. +- generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ. + econstructor; split. simpl; eauto. rewrite EQ; auto. +Qed. + Lemma make_addimm_correct: forall n r, let (op, args) := make_addimm n r in @@ -715,6 +737,8 @@ Proof. InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. (* cmp *) inv H0. apply make_cmp_correct; auto. +(* select *) + inv H0. apply make_select_correct; congruence. (* mulf *) InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) rs#r2). diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index b1cac124..07c325c1 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -38,12 +38,17 @@ Require Import Coqlib. Require Import Compopts. +<<<<<<< HEAD Require Import AST. Require Import Integers. Require Import Floats. Require Import Op. Require Import CminorSel. Require Import OpHelpers. +======= +Require Import AST Integers Floats Builtins. +Require Import Op CminorSel. +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf Require Archi. Local Open Scope cminorsel_scope. @@ -568,9 +573,16 @@ Nondetfunction builtin_arg (e: expr) := | _ => BA e end. +<<<<<<< HEAD (* floats *) Definition divf_base (e1: expr) (e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). Definition divfs_base (e1: expr) (e2: expr) := Eop Odivfs (e1 ::: e2 ::: Enil). +======= +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index 92852d36..3e34244d 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -13,17 +13,10 @@ (** Correctness of instruction selection for operators *) Require Import Coqlib. -Require Import Maps. +Require Import AST Integers Floats. +Require Import Values Memory Builtins Globalenvs. +Require Import Cminor Op CminorSel. Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. Require Import SelectOp. Require Import OpHelpers. Require Import OpHelpersproof. @@ -1069,6 +1062,7 @@ Proof. - constructor; auto. Qed. +<<<<<<< HEAD (* floating-point division without HELPERS *) Theorem eval_divf_base: forall le a b x y, @@ -1089,4 +1083,18 @@ Proof. intros; unfold divfs_base. TrivialExists. Qed. +======= +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf End CMCONSTR. diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index a1338561..0f608d25 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -340,7 +340,7 @@ module Target (System : SYSTEM):TARGET = let ireg_or_zero oc r = if r = GPR0 then output_string oc "0" else ireg oc r - let preg oc = function + let preg_asm oc ty = function | IR r -> ireg oc r | FR r -> freg oc r | _ -> assert false @@ -863,7 +863,7 @@ module Target (System : SYSTEM):TARGET = (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false diff --git a/riscV/Archi.v b/riscV/Archi.v index 3758d686..61d129d0 100644 --- a/riscV/Archi.v +++ b/riscV/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for RISC-V *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -40,26 +40,33 @@ Qed. except the MSB, a.k.a. the quiet bit." Exceptions are operations manipulating signs. *) -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 false (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - false. (**r irrelevant *) +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + default_nan_64. -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 false (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + default_nan_32. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - false. (**r irrelevant *) +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. -Definition fpu_returns_default_qNaN := true. +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, y, z). + +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_32 choose_binop_pl_32 - fpu_returns_default_qNaN + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. (** Whether to generate position-independent code or not *) diff --git a/riscV/Builtins1.v b/riscV/Builtins1.v new file mode 100644 index 00000000..f6e643d2 --- /dev/null +++ b/riscV/Builtins1.v @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* 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 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. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := . + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with end. diff --git a/riscV/CBuiltins.ml b/riscV/CBuiltins.ml index 0c981d11..edaf586d 100644 --- a/riscV/CBuiltins.ml +++ b/riscV/CBuiltins.ml @@ -18,10 +18,10 @@ open C let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", TPtr(TVoid [], []) ]; - Builtins.functions = [ + builtin_functions = [ (* Synchronization *) "__builtin_fence", (TVoid [], [], false); diff --git a/riscV/SelectOp.vp b/riscV/SelectOp.vp index ba7c5664..23235d95 100644 --- a/riscV/SelectOp.vp +++ b/riscV/SelectOp.vp @@ -44,11 +44,8 @@ Require Archi. Require Import Coqlib. Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. +Require Import AST Integers Floats Builtins. +Require Import Op CminorSel. Local Open Scope cminorsel_scope. @@ -455,9 +452,16 @@ Nondetfunction builtin_arg (e: expr) := | _ => BA e end. +<<<<<<< HEAD (* floats *) Definition divf_base (e1: expr) (e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). Definition divfs_base (e1: expr) (e2: expr) := Eop Odivfs (e1 ::: e2 ::: Enil). +======= +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v index 46cc1bbc..ca271342 100644 --- a/riscV/SelectOpproof.v +++ b/riscV/SelectOpproof.v @@ -17,18 +17,10 @@ (** Correctness of instruction selection for operators *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Zbits. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. +Require Import Coqlib Zbits. +Require Import AST Integers Floats. +Require Import Values Memory Builtins Globalenvs. +Require Import Cminor Op CminorSel. Require Import SelectOp. Require Import OpHelpers. Require Import OpHelpersproof. @@ -941,6 +933,7 @@ Proof. - constructor; auto. Qed. +<<<<<<< HEAD (* floating-point division without HELPERS *) Theorem eval_divf_base: @@ -962,4 +955,18 @@ Proof. intros; unfold divfs_base. TrivialExists. Qed. +======= +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf End CMCONSTR. diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 92df7a76..64bcea4c 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -93,7 +93,7 @@ module Target : TARGET = | X0 -> output_string oc "x0" | X r -> ireg oc r - let preg oc = function + let preg_asm oc ty = function | IR r -> ireg oc r | FR r -> freg oc r | _ -> assert false @@ -582,7 +582,7 @@ module Target : TARGET = (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false diff --git a/test/regression/builtins-arm.c b/test/regression/builtins-arm.c index 709343ce..d06e8e5e 100644 --- a/test/regression/builtins-arm.c +++ b/test/regression/builtins-arm.c @@ -2,14 +2,15 @@ #include <stdio.h> +unsigned int x = 0x12345678; +unsigned int y = 0xDEADBEEF; +unsigned long long xx = 0x1234567812345678ULL; +double a = 3.14159; +unsigned short s = 0x1234; + int main(int argc, char ** argv) { - unsigned int x = 0x12345678; - unsigned int y = 0xDEADBEEF; - unsigned long long xx = 0x1234567812345678ULL; unsigned z; - double a = 3.14159; - unsigned short s = 0x1234; printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); diff --git a/test/regression/builtins-powerpc.c b/test/regression/builtins-powerpc.c index 23e9d191..8fd5818b 100644 --- a/test/regression/builtins-powerpc.c +++ b/test/regression/builtins-powerpc.c @@ -9,16 +9,17 @@ char * check_relative_error(double exact, double actual, double precision) return fabs(relative_error) <= precision ? "OK" : "ERROR"; } +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; +unsigned short s = 0x1234; + int main(int argc, char ** argv) { - unsigned int x = 0x12345678; - unsigned int y = 0xDEADBEEF; - unsigned long long xx = 0x1234567812345678ULL; unsigned z; - double a = 3.14159; - double b = 2.718; - double c = 1.414; - unsigned short s = 0x1234; printf("mulhw(%x, %x) = %x\n", x, y, __builtin_mulhw(x, y)); printf("mulhwu(%x, %x) = %x\n", x, y, __builtin_mulhwu(x, y)); diff --git a/test/regression/builtins-riscV.c b/test/regression/builtins-riscV.c index a302a6c4..c34fdf2c 100644 --- a/test/regression/builtins-riscV.c +++ b/test/regression/builtins-riscV.c @@ -2,15 +2,15 @@ #include <stdio.h> +unsigned int x = 0x12345678; +unsigned short s = 0x1234; +unsigned long long zz = 0x123456789ABCDEF0ULL; +double a = 3.14159; +double b = 2.718; +double c = 1.414; + int main(int argc, char ** argv) { - unsigned int x = 0x12345678; - unsigned short s = 0x1234; - unsigned long long zz = 0x123456789ABCDEF0ULL; - double a = 3.14159; - double b = 2.718; - double c = 1.414; - 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)); diff --git a/test/regression/builtins-x86.c b/test/regression/builtins-x86.c index 1ba213e7..6233f9fd 100644 --- a/test/regression/builtins-x86.c +++ b/test/regression/builtins-x86.c @@ -2,18 +2,19 @@ #include <stdio.h> +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; +unsigned short s = 0x1234; + 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; printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); diff --git a/test/regression/extasm.c b/test/regression/extasm.c index babc57f1..83a07a05 100644 --- a/test/regression/extasm.c +++ b/test/regression/extasm.c @@ -33,6 +33,7 @@ int main() void * y; long long z; double f; + float sf; char c[16]; /* No inputs, no outputs */ @@ -72,6 +73,15 @@ int main() #ifdef FAILURES asm("FAIL4 a:%[a]" : "=r"(x) : [z]"i"(0)); #endif + /* One argument of each type */ + asm("TEST15 int32 %0" : : "r" (x)); +#ifdef SIXTYFOUR + asm("TEST15 int64 %0" : : "r" (z)); +#else + asm("TEST15 int64 %Q0 / %R0" : : "r" (z)); +#endif + asm("TEST15 float64 %0" : : "r" (f)); + asm("TEST15 float32 %0" : : "r" (sf)); /* Various failures */ #ifdef FAILURES asm("FAIL5 out:%0,%1" : "=r"(x), "=r"(y)); diff --git a/test/regression/ifconv.c b/test/regression/ifconv.c index dcbf43e5..e12a394c 100644 --- a/test/regression/ifconv.c +++ b/test/regression/ifconv.c @@ -83,6 +83,26 @@ float sdoz(float x, float y) return x >= y ? x - y : 0.0f; } +/* Examples where constant propagation should take place */ + +int constprop1(int x) +{ + int n = 0; + return n ? x : 42; +} + +int constprop2(int x) +{ + int n = 1; + return n ? x : 42; +} + +int constprop3(int x, int y) +{ + int n = 0; + return x < n ? y - 1 : y + 1; +} + /* Test harness */ #define TESTI(call) printf(#call " = %d\n", call) diff --git a/x86/Builtins1.v b/x86/Builtins1.v new file mode 100644 index 00000000..6103cc4c --- /dev/null +++ b/x86/Builtins1.v @@ -0,0 +1,54 @@ +(* *********************************************************************) +(* *) +(* 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 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. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := + | BI_fmin + | BI_fmax. + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + ("__builtin_fmin", BI_fmin) + :: ("__builtin_fmax", BI_fmax) + :: nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with + | BI_fmin | BI_fmax => + mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with + | BI_fmin => + mkbuiltin_n2t Tfloat Tfloat Tfloat + (fun f1 f2 => match Float.compare f1 f2 with + | Some Eq | Some Lt => f1 + | Some Gt | None => f2 + end) + | BI_fmax => + mkbuiltin_n2t Tfloat Tfloat Tfloat + (fun f1 f2 => match Float.compare f1 f2 with + | Some Eq | Some Gt => f1 + | Some Lt | None => f2 + end) + end. + diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml index 69a2eb64..6fb8b697 100644 --- a/x86/CBuiltins.ml +++ b/x86/CBuiltins.ml @@ -26,10 +26,10 @@ let (va_list_type, va_list_scalar, size_va_list) = (TPtr(TVoid [], []), true, 4) let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", va_list_type; ]; - Builtins.functions = [ + builtin_functions = [ (* Integer arithmetic *) "__builtin_bswap64", (TInt(IULongLong, []), [TInt(IULongLong, [])], false); diff --git a/x86/ConstpropOp.vp b/x86/ConstpropOp.vp index f59b9dba..ada8d54a 100644 --- a/x86/ConstpropOp.vp +++ b/x86/ConstpropOp.vp @@ -16,7 +16,7 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats. Require Import Op Registers. -Require Import ValueDomain. +Require Import ValueDomain ValueAOp. (** * Converting known values to constants *) @@ -98,6 +98,15 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := make_cmp_base c args vl end. +Definition make_select (c: condition) (ty: typ) + (r1 r2: reg) (args: list reg) (vl: list aval) := + match resolve_branch (eval_static_condition c vl) with + | Some b => (Omove, (if b then r1 else r2) :: nil) + | None => + let (c', args') := cond_strength_reduction c args vl in + (Osel c' ty, r1 :: r2 :: args') + end. + (** For addressing modes, we need to distinguish - reductions that produce pointers (i.e. that produce [Aglobal], [Ainstack], [Abased] and [Abasedscaled] addressing modes), which are valid only if the pointer size is right; - other reductions (producing [Aindexed] or [Aindexed2] modes), which are valid independently of the pointer size. @@ -416,6 +425,7 @@ Nondetfunction op_strength_reduction let (addr', args') := addr_strength_reduction_64 addr args vl in (Oleal addr', args') | Ocmp c, args, vl => make_cmp c args vl + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 diff --git a/x86/ConstpropOpproof.v b/x86/ConstpropOpproof.v index 3bb0f3cd..6d2df9c1 100644 --- a/x86/ConstpropOpproof.v +++ b/x86/ConstpropOpproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Compopts. Require Import Integers Floats Values Memory Globalenvs Events. -Require Import Op Registers RTL ValueDomain. +Require Import Op Registers RTL ValueDomain ValueAOp ValueAnalysis. Require Import ConstpropOp. Section STRENGTH_REDUCTION. @@ -371,6 +371,28 @@ Proof. - apply make_cmp_base_correct; auto. Qed. +Lemma make_select_correct: + forall c ty r1 r2 args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_select c ty r1 r2 args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.select (eval_condition c e##args m) e#r1 e#r2 ty) v. +Proof. + unfold make_select; intros. + destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB. +- exists (if b then e#r1 else e#r2); split. ++ simpl. destruct b; auto. ++ destruct (eval_condition c e##args m) as [b'|] eqn:EC; simpl; auto. + assert (b = b'). + { eapply resolve_branch_sound; eauto. + rewrite <- EC. apply eval_static_condition_sound with bc. + subst vl. exact (aregs_sound _ _ _ args MATCH). } + subst b'. apply Val.lessdef_normalize. +- generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ. + econstructor; split. simpl; eauto. rewrite EQ; auto. +Qed. + Lemma make_addimm_correct: forall n r, let (op, args) := make_addimm n r in @@ -905,6 +927,8 @@ Proof. auto. (* cond *) inv H0. apply make_cmp_correct; auto. +(* select *) + inv H0. apply make_select_correct; congruence. (* mulf *) InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). diff --git a/x86/SelectOp.vp b/x86/SelectOp.vp index c0434a67..d734ecc6 100644 --- a/x86/SelectOp.vp +++ b/x86/SelectOp.vp @@ -38,9 +38,13 @@ Require Import Coqlib. Require Import Compopts. -Require Import AST Integers Floats. +Require Import AST Integers Floats Builtins. Require Import Op CminorSel. +<<<<<<< HEAD Require Import OpHelpers. +======= +Require Archi. +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf Local Open Scope cminorsel_scope. @@ -499,21 +503,27 @@ Nondetfunction floatofint (e: expr) := end. Definition intuoffloat (e: expr) := - Elet e - (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) - (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) - (intoffloat (Eletvar 1)) - (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat. + if Archi.splitlong then + Elet e + (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) + (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) + (intoffloat (Eletvar 1)) + (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat + else + Eop Olowlong (Eop Olongoffloat (e ::: Enil) ::: Enil). Nondetfunction floatofintu (e: expr) := match e with | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil | _ => - let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) - (floatofint (Eletvar O)) - (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)) + if Archi.splitlong then + let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in + Elet e + (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) + (floatofint (Eletvar O)) + (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)) + else + Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil) end. Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). @@ -570,9 +580,16 @@ Nondetfunction builtin_arg (e: expr) := | _ => BA e end. +<<<<<<< HEAD (* floats *) Definition divf_base (e1: expr) (e2: expr) := Eop Odivf (e1 ::: e2 ::: Enil). Definition divfs_base (e1: expr) (e2: expr) := Eop Odivfs (e1 ::: e2 ::: Enil). +======= +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf diff --git a/x86/SelectOpproof.v b/x86/SelectOpproof.v index 5e0f84e3..b59f4a87 100644 --- a/x86/SelectOpproof.v +++ b/x86/SelectOpproof.v @@ -13,15 +13,9 @@ (** Correctness of instruction selection for operators *) Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. +Require Import AST Integers Floats. +Require Import Values Memory Builtins Globalenvs. +Require Import Cminor Op CminorSel. Require Import SelectOp. Require Import OpHelpers. Require Import OpHelpersproof. @@ -838,7 +832,8 @@ Proof. intros. destruct x; simpl in H0; try discriminate. destruct (Float.to_intu f) as [n|] eqn:?; simpl in H0; inv H0. exists (Vint n); split; auto. unfold intuoffloat. - set (im := Int.repr Int.half_modulus). + destruct Archi.splitlong. +- 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. @@ -865,6 +860,11 @@ Proof. rewrite Int.add_neg_zero in A4. rewrite Int.add_zero in A4. auto. +- apply Float.to_intu_to_long in Heqo. repeat econstructor. eauto. + simpl. rewrite Heqo; reflexivity. + simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned; auto. + assert (Int.modulus < Int64.max_unsigned) by reflexivity. + generalize (Int.unsigned_range n); omega. Qed. Theorem eval_floatofintu: @@ -874,10 +874,11 @@ Theorem eval_floatofintu: exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. Proof. intros until y; unfold floatofintu. case (floatofintu_match a); intros. - InvEval. TrivialExists. - destruct x; simpl in H0; try discriminate. inv H0. +- InvEval. TrivialExists. +- destruct x; simpl in H0; try discriminate. inv H0. exists (Vfloat (Float.of_intu i)); split; auto. - econstructor. eauto. + destruct Archi.splitlong. ++ econstructor. eauto. set (fm := Float.of_intu Float.ox8000_0000). assert (eval_expr ge sp e m (Vint i :: le) (Eletvar O) (Vint i)). constructor. auto. @@ -893,6 +894,7 @@ Proof. constructor. EvalOp. simpl; eauto. constructor. simpl; eauto. fold fm. rewrite Float.of_intu_of_int_2; auto. rewrite Int.sub_add_opp. auto. ++ rewrite Float.of_intu_of_long. repeat econstructor. eauto. reflexivity. Qed. Theorem eval_intofsingle: @@ -1014,6 +1016,7 @@ Proof. - constructor; auto. Qed. +<<<<<<< HEAD (* floating-point division without HELPERS *) Theorem eval_divf_base: @@ -1035,4 +1038,18 @@ Proof. intros; unfold divfs_base. TrivialExists. Qed. +======= +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + +>>>>>>> 91381b65f5aa76e5195caae9ef331b3f5f95afaf End CMCONSTR. diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 3025d2e7..cd54e08b 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -62,8 +62,8 @@ let ireg64 oc r = output_string oc (int64_reg_name r) let ireg = if Archi.ptr64 then ireg64 else ireg32 let freg oc r = output_string oc (float_reg_name r) -let preg oc = function - | IR r -> ireg oc r +let preg_asm oc ty = function + | IR r -> if ty = Tlong then ireg64 oc r else ireg32 oc r | FR r -> freg oc r | _ -> assert false @@ -826,7 +826,7 @@ module Target(System: SYSTEM):TARGET = (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false diff --git a/x86_32/Archi.v b/x86_32/Archi.v index f10570e2..e9d05c14 100644 --- a/x86_32/Archi.v +++ b/x86_32/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for x86 in 32-bit mode *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -34,24 +34,33 @@ Proof. unfold splitlong. destruct ptr64; simpl; congruence. Qed. -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (true, iter_nat 51 _ xO xH). +Definition default_nan_32 := (true, iter_nat 22 _ xO xH). -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +(* Always choose the first NaN argument, if any *) -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. -Definition fpu_returns_default_qNaN := false. +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, y, z). + +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_32 choose_binop_pl_32 - fpu_returns_default_qNaN + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. diff --git a/x86_64/Archi.v b/x86_64/Archi.v index 01eb36dd..959d8dc1 100644 --- a/x86_64/Archi.v +++ b/x86_64/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for x86 in 64-bit mode *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -34,24 +34,33 @@ Proof. unfold splitlong. destruct ptr64; simpl; congruence. Qed. -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (true, iter_nat 51 _ xO xH). +Definition default_nan_32 := (true, iter_nat 22 _ xO xH). -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +(* Always choose the first NaN argument, if any *) -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. -Definition fpu_returns_default_qNaN := false. +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, y, z). + +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_32 choose_binop_pl_32 - fpu_returns_default_qNaN + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. |