├── doc ├── VeriFFI.pdf ├── VeriFFI.png └── veriffi_techreport.pdf ├── examples ├── compose │ ├── prims.h │ ├── gluegen.v │ ├── prims.c │ ├── main.c │ ├── prog.v │ ├── Verif_prog.v │ └── model.v ├── .gitignore ├── array │ ├── prims.h │ ├── gluegen.v │ ├── main.c │ ├── prog.v │ ├── prims.c │ └── model.v ├── uint63z │ ├── prims.h │ ├── gluegen.v │ ├── main.c │ ├── prog.v │ ├── prims.c │ ├── Verif_prog.v │ └── model.v ├── uint63nat │ ├── prims.h │ ├── gluegen.v │ ├── main.c │ ├── prog.v │ ├── model.v │ ├── prims.c │ ├── call.v │ └── specs.v └── bytestring │ ├── main.c │ ├── gluegen.v │ ├── prims.h │ ├── Verif_prog.v │ ├── prog.v │ └── specs.v ├── generator ├── README.md ├── Rep.v ├── module.v ├── FnDesc.v ├── Discrimination.v └── CtorDesc.v ├── c ├── blob.h ├── int63.h ├── verif_int63.v ├── certicoq.h ├── int63.c ├── config.h ├── gc_stack.h ├── values.h └── spec_int63.v ├── .gitmodules ├── library ├── README.md ├── isomorphism.v ├── modelled.v ├── base_representation.v └── meta.v ├── verification ├── demo │ └── proofs_bool.v └── README.md ├── .gitignore ├── Makefile ├── docker └── Dockerfile ├── LICENSE ├── README.md ├── _CoqProject ├── BUILD ├── tests └── generators.v ├── Makefile.coq.local └── INSTALL.md /doc/VeriFFI.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CertiCoq/VeriFFI/HEAD/doc/VeriFFI.pdf -------------------------------------------------------------------------------- /doc/VeriFFI.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CertiCoq/VeriFFI/HEAD/doc/VeriFFI.png -------------------------------------------------------------------------------- /doc/veriffi_techreport.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CertiCoq/VeriFFI/HEAD/doc/veriffi_techreport.pdf -------------------------------------------------------------------------------- /examples/compose/prims.h: -------------------------------------------------------------------------------- 1 | value compose(struct thread_info *, value, value, value, value, value, value); 2 | -------------------------------------------------------------------------------- /generator/README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | Work-in-progress of generation. 4 | 5 | - ``demoRepr.v`` : Example file for generated representation functions -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | *prog.c 2 | *prog.h 3 | *prog.o 4 | prog 5 | glue.c 6 | glue.h 7 | 8 | gc.c 9 | gc.h 10 | gc_stack.c 11 | gc_stack.h 12 | values.h 13 | config.h 14 | m.h 15 | -------------------------------------------------------------------------------- /examples/array/prims.h: -------------------------------------------------------------------------------- 1 | value nat_to_ull(value); 2 | value runM(struct thread_info *tinfo, value, value); 3 | value array_runM(struct thread_info *tinfo, value, value, value, value); 4 | -------------------------------------------------------------------------------- /examples/uint63z/prims.h: -------------------------------------------------------------------------------- 1 | value uint63_from_Z(value z); 2 | value uint63_to_Z(struct thread_info *tinfo, value t); 3 | value uint63_add(value x, value y); 4 | value uint63_mul(value x, value y); 5 | -------------------------------------------------------------------------------- /c/blob.h: -------------------------------------------------------------------------------- 1 | #ifndef CERTICOQ_BLOB_H 2 | #define CERTICOQ_BLOB_H 3 | 4 | #include 5 | 6 | value certicoq_prim__make_blob(struct thread_info *tinfo, size_t bytelen); 7 | 8 | #endif /* CERTICOQ_BLOB_H */ 9 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "CertiGraph"] 2 | path = CertiGraph 3 | url = https://github.com/CertiGraph/CertiGraph.git 4 | [submodule "certicoq"] 5 | path = certicoq 6 | url = https://github.com/CertiCoq/certicoq.git 7 | -------------------------------------------------------------------------------- /library/README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | Work-in-progress of verification. 4 | 5 | - ``graphCRep.v``: Generic definition for the representation predicates, needed for the representation functions generated by MetaCoq in ``generator/rep.v``. 6 | 7 | -------------------------------------------------------------------------------- /examples/uint63nat/prims.h: -------------------------------------------------------------------------------- 1 | value uint63_from_nat(struct thread_info *tinfo, value z); 2 | 3 | value uint63_to_nat(struct thread_info *tinfo, value t); 4 | 5 | value uint63_add(struct thread_info *tinfo, value x, value y); 6 | 7 | value uint63_mul(value x, value y); 8 | -------------------------------------------------------------------------------- /examples/compose/gluegen.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | Require Import VeriFFI.examples.compose.prog. 3 | 4 | CertiCoq Compile -build_dir "examples/compose/" -file "prog" prog. 5 | CertiCoq Generate Glue -build_dir "examples/compose" -file "glue" [ ]. 6 | -------------------------------------------------------------------------------- /examples/compose/prims.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "glue.h" 3 | #include 4 | 5 | value compose(struct thread_info *tinfo, value a, value b, value c, value g, value f, value x) { 6 | value temp = call(tinfo, f, x); 7 | return call(tinfo, g, temp); 8 | } 9 | -------------------------------------------------------------------------------- /examples/array/gluegen.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | Require Import VeriFFI.examples.array.prog. 3 | 4 | CertiCoq Compile -build_dir "examples/array/" -file "prog" prog. 5 | CertiCoq Generate Glue -build_dir "examples/array" -file "glue" [ option, nat, C.MI ]. 6 | -------------------------------------------------------------------------------- /examples/uint63nat/gluegen.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | Require Import VeriFFI.examples.uint63nat.prog. 3 | 4 | CertiCoq Compile -build_dir "examples/uint63nat/" -file "prog" prog. 5 | CertiCoq Generate Glue -build_dir "examples/uint63nat" -file "glue" [ nat ]. 6 | -------------------------------------------------------------------------------- /examples/uint63z/gluegen.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | Require Import ZArith. 3 | Require Import VeriFFI.examples.uint63z.prog. 4 | 5 | CertiCoq Compile -build_dir "examples/uint63z/" -file "prog" prog. 6 | CertiCoq Generate Glue -build_dir "examples/uint63z" -file "glue" [ Z ]. 7 | -------------------------------------------------------------------------------- /examples/bytestring/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | extern value body(struct thread_info *); 6 | 7 | int main(int argc, char *argv[]) { 8 | struct thread_info* tinfo; 9 | 10 | tinfo = make_tinfo(); 11 | body(tinfo); 12 | 13 | return 0; 14 | } 15 | -------------------------------------------------------------------------------- /verification/demo/proofs_bool.v: -------------------------------------------------------------------------------- 1 | From VC Require Export specs. 2 | 3 | Lemma make_bool_true_proof : semax_body Vprog Gprog f_make_Coq_Init_Datatypes_bool_true make_bool_true_spec. 4 | Proof. 5 | start_function. 6 | forward. 7 | Exists (repZ 0). entailer!. 8 | cbv. intuition (try congruence) . admit. 9 | Admitted. 10 | -------------------------------------------------------------------------------- /examples/bytestring/gluegen.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | Require Import String. 3 | Require Import VeriFFI.examples.bytestring.prog. 4 | 5 | CertiCoq Compile -build_dir "examples/bytestring/" -file "prog" prog. 6 | CertiCoq Generate Glue -build_dir "examples/bytestring" -file "glue" 7 | [ unit, nat, bool, string, C.MI ]. 8 | -------------------------------------------------------------------------------- /examples/bytestring/prims.h: -------------------------------------------------------------------------------- 1 | value append(struct thread_info *tinfo, value, value); 2 | value pack(struct thread_info *tinfo, value); 3 | value unpack(struct thread_info *tinfo, value); 4 | value runM(struct thread_info *tinfo, value, value, value, value); 5 | value get_stdin(struct thread_info *tinfo, value); 6 | value get_stdout(struct thread_info *tinfo, value); 7 | -------------------------------------------------------------------------------- /examples/compose/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "glue.h" 5 | 6 | extern value body(struct thread_info *); 7 | 8 | int main(int argc, char *argv[]) { 9 | struct thread_info* tinfo; 10 | 11 | tinfo = make_tinfo(); 12 | value tmp = body(tinfo); 13 | 14 | print_Coq_Init_Datatypes_nat(tmp); 15 | puts(""); 16 | return 0; 17 | } 18 | -------------------------------------------------------------------------------- /examples/uint63nat/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "glue.h" 5 | 6 | extern value body(struct thread_info *); 7 | 8 | int main(int argc, char *argv[]) { 9 | struct thread_info* tinfo; 10 | 11 | tinfo = make_tinfo(); 12 | value tmp = body(tinfo); 13 | 14 | print_Coq_Init_Datatypes_nat(tmp); 15 | puts(""); 16 | return 0; 17 | } 18 | -------------------------------------------------------------------------------- /examples/uint63z/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "glue.h" 5 | 6 | extern value body(struct thread_info *); 7 | 8 | int main(int argc, char *argv[]) { 9 | struct thread_info* tinfo; 10 | 11 | tinfo = make_tinfo(); 12 | value tmp = body(tinfo); 13 | 14 | print_Coq_Numbers_BinNums_Z(tmp); 15 | puts(""); 16 | return 0; 17 | } 18 | -------------------------------------------------------------------------------- /examples/array/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "glue.h" 5 | 6 | extern value body(struct thread_info *); 7 | 8 | int main(int argc, char *argv[]) { 9 | struct thread_info* tinfo; 10 | 11 | tinfo = make_tinfo(); 12 | value tmp = body(tinfo); 13 | 14 | print_Coq_Init_Datatypes_option(tmp, print_Coq_Init_Datatypes_nat); 15 | 16 | puts(""); 17 | return 0; 18 | } 19 | -------------------------------------------------------------------------------- /examples/compose/prog.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | 3 | Module Type Compose. 4 | Axiom compose : forall {A B C}, (B -> C) -> (A -> B) -> (A -> C). 5 | End Compose. 6 | 7 | Module C : Compose. 8 | Axiom compose : forall {A B C}, (B -> C) -> (A -> B) -> (A -> C). 9 | End C. 10 | 11 | CertiCoq Register [ 12 | C.compose => "compose" with tinfo 13 | ] Include [ "prims.h" ]. 14 | 15 | (* Definition prog := C.compose (fun x => x + 1) (fun y => y + 1) 2. *) 16 | Definition prog := C.compose S S 2. 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.aux 2 | .*.d 3 | *.a 4 | *.cma 5 | *.cmi 6 | *.cmo 7 | *.cmx 8 | *.cmxa 9 | *.cmxs 10 | *.glob 11 | *.ml.d 12 | *.ml4.d 13 | *.mli.d 14 | *.mllib.d 15 | *.mlpack.d 16 | *.native 17 | *.o 18 | *.v.d 19 | *.vio 20 | *.vo 21 | *.vok 22 | *.vos 23 | .coq-native/ 24 | .csdp.cache 25 | .lia.cache 26 | .nia.cache 27 | .nlia.cache 28 | .nra.cache 29 | csdp.cache 30 | lia.cache 31 | nia.cache 32 | nlia.cache 33 | nra.cache 34 | *.DS_Store 35 | Makefile.coq 36 | Makefile.coq.conf 37 | /*.c 38 | /*.h 39 | .vscode/ 40 | examples/*/prims.v 41 | -------------------------------------------------------------------------------- /examples/bytestring/Verif_prog.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | Require Import Psatz. 3 | 4 | Require Import VeriFFI.verification.specs_general. 5 | Require Import VeriFFI.generator.Rep. 6 | 7 | (* Obligation Tactic := gen. *) 8 | (* MetaCoq Run (gen_for nat). *) 9 | (* MetaCoq Run (gen_for unit). *) 10 | 11 | Require Import VeriFFI.examples.bytestring.prog. 12 | Require Import VeriFFI.examples.bytestring.model. 13 | 14 | Import Bytestring_Proofs. 15 | (* Check append_desc. *) 16 | 17 | (* C function in examples/bytestring/prims.c *) 18 | (* Check (fn_desc_to_funspec append_desc). *) 19 | -------------------------------------------------------------------------------- /examples/compose/Verif_prog.v: -------------------------------------------------------------------------------- 1 | Require Import VeriFFI.examples.compose.prog. 2 | 3 | Require Import ZArith. 4 | Require Import Psatz. 5 | 6 | Require Import VeriFFI.verification.specs_general. 7 | Require Import VeriFFI.examples.compose.glue. 8 | Require Import VeriFFI.library.meta. 9 | 10 | 11 | Require Import VST.floyd.proofauto. 12 | Require Import CertiGraph.CertiGC.GCGraph. 13 | 14 | From VeriFFI Require Import library.base_representation. 15 | From VeriFFI Require Import library.meta. 16 | From VeriFFI Require Import verification.graph_add. 17 | From VeriFFI Require Import verification.specs_library. 18 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: Makefile.coq 2 | cd CertiGraph; make certigc 3 | # make -f Makefile.coq prims_files 4 | +make -f Makefile.coq all 5 | 6 | clean: Makefile.coq 7 | +make -f Makefile.coq clean 8 | rm -f Makefile.coq 9 | rm -f Makefile.coq.conf 10 | rm -f examples/*/glue.[chv] 11 | rm -f examples/*/prog.[ch] 12 | rm -f examples/*/prims.v 13 | 14 | Makefile.coq: _CoqProject 15 | coq_makefile -f _CoqProject -o Makefile.coq 16 | # awk '{if ($$1=="$$(VDFILE):") print "$$(VDFILE): _CoqProject $$(filter-out $$(GENERATED_VFILES), $$(VFILES))"; else print $$0}' xMakefile.coq 17 | # mv xMakefile.coq Makefile.coq 18 | 19 | .PHONY: Makefile.coq all clean 20 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM yforster/coq:8.19.1--clang-11--compcert-3.13.1--extlib-0.12.1--equations-1.3--metacoq-1.3.1 2 | 3 | MAINTAINER Joomy Korkut 4 | 5 | RUN cd && git clone https://github.com/CertiCoq/VeriFFI && cd VeriFFI && git checkout 3f2b87aed2bad21f6d6513c9aa64fdecb5b351f6 && git submodule update --init --recursive 6 | RUN cd ~/VeriFFI/certicoq && opam pin -n -y . 7 | ENV PATH="/home/coq/.opam/2.1.5/bin:${PATH}" 8 | RUN cd ~/VeriFFI/certicoq && opam install -y coq-certicoq --deps-only 9 | RUN cd ~/VeriFFI/certicoq && opam install -y -v -j 4 coq-certicoq 10 | RUN opam install -y coq-vst.2.14 11 | RUN cd ~/VeriFFI/CertiGraph && make certigc 12 | USER coq 13 | RUN /bin/bash 14 | -------------------------------------------------------------------------------- /examples/uint63z/prog.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | 3 | Require Import ZArith. 4 | Require Import Psatz. 5 | 6 | Module Type UInt63. 7 | Axiom t : Type. 8 | Axiom from_Z : Z -> t. 9 | Axiom to_Z : t -> Z. 10 | Axiom add : t -> t -> t. 11 | Axiom mul : t -> t -> t. 12 | End UInt63. 13 | 14 | Module C : UInt63. 15 | Axiom t : Type. 16 | Axiom from_Z : Z -> t. 17 | Axiom to_Z : t -> Z. 18 | Axiom add : t -> t -> t. 19 | Axiom mul : t -> t -> t. 20 | End C. 21 | 22 | CertiCoq Register [ 23 | C.from_Z => "uint63_from_Z", 24 | C.to_Z => "uint63_to_Z" with tinfo, 25 | C.add => "uint63_add" 26 | ] Include [ "prims.h" ]. 27 | 28 | Definition prog := C.to_Z (C.add (C.from_Z 1) (C.from_Z 2)). 29 | -------------------------------------------------------------------------------- /examples/uint63nat/prog.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | 3 | Require Import ZArith. 4 | Require Import Psatz. 5 | 6 | Module Type UInt63. 7 | Axiom t : Type. 8 | Axiom from_nat : nat -> t. 9 | Axiom to_nat : t -> nat. 10 | Axiom add : t -> t -> t. 11 | Axiom mul : t -> t -> t. 12 | End UInt63. 13 | 14 | Module C : UInt63. 15 | Axiom t : Type. 16 | Axiom from_nat : nat -> t. 17 | Axiom to_nat : t -> nat. 18 | Axiom add : t -> t -> t. 19 | Axiom mul : t -> t -> t. 20 | End C. 21 | 22 | CertiCoq Register [ 23 | C.from_nat => "uint63_from_nat", 24 | C.to_nat => "uint63_to_nat" with tinfo, 25 | C.add => "uint63_add" 26 | ] Include [ "prims.h" ]. 27 | 28 | Definition prog := C.to_nat (C.add (C.from_nat 1) (C.from_nat 2)). 29 | -------------------------------------------------------------------------------- /generator/Rep.v: -------------------------------------------------------------------------------- 1 | Require Import VeriFFI.library.base_representation. 2 | Require Import VeriFFI.library.meta. 3 | Require Import VeriFFI.generator.GraphPredicate. 4 | Require Import VeriFFI.generator.InGraph. 5 | Require Import VeriFFI.generator.CtorDesc. 6 | 7 | Require Import MetaCoq.Template.All. 8 | 9 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 10 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 11 | Import monad_utils.MCMonadNotation. 12 | 13 | Definition gen_for {kind : Type} (Tau : kind) : TemplateMonad unit := 14 | @graph_predicate_gen kind Tau ;; 15 | @in_graph_gen kind Tau. 16 | 17 | Definition desc_gen {T : Type} (ctor_val : T) : TemplateMonad unit := 18 | @ctor_desc_gen T ctor_val. 19 | 20 | Ltac gen := 21 | match goal with 22 | | [ |- @reflector _ _ _ _ ] => reflecting 23 | | _ => in_graph_gen_tac 24 | end. 25 | 26 | Local Obligation Tactic := gen. 27 | 28 | (* MetaCoq Run (in_graph_gen unit). *) 29 | (* MetaCoq Run (desc_gen tt). *) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 Andrew Appel, Joomy Korkut, Kathrin Stark 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

VeriFFI 2 |

3 | 4 | VeriFFI is a verified Foreign Function Interface (FFI) for Coq (Gallina) programs that call, and are called by, C programs. The operational connection is by compiling Gallina programs through C using the CertiCoq compiler. The specification/verification connection is by using the Verified Software Toolchain (Verifiable C) to specify library functions written in C that are callable by CertiCoq-compiled programs, and vice versa. The goal is to have a fully foundational soundness proof for this connection. This is still a work in progress. 5 | 6 | Participants: 7 | - [Andrew W. Appel](https://www.cs.princeton.edu/~appel/) 8 | - [Joomy Korkut](https://joomy.korkutblech.com/) 9 | - [Kathrin Stark](https://www.k-stark.de/) 10 | 11 | Journal Article: 12 | - [A Verified Foreign Function Interface between Coq and C](https://doi.org/10.1145/3704860), by Joomy Korkut, Kathrin Stark, and Andrew W. Appel, _Proc. ACM Program. Lang._ 9, POPL, Article 24 (January 2025), 31 pages. 13 | 14 | PhD Thesis: 15 | - [_Foreign Function Verification Through Metaprogramming_](http://arks.princeton.edu/ark:/88435/dsp01k930c143z), by Joomy Korkut, PhD Thesis, Princeton University, October 2024. 16 | -------------------------------------------------------------------------------- /verification/README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | Work-in-progress of verification. Can be run as described in the ``Install.md`` file in the main directory. 4 | 5 | - Example for nat/list in ``example`` directory: 6 | - ``glue.h``: Glue code generate file for nat/list. 7 | - ``glue.c``: Adapted version of glue code which is generated for nat/list. All adaptions are listed in the document. 8 | - ``glue.v``: The CompCert-generated file of ``glue.c``. 9 | - ``graph_add.v`` : Augments CertiGraph with functions for adding a new node at the end of a generation (in contrast to previously copying an already available graph). This requires changing the graph/compatibility condtions/proofs that the generated graph is still well-generated to be able to interact e.g. with the garbage collector 10 | - ``demo``: Example specifications for ``nat`` and ``list``, non-general approach but the one later used 11 | - ``specs_library.v``: General definitions for specifications, needed both for specific specifications and general specifications 12 | - ``specs_general.v``: General specification built on a general specification of constructors 13 | - ``proofs_library_general.v``: General lemmas needed to prove glue code correct (only in verif branch) 14 | - ``alloc_proof_general.v``: Subsumption approach. A general definition of the general Clight representation, a general Clight proof, and a work-in-progress general subsumption proof. (only in verif branch) 15 | 16 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -docroot VeriFFI 2 | -Q library VeriFFI.library 3 | -Q generator VeriFFI.generator 4 | -Q verification VeriFFI.verification 5 | -Q examples VeriFFI.examples 6 | -Q CertiGraph CertiGraph 7 | 8 | library/base_representation.v 9 | verification/graph_add.v 10 | library/meta.v 11 | 12 | generator/gen_utils.v 13 | generator/GraphPredicate.v 14 | generator/Isomorphism.v 15 | generator/InGraph.v 16 | generator/CtorDesc.v 17 | generator/Discrimination.v 18 | generator/Rep.v 19 | 20 | 21 | library/isomorphism.v 22 | library/modelled.v 23 | 24 | verification/specs_library.v 25 | verification/specs_general.v 26 | verification/proofs_library_general.v 27 | 28 | examples/uint63z/prog.v 29 | examples/uint63z/glue.v 30 | examples/uint63z/prims.v 31 | examples/uint63z/model.v 32 | 33 | examples/uint63nat/prog.v 34 | examples/uint63nat/glue.v 35 | examples/uint63nat/prims.v 36 | examples/uint63nat/model.v 37 | examples/uint63nat/specs.v 38 | examples/uint63nat/Verif_prog_general.v 39 | examples/uint63nat/prims_verif.v 40 | 41 | examples/compose/prog.v 42 | examples/compose/model.v 43 | examples/compose/glue.v 44 | examples/compose/prims.v 45 | 46 | examples/array/prog.v 47 | examples/array/model.v 48 | examples/array/glue.v 49 | 50 | examples/bytestring/prog.v 51 | examples/bytestring/model.v 52 | examples/bytestring/glue.v 53 | examples/bytestring/Verif_prog.v 54 | examples/bytestring/prims.v 55 | examples/bytestring/specs.v 56 | examples/bytestring/prims_verif.v 57 | -------------------------------------------------------------------------------- /examples/compose/model.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | Require Import Psatz. 3 | Require Import String. 4 | Open Scope string. 5 | 6 | Require Import VeriFFI.library.isomorphism. 7 | Require Import VeriFFI.library.meta. 8 | Require Import VeriFFI.library.modelled. 9 | 10 | Require Import VeriFFI.examples.compose.prog. 11 | 12 | Module FM <: Compose. 13 | Definition compose {A B C} (g : B -> C) (f : A -> B) : A -> C := 14 | fun x => g (f x). 15 | End FM. 16 | 17 | Module Compose_Proofs. 18 | Definition compose_ep : fn_desc := 19 | {| fn_type_reified := 20 | @TYPEPARAM _ (fun A R_A => 21 | @TYPEPARAM _ (fun B R_B => 22 | @TYPEPARAM _ (fun C R_C => 23 | @ARG _ (B -> C) (@transparent _ (@InGraph_fun _ _ (@foreign_in_graph B R_B) (@foreign_in_graph C R_C))) (fun g => 24 | @ARG _ (A -> B) (@transparent _ (@InGraph_fun _ _ (@foreign_in_graph A R_A) (@foreign_in_graph B R_B))) (fun f => 25 | @RES _ (A -> C) (@transparent _ (@InGraph_fun _ _ (@foreign_in_graph A R_A) (@foreign_in_graph C R_C)))))))) 26 | ; foreign_fn := @C.compose 27 | ; model_fn := fun '(A; (_; (B; (_; (C; (_; (g; (f; tt)))))))) => @FM.compose A B C g f 28 | ; fn_arity := 5 29 | ; c_name := "compose" 30 | |}. 31 | 32 | Axiom compose_properties : model_spec compose_ep. 33 | 34 | (* commented out to reduce chatter in build 35 | Eval cbn in model_spec compose_ep. 36 | *) 37 | Lemma compose_pf : 38 | forall {A B C} (g : B -> C) (f : A -> B) (x : A), 39 | C.compose g f x = FM.compose g f x. 40 | Proof. 41 | intros A B C g f x. 42 | props compose_properties. 43 | auto. 44 | Qed. 45 | 46 | End Compose_Proofs. 47 | -------------------------------------------------------------------------------- /c/int63.h: -------------------------------------------------------------------------------- 1 | /* Tim Carstens 2021 */ 2 | 3 | #ifndef CERTICOQ_INT63_H 4 | #define CERTICOQ_INT63_H 5 | 6 | /* 7 | * Encoding/decoding 8 | */ 9 | #include 10 | 11 | value certicoq_encode_int63(int64_t x); 12 | int64_t certicoq_decode_int63(value x); 13 | 14 | 15 | /* 16 | * Prims 17 | */ 18 | value certicoq_prim__int63_zero(struct thread_info *tinfo); 19 | value certicoq_prim__int63_one(struct thread_info *tinfo); 20 | value certicoq_prim__int63_neg(struct thread_info *tinfo, value x); 21 | value certicoq_prim__int63_abs(struct thread_info *tinfo, value x); 22 | value certicoq_prim__int63_add(struct thread_info *tinfo, value x, value y); 23 | value certicoq_prim__int63_sub(struct thread_info *tinfo, value x, value y); 24 | value certicoq_prim__int63_mul(struct thread_info *tinfo, value x, value y); 25 | value certicoq_prim__int63_div(struct thread_info *tinfo, value x, value y); 26 | value certicoq_prim__int63_rem(struct thread_info *tinfo, value x, value y); 27 | value certicoq_prim__int63_shiftl(struct thread_info *tinfo, value x, value y); 28 | value certicoq_prim__int63_shiftr(struct thread_info *tinfo, value x, value y); 29 | value certicoq_prim__int63_or(struct thread_info *tinfo, value x, value y); 30 | value certicoq_prim__int63_and(struct thread_info *tinfo, value x, value y); 31 | value certicoq_prim__int63_xor(struct thread_info *tinfo, value x, value y); 32 | value certicoq_prim__int63_not(struct thread_info *tinfo, value x); 33 | value certicoq_prim__int63_is_eq(struct thread_info *tinfo, value x, value y); 34 | value certicoq_prim__int63_is_lt(struct thread_info *tinfo, value x, value y); 35 | value certicoq_prim__int63_to_nat(struct thread_info *tinfo, value x_val); 36 | 37 | #endif /* CERTICOQ_INT63_H */ 38 | -------------------------------------------------------------------------------- /c/verif_int63.v: -------------------------------------------------------------------------------- 1 | From VST Require Import floyd.proofauto. 2 | From VeriFFI Require Import c.int63. 3 | From VeriFFI Require Import c.spec_int63. 4 | From VeriFFI Require Import library.modelled. 5 | 6 | 7 | Lemma eqmod_mul_m: 8 | forall c m a b, Zbits.eqmod m a b -> Zbits.eqmod (c*m) (c*a) (c*b). 9 | Proof. 10 | intros. 11 | unfold Zbits.eqmod in *. 12 | destruct H as [k ?]. 13 | exists k. lia. 14 | Qed. 15 | 16 | Lemma body_add: semax_body Vprog ASI f_certicoq_prim__int63_add certicoq_prim__int63_add_spec. 17 | Proof. 18 | unfold certicoq_prim__int63_add_spec, tag63. 19 | start_function. 20 | forward. 21 | apply prop_right. 22 | f_equal. 23 | destruct x as [a ?]. 24 | destruct y as [b ?]. 25 | simpl proj1_sig. 26 | replace (2*a+1+(2*b+1)-1) with 27 | (2*(a+b)+1) by lia. 28 | forget (a+b) as c. 29 | clear. 30 | apply Int64.eqm_samerepr. 31 | apply Int64.eqm_add; [ | apply Int64.eqm_refl]. 32 | unfold Int64.eqm. 33 | change Int64.modulus with (2 * 2^63). 34 | apply eqmod_mul_m. 35 | apply Zbits.eqmod_mod. 36 | lia. 37 | Qed. 38 | 39 | Lemma body_mul: semax_body Vprog ASI f_certicoq_prim__int63_mul certicoq_prim__int63_mul_spec. 40 | Proof. 41 | unfold certicoq_prim__int63_mul_spec, tag63. 42 | start_function. 43 | forward. 44 | apply prop_right. 45 | f_equal. 46 | destruct x as [a ?]. 47 | destruct y as [b ?]. 48 | simpl proj1_sig. 49 | unfold Int64.shru. 50 | rewrite !Int64.unsigned_repr by rep_lia. 51 | rewrite mul64_repr. 52 | rewrite Z.shiftr_div_pow2 by lia. 53 | rewrite add64_repr. 54 | rewrite Z.pow_1_r. 55 | replace ((2 * a + 1)/2) with a. 56 | 2:{ 57 | rewrite Z.add_comm. 58 | rewrite Z.mul_comm. 59 | rewrite Z.div_add by lia. 60 | simpl. lia. 61 | } 62 | rewrite Z.add_simpl_r. 63 | replace (a*(2*b)) with (2*(a*b)) by ring. 64 | forget (a+b) as c. 65 | clear. 66 | apply Int64.eqm_samerepr. 67 | apply Int64.eqm_add; [ | apply Int64.eqm_refl]. 68 | unfold Int64.eqm. 69 | change Int64.modulus with (2 * 2^63). 70 | apply eqmod_mul_m. 71 | apply Zbits.eqmod_mod. 72 | lia. 73 | Qed. 74 | -------------------------------------------------------------------------------- /examples/uint63z/prims.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "glue.h" 3 | 4 | typedef enum { XI, XO, XH } tag_positive; 5 | // not very space efficient but it should be easy to prove 6 | value uint63_from_positive(value p) { 7 | switch (get_Coq_Numbers_BinNums_positive_tag(p)) { 8 | case XI: 9 | return ((2 * ((size_t)(uint63_from_positive(get_args(p)[0])) >> 1) + 1) << 1) + 1; 10 | case XO: 11 | return ((2 * ((size_t)(uint63_from_positive(get_args(p)[0])) >> 1)) << 1) + 1; 12 | case XH: 13 | return (1 << 1) + 1; 14 | } 15 | } 16 | 17 | typedef enum { Z0, ZPOS, ZNEG } tag_Z; 18 | value uint63_from_Z(value z) { 19 | switch (get_Coq_Numbers_BinNums_Z_tag(z)) { 20 | case Z0: 21 | return 0; 22 | case ZPOS: 23 | return uint63_from_positive(get_args(z)[0]); 24 | case ZNEG: 25 | return (value)(-(size_t)(uint63_from_positive(get_args(z)[0]))); 26 | } 27 | } 28 | 29 | value uint63_to_Z(struct thread_info *tinfo, value t) { 30 | if (t == 1) { 31 | return make_Coq_Numbers_BinNums_Z_Z0(); 32 | } 33 | value temp = 0; 34 | // loop over bits from left (most significant) to right (least significant) 35 | // ignore the last bit, hence i > 0, not i >= 0 36 | for (unsigned int i = sizeof(value) * 8 - 1; i > 0; i--) { 37 | _Bool bit = ((size_t)t & (1 << i)) >> i; 38 | if (bit) { 39 | if (temp) { 40 | temp = alloc_make_Coq_Numbers_BinNums_positive_xI(tinfo, temp); 41 | } else { 42 | temp = make_Coq_Numbers_BinNums_positive_xH(); 43 | } 44 | } else if (temp) { 45 | temp = alloc_make_Coq_Numbers_BinNums_positive_xO(tinfo, temp); 46 | } 47 | // ignore the 0 bits before the first significant 1 48 | } 49 | return alloc_make_Coq_Numbers_BinNums_Z_Zpos(tinfo, temp); 50 | } 51 | 52 | value uint63_add(value x, value y) { 53 | return (value)(((((size_t)x >> 1) + ((size_t)y >> 1)) << 1) + 1); 54 | } 55 | 56 | value uint63_mul(value x, value y) { 57 | return (value)(((((size_t)x >> 1) * ((size_t)y >> 1)) << 1) + 1); 58 | } 59 | -------------------------------------------------------------------------------- /examples/bytestring/prog.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | 3 | Require Import String. 4 | 5 | Module Type Bytestring. 6 | Axiom bytestring : Type. 7 | Axiom append : bytestring -> bytestring -> bytestring. 8 | Axiom pack : string -> bytestring. 9 | Axiom unpack : bytestring -> string. 10 | 11 | Axiom M : Type -> Type. 12 | Axiom pure : forall {A}, A -> M A. 13 | Axiom bind : forall {A B}, M A -> (A -> M B) -> M B. 14 | Axiom print : bytestring -> M unit. 15 | Axiom scan : nat -> M bytestring. 16 | 17 | Axiom stream : Type. 18 | Axiom get_stdin : unit -> stream. 19 | Axiom get_stdout : unit -> stream. 20 | 21 | Axiom runM : forall {A} (instream outstream : stream), M A -> A. 22 | End Bytestring. 23 | 24 | Module C <: Bytestring. 25 | Axiom bytestring : Type. 26 | Axiom append : bytestring -> bytestring -> bytestring. 27 | Axiom pack : string -> bytestring. 28 | Axiom unpack : bytestring -> string. 29 | 30 | Inductive MI : Type -> Type := 31 | | pureI : forall {A}, A -> MI A 32 | | bindI : forall {A B}, MI A -> (A -> MI B) -> MI B 33 | | printI : bytestring -> MI unit 34 | | scanI : nat -> MI bytestring. 35 | 36 | Definition M := MI. 37 | Definition pure : forall {A}, A -> M A := @pureI. 38 | Definition bind : forall {A B}, M A -> (A -> M B) -> M B := @bindI. 39 | Definition print : bytestring -> M unit := @printI. 40 | Definition scan : nat -> M bytestring := @scanI. 41 | 42 | Axiom stream : Type. 43 | Axiom get_stdin : unit -> stream. 44 | Axiom get_stdout : unit -> stream. 45 | 46 | Axiom runM : forall {A} (instream outstream : stream), M A -> A. 47 | End C. 48 | 49 | CertiCoq Register [ 50 | C.append => "append" with tinfo, 51 | C.pack => "pack" with tinfo, 52 | C.unpack => "unpack" with tinfo, 53 | C.runM => "runM" with tinfo, 54 | C.get_stdin => "get_stdin" with tinfo, 55 | C.get_stdout => "get_stdout" with tinfo 56 | ] Include [ "prims.h" ]. 57 | 58 | Notation "e1 ;; e2" := 59 | (@C.bind _ _ e1 (fun _ => e2)) (at level 61, right associativity). 60 | Notation "x <- c1 ;; c2" := 61 | (@C.bind _ _ c1 (fun x => c2)) (at level 61, c1 at next level, right associativity). 62 | Notation "x ++ y" := (C.append x y) (right associativity, at level 60). 63 | 64 | Definition prog : unit := 65 | C.runM (C.get_stdin tt) (C.get_stdout tt) 66 | (x <- C.scan 10 ;; 67 | y <- C.scan 10 ;; 68 | C.print (C.pack "Hello, " ++ x ++ C.pack " " ++ y)). 69 | -------------------------------------------------------------------------------- /BUILD: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # This BUILD file corresponds, more or less, to docker/Dockerfile 3 | #RUN comments in this correspond, more or less, to commands in Dockerfile 4 | 5 | OPAMJOBS ?= 1 6 | 7 | # leave this out because it's linux-specific 8 | # RUN sudo apt-get update && sudo apt-get install -y libgmp-dev 9 | 10 | # let's not name the switch 4.10.2 because the user might have some other ocaml-4.10.2-purpose switch 11 | # RUN opam switch create 4.10.2 && eval $(opam env) 12 | echo "RUN: opam update" 13 | opam update # recommended 14 | echo "RUN: opam switch create veriffi-coq8.19.1 4.14.1" 15 | opam switch create veriffi-coq8.19.1 4.14.1 # this will fail if the switch already exists 16 | echo "RUN: opam switch veriffi-coq8.19.1" 17 | opam switch veriffi-coq8.19.1 # do this in case the previous command failed, harmless if succeeded 18 | eval $(opam env --switch=veriffi-coq8.19.1 --set-switch) 19 | 20 | # RUN opam repo add coq-released http://coq.inria.fr/opam/released && opam pin add coq 8.19.1 21 | echo "RUN: opam repo add coq-released http://coq.inria.fr/opam/released" 22 | opam repo add coq-released https://coq.inria.fr/opam/released 23 | echo "RUN: opam pin add coq 8.19.1" 24 | opam pin add coq 8.19.1 -y || exit 1 25 | echo "RUN: opam pin add coqide 8.19.1" 26 | opam pin add coqide 8.19.1 -y # all right if this one fails 27 | 28 | echo "RUN: git submodule update --init --checkout --recursive" 29 | git submodule update --init --checkout --recursive || exit 1 30 | 31 | # certicoq is now a submodule of veriffi 32 | # RUN cd && git clone https://github.com/joom/certicoq && cd ~/certicoq && git checkout coq-8.15 && git submodule update --init 33 | 34 | # no longer need metacoq from submodule, since certicoq uses the opam release of metacoq 35 | # echo "RUN: cd certicoq; opam pin -n -y submodules/metacoq" 36 | # (cd certicoq; opam pin -n -y submodules/metacoq) || exit 1 37 | echo "RUN: cd certicoq; opam pin -n -y . || exit 1" 38 | (cd certicoq; opam pin -n -y .) || exit 1 39 | echo "RUN: cd certicoq; opam install coq-certicoq --deps-only -y || exit 1" 40 | (cd certicoq; opam install coq-certicoq --deps-only -y) || exit 1 41 | echo "RUN: clang --version" 42 | clang --version || exit 1 43 | 44 | # RUN cd ~/certicoq && opam install . 45 | echo "RUN: cd certicoq; opam install ." 46 | (cd certicoq; opam install . -y) || exit 1 47 | 48 | echo "RUN: opam install coq-vst.2.14" 49 | opam install coq-vst.2.14 -y || exit 1 50 | echo "RUN: opam install coq-vst-lib.2.14" 51 | opam install coq-vst-lib.2.14 -y || exit 1 52 | 53 | echo "RUN: cd CertiGraph; make -j $(OPAMJOBS) certigc" 54 | (cd CertiGraph; make -j $(OPAMJOBS) certigc) || exit 1 55 | 56 | 57 | # Now build VeriFFI itself 58 | echo "RUN: make -kj $(OPAMJOBS)" 59 | make -kj $(OPAMJOBS) || exit 1 60 | 61 | # USER opam 62 | # RUN /bin/bash 63 | -------------------------------------------------------------------------------- /examples/uint63z/Verif_prog.v: -------------------------------------------------------------------------------- 1 | Require Import VeriFFI.examples.uint63z.prog. 2 | 3 | Require Import ZArith. 4 | Require Import Psatz. 5 | 6 | Require Import VeriFFI.verification.specs_general. 7 | 8 | Require Import VeriFFI.generator.all. 9 | 10 | Obligation Tactic := gen. 11 | MetaCoq Run (gen_for Z). 12 | MetaCoq Run (gen_for nat). 13 | MetaCoq Run (gen_for bool). 14 | 15 | Print positive. 16 | (* MetaCoq Run (desc_gen xH). *) 17 | MetaCoq Run (desc_gen xI). 18 | (* MetaCoq Run (desc_gen xO). *) 19 | 20 | (* MetaCoq Run (desc_gen Z0). *) 21 | (* MetaCoq Run (desc_gen Zpos). *) 22 | (* MetaCoq Run (desc_gen Zneg). *) 23 | 24 | 25 | Require Import VST.floyd.proofauto. 26 | Require Import VeriFFI.examples.uint63z.glue. 27 | Require Import VeriFFI.library.meta. 28 | 29 | Definition alloc_make_Coq_Numbers_BinNums_positive_xI_spec : ident * funspec := 30 | DECLARE _alloc_make_Coq_Numbers_BinNums_positive_xI 31 | (alloc_make_spec_general (@desc _ xI _) 1). 32 | 33 | Instance CompSpecs : compspecs. make_compspecs prog. Defined. 34 | Definition Vprog : varspecs. mk_varspecs prog. Defined. 35 | Definition Gprog := [alloc_make_Coq_Numbers_BinNums_positive_xI_spec]. 36 | 37 | Lemma intro_prop_through_close_precondition : 38 | forall {Espec : OracleKind} Delta (p1 : Prop) f ps LS sf c post, 39 | (p1 -> semax Delta (sepcon (close_precondition f ((PROPx ps LS))) sf) c post) -> 40 | semax Delta (sepcon (close_precondition f (PROPx (p1 :: ps) LS)) sf) c post. 41 | Proof. 42 | intros. 43 | unfold close_precondition in *. 44 | simpl in *. 45 | eapply semax_pre with (andp (prop p1) 46 | (fun rho : environ => 47 | ((EX vals : list val, 48 | !! (map (Map.get (te_of rho)) f = map Some vals /\ 49 | Forall (fun v : val => v <> Vundef) vals) && 50 | PROPx ps LS (ge_of rho, vals)) 51 | * sf rho)%logic)). 52 | 2: apply semax_extract_prop; auto. 53 | clear H. 54 | intro rho. 55 | simpl. 56 | apply andp_left2. 57 | Intro vals. 58 | Exists vals. 59 | unfold PROPx. 60 | simpl. 61 | normalize. 62 | apply andp_right; auto. 63 | apply prop_right; auto. 64 | Qed. 65 | 66 | Check intro_prop_through_close_precondition. 67 | 68 | Lemma body_alloc_make_Coq_Numbers_BinNums_positive_xI : 69 | semax_body Vprog Gprog 70 | f_alloc_make_Coq_Numbers_BinNums_positive_xI 71 | alloc_make_Coq_Numbers_BinNums_positive_xI_spec. 72 | Proof. 73 | unfold alloc_make_Coq_Numbers_BinNums_positive_xI_spec. 74 | unfold alloc_make_spec_general. 75 | start_function1. 76 | repeat (simple apply intro_prop_through_close_precondition; intro). 77 | destruct ps, xs. 78 | 79 | Print PROPx. 80 | 81 | 82 | Print close_precondition. 83 | 84 | 85 | 86 | erewrite compute_close_precondition_eq. 87 | 2 : { reflexivity.} 88 | 2 : { simpl. reflexivity.} 89 | Print start_function2. 90 | start_function2. 91 | start_function. 92 | Admitted. 93 | -------------------------------------------------------------------------------- /library/isomorphism.v: -------------------------------------------------------------------------------- 1 | Require Import Init. 2 | 3 | Class Isomorphism (A B : Type) := 4 | { from : A -> B 5 | ; to : B -> A 6 | ; from_to : forall (x : A), to (from x) = x 7 | ; to_from : forall (x : B), from (to x) = x 8 | }. 9 | 10 | #[export] Instance Isomorphism_refl {A : Type} : Isomorphism A A. 11 | Proof. 12 | refine {| from := id ; to := id ; from_to := _ ; to_from := _ |}; auto. 13 | Defined. 14 | 15 | Lemma Isomorphism_sym {A B : Type} : Isomorphism A B -> Isomorphism B A. 16 | Proof. 17 | intro i. 18 | exact {| from := to 19 | ; to := from 20 | ; from_to := to_from 21 | ; to_from := from_to |}. 22 | Defined. 23 | 24 | Lemma Isomorphism_trans {A B C : Type} : Isomorphism A B -> Isomorphism B C -> Isomorphism A C. 25 | Proof. 26 | intros [f1 t1 pf1 pt1] [f2 t2 pf2 pt2]. 27 | refine {| from := fun x => f2 (f1 x) 28 | ; to := fun x => t1 (t2 x) 29 | ; from_to := _ 30 | ; to_from := _ |}; 31 | intro; [rewrite pf2, pf1 | rewrite pt1, pt2]; auto. 32 | Defined. 33 | 34 | Lemma from_sym : forall A B `(M : Isomorphism A B), 35 | @from A B M = @to B A (Isomorphism_sym M). 36 | Proof. 37 | intros A B M; auto. 38 | Defined. 39 | 40 | Lemma to_sym : forall A B `(M : Isomorphism A B), 41 | @to A B M = @from B A (Isomorphism_sym M). 42 | Proof. 43 | intros A B M; auto. 44 | Defined. 45 | 46 | Lemma from_trans : forall A B C `(M1 : Isomorphism A B) `(M2 : Isomorphism B C), 47 | forall (x : A), @from B C M2 (@from A B M1 x) = @from A C (Isomorphism_trans M1 M2) x . 48 | Proof. 49 | intros A B C [f1 t1 pf1 pt1] [f2 t2 pf2 pt2] x; simpl; auto. 50 | Defined. 51 | 52 | Lemma to_switch : forall A B `(M : Isomorphism A B) (a : A) (b : B), 53 | to b = a -> b = from a. 54 | Proof. 55 | intros A B M a b eq; rewrite <- eq; rewrite to_from; auto. 56 | Defined. 57 | 58 | Require Import Coq.Logic.FunctionalExtensionality. 59 | 60 | Lemma Isomorphism_dep_fn {A A' : Type} {B : A -> Type} {B' : A' -> Type} : 61 | Isomorphism A A' -> 62 | (forall (a : A) (a' : A'), Isomorphism A A' -> Isomorphism (B a) (B' a')) -> 63 | Isomorphism (forall (a : A), B a) (forall (a' : A'), B' a'). 64 | Proof. 65 | intros. 66 | econstructor. 67 | instantiate (1 := ltac:(intros g a; exact (from (g (to a))))). 68 | instantiate (1 := ltac:(intros g a'; exact (to (g (from a'))))). 69 | all: intros; apply functional_extensionality_dep; 70 | intro; rewrite ?from_to, ?to_from; auto. 71 | Defined. 72 | 73 | Lemma Isomorphism_fn {A A' B B' : Type} : 74 | Isomorphism A A' -> Isomorphism B B' -> Isomorphism (A -> B) (A' -> B'). 75 | Proof. 76 | intros i1 i2. 77 | exact (@Isomorphism_dep_fn A A' (fun _ => B) (fun _ => B') i1 (fun _ _ _ => i2)). 78 | Defined. 79 | 80 | Lemma Isomorphism_pair {A A' B B' : Type} : 81 | Isomorphism A A' -> Isomorphism B B' -> Isomorphism (A * B) (A' * B'). 82 | Proof. 83 | intros [f1 t1 ft1 tf1] [f2 t2 ft2 tf2]. 84 | econstructor. 85 | instantiate (1:= ltac:(intros [a b]; split; auto)). 86 | instantiate (1:= ltac:(intros [a b]; split; auto)). 87 | all: intros; intuition. 88 | rewrite ft1, ft2; auto. 89 | rewrite tf1, tf2; auto. 90 | Defined. 91 | -------------------------------------------------------------------------------- /c/certicoq.h: -------------------------------------------------------------------------------- 1 | #ifndef CERTICOQ_H 2 | #define CERTICOQ_H 3 | 4 | 5 | /* 6 | * Abort routines 7 | */ 8 | void certicoq_prim__abort(const char *fn, const char *fmt, ...); 9 | #define certicoq_abort_str(str) certicoq_prim__abort(__FUNCTION__, "%s", str) 10 | #define certicoq_abort(fmt, ...) certicoq_prim__abort(__FUNCTION__, fmt, __VA_ARGS__) 11 | #define certicoq_abort_if_null(p) if (!(p)) { certicoq_prim__abort(__FUNCTION__, "expected non-null pointer\n"); } 12 | #define certicoq_abort_if_not_null(p) if (p) { certicoq_prim__abort(__FUNCTION__, "expected null pointer\n"); } 13 | 14 | 15 | /* 16 | * GC 17 | */ 18 | #include "gc_stack.h" 19 | 20 | 21 | /* 22 | * CertiCoq stuff 23 | */ 24 | extern value call(struct thread_info *, value, value); 25 | value calls(struct thread_info* tinfo, value clos, unsigned int n, ...); 26 | 27 | extern value make_Coq_Init_Datatypes_unit_tt(void); 28 | 29 | extern value make_Coq_Init_Datatypes_option_None(void); 30 | extern value alloc_make_Coq_Init_Datatypes_option_Some(struct thread_info *, value); 31 | 32 | extern unsigned int get_Coq_Init_Datatypes_bool_tag(value); 33 | extern value make_Coq_Init_Datatypes_bool_true(void); 34 | extern value make_Coq_Init_Datatypes_bool_false(void); 35 | 36 | extern unsigned int get_Coq_Init_Datatypes_list_tag(value); 37 | extern value make_Coq_Init_Datatypes_list_nil(void); 38 | extern value alloc_make_Coq_Init_Datatypes_list_cons(struct thread_info *, value, value); 39 | 40 | extern value make_Coq_Init_Datatypes_nat_O(void); 41 | extern value alloc_make_Coq_Init_Datatypes_nat_S(struct thread_info *, value); 42 | 43 | extern value alloc_make_Coq_Strings_Ascii_ascii_Ascii(struct thread_info *, value, value, value, value, value, value, value, value); 44 | 45 | extern unsigned int get_Coq_Strings_String_string_tag(value); 46 | extern value make_Coq_Strings_String_string_EmptyString(void); 47 | extern value alloc_make_Coq_Strings_String_string_String(struct thread_info *, value, value); 48 | struct Coq_Strings_String_String_args { 49 | value Coq_Strings_String_String_arg_0; 50 | value Coq_Strings_String_String_arg_1; 51 | }; 52 | extern struct Coq_Strings_String_String_args *get_Coq_Strings_String_String_args(value v); 53 | 54 | 55 | /* 56 | * Primops 57 | */ 58 | /* #include "array.h" */ 59 | #include "blob.h" 60 | /* #include "bytestring.h" */ 61 | /* #include "uint8.h" */ 62 | /* #include "int63.h" */ 63 | /* #include "mut.h" */ 64 | 65 | 66 | /* 67 | * Effects 68 | */ 69 | enum certicoq_prim__effect_tag { 70 | certicoq_prim__E_bytestring = 0, 71 | certicoq_prim__E_mut, 72 | certicoq_prim__E_array, 73 | }; 74 | 75 | extern enum certicoq_prim__effect_tag get_CertiCoqExt_Lib_CertiCoqRT_E_tag(value); 76 | 77 | value certicoq_prim__exec_effect(struct thread_info *tinfo, value effect_val); 78 | 79 | 80 | /* 81 | * ITrees 82 | */ 83 | enum certicoq_prim__itree_tag { 84 | certicoq_prim__IT_ret = 0, 85 | certicoq_prim__IT_vis, 86 | certicoq_prim__IT_tau 87 | }; 88 | 89 | extern enum certicoq_prim__itree_tag get_CertiCoqExt_Lib_CertiCoqRT_ITree_tag(value); 90 | 91 | value certicoq_prim__exec_itree(value (*exec_effect)(struct thread_info *, value), struct thread_info *tinfo, value itree_val); 92 | 93 | #endif /* CERTICOQ_H */ 94 | -------------------------------------------------------------------------------- /tests/generators.v: -------------------------------------------------------------------------------- 1 | (* 2 | Require Import VeriFFI.generator.Rep. 3 | 4 | MetaCoq Run (gen_for unit). 5 | MetaCoq Run (gen_for bool). 6 | MetaCoq Run (gen_for nat). 7 | MetaCoq Run (gen_for option). 8 | MetaCoq Run (gen_for prod). 9 | MetaCoq Run (gen_for list). 10 | 11 | Inductive vec (A : Type) : nat -> Type := 12 | | vnil : vec A O 13 | | vcons : forall n, A -> vec A n -> vec A (S n). 14 | 15 | MetaCoq Run (gen_for nat). 16 | 17 | Inductive option_indexed : Type -> Type := 18 | | mysome : forall A, A -> option_indexed A. 19 | (* This is supposed to fail because if the type argument is not a parameter, 20 | then knowing how to represent things of that type statically is tricky, 21 | and often impossible. *) 22 | Fail MetaCoq Run (gen_for option_indexed). 23 | 24 | Inductive mylist (A B : Type) : Type := 25 | | mynil : mylist A B 26 | | mycons : A -> option A -> option B -> mylist A B. 27 | MetaCoq Run (in_graph_gen mylist). 28 | 29 | (* Testing mutually recursive inductive types: *) 30 | Inductive T1 := 31 | | c1 : T2 -> T1 32 | with T2 := 33 | | c2 : T1 -> T2. 34 | MetaCoq Run (gen_for T1). 35 | 36 | Inductive tree (A : Type) : Type := 37 | | tleaf : tree A 38 | | tnode : nat -> forest A -> tree A 39 | with forest (A : Type) : Type := 40 | | fnil : forest A 41 | | fcons : tree A -> forest A -> forest A. 42 | MetaCoq Run (gen_for tree) 43 | 44 | (* Testing dependent types: *) 45 | Inductive natty : nat -> nat -> Type := 46 | | mynatty : forall n m, natty n m. 47 | MetaCoq Run (gen_for natty). 48 | 49 | Inductive D1 : nat -> Type := 50 | | cd1 : forall n : nat, D1 n. 51 | MetaCoq Run (gen_for D1). 52 | 53 | Inductive D2 (n : nat) : Type := 54 | | cd2 : D2 n. 55 | MetaCoq Run (gen_for D2). 56 | 57 | Inductive indexed : nat -> Type := 58 | | bar : indexed O. 59 | MetaCoq Run (gen_for indexed). 60 | 61 | Inductive fin : nat -> Set := 62 | | F1 : forall {n}, fin (S n) 63 | | FS : forall {n}, fin n -> fin (S n). 64 | MetaCoq Run (gen_for fin). 65 | 66 | Inductive param_and_index (a b : nat) : a < b -> Type := 67 | | foo : forall (pf : a < b), param_and_index a b pf. 68 | MetaCoq Run (gen_for param_and_index). 69 | 70 | (* Testing nested types: *) 71 | (* "Haskell Programming with Nested Types: A Principled Approach", Johann and Ghani, 2009 *) 72 | Inductive lam (A : Type) : Type := 73 | | variable : A -> lam A 74 | | app : lam A -> lam A -> lam A 75 | | abs : lam (option A) -> lam A. 76 | MetaCoq Run (gen_for lam). 77 | 78 | Inductive digit (A : Type) : Type := 79 | | one : A -> digit A 80 | | two : A -> A -> digit A 81 | | three : A -> A -> A -> digit A 82 | | four : A -> A -> A -> A -> digit A. 83 | Inductive node (A : Type) : Type := 84 | | node2 : nat -> A -> A -> node A 85 | | node3 : nat -> A -> A -> A -> node A. 86 | Inductive finger_tree (A : Type) : Type := 87 | | emptyT : finger_tree A 88 | | single : A -> finger_tree A 89 | | deep : nat -> digit A -> finger_tree (node A) -> digit A -> finger_tree A. 90 | MetaCoq Run (gen_for finger_tree). 91 | 92 | Inductive two (A : Type) := 93 | | mkTwo : A -> A -> two A. 94 | Inductive tree (A : Type) : Type := 95 | | leaf : tree A 96 | | node : two (tree A) -> tree A. 97 | Inductive ntree (A : Type) : Type := 98 | | nleaf : ntree A 99 | | nnode : ntree (two A) -> ntree A. 100 | MetaCoq Run (gen_for ntree). 101 | *) 102 | -------------------------------------------------------------------------------- /examples/array/prog.v: -------------------------------------------------------------------------------- 1 | From CertiCoq.Plugin Require Import CertiCoq. 2 | 3 | Definition elt := nat. 4 | 5 | Module Type Array. 6 | Axiom M : Type -> Type. 7 | Axiom pure : forall {A}, A -> M A. 8 | Axiom bind : forall {A B}, M A -> (A -> M B) -> M B. 9 | Axiom runM : forall {A} (len : nat) (init : elt), M A -> A. 10 | Axiom set : nat -> elt -> M unit. 11 | Axiom get : nat -> M elt. 12 | End Array. 13 | 14 | Module C <: Array. 15 | Inductive MI : Type -> Type := 16 | | pureI : forall {A}, A -> MI A 17 | | bindI : forall {A B}, MI A -> (A -> MI B) -> MI B 18 | | setI : nat -> elt -> MI unit 19 | | getI : nat -> MI elt. 20 | 21 | Definition M := MI. 22 | Definition pure : forall {A}, A -> M A := @pureI. 23 | Definition bind : forall {A B}, M A -> (A -> M B) -> M B := @bindI. 24 | Definition set : nat -> elt -> M unit := @setI. 25 | Definition get : nat -> M elt := @getI. 26 | Axiom runM : forall {A} (len : nat) (init : elt), M A -> A. 27 | End C. 28 | 29 | CertiCoq Register [ 30 | C.runM => "array_runM" with tinfo 31 | ] Include [ "prims.h" ]. 32 | 33 | Notation "e1 ;; e2" := 34 | (@C.bind _ _ e1 (fun _ => e2)) (at level 61, right associativity). 35 | Notation "x <- c1 ;; c2" := 36 | (@C.bind _ _ c1 (fun x => c2)) (at level 61, c1 at next level, right associativity). 37 | 38 | (* 39 | Module Array2D. 40 | Definition runM {A} (rows cols : nat) (init : elt) (m : C.M A) : A := 41 | C.runM (rows * cols) init m. 42 | 43 | Definition get {cols : nat} (row col : nat) : C.M elt := 44 | C.get (row * cols + col). 45 | 46 | Definition set {cols : nat} (row col : nat) (x : elt) : C.M unit := 47 | C.set (row * cols + col) x. 48 | End Array2D. 49 | 50 | Check (Array2D.runM 3 3 0 (Array2D.set 0 0 1 ;; Array2D.get 0 0)). 51 | *) 52 | 53 | Require Import List. 54 | Import ListNotations. 55 | 56 | Definition incr (i : nat) : C.M unit := 57 | v <- C.get i ;; 58 | C.set i (1 + v). 59 | 60 | Definition index : Type := nat. 61 | 62 | Definition higher_elt (x : option (index * elt)) (y : (index * elt)) : option (index * elt) := 63 | match x, y with 64 | | Some (i1, x'), (i2, y') => if Nat.leb x' y' then Some y else x 65 | | None, _ => Some y 66 | end. 67 | 68 | Definition mode (xs : list elt) : option elt := 69 | let fix create (xs : list elt) : C.M unit := 70 | match xs with 71 | | [] => C.pure tt 72 | | y :: ys => incr y ;; create ys 73 | end in 74 | let fix find (len : index) (highest : option (index * elt)) : C.M (option (index * elt)) := 75 | match len with 76 | | S len' => e <- C.get len' ;; 77 | find len' (higher_elt highest (len', e)) 78 | | O => C.pure highest 79 | end in 80 | let final (len : index) : C.M (option index) := 81 | o <- find len None ;; 82 | match o with 83 | | Some (i, o) => C.pure (Some i) 84 | | None => C.pure None 85 | end in 86 | let len := match xs with [] => O | _ => S (List.list_max xs) end in 87 | C.runM len O (create xs ;; final len). 88 | 89 | Definition prog := mode [1;2;3;2;3;2;4]. 90 | 91 | (* 92 | Definition fib (len : nat) : nat := 93 | let fix aux (n : nat) (fuel : nat) {struct fuel} : C.M unit := 94 | match fuel with 95 | | O => C.pure tt 96 | | S fuel' => 97 | x <- C.get (pred (pred n)) ;; 98 | y <- C.get (pred n) ;; 99 | C.set n (x + y) ;; 100 | aux (S n) fuel' 101 | end 102 | in C.runM (S len) 1 (aux 2 (pred len) ;; C.get len). 103 | 104 | Definition prog := fib 7. 105 | *) 106 | -------------------------------------------------------------------------------- /c/int63.c: -------------------------------------------------------------------------------- 1 | /* Tim Carstens 2021 */ 2 | 3 | #ifndef CERTICOQ_INT63_C 4 | #define CERTICOQ_INT63_C 5 | 6 | #include "certicoq.h" 7 | #include "int63.h" 8 | 9 | 10 | /* 11 | * Encoding/decoding 12 | value certicoq_encode_int63(int64_t x) { 13 | return (x << 1) | 1; 14 | } 15 | 16 | int64_t certicoq_decode_int63(value x) { 17 | return (int64_t)x >> 1; 18 | } 19 | */ 20 | 21 | /* 22 | * Prims 23 | value certicoq_prim__int63_zero() { 24 | return certicoq_encode_int63(0); 25 | } 26 | 27 | value certicoq_prim__int63_one() { 28 | return certicoq_encode_int63(1); 29 | } 30 | 31 | value certicoq_prim__int63_neg(value x) { 32 | return 2 - x; 33 | } 34 | 35 | value certicoq_prim__int63_abs(value x) { 36 | return x < 0 ? certicoq_prim__int63_neg(x) : x; 37 | } 38 | */ 39 | 40 | value certicoq_prim__int63_from_Z(struct thread_info *tinfo, value x) { 41 | return 0; 42 | } 43 | 44 | value certicoq_prim__int63_to_Z(struct thread_info *tinfo, value x) { 45 | size_t n = ((uintnat)x)>>1; 46 | return 0; 47 | } 48 | 49 | value certicoq_prim__int63_add(struct thread_info *tinfo, value x, value y) { 50 | return (value)(((uintnat)x + (uintnat)y) - (uintnat)1); 51 | } 52 | 53 | value certicoq_prim__int63_sub(struct thread_info *tinfo, value x, value y) { 54 | return (x - y) + 1; 55 | } 56 | 57 | value certicoq_prim__int63_mul(struct thread_info *tinfo, value x, value y) { 58 | return (value)((((uintnat)x)>>1) * (((uintnat)y)-1) + 1); 59 | } 60 | 61 | value certicoq_prim__int63_div(struct thread_info *tinfo, value x, value y) { 62 | return (value)((((uintnat)x)-1) * (((uintnat)y)>>1)+(uintnat)1); 63 | } 64 | 65 | /* 66 | value certicoq_prim__int63_rem(value x, value y) { 67 | const int64_t _x = certicoq_decode_int63(x); 68 | const int64_t _y = certicoq_decode_int63(y); 69 | const int64_t _z = _x % _y; 70 | return certicoq_encode_int63(_z); 71 | } 72 | 73 | value certicoq_prim__int63_shiftl(value x, value y) { 74 | const int64_t _x = certicoq_decode_int63(x); 75 | const int64_t _y = certicoq_decode_int63(y); 76 | const int64_t _z = _x << _y; 77 | return certicoq_encode_int63(_z); 78 | } 79 | 80 | value certicoq_prim__int63_shiftr(value x, value y) { 81 | const int64_t _x = certicoq_decode_int63(x); 82 | const int64_t _y = certicoq_decode_int63(y); 83 | const int64_t _z = _x >> _y; 84 | return certicoq_encode_int63(_z); 85 | } 86 | */ 87 | 88 | value certicoq_prim__int63_or(struct thread_info *tinfo, value x, value y) { 89 | return x | y; 90 | } 91 | 92 | value certicoq_prim__int63_and(struct thread_info *tinfo, value x, value y) { 93 | return x & y; 94 | } 95 | 96 | value certicoq_prim__int63_xor(struct thread_info *tinfo, value x, value y) { 97 | return (value)1 | (x ^ y); 98 | } 99 | 100 | value certicoq_prim__int63_not(struct thread_info *tinfo, value x) { 101 | return (value)1 | ~ x; 102 | } 103 | 104 | value certicoq_prim__int63_is_eq(struct thread_info *tinfo, value x, value y) { 105 | return (x == y) ? make_Coq_Init_Datatypes_bool_true() : make_Coq_Init_Datatypes_bool_false(); 106 | } 107 | 108 | value certicoq_prim__int63_is_lt(struct thread_info *tinfo, value x, value y) { 109 | return ((uintnat)x < (uintnat)y) ? make_Coq_Init_Datatypes_bool_true() : make_Coq_Init_Datatypes_bool_false(); 110 | } 111 | 112 | /* 113 | value certicoq_prim__int63_to_nat(struct thread_info *tinfo, value x_val) { 114 | int64_t x = certicoq_decode_int63(x_val); 115 | value ret = make_Coq_Init_Datatypes_nat_O(); 116 | while (x > 0) { 117 | ret = alloc_make_Coq_Init_Datatypes_nat_S(tinfo, ret); 118 | x--; 119 | } 120 | return ret; 121 | } 122 | */ 123 | 124 | #endif /* CERTICOQ_INT63_C */ 125 | -------------------------------------------------------------------------------- /examples/array/prims.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "glue.h" 4 | #include 5 | #include 6 | 7 | // live pointers 8 | #define LIVEPOINTERS0(tinfo, exp) (exp) 9 | #define LIVEPOINTERS1(tinfo, exp, a) ({ \ 10 | value __ROOT__[1] = { a }; \ 11 | struct stack_frame __FRAME__ = { __ROOT__ + 1, __ROOT__, tinfo->fp }; \ 12 | tinfo->fp = &__FRAME__; value __TEMP__ = exp; \ 13 | a = __ROOT__[0]; \ 14 | tinfo->fp = __FRAME__.prev; __TEMP__; }) 15 | #define LIVEPOINTERS2(tinfo, exp, a, b) ({ \ 16 | value __ROOT__[2] = { a, b }; \ 17 | struct stack_frame __FRAME__ = { __ROOT__ + 2, __ROOT__, tinfo->fp }; \ 18 | tinfo->fp = &__FRAME__; value __TEMP__ = exp; \ 19 | a = __ROOT__[0]; b = __ROOT__[1]; \ 20 | tinfo->fp = __FRAME__.prev; __TEMP__; }) 21 | #define LIVEPOINTERS2_(tinfo, exp, a, b) ({ \ 22 | value __ROOT__[2] = { a, b }; \ 23 | struct stack_frame __FRAME__ = { __ROOT__ + 2, __ROOT__, tinfo->fp }; \ 24 | tinfo->fp = &__FRAME__; exp; \ 25 | a = __ROOT__[0]; b = __ROOT__[1]; \ 26 | tinfo->fp = __FRAME__.prev; }) 27 | #define LIVEPOINTERS3(tinfo, exp, a, b, c) ({ \ 28 | value __ROOT__[3] = { a, b, c }; \ 29 | struct stack_frame __FRAME__ = { __ROOT__ + 3, __ROOT__, tinfo->fp }; \ 30 | tinfo->fp = &__FRAME__; value __TEMP__ = exp; \ 31 | a = __ROOT__[0]; b = __ROOT__[1]; c = __ROOT__[2]; \ 32 | tinfo->fp = __FRAME__.prev; __TEMP__; }) 33 | #define LIVEPOINTERS4(tinfo, exp, a, b, c, d) ({ \ 34 | value __ROOT__[4] = { a, b, c, d }; \ 35 | struct stack_frame __FRAME__ = { __ROOT__ + 4, __ROOT__, tinfo->fp }; \ 36 | tinfo->fp = &__FRAME__; value __TEMP__ = exp; \ 37 | a = __ROOT__[0]; b = __ROOT__[1]; c = __ROOT__[2]; d = __ROOT__[3]; \ 38 | tinfo->fp = __FRAME__.prev; __TEMP__; }) 39 | 40 | typedef enum { O, S } nat; 41 | unsigned long long nat_to_ull(value n) { 42 | value temp = n; 43 | unsigned int i = 0; 44 | 45 | while(1) { 46 | unsigned int tag = get_Coq_Init_Datatypes_nat_tag(temp); 47 | if(tag == S) { 48 | i++; 49 | temp = get_args(temp)[0]; 50 | } else { 51 | break; 52 | } 53 | } 54 | return i; 55 | } 56 | 57 | typedef enum { PURE, BIND, SET, GET } mi; 58 | value runM(struct thread_info *tinfo, unsigned long long size, value init, value arr, value action) { 59 | value i, temp, arg0, arg1; 60 | switch (get_prog_C_MI_tag(action)) { 61 | case PURE: 62 | return get_args(action)[1]; 63 | case BIND: 64 | arg0 = get_args(action)[2]; 65 | arg1 = get_args(action)[3]; 66 | temp = LIVEPOINTERS4(tinfo, runM(tinfo, size, init, arr, arg0), arg0, arg1, init, arr); 67 | temp = LIVEPOINTERS4(tinfo, call(tinfo, arg1, temp), arg1, init, arr, temp); 68 | return runM(tinfo, size, init, arr, temp); 69 | case SET: 70 | arg0 = get_args(action)[0]; 71 | i = nat_to_ull(arg0); 72 | arg1 = get_args(action)[1]; 73 | // check if there's enough memory for the update record (1 word) 74 | if (!(1 <= tinfo->limit - tinfo->alloc)) { 75 | tinfo->nalloc = 1; 76 | LIVEPOINTERS2_(tinfo, garbage_collect(tinfo), arr, arg1); 77 | } 78 | if (i < size) { 79 | certicoq_modify(tinfo, (value *) arr + i, arg1); 80 | } 81 | return make_Coq_Init_Datatypes_unit_tt(); 82 | case GET: 83 | arg0 = get_args(action)[0]; 84 | i = nat_to_ull(arg0); 85 | if (i < size) { 86 | return *((value *) arr + i); 87 | } else { 88 | return init; 89 | } 90 | } 91 | } 92 | 93 | value array_runM(struct thread_info *tinfo, value a, value len, value init, value action) { 94 | size_t size = nat_to_ull(len); 95 | size_t nalloc = size + 1; 96 | // check if there's enough memory for the array (size + 1 word for header) 97 | if (!(nalloc <= tinfo->limit - tinfo->alloc)) { 98 | tinfo->nalloc = nalloc; 99 | LIVEPOINTERS2_(tinfo, garbage_collect(tinfo), init, action); 100 | } 101 | value *arr = tinfo->alloc; 102 | arr[0LLU] = size << 10; 103 | arr = arr + 1LLU; 104 | for (size_t i = 0; i < size; i++) { 105 | arr[i] = init; 106 | } 107 | tinfo->alloc += nalloc; 108 | return runM(tinfo, size, init, (value) arr, action); 109 | } 110 | -------------------------------------------------------------------------------- /library/modelled.v: -------------------------------------------------------------------------------- 1 | Require Import String. 2 | 3 | Require Import ZArith. 4 | Require Import Psatz. 5 | Require Import List. 6 | Import ListNotations. 7 | 8 | Require Import VeriFFI.library.isomorphism. 9 | Require Import VeriFFI.library.meta. 10 | 11 | Class ForeignInGraph (model foreign : Type) : Type := 12 | model_in_graph : InGraph model. 13 | 14 | Class foreign_ann (primary : Type) : Type := 15 | { secondary : Type 16 | ; foreign_in_graph :: ForeignInGraph primary secondary 17 | ; foreign_iso : Isomorphism primary secondary 18 | }. 19 | 20 | Definition transparent {A : Type} `{IG_A : InGraph A} : foreign_ann A := 21 | {| secondary := A 22 | ; foreign_in_graph := IG_A 23 | ; foreign_iso := Isomorphism_refl 24 | |}. 25 | 26 | Definition opaque {A B : Type} 27 | `{IG_A : ForeignInGraph A B} 28 | `{Iso : Isomorphism A B} : foreign_ann A := 29 | {| secondary := B 30 | ; foreign_in_graph := IG_A 31 | ; foreign_iso := Iso 32 | |}. 33 | 34 | Definition foreign_ann_any {A} : foreign_ann A := @transparent A InGraph_any. 35 | 36 | Fixpoint to_foreign_fn_type (r : reified foreign_ann) : Type := 37 | match r with 38 | | TYPEPARAM f => 39 | forall (A : Type), 40 | to_foreign_fn_type (f A foreign_ann_any) 41 | | ARG primary ann k => 42 | forall (m : secondary), 43 | to_foreign_fn_type (k (@to primary secondary foreign_iso m)) 44 | | RES _ ann => secondary 45 | end. 46 | 47 | Fixpoint to_model_fn_type (r : reified foreign_ann) : Type := 48 | match r with 49 | | TYPEPARAM f => 50 | forall (A : Type), 51 | to_model_fn_type (f A foreign_ann_any) 52 | | ARG primary ann k => forall (p : primary), to_model_fn_type (k p) 53 | | RES primary ann => primary 54 | end. 55 | 56 | Fixpoint curry_model_fn 57 | (r : reified foreign_ann) 58 | (mt : reflect r) {struct r} : to_model_fn_type r. 59 | Proof. 60 | unfold reflect in *. 61 | destruct r. 62 | * intro A. 63 | refine (curry_model_fn (r A foreign_ann_any) (fun P => _)). 64 | change (projT1 (result (TYPEPARAM foreign_ann r) (A; (foreign_ann_any; P)))). 65 | apply mt. 66 | * intro a. 67 | refine (curry_model_fn (r a) (fun P => _)). 68 | change (projT1 (result (ARG foreign_ann A r) (a; P))). 69 | apply mt. 70 | * exact (mt tt). 71 | Defined. 72 | 73 | Record fn_desc := 74 | { fn_type_reified : reified foreign_ann 75 | ; foreign_fn : to_foreign_fn_type fn_type_reified 76 | ; model_fn : reflect fn_type_reified 77 | ; fn_arity : nat 78 | ; c_name : string 79 | }. 80 | 81 | Definition curried_model_fn (d : fn_desc) : to_model_fn_type (fn_type_reified d) := 82 | curry_model_fn (fn_type_reified d) (model_fn d). 83 | 84 | (* 85 | From Equations Require Import Equations Signature. 86 | 87 | Ltac rewrite_apply lem t := 88 | let m := fresh "m" in 89 | pose (m := t); 90 | rewrite lem in m; 91 | apply m. 92 | 93 | Equations model_spec_aux 94 | (a : reified foreign_ann) 95 | (pt : to_foreign_fn_type a) 96 | (mt : to_model_fn_type a) : Prop := 97 | model_spec_aux (@TYPEPARAM f) pt mt := 98 | forall (A : Type), model_spec_aux (f A foreign_ann_any) (pt A) (mt A) ; 99 | model_spec_aux (@ARG primary ann k) pt mt := 100 | forall (x : secondary), 101 | model_spec_aux (k (to x)) (pt x) (mt (to x)) ; 102 | model_spec_aux (@RES primary ann) pt mt := 103 | pt = @from _ _ foreign_iso mt. 104 | *) 105 | 106 | Fixpoint model_spec_aux 107 | (a : reified foreign_ann) 108 | (ft : to_foreign_fn_type a) 109 | (mt : to_model_fn_type a) {struct a} : Prop. 110 | Proof. 111 | destruct a as [f | primary ann k | A ann]; simpl in ft, mt. 112 | * exact (forall (A : Type), 113 | model_spec_aux (f A foreign_ann_any) (ft A) (mt A)). 114 | * destruct ann as [secondary FIG Iso]. 115 | unfold ForeignInGraph in FIG. 116 | refine (forall (x : secondary), model_spec_aux (k (to x)) (ft x) (mt (to x))). 117 | * destruct ann as [secondary IG Iso]. 118 | exact (ft = from mt). 119 | Defined. 120 | 121 | Definition model_spec (d : fn_desc) : Prop := 122 | model_spec_aux (fn_type_reified d) (foreign_fn d) (curried_model_fn d). 123 | 124 | Ltac eq_refl_match := 125 | match goal with 126 | | [ |- context[match ?x with | eq_refl => _ end] ] => destruct x 127 | (* | [ _ : context[match ?x with | eq_refl => _ end] |- _] => destruct x *) 128 | end. 129 | 130 | Ltac foreign_rewrites := 131 | unfold curried_model_fn, curry_model_fn; simpl; 132 | repeat eq_refl_match; 133 | repeat rewrite ?from_to, ?to_from. 134 | 135 | Ltac props x := 136 | let P := fresh in 137 | pose proof x as P; 138 | hnf in P; 139 | simpl in P; 140 | rewrite !P; 141 | unfold id, eq_rect in *; 142 | clear P. 143 | -------------------------------------------------------------------------------- /Makefile.coq.local: -------------------------------------------------------------------------------- 1 | INCLUDE=certicoq/plugin/runtime 2 | GCDIR=certicoq/plugin/runtime 3 | 4 | GLUE_FILES=examples/uint63z/glue.v examples/uint63nat/glue.v examples/compose/glue.v examples/array/glue.v examples/bytestring/glue.v 5 | PRIMS_FILES=examples/uint63z/prims.v examples/uint63nat/prims.v examples/compose/prims.v examples/array/prims.v examples/bytestring/prims.v 6 | GENERATED_VFILES= $(GLUE_FILES) $(PRIMS_FILES) 7 | glue_files: $(GLUE_FILES) 8 | prims_files: $(PRIMS_FILES) 9 | generated_vfiles: $(GENERATED_VFILES) 10 | 11 | examples/uint63nat/glue.c examples/uint63nat/glue.h examples/uint63nat/prog.c examples/uint63nat/prog.h : examples/uint63nat/gluegen.v examples/uint63nat/prog.vo 12 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 13 | examples/uint63nat/gc_stack.o: $(GCDIR)/gc_stack.c $(GCDIR)/gc_stack.h $(GCDIR)/m.h $(GCDIR)/config.h $(GCDIR)/values.h 14 | $(CC) $(CFLAGS) -I$(INCLUDE) -c $< -o $@ 15 | uint63nat-c: examples/uint63nat/prog.c examples/uint63nat/main.c examples/uint63nat/gc_stack.o examples/uint63nat/glue.c examples/uint63nat/prims.c 16 | cd examples/uint63nat; $(CC) ../../$(INCLUDE) -w -g -o prog main.c gc_stack.o prog.c glue.c prims.c 17 | examples/uint63nat/prims.v: examples/uint63nat/prims.c examples/uint63nat/glue.h 18 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 19 | examples/uint63nat/glue.v: examples/uint63nat/glue.c 20 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 21 | 22 | examples/uint63z/glue.c examples/uint63z/glue.h examples/uint63z/prog.c examples/uint63z/prog.h : examples/uint63z/gluegen.v examples/uint63z/prog.vo 23 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 24 | examples/uint63z/gc_stack.o: $(GCDIR)/gc_stack.c $(GCDIR)/gc_stack.h $(GCDIR)/m.h $(GCDIR)/config.h $(GCDIR)/values.h 25 | $(CC) $(CFLAGS) -I$(INCLUDE) -c $< -o $@ 26 | uint63z-c: examples/uint63z/prog.c examples/uint63z/main.c examples/uint63z/gc_stack.o examples/uint63z/glue.c examples/uint63z/prims.c 27 | cd examples/uint63z; $(CC) ../../$(INCLUDE) -w -g -o prog main.c gc_stack.o prog.c glue.c prims.c 28 | examples/uint63z/prims.v: examples/uint63z/prims.c examples/uint63z/glue.h 29 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 30 | examples/uint63z/glue.v: examples/uint63z/glue.c 31 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 32 | 33 | examples/array/glue.c examples/array/glue.h examples/array/prog.c examples/array/prog.h : examples/array/gluegen.v examples/array/prog.vo 34 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 35 | examples/array/gc_stack.o: $(GCDIR)/gc_stack.c $(GCDIR)/gc_stack.h $(GCDIR)/m.h $(GCDIR)/config.h $(GCDIR)/values.h 36 | $(CC) $(CFLAGS) -I$(INCLUDE) -c $< -o $@ 37 | array-c: examples/array/prog.c examples/array/main.c examples/array/gc_stack.o examples/array/glue.c examples/array/prims.c 38 | cd examples/array; $(CC) ../../$(INCLUDE) -w -g -o prog main.c gc_stack.o prog.c glue.c prims.c 39 | examples/array/prims.v: examples/array/prims.c examples/array/glue.h 40 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 41 | examples/array/glue.v: examples/array/glue.c 42 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 43 | 44 | examples/bytestring/glue.c examples/bytestring/glue.h examples/bytestring/prog.c examples/bytestring/prog.h : examples/bytestring/gluegen.v examples/bytestring/prog.vo 45 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 46 | examples/bytestring/gc_stack.o: $(GCDIR)/gc_stack.c $(GCDIR)/gc_stack.h $(GCDIR)/m.h $(GCDIR)/config.h $(GCDIR)/values.h 47 | $(CC) $(CFLAGS) -I$(INCLUDE) -c $< -o $@ 48 | bytestring-c: examples/bytestring/prog.c examples/bytestring/main.c examples/bytestring/gc_stack.o examples/bytestring/glue.c examples/bytestring/prims.c 49 | cd examples/bytestring; $(CC) ../../$(INCLUDE) -w -g -o prog main.c gc_stack.o prog.c glue.c prims.c 50 | examples/bytestring/prims.v: examples/bytestring/prims.c examples/bytestring/glue.h 51 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 52 | examples/bytestring/glue.v: examples/bytestring/glue.c 53 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 54 | 55 | examples/compose/glue.c examples/compose/glue.h examples/compose/prog.c examples/compose/prog.h : examples/compose/gluegen.v examples/compose/prog.vo 56 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 57 | examples/compose/gc_stack.o: $(GCDIR)/gc_stack.c $(GCDIR)/gc_stack.h $(GCDIR)/m.h $(GCDIR)/config.h $(GCDIR)/values.h 58 | $(CC) $(CFLAGS) -I$(INCLUDE) -c $< -o $@ 59 | compose-c: examples/compose/prog.c examples/compose/main.c examples/compose/gc_stack.o examples/compose/glue.c examples/compose/prims.c 60 | cd examples/compose; $(CC) ../../$(INCLUDE) -w -g -o prog main.c gc_stack.o prog.c glue.c prims.c 61 | examples/compose/prims.v: examples/compose/prims.c examples/compose/glue.h 62 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 63 | examples/compose/glue.v: examples/compose/glue.c 64 | clightgen -I$(INCLUDE) -normalize -DVERIFFI -DCOMPCERT $< -o $@ 65 | 66 | -------------------------------------------------------------------------------- /examples/uint63nat/model.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | Require Import Psatz. 3 | Require Import String. 4 | Open Scope string. 5 | 6 | Require Import VeriFFI.library.modelled. 7 | Require Import VeriFFI.library.isomorphism. 8 | Require Import VeriFFI.library.meta. 9 | 10 | Require Import VeriFFI.generator.Rep. 11 | Local Obligation Tactic := gen. 12 | MetaCoq Run (gen_for nat). 13 | MetaCoq Run (desc_gen S). 14 | 15 | Require Import VeriFFI.examples.uint63nat.prog. 16 | 17 | Module FM <: UInt63. 18 | Definition t := {z : nat | z < 2^63}. 19 | 20 | Lemma mod63_ok: 21 | forall z, (z mod (2^63) < 2^63)%nat. 22 | Proof. intro. apply Nat.mod_upper_bound, Nat.pow_nonzero. auto. Qed. 23 | 24 | Definition from_nat (z : nat) : t. 25 | exists (Nat.modulo z (2^63)). 26 | apply mod63_ok. 27 | Defined. 28 | 29 | Definition to_nat (z : t) : nat := proj1_sig z. 30 | 31 | 32 | Definition add (x y: t) : t := 33 | let '(exist xz x_pf) := x in 34 | let '(exist yz y_pf) := y in 35 | let z := ((xz + yz) mod (2^63))%nat in 36 | exist _ z (mod63_ok _). 37 | 38 | Definition mul (x y: t) : t := 39 | let '(exist xz x_pf) := x in 40 | let '(exist yz y_pf) := y in 41 | let z := ((xz * yz) mod (2^63))%nat in 42 | exist _ z (mod63_ok _). 43 | End FM. 44 | 45 | Module UInt63_Proofs. 46 | Axiom Isomorphism_t : Isomorphism FM.t C.t. 47 | #[local] Existing Instance Isomorphism_t. 48 | 49 | #[local] Instance GraphPredicate_t : GraphPredicate FM.t. 50 | constructor. 51 | intros g outlier [z H] p. 52 | apply (match p with repZ i => i= Z.of_nat z | _ => False end). 53 | Defined. 54 | 55 | #[local] Instance ForeignInGraph_t : ForeignInGraph FM.t C.t. 56 | apply (Build_InGraph _ GraphPredicate_t). 57 | - intros ? ? [z H] ? ?. hnf in H0. contradiction. 58 | - intros; auto. 59 | - intros ? ? [z H] ? ? ?. hnf in H1. contradiction. 60 | - intros. hnf. destruct n. destruct p; eauto. 61 | Defined. 62 | 63 | Definition from_nat_desc : fn_desc := 64 | {| fn_type_reified := 65 | @ARG _ nat transparent (fun _ => 66 | @RES _ FM.t opaque) 67 | ; foreign_fn := C.from_nat 68 | ; model_fn := fun '(x; tt) => FM.from_nat x 69 | ; fn_arity := 1 70 | ; c_name := "int63_from_nat" 71 | |}. 72 | 73 | Definition to_nat_desc : fn_desc := 74 | {| fn_type_reified := 75 | @ARG _ FM.t opaque (fun _ => 76 | @RES _ nat transparent) 77 | ; foreign_fn := C.to_nat 78 | ; model_fn := fun '(x; tt) => FM.to_nat x 79 | ; fn_arity := 1 80 | ; c_name := "int63_to_nat" 81 | |}. 82 | 83 | Definition add_desc : fn_desc := 84 | {| fn_type_reified := 85 | @ARG _ FM.t opaque (fun _ => 86 | @ARG _ FM.t opaque (fun _ => 87 | @RES _ FM.t opaque)) 88 | ; foreign_fn := C.add 89 | ; model_fn := fun '(x; (y; tt)) => FM.add x y 90 | ; fn_arity := 2 91 | ; c_name := "int63_add" 92 | |}. 93 | 94 | Definition mul_desc : fn_desc := 95 | {| fn_type_reified := 96 | @ARG _ FM.t opaque (fun _ => 97 | @ARG _ FM.t opaque (fun _ => 98 | @RES _ FM.t opaque)) 99 | ; foreign_fn := C.mul 100 | ; model_fn := fun '(x; (y; tt)) => FM.mul x y 101 | ; fn_arity := 2 102 | ; c_name := "int63_mul" 103 | |}. 104 | 105 | Axiom from_nat_spec : model_spec from_nat_desc. 106 | Axiom to_nat_spec : model_spec to_nat_desc. 107 | Axiom add_spec : model_spec add_desc. 108 | Axiom mul_spec : model_spec mul_desc. 109 | 110 | (* Class HasSpec {A} (f : A) : Type := *) 111 | (* { get_spec : {d : fn_desc & model_spec d} }. *) 112 | 113 | (* Instance HasSpec_from_nat : HasSpec C.from_nat := *) 114 | (* {| get_spec := (from_nat_desc; from_nat_spec) |}. *) 115 | (* Instance HasSpec_to_nat : HasSpec C.to_nat := *) 116 | (* {| get_spec := (to_nat_desc; to_nat_spec) |}. *) 117 | (* Instance HasSpec_add : HasSpec C.add := *) 118 | (* {| get_spec := (add_desc; add_spec) |}. *) 119 | (* Instance HasSpec_mul : HasSpec C.mul := *) 120 | (* {| get_spec := (mul_desc; mul_spec) |}. *) 121 | 122 | (* commented out to reduce chatter in build 123 | Eval cbn in model_spec from_nat_desc. 124 | Eval cbn in model_spec to_nat_desc. 125 | Eval cbn in model_spec add_desc. 126 | *) 127 | Lemma add_assoc : forall (x y z : nat), 128 | C.to_nat (C.add (C.from_nat x) (C.add (C.from_nat y) (C.from_nat z))) = 129 | C.to_nat (C.add (C.add (C.from_nat x) (C.from_nat y)) (C.from_nat z)). 130 | Proof. 131 | (* let o := open_constr:(HasSpec C.to_nat) in unshelve evar (x:o); [typeclasses eauto|]. *) 132 | intros x y z. 133 | props to_nat_spec. 134 | props add_spec. 135 | props from_nat_spec. 136 | foreign_rewrites. 137 | unfold FM.add, FM.from_nat, FM.to_nat. 138 | (* the rest is just a proof about the functional model *) 139 | unfold proj1_sig. 140 | rewrite <- !(Nat.Div0.add_mod y z). 141 | rewrite <- !(Nat.Div0.add_mod x y). 142 | rewrite <- !(Nat.Div0.add_mod). 143 | f_equal. 144 | apply Nat.add_assoc. 145 | all: apply Nat.pow_nonzero; auto. 146 | Qed. 147 | 148 | End UInt63_Proofs. 149 | -------------------------------------------------------------------------------- /INSTALL.md: -------------------------------------------------------------------------------- 1 | # Installation instructions 2 | 3 | Currently the recommended way to build the VeriFFI project is through Docker containers. 4 | 5 | ## Using the prebuilt image 6 | 7 | Here are the necessary steps: 8 | 9 | 1. [Install Docker on your machine.](https://docs.docker.com/get-docker/) 10 | 2. Start the Docker engine. 11 | 3. Download our image by running `docker pull certicoq/veriffi-8.17` in your terminal. 12 | This image currently has Opam 2.1.3, OCaml 4.13.1, Coq 8.17.0, CompCert 3.12, VST 2.12, MetaCoq's branch for Coq 8.17, coq-ext-lib 0.11.8, the latest CertiGraph, and `master` branch of CertiCoq. 13 | 4. Create a workspace folder in which you will have the files you want to run in the container. 14 | 15 | For these instructions, we will assume they are in `~/container`. 16 | ``` 17 | cd ~/container 18 | ``` 19 | You don't need to clone the repo because the Docker image has a copy of it already. 20 | 5. You can navigate to that folder in your terminal (if you haven't done it in the previous step) and then create a Docker container with these commands: 21 | 22 | ``` 23 | cd ~/container 24 | docker run -ti -v $(pwd):/tmp --name vf certicoq/veriffi-8.17 25 | mv ~/VeriFFI /tmp 26 | ``` 27 | This will create a Docker container named `vf` and it will take you to a bash session inside the container. 28 | 6. When you are inside that bash session, you can find the files in your host machine's `~/container` directory in `/tmp` in the container. 29 | Any change you make on the host will appear in the container and vice versa. For example, you can compile the VeriFFI project inside the container by running 30 | ``` 31 | cd /tmp/VeriFFI 32 | make 33 | ``` 34 | 7. Exiting the bash session will terminate the container but you can restart it anytime in the background by running 35 | ``` 36 | docker restart vf 37 | ``` 38 | If you want to access the container bash session again, you can run 39 | ``` 40 | docker exec -ti vf /bin/bash 41 | ``` 42 | 8. If you want to use Emacs in your host machine to edit files in the container and run the Coq version in the container, 43 | you need to use the [docker.el](https://github.com/Silex/docker.el) package for Emacs. 44 | 45 | If you're using Spacemacs, you can just add it to the additional packages list: 46 | ```lisp 47 | (setq-default dotspacemacs-additional-packages '(company-coq 48 | docker 49 | )) 50 | ``` 51 | You can also install the ``docker`` package using [melpa](https://melpa.org/#/getting-started): 52 | 53 | ```M-x package-list-packages docker``` 54 | 55 | If you're not using such an Emacs distribution, you can use [use-package](https://github.com/jwiegley/use-package) or more traditional methods to install that package. 56 | 57 | Once you do, you will also want to add this to your `.emacs` (or `.spacemacs`) file: 58 | 59 | ```lisp 60 | (defun set-coqtop-docker () 61 | (if (string-prefix-p "/docker:vf:" (buffer-file-name)) 62 | (setq coq-prog-name "/home/opam/.opam/4.10.2/bin/coqtop") 63 | (setq coq-prog-name "coqtop") 64 | )) 65 | 66 | (add-hook 'coq-mode-hook 'set-coqtop-docker) 67 | ``` 68 | This function checks every time you start Coq mode for a file, whether that file is from our Docker container, 69 | and if it is, it sets a hard path for the `coqtop` program that allows Emacs to communicate with Coq. If not, it just uses the `coqtop` on your host machine. 70 | This way you can use the Coq version on your host machine and the Coq version in your container with the same settings. 71 | 72 | Do not be confused by the hard path in the code above, it is a path inside the Docker container. 73 | 74 | 9. That's it! 75 | 76 | You can now load a file (C-x C-f) in Emacs from the Docker container by typing `/docker:vf:/tmp/` (complete it yourself) and you should be able to open any file from `~/container/` but using the Coq version in the container. 77 | 78 | 79 | ## Building the image yourself 80 | 81 | 1. [Install Docker on your machine.](https://docs.docker.com/get-docker/) 82 | 83 | 2. Start the Docker engine. 84 | 85 | 3. Get [the Dockerfile from this repo](https://github.com/CertiCoq/VeriFFI/blob/main/docker/Dockerfile). 86 | 87 | 4. In your terminal, get in the same directory as your Dockerfile. 88 | 89 | 5. Run 90 | ``` 91 | docker build -t certicoq/veriffi-8.17 . 92 | ``` 93 | This took a few hours when we built it from scratch. If you get an error, consider increasing the memory you allow Docker to use; we had to build it with 16 GB of memory. 94 | 95 | 6. You can now continue with the instructions to use a prebuilt image, starting from step 4. 96 | 97 | 98 | 99 | ## Building the Coq Code 100 | 101 | All Coq code can be run from the Docker image. 102 | 103 | 1. Follow all instructions until step 7, restart the machine. 104 | 105 | ``` 106 | docker exec -ti vf /bin/bash 107 | ``` 108 | 109 | 2. Inside the Docker image, you can run the ``make file`` in the main directory. 110 | 3. You can browse the Coq code as described above. 111 | 112 | -------------------------------------------------------------------------------- /generator/module.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.ZArith.ZArith 2 | Coq.Program.Basics 3 | Coq.Strings.String 4 | Coq.Lists.List 5 | Coq.Lists.ListSet. 6 | 7 | Require Import ExtLib.Structures.Monads 8 | ExtLib.Data.Monads.OptionMonad 9 | ExtLib.Data.Monads.StateMonad 10 | ExtLib.Data.String. 11 | 12 | Require Import MetaCoq.Template.All. 13 | 14 | Require Import VeriFFI.generator.gen_utils. 15 | Require Import VeriFFI.library.base_representation. 16 | Require Import VeriFFI.library.meta. 17 | Require Import VeriFFI.library.modelled. 18 | Require Import VeriFFI.library.isomorphism. 19 | 20 | (* Unset MetaCoq Strict Unquote Universe Mode. *) 21 | 22 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 23 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 24 | Import monad_utils.MCMonadNotation 25 | ListNotations 26 | MetaCoqNotations. 27 | 28 | Module Type T. 29 | Axiom t : Type. 30 | Axiom add : t -> t -> t. 31 | End T. 32 | Module C : T. 33 | Axiom t : Type. 34 | Axiom add : t -> t -> t. 35 | End C. 36 | Module FM : T. 37 | Definition t := nat. 38 | Definition add := plus. 39 | End FM. 40 | 41 | MetaCoq Run (tmQuoteModule "FM"%bs >>= tmPrint). 42 | (* Check (tmQuoteModule "M"%bs >>= monad_iter (fun x => tmLocate x >>= tmPrint)). *) 43 | (* MetaCoq Run (tmQuoteModule "M"%bs >>= monad_iter (fun x => tmLocate x >>= tmPrint)). *) 44 | 45 | Definition get_type (t : term) : TemplateMonad term := 46 | t' <- tmUnquote t ;; 47 | tmEval all (my_projT1 t') >>= tmQuote. 48 | 49 | Definition get_kn_type (kn : kername) : TemplateMonad term := 50 | get_type (tConst kn []). 51 | 52 | (* Check if the term is of the form "(_ ->)* (Type|Set|Prop)" *) 53 | Fixpoint is_type (t : term) : bool := 54 | match t with 55 | | tProd _ _ rest => is_type rest 56 | | tSort _ => true 57 | | _ => false 58 | end. 59 | 60 | Check @Isomorphism. 61 | Print tApp. 62 | Definition type_to_isomorphism (c_ty f_ty : term) : TemplateMonad term := 63 | let fix aux (c_ty f_ty : term) (c_args f_args : list named_term) : TemplateMonad named_term := 64 | match c_ty, f_ty with 65 | | tProd cn ct c_rest, tProd fn ft f_rest => 66 | id1 <- tmFreshName "A"%bs ;; 67 | id2 <- tmFreshName "B"%bs ;; 68 | id3 <- tmFreshName "Iso"%bs ;; 69 | rest <- aux c_rest f_rest (tVar id1 :: c_args) (tVar id2 :: f_args) ;; 70 | match is_type ct, is_type ft with 71 | | true, true => 72 | ret (tProd (mkBindAnn (nNamed id1) Relevant) ct 73 | (tProd (mkBindAnn (nNamed id2) Relevant) ft 74 | (tProd (mkBindAnn (nNamed id3) Relevant) 75 | (tApp <% Isomorphism %> [tVar id1; tVar id2]) rest))) 76 | | false, false => 77 | ret (tProd (mkBindAnn (nNamed id1) Relevant) ct 78 | (tProd (mkBindAnn (nNamed id2) Relevant) ft rest)) 79 | | _, _ => tmFail "Mismatch on arguments"%bs 80 | end 81 | | tSort _, tSort _ => 82 | ret (tApp <% Isomorphism %> [hole; hole]) (* TODO *) 83 | | _, _ => tmFail "Not a type"%bs 84 | end 85 | in aux c_ty f_ty nil nil. 86 | 87 | Definition tmVariable_ (id : ident) (t : term) : TemplateMonad unit := 88 | @tmBind _ _ (tmUnquoteTyped Type t) (fun ty => tmVariable id ty). 89 | Set Printing Universes. 90 | Print tmVariable_. 91 | 92 | Definition tmVariable__ (id : ident) (t : term) : TemplateMonad unit := 93 | tmVariable_ id t. 94 | 95 | Check tmVariable__. 96 | Check tmVariable_. 97 | Print tmVariable. 98 | Print Z. 99 | Set Printing All. 100 | Compute (-1)%Z. 101 | 102 | Print N. 103 | Print positive. 104 | Compute (0%N). 105 | Fixpoint module_to_specs 106 | (c_refs f_refs : list global_reference) : TemplateMonad (list fn_desc) := 107 | match c_refs, f_refs with 108 | | ConstRef c_kn :: c_grs, ConstRef f_kn :: f_grs => 109 | let '(c_id, f_id) := (snd c_kn, snd f_kn) in 110 | if negb (ident_eq c_id f_id) 111 | then tmFail ("Mismatch between functions " ++ c_id ++ " and " ++ f_id)%bs 112 | else 113 | c_ty <- get_kn_type c_kn ;; 114 | tmPrint c_ty ;; 115 | if is_type c_ty 116 | then 117 | f_ty <- get_kn_type f_kn ;; 118 | iso_ty <- type_to_isomorphism c_ty f_ty ;; 119 | iso_name <- tmFreshName ("Isomorphism_" ++ c_id)%bs ;; 120 | tmPrint iso_ty ;; 121 | tmVariable__ iso_name iso_ty ;; 122 | tmMsg ("Parametrized over " ++ iso_name)%bs ;; 123 | module_to_specs c_grs f_grs 124 | else 125 | tmMsg "NOPE"%bs ;; 126 | module_to_specs c_grs f_grs 127 | | c_gr :: c_grs , f_gr :: f_grs => 128 | tmMsg "Couldn't generate spec for: "%bs ;; 129 | tmPrint c_gr ;; 130 | module_to_specs c_grs f_grs 131 | | nil , nil => ret nil 132 | | nil , _ => tmFail "Reference list mismatch, the functional model has more definitions"%bs 133 | | _ , nil => tmFail "Reference list mismatch, the primitives have more definitions"%bs 134 | end. 135 | 136 | Definition test c fm : TemplateMonad unit := 137 | cl <- tmQuoteModule c ;; 138 | fl <- tmQuoteModule fm ;; 139 | module_to_specs cl fl >>= tmPrint. 140 | 141 | MetaCoq Run (test "C" "FM")%bs. 142 | Print global_reference. 143 | Set Universe Polymorphism. 144 | (* Set Polymorphic Inductive Cumulativity. *) 145 | 146 | -------------------------------------------------------------------------------- /c/config.h: -------------------------------------------------------------------------------- 1 | /**************************************************************************/ 2 | /* */ 3 | /* OCaml */ 4 | /* */ 5 | /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ 6 | /* */ 7 | /* Copyright 1996 Institut National de Recherche en Informatique et */ 8 | /* en Automatique. */ 9 | /* */ 10 | /* All rights reserved. This file is distributed under the terms of */ 11 | /* the GNU Lesser General Public License version 2.1, with the */ 12 | /* special exception on linking described in the file LICENSE. */ 13 | /* */ 14 | /**************************************************************************/ 15 | 16 | #ifndef CERTICOQ_CONFIG_H 17 | #define CERTICOQ_CONFIG_H 18 | 19 | #if SIZEOF_PTR == SIZEOF_LONG 20 | /* Standard models: ILP32 or I32LP64 */ 21 | typedef long intnat; 22 | typedef unsigned long uintnat; 23 | #define ARCH_INTNAT_PRINTF_FORMAT "l" 24 | #elif SIZEOF_PTR == SIZEOF_INT 25 | /* Hypothetical IP32L64 model */ 26 | typedef int intnat; 27 | typedef unsigned int uintnat; 28 | #define ARCH_INTNAT_PRINTF_FORMAT "" 29 | #elif SIZEOF_PTR == 8 30 | /* Win64 model: IL32P64 */ 31 | typedef int64_t intnat; 32 | typedef uint64_t uintnat; 33 | #define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT 34 | #else 35 | #error "No integer type available to represent pointers" 36 | #endif 37 | 38 | /* Endianness of floats */ 39 | 40 | /* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: 41 | the value [0xabcdefgh] means that the least significant byte of the 42 | float is at byte offset [a], the next lsb at [b], ..., and the 43 | most significant byte at [h]. */ 44 | 45 | #if defined(__arm__) && !defined(__ARM_EABI__) 46 | #define ARCH_FLOAT_ENDIANNESS 0x45670123 47 | #elif defined(ARCH_BIG_ENDIAN) 48 | #define ARCH_FLOAT_ENDIANNESS 0x76543210 49 | #else 50 | #define ARCH_FLOAT_ENDIANNESS 0x01234567 51 | #endif 52 | 53 | 54 | /* We use threaded code interpretation if the compiler provides labels 55 | as first-class values (GCC 2.x). */ 56 | 57 | #if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \ 58 | && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) 59 | #define THREADED_CODE 60 | #endif 61 | 62 | 63 | /* Memory model parameters */ 64 | 65 | /* The size of a page for memory management (in bytes) is [1 << Page_log]. 66 | [Page_size] must be a multiple of [sizeof (value)]. 67 | [Page_log] must be be >= 8 and <= 20. 68 | Do not change the definition of [Page_size]. */ 69 | #define Page_log 12 /* A page is 4 kilobytes. */ 70 | #define Page_size (1 << Page_log) 71 | 72 | /* Initial size of stack (bytes). */ 73 | #define Stack_size (4096 * sizeof(value)) 74 | 75 | /* Minimum free size of stack (bytes); below that, it is reallocated. */ 76 | #define Stack_threshold (256 * sizeof(value)) 77 | 78 | /* Default maximum size of the stack (words). */ 79 | #define Max_stack_def (1024 * 1024) 80 | 81 | 82 | /* Maximum size of a block allocated in the young generation (words). */ 83 | /* Must be > 4 */ 84 | #define Max_young_wosize 256 85 | #define Max_young_whsize (Whsize_wosize (Max_young_wosize)) 86 | 87 | 88 | /* Minimum size of the minor zone (words). 89 | This must be at least [2 * Max_young_whsize]. */ 90 | #define Minor_heap_min 4096 91 | 92 | /* Maximum size of the minor zone (words). 93 | Must be greater than or equal to [Minor_heap_min]. 94 | */ 95 | #define Minor_heap_max (1 << 28) 96 | 97 | /* Default size of the minor zone. (words) */ 98 | #define Minor_heap_def 262144 99 | 100 | 101 | /* Minimum size increment when growing the heap (words). 102 | Must be a multiple of [Page_size / sizeof (value)]. */ 103 | #define Heap_chunk_min (15 * Page_size) 104 | 105 | /* Default size increment when growing the heap. 106 | If this is <= 1000, it's a percentage of the current heap size. 107 | If it is > 1000, it's a number of words. */ 108 | #define Heap_chunk_def 2048 /* 15 (original value) */ 109 | 110 | /* Default initial size of the major heap (words); 111 | Must be a multiple of [Page_size / sizeof (value)]. */ 112 | #define Init_heap_def (31 * Page_size) 113 | /* (about 512 kB for a 32-bit platform, 1 MB for a 64-bit platform.) */ 114 | 115 | 116 | /* Default speed setting for the major GC. The heap will grow until 117 | the dead objects and the free list represent this percentage of the 118 | total size of live objects. */ 119 | #define Percent_free_def 80 120 | 121 | /* Default setting for the compacter: 500% 122 | (i.e. trigger the compacter when 5/6 of the heap is free or garbage) 123 | This can be set quite high because the overhead is over-estimated 124 | when fragmentation occurs. 125 | */ 126 | #define Max_percent_free_def 500 127 | 128 | /* Default setting for the major GC slice smoothing window: 1 129 | (i.e. no smoothing) 130 | */ 131 | #define Major_window_def 1 132 | 133 | /* Maximum size of the major GC slice smoothing window. */ 134 | #define Max_major_window 50 135 | 136 | 137 | /* Default size of the heap in words */ 138 | #define Heap_def 8192 139 | 140 | 141 | #endif /* CERTICOQ_CONFIG_H */ 142 | -------------------------------------------------------------------------------- /examples/array/model.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | Require Import Psatz. 3 | Require Import List. 4 | Require Import String. 5 | Open Scope string. 6 | 7 | Require Import VeriFFI.generator.Rep. 8 | Local Obligation Tactic := gen. 9 | MetaCoq Run (gen_for unit). 10 | MetaCoq Run (gen_for nat). 11 | 12 | Require Import VeriFFI.library.meta. 13 | Require Import VeriFFI.library.modelled. 14 | Require Import VeriFFI.library.isomorphism. 15 | 16 | Require Import VeriFFI.examples.array.prog. 17 | 18 | #[export] Instance InGraph_elt : InGraph elt := InGraph_nat. 19 | 20 | (* Look at canon.replace_nth, invariants.replace_nth, sepalg_list.replace for lemmas *) 21 | Module FM <: Array. 22 | Definition state : Type := 23 | (list elt * elt). (* the internal list and the default element *) 24 | Definition M (A : Type) : Type := state -> A * state. 25 | Definition pure {A} (a : A) : M A := fun s => (a, s). 26 | Definition bind {A B} (m : M A) (f : A -> M B) : M B := 27 | fun s => f (fst (m s)) (snd (m s)). 28 | (* fun s => let '(a, s') := m s in f a s'. *) 29 | Definition runM {A} (len : nat) (init: elt) (m : M A) : A := 30 | fst (m (repeat init len, init)). 31 | 32 | Definition set (index : nat) (x : elt) : M unit := 33 | fun '(l, init) => (tt, (VST.veric.invariants.replace_nth index l x, init)). 34 | 35 | Definition get (index : nat) : M elt := 36 | fun '(l, init) => (nth index l init, (l, init)). 37 | End FM. 38 | 39 | Module Array_Proofs. 40 | (* Axiom Isomorphism_state : Isomorphism C.state FM.state. *) 41 | Axiom Isomorphism_M : forall {A A' : Type} (I : Isomorphism A A'), 42 | Isomorphism (FM.M A) (C.M A'). 43 | #[local] Existing Instance Isomorphism_M. 44 | 45 | #[local] Instance InGraph_M : forall {A : Type} `{InGraph A}, InGraph (FM.M A). 46 | Admitted. 47 | 48 | Definition pure_desc : fn_desc := 49 | {| fn_type_reified := 50 | @TYPEPARAM _ (fun A (P_A : foreign_ann A) => 51 | @ARG _ A P_A (fun a => 52 | @RES _ (FM.M A) (@opaque _ (C.M A) (@InGraph_M A (@foreign_in_graph _ P_A)) (@Isomorphism_M A A (@Isomorphism_refl A))))) 53 | ; foreign_fn := @C.pure 54 | ; model_fn := fun '(A; (_; (a; tt))) => @FM.pure A a 55 | ; fn_arity := 2 56 | ; c_name := "m_pure" 57 | |}. 58 | 59 | Definition bind_desc : fn_desc := 60 | {| fn_type_reified := 61 | @TYPEPARAM _ (fun (A : Type) (P_A : foreign_ann A) => 62 | @TYPEPARAM _ (fun (B : Type) (P_B : foreign_ann B) => 63 | @ARG _ (FM.M A) (@opaque _ (C.M A) (@InGraph_M A (@foreign_in_graph _ P_A)) (Isomorphism_M _)) (fun m => 64 | @ARG _ (A -> FM.M B) (@opaque _ (A -> C.M B) (@InGraph_fun _ _ (@foreign_in_graph _ P_A) (@InGraph_M B (@foreign_in_graph _ P_B))) (Isomorphism_fn _ (Isomorphism_M _))) (fun f => 65 | @RES _ (FM.M B) (@opaque _ (C.M B) (@InGraph_M B (@foreign_in_graph _ P_B)) (Isomorphism_M _)))))) 66 | ; foreign_fn := @C.bind 67 | ; model_fn := fun '(A; (_; (B; (_; (m; (f; tt)))))) => @FM.bind A B m f 68 | ; fn_arity := 4 69 | ; c_name := "m_bind" 70 | |}. 71 | 72 | Definition runM_desc : fn_desc := 73 | {| fn_type_reified := 74 | @TYPEPARAM _ (fun (A : Type) (P_A : foreign_ann A) => 75 | @ARG _ _ (@transparent nat InGraph_nat) (fun len => 76 | @ARG _ _ (@transparent elt InGraph_elt) (fun init => 77 | @ARG _ _ (@opaque (FM.M A) (C.M A) (@InGraph_M _ (@foreign_in_graph _ P_A)) (Isomorphism_M _)) (fun f => 78 | @RES _ _ (@transparent A (@foreign_in_graph _ P_A)))))) 79 | ; foreign_fn := @C.runM 80 | ; model_fn := fun '(A; (_; (len; (init; (f; tt))))) => @FM.runM A len init f 81 | ; fn_arity := 4 82 | ; c_name := "m_runM" 83 | |}. 84 | 85 | Definition set_desc : fn_desc := 86 | {| fn_type_reified := 87 | @ARG _ _ (@transparent nat InGraph_nat) (fun n => 88 | @ARG _ _ (@transparent elt InGraph_elt) (fun a => 89 | @RES _ _ (@opaque (FM.M unit) _ (InGraph_M) (Isomorphism_M _)))) 90 | ; foreign_fn := @C.set 91 | ; model_fn := fun '(n; (a; tt)) => @FM.set n a 92 | ; fn_arity := 2 93 | ; c_name := "array_set" 94 | |}. 95 | 96 | Definition get_desc : fn_desc := 97 | {| fn_type_reified := 98 | @ARG _ _ (@transparent nat InGraph_nat) (fun n => 99 | @RES _ _ (@opaque (FM.M elt) (C.M elt) (InGraph_M) (Isomorphism_M _))) 100 | ; foreign_fn := @C.get 101 | ; model_fn := fun '(n; tt) => @FM.get n 102 | ; fn_arity := 1 103 | ; c_name := "array_get" 104 | |}. 105 | 106 | Axiom pure_spec : model_spec pure_desc. 107 | Axiom bind_spec : model_spec bind_desc. 108 | Axiom runM_spec : model_spec runM_desc. 109 | Axiom set_spec : model_spec set_desc. 110 | Axiom get_spec : model_spec get_desc. 111 | 112 | Arguments from A B {_}. 113 | Arguments to A B {_}. 114 | 115 | Lemma set_get : 116 | forall (n len : nat) (bound : n < len) (init : elt) (to_set : elt), 117 | (C.runM len init (C.bind (C.set n to_set) (fun _ => C.get n))) 118 | = 119 | (C.runM len init (C.pure to_set)). 120 | Proof. 121 | intros n len bound init to_set. 122 | 123 | props runM_spec. 124 | foreign_rewrites. 125 | unfold FM.runM. 126 | 127 | props bind_spec. 128 | props pure_spec. 129 | foreign_rewrites. 130 | unfold FM.bind, FM.pure. 131 | 132 | props set_spec. 133 | props get_spec. 134 | foreign_rewrites. 135 | 136 | eapply invariants.nth_replace_nth. 137 | rewrite repeat_length. 138 | auto. 139 | Qed. 140 | 141 | End Array_Proofs. 142 | -------------------------------------------------------------------------------- /examples/uint63z/model.v: -------------------------------------------------------------------------------- 1 | Require Import ZArith. 2 | Require Import Psatz. 3 | Require Import String. 4 | Open Scope string. 5 | 6 | Require Import VeriFFI.library.modelled. 7 | Require Import VeriFFI.library.isomorphism. 8 | Require Import VeriFFI.library.meta. 9 | 10 | Unset MetaCoq Strict Unquote Universe Mode. 11 | Require Import VeriFFI.generator.Rep. 12 | Local Obligation Tactic := gen. 13 | MetaCoq Run (gen_for Z). 14 | 15 | Require Import VeriFFI.examples.uint63z.prog. 16 | 17 | Module FM <: UInt63. 18 | Definition t := {z : Z | 0 <= z < 2^63}%Z. 19 | Definition from_Z (z : Z) : t. 20 | exists (Z.modulo z (2^63)). 21 | apply Z_mod_lt. 22 | constructor. 23 | Defined. 24 | 25 | Definition to_Z (z : t) : Z := proj1_sig z. 26 | 27 | Lemma mod63_ok: 28 | forall z, (0 <= z mod (2^63) < 2^63)%Z. 29 | Proof. 30 | intro. apply Z.mod_pos_bound. 31 | apply Z.pow_pos_nonneg; lia. 32 | Defined. 33 | 34 | Definition add (x y: t) : t := 35 | let '(exist xz x_pf) := x in 36 | let '(exist yz y_pf) := y in 37 | let z := ((xz + yz) mod (2^63))%Z in 38 | exist _ z (mod63_ok _). 39 | 40 | Definition mul (x y: t) : t := 41 | let '(exist xz x_pf) := x in 42 | let '(exist yz y_pf) := y in 43 | let z := ((xz * yz) mod (2^63))%Z in 44 | exist _ z (mod63_ok _). 45 | End FM. 46 | 47 | Module UInt63_Proofs. 48 | Axiom Isomorphism_t : Isomorphism FM.t C.t. 49 | #[local] Existing Instance Isomorphism_t. 50 | 51 | Definition GraphPredicate_t : GraphPredicate FM.t. 52 | constructor. 53 | intros g outlier [z H] p. 54 | apply (match p with repZ i => i=z | _ => False end). 55 | Defined. 56 | 57 | #[local] Instance ForeignInGraph_t : ForeignInGraph FM.t C.t. 58 | apply (Build_InGraph _ GraphPredicate_t). 59 | - intros ? ? [z H] ? ?. hnf in H0. contradiction. 60 | - intros; auto. 61 | - intros ? ? [z H] ? ? ?. hnf in H1. contradiction. 62 | - intros. hnf. destruct n. destruct p; eauto. 63 | Defined. 64 | 65 | Definition from_Z_desc : fn_desc := 66 | {| fn_type_reified := 67 | @ARG _ Z transparent (fun _ => 68 | @RES _ FM.t opaque) 69 | ; foreign_fn := C.from_Z 70 | ; model_fn := fun '(x; tt) => FM.from_Z x 71 | ; fn_arity := 1 72 | ; c_name := "int63_from_Z" 73 | |}. 74 | 75 | Definition to_Z_desc : fn_desc := 76 | {| fn_type_reified := 77 | @ARG _ FM.t opaque (fun _ => 78 | @RES _ Z transparent) 79 | ; foreign_fn := C.to_Z 80 | ; model_fn := fun '(x; tt) => FM.to_Z x 81 | ; fn_arity := 1 82 | ; c_name := "int63_to_Z" 83 | |}. 84 | 85 | Definition add_desc : fn_desc := 86 | {| fn_type_reified := 87 | @ARG _ FM.t opaque (fun _ => 88 | @ARG _ FM.t opaque (fun _ => 89 | @RES _ FM.t opaque)) 90 | ; foreign_fn := C.add 91 | ; model_fn := fun '(x; (y; tt)) => FM.add x y 92 | ; fn_arity := 2 93 | ; c_name := "int63_add" 94 | |}. 95 | 96 | Definition mul_desc : fn_desc := 97 | {| fn_type_reified := 98 | @ARG _ FM.t opaque (fun _ => 99 | @ARG _ FM.t opaque (fun _ => 100 | @RES _ FM.t opaque)) 101 | ; foreign_fn := C.mul 102 | ; model_fn := fun '(x; (y; tt)) => FM.mul x y 103 | ; fn_arity := 2 104 | ; c_name := "int63_mul" 105 | |}. 106 | 107 | Axiom from_Z_spec : model_spec from_Z_desc. 108 | Axiom to_Z_spec : model_spec to_Z_desc. 109 | Axiom add_spec : model_spec add_desc. 110 | Axiom mul_spec : model_spec mul_desc. 111 | 112 | Lemma seven : C.to_Z (C.add (C.from_Z 3%Z) (C.from_Z 4%Z)) = 7%Z. 113 | Proof. 114 | props from_Z_spec. 115 | props add_spec. 116 | props to_Z_spec. 117 | foreign_rewrites. 118 | unfold FM.to_Z, FM.add, FM.from_Z. 119 | simpl. 120 | rewrite Z.mod_small. 121 | auto. 122 | lia. 123 | Qed. 124 | 125 | Lemma add_assoc : forall (x y z : Z), 126 | C.to_Z (C.add (C.from_Z x) (C.add (C.from_Z y) (C.from_Z z))) = 127 | C.to_Z (C.add (C.add (C.from_Z x) (C.from_Z y)) (C.from_Z z)). 128 | Proof. 129 | intros x y z. 130 | props from_Z_spec. 131 | props to_Z_spec. 132 | props add_spec. 133 | foreign_rewrites. 134 | unfold FM.add, FM.from_Z, FM.to_Z. 135 | simpl. 136 | rewrite <- !(Z.add_mod y z). 137 | rewrite <- !(Z.add_mod x y). 138 | rewrite <- !(Z.add_mod). 139 | f_equal. 140 | apply Z.add_assoc. 141 | all: lia. 142 | Qed. 143 | 144 | Lemma mul_add_distr_l : forall (x y z : Z), 145 | C.to_Z (C.mul (C.from_Z x) (C.add (C.from_Z y) (C.from_Z z))) = 146 | C.to_Z (C.add (C.mul (C.from_Z x) (C.from_Z y)) (C.mul (C.from_Z x) (C.from_Z z))). 147 | Proof. 148 | intros x y z. 149 | props from_Z_spec. 150 | props to_Z_spec. 151 | props add_spec. 152 | props mul_spec. 153 | foreign_rewrites. 154 | unfold FM.mul, FM.add, FM.from_Z, FM.to_Z. 155 | simpl. 156 | pose (y' := Z.modulo y (Z.pow_pos 2 63)); fold y'. 157 | pose (z' := Z.modulo z (Z.pow_pos 2 63)); fold z'. 158 | rewrite <- Zplus_mod. 159 | rewrite <- Z.mul_add_distr_l. 160 | rewrite Zmult_mod_idemp_r. 161 | auto. 162 | Qed. 163 | 164 | Lemma mul_add_distr_r : forall (x y z : Z), 165 | C.to_Z (C.mul (C.add (C.from_Z x) (C.from_Z y)) (C.from_Z z)) = 166 | C.to_Z (C.add (C.mul (C.from_Z x) (C.from_Z z)) (C.mul (C.from_Z y) (C.from_Z z))). 167 | Proof. 168 | intros x y z. 169 | props from_Z_spec. 170 | props to_Z_spec. 171 | props add_spec. 172 | props mul_spec. 173 | foreign_rewrites. 174 | unfold FM.mul, FM.add, FM.from_Z, FM.to_Z. 175 | simpl. 176 | pose (x' := Z.modulo y (Z.pow_pos 2 63)); fold x'. 177 | pose (y' := Z.modulo y (Z.pow_pos 2 63)); fold y'. 178 | pose (z' := Z.modulo z (Z.pow_pos 2 63)); fold z'. 179 | rewrite <- Zplus_mod. 180 | rewrite <- Z.mul_add_distr_r. 181 | rewrite Zmult_mod_idemp_l. 182 | auto. 183 | Qed. 184 | 185 | End UInt63_Proofs. 186 | -------------------------------------------------------------------------------- /examples/uint63nat/prims.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "glue.h" 3 | #include 4 | #include 5 | 6 | /* THE FOLLOWING SHOULD EVENTUALLY BE MOVED INTO gc_stack.h */ 7 | /* BEGINFRAME / LIVEPOINTERSn / ENDFRAME 8 | Usage: 9 | 10 | value myfunc(struct thread_info *tinfo, ...other args...) { 11 | ... some variable declarations ... 12 | BEGINFRAME(tinfo,n) 13 | ... some more variable declarations ... 14 | 15 | ... 16 | r=LIVEPOINTERSj(tinfo,funcallx,a0,a1,...,aj-1); [where jfp }; \ 45 | struct stack_frame *__PREV__; \ 46 | size_t nalloc; \ 47 | value __RTEMP__; 48 | 49 | #define ENDFRAME }}}}} 50 | 51 | #define LIVEPOINTERS0(tinfo, exp) (exp) 52 | 53 | #define LIVEPOINTERS1(tinfo, exp, a0) \ 54 | (tinfo->fp= &__FRAME__, __FRAME__.next=__ROOT__+1, \ 55 | __ROOT__[0]=(a0), __RTEMP__=(exp), (a0)=__ROOT__[0], \ 56 | __PREV__=__FRAME__.prev, tinfo->fp=__PREV__, __RTEMP__) 57 | 58 | #define LIVEPOINTERS2(tinfo, exp, a0, a1) \ 59 | (tinfo->fp= &__FRAME__, __FRAME__.next=__ROOT__+2, \ 60 | __ROOT__[0]=(a0), __ROOT__[1]=(a1), \ 61 | __RTEMP__=(exp), \ 62 | (a0)=__ROOT__[0], (a1)=__ROOT__[1], \ 63 | __PREV__=__FRAME__.prev, tinfo->fp=__PREV__, __RTEMP__) 64 | 65 | #define LIVEPOINTERS3(tinfo, exp, a0, a1, a2) \ 66 | (tinfo->fp= &__FRAME__, __FRAME__.next=__ROOT__+3, \ 67 | __ROOT__[0]=(a0), __ROOT__[1]=(a1), __ROOT__[2]=(a2), \ 68 | __RTEMP__=(exp), \ 69 | (a0)=__ROOT__[0], (a1)=__ROOT__[1], (a2)=__ROOT__[2], \ 70 | __PREV__=__FRAME__.prev, tinfo->fp=__PREV__, __RTEMP__) 71 | 72 | #define LIVEPOINTERS4(tinfo, exp, a0, a1, a2, a3) \ 73 | (tinfo->fp= &__FRAME__, __FRAME__.next=__ROOT__+4, \ 74 | __ROOT__[0]=(a0), __ROOT__[1]=(a1), __ROOT__[2]=(a2), __ROOT__[3]=(a3), \ 75 | __RTEMP__=(exp), \ 76 | (a0)=__ROOT__[0], (a1)=__ROOT__[1], (a2)=__ROOT__[2], (a3)=__ROOT__[3], \ 77 | __PREV__=__FRAME__.prev, tinfo->fp=__PREV__, __RTEMP__) 78 | /* END OF STUFF TO BE MOVED INTO gc_stack.h */ 79 | 80 | typedef enum { O, S } nat; 81 | 82 | value uint63_from_nat(struct thread_info *tinfo, value n) { 83 | value temp = n; 84 | uint64_t i = 0; 85 | 86 | while (get_Coq_Init_Datatypes_nat_tag(temp) == S) { 87 | i++; 88 | temp = get_args(temp)[0]; 89 | } 90 | return (value) ((i << 1) + 1); 91 | } 92 | 93 | value uint63_to_nat_no_gc (struct thread_info *tinfo, value t) { 94 | uint64_t i = (uint64_t) (((uint64_t) t) >> 1); 95 | value temp = make_Coq_Init_Datatypes_nat_O(); 96 | while (i) { 97 | /* if (!(2 <= tinfo->limit - tinfo->alloc)) { 98 | tinfo->nalloc = 2; 99 | garbage_collect(tinfo); 100 | } */ 101 | temp = alloc_make_Coq_Init_Datatypes_nat_S(tinfo, temp); 102 | i--; 103 | } 104 | return temp; 105 | } 106 | 107 | /* Usage of GC_SAVE1 108 | Before the invocation of GC_SAVE1(n), 109 | the variable __FRAME__ (etc) must be set up as by BEGINFRAME(tinfo,k) with k>=n 110 | 111 | After the invocation of GC_SAVE1(n), 112 | n <= tinfo->limit-tinfo->alloc 113 | AND the possibly pointer variable save0 will have properly forwarded 114 | AND all the pointers in the stack-of-frames (from tinfo->fp) will have been forwarded 115 | AND no other pointer variables are correctly preserved 116 | AND all other nonpointer variables are preserved (except _LIMIT, _ALLOC) 117 | 118 | We cannot allow the name of variable save0 to be a parameter to this macro, 119 | it must be named exactly that for the convenience of Lemma semax_GC_SAVE1. 120 | */ 121 | #define GC_SAVE1 \ 122 | if (!(_LIMIT=tinfo->limit, _ALLOC=tinfo->alloc, nalloc <= _LIMIT-_ALLOC)) { \ 123 | tinfo->nalloc = nalloc; \ 124 | LIVEPOINTERS1(tinfo,(garbage_collect(tinfo),(value)NULL),save0); \ 125 | } 126 | 127 | #define GC_SAVE2 \ 128 | if (!(_LIMIT=tinfo->limit, _ALLOC=tinfo->alloc, nalloc <= _LIMIT-_ALLOC)) { \ 129 | tinfo->nalloc = nalloc; \ 130 | LIVEPOINTERS2(tinfo,(garbage_collect(tinfo),(value)NULL),save0,save1); \ 131 | } 132 | 133 | value uint63_to_nat(struct thread_info *tinfo, value t) { 134 | uint64_t i = (uint64_t) (((uint64_t) t) >> 1); 135 | value save0 = make_Coq_Init_Datatypes_nat_O(); /* must name this save0 for compatibility with GC_SAVE1 */ 136 | BEGINFRAME(tinfo,1) 137 | while (i) { 138 | nalloc=2; GC_SAVE1 /* no semicolon! */ 139 | save0 = alloc_make_Coq_Init_Datatypes_nat_S(tinfo,save0); 140 | i--; 141 | } 142 | return save0; 143 | ENDFRAME 144 | } 145 | 146 | value uint63_add(struct thread_info *tinfo, value x, value y) { 147 | return (value) ((((((uint64_t) x) >> 1) + (((uint64_t) y) >> 1)) << 1) + 1); 148 | } 149 | 150 | value uint63_mul(value x, value y) { 151 | return (value) ((((((uint64_t) x) >> 1) * (((uint64_t) y) >> 1)) << 1) + 1); 152 | } 153 | -------------------------------------------------------------------------------- /c/gc_stack.h: -------------------------------------------------------------------------------- 1 | #ifndef CERTICOQ_GC_STACK_H 2 | #define CERTICOQ_GC_STACK_H 3 | 4 | #include "values.h" 5 | 6 | /* EXPLANATION OF THE CERTICOQ GENERATIONAL GARBAGE COLLECTOR. 7 | Andrew W. Appel, September 2016 8 | 9 | The current Certicoq code generator uses Ocaml object formats, 10 | as described in Chapter 20 of Real World Ocaml by Minsky et al. 11 | https://realworldocaml.org/v1/en/html/memory-representation-of-values.html 12 | 13 | That is: 14 | 15 | 31 10 9 8 7 0 16 | +-------+---------+----------+ 17 | | size | color | tag byte | 18 | +-------+---------+----------+ 19 | v --> | value[0] | 20 | +----------------------------+ 21 | | value[1] | 22 | +----------------------------+ 23 | | . | 24 | | . | 25 | | . | 26 | +----------------------------+ 27 | | value[size-1] | 28 | +----------------------------+ 29 | 30 | This works for 32-bit or 64-bit words; 31 | if 64-bit words, substitute "63" for "31" in the diagram above. 32 | At present we'll assume 32-bit words. 33 | 34 | The header file "values.h", from the OCaml distribution, 35 | has macros (etc.) for accessing these fields and headers. 36 | 37 | The header file "config.h", from the OCaml distribution, defines 38 | typedef "intnat", the "natural integer type" for this compiler/machine, 39 | and "uintnat", the "natural unsigned integer type". 40 | Config.h also defines (BUT WE DO NOT USE) parameters for the Ocaml 41 | generational garbage collector. 42 | 43 | The important definitions we use from values.h are: 44 | 45 | Is_block(v) : tests whether v is a pointer (even number) 46 | Hd_val(v) : contents of the header word, i.e., just before where v points to 47 | Field(v,i) : the i'th field of object v 48 | Tag_hd(h) : If h is a header-word, get the constructor-tag 49 | Wosize_hd(h): If h is a header-word, get size of the object in words 50 | 51 | We define the following ourselves, following Ocaml's format: 52 | 53 | No_scan(t) : If t is a constructor-tag, true if none of the object's 54 | data words are to be interpreted as pointers. 55 | (For example, character-string data) 56 | 57 | CALLING THE GARBAGE COLLECTOR (this part is NOT standard Ocaml): 58 | 59 | The mutator runs in this environment: 60 | 61 | NURSERY OLDER GENERATIONS 62 | +-------------+ start---->+-------------+ +-------------+ 63 | | args[0] | | | | | 64 | +-------------+ | <-\ | /-->| | 65 | | args[1] *----\ | | *---/ | | 66 | +-------------+ \-----> | *-/ | | | 67 | | . | +-+ | | | | 68 | | . | alloc|*-->+-------------+ | | 69 | | . | +-+ | | | | 70 | +-------------+ | | | | 71 | | args[argc-1]| +-+ | | | | 72 | +-------------+ limit|*-->+-------------+ | | 73 | +-+ +-------------+ 74 | 75 | There is a global "args" array. Certain words in "args" may 76 | point into the heap (either the nursery or into older generations). 77 | The nursery may point within itself, or into older generations. 78 | Older generations may not point into the nursery. 79 | The heap may not point into the args array. 80 | 81 | The mutator creates a new object by using the N+1 words (including header) 82 | starting at "alloc", and then adding N+1 to alloc. This is only 83 | permitted if alloc+N+1 <= limit. Otherwise, the mutator must 84 | first call the garbage collector. 85 | 86 | The variables "alloc" and "limit" are owned by the mutator. 87 | The "start" value is not actually a variable of the mutator, 88 | but it was the value of "alloc" immediately after the most 89 | recent collection. 90 | 91 | To call the garbage collector, the mutator passes a fun_info and 92 | a thread_info, as follows. */ 93 | 94 | #define No_scan_tag 251 95 | #define No_scan(t) ((t) >= No_scan_tag) 96 | 97 | typedef const uintnat *fun_info; 98 | /* fi[0]: How many words the function might allocate 99 | fi[1]: How many slots of the args array contain live roots 100 | fi[2..(fi[1]-2)]: Indices of the live roots in the args array 101 | */ 102 | 103 | struct heap; /* abstract, opaque */ 104 | 105 | #define MAX_ARGS 1024 106 | 107 | /* A frame of the shadow stack used to keep track of the live roots */ 108 | struct stack_frame { 109 | value *next; 110 | value *root; /* the array of roots of the function. Allocated in the stack of the function */ 111 | struct stack_frame *prev; /* pointer to the previous stack frame */ 112 | }; 113 | 114 | 115 | struct thread_info { 116 | value *alloc; /* alloc pointer */ 117 | value *limit; /* limit pointer */ 118 | struct heap *heap; /* Description of the generations in the heap */ 119 | value args[MAX_ARGS]; /* the args array */ 120 | struct stack_frame *fp; /* stack pointer */ 121 | uintnat nalloc; /* Remaining allocation until next GC call*/ 122 | void *odata; 123 | }; 124 | 125 | struct thread_info *make_tinfo(void); 126 | 127 | void garbage_collect(struct thread_info *ti); 128 | /* Performs one garbage collection; 129 | or if ti->heap==NULL, initializes the heap. 130 | 131 | The returns in a state where 132 | (1) the "after" graph of nodes reachable from args[indices[0..num_args]] 133 | is isomorphic to the "before" graph; and 134 | (2) the alloc pointer points to N words of unallocated heap space 135 | (where N>=num_allocs), such that limit-alloc=N. 136 | */ 137 | 138 | void free_heap(struct heap *h); 139 | /* Deallocates all heap data associated with h, and returns the 140 | * memory to the operating system (via the malloc/free system). 141 | * After calling this function, h is a dangling pointer and should not be used. 142 | */ 143 | 144 | void reset_heap(struct heap *h); 145 | /* Empties the heap without freeing its storage. 146 | * After a complete execution of the mutator, 147 | * and after whoever invoked the mutator copies whatever result they want 148 | * out of the heap, one can call this function before starting 149 | * another mutator execution. This saves the operating-system overhead of 150 | * free_heap() followed by the implicit create_heap that would have been 151 | * done in the first garbage_collect() call of the next execution. 152 | */ 153 | 154 | /* which slot of the args array has the answer of a certicoq program */ 155 | #define answer_index 1 156 | 157 | value* extract_answer(struct thread_info *ti); 158 | /* y=extract_answer(x,ti) copies the dag rooted at ti->args[answer_index] 159 | into a compact data structure starting at y[1], outside the heap, 160 | in a single malloc'ed (therefore freeable) object at address y. 161 | All within-the-heap pointers will now be within the object y. 162 | If (the answer within) the heap pointed to records outside 163 | the heap, then those will point at their original locations 164 | outside the object y. 165 | 166 | Note that the start is *(y+1), not (y+1); that is, there's an 167 | extra wrapper-record round the object. That's so that the 168 | root-within-the-heap and the root-outside-the-heap (or root-unboxed) 169 | can be treated uniformly by the caller of extract_answer(). 170 | */ 171 | 172 | void* export(struct thread_info *ti); 173 | 174 | /* mutable write barrier */ 175 | void certicoq_modify(struct thread_info *ti, value *p_cell, value p_val); 176 | 177 | void print_heapsize(struct thread_info *ti); 178 | 179 | #endif /* CERTICOQ_GC_STACK_H */ 180 | -------------------------------------------------------------------------------- /c/values.h: -------------------------------------------------------------------------------- 1 | /**************************************************************************/ 2 | /* */ 3 | /* OCaml */ 4 | /* */ 5 | /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ 6 | /* */ 7 | /* Copyright 1996 Institut National de Recherche en Informatique et */ 8 | /* en Automatique. */ 9 | /* */ 10 | /* All rights reserved. This file is distributed under the terms of */ 11 | /* the GNU Lesser General Public License version 2.1, with the */ 12 | /* special exception on linking described in the file LICENSE. */ 13 | /* */ 14 | /**************************************************************************/ 15 | 16 | #ifndef CERTICOQ_VALUES_H 17 | #define CERTICOQ_VALUES_H 18 | 19 | #include "config.h" 20 | 21 | #ifdef __cplusplus 22 | extern "C" { 23 | #endif 24 | 25 | /* Definitions 26 | 27 | word: Four bytes on 32 and 16 bit architectures, 28 | eight bytes on 64 bit architectures. 29 | long: A C integer having the same number of bytes as a word. 30 | val: The ML representation of something. A long or a block or a pointer 31 | outside the heap. If it is a block, it is the (encoded) address 32 | of an object. If it is a long, it is encoded as well. 33 | block: Something allocated. It always has a header and some 34 | fields or some number of bytes (a multiple of the word size). 35 | field: A word-sized val which is part of a block. 36 | bp: Pointer to the first byte of a block. (a char *) 37 | op: Pointer to the first field of a block. (a value *) 38 | hp: Pointer to the header of a block. (a char *) 39 | int32_t: Four bytes on all architectures. 40 | int64_t: Eight bytes on all architectures. 41 | 42 | Remark: A block size is always a multiple of the word size, and at least 43 | one word plus the header. 44 | 45 | bosize: Size (in bytes) of the "bytes" part. 46 | wosize: Size (in words) of the "fields" part. 47 | bhsize: Size (in bytes) of the block with its header. 48 | whsize: Size (in words) of the block with its header. 49 | 50 | hd: A header. 51 | tag: The value of the tag field of the header. 52 | color: The value of the color field of the header. 53 | This is for use only by the GC. 54 | */ 55 | 56 | typedef intnat value; 57 | typedef uintnat header_t; 58 | typedef uintnat mlsize_t; 59 | typedef unsigned int tag_t; /* Actually, an unsigned char */ 60 | typedef uintnat color_t; 61 | typedef uintnat mark_t; 62 | 63 | /* Longs vs blocks. */ 64 | #define Is_long(x) (((x) & 1) != 0) 65 | #define Is_block(x) (((x) & 1) == 0) 66 | 67 | /* Conversion macro names are always of the form "to_from". */ 68 | /* Example: Val_long as in "Val from long" or "Val of long". */ 69 | #define Val_long(x) ((intnat) (((uintnat)(x) << 1)) + 1) 70 | #define Long_val(x) ((x) >> 1) 71 | #define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) 72 | #define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) 73 | #define Val_int(x) Val_long(x) 74 | #define Int_val(x) ((int) Long_val(x)) 75 | #define Unsigned_long_val(x) ((uintnat)(x) >> 1) 76 | #define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) 77 | 78 | /* Structure of the header: 79 | 80 | For 16-bit and 32-bit architectures: 81 | +--------+-------+-----+ 82 | | wosize | color | tag | 83 | +--------+-------+-----+ 84 | bits 31 10 9 8 7 0 85 | 86 | For 64-bit architectures: 87 | 88 | +--------+-------+-----+ 89 | | wosize | color | tag | 90 | +--------+-------+-----+ 91 | bits 63 10 9 8 7 0 92 | 93 | For x86-64 with Spacetime profiling: 94 | P = PROFINFO_WIDTH (as set by "configure", currently 26 bits, giving a 95 | maximum block size of just under 4Gb) 96 | +----------------+----------------+-------------+ 97 | | profiling info | wosize | color | tag | 98 | +----------------+----------------+-------------+ 99 | bits 63 (64-P) (63-P) 10 9 8 7 0 100 | 101 | */ 102 | 103 | #define PROFINFO_SHIFT (64 - PROFINFO_WIDTH) 104 | #define PROFINFO_MASK ((1ull << PROFINFO_WIDTH) - 1ull) 105 | 106 | #define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) 107 | #ifdef WITH_SPACETIME 108 | #define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT)) 109 | #define Wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10)) 110 | #else 111 | #define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) 112 | #endif /* SPACETIME */ 113 | #ifdef ARCH_SIXTYFOUR 114 | /* [Profinfo_hd] is used when the compiler is not configured for Spacetime 115 | (e.g. when decoding profiles). */ 116 | #define Profinfo_hd(hd) (((mlsize_t) ((hd) >> PROFINFO_SHIFT)) & PROFINFO_MASK) 117 | #else 118 | #define Profinfo_hd(hd) ((hd) & 0) 119 | #endif /* ARCH_SIXTYFOUR */ 120 | 121 | #define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ 122 | #define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ 123 | #define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ 124 | #define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ 125 | #define Hp_val(val) (((header_t *) (val)) - 1) 126 | #define Hp_op(op) (Hp_val (op)) 127 | #define Hp_bp(bp) (Hp_val (bp)) 128 | #define Val_op(op) ((value) (op)) 129 | #define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) 130 | #define Op_hp(hp) ((value *) Val_hp (hp)) 131 | #define Bp_hp(hp) ((char *) Val_hp (hp)) 132 | 133 | #define Num_tags (1 << 8) 134 | #ifdef ARCH_SIXTYFOUR 135 | #ifdef WITH_SPACETIME 136 | #define Max_wosize (((intnat)1 << (54-PROFINFO_WIDTH)) - 1) 137 | #else 138 | #define Max_wosize (((intnat)1 << 54) - 1) 139 | #endif 140 | #else 141 | #define Max_wosize ((1 << 22) - 1) 142 | #endif 143 | 144 | #define Wosize_val(val) (Wosize_hd (Hd_val (val))) 145 | #define Wosize_op(op) (Wosize_val (op)) 146 | #define Wosize_bp(bp) (Wosize_val (bp)) 147 | #define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) 148 | #define Whsize_wosize(sz) ((sz) + 1) 149 | #define Wosize_whsize(sz) ((sz) - 1) 150 | #define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) 151 | #define Bsize_wsize(sz) ((sz) * sizeof (value)) 152 | #define Wsize_bsize(sz) ((sz) / sizeof (value)) 153 | #define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) 154 | #define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) 155 | #define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) 156 | #define Bosize_op(op) (Bosize_val (Val_op (op))) 157 | #define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) 158 | #define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) 159 | #define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) 160 | #define Whsize_val(val) (Whsize_hp (Hp_val (val))) 161 | #define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) 162 | #define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) 163 | #define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) 164 | #define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) 165 | #define Bhsize_val(val) (Bsize_wsize (Whsize_val (val))) 166 | 167 | #define Profinfo_val(val) (Profinfo_hd (Hd_val (val))) 168 | 169 | #ifdef ARCH_BIG_ENDIAN 170 | #define Tag_val(val) (((unsigned char *) (val)) [-1]) 171 | /* Also an l-value. */ 172 | #define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) 173 | /* Also an l-value. */ 174 | #else 175 | #define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) 176 | /* Also an l-value. */ 177 | #define Tag_hp(hp) (((unsigned char *) (hp)) [0]) 178 | /* Also an l-value. */ 179 | #endif 180 | 181 | /* Pointer to the first field. */ 182 | #define Op_val(x) ((value *) (x)) 183 | /* Fields are numbered from 0. */ 184 | #define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ 185 | 186 | /* Pointer to the first byte */ 187 | #define Bp_val(v) ((char *) (v)) 188 | #define Val_bp(p) ((value) (p)) 189 | /* Bytes are numbered from 0. */ 190 | #define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ 191 | #define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ 192 | 193 | #ifdef __cplusplus 194 | } 195 | #endif 196 | 197 | #endif /* CERTICOQ_VALUES_H */ 198 | -------------------------------------------------------------------------------- /library/base_representation.v: -------------------------------------------------------------------------------- 1 | (** * Generic Definitions for the Representation Predicates 2 | 3 | Kathrin Stark, 2020. 4 | 5 | This code contains definitions to later on generate specific instances of representation predicates. 6 | 7 | This document contains of the following parts: 8 | - 1. Import of necessary definitions from Shengyi/Olivier. The CertiCoq code cannot be imported at the moment because of problems compiling both projects at the same time. 9 | - 2. The definition of rep_type, the type to describe a node either in the graph or outside, and its connection to field. 10 | - 3. The graph_cRep predicate which will be the central part of later specific instances. 11 | - 4. Examples on how this predicate will be used in the representation predicate for bool, nat, and list. 12 | *) 13 | 14 | Require Import VST.floyd.proofauto. 15 | From CertiGraph Require Import graph_model. 16 | From CertiGraph.CertiGC Require Import gc_spec. 17 | (* Require Import CertiGraph.CertiGC.GCGraph. *) 18 | (* Require Import CertiGraph.CertiGC.spatial_gcgraph. *) 19 | 20 | (** ** 1. Import of the necessary definitions *) 21 | 22 | (** Type of graphs, according to Shengyi's garbage collector proof. *) 23 | Definition graph := LGraph. 24 | 25 | (** *** Definitions from the CertiCoq Project. *) 26 | 27 | (** Representation of unboxed values. *) 28 | Definition repr_unboxed_L7: N -> Z -> Prop := 29 | fun t => fun h => 30 | (h = (Z.shiftl (Z.of_N t) 1) + 1)%Z /\ 31 | (0 <= (Z.of_N t) < Ptrofs.half_modulus )%Z. 32 | 33 | (** Representation of the boxed header, given the tag byte and the size of the data. *) 34 | Definition boxed_header: N -> N -> Z -> Prop := 35 | fun t => fun a => fun h => 36 | (h = (Z.shiftl (Z.of_N a) 10) + (Z.of_N t))%Z /\ 37 | (0 <= Z.of_N t < Zpower.two_power_pos 8)%Z /\ 38 | (0 <= Z.of_N a < Zpower.two_power_nat (Ptrofs.wordsize - 10))%Z. 39 | 40 | Definition int_chunk := if Archi.ptr64 then Mint64 else Mint32. 41 | Definition int_size := (size_chunk int_chunk). 42 | 43 | (** Internal representation of a constructor, where enum t describes a constructor with tag t, and boxed t n is a boxed value with tag t and n arguments. *) 44 | Inductive cRep : Set := enum : N -> cRep | boxed : N -> N -> cRep. 45 | 46 | 47 | (** ** 2. Representation type *) 48 | 49 | (** Type of representation values, rep_type: 50 | 51 | Either Z, a value representing an unboxed value, 52 | or GC_Pointer, a pointer outside the garbage-collected heap, 53 | (Inductive GC_Pointer : Type := GCPtr : block -> ptrofs -> GC_Pointer) 54 | or VType, a node in the graph. 55 | 56 | Values generated by the code generator never point outside the garbage-collected heap, 57 | but later C code might do this. *) 58 | 59 | Inductive rep_type := 60 | | repZ : Z -> rep_type 61 | | repOut : GC_Pointer -> rep_type 62 | | repNode : VType -> rep_type. 63 | 64 | (** Conversion functions between raw_field, the representation type of fields in Shengyi's graphs, and our rep_type from outside. 65 | 66 | raw_field = option (Z + GC_Pointer) 67 | Meaning: Z and GC_Pointer have the same meaning as in rep_type. 68 | The empty option case denotes the case that we have a pointer to another node in the graph, denoted by an edge. 69 | 70 | The Z and GC_Pointer case are straightforward. 71 | In make_field_t we have additionally the graph g, 72 | and the node v and the nth argument we are coming from. 73 | Given this information, we can determine the goal node. 74 | *) 75 | 76 | Definition field_rep (g : graph) (v : VType) (n : nat) (raw : raw_field) : rep_type := ( 77 | match raw with 78 | | None => repNode (dst g (v, n)) 79 | | Some (inl z) => repZ z 80 | | Some (inr p) => repOut p 81 | end). 82 | 83 | Definition rep_field (x : rep_type) : raw_field := 84 | match x with 85 | | repZ z => Some (inl z) 86 | | repOut p => Some (inr p) 87 | | repNode _ => None 88 | end. 89 | 90 | 91 | (** ** 3. The graph_cRep predicate *) 92 | 93 | (** Predicate to state that a list of raw_field and a list of rep_type are compatible. 94 | This is needed for the fitting_index predicate below. 95 | 96 | Needed, as the information of a raw_field just makes sense together with the graph and the position. 97 | *) 98 | Inductive compatible (g : graph) (v : VType) ( n : nat) : list raw_field -> list rep_type -> Prop := 99 | | compatible_nil : compatible g v n nil nil 100 | | compatible_cons x xs y ys : compatible g v (S n) xs ys -> field_rep g v n x = y -> compatible g v n (x :: xs) (y :: ys). 101 | 102 | 103 | (** Parametric predicate to be used in combination with the generated code. 104 | graph_cRep g p c args states that in graph g, p : rep_type corresponds to the value with the constructor described by c and with arguments args. 105 | 106 | Two cases: 107 | - If we describe an unboxed constructor enum t with tag t, 108 | then the list of arguments has to be empty and the representation of 109 | the tag has to fit with the actual value z according to the relation repr_unboxed_L7. 110 | - If we describe a boxed constructor boxed t n with tag t and length n, 111 | then we describe a node repNode v in the graph and 112 | 1. the length of the arguments arrays has to coincide with the number 113 | given in the constructor description, 114 | 2. the given graph g has to actually contain the node v, 115 | 3. the label of v in the graph g has to coincide with the 116 | information we have given, using the predicate compatible. 117 | 118 | TODO: 119 | - Do we want the args computational in the first case? 120 | **) 121 | 122 | Definition graph_cRep (g: graph) (p : rep_type) (c : cRep) (args: list rep_type) : Prop := 123 | match c, p with 124 | | enum t, repZ z => args = nil /\ (* repr_unboxed_L7 t z *) Z.to_N z = t 125 | | boxed t n, repNode v => length args = N.to_nat n /\ graph_has_v g v /\ 126 | match (vlabel g v) with 127 | | Build_raw_vertex_block false v' raws 0 n _ _ _ _ => (* v = v' /\ *) n = Z.of_N t /\ compatible g v 0 raws args 128 | | _ => False 129 | end 130 | | _, _ => False 131 | end. 132 | 133 | 134 | (** We will later use the following predicate actually spatially representing a graph: 135 | graph_rep : LGraph -> mpred*) 136 | 137 | (** ** 4. Examples of using the graph_cRep predicate for bool/nat. *) 138 | 139 | (* Section Tests. *) 140 | 141 | (* (* Showcase what these definitions mean in the specific case. *) 142 | (* Similar tags and the fixpoints will be generated by Joomy's code generation. *) 143 | (* *) *) 144 | 145 | (* Definition tag_bool (b : bool) : cRep := *) 146 | (* match b with *) 147 | (* | true => enum 0 *) 148 | (* | false => enum 1 *) 149 | (* end. *) 150 | 151 | (* Fixpoint bool_in_graph (g : graph) (b : bool) (p : rep_type) : Prop := *) 152 | (* match b with *) 153 | (* | true => graph_cRep g p (tag_bool true) nil *) 154 | (* | false => graph_cRep g p (tag_bool false) nil *) 155 | (* end. *) 156 | 157 | (* Definition tag_nat (n : nat) : cRep := *) 158 | (* match n with *) 159 | (* | O => enum 0 *) 160 | (* | S _ => boxed 0 1 *) 161 | (* end. *) 162 | 163 | (* Fixpoint nat_in_graph (g : graph) (n : nat) (p : rep_type) : Prop := *) 164 | (* match n with *) 165 | (* | O => graph_cRep g p (tag_nat 0) nil *) 166 | (* | S n' => exists p1, nat_in_graph g n' p1 /\ graph_cRep g p (tag_nat (S n')) (p1 :: nil) *) 167 | (* end. *) 168 | 169 | (* Variable g : graph. *) 170 | 171 | (* (** This is true independent of the graph and always reduces to a true equation. *) 172 | (* *) *) 173 | (* Goal (nat_in_graph g 0 (repZ 0)). *) 174 | (* Proof. *) 175 | (* cbv. intuition congruence. *) 176 | (* Qed. *) 177 | 178 | (* Goal forall n v, nat_in_graph g (S n) v -> exists v', nat_in_graph g n v'. *) 179 | (* Proof. *) 180 | (* intros n v (p1&H1&H2). eauto. *) 181 | (* Qed. *) 182 | 183 | (* Variable v : VType. *) 184 | 185 | (* Goal (nat_in_graph g 1) (repNode v). *) 186 | (* Proof. *) 187 | (* cbn. *) 188 | (* exists (repZ 0). *) 189 | (* intuition (try congruence). *) 190 | (* (** This is the point where we can't influence anything anymore, but the graph has to contain the respective information. *) *) 191 | 192 | (* (* TODO: Can I have it more constructive to get p1? *) 193 | (* Do we want to tactics to simplify this kind of proofs? *) 194 | (* Do we want to give more hints to unfold things? *) 195 | (* *) *) 196 | (* Abort. *) 197 | 198 | (* Definition tag_list {X} (xs : list X): cRep := *) 199 | (* match xs with *) 200 | (* | nil => enum 0 *) 201 | (* | _ => boxed 0 2 *) 202 | (* end. *) 203 | 204 | (* (* TODO: Use type classes for arguments? *) *) 205 | (* Fixpoint list_in_graph {X: Type} (X_in_graph : graph -> X -> rep_type -> Prop) (g : graph) (xs : list X) (p : rep_type) := *) 206 | (* match xs with *) 207 | (* | nil => graph_cRep g p (tag_list (@nil X)) nil *) 208 | (* | cons x xs' => exists p1 p2, X_in_graph g x p1 /\ list_in_graph X_in_graph g xs' p2 /\ graph_cRep g p (tag_list (cons x xs)) (p1 :: p2 :: nil) *) 209 | (* end. *) 210 | 211 | (* Goal (list_in_graph nat_in_graph g (O :: nil)) (repNode v). *) 212 | (* Proof. *) 213 | (* cbn. *) 214 | (* exists (repZ 0). (* For the 0 *) *) 215 | (* exists (repZ 0). (* For nil *) *) 216 | (* intuition (try congruence). *) 217 | (* - (** We need that the vertex v indeed exists. *) *) 218 | (* admit. *) 219 | (* - (** We need that the vertex satisfies corresponding properties. *) *) 220 | (* Abort. *) 221 | 222 | (* End Tests. *) 223 | -------------------------------------------------------------------------------- /generator/FnDesc.v: -------------------------------------------------------------------------------- 1 | 2 | Require Import Coq.ZArith.ZArith 3 | Coq.Program.Basics 4 | Coq.Strings.String 5 | Coq.Lists.List 6 | Coq.Lists.ListSet. 7 | 8 | Require Import ExtLib.Structures.Monads 9 | ExtLib.Data.Monads.OptionMonad 10 | ExtLib.Data.Monads.StateMonad 11 | ExtLib.Data.String. 12 | 13 | Require Import MetaCoq.Template.All. 14 | 15 | Require Import VeriFFI.generator.gen_utils. 16 | Require Import VeriFFI.library.base_representation. 17 | Require Import VeriFFI.library.meta. 18 | Require Import VeriFFI.library.modelled. 19 | Require Import VeriFFI.generator.GraphPredicate. 20 | Require Import VeriFFI.generator.InGraph. 21 | 22 | Unset MetaCoq Strict Unquote Universe Mode. 23 | 24 | (* Require Import VeriFFI.generator.InGraph. *) 25 | (* MetaCoq Run (in_graph_gen bool). *) 26 | (* Instance InGraph_bool : InGraph bool. rep_gen. Defined. *) 27 | (* MetaCoq Run (in_graph_gen list). *) 28 | (* Instance InGraph_list : forall A, InGraph A -> InGraph (list A). rep_gen. Defined. *) 29 | (* MetaCoq Run (in_graph_gen nat). *) 30 | (* Instance InGraph_nat : InGraph nat. rep_gen. Defined. *) 31 | 32 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 33 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 34 | Import monad_utils.MCMonadNotation 35 | ListNotations 36 | MetaCoqNotations. 37 | 38 | Set Universe Polymorphism. 39 | (* Set Polymorphic Inductive Cumulativity. *) 40 | 41 | Fixpoint adjust_context (ctx : list (Kernames.ident * Reppyish)) : TemplateMonad (list (Kernames.ident * named_term)) := 42 | match ctx with 43 | | nil => ret nil 44 | | (id, None) :: xs => adjust_context xs 45 | | (id, Some (A; H)) :: xs => 46 | A' <- tmQuote A ;; 47 | xs' <- adjust_context xs ;; 48 | ret ((id, A') :: xs') 49 | end. 50 | 51 | Definition kleisli_compose {m a b c} `{Monad m} : (b -> m c) -> (a -> m b) -> (a -> m c) := 52 | fun g f x => f x >>= g. 53 | 54 | Definition fresh_aname (prefix : string) (a : aname) : TemplateMonad (Kernames.ident * aname) := 55 | let x := match binder_name a with | nAnon => prefix | nNamed i => prefix ++ i end in 56 | x' <- tmFreshName x ;; 57 | ret (x, {| binder_name := nNamed x'; binder_relevance := binder_relevance a |}). 58 | 59 | Definition fill_hole 60 | (named_ctx : list (Kernames.ident * named_term)) 61 | (goal : named_term) 62 | : TemplateMonad named_term := 63 | (* quantify all the free variables in the goal *) 64 | let quantified : global_term := 65 | fold_left 66 | (fun tm '(id, ty) => tProd (mkBindAnn (nNamed id) Relevant) ty tm) 67 | named_ctx goal in 68 | (* use primitives to infer the type class instance over the global term *) 69 | tmEval all quantified >>= tmPrint ;; 70 | hoisted <- instance_term quantified ;; 71 | (* make function application again to have the same free variables *) 72 | tmMsg "hole ctx:" ;; 73 | tmEval all named_ctx >>= tmPrint ;; 74 | let ctx_to_apps : list named_term := 75 | rev (map (fun '(id, t) => 76 | match t with 77 | | tApp (tInd {| inductive_mind := kn; inductive_ind := 0 |} _) _ => 78 | if eq_kername kn 79 | then tApp <% @foreign_in_graph %> [hole; tVar id] 80 | (* then tApp (tConst (MPfile ["modelled"; "library"; "VeriFFI"], "foreign_in_graph") []) [hole; tVar id] *) 81 | else tVar id 82 | | _ => tVar id 83 | end) named_ctx) in 84 | ret (tApp hoisted ctx_to_apps). 85 | (* ret (strip_lambdas hoisted). *) 86 | (* ret (tApp hoisted (rev (map (fun '(id, _) => tVar id) named_ctx))). *) 87 | 88 | Instance InGraph_list : forall A, InGraph A -> InGraph (list A). 89 | Admitted. 90 | 91 | MetaCoq Run (fill_hole [("H", tApp <% InGraph %> [tVar "a"]);("a", <% Type %>)] 92 | (tApp <% InGraph %> [tApp <% @list %> [tVar "a"]]) >>= tmEval all >>= tmPrint!). 93 | 94 | Print ForeignInGraph. 95 | Print foreign_ann. 96 | 97 | Polymorphic Definition create_reified 98 | (model_t : term) 99 | (foreign_t : term) : TemplateMonad (reified foreign_ann) := 100 | model_t' <- DB.undeBruijn' (map (fun '(id, _) => nNamed id) []) model_t ;; 101 | foreign_t' <- DB.undeBruijn' (map (fun '(id, _) => nNamed id) []) foreign_t ;; 102 | 103 | let fix go 104 | (* type of the functional model function *) 105 | (model_t : named_term) 106 | (* type of the foreign function *) 107 | (foreign_t : named_term) 108 | (* the context kept for De Bruijn indices *) 109 | (index_ctx : list (Kernames.ident * named_term)) 110 | (* the context kept for "lambda lifting" the holes *) 111 | (named_ctx : list (Kernames.ident * named_term)) 112 | : TemplateMonad named_term := 113 | match model_t', foreign_t' with 114 | | tProd model_n (tSort model_s as model_t) model_b 115 | , tProd foreign_n (tSort foreign_s as foreign_t) foreign_b => 116 | '(h, H) <- fresh_aname "H" n ;; 117 | let named_ctx' : list (Kernames.ident * named_term) := 118 | match binder_name n with 119 | | nNamed id => (h, tApp <% @InGraph %> [tVar id]) :: (id, t) :: named_ctx 120 | | _ => named_ctx end in 121 | rest <- go b index_ctx named_ctx' (pred num_params) ;; 122 | let f := tLambda n (tSort s) (tLambda H (tApp <% @ctor_ann %> [tRel O]) rest) in 123 | ret (tApp <% @TYPEPARAM foreign_ann %> [f]) 124 | 125 | | tProd model_n model_t model_b 126 | , tProd foreign_n foreign_t foreign_b => 127 | let named_ctx' : list (Kernames.ident * named_term) := 128 | match binder_name n with 129 | | nNamed id => (id, t) :: named_ctx 130 | | _ => named_ctx end in 131 | rest <- go b index_ctx named_ctx' O ;; 132 | let t' := Substitution.named_subst_all index_ctx t in 133 | let f := tLambda n t' rest in 134 | H <- fill_hole named_ctx (tApp <% InGraph %> [t']) ;; 135 | let H' := tApp <% Build_ctor_ann %> [t'; <% present %>; H] in 136 | ret (tApp <% @ARG foreign_ann %> [t'; H'; f]) 137 | 138 | | model_rest , foreign_rest => 139 | let model_rest' := Substitution.named_subst_all index_ctx model_rest in 140 | let foreign_rest' := Substitution.named_subst_all index_ctx foreign_rest in 141 | H <- fill_hole named_ctx (tApp <% ForeignInGraph %> [rest']) ;; 142 | let H' := tApp <% Build_foreign_ann %> [rest'; <% present %>; H] in 143 | ret (tApp <% @RES foreign_ann %> [rest'; H']) 144 | end 145 | in 146 | 147 | let num_of_params := ind_npars mut in 148 | c <- go t' [] [] num_of_params ;; 149 | tmMsg "after go:" ;; 150 | tmEval all c >>= tmPrint ;; 151 | c' <- DB.deBruijn c ;; 152 | (* tmMsg "after de bruijn:" ;; *) 153 | (* tmEval all c' >>= tmPrint ;; *) 154 | tmUnquoteTyped (reified ctor_ann) c'. 155 | 156 | Print tmQuote. 157 | Print constant_body. 158 | 159 | Definition fn_desc_gen 160 | {T1 T2 : Type} 161 | (model_val : T1) (foreign_val : T2) 162 | (c_name : string) : TemplateMonad unit := 163 | model_t <- tmQuote model_val ;; 164 | foreign_t <- tmQuote foreign_val ;; 165 | match model_t , foreign_t with 166 | | tConst model_kn _ , tConst foreign_kn _ => 167 | if ident_eq (snd model_kn) (snd foreign_kn) 168 | then tmMsg "Warning: functional model and foreign function names are different" 169 | else ret tt ;; 170 | 171 | reified <- create_reified model_t foreign_t ;; 172 | (* tmPrint "after create reified" ;; *) 173 | (* tmEval all reified >>= tmPrint ;; *) 174 | 175 | newName <- tmFreshName "new"%bs ;; 176 | reflected <- tmLemma newName (@reflector foreign_ann T2 foreign_val reified) ;; 177 | 178 | let d := {| type_desc := reified 179 | ; foreign_fn := foreign_val 180 | ; model_fn := reflected 181 | ; fn_arity := _ 182 | ; c_name := c_name 183 | |} in 184 | 185 | name <- tmFreshName (snd foreign_kn ++ "_desc")%bs ;; 186 | @tmDefinition name fn_desc d ;; 187 | (* Declare the new definition a type class instance *) 188 | (* mp <- tmCurrentModPath tt ;; *) 189 | (* tmExistingInstance export (ConstRef (mp, name)) ;; *) 190 | ret tt 191 | | _ , _ => 192 | tmFail "Need two constant definitions in the environment" 193 | end. 194 | 195 | Local Obligation Tactic := reflecting. 196 | 197 | Ltac gen := 198 | match goal with 199 | | [ |- @reflector _ _ _ _ ] => reflecting 200 | | _ => in_graph_gen_tac 201 | end. 202 | 203 | Local Obligation Tactic := gen. 204 | 205 | Unset MetaCoq Strict Unquote Universe Mode. 206 | 207 | (* Set Universe Polymorphism. *) 208 | (* Set Polymorphic Inductive Cumulativity. *) 209 | 210 | (* MetaCoq Run (in_graph_gen option). *) 211 | (* MetaCoq Run (descs_gen option). *) 212 | (* MetaCoq Run (@desc_gen _ (@None)). *) 213 | 214 | (* MetaCoq Run (in_graph_gen unit). *) 215 | (* MetaCoq Run (descs_gen unit). *) 216 | 217 | (* MetaCoq Run (in_graph_gen nat). *) 218 | (* MetaCoq Run (descs_gen nat). *) 219 | 220 | 221 | (* MetaCoq Run (desc_gen tt). *) 222 | (* MetaCoq Run (desc_gen S). *) 223 | (* Set Printing All. *) 224 | (* Print S_desc. *) 225 | (* Check <% tt %>. *) 226 | 227 | (* MetaCoq Run (in_graph_gen unit). *) 228 | (* MetaCoq Run (desc_gen tt). *) 229 | 230 | (* (* Print new_obligation_1. *) *) 231 | (* MetaCoq Run (descs_gen unit). *) 232 | 233 | 234 | (* MetaCoq Run (in_graph_gen nat). *) 235 | (* Instance InGraph_ *) 236 | (* (* MetaCoq Run (rep_gen nat). *) *) 237 | (* MetaCoq Run (descs_gen unit). *) 238 | (* MetaCoq Run (desc_gen O). *) 239 | (* Print O_desc. *) 240 | 241 | (* MetaCoq Run (desc_gen O >>= @tmDefinition ("O_desc"%string) constructor_description). *) 242 | (* Print S_desc. *) 243 | -------------------------------------------------------------------------------- /examples/uint63nat/call.v: -------------------------------------------------------------------------------- 1 | Require Import VeriFFI.examples.uint63nat.prog. 2 | Require Import ZArith. 3 | Require Import Psatz. 4 | Require Export VeriFFI.verification.specs_general. 5 | Require Export VeriFFI.generator.Rep. 6 | 7 | Obligation Tactic := gen. 8 | MetaCoq Run (gen_for nat). 9 | MetaCoq Run (gen_for bool). 10 | 11 | MetaCoq Run (desc_gen S). 12 | MetaCoq Run (desc_gen O). 13 | 14 | Require Export VST.floyd.proofauto. 15 | Require Export CertiGraph.CertiGC.GCGraph. 16 | From VeriFFI Require Export library.base_representation library.meta verification.graph_add verification.specs_library. 17 | 18 | Require Export VeriFFI.examples.uint63nat.Verif_prog_general. 19 | Require Export VeriFFI.examples.uint63nat.glue. 20 | 21 | (* Specific alloc*) 22 | 23 | Definition alloc_make_Coq_Init_Datatypes_nat_O_spec : ident * funspec := 24 | DECLARE _make_Coq_Init_Datatypes_nat_O 25 | WITH gv : globals, g : graph 26 | PRE [ ] 27 | PROP () 28 | PARAMS () 29 | GLOBALS () 30 | SEP (spatial_gcgraph.graph_rep g) 31 | POST [ (talignas 3%N (tptr tvoid)) ] 32 | EX (x : rep_type), 33 | PROP (@is_in_graph nat _ g O x) 34 | LOCAL (temp ret_temp (rep_type_val g x)) 35 | SEP (spatial_gcgraph.graph_rep g). 36 | 37 | (* General specifications for uint63/nat *) 38 | 39 | Definition alloc_make_Coq_Init_Datatypes_nat_S_spec : ident * funspec := 40 | DECLARE _alloc_make_Coq_Init_Datatypes_nat_S 41 | (alloc_make_spec_general (@desc _ S _) 1). 42 | 43 | (* KS: Use *) 44 | Definition nat_get_desc (x : nat) : ctor_desc := 45 | match x with 46 | | O => (@desc _ O _) 47 | | S n => (@desc _ S _) 48 | end. 49 | 50 | Inductive nat_has_tag_prop : nat -> ctor_desc -> Prop := 51 | | tagO : nat_has_tag_prop O (@desc _ O _) 52 | | tagS n : nat_has_tag_prop (S n) (@desc _ S _). 53 | 54 | Definition tag_spec_S : ident * funspec := 55 | DECLARE _get_Coq_Init_Datatypes_nat_tag 56 | WITH gv : globals, g : graph, p : rep_type, 57 | x : nat, roots : roots_t, sh : share, 58 | ti : val, outlier : outlier_t, f_info : fun_info, t_info : GCGraph.thread_info 59 | PRE [[ [int_or_ptr_type] ]] 60 | PROP ( 61 | @is_in_graph nat _ g x p; 62 | writable_share sh) 63 | (PARAMSx ( [rep_type_val g p]) 64 | (GLOBALSx nil 65 | (SEPx (full_gc g t_info roots outlier ti sh :: nil)))) 66 | POST [ tuint ] 67 | (* EX (xs : args (ctor_reific (nat_get_desc x))), *) 68 | PROP ( (* 1. x has tag t and is constructed with the constructor description c. 69 | a. Tag function relating to x. 70 | b. x = ctor_real c xs (* Doesn't type as this. *) 71 | 72 | TODO: Discuss - something around this should already exist for 73 | generating general in_graph functions, and we want things to match. 74 | *) 75 | (* let c := nat_get_desc x in 76 | nat_has_tag_prop x c; *) 77 | (* let c := nat_get_desc x in 78 | let r := result (ctor_reific c) xs in 79 | @is_in_graph (projT1 r) (@in_graph (projT1 r) (projT2 r)) g (ctor_real c xs) p *) 80 | let c := nat_get_desc x in 81 | nat_has_tag_prop x c (* Not 100% sure this is how we want it*) 82 | ) 83 | RETURN ( Vint (Int.repr (Z.of_nat (ctor_tag (nat_get_desc x)))) ) 84 | SEP (full_gc g t_info roots outlier ti sh). 85 | 86 | Definition args_spec_S' (c : ctor_desc) (n : nat) : funspec := 87 | WITH gv : globals, g : graph, p : rep_type, 88 | x: nat, roots : roots_t, sh : share, 89 | ti : val, outlier : outlier_t, f_info : fun_info, t_info : GCGraph.thread_info 90 | PRE [[ [int_or_ptr_type] ]] 91 | PROP ( 92 | writable_share sh; 93 | is_in_graph g (S x) p 94 | ) 95 | (PARAMSx ( [rep_type_val g p]) 96 | (GLOBALSx nil 97 | (SEPx (full_gc g t_info roots outlier ti sh :: nil)))) 98 | POST [ tptr ((tarray int_or_ptr_type 1)) (* tarray int_or_ptr_type 1 *) ] 99 | EX (p' : rep_type) (sh' : share), 100 | PROP ( 101 | is_in_graph g x p' 102 | ) 103 | RETURN ( rep_type_val g p ) 104 | SEP (data_at sh' (tarray int_or_ptr_type 1) [rep_type_val g p'] (rep_type_val g p); 105 | data_at sh' (tarray int_or_ptr_type 1) [rep_type_val g p'] (rep_type_val g p) -* full_gc g t_info roots outlier ti sh). 106 | 107 | 108 | Definition args_make_Coq_Init_Datatypes_nat_S_spec : ident * funspec := 109 | DECLARE _get_args 110 | (args_spec_S' (@desc _ S _) 1). 111 | 112 | (* Same as in UVRooster - TODO: encode_Z as relation to fit our general scheme *) 113 | Definition encode_Z (x: Z): Z := x * 2 + 1. 114 | Definition min_signed: Z := - 2^62. 115 | Definition max_signed: Z := 2^62 - 1. 116 | 117 | #[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined. 118 | 119 | 120 | Instance Discrimination_nat : Discrimination nat. 121 | Admitted. 122 | 123 | Instance Rep_conditional (A : Type) `(InGraph_A : InGraph A) 124 | `(Discrimination_A : Discrimination A) : Rep A := 125 | {| in_graph := InGraph_A ; discrimination := Discrimination_A |}. 126 | 127 | (* Function Spec 128 | 129 | - This is the definition of a Coq function from X to Y/the specification that hopefully CertiCoq 130 | should be able to guarantee. 131 | - The function specification is dependent on (representable) input and output types and a representable 132 | environment type. 133 | - The function yields the right result if given an environment. 134 | - TODO: Don't we rather want that this is... 135 | 136 | - What I changed: changed it to iso. 137 | *) 138 | 139 | Definition fun_spec X Y (In_Graph_X : InGraph X) (In_Graph_Y : InGraph Y) 140 | A (In_Graph_A : InGraph A) (env : A) (f : A -> X -> Y) : funspec := 141 | WITH 142 | (* general info on the garbage collector graph *) 143 | g : graph, roots : roots_t, sh : share, ti : val, 144 | outlier : outlier_t, t_info : GCGraph.thread_info, 145 | (* function-specific *) 146 | x: X, p_x : rep_type, p_env : rep_type 147 | PRE [thread_info, int_or_ptr_type, int_or_ptr_type] 148 | PROP (@is_in_graph X In_Graph_X g x p_x; 149 | is_in_graph g env p_env 150 | ) 151 | PARAMS (ti; rep_type_val g p_env; rep_type_val g p_x) 152 | GLOBALS () 153 | SEP (full_gc g t_info roots outlier ti sh) 154 | POST [ int_or_ptr_type ] 155 | EX (g' : graph) (t_info' : GCGraph.thread_info) (res' : rep_type) (roots' : roots_t), 156 | PROP (@is_in_graph Y In_Graph_Y g' (f env x) res'; 157 | gc_graph_iso g roots g' roots' 158 | ) 159 | RETURN (rep_type_val g' res') 160 | SEP (full_gc g' t_info' roots' outlier ti sh). 161 | 162 | (* This means that for any Coq function f : X -> Y, 163 | CertiCoq has to provide the above lemma for an arbitrary A, InGraph_A, env : A. 164 | *) 165 | 166 | Record closure := { 167 | src_type : Type; 168 | src_repr : InGraph src_type; 169 | trg_type : Type; 170 | trg_repr: InGraph trg_type; 171 | env_type : Type; 172 | env_repr : InGraph env_type; 173 | env : env_type; 174 | fct : env_type -> src_type -> trg_type; 175 | x : src_type (* TODO: NOT IN HERE *) 176 | }. 177 | 178 | 179 | (* Record closure X Y In_Graph_X In_Graph_Y := 180 | {A | env : A, In_Graph_A : InGraph A; 181 | f : A -> X -> Y; 182 | fun_spec X Y In_Graph_X In_Graph_Y A In_Graph_A env f}. *) 183 | 184 | 185 | (* TODO: This would mean that I have to give on the closure... *) 186 | Definition call_spec : ident * funspec := 187 | DECLARE _call 188 | WITH (* General graph content *) 189 | g : graph, roots : roots_t, sh : share, outlier : outlier_t,t_info : GCGraph.thread_info, ti : val, 190 | (* Specific to this function *) 191 | (* X_ : {X : Type | InGraph X}, (* Y : Type, InGraph_Y : InGraph Y, 192 | c: closure X Y In_Graph_X In_Graph_Y, *) 193 | x : X, *) 194 | c : closure, 195 | p_c : val, 196 | p_env : rep_type, 197 | p_x : rep_type, 198 | code_p : rep_type 199 | PRE [ thread_info, int_or_ptr_type, int_or_ptr_type ] 200 | PROP (@is_in_graph _ (src_repr c) g (x c) p_x; 201 | writable_share sh; 202 | (* is_in_graph g closure code_p; *) 203 | @is_in_graph _ (env_repr c) g (env c) p_env ) 204 | PARAMS (ti; p_c; rep_type_val g p_x) 205 | GLOBALS () 206 | SEP (full_gc g t_info roots outlier ti sh; 207 | (* TODO *) 208 | data_at sh (Tstruct _closure noattr) (rep_type_val g code_p, rep_type_val g p_env) p_c; 209 | func_ptr' (fun_spec _ _ (src_repr c) (trg_repr c) _ (env_repr c) (env c) (fct c)) (rep_type_val g code_p) 210 | ) 211 | POST [ int_or_ptr_type ] 212 | EX (g' : graph)(t_info' : GCGraph.thread_info) (p: rep_type) (roots': roots_t), 213 | PROP ( @is_in_graph _ (trg_repr c) g' (fct c (env c) (x c)) p; 214 | gc_graph_iso g roots g' roots' ) 215 | RETURN (rep_type_val g p) 216 | SEP (full_gc g' t_info' roots outlier ti sh). 217 | 218 | 219 | Definition Vprog : varspecs. mk_varspecs prog. Defined. 220 | Definition Gprog := [ tag_spec_S; alloc_make_Coq_Init_Datatypes_nat_O_spec; alloc_make_Coq_Init_Datatypes_nat_S_spec 221 | ; args_make_Coq_Init_Datatypes_nat_S_spec ; 222 | call_spec 223 | ] . 224 | 225 | Lemma body_call : 226 | semax_body Vprog Gprog 227 | f_call 228 | call_spec. 229 | Proof. 230 | start_function. 231 | (* __f = ((tptr (Tstruct _closure noattr)) __clo -> _func); *) 232 | (* (Sset __f 233 | (Efield 234 | (Ederef 235 | (Ecast (Etempvar __clo (Tpointer tvoid (mk_attr false (@Some N (Npos (xI xH)))))) 236 | (tptr (Tstruct _closure noattr))) (Tstruct _closure noattr)) _func 237 | (tptr 238 | (Tfunction 239 | (Tcons (Tstruct _thread_info noattr) 240 | (Tcons (Tpointer tvoid (mk_attr false (@Some N (Npos (xI xH))))) 241 | (Tcons (Tpointer tvoid (mk_attr false (@Some N (Npos (xI xH))))) Tnil))) tvoid cc_default)))) 242 | *) 243 | forward. 244 | (* __envi = ((tptr (Tstruct _closure noattr)) __clo -> _env) *) 245 | (* replace _env with _func at 1. 246 | replace __envi with __f. *) 247 | (* (Ssequence 248 | (Sset __envi 249 | (Efield 250 | (Ederef 251 | (Ecast (Etempvar __clo (Tpointer tvoid (mk_attr false (@Some N (Npos (xI xH)))))) 252 | (tptr (Tstruct _closure noattr))) (Tstruct _closure noattr)) _env 253 | (Tpointer tvoid (mk_attr false (@Some N (Npos (xI xH))))))) MORE_COMMANDS) *) 254 | (* TYPE IS DIFFEREENT *) 255 | forward. 256 | 257 | (* semax Delta 258 | (PROP ( ) 259 | LOCAL (temp __tinfo ti; temp __clo p_c; temp __arg (rep_type_val g p_x)) 260 | SEP (full_gc g t_info roots outlier ti sh; 261 | data_at sh (Tstruct _closure noattr) (rep_type_val g code_p, rep_type_val g p_env) p_c; 262 | func_ptr' 263 | (fun_spec (src_type c) (trg_type c) (src_repr c) (trg_repr c) (env_type c) (env_repr c) (env c) (fct c)) 264 | (rep_type_val g code_p))) (__f = ((tptr (Tstruct _closure noattr)) __clo -> _func); 265 | MORE_COMMANDS) POSTCONDITION *) 266 | 267 | -------------------------------------------------------------------------------- /generator/Discrimination.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.ZArith.ZArith 2 | Coq.Program.Basics 3 | Coq.Strings.String 4 | Coq.Lists.List 5 | Coq.Lists.ListSet. 6 | 7 | Require Import ExtLib.Structures.Monads 8 | ExtLib.Data.Monads.OptionMonad 9 | ExtLib.Data.Monads.StateMonad 10 | ExtLib.Data.String. 11 | 12 | Require Import VeriFFI.generator.gen_utils. 13 | Require Import VeriFFI.library.base_representation. 14 | Require Import VeriFFI.library.meta. 15 | 16 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 17 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 18 | Import ListNotations. 19 | 20 | Require Import MetaCoq.Template.All. 21 | 22 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 23 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 24 | Import monad_utils.MCMonadNotation 25 | ListNotations 26 | MetaCoqNotations. 27 | 28 | Require Import VeriFFI.generator.GraphPredicate. 29 | 30 | Definition Discriminator (A : Type) (descs : list ctor_desc) : Type := 31 | Discrimination A. 32 | 33 | Ltac disc_gen_tac := 34 | idtac. 35 | (* intros; *) 36 | (* repeat (match goal with *) 37 | (* | [R : Discrimination _ |- _] => destruct R *) 38 | (* end); *) 39 | (* unshelve econstructor. *) 40 | (* [apply graph_predicate | prove_has_v | prove_monotone]. *) 41 | 42 | Definition generate_Discrimination_instance_type 43 | (ind : inductive) 44 | (mut : mutual_inductive_body) 45 | (one : one_inductive_body) : TemplateMonad named_term := 46 | generate_instance_type ind mut one 47 | (fun ty_name t => t) 48 | (fun t => apply_to_pi_base (fun t' => tApp <% Discrimination %> [t']) t). 49 | 50 | (* Constructs the instance type for the type at hand, 51 | checks if there's an instance for it. *) 52 | Definition find_missing_instance 53 | (ind : inductive) 54 | (mut : mutual_inductive_body) 55 | (one : one_inductive_body) : TemplateMonad bool := 56 | tmMsg! ("Missing: " ++ string_of_inductive ind) ;; 57 | generate_Discrimination_instance_type ind mut one >>= 58 | DB.deBruijn >>= tmUnquoteTyped Type >>= has_instance. 59 | 60 | (* Take in a [global_declarations], which is a list of declarations, 61 | and find the inductive declarations in that list 62 | that do not have [Discrimination] instances. *) 63 | Fixpoint find_missing_instances 64 | (env : global_declarations) : TemplateMonad (list kername) := 65 | match env with 66 | | (kn, InductiveDecl mut) :: env' => 67 | rest <- find_missing_instances env' ;; 68 | ones <- monad_map_i 69 | (fun i => find_missing_instance 70 | {| inductive_mind := kn ; inductive_ind := i |} mut) 71 | (ind_bodies mut) ;; 72 | if (fold_left andb ones true) (* if there are instances for all *) 73 | then ret rest (* then this one is not missing *) 74 | else ret (kn :: rest) 75 | | _ :: env' => find_missing_instances env' 76 | | nil => 77 | tmMsg "End of missings" ;; 78 | ret nil 79 | end. 80 | 81 | Definition tmInferInstance' (A : Type) (err : string) : TemplateMonad term := 82 | o <- tmInferInstance (Some all) A ;; 83 | match o with 84 | | my_Some inst => tmQuote inst 85 | | my_None => tmFail err 86 | end. 87 | 88 | Definition make_desc_list (ind : inductive) 89 | (ctors : list constructor_body) : TemplateMonad term := 90 | l <- monad_map_i 91 | (fun i _ => 92 | t <- tmUnquoteTyped Type (tApp <% @CtorDesc %> [hole; tConstruct ind i []]) ;; 93 | t_inst <- tmInferInstance' t "No CtorDesc instance for constructor"%bs;; 94 | tmUnquoteTyped ctor_desc 95 | (tApp <% @ctor_desc_of_val %> [hole; tConstruct ind i []; t_inst])) ctors ;; 96 | tmQuote l. 97 | 98 | Definition tmLemmaQuote (id : ident) (A : Type) : TemplateMonad term := 99 | tmLemma id A >>= tmQuote. 100 | 101 | Definition add_instances_aux 102 | (kn : kername) 103 | (mut : mutual_inductive_body) : TemplateMonad (list unit) := 104 | monad_map_i 105 | (fun i one => 106 | let ind := {| inductive_mind := kn ; inductive_ind := i |} in 107 | (* quantified <- generate_Discrimination_instance_type ind mut one ;; *) 108 | desc_list <- make_desc_list ind (ind_ctors one) ;; 109 | quantified_before <- generate_instance_type ind mut one 110 | (fun ty_name t => t) 111 | (* (fun t => apply_to_pi_base (fun t' => tApp <% Discrimination %> [t']) t) ;; *) 112 | (fun t => apply_to_pi_base (fun t' => tApp <% Discriminator %> [t'; desc_list]) t) ;; 113 | (* [tApp <% holding %> [t'; <% @nil ctor_desc %>]]) t) ;; *) 114 | quantified_after <- generate_instance_type ind mut one 115 | (fun ty_name t => t) 116 | (fun t => apply_to_pi_base (fun t' => tApp <% Discrimination %> [t']) t) ;; 117 | 118 | instance_ty_before <- DB.deBruijn quantified_before >>= tmUnquoteTyped Type ;; 119 | quantified_after' <- DB.deBruijn quantified_after ;; 120 | instance_ty_after <- tmUnquoteTyped Type quantified_after' ;; 121 | 122 | name_before <- tmFreshName ("Discriminator_" ++ ind_name one)%bs ;; 123 | lemma <- tmLemmaQuote name_before instance_ty_before ;; 124 | 125 | name_after <- tmFreshName ("Discrimination_" ++ ind_name one)%bs ;; 126 | let def : term := tCast lemma Cast quantified_after' in 127 | (* Tried this, didn't work: 128 | instance <- tmUnquoteTyped instance_ty_after def ;; 129 | @tmDefinition name_after instance_ty_after instance ;; 130 | *) 131 | 132 | (* This is sort of a hack. I couldn't use [tmUnquoteTyped] above *) 133 | (* because of a mysterious type error. (Coq's type errors in monadic *) 134 | (* contexts are just wild.) Therefore I had to [tmUnquote] it to get *) 135 | (* a Σ-type. But when you project the second field out of that, *) 136 | (* the type doesn't get evaluated to [Discrimination _], it stays as *) 137 | (* [my_projT2 {| ... |}]. The same thing goes for the first projection, *) 138 | (* which is the type of the second projection. When the user prints *) 139 | (* their [Discrimination] instance, Coq shows the unevaluated version. *) 140 | (* But we don't want to evaluate it [all] the way, that would unfold *) 141 | (* the references to other instances of [Discrimination]. We only want to get *) 142 | (* the head normal form with [hnf]. *) 143 | (* We have to do this both for the instance body and its type. *) 144 | instance <- tmUnquote def ;; 145 | tmEval hnf (my_projT2 instance) >>= 146 | tmDefinitionRed_ false name_after (Some hnf) ;; 147 | 148 | (* Declare the new definition a type class instance *) 149 | mp <- tmCurrentModPath tt ;; 150 | tmExistingInstance export (ConstRef (mp, name_after)) ;; 151 | 152 | let fake_kn := (fst kn, ind_name one) in 153 | tmMsg! ("Added Discrimination instance for " ++ string_of_kername fake_kn) ;; 154 | ret tt) (ind_bodies mut). 155 | 156 | Definition add_instances (kn : kername) : TemplateMonad unit := 157 | mut <- tmQuoteInductive kn ;; 158 | add_instances_aux kn mut ;; 159 | ret tt. 160 | 161 | 162 | (* Derives a [Discrimination] instance for the type constructor [Tau], 163 | and the types its definition depends on. *) 164 | Definition disc_gen {kind : Type} (Tau : kind) : TemplateMonad unit := 165 | '(env, tau) <- tmQuoteRec Tau ;; 166 | missing <- find_missing_instances (declarations env) ;; 167 | monad_iter add_instances (rev missing). 168 | 169 | Ltac discriminating := 170 | match goal with 171 | | [ |- @Discriminator _ ?l ] => set l as descs 172 | end; 173 | unfold Discriminator; intros; 174 | constructor; intros x; 175 | match goal with 176 | (* one for each number of constructors, unfortunately *) 177 | | [ descs := nil |- _ ] => 178 | case x eqn:eq_x; idtac 179 | | [ descs := ?d1 :: nil |- _ ] => 180 | case x eqn:eq_x; exists d1 181 | | [ descs := ?d1 :: ?d2 :: nil |- _ ] => 182 | case x eqn:eq_x; [ exists d1 | exists d2 ] 183 | | [ descs := ?d1 :: ?d2 :: ?d3 :: nil |- _ ] => 184 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 ] 185 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: nil |- _ ] => 186 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 ] 187 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: ?d5 :: nil |- _ ] => 188 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 | exists d5 ] 189 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: ?d5 :: ?d6 :: nil |- _ ] => 190 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 | exists d5 | exists d6 ] 191 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: ?d5 :: ?d6 :: ?d7 :: nil |- _ ] => 192 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 | exists d5 | exists d6 | exists d7 ] 193 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: ?d5 :: ?d6 :: ?d7 :: ?d8 :: nil |- _ ] => 194 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 | exists d5 | exists d6 | exists d7 | exists d8 ] 195 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: ?d5 :: ?d6 :: ?d7 :: ?d8 :: ?d9 :: nil |- _ ] => 196 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 | exists d5 | exists d6 | exists d7 | exists d8 | exists d9 ] 197 | | [ descs := ?d1 :: ?d2 :: ?d3 :: ?d4 :: ?d5 :: ?d6 :: ?d7 :: ?d8 :: ?d9 :: ?d10 :: nil |- _ ] => 198 | case x eqn:eq_x; [ exists d1 | exists d2 | exists d3 | exists d4 | exists d5 | exists d6 | exists d7 | exists d8 | exists d9 | exists d10 ] 199 | end; 200 | match goal with 201 | (* one for each constructor arity, unfortunately *) 202 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4 ?v5 ?v6 ?v7 ?v8 ?v9 ?v10) |- _ ] => exists (v1; (v2; (v3; (v4; (v5; (v6; (v7; (v8; (v9; (v10; tt)))))))))) 203 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4 ?v5 ?v6 ?v7 ?v8 ?v9) |- _ ] => exists (v1; (v2; (v3; (v4; (v5; (v6; (v7; (v8; (v9; tt))))))))) 204 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4 ?v5 ?v6 ?v7 ?v8) |- _ ] => exists (v1; (v2; (v3; (v4; (v5; (v6; (v7; (v8; tt)))))))) 205 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4 ?v5 ?v6 ?v7) |- _ ] => exists (v1; (v2; (v3; (v4; (v5; (v6; (v7; tt))))))) 206 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4 ?v5 ?v6) |- _ ] => exists (v1; (v2; (v3; (v4; (v5; (v6; tt)))))) 207 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4 ?v5) |- _ ] => exists (v1; (v2; (v3; (v4; (v5; tt))))) 208 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3 ?v4) |- _ ] => exists (v1; (v2; (v3; (v4; tt)))) 209 | | [ eq_x : @eq _ _ (_ ?v1 ?v2 ?v3) |- _ ] => exists (v1; (v2; (v3; tt))) 210 | | [ eq_x : @eq _ _ (_ ?v1 ?v2) |- _ ] => exists (v1; (v2; tt)) 211 | | [ eq_x : @eq _ _ (_ ?v1) |- _ ] => exists (v1; tt) 212 | | [ eq_x : @eq _ _ _ |- _ ] => exists tt 213 | end; 214 | auto. 215 | 216 | Require Import VeriFFI.generator.InGraph. 217 | Require Import VeriFFI.generator.CtorDesc. 218 | Ltac gen := 219 | match goal with 220 | | [ |- @Discriminator _ _ ] => discriminating 221 | | [ |- @reflector _ _ _ _ ] => reflecting 222 | | _ => in_graph_gen_tac 223 | end. 224 | 225 | Local Obligation Tactic := gen. 226 | 227 | (* Unset MetaCoq Strict Unquote Universe Mode. *) 228 | (* MetaCoq Run (in_graph_gen bool). *) 229 | (* MetaCoq Run (descs_gen bool). *) 230 | (* MetaCoq Run (disc_gen bool). *) 231 | 232 | (* MetaCoq Run (in_graph_gen option). *) 233 | (* MetaCoq Run (descs_gen option). *) 234 | 235 | (* MetaCoq Run (in_graph_gen list). *) 236 | (* MetaCoq Run (descs_gen list). *) 237 | (* MetaCoq Run (disc_gen list). *) 238 | -------------------------------------------------------------------------------- /examples/bytestring/specs.v: -------------------------------------------------------------------------------- 1 | Require Import VeriFFI.examples.bytestring.prog. 2 | Require Import ZArith. 3 | Require Import Psatz. 4 | Require Export VeriFFI.verification.specs_general. 5 | Require Export VeriFFI.generator.Rep. 6 | 7 | Import Ascii. 8 | Import Coq.Strings.String. 9 | 10 | #[local] Obligation Tactic := gen. 11 | MetaCoq Run (gen_for ascii). 12 | MetaCoq Run (gen_for string). 13 | 14 | 15 | Require Export VST.floyd.proofauto. 16 | Require Export CertiGraph.CertiGC.GCGraph. 17 | Export spatial_gcgraph. 18 | From VeriFFI Require Export library.base_representation library.meta verification.graph_add verification.specs_library. 19 | 20 | Require Import VeriFFI.examples.bytestring.prog. 21 | Require Export VeriFFI.examples.bytestring.model. 22 | Require Export VeriFFI.examples.bytestring.prims. 23 | 24 | 25 | #[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined. 26 | 27 | #[export] Instance CCE1: change_composite_env env_graph_gc.CompSpecs CompSpecs. 28 | make_cs_preserve env_graph_gc.CompSpecs CompSpecs. 29 | Defined. 30 | 31 | 32 | MetaCoq Run (desc_gen EmptyString). 33 | MetaCoq Run (desc_gen String). 34 | MetaCoq Run (desc_gen Ascii). 35 | 36 | (* TODO this is just Discrimination? *) 37 | Definition string_get_desc (x : string) : ctor_desc := 38 | match x with 39 | | EmptyString => (@ctor_desc_of_val _ EmptyString _) 40 | | String _ _ => (@ctor_desc_of_val _ String _) 41 | end. 42 | 43 | Inductive string_has_tag_prop : string -> ctor_desc -> Prop := 44 | | tagEmpty : string_has_tag_prop EmptyString (@ctor_desc_of_val _ EmptyString _) 45 | | tagString c r : string_has_tag_prop (String c r) (@ctor_desc_of_val _ String _). 46 | 47 | Remark string_desc_has_tag_prop: forall x, string_has_tag_prop x (string_get_desc x). 48 | Proof. 49 | destruct x; constructor. 50 | Qed. 51 | 52 | Definition tag_spec_string : ident * funspec := 53 | DECLARE _get_Coq_Strings_String_string_tag 54 | WITH gv : globals, g : graph, p : rep_type, 55 | x : string, roots : roots_t, sh : share, 56 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 57 | PRE [int_or_ptr_type] 58 | PROP ( 59 | @is_in_graph string _ g outlier x p; 60 | writable_share sh ) 61 | (PARAMSx ( [rep_type_val g p] ) 62 | (GLOBALSx [gv] 63 | (SEPx (full_gc g t_info roots outlier ti sh gv :: nil)))) 64 | POST [ tulong ] 65 | PROP ( ) 66 | RETURN ( Vlong (Int64.repr (Z.of_nat (ctor_tag (string_get_desc x)))) ) 67 | SEP (full_gc g t_info roots outlier ti sh gv). 68 | 69 | Definition tag_spec_string2 : ident * funspec := 70 | DECLARE _get_Coq_Strings_String_string_tag 71 | WITH g : graph, outlier: outlier_t, p : rep_type, x : string 72 | PRE [int_or_ptr_type] 73 | PROP (@is_in_graph string _ g outlier x p ) 74 | PARAMS (rep_type_val g p) 75 | SEP (graph_rep g) 76 | POST [ tulong ] 77 | PROP ( ) 78 | RETURN ( Vlong (Int64.repr (Z.of_nat (ctor_tag (string_get_desc x)))) ) 79 | SEP (graph_rep g). 80 | 81 | Record alloc_prepackage : Type := { 82 | AP_g: graph; 83 | AP_ti: GCGraph.thread_info; 84 | AP_outlier: outlier_t; 85 | AP_n: Z; 86 | AP_enough: 0 <= AP_n <= headroom AP_ti 87 | }. 88 | 89 | 90 | Lemma AP_raw_color_range: 0 <= 0 < 4. 91 | Proof. lia. Qed. 92 | 93 | 94 | Record alloc_package (pp: alloc_prepackage) : Type := { 95 | AP_raw_fields: list raw_field; 96 | AP_tag: Z; 97 | AP_tag_range: 0 <= AP_tag < 256; 98 | AP_raw_fields_range: 0 < Zlength AP_raw_fields < two_p (WORD_SIZE * 8 - 10); 99 | AP_tag_no_scan: NO_SCAN_TAG <= AP_tag -> ~In None AP_raw_fields; 100 | AP_fields: list (EType * (VType * VType)); 101 | AP_len: AP_n pp = (1 + Zlength AP_raw_fields)%Z; 102 | AP_vertex := new_copied_v (AP_g pp) O; 103 | AP_rvb := Build_raw_vertex_block false AP_vertex AP_raw_fields 104 | 0 AP_tag AP_tag_range AP_raw_color_range AP_raw_fields_range AP_tag_no_scan; 105 | AP_compat: add_node_compatible (AP_g pp) AP_vertex AP_fields; 106 | AP_edge_compat: edge_compatible (AP_g pp) 0 AP_raw_fields AP_fields; 107 | AP_incl_outlier: incl (List_ext.filter_sum_right (List_ext.filter_option 108 | (raw_fields AP_rvb))) (AP_outlier pp) 109 | }. 110 | 111 | Definition AP_newg pp ap := add_node (AP_g pp) O (AP_rvb pp ap) (AP_fields pp ap). 112 | 113 | Lemma allocate_in_nursery_pf {n: Z} {nursery : space} 114 | (H: 0 <= n <= nursery.(total_space)-nursery.(used_space)) : 115 | 0 <= nursery.(used_space)+n <= nursery.(total_space). 116 | Proof. 117 | intros. 118 | pose proof space_order nursery. 119 | lia. 120 | Qed. 121 | 122 | Definition allocate_in_nursery (n: Z) (nursery : space) 123 | (H: 0 <= n <= nursery.(total_space)-nursery.(used_space)) := 124 | {| space_start := nursery.(space_start); 125 | used_space := nursery.(used_space) + n; 126 | total_space := nursery.(total_space); 127 | space_sh := nursery.(space_sh); 128 | space_order := allocate_in_nursery_pf H; 129 | space_upper_bound := nursery.(space_upper_bound) |}. 130 | 131 | Lemma allocate_in_full_gc_aux: 132 | forall n nursery H h, 133 | Zlength (allocate_in_nursery n nursery H :: tl (spaces h)) = MAX_SPACES. 134 | Proof. 135 | intros. 136 | pose proof spaces_size h. 137 | destruct (spaces h). 138 | inversion H0. 139 | simpl. 140 | rewrite Zlength_cons in *. 141 | auto. 142 | Qed. 143 | 144 | Lemma enough_lemma: forall n tinfo, 145 | 0 <= n <= headroom tinfo -> 146 | 0 <= n <= 147 | total_space (nth 0 (spaces (ti_heap tinfo)) null_space) 148 | - used_space (nth 0 (spaces (ti_heap tinfo)) null_space). 149 | Proof. 150 | unfold headroom. 151 | intros. 152 | destruct (heap_head_cons (ti_heap tinfo)) as [nursery [rest [? ? ] ] ]. 153 | rewrite H0. rewrite H1 in H. simpl. auto. 154 | Qed. 155 | 156 | Definition bump_alloc (pp: alloc_prepackage) : GCGraph.thread_info := 157 | let tinfo := AP_ti pp in 158 | let nursery := heap_head (ti_heap tinfo)in 159 | {| ti_heap_p := tinfo.(ti_heap_p); 160 | ti_heap := add_node_heap 0 (ti_heap tinfo) (AP_n pp) (enough_lemma _ _ (AP_enough pp)) ; 161 | ti_args := tinfo.(ti_args); 162 | arg_size := tinfo.(arg_size); 163 | ti_frames := tinfo.(ti_frames); 164 | ti_nalloc := tinfo.(ti_nalloc) |}. 165 | 166 | Definition alloc_at (tinfo: GCGraph.thread_info) : val := 167 | let nursery := heap_head (ti_heap tinfo) in 168 | offset_val (WORD_SIZE * (used_space nursery)) (space_start nursery). 169 | 170 | Definition bump_allocptr_spec: ident * funspec := 171 | DECLARE _bump_allocptr 172 | WITH gv: globals, roots: roots_t, 173 | sh: share, ti: val, 174 | pp: alloc_prepackage 175 | PRE [ thread_info, size_t ] 176 | PROP( writable_share sh ) 177 | PARAMS (ti; Vptrofs (Ptrofs.repr (AP_n pp))) GLOBALS (gv) 178 | SEP (full_gc (AP_g pp) (AP_ti pp) roots (AP_outlier pp) ti sh gv) 179 | POST [ tptr int_or_ptr_type ] 180 | PROP( ) 181 | RETURN ( alloc_at (AP_ti pp)) 182 | SEP (graph_rep (AP_g pp); 183 | @data_at_ env_graph_gc.CompSpecs (nth_sh (AP_g pp) 0) 184 | (tarray int_or_ptr_type (AP_n pp)) (alloc_at (AP_ti pp)); 185 | ALL pk: alloc_package pp, 186 | (graph_rep (AP_g pp)* 187 | vertex_at (nth_sh (AP_g pp) O) (vertex_address (AP_newg _ pk) (new_copied_v (AP_g pp) O)) 188 | (header_new (AP_rvb _ pk)) 189 | (fields_new (AP_newg _ pk) (AP_rvb _ pk) (new_copied_v (AP_g pp) O))) -* 190 | full_gc (AP_newg _ pk) (bump_alloc pp) roots (AP_outlier pp) ti sh gv ). 191 | 192 | Definition args_spec_String : funspec := 193 | WITH gv : globals, g : graph, p : rep_type, 194 | chs: ascii*string, roots : roots_t, sh : share, 195 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 196 | PRE [int_or_ptr_type] 197 | PROP (writable_share sh; 198 | is_in_graph g outlier (String (fst chs) (snd chs)) p) 199 | PARAMS (rep_type_val g p) 200 | GLOBALS (gv) 201 | SEP (full_gc g t_info roots outlier ti sh gv) 202 | POST [ tptr int_or_ptr_type ] 203 | EX (p0 : rep_type) (p1: rep_type) (sh' : share), 204 | PROP (writable_share sh'; 205 | is_in_graph g outlier (fst chs) p0; 206 | is_in_graph g outlier (snd chs) p1) 207 | RETURN ( rep_type_val g p ) 208 | SEP (data_at sh' (tarray int_or_ptr_type 2) [rep_type_val g p0; rep_type_val g p1] (rep_type_val g p); 209 | data_at sh' (tarray int_or_ptr_type 2) [rep_type_val g p0; rep_type_val g p1] (rep_type_val g p) -* full_gc g t_info roots outlier ti sh gv). 210 | 211 | Definition args_spec_String2 : funspec := 212 | WITH g : graph, outlier: outlier_t, p : rep_type, chs: ascii*string 213 | PRE [int_or_ptr_type] 214 | PROP (is_in_graph g outlier (String (fst chs) (snd chs)) p) 215 | PARAMS (rep_type_val g p) 216 | SEP (graph_rep g) 217 | POST [ tptr int_or_ptr_type ] 218 | EX (p0 : rep_type) (p1: rep_type) (sh' : share), 219 | PROP ( writable_share sh'; 220 | is_in_graph g outlier (fst chs) p0; is_in_graph g outlier (snd chs) p1 221 | ) 222 | RETURN ( rep_type_val g p ) 223 | SEP (data_at sh' (tarray int_or_ptr_type 2) [rep_type_val g p0; rep_type_val g p1] (rep_type_val g p); 224 | data_at sh' (tarray int_or_ptr_type 2) [rep_type_val g p0; rep_type_val g p1] (rep_type_val g p) -* graph_rep g). 225 | 226 | Lemma args_spec_String_sub: 227 | funspec_sub args_spec_String2 args_spec_String. 228 | Proof. 229 | do_funspec_sub. 230 | rename g into genv. 231 | destruct w as [[[[[[[[gv g] p] chs] roots] sh] ti] outlier] t_info]. 232 | Intros. 233 | simpl in H2, H3. 234 | Exists (g,outlier,p,chs). 235 | simpl fst. simpl snd. 236 | unfold full_gc; Intros. 237 | rewrite !prop_true_andp by auto. 238 | Exists (outlier_rep outlier 239 | * before_gc_thread_info_rep sh t_info ti 240 | * ti_token_rep (ti_heap t_info) (ti_heap_p t_info) 241 | * gc_spec.all_string_constants Ers gv)%logic. 242 | apply andp_right. 243 | cancel. 244 | apply prop_right. 245 | intros. 246 | Intros p1 p2 sh'. 247 | Exists p1 p2 sh'. 248 | entailer!!. 249 | apply -> wand_sepcon_adjoint. 250 | cancel. 251 | rewrite sepcon_comm. 252 | apply modus_ponens_wand. 253 | Qed. 254 | 255 | Definition ascii_to_char_spec: ident * funspec := 256 | DECLARE _ascii_to_char 257 | WITH g: graph, outlier: outlier_t, p: rep_type, ch: ascii 258 | PRE [ int_or_ptr_type ] 259 | PROP (is_in_graph g outlier ch p) 260 | PARAMS (rep_type_val g p) 261 | SEP (graph_rep g) 262 | POST [ tuchar ] 263 | PROP() 264 | RETURN ( Vint (Int.repr (Z.of_N (N_of_ascii ch))) ) 265 | SEP (graph_rep g). 266 | 267 | 268 | Definition args_make_Coq_Init_Datatypes_String_String_spec : ident * funspec := 269 | DECLARE _get_args 270 | (args_spec_String2). 271 | 272 | Definition make_Coq_Strings_String_string_EmptyString_spec : ident * funspec := 273 | DECLARE _make_Coq_Strings_String_string_EmptyString 274 | (alloc_make_spec_general (@ctor_desc_of_val _ EmptyString _) 0). 275 | 276 | Definition alloc_make_Coq_Strings_String_string_String_spec : ident * funspec := 277 | DECLARE _alloc_make_Coq_Strings_String_string_String 278 | (alloc_make_spec_general (@ctor_desc_of_val _ String _) 2). 279 | 280 | Definition alloc_make_Coq_Strings_Ascii_ascii_Ascii_spec : ident * funspec := 281 | DECLARE _alloc_make_Coq_Strings_Ascii_ascii_Ascii 282 | (alloc_make_spec_general (@ctor_desc_of_val _ Ascii _) 8). 283 | 284 | 285 | Definition pack_spec : ident * funspec := 286 | fn_desc_to_funspec Bytestring_Proofs.pack_desc. 287 | 288 | 289 | Definition unpack_spec : ident * funspec := 290 | fn_desc_to_funspec Bytestring_Proofs.unpack_desc. 291 | 292 | Definition append_spec : ident * funspec := 293 | fn_desc_to_funspec Bytestring_Proofs.append_desc. 294 | 295 | 296 | Definition Vprog : varspecs. mk_varspecs prog. Defined. 297 | Definition Gprog := [ ascii_to_char_spec; 298 | tag_spec_string2; 299 | bump_allocptr_spec; 300 | args_make_Coq_Init_Datatypes_String_String_spec; 301 | make_Coq_Strings_String_string_EmptyString_spec; 302 | alloc_make_Coq_Strings_String_string_String_spec; 303 | alloc_make_Coq_Strings_Ascii_ascii_Ascii_spec; 304 | gc_spec.garbage_collect_spec 305 | (* _call, call_spec *) 306 | ] . 307 | -------------------------------------------------------------------------------- /generator/CtorDesc.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.ZArith.ZArith 2 | Coq.Program.Basics 3 | Coq.Strings.String 4 | Coq.Lists.List 5 | Coq.Lists.ListSet. 6 | 7 | Require Import ExtLib.Structures.Monads 8 | ExtLib.Data.Monads.OptionMonad 9 | ExtLib.Data.Monads.StateMonad 10 | ExtLib.Data.String. 11 | 12 | Require Import MetaCoq.Template.All. 13 | 14 | Require Import VeriFFI.generator.gen_utils. 15 | Require Import VeriFFI.library.base_representation. 16 | Require Import VeriFFI.library.meta. 17 | Require Import VeriFFI.generator.GraphPredicate. 18 | Require Import VeriFFI.generator.InGraph. 19 | 20 | (* Unset MetaCoq Strict Unquote Universe Mode. *) 21 | 22 | (* Require Import VeriFFI.generator.InGraph. *) 23 | (* MetaCoq Run (in_graph_gen bool). *) 24 | (* Instance InGraph_bool : InGraph bool. rep_gen. Defined. *) 25 | (* MetaCoq Run (in_graph_gen list). *) 26 | (* Instance InGraph_list : forall A, InGraph A -> InGraph (list A). rep_gen. Defined. *) 27 | (* MetaCoq Run (in_graph_gen nat). *) 28 | (* Instance InGraph_nat : InGraph nat. rep_gen. Defined. *) 29 | 30 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 31 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 32 | Import monad_utils.MCMonadNotation 33 | ListNotations 34 | MetaCoqNotations. 35 | 36 | Set Universe Polymorphism. 37 | (* Set Polymorphic Inductive Cumulativity. *) 38 | 39 | Fixpoint adjust_context (ctx : list (Kernames.ident * Reppyish)) : TemplateMonad (list (Kernames.ident * named_term)) := 40 | match ctx with 41 | | nil => ret nil 42 | | (id, None) :: xs => adjust_context xs 43 | | (id, Some (A; H)) :: xs => 44 | A' <- tmQuote A ;; 45 | xs' <- adjust_context xs ;; 46 | ret ((id, A') :: xs') 47 | end. 48 | 49 | Definition kleisli_compose {m a b c} `{Monad m} : (b -> m c) -> (a -> m b) -> (a -> m c) := 50 | fun g f x => f x >>= g. 51 | 52 | Definition fresh_aname (prefix : string) (a : aname) : TemplateMonad (Kernames.ident * aname) := 53 | let x := match binder_name a with | nAnon => prefix | nNamed i => prefix ++ i end in 54 | x' <- tmFreshName x ;; 55 | ret (x, {| binder_name := nNamed x'; binder_relevance := binder_relevance a |}). 56 | 57 | Definition fill_hole 58 | (named_ctx : list (Kernames.ident * named_term)) 59 | (goal : named_term) 60 | : TemplateMonad named_term := 61 | (* quantify all the free variables in the goal *) 62 | let quantified : global_term := 63 | fold_left 64 | (fun tm '(id, ty) => tProd (mkBindAnn (nNamed id) Relevant) ty tm) 65 | named_ctx goal in 66 | (* use primitives to infer the type class instance over the global term *) 67 | tmEval all quantified >>= tmPrint ;; 68 | hoisted <- instance_term quantified ;; 69 | (* make function application again to have the same free variables *) 70 | tmMsg "hole ctx:" ;; 71 | tmEval all named_ctx >>= tmPrint ;; 72 | let ctx_to_apps : list named_term := 73 | rev (map (fun '(id, t) => 74 | match t with 75 | | tApp (tInd {| inductive_mind := kn; inductive_ind := 0 |} _) _ => 76 | if eq_kername kn 77 | then tApp <% @field_in_graph %> [hole; tVar id] 78 | (* then tApp (tConst (MPfile ["meta"; "library"; "VeriFFI"], "field_in_graph") []) [hole; tVar id] *) 79 | else tVar id 80 | | _ => tVar id 81 | end) named_ctx) in 82 | ret (tApp hoisted ctx_to_apps). 83 | (* ret (strip_lambdas hoisted). *) 84 | (* ret (tApp hoisted (rev (map (fun '(id, _) => tVar id) named_ctx))). *) 85 | 86 | (* 87 | MetaCoq Run (fill_hole [("H", tApp <% InGraph %> [tVar "a"]);("a", <% Type %>)] 88 | (tApp <% InGraph %> [tApp <% @list %> [tVar "a"]]) >>= tmEval all >>= tmPrint). 89 | *) 90 | 91 | Polymorphic Definition create_reified 92 | (ind : inductive) 93 | (mut : mutual_inductive_body) 94 | (one : one_inductive_body) 95 | (ctor : constructor_body) : TemplateMonad (reified ctor_ann) := 96 | let cn := cstr_name ctor in 97 | let t := cstr_type ctor in 98 | let arity := cstr_arity ctor in 99 | (* We convert the constructor type to the named representation *) 100 | let init_index_ctx : list (Kernames.ident * named_term) := 101 | mapi (fun i one => (ind_name one, tInd {| inductive_mind := inductive_mind ind 102 | ; inductive_ind := i |} [])) 103 | (ind_bodies mut) in 104 | t' <- DB.undeBruijn' (map (fun '(id, _) => nNamed id) init_index_ctx) t ;; 105 | 106 | let fix go 107 | (* type of the constructor to be taken apart *) 108 | (t : named_term) 109 | (* the context kept for De Bruijn indices *) 110 | (index_ctx : list (Kernames.ident * named_term)) 111 | (* the context kept for "lambda lifting" the holes *) 112 | (named_ctx : list (Kernames.ident * named_term)) 113 | (* unprocessed number of parameters left on the type *) 114 | (num_params : nat) : TemplateMonad named_term := 115 | match t, num_params with 116 | | tProd n (tSort s as t) b , S n' => 117 | '(h, H) <- fresh_aname "H" n ;; 118 | let named_ctx' : list (Kernames.ident * named_term) := 119 | match binder_name n with 120 | | nNamed id => (h, tApp <% @InGraph %> [tVar id]) :: (id, t) :: named_ctx 121 | | _ => named_ctx end in 122 | rest <- go b index_ctx named_ctx' (pred num_params) ;; 123 | let f := tLambda n (tSort s) (tLambda H (tApp <% @ctor_ann %> [tRel O]) rest) in 124 | ret (tApp <% @TYPEPARAM ctor_ann %> [f]) 125 | 126 | | tProd n t b , O => 127 | let named_ctx' : list (Kernames.ident * named_term) := 128 | match binder_name n with 129 | | nNamed id => (id, t) :: named_ctx 130 | | _ => named_ctx end in 131 | rest <- go b index_ctx named_ctx' O ;; 132 | let t' := Substitution.named_subst_all index_ctx t in 133 | let f := tLambda n t' rest in 134 | H <- fill_hole named_ctx (tApp <% InGraph %> [t']) ;; 135 | let H' := tApp <% Build_ctor_ann %> [t'; <% present %>; H] in 136 | ret (tApp <% @ARG ctor_ann %> [t'; H'; f]) 137 | 138 | | rest , _ => 139 | let rest' := Substitution.named_subst_all index_ctx rest in 140 | H <- fill_hole named_ctx (tApp <% InGraph %> [rest']) ;; 141 | let H' := tApp <% Build_ctor_ann %> [rest'; <% present %>; H] in 142 | ret (tApp <% @RES ctor_ann %> [rest'; H']) 143 | end 144 | in 145 | 146 | let num_of_params := ind_npars mut in 147 | c <- go t' init_index_ctx [] num_of_params ;; 148 | tmMsg "after go:" ;; 149 | tmEval all c >>= tmPrint ;; 150 | c' <- DB.deBruijn c ;; 151 | (* tmMsg "after de bruijn:" ;; *) 152 | (* tmEval all c' >>= tmPrint ;; *) 153 | tmUnquoteTyped (reified ctor_ann) c'. 154 | 155 | Definition ctor_desc_gen {T : Type} (ctor_val : T) : TemplateMonad unit := 156 | t <- tmQuote ctor_val ;; 157 | match t with 158 | | tConstruct ({| inductive_mind := kn ; inductive_ind := mut_tag |} as ind) ctor_tag _ => 159 | mut <- tmQuoteInductive kn ;; 160 | 161 | match (nth_error (ind_bodies mut) mut_tag) with 162 | | None => tmFail "Impossible mutual block index" 163 | | Some one => 164 | match (nth_error (ind_ctors one) ctor_tag) with 165 | | None => tmFail "Impossible constructor index" 166 | | Some ctor => 167 | reified <- create_reified ind mut one ctor ;; 168 | (* tmPrint "after create reified" ;; *) 169 | (* tmEval all reified >>= tmPrint ;; *) 170 | 171 | newName <- tmFreshName "new"%bs ;; 172 | reflected <- tmLemma newName (@reflector ctor_ann T ctor_val reified) ;; 173 | 174 | let d := {| ctor_name := cstr_name ctor 175 | ; ctor_reified := reified 176 | ; ctor_reflected := reflected 177 | ; ctor_tag := ctor_tag 178 | ; ctor_arity := cstr_arity ctor 179 | |} in 180 | 181 | name <- tmFreshName (cstr_name ctor ++ "_desc")%bs ;; 182 | @tmDefinition name (@CtorDesc T ctor_val) {| ctor_desc_of_val := d |} ;; 183 | (* Declare the new definition a type class instance *) 184 | mp <- tmCurrentModPath tt ;; 185 | tmExistingInstance export (ConstRef (mp, name)) ;; 186 | ret tt 187 | end 188 | end 189 | | t' => tmPrint t' ;; tmFail "Not a constructor" 190 | end. 191 | 192 | Definition ctor_descs_gen {kind : Type} (Tau : kind) : TemplateMonad unit := 193 | '(env, tau) <- tmQuoteRec Tau ;; 194 | match declarations (env) with 195 | | (kn, InductiveDecl decl) :: _ => 196 | let each_ctor (mut : mutual_inductive_body) 197 | (one : one_inductive_body) 198 | (mut_type_count : nat) 199 | (ctor_count : nat) 200 | (ctor : constructor_body) : TemplateMonad unit := 201 | let ind := {| inductive_mind := kn ; inductive_ind := mut_type_count |} in 202 | t <- tmUnquote (tConstruct ind ctor_count []) ;; 203 | let '{| my_projT1 := T; my_projT2 := ctor_val |} := t in 204 | 205 | reified <- create_reified ind mut one ctor ;; 206 | (* tmPrint "after create reified" ;; *) 207 | (* tmEval all reified >>= tmPrint ;; *) 208 | 209 | newName <- tmFreshName "new"%bs ;; 210 | reflected <- tmLemma newName (@reflector ctor_ann T ctor_val reified) ;; 211 | 212 | let d := {| ctor_name := cstr_name ctor 213 | ; ctor_reified := reified 214 | ; ctor_reflected := reflected 215 | ; ctor_tag := ctor_count 216 | ; ctor_arity := cstr_arity ctor 217 | |} in 218 | 219 | name <- tmFreshName (cstr_name ctor ++ "_desc")%bs ;; 220 | @tmDefinition name (@CtorDesc T ctor_val) {| ctor_desc_of_val := d |} ;; 221 | (* Declare the new definition a type class instance *) 222 | mp <- tmCurrentModPath tt ;; 223 | tmExistingInstance export (ConstRef (mp, name)) ;; 224 | ret tt 225 | 226 | in 227 | let all_in_one (mut : mutual_inductive_body) 228 | (mut_type_count : nat) 229 | (one : one_inductive_body) : TemplateMonad unit := 230 | let ctors := ind_ctors one in 231 | monad_map_i (each_ctor mut one mut_type_count) (ind_ctors one) ;; ret tt 232 | in 233 | let all_in_mut (mut : mutual_inductive_body) : TemplateMonad unit := 234 | monad_map_i (all_in_one mut) (ind_bodies mut) ;; ret tt 235 | in 236 | all_in_mut decl 237 | | _ => tmFail "Need an inductive type in the environment" 238 | end. 239 | 240 | Local Obligation Tactic := reflecting. 241 | 242 | Ltac gen := 243 | match goal with 244 | | [ |- @reflector _ _ _ _ ] => reflecting 245 | | _ => in_graph_gen_tac 246 | end. 247 | 248 | Local Obligation Tactic := gen. 249 | 250 | Unset MetaCoq Strict Unquote Universe Mode. 251 | 252 | (* Set Universe Polymorphism. *) 253 | (* Set Polymorphic Inductive Cumulativity. *) 254 | 255 | (* MetaCoq Run (in_graph_gen option). *) 256 | (* MetaCoq Run (descs_gen option). *) 257 | (* MetaCoq Run (@desc_gen _ (@None)). *) 258 | 259 | (* MetaCoq Run (in_graph_gen unit). *) 260 | (* MetaCoq Run (descs_gen unit). *) 261 | 262 | (* MetaCoq Run (in_graph_gen nat). *) 263 | (* MetaCoq Run (descs_gen nat). *) 264 | 265 | 266 | (* MetaCoq Run (desc_gen tt). *) 267 | (* MetaCoq Run (desc_gen S). *) 268 | (* Set Printing All. *) 269 | (* Print S_desc. *) 270 | (* Check <% tt %>. *) 271 | 272 | (* MetaCoq Run (in_graph_gen unit). *) 273 | (* MetaCoq Run (desc_gen tt). *) 274 | 275 | (* (* Print new_obligation_1. *) *) 276 | (* MetaCoq Run (descs_gen unit). *) 277 | 278 | 279 | (* MetaCoq Run (in_graph_gen nat). *) 280 | (* Instance InGraph_ *) 281 | (* (* MetaCoq Run (rep_gen nat). *) *) 282 | (* MetaCoq Run (descs_gen unit). *) 283 | (* MetaCoq Run (desc_gen O). *) 284 | (* Print O_desc. *) 285 | 286 | (* MetaCoq Run (desc_gen O >>= @tmDefinition ("O_desc"%string) constructor_description). *) 287 | (* Print S_desc. *) 288 | 289 | 290 | -------------------------------------------------------------------------------- /examples/uint63nat/specs.v: -------------------------------------------------------------------------------- 1 | Require Import VeriFFI.examples.uint63nat.prog. 2 | Require Import ZArith. 3 | Require Import Psatz. 4 | Require Export VeriFFI.verification.specs_general. 5 | Require Export VeriFFI.generator.Rep. 6 | Require Export VeriFFI.generator.CtorDesc. 7 | Require Import VeriFFI.generator.Discrimination. 8 | 9 | #[export] Obligation Tactic := gen. 10 | MetaCoq Run (gen_for nat). 11 | MetaCoq Run (gen_for bool). 12 | 13 | MetaCoq Run (ctor_desc_gen S). 14 | MetaCoq Run (ctor_desc_gen O). 15 | 16 | Require Export VST.floyd.proofauto. 17 | Require Export CertiGraph.CertiGC.GCGraph. 18 | Export spatial_gcgraph. 19 | From VeriFFI Require Export library.base_representation library.meta verification.graph_add verification.specs_library. 20 | 21 | Require Export VeriFFI.examples.uint63nat.Verif_prog_general. 22 | Require Export VeriFFI.examples.uint63nat.prims. 23 | Require Export VeriFFI.examples.uint63nat.model. 24 | 25 | 26 | (* Specific alloc *) 27 | 28 | Definition alloc_make_Coq_Init_Datatypes_nat_O_spec : ident * funspec := 29 | DECLARE _make_Coq_Init_Datatypes_nat_O 30 | WITH gv : globals, g : graph, outlier: outlier_t 31 | PRE [ ] 32 | PROP () 33 | PARAMS () 34 | GLOBALS () 35 | SEP (graph_rep g) 36 | POST [ (talignas 3%N (tptr tvoid)) ] 37 | EX (x : rep_type), 38 | PROP (@is_in_graph nat _ g outlier O x) 39 | LOCAL (temp ret_temp (rep_type_val g x)) 40 | SEP (graph_rep g). 41 | 42 | (* General specifications for uint63/nat *) 43 | 44 | Definition alloc_make_Coq_Init_Datatypes_nat_S_spec : ident * funspec := 45 | DECLARE _alloc_make_Coq_Init_Datatypes_nat_S 46 | (alloc_make_spec_general (@ctor_desc_of_val _ S _) 1). 47 | 48 | Definition nat_get_desc (x : nat) : ctor_desc := 49 | match x with 50 | | O => (@ctor_desc_of_val _ O _) 51 | | S n => (@ctor_desc_of_val _ S _) 52 | end. 53 | 54 | Inductive nat_has_tag_prop : nat -> ctor_desc -> Prop := 55 | | tagO : nat_has_tag_prop O (@ctor_desc_of_val _ O _) 56 | | tagS n : nat_has_tag_prop (S n) (@ctor_desc_of_val _ S _). 57 | 58 | Definition tag_spec_S : ident * funspec := 59 | DECLARE _get_Coq_Init_Datatypes_nat_tag 60 | WITH gv : globals, g : graph, p : rep_type, 61 | x : nat, roots : roots_t, sh : share, 62 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 63 | PRE [int_or_ptr_type] 64 | PROP (@is_in_graph nat _ g outlier x p; 65 | writable_share sh ) 66 | PARAMS (rep_type_val g p) 67 | GLOBALS (gv) 68 | SEP (full_gc g t_info roots outlier ti sh gv) 69 | POST [ tulong ] 70 | (* EX (xs : args (ctor_reific (nat_get_desc x))), *) 71 | PROP ( (* 1. x has tag t and is constructed with the constructor description c. 72 | a. Tag function relating to x. 73 | b. x = ctor_real c xs (* Doesn't type as this. *) 74 | 75 | TODO: Discuss - something around this should already exist for 76 | generating general in_graph functions, and we want things to match. 77 | *) 78 | (* let c := nat_get_desc x in 79 | nat_has_tag_prop x c; *) 80 | (* let c := nat_get_desc x in 81 | let r := result (ctor_reific c) xs in 82 | @is_in_graph (projT1 r) (@in_graph (projT1 r) (projT2 r)) g (ctor_real c xs) p *) 83 | let c := nat_get_desc x in 84 | nat_has_tag_prop x c 85 | ) 86 | RETURN ( Vlong (Int64.repr (Z.of_nat (ctor_tag (nat_get_desc x)))) ) 87 | SEP (full_gc g t_info roots outlier ti sh gv). 88 | 89 | Definition args_spec_S' : funspec := 90 | WITH gv : globals, g : graph, p : rep_type, 91 | x : nat, roots : roots_t, sh : share, 92 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 93 | PRE [int_or_ptr_type] 94 | PROP (writable_share sh; 95 | is_in_graph g outlier (S x) p) 96 | PARAMS (rep_type_val g p) 97 | GLOBALS (gv) 98 | SEP (full_gc g t_info roots outlier ti sh gv) 99 | POST [ tptr int_or_ptr_type (* tarray int_or_ptr_type 1 *) ] 100 | EX (p' : rep_type) (sh' : share), 101 | PROP (writable_share sh'; 102 | is_in_graph g outlier x p') 103 | RETURN ( rep_type_val g p ) 104 | SEP (data_at sh' (tarray int_or_ptr_type 1) [rep_type_val g p'] (rep_type_val g p); 105 | data_at sh' (tarray int_or_ptr_type 1) [rep_type_val g p'] (rep_type_val g p) -* full_gc g t_info roots outlier ti sh gv). 106 | 107 | 108 | Definition args_make_Coq_Init_Datatypes_nat_S_spec : ident * funspec := 109 | DECLARE _get_args (args_spec_S'). 110 | 111 | Definition encode_Z (x : Z) : Z := x * 2 + 1. 112 | 113 | #[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined. 114 | 115 | Local Obligation Tactic := gen. 116 | MetaCoq Run (disc_gen nat). 117 | 118 | #[export] Instance Rep_conditional (A : Type) `(InGraph_A : InGraph A) 119 | `(Discrimination_A : Discrimination A) : Rep A := 120 | {| in_graph := InGraph_A ; discrimination := Discrimination_A |}. 121 | 122 | Definition uint63_to_nat_spec := fn_desc_to_funspec UInt63_Proofs.to_nat_desc. 123 | 124 | Definition uint63_to_nat_spec' : ident * funspec := 125 | DECLARE _uint63_to_nat 126 | WITH gv : globals, g : graph, roots : roots_t, sh : share, n: nat, 127 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 128 | PRE [ tptr (Tstruct _thread_info noattr ), (talignas 3%N (tptr tvoid)) ] 129 | PROP ( writable_share sh; 130 | encode_Z (Z.of_nat n) <= Int64.max_unsigned 131 | ) 132 | PARAMS (ti; Vlong (Int64.repr (encode_Z (Z.of_nat n)))) 133 | GLOBALS (gv) 134 | SEP (full_gc g t_info roots outlier ti sh gv; VST.floyd.library.mem_mgr gv) 135 | POST [ (talignas 3%N (tptr tvoid)) ] 136 | EX (p' : rep_type) (g' : graph) (t_info' : GCGraph.thread_info) (roots': roots_t), 137 | PROP (@is_in_graph nat (@in_graph nat _) g' outlier n p' ; 138 | gc_graph_iso g roots g' roots'; 139 | frame_shells_eq (ti_frames t_info) (ti_frames t_info')) 140 | RETURN (rep_type_val g' p') 141 | SEP (full_gc g' t_info' roots' outlier ti sh gv; VST.floyd.library.mem_mgr gv). 142 | 143 | Definition uint63_to_nat_no_gc_spec : ident * funspec := 144 | DECLARE _uint63_to_nat_no_gc 145 | WITH gv : globals, g : graph, roots : roots_t, sh : share, n: nat, 146 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 147 | PRE [ tptr (Tstruct _thread_info noattr ), (talignas 3%N (tptr tvoid)) ] 148 | PROP ( 2 * (Z.of_nat n) < headroom t_info ; 149 | writable_share sh; 150 | encode_Z (Z.of_nat n) <= Int64.max_unsigned 151 | ) 152 | PARAMS (ti; Vlong (Int64.repr (encode_Z (Z.of_nat n)))) 153 | GLOBALS (gv) 154 | SEP (full_gc g t_info roots outlier ti sh gv) 155 | POST [ (talignas 3%N (tptr tvoid)) ] 156 | EX (p' : rep_type) (g' : graph) (t_info' : GCGraph.thread_info), 157 | PROP (@is_in_graph nat (@in_graph nat _) g' outlier n p' ; 158 | gc_graph_iso g roots g' roots) 159 | RETURN (rep_type_val g' p') 160 | SEP (full_gc g' t_info' roots outlier ti sh gv). 161 | 162 | Definition uint63_from_nat_spec := fn_desc_to_funspec UInt63_Proofs.from_nat_desc. 163 | 164 | Definition uint63_from_nat_spec' : ident * funspec := 165 | DECLARE _uint63_from_nat 166 | WITH gv : globals, g : graph, roots : roots_t, sh : share, n: nat, p : rep_type, 167 | ti : val, outlier : outlier_t, t_info : GCGraph.thread_info 168 | PRE [ int_or_ptr_type ] 169 | PROP ( encode_Z (Z.of_nat n) <= Int64.max_signed; 170 | @is_in_graph nat (@in_graph nat _) g outlier n p ; 171 | writable_share sh) 172 | PARAMS (rep_type_val g p) 173 | GLOBALS (gv) 174 | SEP (full_gc g t_info roots outlier ti sh gv) 175 | POST [ int_or_ptr_type ] 176 | PROP () 177 | RETURN (Vlong (Int64.repr (encode_Z (Z.of_nat n)))) 178 | SEP (full_gc g t_info roots outlier ti sh gv). 179 | 180 | Definition uint63_add_spec := fn_desc_to_funspec UInt63_Proofs.add_desc. 181 | 182 | Definition uint63_add_spec' : ident * funspec := 183 | DECLARE _uint63_add 184 | WITH m : nat, n : nat 185 | PRE [ int_or_ptr_type, int_or_ptr_type ] 186 | PROP (encode_Z (Z.of_nat (m + n)) <= Int64.max_unsigned) 187 | PARAMS (Vlong (Int64.repr (encode_Z (Z.of_nat m))); 188 | Vlong (Int64.repr (encode_Z (Z.of_nat n)))) 189 | GLOBALS () 190 | SEP () 191 | POST [ int_or_ptr_type ] 192 | PROP () 193 | RETURN (Vlong (Int64.repr (encode_Z (Z.of_nat (m + n))))) 194 | SEP (). 195 | 196 | (* Function Spec 197 | 198 | - This is the definition of a Coq function from X to Y/the specification that hopefully CertiCoq 199 | should be able to guarantee. 200 | - The function specification is dependent on (representable) input and output types and a representable 201 | environment type. 202 | - The function yields the right result if given an environment. 203 | - TODO: Don't we rather want that this is... 204 | 205 | - What I changed: changed it to iso. 206 | *) 207 | 208 | Definition fun_spec X Y (In_Graph_X : InGraph X) (In_Graph_Y : InGraph Y) 209 | A (In_Graph_A : InGraph A) (env : A) (f : A -> X -> Y) : funspec := 210 | WITH 211 | (* general info on the garbage collector graph *) 212 | gv : globals, g : graph, roots : roots_t, sh : share, ti : val, 213 | outlier : outlier_t, t_info : GCGraph.thread_info, 214 | (* function-specific *) 215 | x: X, p_x : rep_type, p_env : rep_type 216 | PRE [thread_info, int_or_ptr_type, int_or_ptr_type] 217 | PROP (@is_in_graph X In_Graph_X g outlier x p_x; 218 | is_in_graph g outlier env p_env 219 | ) 220 | PARAMS (ti; rep_type_val g p_env; rep_type_val g p_x) 221 | GLOBALS (gv) 222 | SEP (full_gc g t_info roots outlier ti sh gv) 223 | POST [ int_or_ptr_type ] 224 | EX (g' : graph) (t_info' : GCGraph.thread_info) (res' : rep_type) (roots' : roots_t), 225 | PROP (@is_in_graph Y In_Graph_Y g' outlier (f env x) res'; 226 | gc_graph_iso g roots g' roots' 227 | ) 228 | RETURN (rep_type_val g' res') 229 | SEP (full_gc g' t_info' roots' outlier ti sh gv). 230 | 231 | (* This means that for any Coq function f : X -> Y, 232 | CertiCoq has to provide the above lemma for an arbitrary A, InGraph_A, env : A. 233 | *) 234 | 235 | Record closure := { 236 | src_type : Type; 237 | src_repr : InGraph src_type; 238 | trg_type : Type; 239 | trg_repr: InGraph trg_type; 240 | env_type : Type; 241 | env_repr : InGraph env_type; 242 | env : env_type; 243 | fct : env_type -> src_type -> trg_type; 244 | x : src_type (* TODO: NOT IN HERE *) 245 | }. 246 | 247 | 248 | (* Record closure X Y In_Graph_X In_Graph_Y := 249 | {A | env : A, In_Graph_A : InGraph A; 250 | f : A -> X -> Y; 251 | fun_spec X Y In_Graph_X In_Graph_Y A In_Graph_A env f}. *) 252 | 253 | 254 | (* TODO: This would mean that I have to give on the closure... *) 255 | Definition call_spec : funspec := 256 | WITH (* General graph content *) 257 | gv: globals, g : graph, roots : roots_t, sh : share, outlier : outlier_t,t_info : GCGraph.thread_info, ti : val, 258 | (* Specific to this function *) 259 | (* X_ : {X : Type | InGraph X}, (* Y : Type, InGraph_Y : InGraph Y, 260 | c: closure X Y In_Graph_X In_Graph_Y, *) 261 | x : X, *) 262 | c : closure, 263 | p_c : val, 264 | p_env : rep_type, 265 | p_x : rep_type, 266 | code_p : rep_type 267 | PRE [ thread_info, int_or_ptr_type, int_or_ptr_type ] 268 | PROP (@is_in_graph _ (src_repr c) g outlier (x c) p_x; 269 | (* is_in_graph g closure code_p; *) 270 | @is_in_graph _ (env_repr c) g outlier (env c) p_env ) 271 | PARAMS (ti; p_c; rep_type_val g p_x) 272 | GLOBALS (gv) 273 | SEP (full_gc g t_info roots outlier ti sh gv; 274 | func_ptr' (fun_spec _ _ (src_repr c) (trg_repr c) _ (env_repr c) (env c) (fct c)) (rep_type_val g code_p) 275 | ) 276 | POST [ int_or_ptr_type ] 277 | EX (g' : graph)(t_info' : GCGraph.thread_info) (p: rep_type) (roots': roots_t), 278 | PROP ( @is_in_graph _ (trg_repr c) g' outlier (fct c (env c) (x c)) p; 279 | gc_graph_iso g roots g' roots' ) 280 | RETURN (rep_type_val g p) 281 | SEP (full_gc g' t_info' roots outlier ti sh gv). 282 | 283 | Definition Vprog : varspecs. mk_varspecs prog. Defined. 284 | Definition Gprog := 285 | [ tag_spec_S 286 | ; alloc_make_Coq_Init_Datatypes_nat_O_spec; alloc_make_Coq_Init_Datatypes_nat_S_spec 287 | ; args_make_Coq_Init_Datatypes_nat_S_spec 288 | ; uint63_to_nat_spec 289 | ; uint63_from_nat_spec 290 | ; uint63_to_nat_no_gc_spec 291 | ; gc_spec.garbage_collect_spec 292 | ; uint63_add_spec 293 | (* ; call_spec *) 294 | ]. 295 | -------------------------------------------------------------------------------- /c/spec_int63.v: -------------------------------------------------------------------------------- 1 | From VST Require Import floyd.proofauto. 2 | From VeriFFI Require Import c.int63. 3 | #[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined. 4 | Definition Vprog : varspecs. mk_varspecs prog. Defined. 5 | 6 | From VeriFFI Require Import library.modelled. 7 | 8 | (* 9 | 10 | Definition encode_Z (x: Z): Z := x * 2 + 1. 11 | 12 | Module encode_Z. 13 | Definition min_signed: Z := - 2^62. 14 | Definition max_signed: Z := 2^62 - 1. 15 | 16 | Lemma bound_iff (x: Z): 17 | Int64.min_signed <= encode_Z x <= Int64.max_signed <-> min_signed <= x <= max_signed. 18 | Proof. 19 | unfold encode_Z. 20 | unfold min_signed. 21 | unfold max_signed. 22 | assert (E: Int64.min_signed = - 2^63). { reflexivity. } rewrite E in * ; clear E. 23 | assert (E: Int64.max_signed = 2^63 - 1). { reflexivity. } rewrite E in * ; clear E. 24 | constructor ; lia. 25 | Qed. 26 | 27 | Lemma bitwise (x: Z): 28 | encode_Z x = Z.lor 1 (Z.shiftl x 1). 29 | Proof. 30 | unfold encode_Z. 31 | rewrite Z.shiftl_mul_pow2 ; try lia. 32 | assert (E: 2 ^ 1 = 2). { lia. } rewrite E ; clear E. 33 | assert (E: x * 2 = 2 * x). { lia. } repeat rewrite E ; clear E. 34 | assert (E: 2 * x + 1 = 1 + 2 * x). { lia. } repeat rewrite E ; clear E. 35 | destruct x as [ | x' | x' ] ; try reflexivity. 36 | destruct x' ; try reflexivity. 37 | Qed. 38 | 39 | Lemma bound (x: Z) (H: Int64.min_signed <= encode_Z x <= Int64.max_signed): 40 | Int64.min_signed <= x <= Int64.max_signed. 41 | Proof. 42 | unfold encode_Z in *. 43 | unfold Int64.min_signed in *. 44 | unfold Int64.max_signed in *. 45 | constructor ; try lia. 46 | Qed. 47 | 48 | Lemma tight_bound (x: Z) (Hx: Int64.min_signed <= encode_Z x <= Int64.max_signed): 49 | Int64.min_signed < encode_Z x <= Int64.max_signed. 50 | Proof. 51 | constructor ; try lia. 52 | 53 | destruct Hx as [ Hx_l Hx_h ]. clear Hx_h. 54 | assert (Hx_l': Int64.min_signed < encode_Z x \/ Int64.min_signed = encode_Z x). { lia. } clear Hx_l. rename Hx_l' into Hx_l. 55 | destruct Hx_l as [ Hx_l | Hx_l ] ; try assumption. 56 | unfold encode_Z in *. 57 | 58 | assert (E: x * 2 + 1 = 1 + 2 * x). { lia. } rewrite E in * ; clear E. 59 | assert (F: Z.even Int64.min_signed = Z.even (1 + 2 * x)). { congruence. } clear Hx_l. 60 | rewrite Z.even_add_mul_2 in F. 61 | inversion F. 62 | Qed. 63 | End encode_Z. 64 | 65 | Definition certicoq_encode_int63_spec: ident * funspec := 66 | DECLARE _certicoq_encode_int63 67 | WITH x: Z, gv: globals 68 | PRE [ tlong ] 69 | PROP ( ) 70 | PARAMS (Vlong (Int64.repr x)) 71 | GLOBALS(gv) 72 | SEP ( ) 73 | POST [ tlong ] 74 | PROP ( ) 75 | RETURN (Vlong (Int64.repr (encode_Z x))) 76 | SEP ( ). 77 | 78 | Definition certicoq_decode_int63_spec: ident * funspec := 79 | DECLARE _certicoq_decode_int63 80 | WITH x: Z, gv: globals 81 | PRE [ tlong ] 82 | PROP (Int64.min_signed <= encode_Z x <= Int64.max_signed) 83 | PARAMS (Vlong (Int64.repr (encode_Z x))) 84 | GLOBALS(gv) 85 | SEP ( ) 86 | POST [ tlong ] 87 | PROP ( ) 88 | RETURN (Vlong (Int64.repr x)) 89 | SEP ( ). 90 | *) 91 | 92 | Definition tvalue := Tlong Signed noattr. 93 | Definition threadinfo := Tstruct _thread_info noattr. 94 | 95 | (* 96 | Definition certicoq_prim__int63_zero_spec: ident * funspec := 97 | DECLARE _certicoq_prim__int63_zero 98 | WITH tinfo: val 99 | PRE [ tptr threadinfo ] 100 | PROP () 101 | PARAMS ( tinfo ) 102 | GLOBALS() 103 | SEP ( ) 104 | POST [ tlong ] 105 | PROP ( ) 106 | RETURN (Vlong (Int64.repr 0)) 107 | SEP ( ). 108 | 109 | Definition certicoq_prim__int63_one_spec: ident * funspec := 110 | DECLARE _certicoq_prim__int63_one 111 | WITH tinfo: val 112 | PRE [ tptr threadinfo ] 113 | PROP () 114 | PARAMS ( tinfo ) 115 | GLOBALS() 116 | SEP ( ) 117 | POST [ tlong ] 118 | PROP ( ) 119 | RETURN (Vlong (Int64.repr 1)) 120 | SEP ( ). 121 | 122 | Definition certicoq_prim__int63_neg_spec: ident * funspec := 123 | DECLARE _certicoq_prim__int63_neg 124 | WITH x: Z, gv: globals 125 | PRE [ tlong ] 126 | PROP ( 127 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 128 | Int64.min_signed <= encode_Z (- x) <= Int64.max_signed 129 | ) 130 | PARAMS (Vlong (Int64.repr (encode_Z x))) 131 | GLOBALS(gv) 132 | SEP ( ) 133 | POST [ tlong ] 134 | PROP ( ) 135 | RETURN (Vlong (Int64.repr (encode_Z (- x)))) 136 | SEP ( ). 137 | 138 | Definition certicoq_prim__int63_abs_spec: ident * funspec := 139 | DECLARE _certicoq_prim__int63_abs 140 | WITH x: Z, gv: globals 141 | PRE [ tlong ] 142 | PROP ( 143 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 144 | Int64.min_signed <= encode_Z (- x) <= Int64.max_signed 145 | ) 146 | PARAMS (Vlong (Int64.repr (encode_Z x))) 147 | GLOBALS(gv) 148 | SEP ( ) 149 | POST [ tlong ] 150 | PROP ( ) 151 | RETURN (Vlong (Int64.repr (encode_Z (Z.abs x)))) 152 | SEP ( ). 153 | *) 154 | 155 | Import IntVerification. 156 | 157 | Definition tag63 (x: FM.t) := Vlong (Int64.repr (2*(proj1_sig x)+1)). 158 | 159 | Definition certicoq_prim__int63_add_spec: ident * funspec := 160 | DECLARE _certicoq_prim__int63_add 161 | WITH tinfo: val, x: FM.t, y:FM.t 162 | PRE [ tptr threadinfo, tlong, tlong ] 163 | PROP () 164 | PARAMS (tinfo; tag63 x; tag63 y) 165 | GLOBALS() 166 | SEP ( ) 167 | POST [ tlong ] 168 | PROP ( ) 169 | RETURN (tag63 (FM.add x y)) 170 | SEP ( ). 171 | 172 | (* 173 | Definition certicoq_prim__int63_sub_spec: ident * funspec := 174 | DECLARE _certicoq_prim__int63_add 175 | WITH x: FM.t, y:FM.t 176 | PRE [ tlong, tlong ] 177 | PROP () 178 | PARAMS (tag63 x; tag63 y) 179 | GLOBALS() 180 | SEP ( ) 181 | POST [ tlong ] 182 | PROP ( ) 183 | RETURN (tag63 (FMs.sub x y)) 184 | SEP ( ). 185 | *) 186 | 187 | Definition certicoq_prim__int63_mul_spec: ident * funspec := 188 | DECLARE _certicoq_prim__int63_mul 189 | WITH tinfo: val, x: FM.t, y:FM.t 190 | PRE [ tptr threadinfo, tlong, tlong ] 191 | PROP () 192 | PARAMS (tinfo; tag63 x; tag63 y) 193 | GLOBALS() 194 | SEP ( ) 195 | POST [ tlong ] 196 | PROP ( ) 197 | RETURN (tag63 (FM.mul x y)) 198 | SEP ( ). 199 | (* 200 | 201 | Definition certicoq_prim__int63_div_spec: ident * funspec := 202 | DECLARE _certicoq_prim__int63_div 203 | WITH x: Z, y: Z, gv: globals 204 | PRE [ tlong, tlong ] 205 | PROP ( 206 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 207 | Int64.min_signed <= encode_Z y <= Int64.max_signed; 208 | y <> 0 209 | ) 210 | PARAMS ( 211 | Vlong (Int64.repr (encode_Z x)); 212 | Vlong (Int64.repr (encode_Z y)) 213 | ) 214 | GLOBALS(gv) 215 | SEP ( ) 216 | POST [ tlong ] 217 | PROP ( ) 218 | RETURN (Vlong (Int64.repr (encode_Z (Z.quot x y)))) 219 | SEP ( ). 220 | 221 | Definition certicoq_prim__int63_rem_spec: ident * funspec := 222 | DECLARE _certicoq_prim__int63_rem 223 | WITH x: Z, y: Z, gv: globals 224 | PRE [ tlong, tlong ] 225 | PROP ( 226 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 227 | Int64.min_signed <= encode_Z y <= Int64.max_signed; 228 | y <> 0 229 | ) 230 | PARAMS ( 231 | Vlong (Int64.repr (encode_Z x)); 232 | Vlong (Int64.repr (encode_Z y)) 233 | ) 234 | GLOBALS(gv) 235 | SEP ( ) 236 | POST [ tlong ] 237 | PROP ( ) 238 | RETURN (Vlong (Int64.repr (encode_Z (Z.rem x y)))) 239 | SEP ( ). 240 | 241 | Definition certicoq_prim__int63_shiftl_spec: ident * funspec := 242 | DECLARE _certicoq_prim__int63_shiftl 243 | WITH x: Z, y: Z, gv: globals 244 | PRE [ tlong, tlong ] 245 | PROP ( 246 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 247 | Int64.min_signed <= encode_Z y <= Int64.max_signed; 248 | 0 <= x; 249 | 0 <= y < Int64.zwordsize 250 | ) 251 | PARAMS ( 252 | Vlong (Int64.repr (encode_Z x)); 253 | Vlong (Int64.repr (encode_Z y)) 254 | ) 255 | GLOBALS(gv) 256 | SEP ( ) 257 | POST [ tlong ] 258 | PROP ( ) 259 | RETURN (Vlong (Int64.repr (encode_Z (Z.shiftl x y)))) 260 | SEP ( ). 261 | 262 | Definition certicoq_prim__int63_shiftr_spec: ident * funspec := 263 | DECLARE _certicoq_prim__int63_shiftr 264 | WITH x: Z, y: Z, gv: globals 265 | PRE [ tlong, tlong ] 266 | PROP ( 267 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 268 | Int64.min_signed <= encode_Z y <= Int64.max_signed; 269 | 0 <= y < Int64.zwordsize 270 | ) 271 | PARAMS ( 272 | Vlong (Int64.repr (encode_Z x)); 273 | Vlong (Int64.repr (encode_Z y)) 274 | ) 275 | GLOBALS(gv) 276 | SEP ( ) 277 | POST [ tlong ] 278 | PROP ( ) 279 | RETURN (Vlong (Int64.repr (encode_Z (Z.shiftr x y)))) 280 | SEP ( ). 281 | 282 | Definition certicoq_prim__int63_or_spec: ident * funspec := 283 | DECLARE _certicoq_prim__int63_or 284 | WITH x: Z, y: Z, gv: globals 285 | PRE [ tlong, tlong ] 286 | PROP ( 287 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 288 | Int64.min_signed <= encode_Z y <= Int64.max_signed 289 | ) 290 | PARAMS ( 291 | Vlong (Int64.repr (encode_Z x)); 292 | Vlong (Int64.repr (encode_Z y)) 293 | ) 294 | GLOBALS(gv) 295 | SEP ( ) 296 | POST [ tlong ] 297 | PROP ( ) 298 | RETURN (Vlong (Int64.repr (encode_Z (Z.lor x y)))) 299 | SEP ( ). 300 | 301 | Definition certicoq_prim__int63_and_spec: ident * funspec := 302 | DECLARE _certicoq_prim__int63_and 303 | WITH x: Z, y: Z, gv: globals 304 | PRE [ tlong, tlong ] 305 | PROP ( 306 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 307 | Int64.min_signed <= encode_Z y <= Int64.max_signed 308 | ) 309 | PARAMS ( 310 | Vlong (Int64.repr (encode_Z x)); 311 | Vlong (Int64.repr (encode_Z y)) 312 | ) 313 | GLOBALS(gv) 314 | SEP ( ) 315 | POST [ tlong ] 316 | PROP ( ) 317 | RETURN (Vlong (Int64.repr (encode_Z (Z.land x y)))) 318 | SEP ( ). 319 | 320 | Definition certicoq_prim__int63_xor_spec: ident * funspec := 321 | DECLARE _certicoq_prim__int63_xor 322 | WITH x: Z, y: Z, gv: globals 323 | PRE [ tlong, tlong ] 324 | PROP ( 325 | Int64.min_signed <= encode_Z x <= Int64.max_signed; 326 | Int64.min_signed <= encode_Z y <= Int64.max_signed 327 | ) 328 | PARAMS ( 329 | Vlong (Int64.repr (encode_Z x)); 330 | Vlong (Int64.repr (encode_Z y)) 331 | ) 332 | GLOBALS(gv) 333 | SEP ( ) 334 | POST [ tlong ] 335 | PROP ( ) 336 | RETURN (Vlong (Int64.repr (encode_Z (Z.lxor x y)))) 337 | SEP ( ). 338 | 339 | Definition certicoq_prim__int63_not_spec: ident * funspec := 340 | DECLARE _certicoq_prim__int63_not 341 | WITH x: Z, gv: globals 342 | PRE [ tlong ] 343 | PROP (Int64.min_signed <= encode_Z x <= Int64.max_signed) 344 | PARAMS (Vlong (Int64.repr (encode_Z x))) 345 | GLOBALS(gv) 346 | SEP ( ) 347 | POST [ tlong ] 348 | PROP ( ) 349 | RETURN (Vlong (Int64.repr (encode_Z (Z.lnot x)))) 350 | SEP ( ). 351 | *) 352 | 353 | 354 | Definition ASI: funspecs := [ 355 | (* 356 | certicoq_decode_int63_spec; 357 | certicoq_encode_int63_spec; 358 | certicoq_prim__int63_zero_spec; 359 | certicoq_prim__int63_one_spec; 360 | certicoq_prim__int63_neg_spec; 361 | certicoq_prim__int63_abs_spec; 362 | *) 363 | certicoq_prim__int63_add_spec; 364 | (* 365 | certicoq_prim__int63_sub_spec; 366 | *) 367 | certicoq_prim__int63_mul_spec 368 | (* 369 | certicoq_prim__int63_div_spec; 370 | certicoq_prim__int63_rem_spec; 371 | certicoq_prim__int63_shiftl_spec; 372 | certicoq_prim__int63_shiftr_spec; 373 | certicoq_prim__int63_or_spec; 374 | certicoq_prim__int63_and_spec; 375 | certicoq_prim__int63_xor_spec; 376 | certicoq_prim__int63_not_spec 377 | *) 378 | ]. 379 | 380 | -------------------------------------------------------------------------------- /library/meta.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.ZArith.ZArith 2 | Coq.Program.Basics 3 | Coq.Lists.List 4 | Coq.Lists.ListSet. 5 | 6 | Require Import ExtLib.Structures.Monads 7 | ExtLib.Data.Monads.OptionMonad 8 | ExtLib.Data.Monads.StateMonad. 9 | 10 | Require Import VeriFFI.library.base_representation. 11 | 12 | (* Warning: MetaCoq doesn't use the Monad notation from ExtLib, 13 | therefore don't expect ExtLib functions to work with TemplateMonad. *) 14 | Import ListNotations. 15 | 16 | From VeriFFI Require Export verification.graph_add. 17 | Require Import CertiGraph.CertiGC.GCGraph. 18 | 19 | Notation " ( x ; p ) " := (existT _ x p). 20 | 21 | (* Set Universe Polymorphism. *) 22 | (* Set Polymorphic Inductive Cumulativity. *) 23 | 24 | Definition roots_rep_type (p : rep_type) : root_t := 25 | match p with 26 | | repZ z => inl (inl z) 27 | | repOut p => inl (inr p) 28 | | repNode v => (inr v) 29 | end. 30 | 31 | Definition lift vmap p := 32 | match p with 33 | | repNode v' => repNode (vmap v') 34 | | _ => p 35 | end. 36 | 37 | Definition reachable_p (g : LGraph) roots p' := match p' with 38 | | repNode v' => 39 | path_lemmas.reachable_through_set (graph_model.pg_lg g) 40 | (List_ext.filter_sum_right (map roots_rep_type roots)) v' 41 | | _ => True 42 | end. 43 | 44 | (* The type class to describe how a Coq type is represented in the CertiCoq heap graph. 45 | We also have some lemmas about this representation as a part of the type class. *) 46 | (* GraphPredicate is only for internal use, just to make automatic generation easier *) 47 | Class GraphPredicate (A : Type) := 48 | { graph_predicate : graph -> outlier_t -> A -> rep_type -> Prop }. 49 | Class InGraph (A : Type) : Type := 50 | { in_graph_pred : GraphPredicate A 51 | ; has_v : 52 | forall (g : graph) outliers (n : A) (v : VType), graph_predicate g outliers n (repNode v) -> graph_has_v g v 53 | ; is_monotone : 54 | forall (g : graph) outliers (to : nat) (lb : raw_vertex_block) 55 | (e : list (EType * (VType * VType))) (n : A) (p : rep_type), 56 | add_node_compatible g (new_copied_v g to) e -> 57 | graph_has_gen g to -> graph_predicate g outliers n p -> graph_predicate (add_node g to lb e) outliers n p 58 | ; outlier_compat: forall (g: graph) outliers (x: A) (p: GC_Pointer) , 59 | outlier_compatible g outliers -> 60 | graph_predicate g outliers x (repOut p) -> 61 | In p outliers 62 | ; gc_preserved: 63 | forall g g' roots roots' p n outliers, 64 | gc_correct.sound_gc_graph g -> gc_correct.sound_gc_graph g' 65 | -> no_dangling_dst g 66 | -> graph_predicate g outliers n p 67 | -> reachable_p g roots p -> 68 | forall vmap12 vmap21 emap12 emap21, 69 | roots' = map (root_map vmap12) (map roots_rep_type roots) -> 70 | graph_isomorphism.label_preserving_graph_isomorphism_explicit 71 | (subgraph2.reachable_sub_labeledgraph g (List_ext.filter_sum_right (map roots_rep_type roots))) 72 | (subgraph2.reachable_sub_labeledgraph g' (List_ext.filter_sum_right roots')) vmap12 vmap21 emap12 73 | emap21 -> 74 | graph_predicate g' outliers n (lift vmap12 p) 75 | }. 76 | 77 | Definition is_in_graph {A : Type} `{IA : InGraph A} : graph -> outlier_t -> A -> rep_type -> Prop := 78 | @graph_predicate A (@in_graph_pred A IA). 79 | 80 | #[export] Instance GraphPredicate_Prop : GraphPredicate Prop := 81 | {| graph_predicate g outliers x p := graph_cRep g p (enum 0) [] |}. 82 | #[export] Instance GraphPredicate_Set : GraphPredicate Set := 83 | {| graph_predicate g outliers x p := graph_cRep g p (enum 0) [] |}. 84 | #[export] Instance GraphPredicate_Type : GraphPredicate Type := 85 | {| graph_predicate g outliers x p := graph_cRep g p (enum 0) [] |}. 86 | 87 | #[export] Instance InGraph_Prop : InGraph Prop. 88 | Proof. 89 | refine (@Build_InGraph _ _ _ _ _ _). 90 | intros; simpl in *. intuition. induction p; intuition. 91 | intuition auto with *. intros. destruct p; simpl in *; eauto. 92 | Defined. 93 | #[export] Instance InGraph_Set : InGraph Set. 94 | Proof. 95 | refine (@Build_InGraph _ _ _ _ _ _). 96 | intros; simpl in *. intuition. induction p; intuition. 97 | intuition auto with *. intros. destruct p; simpl in *; eauto. 98 | Defined. 99 | #[export] Instance InGraph_Type : InGraph Type. 100 | Proof. 101 | refine (@Build_InGraph _ _ _ _ _ _). 102 | intros; simpl in *. intuition. induction p; intuition. 103 | intuition auto with *. intros. destruct p; simpl in *; eauto. 104 | Defined. 105 | 106 | Definition GraphPredicate_fun (A B : Type) : GraphPredicate (A -> B) := 107 | Build_GraphPredicate _ (fun g outliers f p => 108 | match p with 109 | | repOut q => In q outliers (* Is this all we need here? *) 110 | | _ => False 111 | end). 112 | 113 | #[export] Definition InGraph_fun {A B : Type} `{InGraph A} `{InGraph B} : InGraph (A -> B). 114 | Proof. 115 | apply (Build_InGraph _ (GraphPredicate_fun A B)). 116 | - intros. contradiction H1. 117 | - intros. destruct p; try contradiction. apply H3. 118 | - intros. apply H2. 119 | - intros. destruct p; simpl in *; eauto. 120 | Defined. 121 | 122 | (* This is an unprovable but useful predicate about 123 | a Coq value being in the heap graph. 124 | Unprovable because it requires proving False. 125 | Useful because traversing HOAS-style annotations 126 | (like reified and annotated) requires a InGraph instance. 127 | However, make sure you don't declare these as global instances. 128 | They should only be available in cases like this. *) 129 | Theorem GraphPredicate_any : forall {A : Type}, GraphPredicate A. 130 | Proof. 131 | intros. constructor. exact (fun g _ x p => False). 132 | Defined. 133 | Theorem InGraph_any : forall {A : Type}, InGraph A. 134 | Proof. 135 | intros. 136 | unshelve econstructor. 137 | apply GraphPredicate_any. 138 | all: intros; simpl in *; contradiction. 139 | Defined. 140 | 141 | (* Explain why we have type specific defs and proofs computed by tactics/metaprograms, instead of going from a deep embedded type desc to the proofs. *) 142 | 143 | (* The type to represent a constructor in an inductive data type. 144 | The name [reified] stands for "reified inductive constructor". 145 | Notice how this type uses Gallina binders, 146 | it is a weak HOAS description of the constructor. *) 147 | (* What other examples of cls are there? *) 148 | Inductive reified (ann : Type -> Type) : Type := 149 | (* the type parameters in parametric polymorphism, isn't represented immediately in memory, 150 | but the possibility for representation is needed later, e.g., A in [list A] *) 151 | | TYPEPARAM : (forall (A : Type) `{ann A}, reified ann) -> reified ann 152 | (* dependent argument, represented in memory, e.g. in positive_nat_list *) 153 | | ARG : forall (A : Type) `{ann A}, (A -> reified ann) -> reified ann 154 | (* the end type, e.g., list X for cons : forall X, X -> list X -> **list X** *) 155 | | RES : forall (A : Type) `{ann A}, reified ann. 156 | 157 | (* Makes nested sigmas (i.e. dependent tuples) of all the arguments. *) 158 | Fixpoint args {cls : Type -> Type} (c : reified cls) : Type := 159 | match c with 160 | | TYPEPARAM f => {A : Type & {H : cls A & args (f A H)}} 161 | | ARG A H f => {a : A & args (f a)} 162 | | RES _ _ => unit 163 | end. 164 | 165 | (* Instance of result type *) 166 | Fixpoint result {cls : Type -> Type} (c : reified cls) (xs : args c) : {A : Type & cls A} := 167 | match c as l return (args l -> {A : Type & cls A}) with 168 | | TYPEPARAM f => fun P => let '(a; (h; rest)) := P in result (f a h) rest 169 | | ARG A H f => fun P => let '(a; rest) := P in result (f a) rest 170 | | RES A H => fun _ => (A; H) 171 | end xs. 172 | 173 | (* some things are computationally irrelevant but still present at computational time *) 174 | Variant erasure := erased | present. 175 | 176 | Class ctor_ann (A : Type) : Type := 177 | { is_erased : erasure 178 | ; field_in_graph : InGraph A 179 | }. 180 | 181 | (* Makes a Coq level constructor type from a [reified], with the new type 182 | taking a nested dependent tuple instead of curried arguments. *) 183 | Definition reflect {cls : Type -> Type} (c : reified cls) : Type := 184 | forall (P : args c), 185 | projT1 (result c P). 186 | 187 | (* The same thing as [reflect] but takes the actual constructor 188 | as an argument but "ignores" it. In reality that argument is 189 | used by the tactic to infer how to reflect. *) 190 | Definition reflector {cls : Type -> Type} {T : Type} (x : T) (c : reified cls) := 191 | reflect c. 192 | 193 | Ltac destruct_through C := 194 | match goal with 195 | | [P : (@sigT (_ _) _) |- _ ] => 196 | destruct P; destruct_through C 197 | | [P : (@sigT _ _) |- _ ] => 198 | let a := fresh "a" in destruct P as [a]; 199 | destruct_through constr:(C a) 200 | | [P : (@prod _ _) |- _ ] => 201 | let a := fresh "a" in destruct P as [a]; 202 | let C' := constr:(C a) in 203 | destruct_through constr:(C a) 204 | | [P : unit |- _ ] => exact C 205 | end. 206 | 207 | Ltac reflecting_aux C := 208 | let P := fresh "P" in 209 | intro P; 210 | simpl in P; 211 | destruct_through C. 212 | 213 | (* The entry point to the tactic that solves 214 | goals like [reflector S S_reified]. *) 215 | Ltac reflecting := 216 | match goal with 217 | | [ |- @reflector _ _ ?C _ ] => hnf; reflecting_aux C 218 | end. 219 | 220 | (* EXAMPLES *) 221 | (* 222 | Instance Rep_unit : Rep unit. 223 | constructor. intros. exact True. Defined. 224 | Instance Rep_nat : Rep nat. 225 | constructor. intros. exact True. Defined. 226 | Instance Rep_list : forall A : Type, Rep A -> Rep (list A). 227 | intros. constructor. intros. exact True. Defined. 228 | 229 | Inductive vec (A : Type) : nat -> Type := 230 | | vnil : vec A 0 231 | | vcons : forall n : nat, A -> vec A n -> vec A (S n). 232 | 233 | Check <%% vec %%>. 234 | Instance Rep_vec : forall (A : Type) (n : nat), Rep A -> Rep (vec A n). 235 | intros. constructor. intros. exact True. Defined. 236 | 237 | Definition S_reified : reified := 238 | @ARG nat Rep_nat (@RES nat Rep_nat). 239 | Set Printing Universes. 240 | 241 | Inductive plist (A : Type) := 242 | | pnil : plist A 243 | | pcons : A -> plist A -> plist A. 244 | Check <%% plist %%>. 245 | Cumulative Inductive pprod (A B : Type) := 246 | | ppair : A -> B -> pprod A B. 247 | Check <%% @pprod %%>. 248 | Check tSort. 249 | 250 | Instance Rep_plist (A : Type) (Rep_A : Rep A) : Rep (plist A) := 251 | {| rep _ _ _ := False |}. 252 | 253 | Definition pcons_reified : reified := 254 | @TYPEPARAM (fun A H => 255 | @ARG A H 256 | (@ARG (plist A) (Rep_plist A H) 257 | (@RES (plist A) (Rep_plist A H)))). 258 | 259 | Definition pcons' : reflector (@pcons) pcons_reified. 260 | reflecting. Defined. 261 | Print pcons'. 262 | 263 | Check <% 264 | @TYPEPARAM (fun A H => 265 | @ARG A H 266 | (@ARG (plist A) (Rep_plist A H) 267 | (@RES (plist A) (Rep_plist A H)))) %>. 268 | 269 | 270 | Definition cons_reified : reified := 271 | @TYPEPARAM (fun A H => 272 | @ARG A H 273 | (@ARG (list A) (Rep_list A H) 274 | (@RES (list A) (Rep_list A H)))). 275 | 276 | Compute reflector (@cons) cons_reified. 277 | Goal reflector (@cons) cons_reified. 278 | reflecting. Defined. 279 | 280 | Inductive two (A : Type) : Type := 281 | | mkTwo : A -> A -> two A. 282 | 283 | Definition Rep_two : forall (A : Type), Rep A -> Rep (two A). 284 | intros. constructor. intros. exact True. Defined. 285 | Existing Instance Rep_two. 286 | 287 | Definition mkTwo_reified : reified := 288 | @TYPEPARAM (fun A H => 289 | @ARG A H (@ARG A H (@RES (two A) (Rep_two A H)))). 290 | 291 | Goal reflector mkTwo mkTwo_reified. 292 | reflecting. Defined. 293 | 294 | Definition vnil_reified : reified := 295 | @TYPEPARAM (fun A H => 296 | (@RES (vec A O) (Rep_vec A O H))). 297 | 298 | Goal (reflector vnil). 299 | reflecting. Defined. 300 | 301 | Definition vcons_reified : reified := 302 | @TYPEPARAM (fun A H => 303 | @INDEX nat Rep_nat (fun n => 304 | @ARG A H (@ARG (vec A n) (Rep_vec A n H) 305 | (@RES (vec A (S n)) (Rep_vec A (S n) H))))). 306 | 307 | Goal (reflector vcons vcons_reified). 308 | reflecting. Defined. 309 | 310 | Check <%% vec %%>. 311 | 312 | *) 313 | 314 | (* GENERATION *) 315 | Require Import MetaCoq.Template.All. 316 | Require Import MetaCoq.Utils.MCString. 317 | Record ctor_desc := 318 | { ctor_name : MCString.string 319 | ; ctor_reified : reified ctor_ann 320 | ; ctor_reflected : reflect ctor_reified 321 | ; ctor_tag : nat 322 | ; ctor_arity : nat 323 | }. 324 | 325 | Class CtorDesc {T : Type} (ctor_val : T) := 326 | { ctor_desc_of_val : ctor_desc 327 | (* Think about an addition like the following: *) 328 | (* ; proof : ctor_val = curry ctor_real *) 329 | }. 330 | 331 | Require Import JMeq. 332 | 333 | (* pattern match class? *) 334 | Class Discrimination (A : Type) := 335 | { get_ctor_desc : forall (x : A), 336 | { c : ctor_desc & 337 | { y : args (ctor_reified c) & 338 | JMeq (ctor_reflected c y) x } } 339 | }. 340 | 341 | (* 342 | Definition Descs_nat : Descs nat. 343 | Proof. 344 | constructor. 345 | intros x. 346 | case x. 347 | exists (@desc _ O _). exists tt. auto. 348 | exists (@desc _ S _). exists (n; tt). auto. 349 | Defined. 350 | *) 351 | 352 | Class Rep (A : Type) := 353 | { in_graph : InGraph A 354 | ; discrimination : Discrimination A 355 | }. 356 | 357 | #[export] Instance Rep_implied 358 | (A : Type) 359 | `(InGraph_A : InGraph A) 360 | `(Discrimination_A : Discrimination A) : Rep A := 361 | {| in_graph := InGraph_A 362 | ; discrimination := Discrimination_A 363 | |}. 364 | 365 | Definition Reppyish := option ({A : Type & Rep A}). --------------------------------------------------------------------------------