├── .dockerignore ├── .github └── workflows │ └── main.yml ├── .gitignore ├── Dockerfile ├── LICENSE ├── Readme.md ├── Readme.pdf ├── aec.sh ├── container-install.sh └── src ├── coqjit ├── .gitignore ├── BUILD.md ├── Makefile ├── Readme.md ├── _CoqProject ├── _tags ├── assume_insertion.v ├── assume_insertion_delay.v ├── assume_insertion_delay_proof.v ├── assume_insertion_proof.v ├── backend │ ├── native.ml │ ├── native_llvm.ml │ └── native_prim.ml ├── common.v ├── const_prop.v ├── const_prop_proof.v ├── conv.ml ├── def_regs.v ├── experiments.sh ├── extract.v ├── flags.ml ├── framestate_insertion.v ├── framestate_insertion_proof.v ├── frontend │ ├── frontend.ml │ ├── lua_lexer.mll │ ├── lua_parser.mly │ └── lua_syntax.ml ├── inlining.v ├── inlining_proof.v ├── internal_simulations.v ├── interpreter.v ├── interpreter_proof.v ├── ir_properties.v ├── jit.ml.patch ├── jit.mli.patch ├── jit.v ├── jit_proof.v ├── lib │ ├── Axioms.v │ ├── Behaviors.v │ ├── Camlcoq.ml │ ├── Coqlib.v │ ├── Heaps.v │ ├── Iteration.v │ ├── Kildall.v │ ├── Lattice.v │ ├── Maps.v │ ├── Ordered.v │ ├── Smallstep.v │ ├── Wfsimpl.v │ ├── events.v │ └── values.v ├── liveness.v ├── lowering.v ├── lowering_proof.v ├── main.ml ├── memory.ml ├── myocamlbuild.ml ├── opam ├── optimizer.v ├── optimizer_proof.v ├── params.ml ├── parsing │ ├── ast.ml │ ├── lexer.mll │ └── parser.mly ├── printer.ml ├── profiler.ml ├── profiler_types.v ├── progs_lua │ ├── binsearch.lua │ ├── bubble_sort.lua │ ├── example1.lua │ ├── fail.lua │ ├── fib.lua │ ├── fib2.lua │ ├── first.lua │ ├── gnome_sort.lua │ ├── if_then.lua │ ├── loop.lua │ ├── printing.lua │ ├── scopes.lua │ ├── spec.lua │ ├── spec_fail.lua │ ├── spec_pos.lua │ └── table.lua ├── progs_specIR │ ├── constprop.specir │ ├── inline2.specir │ ├── native_test.specir │ ├── native_test2.specir │ └── test.specir ├── specIR.v ├── test.sh └── test_optim.ml └── native_lib ├── .gitignore ├── Makefile └── native_lib.c /.dockerignore: -------------------------------------------------------------------------------- 1 | src/coqjit/*.vo 2 | src/coqjit/*.vok 3 | src/coqjit/*.vos 4 | src/coqjit/*.glob 5 | src/coqjit/*.aux 6 | src/coqjit/.depend 7 | src/coqjit/_build/ 8 | src/coqjit/extraction/ 9 | src/coqjit/jit 10 | src/coqjit/test_optim 11 | src/native_lib/*.o 12 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Create Artifact 2 | on: 3 | push: {} 4 | release: 5 | types: 6 | - created 7 | 8 | jobs: 9 | 10 | build-image: 11 | name: Build and push docker image 12 | runs-on: ubuntu-latest 13 | steps: 14 | - name: Checkout 15 | uses: actions/checkout@v2 16 | - name: Build 17 | run: docker build . --file Dockerfile --tag coqjit 18 | - name: Test 19 | run: docker run coqjit 20 | - name: Login 21 | env: 22 | QUAY_PW: ${{ secrets.QUAY_PW }} 23 | if: ${{ github.event_name == 'release' }} 24 | run: echo $QUAY_PW | docker login quay.io -u corejit --password-stdin 25 | - name: Push 26 | if: ${{ github.event_name == 'release' }} 27 | run: docker tag coqjit quay.io/corejit/jit:${{ github.sha }} && docker push quay.io/corejit/jit:${{ github.sha }} 28 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | archive/coq_jit.tar.gz 3 | clang+llvm-9.0.0-x86_64-pc-linux-gnu.tar.xz 4 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:4.09 2 | 3 | ADD https://releases.llvm.org/9.0.0/clang+llvm-9.0.0-x86_64-pc-linux-gnu.tar.xz /tmp/ 4 | ADD src /home/opam/ 5 | 6 | ADD container-install.sh /home/opam/ 7 | RUN "/home/opam/container-install.sh" 8 | 9 | ADD aec.sh /home/opam/ 10 | CMD ["/home/opam/aec.sh"] 11 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: CoreJIT 3 | author: 4 | - Aurèle Barrière 5 | - Sandrine Blazy 6 | - Olivier Flückiger 7 | - David Pichardie 8 | - Jan Vitek 9 | --- 10 | Also includes some work done by Roméo La Spina (liveness analysis + more general inlining). 11 | This is the development of CoreJIT, a verified JIT compiler. 12 | This document contains an overview of the code and build instructions. 13 | 14 | ## Running CoreJIT 15 | 16 | This artifact comes with a prebuilt version of CoreJIT packaged as an OCI compliant container. 17 | To follow these instructions you need to install a container runtime, such as `docker` or `podman`. 18 | To follow the local build instructions in the end, you need `opam` installed. 19 | 20 | To run this artifact it suffices to run: 21 | 22 | ``` 23 | CR=docker # or podman 24 | VS=90bd61a3e99a3fae1c78d62c60bd69b8d742e485 25 | RG=quay.io/corejit/jit 26 | $CR run $RG:$VS 27 | ``` 28 | 29 | The final submission of this artifact will include a copy of the container which can be imported using `$CR load < image.tgz`. 30 | 31 | This container by default executes the `aec.sh` script, which compiles the proofs, runs all tests and the performance experiments. 32 | 33 | There are a number of example programs in CoreJITs IR format in `progs_specIR`. To run one of these programs do the following: 34 | 35 | ``` 36 | $CR run $RG:$VS bash -c "~/coqjit/jit ~/coqjit/progs_specIR/constprop.specir" 37 | ``` 38 | 39 | To get the list of options use 40 | 41 | ``` 42 | $CR run $RG:$VS bash -c "~/coqjit/jit -help" 43 | ``` 44 | 45 | There are a number of lua programs in `progs_lua`. To run one of these programs do the following: 46 | 47 | ``` 48 | $CR run $RG:$VS bash -c "~/coqjit/jit -f ~/coqjit/progs_lua/scopes.lua" 49 | ``` 50 | 51 | To run these steps with the native backend enabled additionally pass the `-n` flag. 52 | 53 | 54 | ### Reproducing performance numbers 55 | 56 | ``` 57 | $CR run $RG:$VS bash -c "~/coqjit/experiments.sh 10" 58 | ``` 59 | 60 | ## Building CoreJIT 61 | 62 | The container of this artifact includes build dependencies and source. 63 | 64 | To edit and build inside the container use: 65 | 66 | ``` 67 | $CR run -it $RG:$VS bash 68 | # Then in the container: 69 | cd ~/coqjit 70 | make clean 71 | vim .... # edit some files 72 | make 73 | ``` 74 | 75 | To build the sources from this repository from your host filesystem inside the container: 76 | 77 | ``` 78 | $CR run -v $PWD/src:/home/opam/src -it $RG:$VS bash 79 | # Then in the container 80 | cd ~/src/coqjit 81 | make 82 | ``` 83 | 84 | ### Building the Container 85 | 86 | This artifact also includes a `Dockerfile` to build the container using: 87 | 88 | ``` 89 | docker build . --file Dockerfile 90 | ``` 91 | 92 | The interesting steps are to be found in the `docker-install.sh` script. 93 | 94 | Alternatively and optionally CoreJIT can be built without docker on any system with `opam` as follows: 95 | 96 | ``` 97 | cd src/coqjit 98 | wget https://releases.llvm.org/9.0.0/clang+llvm-9.0.0-x86_64-pc-linux-gnu.tar.xz 99 | tar xf clang+llvm-9.0.0-x86_64-pc-linux-gnu.tar.xz 100 | PATH="$PATH:$PWD/clang+llvm-9.0.0-x86_64-pc-linux-gnu/bin" 101 | make install-deps 102 | eval $(opam env) 103 | make 104 | ``` 105 | 106 | ## CoreJIT code overview 107 | 108 | This section details the different components of CoreJIT. 109 | Some definitions have been renamed in the submission. 110 | Here are their equivalent: 111 | 112 | - CoreIR <-> `SpecIR` 113 | - core_sem <-> `specir_sem` 114 | - Anchor <-> `Framestate` 115 | 116 | ### Coq Development 117 | 118 | The `src/coqjit` directory contains the Coq development for CoreJIT, operating on CoreIR, our intermediate representation for speculative optimizations and deoptimizations. 119 | CoreIR syntax and semantics are defined in `specIR.v`. 120 | 121 | The JIT step that is looped during JIT execution is defined in `jit.v`. 122 | This either calls a CoreIR interpreter `interpreter.v` or a dynamic optimizer `optimizer.v` 123 | The different passes of the dynamic optimizer are in separate files (`const_prop.v, inlining.v`...). 124 | 125 | Our developpment uses a few Coq libraries from CompCert. These are located in `src/coqjit/lib`. 126 | 127 | ### Coq Proofs 128 | 129 | Our final Semantic Preservation Theorem is proved in `jit_proof.v`. 130 | Each file ending in `_proof.v` contains the correctness proof of a CoreJIT component. 131 | The Internal Simulation Framework for Dynamic Optimizations is located in `internal_simulations.v`. 132 | 133 | ### Extraction 134 | 135 | The Coq development is extracted to OCaml as specified by the `extract.v` file. 136 | This creates an `extraction` directory where the extracted code is located. 137 | The extraction of `jit` is patched with `jit.ml.patch` to integrate the native backend, which has no representation in coq (see below). 138 | 139 | ### OCaml Frontend 140 | 141 | CoreJIT can be run using the extracted OCaml code. The additional OCaml code is out of scope of our verification work. 142 | The `parsing` directory contains a parser of CoreIR (see examples in `progs_specIR` directory). 143 | The `frontend` directory contains a frontend from miniLua (see examples in `progs_lua`) to CoreIR. 144 | 145 | The extracted `jit_step` from `jit.v` is looped in `main.ml`. 146 | A simple profiler implementation is defined in `profiler.ml`. 147 | 148 | ### Native Backend 149 | 150 | The `backend` directory contains an optional native backend written in OCaml where CoreIR is translated to LLVM IR and then to native code. 151 | 152 | To call from the interpreter into native code, the extracted jit is modified using the patch in `jit.ml.patch`. This patch adds an alternate execution step, which instead of using the interpreter to evaluate instructions of a function, hands control to native code. This part is out of scope of our verification work. 153 | 154 | The generated native code relies on some builtin functions in `native_lib/native_lib.c` used for I/O and interfacing with the OCaml runtime. 155 | 156 | ## Coq Axioms and Parameters 157 | 158 | The profiler, optimization heuristics and memory model are external parameters. 159 | This ensures that the correctness theorems do not depend on their implementation. 160 | These parameters have to be realized for the JIT to be extracted. 161 | The Load and Store implementations may fail (return None), for instance for an out-of-bound access. 162 | This corresponds to blocking behaviors in the semantics, and these behaviors are preserved. 163 | 164 | Here is a list of Parameters realized during the Coq extraction: 165 | 166 | - `profiler_state`: a type that the profiler can update 167 | - `initial_profiler_state`: how to initialiaze the profiler state 168 | - `profiler`: updating the profiler state 169 | - `optim_policy`: suggesting to optimize or execute 170 | - `optim_list`: the list of optimization wishes the profiler wants to perform 171 | - `framestates_to_insert`: the list of locations the profiler wants to insert framestates at 172 | 173 | - `mem_state`: an abstract type for the memory 174 | - `initial_memory`: how to initialize the memory 175 | - `Store_`: how to implement the Store instruction (may fail) 176 | - `Load_`: how to implement the Load instruction (may fail) 177 | 178 | - `spacing`: a number used as an heuristic for Assume insertion 179 | - `max_optim`: maximum number of optimization steps the JIT can do 180 | - `interpreter_fuel`: maximum number of steps the interpreter can perform before going back to the JIT 181 | - `hint`: a type to annotate the Nop instructions 182 | - `fuel_fresh`: a number used as an heuristic for Assume insertion 183 | 184 | The CompCert libraries also use 2 Axioms: Functional Extensionality and Classical Logic. 185 | -------------------------------------------------------------------------------- /Readme.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Aurele-Barriere/CoreJIT/8740d4149be649d0746d9f0d2d759b387a8f3246/Readme.pdf -------------------------------------------------------------------------------- /aec.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | cd /home/opam/coqjit 6 | 7 | echo "Welcome to the coqjit artifact" 8 | 9 | /usr/games/cowsay "Proving Theorems \"make proofs\"" 10 | make -j proofs 11 | echo "□" 12 | 13 | /usr/games/cowsay "Running Tests \"./test.sh\"" 14 | ./test.sh > /dev/null 15 | echo "□" 16 | 17 | /usr/games/cowsay "Running Experiments \"./experiments.sh\"" 18 | ./experiments.sh 1 19 | echo "□" 20 | 21 | /usr/games/cowsay "All done, enjoy your well deserved cup of coffee!" 22 | -------------------------------------------------------------------------------- /container-install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | LLVM="clang+llvm-9.0.0-x86_64-pc-linux-gnu" 6 | cd /home/opam 7 | 8 | sudo chmod o+r /tmp/$LLVM.tar.xz 9 | tar xf /tmp/$LLVM.tar.xz 10 | sudo rm -f /tmp/$LLVM.tar.xz 11 | PATH="$PATH:/home/opam/$LLVM/bin" 12 | 13 | sudo apt-get update 14 | sudo apt-get install -y pkg-config python2 m4 cmake libz3-4 libffi-dev libz-dev libncurses5-dev lua5.3 luajit cowsay 15 | sudo ln -s /usr/lib/x86_64-linux-gnu/libz3.so.4 /usr/lib/x86_64-linux-gnu/libz3.so.4.8 16 | sudo apt-get clean all 17 | 18 | opam update 19 | 20 | sudo chown -R opam:opam coqjit native_lib 21 | cd coqjit 22 | make install-deps 23 | opam clean 24 | eval $(opam env) 25 | 26 | make -j coq 27 | make -j extract 28 | make -j ocaml 29 | -------------------------------------------------------------------------------- /src/coqjit/.gitignore: -------------------------------------------------------------------------------- 1 | *.vo 2 | *.vok 3 | *.vos 4 | *.glob 5 | *.aux 6 | .depend 7 | _build/ 8 | extraction/ 9 | jit 10 | test_optim 11 | .lia.cache -------------------------------------------------------------------------------- /src/coqjit/BUILD.md: -------------------------------------------------------------------------------- 1 | * Download a binary release of LLVM 9.0 from https://releases.llvm.org/download.html 2 | * Add the bin directory of the unpacked LLVM to the PATH 3 | * make install-deps 4 | * make 5 | -------------------------------------------------------------------------------- /src/coqjit/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: coq ocaml all extract proofs clean clean_all clean_coq clean_extracted clean_ocaml clean_libs coq_depend ../native_lib/native_lib.o 2 | 3 | LIBS = Coqlib.v Maps.v Axioms.v Heaps.v Iteration.v Lattice.v Ordered.v Wfsimpl.v Kildall.v events.v Smallstep.v values.v Behaviors.v 4 | FILES = common.v specIR.v interpreter.v def_regs.v ir_properties.v framestate_insertion.v lowering.v const_prop.v assume_insertion.v assume_insertion_delay.v inlining.v profiler_types.v optimizer.v jit.v 5 | PROOFS = internal_simulations.v interpreter_proof.v const_prop_proof.v lowering_proof.v framestate_insertion_proof.v assume_insertion_proof.v assume_insertion_delay_proof.v inlining_proof.v optimizer_proof.v jit_proof.v 6 | 7 | COQC=coqc -R lib coqjit.lib 8 | COQDEP=coqdep -R lib coqjit.lib 9 | OCB_FLAGS = -tag bin_annot -I . -I extraction -I parsing -I frontend -I backend -I lib -use-menhir -use-ocamlfind -package coq -package llvm -package llvm.analysis -package llvm.executionengine -package llvm.scalar_opts -package ctypes -package ctypes.foreign -lflag ../../native_lib/native_lib.o 10 | OCB=ocamlbuild $(OCB_FLAGS) 11 | 12 | all: coq extract ocaml proofs 13 | 14 | %.vo: %.v 15 | @echo COQC $*.v 16 | @$(COQC) $*.v 17 | 18 | extract.vo: extract.v $(FILES:%.v=%.vo) 19 | @echo Creating extraction folder 20 | -@mkdir extraction 21 | @echo COQC extract.v 22 | @$(COQC) extract.v 23 | @patch extraction/jit.mli jit.mli.patch 24 | @patch extraction/jit.ml jit.ml.patch 25 | 26 | coq_libs: $(LIBS:%.v=lib/%.vo) 27 | 28 | .depend: $(FILES) $(PROOFS) $(LIBS:%=lib/%) 29 | @echo COQDEP: Generating dependencies 30 | @$(COQDEP) # ensure coqdep exists before writing to .depend 31 | @$(COQDEP) $^ > .depend 32 | 33 | coq_depend: .depend 34 | 35 | coq: coq_depend coq_libs $(FILES:%.v=%.vo) 36 | 37 | extract: coq extract.vo 38 | 39 | proofs: coq $(PROOFS:%.v=%.vo) 40 | 41 | ocaml: ../native_lib/native_lib.o 42 | @echo Building the OCaml Extracted JIT 43 | @$(OCB) main.native 44 | @mv main.native jit 45 | 46 | test_optim: test_optim.ml progs_specIR/test.specir 47 | @$(OCB) test_optim.native 48 | @mv test_optim.native test_optim 49 | 50 | ../native_lib/native_lib.o: 51 | $(MAKE) -C ../native_lib 52 | 53 | clean: clean_coq clean_extracted clean_ocaml 54 | 55 | clean_all: clean clean_libs 56 | 57 | clean_coq: 58 | @echo Cleaning Coq compiled files 59 | -@rm .depend 60 | -@rm *.vo *.glob .*.aux *.vok *.vos 61 | -@rm extraction/extract.vo extraction/extract.vok extraction/extract.vos 62 | 63 | clean_extracted: 64 | @echo Cleaning Extracted files 65 | -@rm -R extraction 66 | 67 | clean_ocaml: 68 | @echo Cleaning OCaml compiled files 69 | -@rm jit 70 | -@rm -R _build 71 | 72 | clean_libs: 73 | @echo Cleaning Coq compiled libraries 74 | -@rm lib/*.vo lib/*.glob lib/.*.aux lib/*.vok lib/*.vos 75 | 76 | install-deps: 77 | opam pin add coqjit . --no-action # tell opam about a local "cogjit" package 78 | opam install --deps-only coqjit # then install its dependencies 79 | 80 | -include .depend 81 | -------------------------------------------------------------------------------- /src/coqjit/Readme.md: -------------------------------------------------------------------------------- 1 | # Coq JIT 2 | These files describe an implementation and proof of a verified JIT in Coq. 3 | 4 | ## Install 5 | Typing `make` will: 6 | * Build the Coq development, proofs and implentation 7 | * Extract the Coq functions to an `extraction` folder as OCaml code 8 | * Build the Ocaml executable JIT, from the extracted Coq code and the Ocaml code (profiler, parser etc) 9 | 10 | To clean generated files: 11 | `make clean_all` will clean every generated file, `make clean` won't clean the Coq librairies. 12 | 13 | ## Usage 14 | Once compiled, execute the JIT by typing `./jit prog` where `prog` is a file containing a specIR (or miniLua) program. 15 | Examples can be found in the `progs_specIR` or `progs_lua` directory. 16 | 17 | You can give an option: 18 | * `-o` Print Optimized Functions 19 | * `-s` Print Debug Strings 20 | * `-p` Print Debug Program 21 | * `-k` Disable profiler using hints 22 | * `-n` Enable unverified native backend 23 | * `-f` Enable unverified lua frontend 24 | * `-t` Enable asserts in frontend 25 | * `-d` Print Native Debugging 26 | * `-a` Print Native Code 27 | * `-m` Print Native Heap 28 | * `-c` Native call always goes through jit_step, even when calling optimized code 29 | * `-help` Display this list of options 30 | -------------------------------------------------------------------------------- /src/coqjit/_CoqProject: -------------------------------------------------------------------------------- 1 | -R lib coqjit.lib -------------------------------------------------------------------------------- /src/coqjit/_tags: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Aurele-Barriere/CoreJIT/8740d4149be649d0746d9f0d2d759b387a8f3246/src/coqjit/_tags -------------------------------------------------------------------------------- /src/coqjit/assume_insertion.v: -------------------------------------------------------------------------------- 1 | (* Assume insertion: inserting Assume instructions *) 2 | (* A pass of the dynamic optimizer *) 3 | (* To insert an assume, you need a guard (what to speculate on) *) 4 | (* And you need a label where there is a framestate, that you want to copy the metadata of *) 5 | (* And the Assume is inserted next to that Framestate instruction *) 6 | 7 | Require Export List. 8 | Require Export Coqlib. 9 | Require Export Maps. 10 | Require Export specIR. 11 | Require Import Coq.MSets.MSetPositive. 12 | Require Export def_regs. 13 | 14 | (** * Guard checking *) 15 | (* To ensure that the Assume does not intriduce bugs, *) 16 | (* We check that the guard can evaluate without errors *) 17 | Definition check_reg (r:reg) (def:regset) : bool := 18 | PositiveSet.mem r def. 19 | 20 | Definition check_op (o:op) (def:regset) : bool := 21 | match o with 22 | | Reg r => check_reg r def 23 | | Cst _ => true 24 | end. 25 | 26 | Definition check_expr (e:expr) (def:regset): bool := 27 | match e with 28 | | Binexpr _ o1 o2 => andb (check_op o1 def) (check_op o2 def) 29 | | Unexpr _ o => check_op o def 30 | end. 31 | 32 | (* making sure that the guard can evaluate, given a set of defined registers *) 33 | Fixpoint check_guard (guard:list expr) (def:regset): bool := 34 | match guard with 35 | | nil => true 36 | | e::guard' => 37 | andb (check_expr e def) (check_guard guard' def) 38 | end. 39 | 40 | 41 | (** * The optimization that inserts Assume directly after the Framestate *) 42 | 43 | (* Verify that the assume can be inserted: no code between assume and Framestate *) 44 | Definition validator (v:version) (fs_lbl: label) (guard:list expr) (params: list reg): res unit := 45 | match ((ver_code v)#fs_lbl) with 46 | | Some (Framestate _ _ _ next) => 47 | do abs <- try_op (defined_regs_analysis (ver_code v) params (ver_entry v)) "Def_regs analysis failed"; 48 | do def_regs <- OK(def_absstate_get fs_lbl abs); 49 | match def_regs with 50 | | DefFlatRegset.Inj def => 51 | match (check_guard guard def) with 52 | | true => OK tt 53 | | false => Error "The guard might evaluate to an error" 54 | end 55 | | DefFlatRegset.Top => Error "The analysis couldn't get the exact set of defined registers: TOP" 56 | | DefFlatRegset.Bot => Error "The analysis couldn't get the exact set of defined registers: BOT" 57 | end 58 | | _ => Error "Not pointing to a valid Framestate" 59 | end. 60 | 61 | (* Returns the version where the Assume has been inserted *) 62 | Definition insert_assume_version (v:version) (fid:fun_id) (guard:list expr) (fsl:label) (params:list reg): res version := 63 | do code <- OK(ver_code v); 64 | do freshlbl <- OK (fresh_label (Pos.succ fsl) code); 65 | do _ <- validator v fsl guard params; (* validating that the assume can be inserted *) 66 | match code # fsl with 67 | | Some (Framestate tgt vm sl next) => 68 | do instr <- try_op (code # next) "Next Label is not used in the function"; 69 | do update_fs <- OK (code # fsl <- (Framestate tgt vm sl freshlbl)); 70 | do new_code <- OK (update_fs # freshlbl <- (Assume guard tgt vm sl next)); 71 | (* in the new assume, the deopt target, the varmap and the synth list are copied from the framestate *) 72 | OK (mk_version new_code (ver_entry v)) 73 | | _ => Error "Not pointing to a valid Framestate" 74 | end. 75 | 76 | (* The optimization pass *) 77 | Definition insert_assume (fid: fun_id) (guard:list expr) (fs_lbl: label) (p:program): res program := 78 | do f <- try_op (find_function fid p) "Function to optimize not found"; 79 | do v <- OK(current_version f); (* the optimized code if it exists, the base version otherwise *) 80 | do newv <- insert_assume_version v fid guard fs_lbl (fn_params f); 81 | do new_program <- OK (set_version p fid newv); 82 | OK (new_program). 83 | 84 | 85 | Definition safe_insert_assume (p:program) (fid:fun_id) (guard:list expr) (fs_lbl: label): program := 86 | safe_res (insert_assume fid guard fs_lbl) p. 87 | -------------------------------------------------------------------------------- /src/coqjit/assume_insertion_delay.v: -------------------------------------------------------------------------------- 1 | (* Assume insertion Delay: inserting Assume instruction *) 2 | (* This versions tries to insert an Assume after a Condition Instruction *) 3 | (* This showcases the possible separation of Framestate and Assume *) 4 | (* This is a pass of the dynamic optimizer *) 5 | 6 | Require Export List. 7 | Require Export Coqlib. 8 | Require Export Maps. 9 | Require Export specIR. 10 | Require Export assume_insertion. 11 | 12 | (* Checks that a label is not in a list *) 13 | Fixpoint not_in_list (l:list label) (lbl:label): bool := 14 | match l with 15 | | nil => true 16 | | lbl'::l' => 17 | match (Pos.eqb lbl' lbl) with 18 | | true => false 19 | | false => not_in_list l' lbl 20 | end 21 | end. 22 | 23 | (* Check that an instruction has for only predecessor some label *) 24 | Definition only_pred (c:code) (next:label) (pred:label): bool := 25 | PTree.fold 26 | (fun b lbl i => 27 | andb b 28 | (match (Pos.eqb lbl pred) with 29 | | true => true (* at the predecessor, we can point to next *) 30 | | false => not_in_list (instr_succ i) next (* elsewehere, next should not be a successor *) 31 | end)) 32 | c true. 33 | 34 | 35 | (* Verify that the assume can be inserted after a Cond Instruction *) 36 | Definition validator (v:version) (fs_lbl: label) (guard:list expr) (params:list reg): res unit := 37 | match ((ver_code v)#fs_lbl) with 38 | | Some (Framestate _ _ _ next) => 39 | match ((ver_code v)#next) with 40 | | Some (Cond _ iftrue _) => 41 | match (only_pred (ver_code v) next fs_lbl) with 42 | | true => 43 | match (Pos.eqb next (ver_entry v)) with 44 | | false => 45 | do abs <- try_op (defined_regs_analysis (ver_code v) params (ver_entry v)) "Def_regs analysis failed"; 46 | do def_regs <- OK(def_absstate_get next abs); 47 | match def_regs with 48 | | DefFlatRegset.Inj def => 49 | match (check_guard guard def) with 50 | | true => OK tt 51 | | false => Error "The guard might evaluate to an error" 52 | end 53 | | _ => Error "The analysis couldn't get the exact set of defined registers" 54 | end 55 | | true => Error "The Condition is the entry of the version" 56 | end 57 | | false => Error "The Framestate instruction does not dominate the Condition" 58 | end 59 | | _ => Error "No Condition instruction after the Framestate" 60 | end 61 | | _ => Error "Not pointing to a valid Framestate" 62 | end. 63 | 64 | (* Returns the version where the Assume has been inserted *) 65 | Definition insert_assume_version (v:version) (fid:fun_id) (guard:list expr) (fsl:label) (params:list reg): res version := 66 | do code <- OK(ver_code v); 67 | do _ <- validator v fsl guard params; (* validating that the assume can be inserted *) 68 | match code # fsl with 69 | | Some (Framestate tgt vm sl next) => 70 | match code # next with 71 | | Some (Cond condexpr iftrue iffalse) => 72 | do freshlbl <- OK (fresh_label (Pos.succ next) code); 73 | do instr <- try_op (code # iftrue) "Next Label is not used in the function"; 74 | do update_cond <- OK (code # next <- (Cond condexpr freshlbl iffalse)); 75 | do new_code <- OK (update_cond # freshlbl <- (Assume guard tgt vm sl iftrue)); 76 | (* in the new assume, the deopt target, the varmap and the synth list are copied from the framestate *) 77 | OK (mk_version new_code (ver_entry v)) 78 | | _ => Error "The instruction after the Framestate is not a Cond Instruction" 79 | end 80 | | _ => Error "Not pointing to a valid Framestate" 81 | end. 82 | 83 | (* The optimization pass *) 84 | Definition insert_assume_delay (fid: fun_id) (guard:list expr) (fs_lbl: label) (p:program): res program := 85 | do f <- try_op (find_function fid p) "Function to optimize not found"; 86 | do v <- OK(current_version f); (* the optimized code if it exists, the base version otherwise *) 87 | do newv <- insert_assume_version v fid guard fs_lbl (fn_params f); 88 | do new_program <- OK (set_version p fid newv); 89 | OK (new_program). 90 | 91 | 92 | Definition safe_insert_assume_delay (p:program) (fid:fun_id) (guard:list expr) (fs_lbl: label): program := 93 | safe_res (insert_assume_delay fid guard fs_lbl) p. 94 | -------------------------------------------------------------------------------- /src/coqjit/backend/native_llvm.ml: -------------------------------------------------------------------------------- 1 | open Llvm 2 | open Llvm_target 3 | open Llvm_scalar_opts 4 | open Ctypes 5 | open Ctypes_static 6 | open Foreign 7 | open Conv 8 | 9 | let context = global_context () 10 | let the_module = create_module context "my cool jit" 11 | 12 | let execution_engine () = 13 | assert (Llvm_executionengine.initialize ()); 14 | Llvm_executionengine.create the_module 15 | 16 | let double_type = double_type context 17 | let void_type = void_type context 18 | let void_ptr = pointer_type void_type 19 | let int_type = i64_type context (* assuming int is 64 *) 20 | let i32_type = i32_type context 21 | let int_val_type = int_type 22 | let char_type = i8_type context 23 | let char_ptr = pointer_type char_type 24 | let heap_ptr_type = int_type 25 | let heap_backing_store = pointer_type int_val_type 26 | let arg_buf_type = pointer_type int_val_type 27 | 28 | let zero = const_int i32_type 0 29 | let ltrue = const_int (i1_type context) 1 30 | let lfalse = const_int (i1_type context) 0 31 | 32 | let global_arg_buffer_content_ty = array_type int_type 256 33 | let global_arg_buffer_ty = pointer_type global_arg_buffer_content_ty 34 | let global_arg_buffer = define_global "global_arg_buffer" (const_null global_arg_buffer_content_ty) the_module 35 | 36 | let declare fid = 37 | let args = [| heap_backing_store ; arg_buf_type |] in 38 | let ft = function_type void_type args in 39 | let name = "fun" ^ (string_of_int (int_of_positive fid)) in 40 | let rec fresh_name suff = 41 | match lookup_function (name^suff) the_module with 42 | | None -> suff 43 | | Some _ -> fresh_name (suff ^ "_") 44 | in 45 | let name = name ^ (fresh_name "") in 46 | let f = declare_function name ft the_module in 47 | let bb = append_block context "entry" f in 48 | let builder = builder context in 49 | position_at_end bb builder; 50 | (f, builder, name) 51 | 52 | (* llvm optimization pipeline *) 53 | let the_fpm = begin 54 | let the_fpm = PassManager.create_function the_module in 55 | add_aggressive_dce the_fpm; 56 | add_cfg_simplification the_fpm; 57 | add_dead_store_elimination the_fpm; 58 | add_scalarizer the_fpm; 59 | add_merged_load_store_motion the_fpm; 60 | add_gvn the_fpm; 61 | add_ind_var_simplification the_fpm; 62 | add_instruction_combination the_fpm; 63 | add_jump_threading the_fpm; 64 | add_licm the_fpm; 65 | add_loop_deletion the_fpm; 66 | add_loop_idiom the_fpm; 67 | add_loop_rotation the_fpm; 68 | add_loop_reroll the_fpm; 69 | add_loop_unroll the_fpm; 70 | add_loop_unswitch the_fpm; 71 | add_memcpy_opt the_fpm; 72 | add_partially_inline_lib_calls the_fpm; 73 | add_lower_switch the_fpm; 74 | add_memory_to_register_promotion the_fpm; 75 | add_early_cse the_fpm; 76 | add_reassociation the_fpm; 77 | add_sccp the_fpm; 78 | add_constant_propagation the_fpm; 79 | add_aggressive_dce the_fpm; 80 | add_cfg_simplification the_fpm; 81 | add_scalar_repl_aggregation the_fpm; 82 | add_scalar_repl_aggregation_ssa the_fpm; 83 | add_scalar_repl_aggregation_with_threshold 4 the_fpm; 84 | add_lib_call_simplification the_fpm; 85 | add_tail_call_elimination the_fpm; 86 | add_constant_propagation the_fpm; 87 | (*add_memory_to_register_demotion the_fpm;*) 88 | add_verifier the_fpm; 89 | add_correlated_value_propagation the_fpm; 90 | add_lower_expect_intrinsic the_fpm; 91 | add_type_based_alias_analysis the_fpm; 92 | add_scoped_no_alias_alias_analysis the_fpm; 93 | add_basic_alias_analysis the_fpm; 94 | ignore (PassManager.initialize the_fpm); 95 | the_fpm 96 | end 97 | -------------------------------------------------------------------------------- /src/coqjit/backend/native_prim.ml: -------------------------------------------------------------------------------- 1 | open SpecIR 2 | open Llvm 3 | open Native_llvm 4 | open Bigarray 5 | open Conv 6 | open Ctypes 7 | open Ctypes_static 8 | open Maps 9 | open Camlcoq 10 | 11 | (* Primitive Functions by the native lib *) 12 | 13 | (* external hooks, needs to be provided by main *) 14 | let jit_main_hook = ref (fun _ -> assert false);; 15 | 16 | (* Converting ocaml objects to opaque ptrs *) 17 | let to_opaque (ovalue : Jit.jit_state) = 18 | Int64.of_nativeint (raw_address_of_ptr (Root.create ovalue)) 19 | let of_opaque opaque : Jit.jit_state = 20 | let addr = ptr_of_raw_address (Int64.to_nativeint opaque) in 21 | Root.get addr 22 | let release_opaque opaque : Jit.jit_state = 23 | let addr = ptr_of_raw_address (Int64.to_nativeint opaque) in 24 | let res = Root.get addr in 25 | Root.release addr; 26 | res 27 | 28 | (* Print *) 29 | let print_prim_ty = function_type void_type [|int_val_type|] 30 | let print_prim = declare_function "c_print_prim" print_prim_ty the_module 31 | 32 | (* Print String *) 33 | let print_string_prim_ty = function_type void_type [|char_ptr|] 34 | let print_string_prim = declare_function "c_print_string_prim" print_string_prim_ty the_module 35 | 36 | (* Fail *) 37 | let fail_prim_ty = function_type void_type [|char_ptr|] 38 | let fail_prim = declare_function "c_fail_prim" fail_prim_ty the_module 39 | 40 | (* Deopt *) 41 | type native_deopt_metadata = (deopt_target * varmap * synth_frame list) 42 | let native_deopt_metadata : (native_deopt_metadata array) ref = ref [||] 43 | 44 | let deopt_prim_ty = function_type void_type [|i32_type; i32_type; arg_buf_type|] 45 | let deopt_prim = declare_function "c_deopt_prim" deopt_prim_ty the_module 46 | 47 | let ocaml_deopt_prim (id:int) args : unit = 48 | let (deopt_trg, deopt_vm, deopt_sl) = (!native_deopt_metadata).(id) in 49 | if !Flags.print_debug_native then begin 50 | let (deopt_f,deopt_l) = deopt_trg in 51 | Printf.printf "[native->] Deopt @ %d :\n" id; 52 | Printf.printf " target : (%s,%s)\n" (Printer.print_fun_id deopt_f) 53 | (Printer.print_lbl deopt_l); 54 | Printf.printf " frames : {%s} [%s]\n" (Printer.print_varmap deopt_vm) 55 | (Printer.print_synth_list deopt_sl); 56 | Printf.printf " values : "; 57 | let n = Array1.dim args in 58 | for i = 0 to (n-1) do Printf.printf "%Ld " args.{i} done; 59 | Printf.printf "\n%!" 60 | end; 61 | let state = of_opaque args.{0} in 62 | let find_base_version f = 63 | match find_base_version f state.prog with 64 | | Some ver -> ver | None -> assert false 65 | in 66 | let md_pos = ref 1 in 67 | let synth_rm (vm:SpecIR.varmap) = 68 | let do_synth (s, _) = 69 | let res = (s, val_of_int64 args.{!md_pos}) in 70 | md_pos := !md_pos + 1; 71 | res 72 | in 73 | let rm = List.map do_synth vm in 74 | List.fold_left (fun m (r,v) -> 75 | PTree.set r v m) PTree.empty rm 76 | in 77 | let new_rm = synth_rm deopt_vm in 78 | let stack' = List.map (fun (((f,l), reg),vm)-> 79 | Stackframe (reg,find_base_version f,l,synth_rm vm)) deopt_sl 80 | in 81 | let new_state = Interpreter.S_Deopt (deopt_trg, stack', new_rm) in 82 | ignore ((!jit_main_hook) {state with synchro = new_state}) 83 | ;; 84 | Callback.register "ocaml_deopt_prim" ocaml_deopt_prim 85 | 86 | (* Call *) 87 | let call_prim_ty = function_type void_type [|i32_type; i32_type; i32_type; arg_buf_type|] 88 | let call_prim = declare_function "c_call_prim" call_prim_ty the_module 89 | let ocaml_call_prim (func:int) (nargs:int) args : unit = 90 | let argv = ref [] in 91 | if !Flags.print_debug_native then begin 92 | Printf.printf "[native->] calling fun%d with %d args\n%!" func nargs; 93 | end; 94 | for i = 0 to (nargs-1) do argv := (val_of_int64 args.{nargs-i})::(!argv) done; 95 | let state = release_opaque args.{0} in 96 | let synchro = Interpreter.S_Call (P.of_int func, !argv, None) in 97 | let (res, state) = (!jit_main_hook) {state with synchro} in 98 | (* return results via args buffer *) 99 | args.{0} <- to_opaque state; 100 | args.{1} <- int64_of_val res; 101 | if !Flags.print_debug_native then begin 102 | Printf.printf "[->native] returning %Ld to native\n%!" args.{1}; 103 | end; 104 | ;; 105 | Callback.register "ocaml_call_prim" ocaml_call_prim 106 | -------------------------------------------------------------------------------- /src/coqjit/common.v: -------------------------------------------------------------------------------- 1 | (* Common definitions for the JIT compiler *) 2 | 3 | Require Export Coqlib. 4 | Require Export String. 5 | Require Export Maps. 6 | 7 | (* Notations for maps *) 8 | Notation "a # b" := (PTree.get b a) (at level 1). 9 | Notation "a # b <- c" := (PTree.set b c a) (at level 1, b at next level). 10 | 11 | (* Some functions can return an error. These functions return something of type [res A], *) 12 | (* either a value of type [A], or an error *) 13 | Inductive res (A:Type): Type := 14 | | OK: A -> res A 15 | | Error: string -> res A. 16 | 17 | Arguments OK [A]. 18 | Arguments Error [A]. 19 | 20 | (* To perform [f] on a value of type [res A] *) 21 | Definition bind {A B: Type} (v: res A) (f: A -> res B): res B := 22 | match v with 23 | | Error s => Error s 24 | | OK v => f v 25 | end. 26 | 27 | (* perform [f] on a type [res(A*B)] *) 28 | Definition bind2 {A B C: Type} (v: res (A * B)) (f: A -> B -> res C) : res C := 29 | bind v (fun xy => f (fst xy) (snd xy)). 30 | 31 | Definition bind3 {A B C D: Type} (v: res (A * B * C)) (f: A -> B -> C -> res D) : res D := 32 | bind v (fun xyz => f (fst (fst xyz)) (snd(fst xyz)) (snd(xyz))). 33 | 34 | Definition bind4 {A B C D E: Type} (v: res (A * B * C * D)) (f: A -> B -> C -> D -> res E) : res E := 35 | bind v (fun abcd => f (fst (fst (fst abcd))) (snd (fst (fst abcd))) (snd (fst abcd)) (snd abcd)). 36 | 37 | 38 | Notation "'do' X <- A ; B" := (bind A (fun X => B)) 39 | (at level 200, X ident, A at level 100, B at level 200). 40 | Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) 41 | (at level 200, X ident, Y ident, A at level 100, B at level 200). 42 | Notation "'do' ( X , Y , Z ) <- A ; B" := (bind3 A (fun X Y Z => B)) 43 | (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200). 44 | Notation "'do' ( W , X , Y , Z ) <- A ; B" := (bind4 A (fun W X Y Z => B)) 45 | (at level 200, W ident, X ident, Y ident, Z ident, A at level 100, B at level 200). 46 | 47 | 48 | (* Some functions return an option. *) 49 | (* [try_op v s] returns the corresponding [OK], or fails with [Error s] *) 50 | Definition try_op {A:Type} (o:option A) (s:string): res A := 51 | match o with 52 | | None => Error s 53 | | Some v => OK v 54 | end. 55 | 56 | Lemma try_op_rewrite: 57 | forall A (e:option A) r s, 58 | try_op e s = OK r -> e = Some r. 59 | Proof. 60 | intros A e r s H. destruct e; inv H. auto. 61 | Qed. 62 | 63 | (* With f a function that transforms x, return (f x) or in case of an error, x unchanged *) 64 | Definition safe_res {A:Type} (f:A -> res A) (x:A) := 65 | match f x with 66 | | Error _ => x 67 | | OK y => y 68 | end. 69 | 70 | (* A JIT execution is a serie of optimization or execution steps *) 71 | (* jit_status represents these two types of steps *) 72 | Inductive jit_status: Type := 73 | | Exe (* execution *) 74 | | Opt. (* optimization *) 75 | 76 | (* Tactics to reason about monads *) 77 | Ltac ok_do:= 78 | match goal with 79 | | [ H: ?e = OK ?v |- context[?e]] => try rewrite H; simpl 80 | | [ H: ?e = Some ?v |- context[try_op ?e ?m]] => try rewrite H; simpl 81 | end. 82 | 83 | Ltac do_ok:= 84 | let HDO := fresh "HDO" in 85 | match goal with 86 | | [ H: (do V <- ?e; ?c) = OK ?r |- _ ] => try destruct e eqn:HDO; inv H 87 | | [ H: (do (A,B) <- ?e; ?c) = OK ?r |- _ ] => try destruct e eqn:HDO; inv H 88 | | [ H: (do (A,B,C) <- ?e; ?c) = OK ?r |- _ ] => try destruct e eqn:HDO; inv H 89 | | [ H: try_op ?e ?m = OK ?r |- _ ] => try destruct e eqn:HDO; inv H 90 | end. 91 | 92 | (* Tactics to reason about options *) 93 | Ltac match_some:= 94 | match goal with 95 | | [ H: ?e = Some ?i, 96 | H1: ?e = Some ?ii |- _ ] => 97 | try (rewrite H in H1; inv H1) 98 | end. 99 | 100 | Ltac match_ok:= 101 | match goal with 102 | | [H: OK ?a = OK ?b |- _ ] => 103 | assert(HMATCHOK: a = b) by (inv H; auto); clear H; rename HMATCHOK into H 104 | end. 105 | 106 | (* Destructing on the equality of two ppositives *) 107 | Ltac poseq_destr b1 b2 := 108 | let HEQ := fresh "HEQ" in 109 | destruct (Pos.eqb b1 b2) eqn:HEQ; [apply Pos.eqb_eq in HEQ; subst | apply Pos.eqb_neq in HEQ]. 110 | 111 | (** * Optimization hints *) 112 | (* We allow annotations in our program, to help the dynamic optimizer *) 113 | (* A Frontend can use this for instance to guide speculation *) 114 | Parameter hint: Type. 115 | -------------------------------------------------------------------------------- /src/coqjit/conv.ml: -------------------------------------------------------------------------------- 1 | open BinNums 2 | open BinInt 3 | open BinPos 4 | open Values 5 | open Camlcoq 6 | 7 | (* Converting values to OCaml int *) 8 | let rec int64_of_positive = function 9 | | Coq_xI p -> Int64.add (Int64.shift_left (int64_of_positive p) 1) 1L 10 | | Coq_xO p -> Int64.shift_left (int64_of_positive p) 1 11 | | Coq_xH -> 1L 12 | 13 | let rec int_of_positive = function 14 | | Coq_xI p -> ((int_of_positive p) lsl 1) + 1 15 | | Coq_xO p -> (int_of_positive p) lsl 1 16 | | Coq_xH -> 1 17 | 18 | let int64_of_val = function 19 | | Z0 -> 0L 20 | | Zpos p -> int64_of_positive p 21 | | Zneg p -> Int64.neg (int64_of_positive p) 22 | 23 | let int_of_val v = Int64.to_int (int64_of_val v) 24 | 25 | let val_of_int64 (i:int64) = 26 | if (i > 0L) 27 | then Zpos (P.of_int64 i) 28 | else if i < 0L 29 | then Zneg (P.of_int64 (Int64.neg i)) 30 | else Z0 31 | ;; 32 | 33 | let val_of_positive (i:P.t) = 34 | Zpos i 35 | 36 | let val_of_int (i:int) = 37 | val_of_int64 (Int64.of_int i) 38 | -------------------------------------------------------------------------------- /src/coqjit/def_regs.v: -------------------------------------------------------------------------------- 1 | (* Defined Registers ANalysis *) 2 | (* For Assume and Framestate insertion, we need to know the *) 3 | (* exact set of defined registers at some program point *) 4 | (* This analysis tracks defined registers, using Kildall library *) 5 | 6 | Require Import specIR. 7 | Require Import Lattice. 8 | Require Import Kildall. 9 | Require Import Coq.MSets.MSetPositive. 10 | 11 | Definition regset: Type := PositiveSet.t. 12 | Lemma regset_eq_refl: forall x, PositiveSet.eq x x. 13 | Proof. apply PositiveSet.eq_equiv. Qed. 14 | Lemma regset_eq_sym: forall x y, PositiveSet.eq x y -> PositiveSet.eq y x. 15 | Proof. apply PositiveSet.eq_equiv. Qed. 16 | Lemma regset_eq_trans: forall x y z, PositiveSet.eq x y -> PositiveSet.eq y z -> PositiveSet.eq x z. 17 | Proof. apply PositiveSet.eq_equiv. Qed. 18 | 19 | (* A Flat Semi-Lattice for sets of defined registers *) 20 | (* Either Bot, a given set, or Top *) 21 | Module DefFlatRegset <: SEMILATTICE_WITH_TOP. 22 | 23 | Inductive t' : Type := 24 | | Bot: t' 25 | | Inj: regset -> t' 26 | | Top: t'. 27 | 28 | Definition t : Type := t'. 29 | 30 | Definition eq (x y: t) : Prop := 31 | match x with 32 | | Bot => match y with 33 | | Bot => True 34 | | _ => False 35 | end 36 | | Top => match y with 37 | | Top => True 38 | | _ => False 39 | end 40 | | Inj rsx => match y with 41 | | Inj rsy => PositiveSet.Equal rsx rsy 42 | | _ => False 43 | end 44 | end. 45 | 46 | Lemma eq_refl: forall x, eq x x. 47 | Proof. intros. destruct x; simpl; auto. apply regset_eq_refl. Qed. 48 | 49 | Lemma eq_sym: forall x y, eq x y -> eq y x. 50 | Proof. intros. destruct x; destruct y; simpl; auto. simpl in H. apply regset_eq_sym. auto. Qed. 51 | 52 | Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. 53 | Proof. 54 | intros. destruct x; destruct y; destruct z; simpl; auto; simpl in H; simpl in H0. 55 | inv H. eapply regset_eq_trans; eauto. inv H. 56 | Qed. 57 | 58 | Definition beq (x y: t) : bool := 59 | match x, y with 60 | | Bot, Bot => true 61 | | Inj u, Inj v => if PositiveSet.equal u v then true else false 62 | | Top, Top => true 63 | | _, _ => false 64 | end. 65 | 66 | Lemma beq_correct: forall x y, beq x y = true -> eq x y. 67 | Proof. 68 | unfold eq; destruct x; destruct y; simpl; try congruence; intro; auto. 69 | destruct (PositiveSet.equal r r0) eqn:EQ; auto; inv H. apply PositiveSet.equal_spec. auto. 70 | Qed. 71 | 72 | Definition ge (x y: t) : Prop := 73 | match x, y with 74 | | Top, _ => True 75 | | _, Bot => True 76 | | Inj a, Inj b => PositiveSet.eq a b 77 | | _, _ => False 78 | end. 79 | 80 | Lemma ge_refl: forall x y, eq x y -> ge x y. 81 | Proof. 82 | unfold eq, ge. intros. destruct x; destruct y; simpl; auto. 83 | Qed. 84 | 85 | Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. 86 | Proof. 87 | unfold ge; destruct x; destruct y; try destruct z; intuition. 88 | eapply regset_eq_trans; eauto. 89 | Qed. 90 | 91 | Definition bot: t := Bot. 92 | 93 | Lemma ge_bot: forall x, ge x bot. 94 | Proof. 95 | destruct x; simpl; auto. 96 | Qed. 97 | 98 | Definition top: t := Top. 99 | 100 | Lemma ge_top: forall x, ge top x. 101 | Proof. 102 | destruct x; simpl; auto. 103 | Qed. 104 | 105 | Definition lub (x y: t) : t := 106 | match x, y with 107 | | Bot, _ => y 108 | | _, Bot => x 109 | | Top, _ => Top 110 | | _, Top => Top 111 | | Inj a, Inj b => if PositiveSet.equal a b then Inj a else Top 112 | end. 113 | 114 | Lemma ge_lub_left: forall x y, ge (lub x y) x. 115 | Proof. 116 | destruct x; destruct y; simpl; auto. apply regset_eq_refl. 117 | destruct (PositiveSet.equal r r0); simpl; auto. apply regset_eq_refl. 118 | Qed. 119 | 120 | Lemma ge_lub_right: forall x y, ge (lub x y) y. 121 | Proof. 122 | destruct x; destruct y; simpl; auto. apply regset_eq_refl. 123 | destruct (PositiveSet.equal r r0) eqn:EQ; simpl; auto. apply PositiveSet.equal_spec. auto. 124 | Qed. 125 | 126 | End DefFlatRegset. 127 | 128 | (* Top means we can't know for sure the set of defined registers *) 129 | (* Inj rs means rs is the set of defined registers at this point *) 130 | (* Bot is the initial value *) 131 | Definition def_abs_dr: Type := DefFlatRegset.t. 132 | 133 | (* Associating an abs_dr to each label *) 134 | Definition def_abs_state : Type := PMap.t def_abs_dr. 135 | Definition def_absstate_get (pc:label) (abs:def_abs_state) : def_abs_dr := 136 | PMap.get pc abs. 137 | 138 | (* At the function entry, we know parameters are defined *) 139 | Fixpoint def_entry_set (params:list reg): regset := 140 | match params with 141 | | nil => PositiveSet.empty 142 | | p::params' => PositiveSet.add p (def_entry_set params') 143 | end. 144 | 145 | Definition def_entry_abs_dr (params:list reg): def_abs_dr := 146 | DefFlatRegset.Inj (def_entry_set params). 147 | 148 | Module DS := Dataflow_Solver (DefFlatRegset) (NodeSetBackward). 149 | 150 | (* Inserting a new defined register into an abstract set *) 151 | Definition def_insert (r:reg) (adr:def_abs_dr) : def_abs_dr := 152 | match adr with 153 | | DefFlatRegset.Top => DefFlatRegset.Top 154 | | DefFlatRegset.Bot => DefFlatRegset.Inj (PositiveSet.singleton r) 155 | | DefFlatRegset.Inj rs => DefFlatRegset.Inj (PositiveSet.add r rs) 156 | end. 157 | 158 | Fixpoint def_insert_list (lr:list reg) (adr:def_abs_dr) : def_abs_dr := 159 | match lr with 160 | | nil => adr 161 | | r::lr' => def_insert r (def_insert_list lr' adr) 162 | end. 163 | 164 | (* The transf function that updates reg sets *) 165 | Definition def_dr_transf (c:code) (l:label) (adr:def_abs_dr) : def_abs_dr := 166 | match c!l with 167 | | None => adr 168 | | Some i => 169 | match i with 170 | | Op expr reg next => 171 | def_insert reg adr 172 | | Move ml next => 173 | def_insert_list (map fst ml) adr 174 | | Call fid args retreg next => 175 | def_insert retreg adr 176 | | Load expr reg next => 177 | def_insert reg adr 178 | | _ => adr (* other instructions can't declare registers *) 179 | end 180 | end. 181 | 182 | Definition defined_regs_analysis (c:code) (params:list reg) (entry:label): option def_abs_state:= 183 | DS.fixpoint 184 | (PTree.map1 instr_succ c) 185 | (def_dr_transf c) 186 | ((entry,(def_entry_abs_dr params))::nil). 187 | 188 | 189 | (** * Correctness of the analysis *) 190 | 191 | (* Matching abstract reg_sets with a concrete regmap *) 192 | Definition defined (rm:reg_map) (adr:def_abs_dr) := 193 | match adr with 194 | | DefFlatRegset.Top => True 195 | | DefFlatRegset.Bot => False 196 | | DefFlatRegset.Inj rs => 197 | forall r, PositiveSet.In r rs <-> exists v, rm # r = Some v 198 | end. 199 | 200 | Lemma mem_empty: 201 | forall r s, PositiveSet.is_empty s = true -> PositiveSet.mem r s = false. 202 | Proof. 203 | intros r s H. generalize dependent r. induction s; intros; auto. 204 | inv H. destruct (negb b) eqn:NEG; inv H1. 205 | destruct (PositiveSet.is_empty s1) eqn:EMPTY1; inv H0. 206 | simpl. destruct r. 207 | - apply IHs2. auto. 208 | - apply IHs1. auto. 209 | - destruct b; auto. 210 | Qed. 211 | 212 | (* There might be a simpler way *) 213 | Lemma mem_eq: 214 | forall r s1 s2, 215 | PositiveSet.eq s1 s2 -> 216 | PositiveSet.mem r s2 = PositiveSet.mem r s1. 217 | Proof. 218 | intros. unfold PositiveSet.eq in H. rewrite <- PositiveSet.equal_spec in H. 219 | generalize dependent s2. generalize dependent r. induction s1; intros. 220 | - inv H. simpl. apply mem_empty. auto. 221 | - destruct s2. 222 | + inv H. destruct (negb b) eqn:NEG; inv H1. destruct (PositiveSet.is_empty s1_1) eqn:EMPTY; inv H0. 223 | simpl. destruct r. 224 | * symmetry. apply mem_empty. auto. 225 | * symmetry. apply mem_empty. auto. 226 | * destruct b; inv NEG. auto. 227 | + simpl in H. simpl. destruct (eqb b b0) eqn:EQ; inv H. 228 | destruct (PositiveSet.equal s1_1 s2_1) eqn:EQ1; inv H1. destruct r. 229 | * apply IHs1_2. auto. 230 | * apply IHs1_1. auto. 231 | * symmetry. apply eqb_true_iff. auto. 232 | Qed. 233 | 234 | Lemma eq_defined: 235 | forall s1 s2 rm, 236 | PositiveSet.eq s1 s2 -> 237 | defined rm (DefFlatRegset.Inj s2) -> 238 | defined rm (DefFlatRegset.Inj s1). 239 | Proof. 240 | unfold defined, PositiveSet.In. intros s1 s2 rm EQ DEF. intros r. specialize (DEF r). 241 | apply mem_eq with (r:=r) in EQ. rewrite EQ in DEF. auto. 242 | Qed. 243 | 244 | Lemma defined_increasing: 245 | forall rm adr1 adr2, 246 | DefFlatRegset.ge adr1 adr2 -> 247 | defined rm adr2 -> 248 | defined rm adr1. 249 | Proof. 250 | intros rm adr1 adr2 GE DEF. 251 | destruct adr1; destruct adr2; try inv GE; auto; try inv DEF. 252 | simpl in GE. eapply eq_defined; eauto. constructor. 253 | Qed. 254 | 255 | (* The iterative analysis is correct *) 256 | Lemma def_analyze_successor: 257 | forall v params abs pc i pc', 258 | defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs -> 259 | (ver_code v) # pc = Some i -> 260 | In pc' (instr_succ i) -> 261 | DefFlatRegset.ge (def_absstate_get pc' abs) (def_dr_transf (ver_code v) pc (def_absstate_get pc abs)). 262 | Proof. 263 | intros v params abs pc i pc' H H0 H1. unfold defined_regs_analysis in H. 264 | eapply DS.fixpoint_solution; eauto. 265 | assert (@PTree.get (list positive) pc (PTree.map1 instr_succ (ver_code v)) = Some (instr_succ i)). 266 | { rewrite PTree.gmap1. unfold option_map. rewrite H0. auto. } 267 | unfold successors_list. rewrite H2. 268 | simpl. auto. 269 | Qed. 270 | 271 | Theorem def_analyze_correct: 272 | forall v pc i pc' abs params rm, 273 | defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs -> 274 | (ver_code v) # pc = Some i -> 275 | In pc' (instr_succ i) -> 276 | defined rm (def_dr_transf (ver_code v) pc (def_absstate_get pc abs)) -> 277 | defined rm (def_absstate_get pc' abs). 278 | Proof. 279 | intros. eapply def_analyze_successor in H; eauto. 280 | eapply defined_increasing; eauto. 281 | Qed. 282 | 283 | Lemma def_analyze_init': 284 | forall rm params valist, 285 | specIR.init_regs valist params = Some rm -> 286 | defined rm (def_entry_abs_dr params). 287 | Proof. 288 | intros. unfold def_entry_abs_dr. simpl. generalize dependent valist. generalize dependent rm. 289 | induction params; intros. 290 | - destruct valist; inv H. split; intros; inv H. 291 | unfold empty_regmap in H0. rewrite PTree.gempty in H0. inv H0. 292 | - destruct valist; inv H. destruct (init_regs valist params) eqn:INIT; inv H1. 293 | specialize (IHparams r0 valist INIT r). split; intros. 294 | + simpl in H. apply PositiveSet.add_spec in H. destruct H. 295 | * subst. rewrite PTree.gss. eauto. 296 | * apply IHparams in H. destruct H. poseq_destr a r. 297 | rewrite PTree.gss; eauto. 298 | rewrite PTree.gso; auto. eauto. 299 | + apply PositiveSet.add_spec. fold def_entry_set. poseq_destr a r. 300 | * left. auto. 301 | * right. rewrite PTree.gso in H; auto. apply <- IHparams in H. auto. 302 | Qed. 303 | 304 | Theorem def_analyze_init: 305 | forall rm v params abs valist, 306 | defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs -> 307 | specIR.init_regs valist params = Some rm -> 308 | defined rm (def_absstate_get (ver_entry v) abs). 309 | Proof. 310 | unfold defined_regs_analysis. intros rm v params abs valist FIX INIT. 311 | assert (A: DefFlatRegset.ge (def_absstate_get (ver_entry v) abs) (def_entry_abs_dr params)). 312 | { eapply DS.fixpoint_entry; eauto. left. auto. } 313 | eapply defined_increasing; eauto. 314 | eapply def_analyze_init'; eauto. 315 | Qed. 316 | 317 | (** * More defined Properties *) 318 | Lemma define_insert: 319 | forall rm reg v rs, 320 | defined rm rs -> 321 | defined rm # reg <- v (def_insert reg rs). 322 | Proof. 323 | intros rm reg v rs DEF. destruct rs. inv DEF. 2: simpl; auto. 324 | simpl in DEF. simpl. intros x. 325 | split; intros. 326 | - apply PositiveSet.add_spec in H. destruct H. 327 | + subst. rewrite PTree.gss. eauto. 328 | + specialize (DEF x). apply DEF in H. destruct H. 329 | poseq_destr reg x. rewrite PTree.gss. eauto. rewrite PTree.gso; eauto. 330 | - apply PositiveSet.add_spec. poseq_destr x reg; auto. 331 | right. rewrite PTree.gso in H; auto. apply DEF in H. auto. 332 | Qed. 333 | 334 | Lemma define_insert_list: 335 | forall ml rm newrm rs, 336 | defined rm rs -> 337 | update_movelist ml rm newrm -> 338 | defined newrm (def_insert_list (map fst ml) rs). 339 | Proof. 340 | unfold update_movelist. intros ml. induction ml; intros; inv H0. auto. 341 | simpl. apply define_insert. eapply IHml; eauto. 342 | Qed. 343 | 344 | (* Inequality between registers *) 345 | Definition reg_neq (r1:reg) (r2:reg) : bool := 346 | negb (Pos.eqb r1 r2). 347 | -------------------------------------------------------------------------------- /src/coqjit/experiments.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" 6 | JIT=$DIR/jit 7 | 8 | function measure { 9 | TIMEFORMAT='%E';time ( $@ ) 2>&1 1>/dev/null 10 | } 11 | 12 | ITER=$1 13 | 14 | $JIT -f -n $DIR/progs_lua/bubble_sort.lua > /dev/null 15 | 16 | echo "benchmark, vm, run, time" 17 | for i in $(seq 1 $ITER); do 18 | for t in gnome_sort fib2; do 19 | p=$DIR/progs_lua/$t.lua 20 | pn=$(mktemp /tmp/jit-test.XXXXXX) 21 | sed 's/__hint.*//' $p > $pn 22 | time=$(measure $JIT -f -n $p) 23 | echo "$t, jit, $i, $time" 24 | time=$(measure $JIT -f -k -n $p) 25 | echo "$t, jit_static, $i, $time" 26 | time=$(measure lua $pn) 27 | echo "$t, lua, $i, $time" 28 | time=$(measure luajit $pn) 29 | echo "$t, luajit, $i, $time" 30 | rm $pn 31 | done 32 | done 33 | -------------------------------------------------------------------------------- /src/coqjit/extract.v: -------------------------------------------------------------------------------- 1 | (* Extracting the Coq JIT to OCaml *) 2 | 3 | Require Export List. 4 | Require Export Coqlib. 5 | Require Export Maps. 6 | Require Export common. 7 | Require Export specIR. 8 | Require Export interpreter. 9 | Require Export profiler_types. 10 | Require Export optimizer. 11 | Require Export jit. 12 | Require Export liveness. 13 | Require Extraction. 14 | 15 | (* Standard lib *) 16 | Require Import ExtrOcamlBasic. 17 | Require Import ExtrOcamlString. 18 | 19 | (* Datatypes *) 20 | Extract Inlined Constant Datatypes.fst => "fst". 21 | Extract Inlined Constant Datatypes.snd => "snd". 22 | 23 | (* Avoid name clashes *) 24 | Extraction Blacklist List String Int. 25 | 26 | (* Strings *) 27 | (* https://github.com/coq/coq/issues/2747 *) 28 | Extract Inductive string => "string" [ """""" "(fun (a,b) -> (Char.escaped a) ^ b)"] "(fun e c s -> if s = "" then e else c s.[0] (String.sub s 1 (String.length s - 1)))". 29 | 30 | (* Realizing parameters *) 31 | Extract Constant hint => "Params.hint". 32 | 33 | Extract Constant mem_state => "Memory.mem_state". 34 | 35 | Extract Constant initial_memory => "Memory.initial_memory". 36 | 37 | Extract Constant Load_ => "Memory.load_". 38 | 39 | Extract Constant Store_ => "Memory.store_". 40 | 41 | Extract Constant max_optim => "Params.max_optim". 42 | 43 | Extract Constant interpreter_fuel => "Params.interpreter_fuel". 44 | 45 | Extract Constant profiler_state => "Profiler.profiler_state". 46 | 47 | Extract Constant initial_profiler_state => "Profiler.initial_profiler_state". 48 | 49 | Extract Constant profiler => "Profiler.profiler". 50 | 51 | Extract Constant optim_policy => "Profiler.optim_policy". 52 | 53 | Extract Constant optim_list => "Profiler.optim_list". 54 | 55 | Extract Constant framestates_to_insert => "Profiler.framestates_to_insert". 56 | 57 | Extract Constant fuel_fresh => "Params.fuel_fresh". 58 | 59 | Extract Constant spacing => "Params.spacing". 60 | 61 | (* Needed in Coq 8.4 to avoid problems with Function definitions. *) 62 | (* Set Extraction AccessOpaque. *) 63 | 64 | Cd "extraction". 65 | 66 | Separate Extraction jit_step jit_program jit_final_value initial_jit_state 67 | insert_all_framestates test_optimizer liveness_analyze 68 | PMap.set PMap.get PMap.init 69 | Pos.leb Pos.pred Z.succ Z.pred Z.neg Z.add Z.sub Z.mul Z.div Z.modulo Z.compare Z.of_N Z.land. 70 | -------------------------------------------------------------------------------- /src/coqjit/flags.ml: -------------------------------------------------------------------------------- 1 | let enable_native = ref false 2 | let print_debug_native = ref false 3 | let print_debug_native_code = ref false 4 | let print_debug_native_heap = ref false 5 | let native_call_always_jit_loop = ref false 6 | let enable_frontend_assert = ref false 7 | let disable_profiler_hints = ref false 8 | -------------------------------------------------------------------------------- /src/coqjit/framestate_insertion.v: -------------------------------------------------------------------------------- 1 | (* Framestate insertion: inserting Framestate instructions *) 2 | (* Such instructions act as templates for the insertion of speculation *) 3 | (* This is the first pass of the dynamic optimizer *) 4 | 5 | Require Export List. 6 | Require Export Coqlib. 7 | Require Export Maps. 8 | Require Export specIR. 9 | Require Import Coq.MSets.MSetPositive. 10 | Require Export liveness. 11 | Require Export def_regs. 12 | 13 | (* The identity varmap for the set of defined registers *) 14 | (* Maps to each defined register its current value *) 15 | Definition identity_varmap (rs:regset) : varmap := 16 | map (fun r => (r, Unexpr Assign (Reg r))) (PositiveSet.elements rs). 17 | 18 | Definition defined_rs (abs:def_abs_state) (l:label) : option regset := 19 | match (def_absstate_get l abs) with 20 | | DefFlatRegset.Top => None (* The analysis wasn't precise enough *) 21 | | DefFlatRegset.Inj rs => Some rs 22 | | DefFlatRegset.Bot => None (* Did not converge *) 23 | end. 24 | 25 | (* The list of labels where we must insert Framestates has to be cleaned *) 26 | (* We can't allow inserting twice at the same place: no duplicates in the list *) 27 | (* And labels must be associated with some code in the original code *) 28 | (* And we can't insert if the analysis failed to get the exact set of defined registers *) 29 | Definition remove_dup (l:list label): list label := nodup Pos.eq_dec l. 30 | 31 | Definition is_used (c:code) (l:label) : bool := 32 | match (c # l) with 33 | | Some _ => true 34 | | None => false 35 | end. 36 | Definition filter_unused (c:code) (l:list label) := filter (is_used c) l. 37 | 38 | Definition is_analyzed (abs:def_abs_state) (l:label) : bool := 39 | match (defined_rs abs l) with 40 | | Some _ => true 41 | | None => false 42 | end. 43 | 44 | Definition filter_analyzed (abs:def_abs_state) (l:list label) := filter (is_analyzed abs) l. 45 | 46 | Definition clean_label_list (def:def_abs_state) (c:code) (l:list label) : list label := 47 | filter_analyzed def (filter_unused c (remove_dup l)). 48 | 49 | (* The spacing between the inserted Framestate and the replaced instruction *) 50 | (* Used as heuristics for the fresh_label procedure *) 51 | Parameter spacing: positive. 52 | 53 | Definition insert_single_framestate (base_c:code) (c:code) (fid:fun_id) (lbl:label) (live:live_abs_state) (def:def_abs_state): res code := 54 | do instr <- try_op (c # lbl) "Label is not used in the function"; (* this shouldn't happen (filter_unused) *) 55 | do rs_def <- try_op (defined_rs def lbl) "Defined regs analysis failed"; (* this shouldn't happen (filter_analyzed) *) 56 | do rs_live_before <- OK (live_dr_transf base_c lbl (live_absstate_get lbl live)); 57 | (* base_c is needed to remember what was the code like before 58 | all the optimisations, in order to apply the transfer function *) 59 | do identity <- OK (identity_varmap (PositiveSet.inter rs_def rs_live_before)); 60 | (* we assign all the registers that are both defined at the instruction 61 | and live before the instruction *) 62 | do freshlbl <- OK (fresh_label (Pos.add lbl spacing) c); 63 | do move_instr <- OK (c # freshlbl <- instr); (* moving the old instruction *) 64 | (* constructing the Framestate instruction *) 65 | do fs_instr <- OK (Framestate (fid, lbl) identity nil freshlbl); (* deoptimizing to the same function *) 66 | do new_code <- OK (move_instr # lbl <- fs_instr); (* inserting the framestate *) 67 | OK new_code. 68 | 69 | 70 | Fixpoint insert_list_framestate (base_c:code) (c:code) (fid:fun_id) (lbllist:list label) (live:live_abs_state) (def:def_abs_state): res code := 71 | match lbllist with 72 | | nil => OK c 73 | | lbl::l => do newc <- insert_single_framestate base_c c fid lbl live def; 74 | insert_list_framestate base_c newc fid l live def 75 | end. 76 | 77 | Definition fs_insert_version (v:version) (fid:fun_id) (lbllist:list label) (live:live_abs_state) (def:def_abs_state) : res version := 78 | do code_ins <- insert_list_framestate (ver_code v) (ver_code v) fid lbllist live def; 79 | OK (mk_version code_ins (ver_entry v)). 80 | 81 | (* Returns the base version and checks that there is no optimized version *) 82 | Definition check_no_opt (f:function): res version := 83 | match (fn_opt f) with 84 | | None => OK (fn_base f) 85 | | Some _ => Error "Insertion in previously optimized functions is not supported yet" 86 | end. 87 | 88 | (* fid is the identifier of the function to insert framestate in *) 89 | (* lbllist is the places we want to insert framestates at, just before the current instruction *) 90 | Definition insert_framestate (fid:fun_id) (lbllist: list label) (p:program) : res program := 91 | do f <- try_op (find_function fid p) "Function to optimize not found"; 92 | do v <- check_no_opt f; (* gets the base version and checks that there is no opt version *) 93 | do params <- OK (fn_params f); 94 | do live <- try_op (liveness_analyze v) "Liveness analysis failed"; 95 | do def <- try_op (defined_regs_analysis (ver_code v) (fn_params f) (ver_entry v)) "Def_regs analysis failed"; 96 | do code <- OK (ver_code v); 97 | do clean_list <- OK (clean_label_list def code lbllist); 98 | do new_ver <- fs_insert_version v fid clean_list live def; 99 | do new_prog <- OK (set_version p fid new_ver); 100 | OK (new_prog). 101 | 102 | (* Tries to insert all possible Framestates *) 103 | Definition insert_all_framestates (fid:fun_id) (p:program): res program := 104 | do f <- try_op (find_function fid p) "Function to optimize not found"; 105 | do v <- check_no_opt f; (* gets the base version and checks that there is no opt version *) 106 | do params <- OK (fn_params f); 107 | do live <- try_op (liveness_analyze v) "Liveness analysis failed"; 108 | do def <- try_op (defined_regs_analysis (ver_code v) (fn_params f) (ver_entry v)) "Def_regs analysis failed"; 109 | do code <- OK (ver_code v); 110 | do clean_list <- OK (clean_label_list def code (map fst (PTree.elements code))); 111 | do new_ver <- fs_insert_version v fid clean_list live def; 112 | do new_prog <- OK (set_version p fid new_ver); 113 | OK (new_prog). 114 | 115 | 116 | Definition safe_insert_framestate (p:program) (fid: fun_id) (lbllist:list label): program := 117 | safe_res (insert_framestate fid lbllist) p. 118 | -------------------------------------------------------------------------------- /src/coqjit/frontend/lua_lexer.mll: -------------------------------------------------------------------------------- 1 | (* 2 | * parser by KINOSHITA Minoru 3 | * https://github.com/krtx/lua-parser 4 | * license: MIT 5 | *) 6 | { 7 | open Lexing 8 | open Lua_syntax 9 | open Lua_parser 10 | 11 | let reserved_keywords = 12 | [ "and", Lua_parser.AND 13 | ; "break", Lua_parser.BREAK 14 | ; "do", Lua_parser.DO 15 | ; "else", Lua_parser.ELSE 16 | ; "elseif", Lua_parser.ELSEIF 17 | ; "end", Lua_parser.END 18 | ; "false", Lua_parser.FALSE 19 | ; "for", Lua_parser.FOR 20 | ; "function", Lua_parser.FUNCTION 21 | ; "goto", Lua_parser.GOTO 22 | ; "if", Lua_parser.IF 23 | ; "in", Lua_parser.IN 24 | ; "local", Lua_parser.LOCAL 25 | ; "nil", Lua_parser.NIL 26 | ; "not", Lua_parser.NOT 27 | ; "or", Lua_parser.OR 28 | ; "repeat", Lua_parser.REPEAT 29 | ; "return", Lua_parser.RETURN 30 | ; "then", Lua_parser.THEN 31 | ; "true", Lua_parser.TRUE 32 | ; "until", Lua_parser.UNTIL 33 | ; "while", Lua_parser.WHILE 34 | ] 35 | 36 | let next_line lexbuf = 37 | let pos = lexbuf.lex_curr_p in 38 | lexbuf.lex_curr_p <- 39 | { pos with pos_bol = lexbuf.lex_curr_pos; 40 | pos_lnum = pos.pos_lnum + 1 41 | } 42 | } 43 | 44 | let white = [' ' '\t']+ 45 | let newline = '\r' | '\n' | '\r' '\n' 46 | let name = ['_' 'a'-'z' 'A'-'Z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9']* 47 | let hex = '0' ['x' 'X'] 48 | 49 | rule read = parse 50 | | '-' '-' '[' '[' { comment_long lexbuf } 51 | | '-' '-' { comment lexbuf } 52 | | white { read lexbuf } 53 | | newline { next_line lexbuf; read lexbuf } 54 | | name { let name = lexeme lexbuf in 55 | try 56 | List.assoc name reserved_keywords 57 | with 58 | Not_found -> Lua_parser.NAME name } 59 | | ['0'-'9']+ '.' ['0'-'9']+ 60 | { Lua_parser.FLOAT (float_of_string (lexeme lexbuf)) } 61 | | ['0'-'9']+ ['e' 'E'] ['0'-'9']+ 62 | { Lua_parser.FLOAT (float_of_string (lexeme lexbuf)) } 63 | | ['0'-'9']+ '.' ['0'-'9']* ['e' 'E'] ['0'-'9']+ 64 | { Lua_parser.FLOAT (float_of_string (lexeme lexbuf)) } 65 | | ['0'-'9']+ 66 | { Lua_parser.INTEGER (int_of_string (lexeme lexbuf)) } 67 | | hex ['0'-'9' 'A'-'F' 'a'-'f']+ 68 | { Lua_parser.INTEGER (int_of_string (lexeme lexbuf)) } 69 | | ('\'' | '"') as delimiter 70 | { Lua_parser.LITERALSTRING 71 | (literal_string delimiter lexbuf) } 72 | | '[' '[' 73 | { Lua_parser.LITERALSTRING 74 | (literal_string_long lexbuf) } 75 | | '=' { EQUAL } 76 | | ':' ':' { DOUBLECOLON } 77 | | ':' { COLON } 78 | | ';' { SEMICOLON } 79 | | ',' { COMMA } 80 | | '.' '.' '.' { TRIPLEDOT } 81 | | '.' '.' { DOUBLEDOT } 82 | | '.' { DOT } 83 | | '(' { LPAREN } 84 | | ')' { RPAREN } 85 | | '+' { PLUS } 86 | | '-' { HYPHEN } 87 | | '*' { ASTERISK } 88 | | '/' '/' { DOUBLESLASH } 89 | | '/' { SLASH } 90 | | '^' { HAT } 91 | | '%' { PERCENT } 92 | | '&' { AMPERSAND } 93 | | '~' { TILDA } 94 | | '|' { VERTICALBAR } 95 | | '>' '>' { DOUBLELT } 96 | | '<' '<' { DOUBLEGT } 97 | | '<' { GT } 98 | | '<' '=' { GTEQ } 99 | | '>' { LT } 100 | | '>' '=' { LTEQ } 101 | | '=' '=' { DOUBLEEQUAL } 102 | | '~' '=' { TILDAEQUAL } 103 | | '#' { SHARP } 104 | | '{' { LBRACE } 105 | | '}' { RBRACE } 106 | | '[' { LBRACKET } 107 | | ']' { RBRACKET } 108 | | eof { EOF } 109 | 110 | and comment_long = parse 111 | | newline { next_line lexbuf; comment_long lexbuf } 112 | | ']' ']' { read lexbuf } 113 | | _ { comment_long lexbuf } 114 | 115 | and comment = parse 116 | | newline { next_line lexbuf; read lexbuf } 117 | | _ { comment lexbuf } 118 | 119 | and literal_string open_delimiter = parse 120 | | '\\' '\\' 121 | { "\\\\" ^ (literal_string open_delimiter lexbuf) } 122 | | '\\' '\'' 123 | { "'" ^ (literal_string open_delimiter lexbuf) } 124 | | '\\' '"' 125 | { "\"" ^ (literal_string open_delimiter lexbuf) } 126 | | newline 127 | { next_line lexbuf; literal_string open_delimiter lexbuf } 128 | | _ as ch 129 | { if ch = open_delimiter 130 | then "" 131 | else (Char.escaped ch) ^ (literal_string open_delimiter lexbuf) } 132 | 133 | and literal_string_long = parse 134 | | ']' ']' { "" } 135 | | newline { next_line lexbuf; literal_string_long lexbuf } 136 | | _ as ch { (Char.escaped ch) ^ (literal_string_long lexbuf) } 137 | -------------------------------------------------------------------------------- /src/coqjit/frontend/lua_parser.mly: -------------------------------------------------------------------------------- 1 | (* 2 | * parser by KINOSHITA Minoru 3 | * https://github.com/krtx/lua-parser 4 | * license: MIT 5 | *) 6 | %{ 7 | open Lua_syntax 8 | 9 | type whose_arg = 10 | | FunctionArg of args 11 | | MethodArg of name * args 12 | %} 13 | 14 | %token EQUAL 15 | %token COLON 16 | %token SEMICOLON 17 | %token COMMA 18 | %token DOT 19 | %token EOF 20 | %token LPAREN 21 | %token RPAREN 22 | %token LBRACE 23 | %token RBRACE 24 | %token LBRACKET 25 | %token RBRACKET 26 | 27 | %token PLUS 28 | %token HYPHEN 29 | %token ASTERISK 30 | %token DOUBLESLASH 31 | %token SLASH 32 | %token HAT 33 | %token PERCENT 34 | %token AMPERSAND 35 | %token TILDA 36 | %token VERTICALBAR 37 | %token DOUBLECOLON 38 | %token DOUBLELT 39 | %token DOUBLEGT 40 | %token DOUBLEDOT 41 | %token TRIPLEDOT 42 | %token GT 43 | %token GTEQ 44 | %token LT 45 | %token LTEQ 46 | %token DOUBLEEQUAL 47 | %token TILDAEQUAL 48 | %token SHARP 49 | 50 | (* reserved keywords *) 51 | %token AND 52 | %token BREAK 53 | %token DO 54 | %token ELSE 55 | %token ELSEIF 56 | %token END 57 | %token FALSE 58 | %token FOR 59 | %token FUNCTION 60 | %token GOTO 61 | %token IF 62 | %token IN 63 | %token LOCAL 64 | %token NIL 65 | %token NOT 66 | %token OR 67 | %token REPEAT 68 | %token RETURN 69 | %token THEN 70 | %token TRUE 71 | %token UNTIL 72 | %token WHILE 73 | 74 | %token INTEGER 75 | %token FLOAT 76 | %token NAME 77 | %token LITERALSTRING 78 | %start chunk 79 | %% 80 | 81 | chunk: 82 | | b = block; EOF { b } 83 | ; 84 | 85 | block: 86 | | s = stat*; r = retstat? { s, r } 87 | ; 88 | 89 | stat: 90 | | s = stat_; SEMICOLON? { s } 91 | ; 92 | 93 | stat_: 94 | | vs = varlist; EQUAL; es = explist { Assign (vs, es) } 95 | | fc = functioncall { FunctionCall fc } 96 | | l = label { l } 97 | | BREAK { Break } 98 | | GOTO; n = NAME { Goto n } 99 | | DO; b = block; END { DoEnd b } 100 | | WHILE; e = exp; DO; b = block; END { WhileDoEnd (e, b) } 101 | | REPEAT; b = block; UNTIL; e = exp { RepeatUntil (b, e) } 102 | | IF; e = exp; THEN; b1 = block; 103 | br = list(ELSEIF; e = exp; THEN; b = block { (e, b) }); 104 | b2 = option(ELSE; b = block { b }); END 105 | { If ((e, b1) :: br, b2) } 106 | | FOR; n = NAME; EQUAL; 107 | e1 = exp; COMMA; e2 = exp; e3 = option(COMMA; e = exp { e }); 108 | DO; b = block; END 109 | { ForStep (n, e1, e2, e3, b) } 110 | | FOR; ns = namelist; IN; es = explist; 111 | DO; b = block; END 112 | { ForIn (ns, es, b) } 113 | | FUNCTION; n = separated_nonempty_list(DOT, NAME); 114 | l = option(methodcall); fb = funcbody 115 | { let fb = 116 | let (params, vararg, body) = fb 117 | in FunctionDef ("self" :: params, vararg, body) 118 | in 119 | (* "a.b.c" -> IndexTable ( ... , LiteralString c) *) 120 | let rec var_of_names : name list -> var = function 121 | | [] -> failwith "var_of_names" 122 | | [n] -> Name n 123 | | n :: ns -> IndexTable (Var (var_of_names ns), LiteralString n) 124 | in 125 | let v = var_of_names (List.rev n) in 126 | Assign ([v], [fb]) } 127 | | LOCAL; 128 | FUNCTION; n = NAME; l = option(COLON; n = NAME { n }); fb = funcbody 129 | { LocalAssign ([n], Some [FunctionDef fb]) } 130 | | LOCAL; ns = namelist; es = option(EQUAL; es = explist { es }) 131 | { LocalAssign (ns, es) } 132 | ; 133 | 134 | methodcall: 135 | | COLON; n = NAME { n } 136 | ; 137 | 138 | retstat: 139 | | RETURN; es = explist; SEMICOLON? { es } 140 | | RETURN; SEMICOLON? { [] } 141 | ; 142 | 143 | label: 144 | | DOUBLECOLON; n = NAME; DOUBLECOLON { Label n } 145 | ; 146 | 147 | var: 148 | | n = NAME { Name n } 149 | | pe = prefixexp; LBRACKET; e = exp; RBRACKET { IndexTable (pe, e) } 150 | | pe = prefixexp; DOT; n = NAME { IndexTable (pe, LiteralString n) } 151 | ; 152 | 153 | exp: 154 | | e1 = light_exp; b = binop; e2 = exp { BinOp (b, e1, e2) } 155 | | u = unop; e = exp { UnOp (u, e) } 156 | | e = light_exp { e } 157 | ; 158 | 159 | namelist: 160 | | ns = separated_nonempty_list(COMMA, NAME) { ns } 161 | ; 162 | 163 | varlist: 164 | | vs = separated_nonempty_list(COMMA, var) { vs } 165 | ; 166 | 167 | explist: 168 | | es = separated_nonempty_list(COMMA, exp) { es } 169 | ; 170 | 171 | light_exp: 172 | | NIL { Nil } 173 | | TRUE { True } 174 | | FALSE { False } 175 | | p = prefixexp { PrefixExp p } 176 | | i = INTEGER { Integer i } 177 | | f = FLOAT { Float f } 178 | | s = LITERALSTRING { LiteralString s } 179 | | t = tableconstr { Table t } 180 | | TRIPLEDOT { Vararg } 181 | | FUNCTION; fb = funcbody { FunctionDef fb } 182 | ; 183 | 184 | tableconstr: 185 | | LBRACE; RBRACE { [] } 186 | | LBRACE; fs = fields; RBRACE { fs } 187 | ; 188 | 189 | field_separator: 190 | | COMMA { () } 191 | | SEMICOLON { () } 192 | ; 193 | 194 | fields: 195 | | f = field { [f] } 196 | | f = field; field_separator; fs = fields? 197 | { match fs with 198 | | Some fs -> f :: fs 199 | | None -> [f] 200 | } 201 | ; 202 | 203 | field: 204 | | LBRACKET; k = exp; RBRACKET; EQUAL; v = exp { Some k, v } 205 | | n = NAME; EQUAL; v = exp { Some (LiteralString n), v } 206 | | v = exp { None, v } 207 | ; 208 | 209 | binop: 210 | | PLUS { Addition } 211 | | HYPHEN { Subtraction } 212 | | ASTERISK { Multiplication } 213 | | SLASH { FloatDivision } 214 | | DOUBLESLASH { FloorDivision } 215 | | PERCENT { Modulo } 216 | | HAT { Exponentiation } 217 | | AMPERSAND { BitwiseAnd } 218 | | VERTICALBAR { BitwiseOr } 219 | | TILDA { BitwiseXor } 220 | | DOUBLELT { ShiftRight } 221 | | DOUBLEGT { ShiftLeft } 222 | | DOUBLEEQUAL { Equality } 223 | | TILDAEQUAL { Inequality } 224 | | LT { Less } 225 | | GT { Greater } 226 | | LTEQ { LessEq } 227 | | GTEQ { GreaterEq } 228 | | AND { LogicalAnd } 229 | | OR { LogicalOr } 230 | | DOUBLEDOT { Concat } 231 | ; 232 | 233 | unop: 234 | | HYPHEN { UnaryMinus } 235 | | NOT { BitwiseNot } 236 | | SHARP { Length } 237 | | TILDA { LogicalNot } 238 | ; 239 | 240 | pexp: 241 | | v = var { Var v } 242 | | LPAREN; e = exp; RPAREN { Exp e } 243 | ; 244 | 245 | functioncallarg: 246 | | a = args; { FunctionArg a } 247 | | COLON; n = NAME; a = args { MethodArg (n, a) } 248 | ; 249 | 250 | functioncall: 251 | | p = pexp; fca = nonempty_list(functioncallarg) 252 | { let make_fc (p : functioncall) : whose_arg -> functioncall = function 253 | | MethodArg (n, a) -> Method (FunctionCallExp p, n, a) 254 | | FunctionArg a -> Function (FunctionCallExp p, a) 255 | in 256 | List.fold_left 257 | (fun acc arg -> make_fc acc arg) 258 | (match List.hd fca with 259 | | MethodArg (n, a) -> Method (p, n, a) 260 | | FunctionArg a -> Function (p, a)) 261 | (List.tl fca) 262 | } 263 | ; 264 | 265 | prefixexp: 266 | | fc = functioncall { FunctionCallExp fc } 267 | | p = pexp { p } 268 | ; 269 | 270 | funcbody: 271 | | LPAREN; ps = option(parlist); RPAREN; b = block; END 272 | { let ps, va = 273 | match ps with 274 | | Some s -> s 275 | | None -> [], None 276 | in 277 | ps, va, b } 278 | ; 279 | 280 | parlist: 281 | | TRIPLEDOT { [], Some () } 282 | | n = NAME { [n], None } 283 | | n = NAME; COMMA; ps = parlist 284 | { match ps with ps, va -> n :: ps, va } 285 | ; 286 | 287 | args: 288 | | LPAREN; RPAREN { [] } 289 | | LPAREN; es = explist; RPAREN { es } 290 | | s = LITERALSTRING { [LiteralString s] } 291 | | t = tableconstr { [Table t] } 292 | ; 293 | -------------------------------------------------------------------------------- /src/coqjit/frontend/lua_syntax.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * parser by KINOSHITA Minoru 3 | * https://github.com/krtx/lua-parser 4 | * license: MIT 5 | *) 6 | 7 | type block = stat list * retstat option 8 | 9 | and stat = 10 | | Assign of var list * exp list 11 | | FunctionCall of functioncall 12 | | Label of name 13 | | Break 14 | | Goto of name 15 | | DoEnd of block 16 | | WhileDoEnd of exp * block 17 | | RepeatUntil of block * exp 18 | | If of (exp * block) list * block option 19 | | ForStep of name * exp * exp * exp option * block 20 | | ForIn of name list * exp list * block 21 | | LocalAssign of name list * exp list option 22 | 23 | and funcname = name list (* * name option *) 24 | 25 | and funcbody = name list * unit option * block 26 | 27 | and retstat = exp list 28 | 29 | and name = string 30 | 31 | and exp = 32 | | Nil 33 | | False 34 | | True 35 | | Integer of int 36 | | Float of float 37 | | LiteralString of string 38 | | Vararg 39 | | FunctionDef of funcbody 40 | | PrefixExp of prefixexp 41 | | Table of tableconstr 42 | | BinOp of binop * exp * exp 43 | | UnOp of unop * exp 44 | 45 | and tableconstr = (exp option * exp) list 46 | 47 | and functioncall = 48 | | Function of prefixexp * args 49 | | Method of prefixexp * name * args 50 | 51 | and prefixexp = 52 | | Var of var 53 | | FunctionCallExp of functioncall 54 | | Exp of exp 55 | 56 | and var = 57 | | Name of name 58 | | IndexTable of prefixexp * exp 59 | 60 | and args = exp list 61 | 62 | and binop = 63 | (* arithmetic operators *) 64 | | Addition 65 | | Subtraction 66 | | Multiplication 67 | | FloatDivision 68 | | FloorDivision 69 | | Modulo 70 | | Exponentiation 71 | (* bitwise operators *) 72 | | BitwiseAnd 73 | | BitwiseOr 74 | | BitwiseXor 75 | | ShiftRight 76 | | ShiftLeft 77 | (* relational operators *) 78 | | Equality 79 | | Inequality 80 | | Less 81 | | Greater 82 | | LessEq 83 | | GreaterEq 84 | (* logical operators *) 85 | | LogicalAnd 86 | | LogicalOr 87 | (* string concatenation *) 88 | | Concat 89 | 90 | and unop = 91 | | UnaryMinus 92 | | BitwiseNot 93 | | Length 94 | | LogicalNot 95 | 96 | [@@deriving show] 97 | -------------------------------------------------------------------------------- /src/coqjit/interpreter.v: -------------------------------------------------------------------------------- 1 | (* Interpret a program according to the semantics of the ir *) 2 | 3 | Require Export List. 4 | Require Export Coqlib. 5 | Require Export Maps. 6 | Require Export String. 7 | Require Export common. 8 | Require Export specIR. 9 | 10 | (* Interpreting operands *) 11 | Definition eval_op (o:op) (rm:reg_map): res value := 12 | match o with 13 | | Reg r => try_op (PTree.get r rm) "Unassigned register" 14 | | Cst n => OK n 15 | end. 16 | 17 | 18 | (* Interpreting Binary operations *) 19 | Definition eval_binop_values (bo:bin_operation) (v1:value) (v2:value) : res value := 20 | match v1 with 21 | | Vint vi1 => 22 | match v2 with 23 | | Vint vi2 => 24 | match bo with 25 | | Plus => OK (Vint (vi1 + vi2)) 26 | | Minus => OK (Vint (vi1 - vi2)) 27 | | Mult => OK (Vint (vi1 * vi2)) 28 | | Gt => OK (bool_to_val(Z.gtb vi1 vi2)) 29 | | Lt => OK (bool_to_val(Z.ltb vi1 vi2)) 30 | | Geq => OK (bool_to_val(Z.geb vi1 vi2)) 31 | | Leq => OK (bool_to_val(Z.leb vi1 vi2)) 32 | | Eq => OK (bool_to_val(Z.eqb vi1 vi2)) 33 | end 34 | end 35 | end. 36 | 37 | Definition eval_binop (bo:bin_operation) (o1:op) (o2:op) (rm:reg_map): res value := 38 | do v1 <- eval_op o1 rm; 39 | do v2 <- eval_op o2 rm; 40 | eval_binop_values bo v1 v2. 41 | 42 | (* Interpreting Unary operations *) 43 | Definition eval_unop_value (u:un_operation) (v:value): res value := 44 | match u with 45 | | UMinus => match v with 46 | | Vint vi => OK (Vint (-vi)) 47 | end 48 | | Neg => match v with 49 | | Vint vi => OK (Vint (int_neg vi)) 50 | end 51 | | Assign => OK v 52 | end. 53 | 54 | Definition eval_unop (u:un_operation) (o:op) (rm:reg_map): res value := 55 | do v <- eval_op o rm; 56 | eval_unop_value u v. 57 | 58 | (* Interpreting expressions *) 59 | Definition eval_expr (e:expr) (rm:reg_map): res value := 60 | match e with 61 | | Binexpr binop o1 o2 => eval_binop binop o1 o2 rm 62 | | Unexpr unop o => eval_unop unop o rm 63 | end. 64 | 65 | (* Checks if a list of expressions are all true (!= 0) *) 66 | Fixpoint eval_list_expr (le:list expr) (rm:reg_map): res bool := 67 | match le with 68 | | nil => OK true 69 | | ex::le' => do v <- eval_expr ex rm; 70 | match v with 71 | | Vint 0 => OK false 72 | | Vint _ => eval_list_expr le' rm 73 | end 74 | end. 75 | 76 | (* In case there is an error in the evaluation of the guard of an Assume, we want to deoptimize *) 77 | Definition safe_eval_list_expr (le:list expr) (rm:reg_map): bool := 78 | match eval_list_expr le rm with 79 | | OK b => b 80 | | Error _ => false (* ignore the errors in guard evaluation *) 81 | end. 82 | 83 | (* Interprets a list of expressions (arguments) *) 84 | (* lv is the list of values already evaluated *) 85 | Fixpoint eval_list (le:list expr) (rm:reg_map): res (list value) := 86 | match le with 87 | | nil => OK nil 88 | | ex::le' => do v <- eval_expr ex rm; 89 | do lv <- eval_list le' rm; 90 | OK (v::lv) 91 | end. 92 | 93 | (* Initialize the register map when calling a function *) 94 | Fixpoint init_regs (valist:list value) (params:list reg): res reg_map := 95 | match valist with 96 | | nil => match params with 97 | | nil => OK empty_regmap 98 | | _ => Error "Not enough arguments" 99 | end 100 | | val::valist' => match params with 101 | | nil => Error "Too many arguments" 102 | | par::params' => do rm' <- init_regs valist' params'; 103 | OK (rm' # par <- val) 104 | end 105 | end. 106 | 107 | (* Updates the reg_map [rm] with the binding of [ml] *) 108 | (* rmeval is the original regmap, to evaluate all ops *) 109 | Fixpoint update_movelist' (ml:movelist) (rmeval:reg_map) (rm:reg_map) : res reg_map := 110 | match ml with 111 | | nil => OK rm 112 | | (r,e)::ml' => do v <- eval_expr e rmeval; 113 | do rm' <- update_movelist' ml' rmeval rm; 114 | OK (rm' # r <- v) 115 | end. 116 | 117 | Definition update_movelist (ml:movelist) (rm:reg_map) : res reg_map := 118 | update_movelist' ml rm rm. 119 | 120 | (* Creating a new Register Mapping from a Varmap *) 121 | Fixpoint update_regmap (vm:varmap) (rm:reg_map): res reg_map := 122 | match vm with 123 | | nil => OK empty_regmap 124 | | (r,e)::vm' => 125 | do v <- eval_expr e rm; 126 | do rm' <- update_regmap vm' rm; 127 | OK (rm' # r <- v) 128 | end. 129 | 130 | (* [synthesize_frame p rm sl]: the stack synthesized by the list [sl] under [rm] and [p] *) 131 | Fixpoint synthesize_frame (p:program) (rm:reg_map) (sl:list synth_frame): res stack := 132 | match sl with 133 | | nil => OK nil 134 | | ((f,l),r,vm)::sl' => 135 | do rmupdate <- update_regmap vm rm; 136 | do version <- try_op (find_base_version f p) "The version for the new stackframe does not exist"; 137 | do stack <- synthesize_frame p rm sl'; 138 | OK ((Stackframe r version l rmupdate)::stack) 139 | end. 140 | 141 | (* Returning states without any trace *) 142 | Definition OK0 {A:Type} (s:A) := OK (s,E0). 143 | 144 | Definition check_nil {X:Type} (l:list X) : res unit := 145 | match l with 146 | | nil => OK tt 147 | | _ => Error "The main function should not require any arguments" 148 | end. 149 | 150 | (* Compute the initial state of a program *) 151 | Definition initial_state (p:program) : res state := 152 | do f <- try_op (find_function (prog_main p) p) "Can't find main function of the program"; 153 | do check <- check_nil (fn_params f); 154 | do v <- OK (current_version f); 155 | OK (State nil v (ver_entry v) empty_regmap initial_memory). 156 | 157 | (** * Internal interpreter state *) 158 | (* The internal state of the interpreter. Does not need the stack, as it stops upon Call, Return and Deopt *) 159 | Inductive interpreter_state: Type := 160 | | Int_State: version -> label -> reg_map -> interpreter_state 161 | | Int_Final: value -> interpreter_state. 162 | 163 | (** * Synchronization states *) 164 | (* The output of the interpreter and native calls *) 165 | Inductive synchro_state:= 166 | | S_Call: fun_id -> list value -> option stackframe -> synchro_state 167 | | S_Return: value -> synchro_state 168 | | S_Deopt: deopt_target -> (list stackframe) -> reg_map -> synchro_state 169 | | Halt: interpreter_state -> synchro_state. 170 | (* The stack returned in the Deopt case is the new synthesized stackframes *) 171 | (* Halt allows the interpreter to go back to the JIT even when a synchro points hasn't been reached *) 172 | (* The interpreter synthesizes its own stackframe on a call *) 173 | 174 | (* Returning states without any trace, nor stackframe *) 175 | Definition OK_ (sm:(synchro_state * mem_state)) : res (synchro_state * mem_state * trace) := 176 | OK (sm,E0). 177 | 178 | (** * Internal interpreter step *) 179 | Definition int_step (p:program) (ins:interpreter_state) (ms:mem_state): res (synchro_state * mem_state * trace) := 180 | match ins with 181 | | Int_State v pc rm => 182 | do instr <- try_op ((ver_code v) ! pc) "No code to execute"; 183 | match instr with 184 | | Nop oh next => OK_ (Halt (Int_State v next rm), ms) 185 | 186 | | Op expr reg next => 187 | do val <- eval_expr expr rm; 188 | OK_ (Halt (Int_State v next (rm # reg <- val)), ms) 189 | 190 | | Move ml next => 191 | do newrm <- update_movelist ml rm; 192 | OK_ (Halt (Int_State v next newrm), ms) 193 | 194 | | Cond ex iftrue iffalse => 195 | do val <- eval_expr ex rm; 196 | do nextlbl <- OK (pc_cond val iftrue iffalse); 197 | OK_ (Halt (Int_State v nextlbl rm), ms) 198 | 199 | | Printexpr ex next => 200 | do printval <- eval_expr ex rm; 201 | OK (Halt (Int_State v next rm), ms, Valprint printval::E0) 202 | 203 | | Printstring str next => 204 | OK (Halt (Int_State v next rm), ms, Stringprint str::E0) 205 | 206 | | Store ex1 ex2 next => 207 | do val <- eval_expr ex1 rm; 208 | do addr <- eval_expr ex2 rm; 209 | do newms <- try_op (Store_ ms addr val) "Store_ failed"; 210 | OK_ (Halt (Int_State v next rm), newms) 211 | 212 | | Load ex reg next => 213 | do addr <- eval_expr ex rm; 214 | do val <- try_op (Load_ ms addr) "Load_ failed"; 215 | OK_ (Halt (Int_State v next (rm # reg <- val)), ms) 216 | 217 | | Call fid args retreg next => 218 | do valist <- eval_list args rm; 219 | (* to make sure the result can be forged *) 220 | do func <- try_op (find_function fid p) "Function doesn't exist"; 221 | do newrm <- init_regs valist (fn_params func); 222 | OK (S_Call fid valist (Some (Stackframe retreg v next rm)), ms, E0) 223 | 224 | | IReturn retex => 225 | do retval <- eval_expr retex rm; 226 | OK_ (S_Return retval, ms) 227 | 228 | | Assume g (fa,la) vm sl next => 229 | do assertion <- eval_list_expr g rm; 230 | match assertion with 231 | | true => OK_ (Halt (Int_State v next rm), ms) 232 | | false => 233 | do synth <- synthesize_frame p rm sl; 234 | do newrm <- update_regmap vm rm; 235 | (* to make sure the result can be forged *) 236 | do newver <- try_op (find_base_version fa p) "The version to deoptimize to does not exist"; 237 | OK_ (S_Deopt (fa,la) synth newrm, ms) 238 | end 239 | 240 | | Framestate (fa,la) vm sl next => 241 | do findf <- try_op (find_base_version fa p) "No deopt conditions"; 242 | do synth <- synthesize_frame p rm sl; 243 | do newrm <- update_regmap vm rm; 244 | OK_ (Halt (Int_State v next rm), ms) 245 | (* we give Framestate a behavior, just to make progress preservation proof easier *) 246 | (* Actually, since Framestates are lowered, the interpreter will never see them *) 247 | 248 | | Fail s => Error s (* Fail should make the interpreter crash *) 249 | 250 | end 251 | | Int_Final retval => 252 | Error "Called interpreter on Final" 253 | end. 254 | 255 | 256 | (** * Interpreter loop *) 257 | 258 | (** Safe interpreter step *) 259 | (* version of the interpreter step that returns to the JIT when seeing an error *) 260 | (* The bool tells you if you should keep on interpreting if you still have fuel *) 261 | (* It also returns just after an event is outputed *) 262 | Definition safe_int_step p ins ms : (synchro_state * mem_state * trace * bool) := 263 | match (int_step p ins ms) with 264 | | OK (synchro, newms, t) => match t with 265 | | nil => (synchro, newms, t, true) 266 | | _ => (synchro, newms, t, false) (* stops after outputs *) 267 | end 268 | | Error _ => (Halt ins, ms, E0, false) (* stops before errors *) 269 | end. 270 | 271 | (* looping the safe_step and halting just before an error if there is one *) 272 | Fixpoint interpreter_safe_loop (fuel: nat) (p:program) (ins:interpreter_state) (ms:mem_state): (synchro_state * mem_state * trace) := 273 | match fuel with 274 | | O => (Halt ins, ms, E0) 275 | | S fuel' => 276 | let '(synchro, newms, t, b) := safe_int_step p ins ms in 277 | match b with 278 | | false => (synchro, newms, t) (* the interpreter has encountered an error, time to return to the JIT *) 279 | | true => 280 | match synchro with 281 | | Halt int_state => let '(synchro', newms', t') := interpreter_safe_loop fuel' p int_state newms in 282 | (synchro', newms', t++t') 283 | | _ => (synchro, newms, t) 284 | end 285 | end 286 | end. 287 | 288 | Definition interpreter_loop (fuel: nat) (p:program) (ins:interpreter_state) (ms:mem_state): res (synchro_state * mem_state * trace) := 289 | do (synchro, newms, t) <- int_step p ins ms; (* first step may fail *) 290 | match t with 291 | | nil => 292 | match synchro with 293 | | Halt int_state => (* we may call the safe loop to go a bit further *) 294 | let '(synchro', newms', t') := interpreter_safe_loop fuel p int_state newms in 295 | OK (synchro', newms', t ++ t') 296 | | _ => OK (synchro, newms, t) (* we reached a synchronization point *) 297 | end 298 | | _ => OK (synchro, newms, t) (* we outputed something in the very first step *) 299 | end. 300 | -------------------------------------------------------------------------------- /src/coqjit/jit.ml.patch: -------------------------------------------------------------------------------- 1 | --- a/jit.ml 2020-06-05 14:51:15.349000000 +0200 2 | +++ b/jit.ml 2020-06-05 14:53:02.872000000 +0200 3 | @@ -192,9 +192,18 @@ 4 | 5 | (** val jit_step : jit_state -> (jit_state * trace) res **) 6 | 7 | +let do_native_call = ref (fun _ _ _ -> assert false) 8 | + 9 | let jit_step js = 10 | bind (OK (profiler js.prof_state js.synchro)) (fun newps -> 11 | match next_status newps js.nb_optim with 12 | | Exe -> 13 | + begin match !Flags.enable_native, js.synchro with 14 | + | true, S_Call (fid, param_vals, osf) -> 15 | + let {stack} = js in 16 | + let js = (!do_native_call) {js with stack=[]; prof_state=newps} fid param_vals in 17 | + assert (js.stack = []); 18 | + OK ({js with stack=(forge_call_stackframe stack osf)}, []) 19 | + | _ -> 20 | bind2 (forge_interpreter_state js.prog js.stack js.synchro) 21 | (fun int_state newstack -> 22 | bind3 (interpreter js.prog int_state js.mem) 23 | @@ -203,6 +212,7 @@ 24 | newps; mem = newmem; stack = newstack; synchro = newsynchro; 25 | nb_optim = js.nb_optim }, output))) 26 | + end 27 | | Opt -> 28 | bind (OK (safe_optimize newps js.prog)) (fun newp -> OK ({ prog = newp; 29 | prof_state = newps; mem = js.mem; stack = js.stack; synchro = 30 | -------------------------------------------------------------------------------- /src/coqjit/jit.mli.patch: -------------------------------------------------------------------------------- 1 | --- a/jit.mli 2020-06-04 11:04:59.055000000 +0200 2 | +++ b/jit.mli 2020-06-04 11:00:26.233000000 +0200 3 | @@ -52,3 +52,5 @@ 4 | val jit_final_value : jit_state -> value option 5 | 6 | val jit_program : jit_state -> program 7 | + 8 | +val do_native_call : (jit_state -> fun_id -> value list -> jit_state) ref 9 | -------------------------------------------------------------------------------- /src/coqjit/jit.v: -------------------------------------------------------------------------------- 1 | (* The Just in Time step *) 2 | 3 | Require Export List. 4 | Require Export Coqlib. 5 | Require Export Maps. 6 | Require Export common. 7 | Require Export specIR. 8 | Require Export interpreter. 9 | Require Export optimizer. 10 | 11 | (** * Forging call stackframes *) 12 | (* When the interpreters encounters a Call, it returns a stackframe to add to the JIT stack *) 13 | Definition forge_call_stackframe (s:stack) (osf:option stackframe) : stack := 14 | match osf with 15 | | None => s 16 | | Some sf => sf :: s 17 | end. 18 | 19 | (** * Forging interpreter states *) 20 | (* Mimics the semantics of the call, return or deopt *) 21 | Definition forge_interpreter_state (p:program) (current_stack:stack) (s:synchro_state) : res (interpreter_state * stack) := 22 | match s with 23 | | S_Call fid param_vals osf => 24 | do func <- try_op (find_function fid p) "Function to call does not exist"; 25 | do version <- OK (current_version func); 26 | do newrm <- interpreter.init_regs param_vals (fn_params func); 27 | OK (Int_State version (ver_entry version) newrm, forge_call_stackframe current_stack osf) (* maybe pushed to the stack *) 28 | 29 | | S_Return retval => 30 | match current_stack with 31 | | nil => OK (Int_Final retval,nil) 32 | | (Stackframe retreg v retlbl rm)::st' => 33 | OK (Int_State v retlbl (rm # retreg <- retval), st') (* we popped the stack *) 34 | end 35 | 36 | | S_Deopt (fa,la) synth newrm => 37 | do newver <- try_op (find_base_version fa p) "The version to deoptimize to does not exist"; 38 | OK (Int_State newver la newrm, synth++current_stack) (* we added the synth frames to the stack *) 39 | 40 | | Halt int_state => OK (int_state, current_stack) 41 | end. 42 | 43 | 44 | (** * Profiler oracle, external heuristics *) 45 | (* The JIT correctness does not depend on their implementation *) 46 | Parameter initial_profiler_state: profiler_state. 47 | Parameter profiler: profiler_state -> synchro_state -> profiler_state. 48 | Parameter optim_policy: profiler_state -> jit_status. 49 | 50 | (** * JIT states *) 51 | (* The state of the JIT that gets modified with each step *) 52 | Record jit_state: Type := mk_jit_state { 53 | prog: program; (* current program *) 54 | prof_state: profiler_state; (* state of the profiler *) 55 | mem: mem_state; (* state of the memory *) 56 | stack: stack; (* current model of the stack *) 57 | synchro: synchro_state; (* current synchronization state *) 58 | nb_optim: nat (* number of optimizations left *) 59 | }. 60 | (* The optimization policy cannot be trusted: it could ask us to optimize at each step *) 61 | (* without ever making any progress. *) 62 | (* The nb_optim nat bounds the total number of optimizations possible *) 63 | 64 | (* Maximum number of optimizations to perform *) 65 | Parameter max_optim: nat. 66 | 67 | (** * Interpreter *) 68 | Parameter interpreter_fuel: nat. 69 | 70 | Definition interpreter (p:program) (ins:interpreter_state) (ms:mem_state): res (synchro_state * mem_state * trace) := 71 | interpreter_loop interpreter_fuel p ins ms. (* calling the interpreter loop *) 72 | 73 | (** * Initial JIT state *) 74 | Definition initial_jit_state (p:program) := 75 | OK (mk_jit_state p initial_profiler_state initial_memory nil (S_Call (prog_main p) nil None) max_optim). 76 | 77 | (* Choosing the next step of the JIT (execution or optimizing) *) 78 | Definition next_status (ps:profiler_state) (nb_optim:nat): jit_status := 79 | match nb_optim with 80 | | O => Exe (* force execution if we've reached the max number of optims *) 81 | | _ => optim_policy ps 82 | end. 83 | 84 | 85 | (** * JIT step, to be looped *) 86 | Definition jit_step (js:jit_state): res (jit_state * trace) := 87 | do newps <- OK (profiler (prof_state js) (synchro js)); 88 | match (next_status newps (nb_optim js)) with 89 | | Exe => do (int_state, newstack) <- forge_interpreter_state (prog js) (stack js) (synchro js); 90 | do (newsynchro, newmem, output) <- interpreter (prog js) int_state (mem js); 91 | OK (mk_jit_state 92 | (prog js) 93 | newps 94 | newmem 95 | newstack 96 | newsynchro 97 | (nb_optim js) 98 | , output) 99 | | Opt => do newp <- OK (safe_optimize newps (prog js)); 100 | OK (mk_jit_state 101 | newp 102 | newps 103 | (mem js) 104 | (stack js) 105 | (synchro js) 106 | (Nat.pred (nb_optim js)) (* removing one optimization *) 107 | , E0) 108 | end. 109 | 110 | 111 | (* Is the JIT at a Final Value *) 112 | (* Returning the final returned value of the JIT *) 113 | Definition jit_final_value (js:jit_state): option value := 114 | match (synchro js) with 115 | | S_Return v => 116 | match (stack js) with 117 | | nil => Some v 118 | | _ => None 119 | end 120 | | Halt ints => 121 | match ints with 122 | | Int_Final v => Some v 123 | | _ => None 124 | end 125 | | _ => None 126 | end. 127 | 128 | (* Returning the program of a JIT state *) 129 | (* Useful if we want to look at the optimizations a JIT performed *) 130 | Definition jit_program (js:jit_state): program := 131 | prog js. 132 | -------------------------------------------------------------------------------- /src/coqjit/jit_proof.v: -------------------------------------------------------------------------------- 1 | (* Proving that any behavior of the JIT matches a behavior of the source program *) 2 | 3 | Require Export List. 4 | Require Export Coqlib. 5 | Require Export Maps. 6 | Require Export String. 7 | Require Export common. 8 | Require Export specIR. 9 | Require Export ir_properties. 10 | Require Export interpreter. 11 | Require Export interpreter_proof. 12 | Require Export optimizer_proof. 13 | Require Export jit. 14 | Require Export Behaviors. 15 | 16 | 17 | (** * Index and order for the external simulation *) 18 | (* The number of optimizations left *) 19 | Definition optim_index: Type := nat. 20 | Definition optim_order: optim_index -> optim_index -> Prop := lt. 21 | 22 | Lemma optim_order_wf: well_founded optim_order. 23 | Proof. 24 | unfold optim_order. apply lt_wf. 25 | Qed. 26 | 27 | 28 | (* The decreasing order, during the execution, given by the current backward simulation *) 29 | Record exec_index : Type := mkindex { 30 | index_type: Type; 31 | matchs: index_type -> state -> state -> Prop; 32 | index: index_type; 33 | order: index_type -> index_type -> Prop; 34 | wf: well_founded order; 35 | }. 36 | 37 | (* Update the exec_index with a new index *) 38 | Definition change_index (e:exec_index) (i:(index_type e)) : exec_index := 39 | mkindex (index_type e) (matchs e) i (order e) (wf e). 40 | 41 | (* This order decreases only if the order and relation stay the same *) 42 | Inductive exec_order: exec_index -> exec_index -> Prop := 43 | | exec_ord : 44 | forall e i, 45 | (order e) i (index e) -> 46 | exec_order (change_index e i) e. 47 | 48 | Lemma acc_exec_order: 49 | forall idxt (ord:idxt -> idxt -> Prop) i 50 | (WF: well_founded ord), 51 | Acc ord i -> forall ms, Acc exec_order (mkindex idxt ms i ord WF). 52 | Proof. 53 | induction 1. intros. 54 | apply Acc_intro. intros. inv H1. simpl in H2. 55 | apply H0. auto. 56 | Qed. 57 | 58 | Lemma exec_order_wf: well_founded exec_order. 59 | Proof. 60 | unfold well_founded. intros. destruct a. 61 | apply acc_exec_order. unfold well_founded in wf0. apply wf0. 62 | Qed. 63 | 64 | (* The order that decreases each time the JIT takes a stuttering step *) 65 | Definition jit_index: Type := optim_index * exec_index. 66 | 67 | (* Helper functions *) 68 | Definition joptim: jit_index -> optim_index := fst. 69 | Definition jexec: jit_index -> exec_index := snd. 70 | Definition jtype (ji:jit_index) := index_type (jexec ji). 71 | Definition jrel (ji:jit_index) := matchs (jexec ji). 72 | Definition jindex (ji:jit_index) := index (jexec ji). 73 | Definition jorder (ji:jit_index) := order (jexec ji). 74 | 75 | (* Update the index, but not the order or relation *) 76 | Definition jupdate (ji:jit_index) (i:jtype ji) : jit_index := 77 | (joptim ji, change_index (jexec ji) i). 78 | 79 | Lemma optim_update: 80 | forall ji i, 81 | joptim ji = joptim (jupdate ji i). 82 | Proof. intros. unfold jupdate. simpl. auto. Qed. 83 | 84 | Definition jit_order: jit_index -> jit_index -> Prop := 85 | lex_ord lt exec_order. 86 | 87 | Definition optim_decreases:= lex_ord_left. 88 | Definition exec_decreases:= lex_ord_right. 89 | 90 | (* The JIT order that decreases on stuttering steps is well-founded *) 91 | Theorem jit_order_wf: well_founded jit_order. 92 | Proof. 93 | unfold jit_order. apply wf_lex_ord. apply lt_wf. apply exec_order_wf. 94 | Qed. 95 | 96 | Ltac destruct_jit_index := 97 | let optim_idx := fresh "optim_idx" in 98 | let exec_idx := fresh "exec_idx" in 99 | match goal with 100 | | [ji: jit_index |- _ ] => destruct ji as [optim_idx exec_idx] 101 | end. 102 | 103 | Ltac destruct_exec_index := 104 | let idxt := fresh "index_type" in 105 | let matchs := fresh "match_states" in 106 | let idx := fresh "index" in 107 | let ord := fresh "order" in 108 | let refl := fresh "REFL" in 109 | let wf := fresh "WF" in 110 | match goal with 111 | | [e: exec_index |- _ ] => destruct e as [idxt matchs idx ord refl wf] 112 | end. 113 | 114 | (** * External match_states *) 115 | (* Relating semantic states of the original program and jit states *) 116 | Inductive match_states: program -> jit_index -> state -> jit_state -> Prop := 117 | | jit_match: forall p ji jitp jitps stack synchro int_state newstack src_state ms 118 | (INTERNAL_SIM: backward_internal_simulation' p jitp (jorder ji) (jrel ji)) 119 | (FORGE: forge_interpreter_state jitp stack synchro = OK (int_state, newstack)) 120 | (INTERNAL_MATCH: (jrel ji) (jindex ji) src_state (make_state int_state newstack ms)), 121 | match_states p ji 122 | src_state 123 | (mk_jit_state jitp jitps ms stack synchro (joptim ji)) 124 | 125 | | final_match: forall p ji retval ms jitp jitps, 126 | match_states p ji 127 | (Final retval ms) 128 | (mk_jit_state jitp jitps ms nil (S_Return retval) (joptim ji)). 129 | 130 | (** * JIT Semantics *) 131 | (* We define a semantics using CompCert's formalism *) 132 | (* The extracted JIt uses only the functions *) 133 | (* But this simple inductive definition matches the functions *) 134 | 135 | (* An inductive definition to match CompCert's formalism *) 136 | Inductive jit_step_prop: unit -> jit_state -> trace -> jit_state -> Prop := 137 | | Jstep: forall js1 js2 t 138 | (JIT_STEP: jit_step js1 = OK (js2, t)), 139 | jit_step_prop tt js1 t js2. 140 | 141 | Inductive init_jit_prop: program -> jit_state -> Prop := 142 | | Jinit: forall p js 143 | (JIT_INIT: initial_jit_state p = OK js), 144 | init_jit_prop p js. 145 | 146 | Inductive final_jit_prop: jit_state -> value -> Prop := 147 | | Jfinal: forall js v 148 | (JIT_FINAL: jit_final_value js = Some v), 149 | final_jit_prop js v. 150 | 151 | (* The jit semantics, to prove a backward simulation on and preserve behavior *) 152 | Definition jit_sem (p:program) : semantics := 153 | Semantics_gen jit_step_prop (init_jit_prop p) final_jit_prop tt. 154 | 155 | 156 | (** * External Backward Simulation *) 157 | Definition init_exec_index: exec_index := 158 | mkindex refl_type refl_match_states tt refl_order (* refl_refl *) wf_refl. 159 | Definition init_jit_index: jit_index := 160 | (max_optim, init_exec_index). 161 | 162 | (* The backward simulation used to get behavior refinement *) 163 | Theorem jit_simulation: 164 | forall (p:program), 165 | backward_simulation (specir_sem p) (jit_sem p). 166 | Proof. 167 | intros p. eapply Backward_simulation with (bsim_order := jit_order) (bsim_match_states := match_states p). 168 | - apply jit_order_wf. (* well-foundness *) 169 | - intros s1 H. simpl in H. (* initial_state exists *) 170 | destruct (initial_jit_state p) as [j|] eqn:INIT. 2:inv INIT. exists j. constructor. auto. 171 | 172 | - intros s1 s2 INIT1 INIT2. simpl in INIT1. inv INIT2. (* init states match *) 173 | exists init_jit_index. simpl. exists s1. split; auto. inv JIT_INIT. inv INIT1. eapply jit_match. 174 | + unfold init_jit_index, init_exec_index, jorder, jexec, jrel. simpl. apply backward_refl. 175 | + simpl. rewrite FINDF. simpl. destruct (fn_params f); simpl. eauto. inv NOARGS. 176 | + unfold init_jit_index, init_exec_index, jrel, jindex, make_state. simpl. constructor. 177 | 178 | - intros i s1 s2 r MATCH SAFE FINAL. inv FINAL. inv MATCH. (* final values match *) 179 | + eapply (match_final_states INTERNAL_SIM) in INTERNAL_MATCH; eauto. 180 | destruct synchro; destruct stack; inv JIT_FINAL. inv FORGE. simpl. constructor. 181 | destruct i0; inv H0. inv FORGE. constructor. 182 | destruct i0; inv H0. inv FORGE. constructor. 183 | + exists (Final retval ms). split. apply star_refl. inv JIT_FINAL. constructor. 184 | 185 | - intros i s1 s2 MATCH SAFE. inv MATCH. (* progress *) 186 | + apply (progress INTERNAL_SIM) in INTERNAL_MATCH as [[retval FINAL]|[t [s2' STEP]]] ; auto. 187 | * left. simpl. exists retval. constructor. destruct int_state; inv FINAL. 188 | destruct synchro; inv FORGE; try destruct d; repeat do_ok. 189 | destruct stack; try destruct s; inv H0. auto. constructor. 190 | 191 | * right. simpl. destruct (next_status (profiler jitps synchro) (joptim i)) eqn:STATUS. 192 | ** destruct int_state; simpl in STEP. 193 | 2: { inv STEP. inv STEP0. } 194 | eapply interpreter_loop_progress with (fuel:=interpreter_fuel) in STEP. 195 | destruct STEP as [[[synchro' ms']t']STEP]. simpl in STEP. 196 | set (newps := profiler jitps synchro). 197 | exists t'. exists (mk_jit_state jitp newps ms' newstack synchro' (joptim i)). constructor. 198 | unfold jit_step. simpl. rewrite STATUS. rewrite FORGE. simpl. unfold interpreter. 199 | rewrite STEP. simpl. auto. 200 | ** set (newps := profiler jitps synchro). set (newp := safe_optimize newps jitp). 201 | exists E0. exists (mk_jit_state newp newps ms stack synchro (Nat.pred (joptim i))). 202 | constructor. unfold jit_step. simpl. rewrite STATUS. auto. 203 | + left. exists retval. constructor. constructor. 204 | 205 | - intros s2 t s2' H i s1 MATCH SAFE. (* backward diagram *) 206 | inv MATCH. 207 | + simpl in H. inv H. destruct (next_status (profiler jitps synchro) (joptim i)) eqn:STATUS. 208 | 209 | * unfold jit_step in JIT_STEP. simpl in JIT_STEP. rewrite STATUS in JIT_STEP. (* EXE *) 210 | repeat do_ok. inv FORGE. rename HDO0 into INTERP. unfold interpreter in INTERP. 211 | destruct int_state as [v pc rm | retval]; simpl in INTERP. 212 | 2: { unfold interpreter_loop in INTERP. simpl in INTERP. inv INTERP. } 213 | destruct p1 as [[synchro1 ms1]t1]. 214 | unfold make_state in INTERNAL_MATCH. 215 | { destruct (forge_interpreter_state jitp newstack synchro1) as [[ins nextstack]|] eqn:FORGE_AFTER. 216 | - eapply interpreter_loop_correct in INTERP; eauto. destruct INTERP as [s' [STAR STEP]]. 217 | specialize (exploit_starstep INTERNAL_SIM). 218 | intros DIAG. specialize (DIAG (State newstack v pc rm ms) t1 s' (make_state ins nextstack ms1)). 219 | specialize (DIAG STAR STEP (jindex i) s1 INTERNAL_MATCH SAFE). destruct DIAG as [i' [s1' DIAG]]. 220 | exists (jupdate i i'). exists s1'. 221 | destruct DIAG as [[PLUS|[STAR' ORD]] MATCH]. 222 | + split. left. simpl. auto. erewrite optim_update. eapply jit_match; eauto. 223 | + split. right. simpl. split; auto. unfold jorder, jindex in ORD. unfold jupdate. destruct i. 224 | apply exec_decreases. simpl in ORD. constructor. auto. 225 | erewrite optim_update. eapply jit_match; eauto. 226 | - apply interpreter_loop_correct_result with (stk:=newstack) in INTERP as [ins [stack' FORGE]]. 227 | rewrite FORGE_AFTER in FORGE. inv FORGE. } 228 | 229 | * unfold jit_step in JIT_STEP. simpl in JIT_STEP. rewrite STATUS in JIT_STEP. (* OPT *) 230 | set (newps := profiler jitps synchro). set (newp := safe_optimize newps jitp). 231 | (* The optimization gives a simulated new program *) 232 | assert (OPT_CORRECT: exists optidx (optorder:optidx->optidx->Prop) optms, 233 | backward_internal_simulation' jitp newp optorder optms). 234 | { unfold newp. apply backward_eq. eapply safe_optimize_correct. eauto. } 235 | destruct OPT_CORRECT as [optidx [optorder [optms OPT_SIM]]]. 236 | specialize (match_states_refl OPT_SIM). intros H. unfold reflexive_forge in H. 237 | specialize (H synchro stack int_state newstack ms FORGE). 238 | destruct H as [int_state1 [newstack2 [FORGE2 [i2 OPT_MATCH]]]]. 239 | 240 | (* Composing the two simulations *) 241 | eapply compose_backward_simulation' in OPT_SIM as NEW_SIM; eauto. 242 | 2: { apply specir_single_events. } 243 | 244 | (* Constructing the new index, with a new relation and new order *) 245 | set (neword:= lex_ord (Relation_Operators.clos_trans (index_type (jexec i)) (jorder i)) optorder). 246 | set (newms := bb_ms jitp (jrel i) optms). 247 | assert (NEWWF: well_founded neword) by apply (order_wf NEW_SIM). 248 | fold neword in NEW_SIM. fold newms in NEW_SIM. 249 | exists (Nat.pred (joptim i), mkindex (index_type (jexec i) * optidx) newms (jindex i, i2) neword NEWWF). 250 | exists s1. (* no progress during optimization *) split. 251 | ** right. split. inv JIT_STEP. apply star_refl. destruct i. apply optim_decreases. 252 | unfold joptim. simpl. apply Nat.lt_pred_l. destruct o. inv STATUS. omega. 253 | ** inv JIT_STEP. eapply jit_match. apply NEW_SIM. fold newp. apply FORGE2. 254 | unfold jrel. simpl. unfold jindex. simpl. unfold newms. 255 | eapply bb_match_at'. unfold jindex in INTERNAL_MATCH. eauto. auto. 256 | 257 | + inv H. unfold jit_step in JIT_STEP. simpl in JIT_STEP. 258 | destruct (next_status (profiler jitps (S_Return retval)) (joptim i)) eqn:STATUS. (* final jit states can still optimize *) 259 | inv JIT_STEP. exists (Nat.pred (joptim i), jexec i). exists (Final retval ms). split. 260 | * right. split. inv JIT_STEP. apply star_refl. destruct i. apply optim_decreases. 261 | unfold joptim. simpl. apply Nat.lt_pred_l. destruct o. inv STATUS. omega. 262 | * inv JIT_STEP. apply final_match. 263 | Qed. 264 | 265 | (** * Behavior preservation *) 266 | Theorem jit_behavior_improves: 267 | forall (p:program), 268 | forall (beh_jit:program_behavior), 269 | program_behaves (jit_sem p) beh_jit -> 270 | exists (beh_src:program_behavior), 271 | program_behaves (specir_sem p) beh_src /\ behavior_improves beh_src beh_jit. 272 | Proof. 273 | intros p. eapply backward_simulation_behavior_improves; eauto. apply jit_simulation. 274 | Qed. 275 | 276 | Corollary jit_same_safe_behavior: 277 | forall (p:program), 278 | (forall beh, program_behaves (specir_sem p) beh -> not_wrong beh) -> 279 | (forall beh, program_behaves (jit_sem p) beh -> program_behaves (specir_sem p) beh). 280 | Proof. 281 | intros p. apply backward_simulation_same_safe_behavior. apply jit_simulation. 282 | Qed. 283 | -------------------------------------------------------------------------------- /src/coqjit/lib/Axioms.v: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* *) 3 | (* The Compcert verified compiler *) 4 | (* *) 5 | (* Xavier Leroy, INRIA Paris-Rocquencourt *) 6 | (* *) 7 | (* Copyright Institut National de Recherche en Informatique et en *) 8 | (* Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU General Public License as published by *) 10 | (* the Free Software Foundation, either version 2 of the License, or *) 11 | (* (at your option) any later version. This file is also distributed *) 12 | (* under the terms of the INRIA Non-Commercial License Agreement. *) 13 | (* *) 14 | (* *********************************************************************) 15 | 16 | (** This file collects some axioms used throughout the CompCert development. *) 17 | 18 | Require ClassicalFacts. 19 | Require FunctionalExtensionality. 20 | 21 | (** * Extensionality axioms *) 22 | 23 | (** The [Require FunctionalExtensionality] gives us functional 24 | extensionality for dependent function types: *) 25 | 26 | Lemma functional_extensionality_dep: 27 | forall {A: Type} {B : A -> Type} (f g : forall x : A, B x), 28 | (forall x, f x = g x) -> f = g. 29 | Proof @FunctionalExtensionality.functional_extensionality_dep. 30 | 31 | (** and, as a corollary, functional extensionality for non-dependent functions: 32 | *) 33 | 34 | Lemma functional_extensionality: 35 | forall {A B: Type} (f g : A -> B), (forall x, f x = g x) -> f = g. 36 | Proof @FunctionalExtensionality.functional_extensionality. 37 | 38 | (** For compatibility with earlier developments, [extensionality] 39 | is an alias for [functional_extensionality]. *) 40 | 41 | Lemma extensionality: 42 | forall {A B: Type} (f g : A -> B), (forall x, f x = g x) -> f = g. 43 | Proof @functional_extensionality. 44 | 45 | (** * Proof irrelevance *) 46 | 47 | (** We also use proof irrelevance. *) 48 | 49 | Axiom proof_irr: ClassicalFacts.proof_irrelevance. 50 | 51 | Arguments proof_irr [A]. 52 | -------------------------------------------------------------------------------- /src/coqjit/lib/Camlcoq.ml: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* *) 3 | (* The Compcert verified compiler *) 4 | (* *) 5 | (* Xavier Leroy, INRIA Paris-Rocquencourt *) 6 | (* *) 7 | (* Copyright Institut National de Recherche en Informatique et en *) 8 | (* Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU General Public License as published by *) 10 | (* the Free Software Foundation, either version 2 of the License, or *) 11 | (* (at your option) any later version. This file is also distributed *) 12 | (* under the terms of the INRIA Non-Commercial License Agreement. *) 13 | (* *) 14 | (* *********************************************************************) 15 | 16 | (* Library of useful Caml <-> Coq conversions *) 17 | 18 | open Datatypes 19 | open BinNums 20 | (* open BinNat *) 21 | open BinInt 22 | open BinPos 23 | (* open! Floats *) 24 | 25 | (* Coq's [nat] type and some of its operations *) 26 | 27 | module Nat = struct 28 | 29 | type t = nat = O | S of t 30 | 31 | let rec to_int = function 32 | | O -> 0 33 | | S n -> succ (to_int n) 34 | 35 | let rec to_int32 = function 36 | | O -> 0l 37 | | S n -> Int32.succ(to_int32 n) 38 | 39 | let rec of_int n = 40 | assert (n >= 0); 41 | if n = 0 then O else S (of_int (pred n)) 42 | 43 | let rec of_int32 n = 44 | assert (n >= 0l); 45 | if n = 0l then O else S (of_int32 (Int32.pred n)) 46 | 47 | end 48 | 49 | 50 | (* Coq's [positive] type and some of its operations *) 51 | 52 | module P = struct 53 | 54 | type t = positive = Coq_xI of t | Coq_xO of t | Coq_xH 55 | 56 | let one = Coq_xH 57 | let succ = Pos.succ 58 | let pred = Pos.pred 59 | let eq x y = (Pos.compare x y = Eq) 60 | let lt x y = (Pos.compare x y = Lt) 61 | let gt x y = (Pos.compare x y = Gt) 62 | let le x y = (Pos.compare x y <> Gt) 63 | let ge x y = (Pos.compare x y <> Lt) 64 | let compare x y = match Pos.compare x y with Lt -> -1 | Eq -> 0 | Gt -> 1 65 | 66 | let rec to_int = function 67 | | Coq_xI p -> let n = to_int p in n + n + 1 68 | | Coq_xO p -> let n = to_int p in n + n 69 | | Coq_xH -> 1 70 | 71 | let rec of_int n = 72 | if n land 1 = 0 then 73 | if n = 0 then assert false else Coq_xO (of_int (n lsr 1)) 74 | else 75 | if n = 1 then Coq_xH else Coq_xI (of_int (n lsr 1)) 76 | 77 | let rec to_int32 = function 78 | | Coq_xI p -> Int32.add (Int32.shift_left (to_int32 p) 1) 1l 79 | | Coq_xO p -> Int32.shift_left (to_int32 p) 1 80 | | Coq_xH -> 1l 81 | 82 | let rec of_int32 n = 83 | if Int32.logand n 1l = 0l then 84 | if n = 0l 85 | then assert false 86 | else Coq_xO (of_int32 (Int32.shift_right_logical n 1)) 87 | else 88 | if n = 1l 89 | then Coq_xH 90 | else Coq_xI (of_int32 (Int32.shift_right_logical n 1)) 91 | 92 | let rec to_int64 = function 93 | | Coq_xI p -> Int64.add (Int64.shift_left (to_int64 p) 1) 1L 94 | | Coq_xO p -> Int64.shift_left (to_int64 p) 1 95 | | Coq_xH -> 1L 96 | 97 | let rec of_int64 n = 98 | if Int64.logand n 1L = 0L then 99 | if n = 0L 100 | then assert false 101 | else Coq_xO (of_int64 (Int64.shift_right_logical n 1)) 102 | else 103 | if n = 1L 104 | then Coq_xH 105 | else Coq_xI (of_int64 (Int64.shift_right_logical n 1)) 106 | 107 | let (=) = eq 108 | let (<) = lt 109 | let (<=) = le 110 | let (>) = gt 111 | let (>=) = ge 112 | 113 | end 114 | 115 | (* Coq's [N] type and some of its operations *) 116 | 117 | (* module N = struct 118 | * 119 | * type t = coq_N = N0 | Npos of positive 120 | * 121 | * let zero = N0 122 | * let one = Npos Coq_xH 123 | * let eq x y = (N.compare x y = Eq) 124 | * let lt x y = (N.compare x y = Lt) 125 | * let gt x y = (N.compare x y = Gt) 126 | * let le x y = (N.compare x y <> Gt) 127 | * let ge x y = (N.compare x y <> Lt) 128 | * let compare x y = match N.compare x y with Lt -> -1 | Eq -> 0 | Gt -> 1 129 | * 130 | * let to_int = function 131 | * | N0 -> 0 132 | * | Npos p -> P.to_int p 133 | * 134 | * let of_int n = 135 | * if n = 0 then N0 else Npos (P.of_int n) 136 | * 137 | * let to_int32 = function 138 | * | N0 -> 0l 139 | * | Npos p -> P.to_int32 p 140 | * 141 | * let of_int32 n = 142 | * if n = 0l then N0 else Npos (P.of_int32 n) 143 | * 144 | * let to_int64 = function 145 | * | N0 -> 0L 146 | * | Npos p -> P.to_int64 p 147 | * 148 | * let of_int64 n = 149 | * if n = 0L then N0 else Npos (P.of_int64 n) 150 | * 151 | * let (=) = eq 152 | * let (<) = lt 153 | * let (<=) = le 154 | * let (>) = gt 155 | * let (>=) = ge 156 | * end *) 157 | 158 | (* Coq's [Z] type and some of its operations *) 159 | 160 | module Z = struct 161 | 162 | type t = coq_Z = Z0 | Zpos of positive | Zneg of positive 163 | 164 | let zero = Z0 165 | let one = Zpos Coq_xH 166 | let mone = Zneg Coq_xH 167 | let succ = Z.succ 168 | let pred = Z.pred 169 | let neg = Z.opp 170 | let add = Z.add 171 | let sub = Z.sub 172 | let mul = Z.mul 173 | let div = Z.div 174 | let modulo = Z.modulo 175 | let eq x y = (Z.compare x y = Eq) 176 | let lt x y = (Z.compare x y = Lt) 177 | let gt x y = (Z.compare x y = Gt) 178 | let le x y = (Z.compare x y <> Gt) 179 | let ge x y = (Z.compare x y <> Lt) 180 | let compare x y = match Z.compare x y with Lt -> -1 | Eq -> 0 | Gt -> 1 181 | 182 | let to_int = function 183 | | Z0 -> 0 184 | | Zpos p -> P.to_int p 185 | | Zneg p -> - (P.to_int p) 186 | 187 | let of_sint n = 188 | if n = 0 then Z0 else 189 | if n > 0 then Zpos (P.of_int n) 190 | else Zneg (P.of_int (-n)) 191 | 192 | let of_uint n = 193 | if n = 0 then Z0 else Zpos (P.of_int n) 194 | 195 | let to_int32 = function 196 | | Z0 -> 0l 197 | | Zpos p -> P.to_int32 p 198 | | Zneg p -> Int32.neg (P.to_int32 p) 199 | 200 | let of_sint32 n = 201 | if n = 0l then Z0 else 202 | if n > 0l then Zpos (P.of_int32 n) 203 | else Zneg (P.of_int32 (Int32.neg n)) 204 | 205 | let of_uint32 n = 206 | if n = 0l then Z0 else Zpos (P.of_int32 n) 207 | 208 | let to_int64 = function 209 | | Z0 -> 0L 210 | | Zpos p -> P.to_int64 p 211 | | Zneg p -> Int64.neg (P.to_int64 p) 212 | 213 | let of_sint64 n = 214 | if n = 0L then Z0 else 215 | if n > 0L then Zpos (P.of_int64 n) 216 | else Zneg (P.of_int64 (Int64.neg n)) 217 | 218 | let of_uint64 n = 219 | if n = 0L then Z0 else Zpos (P.of_int64 n) 220 | 221 | let of_N = Z.of_N 222 | 223 | let rec to_string_rec base buff x = 224 | if x = Z0 then () else begin 225 | let (q, r) = Z.div_eucl x base in 226 | to_string_rec base buff q; 227 | let d = to_int r in 228 | Buffer.add_char buff (Char.chr 229 | (if d < 10 then Char.code '0' + d 230 | else Char.code 'A' + d - 10)) 231 | end 232 | 233 | let to_string_aux base x = 234 | match x with 235 | | Z0 -> "0" 236 | | Zpos _ -> 237 | let buff = Buffer.create 10 in 238 | to_string_rec base buff x; 239 | Buffer.contents buff 240 | | Zneg p -> 241 | let buff = Buffer.create 10 in 242 | Buffer.add_char buff '-'; 243 | to_string_rec base buff (Zpos p); 244 | Buffer.contents buff 245 | 246 | let dec = to_string_aux (of_uint 10) 247 | 248 | let hex = to_string_aux (of_uint 16) 249 | 250 | let to_string = dec 251 | 252 | let is_power2 x = 253 | gt x zero && eq (Z.coq_land x (pred x)) zero 254 | 255 | let (+) = add 256 | let (-) = sub 257 | let ( * ) = mul 258 | let ( / ) = div 259 | let (=) = eq 260 | let (<) = lt 261 | let (<=) = le 262 | let (>) = gt 263 | let (>=) = ge 264 | end 265 | 266 | 267 | (* Alternate names *) 268 | 269 | (* let camlint_of_coqint : Integers.Int.int -> int32 = Z.to_int32 270 | * let coqint_of_camlint : int32 -> Integers.Int.int = Z.of_uint32 271 | * (\* interpret the int32 as unsigned so that result Z is in range for int *\) 272 | * let camlint64_of_coqint : Integers.Int64.int -> int64 = Z.to_int64 273 | * let coqint_of_camlint64 : int64 -> Integers.Int64.int = Z.of_uint64 274 | * (\* interpret the int64 as unsigned so that result Z is in range for int *\) 275 | * let camlint64_of_ptrofs : Integers.Ptrofs.int -> int64 = 276 | * fun x -> Z.to_int64 (Integers.Ptrofs.signed x) *) 277 | 278 | (* Atoms (positive integers representing strings) *) 279 | 280 | type atom = positive 281 | 282 | let atom_of_string = (Hashtbl.create 17 : (string, atom) Hashtbl.t) 283 | let string_of_atom = (Hashtbl.create 17 : (atom, string) Hashtbl.t) 284 | let next_atom = ref Coq_xH 285 | 286 | let intern_string s = 287 | try 288 | Hashtbl.find atom_of_string s 289 | with Not_found -> 290 | let a = !next_atom in 291 | next_atom := Pos.succ !next_atom; 292 | Hashtbl.add atom_of_string s a; 293 | Hashtbl.add string_of_atom a s; 294 | a 295 | let extern_atom a = 296 | try 297 | Hashtbl.find string_of_atom a 298 | with Not_found -> 299 | Printf.sprintf "$%d" (P.to_int a) 300 | 301 | let first_unused_ident () = !next_atom 302 | 303 | (* Strings *) 304 | 305 | let camlstring_of_coqstring (s: char list) = 306 | let r = Bytes.create (List.length s) in 307 | let rec fill pos = function 308 | | [] -> r 309 | | c :: s -> Bytes.set r pos c; fill (pos + 1) s 310 | in Bytes.to_string (fill 0 s) 311 | 312 | let coqstring_of_camlstring s = 313 | let rec cstring accu pos = 314 | if pos < 0 then accu else cstring (s.[pos] :: accu) (pos - 1) 315 | in cstring [] (String.length s - 1) 316 | 317 | let coqstring_uppercase_ascii_of_camlstring s = 318 | let rec cstring accu pos = 319 | if pos < 0 then accu else 320 | let d = if s.[pos] >= 'a' && s.[pos] <= 'z' then 321 | Char.chr (Char.code s.[pos] - 32) 322 | else 323 | s.[pos] in 324 | cstring (d :: accu) (pos - 1) 325 | in cstring [] (String.length s - 1) 326 | 327 | (* Floats *) 328 | 329 | (* let coqfloat_of_camlfloat f = 330 | * Float.of_bits(coqint_of_camlint64(Int64.bits_of_float f)) 331 | * let camlfloat_of_coqfloat f = 332 | * Int64.float_of_bits(camlint64_of_coqint(Float.to_bits f)) 333 | * 334 | * let coqfloat32_of_camlfloat f = 335 | * Float32.of_bits(coqint_of_camlint(Int32.bits_of_float f)) 336 | * let camlfloat_of_coqfloat32 f = 337 | * Int32.float_of_bits(camlint_of_coqint(Float32.to_bits f)) *) 338 | 339 | (* Int31 *) 340 | 341 | module Int31 = struct 342 | 343 | (* 344 | let constr (b30,b29,b28,b27,b26,b25,b24, 345 | b23,b22,b21,b20,b19,b18,b17,b16, 346 | b15,b14,b13,b12,b11,b10,b9,b8, 347 | b7,b6,b5,b4,b3,b2,b1,b0) = 348 | let f i b accu = if b then accu + (1 lsl i) else accu in 349 | f 30 b30 (f 29 b29 (f 28 b28 (f 27 b27 (f 26 b26 (f 25 b25 (f 24 b24 350 | (f 23 b23 (f 22 b22 (f 21 b21 (f 20 b20 (f 19 b19 (f 18 b18 (f 17 b17 (f 16 b16 351 | (f 15 b15 (f 14 b14 (f 13 b13 (f 12 b12 (f 11 b11 (f 10 b10 (f 9 b9 (f 8 b8 352 | (f 7 b7 (f 6 b6 (f 5 b5 (f 4 b4 (f 3 b3 (f 2 b2 (f 1 b1 (f 0 b0 0)))))))))))))))))))))))))))))) 353 | *) 354 | 355 | let constr (b30,b29,b28,b27,b26,b25,b24, 356 | b23,b22,b21,b20,b19,b18,b17,b16, 357 | b15,b14,b13,b12,b11,b10,b9,b8, 358 | b7,b6,b5,b4,b3,b2,b1,b0) = 359 | let f i b = if b then 1 lsl i else 0 in 360 | f 30 b30 + f 29 b29 + f 28 b28 + f 27 b27 + f 26 b26 + f 25 b25 + f 24 b24 + 361 | f 23 b23 + f 22 b22 + f 21 b21 + f 20 b20 + f 19 b19 + f 18 b18 + f 17 b17 + f 16 b16 + 362 | f 15 b15 + f 14 b14 + f 13 b13 + f 12 b12 + f 11 b11 + f 10 b10 + f 9 b9 + f 8 b8 + 363 | f 7 b7 + f 6 b6 + f 5 b5 + f 4 b4 + f 3 b3 + f 2 b2 + f 1 b1 + f 0 b0 364 | 365 | let destr f n = 366 | let b i = n land (1 lsl i) <> 0 in 367 | f (b 30) (b 29) (b 28) (b 27) (b 26) (b 25) (b 24) 368 | (b 23) (b 22) (b 21) (b 20) (b 19) (b 18) (b 17) (b 16) 369 | (b 15) (b 14) (b 13) (b 12) (b 11) (b 10) (b 9) (b 8) 370 | (b 7) (b 6) (b 5) (b 4) (b 3) (b 2) (b 1) (b 0) 371 | 372 | let twice n = 373 | (n lsl 1) land 0x7FFFFFFF 374 | 375 | let twice_plus_one n = 376 | ((n lsl 1) land 0x7FFFFFFF) lor 1 377 | 378 | let compare (x:int) (y:int) = 379 | if x = y then Datatypes.Eq 380 | else begin 381 | let sx = x < 0 and sy = y < 0 in 382 | if sx = sy then 383 | (if x < y then Datatypes.Lt else Datatypes.Gt) 384 | else 385 | (if sx then Datatypes.Gt else Datatypes.Lt) 386 | end 387 | 388 | end 389 | -------------------------------------------------------------------------------- /src/coqjit/lib/Iteration.v: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* *) 3 | (* The Compcert verified compiler *) 4 | (* *) 5 | (* Xavier Leroy, INRIA Paris-Rocquencourt *) 6 | (* *) 7 | (* Copyright Institut National de Recherche en Informatique et en *) 8 | (* Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU General Public License as published by *) 10 | (* the Free Software Foundation, either version 2 of the License, or *) 11 | (* (at your option) any later version. This file is also distributed *) 12 | (* under the terms of the INRIA Non-Commercial License Agreement. *) 13 | (* *) 14 | (* *********************************************************************) 15 | 16 | (** Bounded and unbounded iterators *) 17 | 18 | Require Import Axioms. 19 | Require Import Coqlib. 20 | Require Import Wfsimpl. 21 | 22 | (** This modules defines several Coq encodings of a general "while" loop. 23 | The loop is presented in functional style as the iteration 24 | of a [step] function of type [A -> B + A]: 25 | << 26 | let rec iterate step a = 27 | match step a with 28 | | inl b -> b 29 | | inr a' -> iterate step a' 30 | >> 31 | This iteration cannot be defined directly in Coq using [Fixpoint], 32 | because Coq is a logic of total functions, and therefore we must 33 | guarantee termination of the loop. 34 | *) 35 | 36 | (** * Terminating iteration *) 37 | 38 | (** We first implement the case where termination is guaranteed because 39 | the current state [a] decreases at each iteration. *) 40 | 41 | Module WfIter. 42 | 43 | Section ITERATION. 44 | 45 | Variables A B: Type. 46 | Variable step: A -> B + A. 47 | Variable ord: A -> A -> Prop. 48 | Hypothesis ord_wf: well_founded ord. 49 | Hypothesis step_decr: forall a a', step a = inr _ a' -> ord a' a. 50 | 51 | Definition step_info (a: A) : {b | step a = inl _ b} + {a' | step a = inr _ a' & ord a' a}. 52 | Proof. 53 | caseEq (step a); intros. left; exists b; auto. right; exists a0; auto. 54 | Defined. 55 | 56 | Definition iterate_F (a: A) (rec: forall a', ord a' a -> B) : B := 57 | match step_info a with 58 | | inl (exist b P) => b 59 | | inr (exist2 a' P Q) => rec a' Q 60 | end. 61 | 62 | Definition iterate (a: A) : B := Fix ord_wf iterate_F a. 63 | 64 | (** We now prove an invariance property [iterate_prop], similar to the Hoare 65 | logic rule for "while" loops. *) 66 | 67 | Variable P: A -> Prop. 68 | Variable Q: B -> Prop. 69 | 70 | Hypothesis step_prop: 71 | forall a : A, P a -> 72 | match step a with inl b => Q b | inr a' => P a' end. 73 | 74 | Lemma iterate_prop: 75 | forall a, P a -> Q (iterate a). 76 | Proof. 77 | intros a0. pattern a0. apply well_founded_ind with (R := ord). auto. 78 | intros. unfold iterate; rewrite unroll_Fix. unfold iterate_F. 79 | destruct (step_info x) as [[b U] | [a' U V]]. 80 | exploit step_prop; eauto. rewrite U; auto. 81 | apply H. auto. exploit step_prop; eauto. rewrite U; auto. 82 | Qed. 83 | 84 | End ITERATION. 85 | 86 | End WfIter. 87 | 88 | (** * Bounded iteration *) 89 | 90 | (** The presentation of iteration shown above is predicated on the existence 91 | of a well-founded ordering that decreases at each step of the iteration. 92 | In several parts of the CompCert development, it is very painful to define 93 | such a well-founded ordering and to prove decrease, even though we know our 94 | iterations always terminate. 95 | 96 | In the presentation below, we choose instead to bound the number of iterations 97 | by an arbitrary constant. [iterate] then becomes a function that can fail, 98 | of type [A -> option B]. The [None] result denotes failure to reach 99 | a result in the number of iterations prescribed, or, in other terms, 100 | failure to find a solution to the dataflow problem. The compiler 101 | passes that exploit dataflow analysis (the [Constprop], [CSE] and 102 | [Allocation] passes) will, in this case, either fail ([Allocation]) 103 | or turn off the optimization pass ([Constprop] and [CSE]). 104 | 105 | Since we know (informally) that our computations terminate, we can 106 | take a very large constant as the maximal number of iterations. 107 | Failure will therefore never happen in practice, but of 108 | course our proofs also cover the failure case and show that 109 | nothing bad happens in this hypothetical case either. *) 110 | 111 | Module PrimIter. 112 | 113 | Section ITERATION. 114 | 115 | Variables A B: Type. 116 | Variable step: A -> B + A. 117 | 118 | Definition num_iterations := 1000000000000%positive. 119 | 120 | (** The simple definition of bounded iteration is: 121 | << 122 | Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B := 123 | match niter with 124 | | O => None 125 | | S niter' => 126 | match step a with 127 | | inl b => b 128 | | inr a' => iterate niter' a' 129 | end 130 | end. 131 | >> 132 | This function is structural recursive over the parameter [niter] 133 | (number of iterations), represented here as a Peano integer (type [nat]). 134 | However, we want to use very large values of [niter]. As Peano integers, 135 | these values would be much too large to fit in memory. Therefore, 136 | we must express iteration counts as a binary integer (type [positive]). 137 | However, Peano induction over type [positive] is not structural recursion, 138 | so we cannot define [iterate] as a Coq fixpoint and must use 139 | Noetherian recursion instead. *) 140 | 141 | Definition iter_step (x: positive) 142 | (next: forall y, Plt y x -> A -> option B) 143 | (s: A) : option B := 144 | match peq x xH with 145 | | left EQ => None 146 | | right NOTEQ => 147 | match step s with 148 | | inl res => Some res 149 | | inr s' => next (Pos.pred x) (Ppred_Plt x NOTEQ) s' 150 | end 151 | end. 152 | 153 | Definition iter: positive -> A -> option B := Fix Plt_wf iter_step. 154 | 155 | (** The [iterate] function is defined as [iter] up to 156 | [num_iterations] through the loop. *) 157 | 158 | Definition iterate := iter num_iterations. 159 | 160 | (** We now prove the invariance property [iterate_prop]. *) 161 | 162 | Variable P: A -> Prop. 163 | Variable Q: B -> Prop. 164 | 165 | Hypothesis step_prop: 166 | forall a : A, P a -> 167 | match step a with inl b => Q b | inr a' => P a' end. 168 | 169 | Lemma iter_prop: 170 | forall n a b, P a -> iter n a = Some b -> Q b. 171 | Proof. 172 | apply (well_founded_ind Plt_wf 173 | (fun p => forall a b, P a -> iter p a = Some b -> Q b)). 174 | intros. unfold iter in H1. rewrite unroll_Fix in H1. unfold iter_step in H1. 175 | destruct (peq x 1). discriminate. 176 | specialize (step_prop a H0). 177 | destruct (step a) as [b'|a'] eqn:?. 178 | inv H1. auto. 179 | apply H with (Pos.pred x) a'. apply Ppred_Plt; auto. auto. auto. 180 | Qed. 181 | 182 | Lemma iterate_prop: 183 | forall a b, iterate a = Some b -> P a -> Q b. 184 | Proof. 185 | intros. apply iter_prop with num_iterations a; assumption. 186 | Qed. 187 | 188 | End ITERATION. 189 | 190 | End PrimIter. 191 | 192 | (** * General iteration *) 193 | 194 | (* An implementation using classical logic and unbounded iteration, 195 | in the style of Yves Bertot's paper, "Extending the Calculus 196 | of Constructions with Tarski's fix-point theorem". 197 | 198 | As in the bounded case, the [iterate] function returns an option type. 199 | [None] means that iteration does not terminate. 200 | [Some b] means that iteration terminates with the result [b]. *) 201 | 202 | Require Import Classical. 203 | Require Import ClassicalDescription. 204 | Require Import Max. 205 | 206 | Module GenIter. 207 | 208 | Section ITERATION. 209 | 210 | Variables A B: Type. 211 | Variable step: A -> B + A. 212 | 213 | Definition B_le (x y: option B) : Prop := x = None \/ y = x. 214 | Definition F_le (x y: A -> option B) : Prop := forall a, B_le (x a) (y a). 215 | 216 | Definition F_iter (next: A -> option B) (a: A) : option B := 217 | match step a with 218 | | inl b => Some b 219 | | inr a' => next a' 220 | end. 221 | 222 | Lemma F_iter_monot: 223 | forall f g, F_le f g -> F_le (F_iter f) (F_iter g). 224 | Proof. 225 | intros; red; intros. unfold F_iter. 226 | destruct (step a) as [b | a']. red; auto. apply H. 227 | Qed. 228 | 229 | Fixpoint iter (n: nat) : A -> option B := 230 | match n with 231 | | O => (fun a => None) 232 | | S m => F_iter (iter m) 233 | end. 234 | 235 | Lemma iter_monot: 236 | forall p q, (p <= q)%nat -> F_le (iter p) (iter q). 237 | Proof. 238 | induction p; intros. 239 | simpl. red; intros; red; auto. 240 | destruct q. elimtype False; omega. 241 | simpl. apply F_iter_monot. apply IHp. omega. 242 | Qed. 243 | 244 | Lemma iter_either: 245 | forall a, 246 | (exists n, exists b, iter n a = Some b) \/ 247 | (forall n, iter n a = None). 248 | Proof. 249 | intro a. elim (classic (forall n, iter n a = None)); intro. 250 | right; assumption. 251 | left. generalize (not_all_ex_not nat (fun n => iter n a = None) H). 252 | intros [n D]. exists n. generalize D. 253 | case (iter n a); intros. exists b; auto. congruence. 254 | Qed. 255 | 256 | Definition converges_to (a: A) (b: option B) : Prop := 257 | exists n, forall m, (n <= m)%nat -> iter m a = b. 258 | 259 | Lemma converges_to_Some: 260 | forall a n b, iter n a = Some b -> converges_to a (Some b). 261 | Proof. 262 | intros. exists n. intros. 263 | assert (B_le (iter n a) (iter m a)). apply iter_monot. auto. 264 | elim H1; intro; congruence. 265 | Qed. 266 | 267 | Lemma converges_to_exists: 268 | forall a, exists b, converges_to a b. 269 | Proof. 270 | intros. elim (iter_either a). 271 | intros [n [b EQ]]. exists (Some b). apply converges_to_Some with n. assumption. 272 | intro. exists (@None B). exists O. intros. auto. 273 | Qed. 274 | 275 | Lemma converges_to_unique: 276 | forall a b, converges_to a b -> forall b', converges_to a b' -> b = b'. 277 | Proof. 278 | intros a b [n C] b' [n' C']. 279 | rewrite <- (C (max n n')). rewrite <- (C' (max n n')). auto. 280 | apply le_max_r. apply le_max_l. 281 | Qed. 282 | 283 | Lemma converges_to_exists_uniquely: 284 | forall a, exists! b, converges_to a b . 285 | Proof. 286 | intro. destruct (converges_to_exists a) as [b CT]. 287 | exists b. split. assumption. exact (converges_to_unique _ _ CT). 288 | Qed. 289 | 290 | Definition iterate (a: A) : option B := 291 | proj1_sig (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)). 292 | 293 | Lemma converges_to_iterate: 294 | forall a b, converges_to a b -> iterate a = b. 295 | Proof. 296 | intros. unfold iterate. 297 | destruct (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)) as [b' P]. 298 | simpl. apply converges_to_unique with a; auto. 299 | Qed. 300 | 301 | Lemma iterate_converges_to: 302 | forall a, converges_to a (iterate a). 303 | Proof. 304 | intros. unfold iterate. 305 | destruct (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)) as [b' P]. 306 | simpl; auto. 307 | Qed. 308 | 309 | (** Invariance property. *) 310 | 311 | Variable P: A -> Prop. 312 | Variable Q: B -> Prop. 313 | 314 | Hypothesis step_prop: 315 | forall a : A, P a -> 316 | match step a with inl b => Q b | inr a' => P a' end. 317 | 318 | Lemma iter_prop: 319 | forall n a b, P a -> iter n a = Some b -> Q b. 320 | Proof. 321 | induction n; intros until b; intro H; simpl. 322 | congruence. 323 | unfold F_iter. generalize (step_prop a H). 324 | case (step a); intros. congruence. 325 | apply IHn with a0; auto. 326 | Qed. 327 | 328 | Lemma iterate_prop: 329 | forall a b, iterate a = Some b -> P a -> Q b. 330 | Proof. 331 | intros. destruct (iterate_converges_to a) as [n IT]. 332 | rewrite H in IT. apply iter_prop with n a. auto. apply IT. auto. 333 | Qed. 334 | 335 | End ITERATION. 336 | 337 | End GenIter. 338 | -------------------------------------------------------------------------------- /src/coqjit/lib/Ordered.v: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* *) 3 | (* The Compcert verified compiler *) 4 | (* *) 5 | (* Xavier Leroy, INRIA Paris-Rocquencourt *) 6 | (* *) 7 | (* Copyright Institut National de Recherche en Informatique et en *) 8 | (* Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU General Public License as published by *) 10 | (* the Free Software Foundation, either version 2 of the License, or *) 11 | (* (at your option) any later version. This file is also distributed *) 12 | (* under the terms of the INRIA Non-Commercial License Agreement. *) 13 | (* *) 14 | (* *********************************************************************) 15 | 16 | (** Constructions of ordered types, for use with the [FSet] functors 17 | for finite sets and the [FMap] functors for finite maps. *) 18 | 19 | Require Import FSets. 20 | Require Import Coqlib. 21 | Require Import Maps. 22 | (* Require Import Integers. *) 23 | 24 | (** The ordered type of positive numbers *) 25 | 26 | Module OrderedPositive <: OrderedType. 27 | 28 | Definition t := positive. 29 | Definition eq (x y: t) := x = y. 30 | Definition lt := Plt. 31 | 32 | Lemma eq_refl : forall x : t, eq x x. 33 | Proof (@eq_refl t). 34 | Lemma eq_sym : forall x y : t, eq x y -> eq y x. 35 | Proof (@eq_sym t). 36 | Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. 37 | Proof (@eq_trans t). 38 | Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 39 | Proof Plt_trans. 40 | Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. 41 | Proof Plt_ne. 42 | Lemma compare : forall x y : t, Compare lt eq x y. 43 | Proof. 44 | intros. destruct (Pos.compare x y) as [] eqn:E. 45 | apply EQ. red. apply Pos.compare_eq_iff. assumption. 46 | apply LT. assumption. 47 | apply GT. apply Pos.compare_gt_iff. assumption. 48 | Defined. 49 | 50 | Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := peq. 51 | 52 | End OrderedPositive. 53 | 54 | (** The ordered type of integers *) 55 | 56 | (* Module OrderedZ <: OrderedType. *) 57 | 58 | (* Definition t := Z. *) 59 | (* Definition eq (x y: t) := x = y. *) 60 | (* Definition lt := Z.lt. *) 61 | 62 | (* Lemma eq_refl : forall x : t, eq x x. *) 63 | (* Proof (@eq_refl t). *) 64 | (* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *) 65 | (* Proof (@eq_sym t). *) 66 | (* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *) 67 | (* Proof (@eq_trans t). *) 68 | (* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *) 69 | (* Proof Z.lt_trans. *) 70 | (* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *) 71 | (* Proof. unfold lt, eq, t; intros. omega. Qed. *) 72 | (* Lemma compare : forall x y : t, Compare lt eq x y. *) 73 | (* Proof. *) 74 | (* intros. destruct (Z.compare x y) as [] eqn:E. *) 75 | (* apply EQ. red. apply Z.compare_eq_iff. assumption. *) 76 | (* apply LT. assumption. *) 77 | (* apply GT. apply Z.compare_gt_iff. assumption. *) 78 | (* Defined. *) 79 | 80 | (* Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := zeq. *) 81 | 82 | (* End OrderedZ. *) 83 | 84 | (* (** The ordered type of machine integers *) *) 85 | 86 | (* Module OrderedInt <: OrderedType. *) 87 | 88 | (* Definition t := int. *) 89 | (* Definition eq (x y: t) := x = y. *) 90 | (* Definition lt (x y: t) := Int.unsigned x < Int.unsigned y. *) 91 | 92 | (* Lemma eq_refl : forall x : t, eq x x. *) 93 | (* Proof (@eq_refl t). *) 94 | (* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *) 95 | (* Proof (@eq_sym t). *) 96 | (* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *) 97 | (* Proof (@eq_trans t). *) 98 | (* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *) 99 | (* Proof. *) 100 | (* unfold lt; intros. omega. *) 101 | (* Qed. *) 102 | (* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *) 103 | (* Proof. *) 104 | (* unfold lt,eq; intros; red; intros. subst. omega. *) 105 | (* Qed. *) 106 | (* Lemma compare : forall x y : t, Compare lt eq x y. *) 107 | (* Proof. *) 108 | (* intros. destruct (zlt (Int.unsigned x) (Int.unsigned y)). *) 109 | (* apply LT. auto. *) 110 | (* destruct (Int.eq_dec x y). *) 111 | (* apply EQ. auto. *) 112 | (* apply GT. *) 113 | (* assert (Int.unsigned x <> Int.unsigned y). *) 114 | (* red; intros. rewrite <- (Int.repr_unsigned x) in n. rewrite <- (Int.repr_unsigned y) in n. congruence. *) 115 | (* red. omega. *) 116 | (* Defined. *) 117 | 118 | (* Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := Int.eq_dec. *) 119 | 120 | (* End OrderedInt. *) 121 | 122 | (* (** Indexed types (those that inject into [positive]) are ordered. *) *) 123 | 124 | (* Module OrderedIndexed(A: INDEXED_TYPE) <: OrderedType. *) 125 | 126 | (* Definition t := A.t. *) 127 | (* Definition eq (x y: t) := x = y. *) 128 | (* Definition lt (x y: t) := Plt (A.index x) (A.index y). *) 129 | 130 | (* Lemma eq_refl : forall x : t, eq x x. *) 131 | (* Proof (@eq_refl t). *) 132 | (* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *) 133 | (* Proof (@eq_sym t). *) 134 | (* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *) 135 | (* Proof (@eq_trans t). *) 136 | 137 | (* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *) 138 | (* Proof. *) 139 | (* unfold lt; intros. eapply Plt_trans; eauto. *) 140 | (* Qed. *) 141 | 142 | (* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *) 143 | (* Proof. *) 144 | (* unfold lt; unfold eq; intros. *) 145 | (* red; intro. subst y. apply Plt_strict with (A.index x). auto. *) 146 | (* Qed. *) 147 | 148 | (* Lemma compare : forall x y : t, Compare lt eq x y. *) 149 | (* Proof. *) 150 | (* intros. case (OrderedPositive.compare (A.index x) (A.index y)); intro. *) 151 | (* apply LT. exact l. *) 152 | (* apply EQ. red; red in e. apply A.index_inj; auto. *) 153 | (* apply GT. exact l. *) 154 | (* Defined. *) 155 | 156 | (* Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }. *) 157 | (* Proof. *) 158 | (* intros. case (peq (A.index x) (A.index y)); intros. *) 159 | (* left. apply A.index_inj; auto. *) 160 | (* right; red; unfold eq; intros; subst. congruence. *) 161 | (* Defined. *) 162 | 163 | (* End OrderedIndexed. *) 164 | 165 | (* (** The product of two ordered types is ordered. *) *) 166 | 167 | (* Module OrderedPair (A B: OrderedType) <: OrderedType. *) 168 | 169 | (* Definition t := (A.t * B.t)%type. *) 170 | 171 | (* Definition eq (x y: t) := *) 172 | (* A.eq (fst x) (fst y) /\ B.eq (snd x) (snd y). *) 173 | 174 | (* Lemma eq_refl : forall x : t, eq x x. *) 175 | (* Proof. *) 176 | (* intros; split; auto. *) 177 | (* Qed. *) 178 | 179 | (* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *) 180 | (* Proof. *) 181 | (* unfold eq; intros. intuition auto. *) 182 | (* Qed. *) 183 | 184 | (* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *) 185 | (* Proof. *) 186 | (* unfold eq; intros. intuition eauto. *) 187 | (* Qed. *) 188 | 189 | (* Definition lt (x y: t) := *) 190 | (* A.lt (fst x) (fst y) \/ *) 191 | (* (A.eq (fst x) (fst y) /\ B.lt (snd x) (snd y)). *) 192 | 193 | (* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *) 194 | (* Proof. *) 195 | (* unfold lt; intros. *) 196 | (* elim H; elim H0; intros. *) 197 | 198 | (* left. apply A.lt_trans with (fst y); auto. *) 199 | 200 | (* left. elim H1; intros. *) 201 | (* case (A.compare (fst x) (fst z)); intro. *) 202 | (* assumption. *) 203 | (* generalize (A.lt_not_eq H2); intro. elim H5. *) 204 | (* apply A.eq_trans with (fst z). auto. auto. *) 205 | (* generalize (@A.lt_not_eq (fst z) (fst y)); intro. *) 206 | (* elim H5. apply A.lt_trans with (fst x); auto. *) 207 | (* apply A.eq_sym; auto. *) 208 | 209 | (* left. elim H2; intros. *) 210 | (* case (A.compare (fst x) (fst z)); intro. *) 211 | (* assumption. *) 212 | (* generalize (A.lt_not_eq H1); intro. elim H5. *) 213 | (* apply A.eq_trans with (fst x). *) 214 | (* apply A.eq_sym. auto. auto. *) 215 | (* generalize (@A.lt_not_eq (fst y) (fst x)); intro. *) 216 | (* elim H5. apply A.lt_trans with (fst z); auto. *) 217 | (* apply A.eq_sym; auto. *) 218 | 219 | (* right. elim H1; elim H2; intros. *) 220 | (* split. apply A.eq_trans with (fst y); auto. *) 221 | (* apply B.lt_trans with (snd y); auto. *) 222 | (* Qed. *) 223 | 224 | (* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *) 225 | (* Proof. *) 226 | (* unfold lt, eq, not; intros. *) 227 | (* elim H0; intros. *) 228 | (* elim H; intro. *) 229 | (* apply (@A.lt_not_eq _ _ H3 H1). *) 230 | (* elim H3; intros. *) 231 | (* apply (@B.lt_not_eq _ _ H5 H2). *) 232 | (* Qed. *) 233 | 234 | (* Lemma compare : forall x y : t, Compare lt eq x y. *) 235 | (* Proof. *) 236 | (* intros. *) 237 | (* case (A.compare (fst x) (fst y)); intro. *) 238 | (* apply LT. red. left. auto. *) 239 | (* case (B.compare (snd x) (snd y)); intro. *) 240 | (* apply LT. red. right. tauto. *) 241 | (* apply EQ. red. tauto. *) 242 | (* apply GT. red. right. split. apply A.eq_sym. auto. auto. *) 243 | (* apply GT. red. left. auto. *) 244 | (* Defined. *) 245 | 246 | (* Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }. *) 247 | (* Proof. *) 248 | (* unfold eq; intros. *) 249 | (* case (A.eq_dec (fst x) (fst y)); intros. *) 250 | (* case (B.eq_dec (snd x) (snd y)); intros. *) 251 | (* left; auto. *) 252 | (* right; intuition. *) 253 | (* right; intuition. *) 254 | (* Defined. *) 255 | 256 | (* End OrderedPair. *) 257 | 258 | -------------------------------------------------------------------------------- /src/coqjit/lib/Wfsimpl.v: -------------------------------------------------------------------------------- 1 | (* *********************************************************************) 2 | (* *) 3 | (* The Compcert verified compiler *) 4 | (* *) 5 | (* Xavier Leroy, INRIA Paris-Rocquencourt *) 6 | (* *) 7 | (* Copyright Institut National de Recherche en Informatique et en *) 8 | (* Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the GNU General Public License as published by *) 10 | (* the Free Software Foundation, either version 2 of the License, or *) 11 | (* (at your option) any later version. This file is also distributed *) 12 | (* under the terms of the INRIA Non-Commercial License Agreement. *) 13 | (* *) 14 | (* *********************************************************************) 15 | 16 | (** Defining recursive functions by Noetherian induction. This is a simplified 17 | interface to the [Wf] module of Coq's standard library, where the functions 18 | to be defined have non-dependent types, and function extensionality is assumed. *) 19 | 20 | Require Import Axioms. 21 | Require Import Init.Wf. 22 | Require Import Wf_nat. 23 | 24 | Set Implicit Arguments. 25 | 26 | Section FIX. 27 | 28 | Variables A B: Type. 29 | Variable R: A -> A -> Prop. 30 | Hypothesis Rwf: well_founded R. 31 | Variable F: forall (x: A), (forall (y: A), R y x -> B) -> B. 32 | 33 | Definition Fix (x: A) : B := Wf.Fix Rwf (fun (x: A) => B) F x. 34 | 35 | Theorem unroll_Fix: 36 | forall x, Fix x = F (fun (y: A) (P: R y x) => Fix y). 37 | Proof. 38 | unfold Fix; intros. apply Wf.Fix_eq with (P := fun (x: A) => B). 39 | intros. assert (f = g). apply functional_extensionality_dep; intros. 40 | apply functional_extensionality; intros. auto. 41 | subst g; auto. 42 | Qed. 43 | 44 | End FIX. 45 | 46 | (** Same, with a nonnegative measure instead of a well-founded ordering *) 47 | 48 | Section FIXM. 49 | 50 | Variables A B: Type. 51 | Variable measure: A -> nat. 52 | Variable F: forall (x: A), (forall (y: A), measure y < measure x -> B) -> B. 53 | 54 | Definition Fixm (x: A) : B := Wf.Fix (well_founded_ltof A measure) (fun (x: A) => B) F x. 55 | 56 | Theorem unroll_Fixm: 57 | forall x, Fixm x = F (fun (y: A) (P: measure y < measure x) => Fixm y). 58 | Proof. 59 | unfold Fixm; intros. apply Wf.Fix_eq with (P := fun (x: A) => B). 60 | intros. assert (f = g). apply functional_extensionality_dep; intros. 61 | apply functional_extensionality; intros. auto. 62 | subst g; auto. 63 | Qed. 64 | 65 | End FIXM. 66 | 67 | 68 | -------------------------------------------------------------------------------- /src/coqjit/lib/events.v: -------------------------------------------------------------------------------- 1 | (* Observable Behaviors of our programs *) 2 | Require Export String. 3 | Require Export List. 4 | Require Export Maps. 5 | Require Export Coqlib. 6 | Require Export values. 7 | 8 | (* Right now we only send as debug the fuction optimized *) 9 | Inductive debug_info:Type := 10 | | DebugOpt : positive -> debug_info 11 | | DebugString : string -> debug_info. 12 | 13 | (* No event, some debug information, or some printed value *) 14 | Inductive event:Type := 15 | | Debug: debug_info -> event 16 | | Valprint: value -> event 17 | | Stringprint: string -> event 18 | | Loud_Deopt : event (* used for the loud semantics *) 19 | | Loud_Go_on : event. 20 | 21 | (* Traces *) 22 | Definition trace:Type := list event. 23 | Definition E0:trace := nil. 24 | 25 | (* Silent traces. Debug information is also silent: not part of the output *) 26 | Inductive silent: trace -> Prop := 27 | | silent_E0: silent E0 28 | | silent_debug: forall s t, silent t -> silent ((Debug s)::t). 29 | 30 | (* The rest comes from the CompCert Events file *) 31 | Definition Eapp (t1 t2: trace) : trace := t1 ++ t2. 32 | 33 | CoInductive traceinf : Type := 34 | | Econsinf: event -> traceinf -> traceinf. 35 | 36 | Fixpoint Eappinf (t: trace) (T: traceinf) {struct t} : traceinf := 37 | match t with 38 | | nil => T 39 | | ev :: t' => Econsinf ev (Eappinf t' T) 40 | end. 41 | 42 | (** Concatenation of traces is written [**] in the finite case 43 | or [***] in the infinite case. *) 44 | 45 | Infix "**" := Eapp (at level 60, right associativity). 46 | Infix "***" := Eappinf (at level 60, right associativity). 47 | 48 | Lemma E0_left: forall t, E0 ** t = t. 49 | Proof. auto. Qed. 50 | 51 | Lemma E0_right: forall t, t ** E0 = t. 52 | Proof. intros. unfold E0, Eapp. rewrite <- app_nil_end. auto. Qed. 53 | 54 | Lemma Eapp_assoc: forall t1 t2 t3, (t1 ** t2) ** t3 = t1 ** (t2 ** t3). 55 | Proof. intros. unfold Eapp, trace. apply app_ass. Qed. 56 | 57 | Lemma Eapp_E0_inv: forall t1 t2, t1 ** t2 = E0 -> t1 = E0 /\ t2 = E0. 58 | Proof (@app_eq_nil event). 59 | 60 | Lemma E0_left_inf: forall T, E0 *** T = T. 61 | Proof. auto. Qed. 62 | 63 | Lemma Eappinf_assoc: forall t1 t2 T, (t1 ** t2) *** T = t1 *** (t2 *** T). 64 | Proof. 65 | induction t1; intros; simpl. auto. decEq; auto. 66 | Qed. 67 | 68 | Hint Rewrite E0_left E0_right Eapp_assoc 69 | E0_left_inf Eappinf_assoc: trace_rewrite. 70 | 71 | Opaque trace E0 Eapp Eappinf. 72 | 73 | (** The following [traceEq] tactic proves equalities between traces 74 | or infinite traces. *) 75 | 76 | Ltac substTraceHyp := 77 | match goal with 78 | | [ H: (@eq trace ?x ?y) |- _ ] => 79 | subst x || clear H 80 | end. 81 | 82 | Ltac decomposeTraceEq := 83 | match goal with 84 | | [ |- (_ ** _) = (_ ** _) ] => 85 | apply (f_equal2 Eapp); auto; decomposeTraceEq 86 | | _ => 87 | auto 88 | end. 89 | 90 | Ltac traceEq := 91 | repeat substTraceHyp; autorewrite with trace_rewrite; decomposeTraceEq. 92 | 93 | (** Bisimilarity between infinite traces. *) 94 | 95 | CoInductive traceinf_sim: traceinf -> traceinf -> Prop := 96 | | traceinf_sim_cons: forall e T1 T2, 97 | traceinf_sim T1 T2 -> 98 | traceinf_sim (Econsinf e T1) (Econsinf e T2). 99 | 100 | Lemma traceinf_sim_refl: 101 | forall T, traceinf_sim T T. 102 | Proof. 103 | cofix COINDHYP; intros. 104 | destruct T. constructor. apply COINDHYP. 105 | Qed. 106 | 107 | Lemma traceinf_sim_sym: 108 | forall T1 T2, traceinf_sim T1 T2 -> traceinf_sim T2 T1. 109 | Proof. 110 | cofix COINDHYP; intros. inv H; constructor; auto. 111 | Qed. 112 | 113 | Lemma traceinf_sim_trans: 114 | forall T1 T2 T3, 115 | traceinf_sim T1 T2 -> traceinf_sim T2 T3 -> traceinf_sim T1 T3. 116 | Proof. 117 | cofix COINDHYP;intros. inv H; inv H0; constructor; eauto. 118 | Qed. 119 | 120 | CoInductive traceinf_sim': traceinf -> traceinf -> Prop := 121 | | traceinf_sim'_cons: forall t T1 T2, 122 | t <> E0 -> traceinf_sim' T1 T2 -> traceinf_sim' (t *** T1) (t *** T2). 123 | 124 | Lemma traceinf_sim'_sim: 125 | forall T1 T2, traceinf_sim' T1 T2 -> traceinf_sim T1 T2. 126 | Proof. 127 | cofix COINDHYP; intros. inv H. 128 | destruct t. elim H0; auto. 129 | Transparent Eappinf. 130 | Transparent E0. 131 | simpl. 132 | destruct t. simpl. constructor. apply COINDHYP; auto. 133 | constructor. apply COINDHYP. 134 | constructor. unfold E0; congruence. auto. 135 | Qed. 136 | 137 | (** An alternate presentation of infinite traces as 138 | infinite concatenations of nonempty finite traces. *) 139 | 140 | CoInductive traceinf': Type := 141 | | Econsinf': forall (t: trace) (T: traceinf'), t <> E0 -> traceinf'. 142 | 143 | Program Definition split_traceinf' (t: trace) (T: traceinf') (NE: t <> E0): event * traceinf' := 144 | match t with 145 | | nil => _ 146 | | e :: nil => (e, T) 147 | | e :: t' => (e, Econsinf' t' T _) 148 | end. 149 | Next Obligation. 150 | elimtype False. elim NE. auto. 151 | Qed. 152 | Next Obligation. 153 | red; intro. elim (H e). rewrite H0. auto. 154 | Qed. 155 | 156 | CoFixpoint traceinf_of_traceinf' (T': traceinf') : traceinf := 157 | match T' with 158 | | Econsinf' t T'' NOTEMPTY => 159 | let (e, tl) := split_traceinf' t T'' NOTEMPTY in 160 | Econsinf e (traceinf_of_traceinf' tl) 161 | end. 162 | 163 | Remark unroll_traceinf': 164 | forall T, T = match T with Econsinf' t T' NE => Econsinf' t T' NE end. 165 | Proof. 166 | intros. destruct T; auto. 167 | Qed. 168 | 169 | Remark unroll_traceinf: 170 | forall T, T = match T with Econsinf t T' => Econsinf t T' end. 171 | Proof. 172 | intros. destruct T; auto. 173 | Qed. 174 | 175 | Lemma traceinf_traceinf'_app: 176 | forall t T NE, 177 | traceinf_of_traceinf' (Econsinf' t T NE) = t *** traceinf_of_traceinf' T. 178 | Proof. 179 | induction t. 180 | intros. elim NE. auto. 181 | intros. simpl. 182 | rewrite (unroll_traceinf (traceinf_of_traceinf' (Econsinf' (a :: t) T NE))). 183 | simpl. destruct t. auto. 184 | Transparent Eappinf. 185 | simpl. f_equal. apply IHt. 186 | Qed. 187 | 188 | (** Prefixes of traces. *) 189 | 190 | Definition trace_prefix (t1 t2: trace) := 191 | exists t3, t2 = t1 ** t3. 192 | 193 | Definition traceinf_prefix (t1: trace) (T2: traceinf) := 194 | exists T3, T2 = t1 *** T3. 195 | 196 | Lemma trace_prefix_app: 197 | forall t1 t2 t, 198 | trace_prefix t1 t2 -> 199 | trace_prefix (t ** t1) (t ** t2). 200 | Proof. 201 | intros. destruct H as [t3 EQ]. exists t3. traceEq. 202 | Qed. 203 | 204 | Lemma traceinf_prefix_app: 205 | forall t1 T2 t, 206 | traceinf_prefix t1 T2 -> 207 | traceinf_prefix (t ** t1) (t *** T2). 208 | Proof. 209 | intros. destruct H as [T3 EQ]. exists T3. subst T2. traceEq. 210 | Qed. 211 | 212 | (* match_traces *) 213 | (* without external worlds, this is just equality *) 214 | (* to allow determinacy, you would need another definition *) 215 | (* This should correspond to traces of single transitions -> from CompCert *) 216 | (* This only used for the fwd to bwd proof, for loud semantics *) 217 | Inductive match_traces: trace -> trace -> Prop := 218 | | match_traces_E0: 219 | match_traces nil nil 220 | | match_traces_same: 221 | forall e, 222 | match_traces (e::nil) (e::nil) 223 | | match_traces_loud: 224 | match_traces (Loud_Go_on::nil) (Loud_Deopt::nil) 225 | | match_traces_loud2: 226 | match_traces (Loud_Deopt::nil) (Loud_Go_on::nil). 227 | 228 | 229 | (** An output trace is a trace composed only of output events, 230 | that is, events that do not take any result from the outside world. *) 231 | 232 | Definition output_event (ev: event) : Prop := 233 | match ev with 234 | | Valprint _ => True 235 | | Stringprint _ => True 236 | | Debug _ => True 237 | | Loud_Deopt => True 238 | | Loud_Go_on => True 239 | end. 240 | 241 | Fixpoint output_trace (t: trace) : Prop := 242 | match t with 243 | | nil => True 244 | | ev :: t' => output_event ev /\ output_trace t' 245 | end. 246 | -------------------------------------------------------------------------------- /src/coqjit/lib/values.v: -------------------------------------------------------------------------------- 1 | (* The values of our language *) 2 | 3 | Require Export Coqlib. 4 | 5 | (* Values stored inside registers and inside the memory *) 6 | Inductive value : Type := 7 | | Vint : Z -> value. 8 | -------------------------------------------------------------------------------- /src/coqjit/lowering.v: -------------------------------------------------------------------------------- 1 | (* Lowering: remove framestates, keep assume instruction *) 2 | (* Lowers programs into our final intermediate representation *) 3 | (* This is the last pass of the dynamic optimizer *) 4 | 5 | Require Export List. 6 | Require Export Coqlib. 7 | Require Export Maps. 8 | Require Export specIR. 9 | 10 | 11 | (* Framestates are replaced with Nop *) 12 | Definition transf_instr (i:instruction) : instruction := 13 | match i with 14 | | Framestate _ _ _ next => Nop None next 15 | | _ => i 16 | end. 17 | 18 | (* replace each instruction in the code *) 19 | Definition lowering_code (c:code) : code := 20 | PTree.map1 transf_instr c. 21 | 22 | (* Keeping the same entry point *) 23 | Definition lowering_version (v:version) : version := 24 | mk_version (lowering_code (ver_code v)) (ver_entry v). 25 | 26 | Definition lowering_function (f:function) : function := 27 | match (fn_opt f) with 28 | | None => f 29 | | Some vopt => 30 | mk_function (fn_params f) (fn_base f) (Some (lowering_version vopt)) (base_no_spec f) 31 | end. 32 | 33 | (* We lower the entire program *) 34 | (* We could only lower the modified versions for more efficiency *) 35 | Definition lowering (p:program): program := 36 | mk_program (prog_main p) 37 | (PTree.map1 lowering_function (prog_funlist p)). 38 | -------------------------------------------------------------------------------- /src/coqjit/main.ml: -------------------------------------------------------------------------------- 1 | (* Looping the extracted jit_step function *) 2 | open Common 3 | open BinNums 4 | open Maps 5 | open Values 6 | open SpecIR 7 | open Interpreter 8 | open Jit 9 | open Printf 10 | open Printer 11 | open Camlcoq 12 | open Ast 13 | open Lexer 14 | open Lexing 15 | open Memory 16 | 17 | 18 | (* Parsing and Lexing functions *) 19 | (* https://v1.realworldocaml.org/v1/en/html/parsing-with-ocamllex-and-menhir.html *) 20 | let print_position outx lexbuf = 21 | let pos = lexbuf.lex_curr_p in 22 | fprintf outx "%s:%d:%d" pos.pos_fname 23 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 24 | 25 | let parse_with_error lexbuf = 26 | try Parser.prog Lexer.read lexbuf with 27 | | SyntaxError msg -> 28 | fprintf stderr "%a: %s\n" print_position lexbuf msg; 29 | None 30 | | Parser.Error -> 31 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 32 | exit (-1) 33 | 34 | 35 | exception Return of (value*jit_state) 36 | exception RunTimeErr of (string*jit_state) 37 | 38 | let get_program filename: program = 39 | let inx = open_in filename in 40 | let lexbuf = Lexing.from_channel inx in 41 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 42 | let (apo:Ast.aprogram option) = parse_with_error lexbuf in 43 | match apo with 44 | | None -> let _ = close_in inx in failwith "Failed to parse a program" 45 | | Some ap -> let _ = close_in inx in Ast.convert_program ap 46 | 47 | let get_lua_program filename: program = 48 | Frontend.compile filename 49 | 50 | 51 | (* Looping the jit step *) 52 | let rec jit_main (s:jit_state) = 53 | match (Jit.jit_step s) with 54 | | Error mess -> raise (RunTimeErr (mess, s)) 55 | | OK (nexts, t) -> 56 | let _ = print_trace t in 57 | match (jit_final_value nexts) with 58 | | None -> jit_main nexts (* recursive call *) 59 | | Some v -> raise (Return (v, nexts)) 60 | 61 | let print_debug_program = ref false;; 62 | 63 | (* Initializing and executing the JIT *) 64 | let jit (p:program) = 65 | if (!print_debug_program) then begin 66 | let _ = Printf.printf ("\027[96mInput Program:\027[0m \n%s\n%!") (print_program p) in 67 | Printf.printf ("\027[96mStarting the JIT\027[0m\n%!") 68 | end; 69 | match initial_jit_state p with 70 | | Error mess -> Printf.printf ("\027[33mInitialization Error:\027[0m %s\n") mess 71 | | OK js -> try jit_main js with 72 | Return (v,js) -> begin 73 | Printf.printf ("\027[33mEnd of execution, final value is:\027[0m %s\n") (print_value v); 74 | if (!print_debug_program) then 75 | Printf.printf ("\027[96mFinal Program:\027[0m \n%s\n") (print_program js.prog) 76 | end 77 | | RunTimeErr (e,js) -> begin 78 | Printf.printf ("\027[33mRun-Time Error:\027[0m %s\n%!") e; 79 | if (!print_debug_program) then 80 | Printf.printf ("\027[96mFinal JIT Program:\027[0m \n%s\n") (print_program js.prog) 81 | end 82 | ;; 83 | 84 | (* provide a re-entry hook for the jit *) 85 | Native_prim.jit_main_hook := function state -> 86 | try jit_main state with 87 | | Return (v,p) -> (v,p) 88 | | RunTimeErr _ as ex -> raise ex 89 | ;; 90 | Native.init () 91 | 92 | let main = 93 | let path = ref "" in 94 | let enable_lua = ref false in 95 | let cmd_args = [ 96 | ("-o", Arg.Set Printer.print_debug_opt_fun, "Print Optimized Functions"); 97 | ("-s", Arg.Set Printer.print_debug_strings, "Print Debug Strings"); 98 | ("-p", Arg.Set print_debug_program, "Print Debug Program"); 99 | ("-k", Arg.Set Flags.disable_profiler_hints, "Disable profiler using hints"); 100 | ("-n", Arg.Set Flags.enable_native, "Enable unverified native backend"); 101 | ("-f", Arg.Set enable_lua, "Enable unverified lua frontend"); 102 | ("-t", Arg.Set Flags.enable_frontend_assert, "Enable asserts in frontend"); 103 | ("-d", Arg.Set Flags.print_debug_native, "Print Native Debugging"); 104 | ("-a", Arg.Set Flags.print_debug_native_code, "Print Native Code"); 105 | ("-m", Arg.Set Flags.print_debug_native_heap, "Print Native Heap"); 106 | ("-c", Arg.Set Flags.native_call_always_jit_loop, "Native call always goes through jit_step, even when calling optimized code"); 107 | ] in 108 | let usage () = 109 | Printf.printf "%s" "\027[91mPlease use the jit executable on exactly one argument: the program to execute\027[0m\n\027[33m Example: \027[0m ./jit progs/fact1.jitir\n"; 110 | Arg.usage cmd_args "Options:" 111 | in 112 | 113 | Arg.parse cmd_args (fun s -> 114 | if !path <> "" then raise (Arg.Bad ("Invalid argument "^s)); 115 | path := s) "Options:"; 116 | if !path = "" then ( 117 | usage (); 118 | exit 1); 119 | let p = (if (!enable_lua) then get_lua_program else get_program) !path in jit p 120 | -------------------------------------------------------------------------------- /src/coqjit/memory.ml: -------------------------------------------------------------------------------- 1 | (* Implementations of the memory *) 2 | 3 | open Bigarray 4 | open Common 5 | open BinNums 6 | open Maps 7 | open Values 8 | 9 | (* A first implementation of the memory *) 10 | (* Load and Store fail on non-strictly positive values *) 11 | type mem_state = value PTree.t 12 | let initial_memory : mem_state = PTree.empty 13 | 14 | (* The native heap *) 15 | let heap_limit = 300 16 | let heap = Array1.create Bigarray.int64 Bigarray.c_layout (heap_limit+1) 17 | 18 | let load_ (ms:mem_state) (addr:value): value option = 19 | let load () = 20 | match addr with 21 | | Zneg _ -> None 22 | | Z0 -> None 23 | | Zpos p -> PTree.get p ms 24 | in 25 | if !Flags.enable_native 26 | then (assert (ms = initial_memory); 27 | Some (Conv.val_of_int64 heap.{Conv.int_of_val addr})) 28 | else load () 29 | 30 | let store_ (ms:mem_state) (addr:value) (v:value): mem_state option = 31 | let store () = 32 | match addr with 33 | | Zneg _ -> None 34 | | Z0 -> None 35 | | Zpos p -> Some (PTree.set p v ms) 36 | in 37 | if !Flags.enable_native 38 | then (assert (ms = initial_memory); 39 | heap.{Conv.int_of_val addr} <- (Conv.int64_of_val v); 40 | Some ms) 41 | else store () 42 | -------------------------------------------------------------------------------- /src/coqjit/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin;; 2 | 3 | ocaml_lib ~extern:true "llvm";; 4 | ocaml_lib ~extern:true "llvm_analysis";; 5 | ocaml_lib ~extern:true "llvm_target"; 6 | ocaml_lib ~extern:true "llvm_executionengine"; 7 | ocaml_lib ~extern:true "llvm_scalar_opts"; 8 | -------------------------------------------------------------------------------- /src/coqjit/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "coqjit" 3 | version: "~dev" 4 | synopsis: "JIT me correct" 5 | maintainer: "Aurele-Barriere" 6 | authors: ["Aurele-Barriere"] 7 | license: "whatever" 8 | homepage: "https://github.com/Aurele-Barriere/CoreJIT" 9 | dev-repo: "git://git@github.com/Aurele-Barriere/CoreJIT.git" 10 | bug-reports: "https://github.com/Aurele-Barriere/CoreJIT/issues" 11 | depends: [ 12 | "coq" {="8.11.2"} 13 | "ocaml" {<"4.10.0" >="4.07"} 14 | "ocamlbuild" 15 | "menhir" 16 | "ctypes" 17 | "ctypes-foreign" 18 | "llvm" {="9.0.0"} 19 | ] 20 | build: [ 21 | [make] 22 | ] 23 | -------------------------------------------------------------------------------- /src/coqjit/optimizer.v: -------------------------------------------------------------------------------- 1 | (* Optimizer: creates new optimized versions of programs *) 2 | 3 | Require Export List. 4 | Require Export Coqlib. 5 | Require Export Maps. 6 | Require Export specIR. 7 | Require Export interpreter. 8 | Require Export framestate_insertion. 9 | Require Export assume_insertion. 10 | Require Export assume_insertion_delay. 11 | Require Export lowering. 12 | Require Export const_prop. 13 | Require Export inlining. 14 | Require Export profiler_types. 15 | 16 | (* Profiler state external type *) 17 | Parameter profiler_state: Type. 18 | 19 | (* Optimization heuristics *) 20 | Parameter framestates_to_insert : profiler_state -> program -> list (fun_id * (list label)). (* First we insert framestates at various labels *) 21 | Parameter optim_list : profiler_state -> program -> list (fun_id * optim_wish). 22 | (* a list of optims to perform on a given function *) 23 | 24 | (* Inserting Framestates in all functions according to the profiler wish *) 25 | Fixpoint process_fs_list (p:program) (l:list (fun_id * list label)): program := 26 | match l with 27 | | nil => p 28 | | (fid, fs_lbl)::l' => process_fs_list (safe_insert_framestate p fid fs_lbl) l' 29 | end. 30 | 31 | (* Processing each optimization sugeested by the profiler *) 32 | (* Using the safe optimizations: if one fails, it is just ignored by the optimizer *) 33 | Fixpoint process_optim_list (p:program) (l:list (fun_id * optim_wish)): program := 34 | match l with 35 | | nil => p 36 | | (fid, AS_INS le fs_lbl)::l' => process_optim_list (safe_insert_assume p fid le fs_lbl) l' 37 | | (fid, AS_INS_DELAY le fs_lbl)::l' => process_optim_list (safe_insert_assume_delay p fid le fs_lbl) l' 38 | | (fid, CST_PROP)::l' => process_optim_list (safe_constant_propagation p fid) l' 39 | | (fid, INLINE call_lbl)::l' => process_optim_list (safe_optimize_inline fid call_lbl p) l' 40 | | (_, LOWER)::l' => process_optim_list (lowering p) l' 41 | end. 42 | 43 | 44 | Definition optimize (ps:profiler_state) (p:program): res program := 45 | do optims <- OK (optim_list ps p); 46 | do fs_list <- OK (framestates_to_insert ps p); 47 | do pfs <- OK (process_fs_list p fs_list); 48 | do newp <- OK (process_optim_list pfs optims); 49 | OK (lowering newp). 50 | 51 | (* An error in optimization should not stop the execution *) 52 | Definition safe_optimize (ps:profiler_state) (p:program): program := 53 | safe_res (optimize ps) p. 54 | 55 | 56 | (** * Testing optimizations *) 57 | (* This is not used by the JIT, simply used for testing the optimizations with safety off *) 58 | Fixpoint unsafe_fs_list (p:program) (l:list (fun_id * list label)): res program := 59 | match l with 60 | | nil => OK p 61 | | (fid, fs_lbl)::l' => 62 | do newp <- insert_framestate fid fs_lbl p; 63 | unsafe_fs_list newp l' 64 | end. 65 | 66 | Fixpoint unsafe_wishes (p:program) (l:list (fun_id * optim_wish)): res program := 67 | match l with 68 | | nil => OK p 69 | | (fid, AS_INS le fs_lbl)::l' => 70 | do newp <- insert_assume fid le fs_lbl p; 71 | unsafe_wishes newp l' 72 | | (fid, AS_INS_DELAY le fs_lbl)::l' => 73 | do newp <- insert_assume_delay fid le fs_lbl p; 74 | unsafe_wishes newp l' 75 | | (fid, CST_PROP)::l' => 76 | do newp <- constant_propagation fid p; 77 | unsafe_wishes newp l' 78 | | (fid, INLINE call_lbl)::l' => 79 | do newp <- optimize_inline fid call_lbl p; 80 | unsafe_wishes newp l' 81 | | (_, LOWER)::l' => 82 | do newp <- OK (lowering p); 83 | unsafe_wishes newp l' 84 | end. 85 | 86 | Definition test_optimizer (p:program) (fs_list: list (fun_id * (list label))) (wishes:list (fun_id * optim_wish)) : res program := 87 | do fsp <- unsafe_fs_list p fs_list; 88 | unsafe_wishes fsp wishes. 89 | -------------------------------------------------------------------------------- /src/coqjit/optimizer_proof.v: -------------------------------------------------------------------------------- 1 | (* Correctness proof of the middle-end JIT dynamic optimizer *) 2 | (* The final proof is an internal backward simulation *) 3 | (* It is obtained via composing the backward simulations of each pass *) 4 | 5 | Require Export optimizer. 6 | Require Export framestate_insertion_proof. 7 | Require Export const_prop_proof. 8 | Require Export lowering_proof. 9 | Require Export inlining_proof. 10 | Require Export assume_insertion_proof. 11 | Require Export assume_insertion_delay_proof. 12 | Require Export internal_simulations. 13 | 14 | (* Optimizations are "safe" if they return the original program instead of a crash *) 15 | (* Here we exploit the safety to show that we always return a simulated program *) 16 | Lemma safe_backward: 17 | forall (p:program) (opt:program -> res program) 18 | (OPT_OK: forall p', opt p = OK p' -> backward_internal_simulation p p'), 19 | backward_internal_simulation p (safe_res opt p). 20 | Proof. 21 | intros p opt OPT_OK. 22 | unfold safe_res. destruct (opt p) eqn:OPT. 23 | - specialize (OPT_OK p0 eq_refl). auto. 24 | - apply backward_internal_reflexivity. 25 | Qed. 26 | 27 | Lemma safe_constprop: 28 | forall p fid, 29 | backward_internal_simulation p (safe_constant_propagation p fid). 30 | Proof. 31 | intros p fid. unfold safe_constant_propagation. apply safe_backward. intros p' H. 32 | eapply constprop_correct; eauto. 33 | Qed. 34 | 35 | Lemma safe_assume: 36 | forall p fid le fs_lbl, 37 | backward_internal_simulation p (safe_insert_assume p fid le fs_lbl). 38 | Proof. 39 | intros p fid le fs_lbl. unfold safe_insert_assume. apply safe_backward. intros p' H. 40 | eapply assume_insertion_correct. eauto. 41 | Qed. 42 | 43 | Lemma safe_assume_delay: 44 | forall p fid le fs_lbl, 45 | backward_internal_simulation p (safe_insert_assume_delay p fid le fs_lbl). 46 | Proof. 47 | intros p fid le fs_lbl. unfold safe_insert_assume_delay. apply safe_backward. intros p' H. 48 | eapply assume_delay_correct. eauto. 49 | Qed. 50 | 51 | Lemma safe_inline: 52 | forall p fid call_lbl, 53 | backward_internal_simulation p (safe_optimize_inline fid call_lbl p). 54 | intros p fid call_lbl. unfold safe_optimize_inline. apply safe_backward. intros p' H. 55 | eapply inlining_correct. eauto. 56 | Qed. 57 | 58 | Lemma safe_framestate: 59 | forall p fid lbllist, 60 | backward_internal_simulation p (safe_insert_framestate p fid lbllist). 61 | Proof. 62 | intros p fid lbllist. unfold safe_insert_framestate. apply safe_backward. intros p' H. 63 | eapply framestate_insertion_correct. eauto. 64 | Qed. 65 | 66 | Lemma safe_framestate_list: 67 | forall p fsl, 68 | backward_internal_simulation p (process_fs_list p fsl). 69 | Proof. 70 | intros. generalize dependent p. induction fsl; simpl; intros. 71 | - apply backward_internal_reflexivity. 72 | - destruct a. eapply compose_backward_simulation. apply specir_single_events. 73 | eapply safe_framestate. eapply IHfsl. 74 | Qed. 75 | 76 | (* Each optimization pass preserves an internal backward simulation *) 77 | Lemma opt_list_backward: 78 | forall lopt p, 79 | backward_internal_simulation p (process_optim_list p lopt). 80 | Proof. 81 | intros lopt. induction lopt; intros. 82 | - simpl. apply backward_internal_reflexivity. 83 | - simpl. destruct a as [fid optw]. destruct optw. 84 | + eapply compose_backward_simulation. apply specir_single_events. 85 | eapply safe_assume. eapply IHlopt. 86 | + eapply compose_backward_simulation. apply specir_single_events. 87 | eapply safe_assume_delay. eapply IHlopt. 88 | + eapply compose_backward_simulation. apply specir_single_events. 89 | eapply safe_constprop. eapply IHlopt. 90 | + eapply compose_backward_simulation. apply specir_single_events. 91 | eapply safe_inline. eapply IHlopt. 92 | + eapply compose_backward_simulation. apply specir_single_events. 93 | eapply lowering_correct; eauto. eapply IHlopt. 94 | Qed. 95 | 96 | (* The entire optimization process returns a simulated program *) 97 | Lemma safe_optimize_correct: 98 | forall p ps newp, 99 | safe_optimize ps p = newp -> 100 | backward_internal_simulation p newp. 101 | Proof. 102 | intros p ps newp SAFEOPT. unfold safe_optimize in SAFEOPT. rewrite <- SAFEOPT. apply safe_backward. 103 | intros p' OPT. clear SAFEOPT. 104 | unfold optimize in OPT. repeat do_ok. inv HDO. 105 | eapply compose_backward_simulation. apply specir_single_events. 106 | 2: { eapply lowering_correct; eauto. } 107 | eapply compose_backward_simulation. apply specir_single_events. 108 | apply safe_framestate_list. 109 | apply opt_list_backward. 110 | Qed. 111 | -------------------------------------------------------------------------------- /src/coqjit/params.ml: -------------------------------------------------------------------------------- 1 | (* Realizing a few JIT parameters that are not part of the profiler *) 2 | open Datatypes 3 | open BinPos 4 | open BinNums 5 | open Values 6 | 7 | (* don't use on negative numbers *) 8 | let rec make_nat (x:int) : Datatypes.nat = 9 | if x = 0 then O else S (make_nat (x-1)) 10 | 11 | (* JIT Parameters *) 12 | let max_optim = make_nat 10 13 | let interpreter_fuel = make_nat 100 14 | 15 | (* Heuristics for the spacing of label and finding fresh_labels *) 16 | let fuel_fresh = make_nat 3 17 | let spacing = Coq_xI Coq_xH 18 | 19 | (* Realizing the hint Type *) 20 | type hint = 21 | | Hint_Eq of (positive * positive) (* speculating on equality between 2 registers *) 22 | | Hint_Eq_val of (positive * value) (* speculating on the value of a register *) 23 | -------------------------------------------------------------------------------- /src/coqjit/parsing/ast.ml: -------------------------------------------------------------------------------- 1 | (* AST of a program and transformation to an IR program *) 2 | open Common 3 | open Values 4 | open SpecIR 5 | open BinNums 6 | open BinPos 7 | open Camlcoq 8 | open Maps 9 | 10 | (* AST is just like IR, except it uses int instead of Coq positive, and no records *) 11 | (* And using lists instead of PTrees *) 12 | type abinop = 13 | | Aplus 14 | | Aminus 15 | | Amult 16 | | Agt 17 | | Alt 18 | | Ageq 19 | | Aleq 20 | | Aeq 21 | 22 | type aunop = 23 | | Auminus 24 | | Aneg 25 | | Aassign 26 | 27 | type acst = int 28 | 29 | type areg = int 30 | 31 | type aop = 32 | | Acsti of acst 33 | | Areg of areg 34 | 35 | type aexpr = 36 | | Abinexpr of abinop * aop * aop 37 | | Aunexpr of aunop * aop 38 | 39 | type alabel = int 40 | 41 | type afun_id = int 42 | 43 | type adeopt_target = afun_id * alabel 44 | 45 | type amovelist = (areg * aexpr) list 46 | 47 | type avarmap = (areg * aexpr) list 48 | 49 | type asynth_frame = adeopt_target * areg * avarmap 50 | 51 | type ahint = 52 | | Ahint_eq of (areg * areg) 53 | | Ahint_eq_val of (areg * acst) 54 | 55 | type ainstruction = 56 | | Anop of ahint option * alabel 57 | | Aop of aexpr * areg * alabel 58 | | Amove of amovelist * alabel 59 | | Acall of afun_id * aexpr list * areg * alabel 60 | | Aireturn of aexpr 61 | | Acond of aexpr * alabel * alabel 62 | | Astore of aexpr * aexpr * alabel 63 | | Aload of aexpr * areg * alabel 64 | | Aprintexpr of aexpr * alabel 65 | | Aprintstring of string * alabel 66 | | Aframestate of adeopt_target * avarmap * asynth_frame list * alabel 67 | | Aassume of aexpr list * adeopt_target * avarmap * asynth_frame list * alabel 68 | | Afail of string 69 | 70 | type anode = alabel * ainstruction 71 | 72 | type aversion_decl = alabel * anode list 73 | 74 | type afun_decl = afun_id * areg list * aversion_decl * aversion_decl option 75 | 76 | type aprogram = afun_id * afun_decl list 77 | 78 | (* Convert Ocaml int to Coq positive *) 79 | (* We assume that the argument is a strictly positive integer *) 80 | let pos_of_int (i:int): positive = 81 | P.of_int i 82 | 83 | let z_of_int (i:int) = 84 | Z.of_sint i 85 | 86 | let convert_binop (ab:abinop): bin_operation = 87 | match ab with 88 | | Aplus -> Plus 89 | | Aminus -> Minus 90 | | Amult -> Mult 91 | | Agt -> Gt 92 | | Alt -> Lt 93 | | Ageq -> Geq 94 | | Aleq -> Leq 95 | | Aeq -> Eq 96 | 97 | let convert_unop (au:aunop): un_operation = 98 | match au with 99 | | Auminus -> UMinus 100 | | Aneg -> Neg 101 | | Aassign -> Assign 102 | 103 | let convert_lbl = pos_of_int 104 | let convert_reg = pos_of_int 105 | 106 | let convert_op (ao:aop): op = 107 | match ao with 108 | | Acsti c -> Cst ((z_of_int c)) 109 | | Areg r -> Reg (pos_of_int r) 110 | 111 | let convert_expr (ae:aexpr): expr = 112 | match ae with 113 | | Abinexpr (b,o1,o2) -> Binexpr (convert_binop b, convert_op o1, convert_op o2) 114 | | Aunexpr (u,o) -> Unexpr (convert_unop u, convert_op o) 115 | 116 | let convert_exprlist (el:aexpr list): expr list = 117 | List.map convert_expr el 118 | 119 | let convert_varmap (vm:avarmap): varmap = 120 | List.map (fun (r,e) -> ((convert_reg r),(convert_expr e))) vm 121 | 122 | let convert_movelist (ml:amovelist): movelist = 123 | List.map (fun (r,e) -> ((convert_reg r),(convert_expr e))) ml 124 | 125 | let convert_target (at:adeopt_target): deopt_target = 126 | match at with 127 | | (afid, albl) -> (pos_of_int afid, convert_lbl albl) 128 | 129 | let convert_frame ((tgt,r,vm):asynth_frame) = 130 | ((convert_target tgt, convert_reg r), convert_varmap vm) 131 | 132 | let convert_synthlist (sl:asynth_frame list) = 133 | List.map convert_frame sl 134 | 135 | let convert_hint (h:ahint): hint = 136 | match h with 137 | | Ahint_eq (r1,r2) -> Hint_Eq (convert_reg r1, convert_reg r2) 138 | | Ahint_eq_val (r1,v2) -> Hint_Eq_val (convert_reg r1, z_of_int v2) 139 | 140 | let convert_instr (ai:ainstruction): instruction = 141 | match ai with 142 | | Anop (None,l) -> Nop (None,convert_lbl l) 143 | | Anop (Some ah, l) -> Nop (Some (convert_hint ah), convert_lbl l) 144 | | Aop (e,r,l) -> Op (convert_expr e, convert_reg r, convert_lbl l) 145 | | Amove (ml, l) -> Move (convert_movelist ml, convert_lbl l) 146 | | Acall (f,el,r,l) -> Call(pos_of_int f, convert_exprlist el, convert_reg r, convert_lbl l) 147 | | Aireturn (e) -> IReturn(convert_expr e) 148 | | Acond (e,l1,l2) -> Cond(convert_expr e, convert_lbl l1, convert_lbl l2) 149 | | Astore (e1,e2,l) -> Store(convert_expr e1, convert_expr e2, convert_lbl l) 150 | | Aload (e,r,l) -> Load(convert_expr e, convert_reg r, convert_lbl l) 151 | | Aprintexpr(e,l) -> Printexpr(convert_expr e, convert_lbl l) 152 | | Aprintstring(str,l) -> Printstring(str, convert_lbl l) 153 | | Aframestate(tgt,vm,sl,next) -> Framestate(convert_target tgt, convert_varmap vm, convert_synthlist sl, convert_lbl next) 154 | | Aassume(el,tgt,vm,sl,next) -> Assume(convert_exprlist el,convert_target tgt, convert_varmap vm, convert_synthlist sl,convert_lbl next) 155 | | Afail s -> Fail s 156 | 157 | let rec convert_code (anl:anode list): code = 158 | match anl with 159 | | [] -> PTree.empty 160 | | (l,i)::anl' -> PTree.set (convert_lbl l) (convert_instr i) (convert_code anl') 161 | 162 | let convert_version ((lbl,anl):aversion_decl): version = 163 | { ver_code = convert_code anl; ver_entry = convert_lbl lbl } 164 | 165 | let convert_version_option (verop:aversion_decl option): version option= 166 | match verop with 167 | | None -> None 168 | | Some v -> Some (convert_version v) 169 | 170 | let convert_function ((f,rl,base,optop):afun_decl): coq_function = 171 | { fn_params = List.map convert_reg rl; 172 | fn_base = convert_version base; 173 | fn_opt = convert_version_option optop 174 | } 175 | 176 | let id_function ((f,rl,vid,avl):afun_decl): fun_id = 177 | pos_of_int f 178 | 179 | (* Transform an AST into a program *) 180 | let convert_program ((main,funlist):aprogram) : program = 181 | { prog_main = pos_of_int main; 182 | prog_funlist = List.fold_left 183 | (fun t af -> PTree.set (id_function af) (convert_function af) t) 184 | PTree.empty funlist } 185 | -------------------------------------------------------------------------------- /src/coqjit/parsing/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Parser 4 | 5 | exception SyntaxError of string 6 | 7 | let next_line lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | lexbuf.lex_curr_p <- 10 | { pos with pos_bol = lexbuf.lex_curr_pos; 11 | pos_lnum = pos.pos_lnum + 1 12 | } 13 | 14 | let int_of_id (s:string): int = 15 | let si = String.sub s 3 (String.length s-3) in 16 | int_of_string si 17 | 18 | let int_of_ptr (s:string): int = 19 | let si = String.sub s 1 (String.length s-1) in 20 | int_of_string si 21 | 22 | } 23 | 24 | let funid = "Fun"['0'-'9'] ['0'-'9']* 25 | let verid = "Ver"['0'-'9'] ['0'-'9']* 26 | let regid = "reg"['0'-'9'] ['0'-'9']* 27 | let lblid = "lbl"['0'-'9'] ['0'-'9']* 28 | let cstid = '-'? ['0'-'9'] ['0'-'9']* 29 | 30 | let white = [' ' '\t']+ 31 | let newline = '\r' | '\n' | "\r\n" 32 | let errormsg = '\"'['a'-'z''A'-'Z'' ']*'\"' 33 | 34 | rule read = 35 | parse 36 | | white { read lexbuf } 37 | | newline { next_line lexbuf; read lexbuf } 38 | | '[' { LBRACK } 39 | | ']' { RBRACK } 40 | | '(' { LPAR } 41 | | ')' { RPAR } 42 | | '{' { LBRACE } 43 | | '}' { RBRACE } 44 | | ':' { COLON } 45 | | '.' { DOT } 46 | | ',' { COMMA } 47 | | '#' { HINT } 48 | | '=' { HINTEQ } 49 | | "Function" { FUNCTION } 50 | | "Version" { VERSION } 51 | | "Parameters" { PARAMS } 52 | | "Entry" { ENTRY } 53 | | "Main" { MAIN } 54 | | '<' { LL } 55 | | '>' { RR } 56 | | "<-" { ARROW } 57 | | "Plus" { PLUS } 58 | | "Minus" { MINUS } 59 | | "Mult" { MULT } 60 | | "Gt" { GT } 61 | | "Lt" { LT } 62 | | "Geq" { GEQ } 63 | | "Leq" { LEQ } 64 | | "Eq" { EQ } 65 | | "Uminus" { UMINUS } 66 | | "Neg" { NEG } 67 | | "Assign" { ASSIGN } 68 | | "Nop" { NOP } 69 | | "Move" { MOVE } 70 | | "Call" { CALL } 71 | | "Return" { IRETURN } 72 | | "Cond" { COND } 73 | | "Print" { PRINTEXPR } 74 | | "SPrint" { PRINTSTRING } 75 | | "Framestate" { FRAMESTATE } 76 | | "Assume" { ASSUME } 77 | | "Mem" { MEM } 78 | | "Store" { STORE } 79 | | "Load" { LOAD } 80 | | "Fail" { FAIL } 81 | | "EndVersion" { ENDVER } 82 | | "EndFunction" { ENDFUNC } 83 | | "EndProgram" { ENDPROG } 84 | | funid { FID (int_of_id (Lexing.lexeme lexbuf)) } 85 | | regid { REG (int_of_id (Lexing.lexeme lexbuf)) } 86 | | lblid { LBL (int_of_id (Lexing.lexeme lexbuf)) } 87 | | cstid { CSTI (int_of_string (Lexing.lexeme lexbuf)) } 88 | | errormsg { MSG (Lexing.lexeme lexbuf) } 89 | | eof { EOF } 90 | -------------------------------------------------------------------------------- /src/coqjit/parsing/parser.mly: -------------------------------------------------------------------------------- 1 | %token LBRACK RBRACK 2 | %token LPAR RPAR 3 | %token LBRACE RBRACE 4 | %token EOF 5 | %token COLON DOT COMMA 6 | %token ENDVER ENDFUNC ENDPROG 7 | %token FUNCTION VERSION 8 | %token PARAMS 9 | %token ENTRY MAIN 10 | %token REG 11 | %token LBL 12 | %token FID 13 | %token CSTI 14 | %token LL RR 15 | %token PLUS MINUS MULT GT LT GEQ LEQ EQ 16 | %token UMINUS NEG ASSIGN 17 | %token NOP MOVE CALL IRETURN COND PRINTEXPR PRINTSTRING FRAMESTATE ASSUME STORE LOAD FAIL 18 | %token HINT HINTEQ 19 | %token ARROW MEM 20 | %token MSG 21 | %start prog 22 | %% 23 | 24 | op: 25 | | r=REG {Ast.Areg r} 26 | | c=CSTI {Ast.Acsti c} 27 | 28 | binop: 29 | | PLUS {Ast.Aplus} 30 | | MINUS {Ast.Aminus} 31 | | MULT {Ast.Amult} 32 | | GT {Ast.Agt} 33 | | LT {Ast.Alt} 34 | | GEQ {Ast.Ageq} 35 | | LEQ {Ast.Aleq} 36 | | EQ {Ast.Aeq} 37 | 38 | unop: 39 | | UMINUS {Ast.Auminus} 40 | | NEG {Ast.Aneg} 41 | | ASSIGN {Ast.Aassign} 42 | 43 | expr: 44 | | b=binop o1=op o2=op 45 | {Ast.Abinexpr (b,o1,o2)} 46 | | u=unop o=op 47 | {Ast.Aunexpr (u,o)} 48 | | o=op 49 | {Ast.Aunexpr (Ast.Aassign,o)} 50 | | LPAR e=expr RPAR 51 | {e} 52 | 53 | list_expr: 54 | | {[]} 55 | | e=expr {[e]} 56 | | e=expr COMMA le=list_expr {e::le} 57 | 58 | regexpr: 59 | | LPAR r=REG COMMA e=expr RPAR {(r,e)} 60 | 61 | varmap: 62 | | {[]} 63 | | re=regexpr vm=varmap {re::vm} 64 | 65 | movelist: 66 | | {[]} 67 | | re=regexpr ml=movelist {re::ml} 68 | 69 | target: 70 | | f=FID DOT l=LBL 71 | { (f,l) } 72 | 73 | synth: 74 | | t=target r=REG LBRACE vm=varmap RBRACE 75 | {(t,r,vm)} 76 | 77 | list_synth: 78 | | {[]} 79 | | s=synth sl=list_synth {s::sl} 80 | 81 | instruction: 82 | | NOP l=LBL 83 | {Ast.Anop (None,l)} 84 | | HINT r1=REG HINTEQ r2=REG l=LBL 85 | {Ast.Anop (Some (Ahint_eq(r1,r2)),l)} 86 | | HINT r=REG HINTEQ c=CSTI l=LBL 87 | {Ast.Anop (Some (Ahint_eq_val(r,c)),l)} 88 | | r=REG ARROW e=expr l=LBL 89 | {Ast.Aop (e,r,l)} 90 | | MOVE ml=movelist l=LBL 91 | {Ast.Amove (ml,l)} 92 | | r=REG ARROW CALL f=FID LPAR le=list_expr RPAR l=LBL 93 | {Ast.Acall (f,le,r,l)} 94 | | IRETURN e=expr 95 | {Ast.Aireturn e} 96 | | COND e=expr l1=LBL l2=LBL 97 | {Ast.Acond (e,l1,l2)} 98 | | STORE MEM LBRACK e2=expr RBRACK ARROW e1=expr l=LBL 99 | {Ast.Astore (e1,e2,l)} 100 | | r=REG ARROW LOAD MEM LBRACK e=expr RBRACK l=LBL 101 | {Ast.Aload (e,r,l)} 102 | | PRINTEXPR e=expr l=LBL 103 | {Ast.Aprintexpr (e,l)} 104 | | PRINTSTRING str=MSG l=LBL 105 | {Ast.Aprintstring (str,l)} 106 | | FRAMESTATE t=target LBRACE vm=varmap RBRACE LBRACK sl=list_synth RBRACK next=LBL 107 | { Ast.Aframestate (t,vm,sl,next) } 108 | | ASSUME LPAR el=list_expr RPAR t=target LBRACE vm=varmap RBRACE LBRACK sl=list_synth RBRACK next=LBL 109 | {Ast.Aassume (el,t,vm,sl,next)} 110 | | FAIL s=MSG 111 | {Ast.Afail (s)} 112 | 113 | node: 114 | | LL l=LBL RR i=instruction 115 | {(l,i)} 116 | 117 | list_node: 118 | | ENDVER {[]} 119 | | n=node ln=list_node {n::ln} 120 | 121 | version_decl: 122 | | VERSION COLON LBRACK ENTRY COLON l=LBL RBRACK n=list_node 123 | {(l,n)} 124 | 125 | list_reg: 126 | | {[]} 127 | | r=REG {[r]} 128 | | r=REG COMMA lr=list_reg {r::lr} 129 | 130 | fun_decl: 131 | | FUNCTION f=FID COLON PARAMS COLON LPAR rl=list_reg RPAR v=version_decl ENDFUNC 132 | {(f,rl,v,None)} 133 | | FUNCTION f=FID COLON PARAMS COLON LPAR rl=list_reg RPAR v=version_decl vopt=version_decl ENDFUNC 134 | {(f,rl,v,Some vopt)} 135 | 136 | list_fun: 137 | | ENDPROG {[]} 138 | | f=fun_decl lf=list_fun {f::lf} 139 | 140 | prog: 141 | | LBRACK MAIN COLON f=FID RBRACK fl=list_fun {Some (f,fl)} 142 | | EOF {None} 143 | 144 | 145 | %% 146 | -------------------------------------------------------------------------------- /src/coqjit/printer.ml: -------------------------------------------------------------------------------- 1 | (* Printing programs and coq extracted types *) 2 | open Common 3 | open BinNums 4 | open BinPos 5 | open Maps 6 | open SpecIR 7 | open Printf 8 | open Events 9 | open Values 10 | open Conv 11 | 12 | (* What debugging information should be printed *) 13 | let print_debug_strings = ref false 14 | let print_debug_opt_fun = ref false 15 | 16 | let print_debug_info (di:debug_info): string = 17 | match di with 18 | | DebugOpt n -> "Optimizing Fun" ^ (string_of_int (int_of_positive n)) 19 | | DebugString s -> s 20 | 21 | let print_value (v:value): string = 22 | Printf.sprintf "%Ld" (int64_of_val v) 23 | 24 | let print_event = function 25 | | Debug di -> begin match (di, !print_debug_strings, !print_debug_opt_fun) with 26 | | (DebugOpt _, _, true) 27 | | (DebugString _, true, _) -> Printf.printf ("\027[31mDEBUG:\027[0m %s\n%!") (print_debug_info di) 28 | | (_,_,_) -> () 29 | end 30 | | Valprint v -> Printf.printf ("\027[32mOUTPUT:\027[0m %s\n%!") (print_value v) 31 | | Stringprint str -> Printf.printf ("\027[32mOUTPUT:\027[0m %s\n%!") str 32 | | Loud_Deopt -> () 33 | | Loud_Go_on -> () 34 | 35 | let rec print_trace (t:trace): unit = 36 | match t with 37 | | [] -> () 38 | | e::t' -> let _ = print_event e in print_trace t' 39 | 40 | (* Pretty-printing Programs *) 41 | let print_fun_id (f:fun_id): string = 42 | "Fun" ^ string_of_int(int_of_positive f) 43 | 44 | let print_reg (r:reg): string = 45 | "reg" ^ string_of_int(int_of_positive r) 46 | 47 | let print_lbl (l:label): string = 48 | "lbl" ^ string_of_int(int_of_positive l) 49 | 50 | let print_binop (b:bin_operation): string = 51 | match b with 52 | | Plus -> "Plus" 53 | | Minus -> "Minus" 54 | | Mult -> "Mult" 55 | | Gt -> "Gt" 56 | | Lt -> "Lt" 57 | | Geq -> "Geq" 58 | | Leq -> "Leq" 59 | | Eq -> "Eq" 60 | 61 | let print_unop (u:un_operation): string = 62 | match u with 63 | | UMinus -> "Uminus" 64 | | Neg -> "Neg" 65 | | Assign -> "" 66 | 67 | let print_op (o:op): string = 68 | match o with 69 | | Reg r -> print_reg r 70 | | Cst v -> print_value v 71 | 72 | let print_expr (e:expr): string = 73 | match e with 74 | | Binexpr (b,o1,o2) -> print_binop b ^" "^ print_op o1 ^" "^ print_op o2 75 | | Unexpr (Assign,o) -> print_op o 76 | | Unexpr (u,o) -> print_unop u ^" "^ print_op o 77 | 78 | let rec print_expr_list (el:expr list): string = 79 | match el with 80 | | [] -> "" 81 | | [e] -> print_expr e 82 | | e::el' -> print_expr e ^ "," ^ print_expr_list el' 83 | 84 | let print_args (el:expr list): string = 85 | " (" ^ print_expr_list el ^ ") " 86 | 87 | let rec print_varmap (vm:varmap): string = 88 | match vm with 89 | | [] -> "" 90 | | [(r,e)] -> "(" ^ print_reg r ^ "," ^ print_expr e ^ ")" 91 | | (r,e)::vm' -> "(" ^ print_reg r ^ "," ^ print_expr e ^ ") " ^ print_varmap vm' 92 | 93 | let rec print_movelist (ml:movelist): string = 94 | match ml with 95 | | [] -> "" 96 | | [(r,e)] -> "(" ^ print_reg r ^ "," ^ print_expr e ^ ")" 97 | | (r,e)::ml' -> "(" ^ print_reg r ^ "," ^ print_expr e ^ ") " ^ print_movelist ml' 98 | 99 | 100 | let print_frame ((((f,l),r),vm):synth_frame):string = 101 | print_fun_id f ^ "." ^ 102 | print_lbl l ^ " " ^ 103 | print_reg r ^ " {" ^ 104 | print_varmap vm ^ "}" 105 | 106 | let rec print_synth_list (sl:synth_frame list): string = 107 | match sl with 108 | | [] -> "" 109 | | [f] -> print_frame f 110 | | f::sl' -> print_frame f ^ " " ^ print_synth_list sl' 111 | 112 | let print_instr (i:instruction): string = 113 | match i with 114 | | Nop (None,lbl) -> "Nop " ^ print_lbl lbl 115 | | Nop (Some(Hint_Eq(r1,r2)),lbl) -> "# "^print_reg r1^" = "^print_reg r2 ^ " "^print_lbl lbl 116 | | Nop (Some(Hint_Eq_val(r,v)),lbl) -> "# "^print_reg r^" = "^print_value v^ " "^print_lbl lbl 117 | | Op (e,r,lbl) -> print_reg r ^ " <- " ^ print_expr e ^" "^ print_lbl lbl 118 | | Move (ml,lbl) -> "Move " ^ print_movelist ml ^ " " ^ print_lbl lbl 119 | | Call (f,el,r,lbl) -> 120 | print_reg r ^ " <- Call " ^ print_fun_id f ^ print_args el ^ print_lbl lbl 121 | | IReturn e -> "Return " ^ print_expr e 122 | | Cond (e,lbl1,lbl2) -> "Cond (" ^ print_expr e ^") "^ print_lbl lbl1 ^" "^ print_lbl lbl2 123 | | Store (ex1,ex2,lbl) -> "Store Mem[" ^ print_expr ex2 ^ "] <- " ^ print_expr ex1 ^" "^ print_lbl lbl 124 | | Load (ex,r,lbl) -> print_reg r ^ " <- Load Mem[" ^ print_expr ex ^ "] " ^ print_lbl lbl 125 | | Printexpr (e,lbl) -> "Print " ^ print_expr e ^" "^ print_lbl lbl 126 | | Printstring (s,lbl) -> "SPrint " ^ s ^" "^ print_lbl lbl 127 | | Assume (el,(f,l),vm,sl,lbl) -> 128 | "Assume" ^ print_args el ^" "^ print_fun_id f ^"."^ print_lbl l ^ 129 | " "^ "{" ^ print_varmap vm ^ "} [" ^ 130 | print_synth_list sl ^"] "^ print_lbl lbl 131 | | Framestate ((f,l), vm, sl, lbl) -> "Framestate "^ print_fun_id f ^"."^ print_lbl l ^ 132 | " "^ "{" ^ print_varmap vm ^ "} [" ^ 133 | print_synth_list sl ^"] "^ print_lbl lbl 134 | | Fail s -> "Fail " ^ s 135 | 136 | 137 | let positive_sort (pi1:positive* 'a) (pi2:positive* 'a): int = 138 | match (Pos.leb (fst pi1) (fst pi2)) with 139 | | true -> -1 140 | | false -> 1 141 | 142 | let rec print_ilist (il:(positive*instruction) list): string = 143 | match il with 144 | | [] -> "" 145 | | (p,i)::il' -> "<" ^ print_lbl (p) ^ "> " ^ print_instr i ^ "\n" ^ print_ilist il' 146 | 147 | let print_code (c:code): string = 148 | let ilist = PTree.elements c in 149 | let silist = List.sort positive_sort ilist in 150 | print_ilist silist 151 | 152 | let print_version (v:version): string = 153 | "[Entry: " ^ print_lbl (v.ver_entry) ^ "]\n" ^ 154 | print_code (v.ver_code) ^ "EndVersion\n" 155 | 156 | let print_option_version (o): string = 157 | match o with 158 | | None -> "" 159 | | Some v -> "Version: " ^ print_version v ^ "\n" 160 | 161 | let rec print_params (pl:reg list): string = 162 | match pl with 163 | | [] -> "" 164 | | [r] -> print_reg r 165 | | r::pl' -> print_reg r ^ ", " ^ print_params pl' 166 | 167 | let print_function (f:coq_function): string = 168 | "Parameters: (" ^ print_params (f.fn_params) ^ ")\n" ^ 169 | "Version: " ^ print_version (f.fn_base) ^ "\n" ^ 170 | print_option_version (f.fn_opt) ^ "EndFunction\n\n" 171 | 172 | let rec print_funlist (fl: (fun_id * coq_function) list): string = 173 | match fl with 174 | | [] -> "EndProgram\n" 175 | | (fid,f)::fl' -> 176 | "Function " ^ print_fun_id fid ^ ":\n" ^ 177 | print_function f ^ 178 | print_funlist fl' 179 | 180 | let print_function_list (fl:coq_function PTree.t): string = 181 | let flist = PTree.elements fl in 182 | let sflist = List.sort positive_sort flist in 183 | print_funlist sflist 184 | 185 | let print_program (p:program): string = 186 | "[Main: " ^ print_fun_id (p.prog_main) ^ "]\n\n" ^ 187 | print_function_list (p.prog_funlist) 188 | 189 | (* We could add more than just the pc *) 190 | (* let print_semantic_state (s:state): string = 191 | * match s with 192 | * | State (stack,v,pc,rm,ms) -> "Current label: " ^ print_lbl pc 193 | * | Final (v,ms) -> "Final State" *) 194 | 195 | 196 | -------------------------------------------------------------------------------- /src/coqjit/profiler.ml: -------------------------------------------------------------------------------- 1 | (* The profiler gathers information and chooses when to optimize the program *) 2 | (* It sends optimizing information: which function to optimize, with which values... *) 3 | (* This info is not relevant to the correctness proof *) 4 | open Common 5 | open BinNums 6 | open Maps 7 | open Values 8 | open SpecIR 9 | open Interpreter 10 | open List 11 | open Profiler_types 12 | open Printf 13 | open Printer 14 | open Conv 15 | 16 | 17 | type optim_id = fun_id 18 | 19 | (* So far, the profiler associates to each function its number of calls *) 20 | type profiler_state = 21 | { fun_map : int PMap.t; 22 | status : jit_status; 23 | already: fun_id list; (* already optimized functions *) 24 | fidoptim : optim_id; } 25 | (* In already, we put functions that we already ASKED to optimize *) 26 | (* Maybe these suggestions weren't followed by the JIT, and the functions weren't actually optimized *) 27 | 28 | (* Initially, each function has been called 0 times, with no arguments *) 29 | let initial_profiler_state = 30 | { fun_map = PMap.init 0; (* initially no functions have been called *) 31 | status = Exe; 32 | already = []; (* no optimized functions *) 33 | fidoptim = Coq_xH; } 34 | 35 | (* The number of calls to a function before optimization *) 36 | let nb_calls_optim = 3 37 | 38 | (* Keep the same profiler state information, but with Exe status *) 39 | let exe_ps (ps:profiler_state) = 40 | {fun_map = ps.fun_map; status = Exe; already = ps.already; fidoptim = ps.fidoptim } 41 | 42 | (* The function that analyzes the current synchronization state *) 43 | let profiler (ps:profiler_state) (s:synchro_state) = 44 | match s with 45 | | S_Call (fid,val_list,osf) -> (* Just before a Call *) 46 | let psmap = ps.fun_map in 47 | let newpsmap = PMap.set fid ((PMap.get fid psmap)+1) psmap in (* updating the number of executions *) 48 | begin match (PMap.get fid newpsmap > nb_calls_optim && not(List.mem fid ps.already)) with 49 | (* The profiler suggests optimizing the called function *) 50 | | true -> 51 | let _ = Printf.printf ("\027[95mPROFILER:\027[0m Optimizing %s\n%!") (print_fun_id fid) in 52 | {fun_map = newpsmap; status = Opt; already = fid::ps.already; fidoptim = fid} 53 | (* Either already optimized or not been called enough: we keep executing *) 54 | | false -> {fun_map = newpsmap; status = Exe; already = ps.already; fidoptim = ps.fidoptim } 55 | end 56 | | _ -> exe_ps ps (* On all other states, we simply keep executing *) 57 | 58 | 59 | let optim_policy (ps:profiler_state) = ps.status 60 | 61 | (* Where to insert Framestate Instructions at the beginning of an optimization step *) 62 | (* First we insert Framesates wherever there is a hint, and after each Call to allow inlining *) 63 | let framestates_to_insert_single (ps:profiler_state) (p:program) = 64 | match find_function ps.fidoptim p with 65 | | None -> ps.fidoptim, [] 66 | | Some f -> 67 | let collect acc = function 68 | | l, Nop (Some _, lbl) -> 69 | lbl::acc 70 | | l, Call (callee,args,retreg,nextlbl) -> 71 | nextlbl::acc 72 | | _ -> acc 73 | in 74 | ps.fidoptim, List.fold_left collect [] (PTree.elements f.fn_base.ver_code) 75 | 76 | let framestates_to_insert (ps:profiler_state) (p:program) = 77 | [framestates_to_insert_single ps p] 78 | 79 | let collect_hints ps (func:version) = 80 | let collect acc = function 81 | | l, Nop (Some (Hint_Eq(r1, r2)), lbl) -> 82 | (ps.fidoptim, 83 | AS_INS( 84 | [Binexpr(Eq, Reg r1, Reg r2)], 85 | lbl)) :: acc 86 | | l, Nop (Some (Hint_Eq_val(r, v)), lbl) -> 87 | (ps.fidoptim, 88 | AS_INS( 89 | [Binexpr(Eq, Reg r, Cst v)], 90 | lbl)) :: acc 91 | | _ -> acc 92 | in 93 | List.fold_left collect [] (PTree.elements func.ver_code) 94 | 95 | (* finding call instructions to inline *) 96 | (* Here we suggest inlining every calls *) 97 | let collect_calls (ps:profiler_state) (func:version) = 98 | let collect acc = function 99 | | l, Call (_, _, _, _) -> (ps.fidoptim, INLINE l) :: acc 100 | | _ -> acc 101 | in 102 | List.fold_left collect [] (PTree.elements func.ver_code) 103 | 104 | let optim_list (ps:profiler_state) (p:program) = 105 | let cf = List.init 10 (fun _ -> (ps.fidoptim, CST_PROP)) in 106 | (if !Flags.disable_profiler_hints then 107 | [] 108 | else 109 | match find_function ps.fidoptim p with 110 | | None -> [] 111 | | Some f -> 112 | (collect_hints ps f.fn_base) @ (collect_calls ps f.fn_base))@ 113 | cf 114 | 115 | 116 | -------------------------------------------------------------------------------- /src/coqjit/profiler_types.v: -------------------------------------------------------------------------------- 1 | (* Profiler_types: the types used by the profiler functions *) 2 | 3 | Require Export specIR. 4 | 5 | (* The different kinds of Optimizations passes the profiler wishes to make *) 6 | Inductive optim_wish : Type := 7 | | AS_INS: list expr -> label -> optim_wish 8 | | AS_INS_DELAY: list expr -> label -> optim_wish 9 | | CST_PROP: optim_wish 10 | | INLINE: label -> optim_wish 11 | | LOWER: optim_wish. 12 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/binsearch.lua: -------------------------------------------------------------------------------- 1 | do 2 | -- Avoid heap allocs for performance 3 | local default_fcompval = function( value ) return value end 4 | local fcompf = function( a,b ) return a < b end 5 | local fcompr = function( a,b ) return a > b end 6 | function table.binsearch( tbl,value,fcompval,reversed ) 7 | -- Initialise functions 8 | local fcompval = fcompval or default_fcompval 9 | local fcomp = reversed and fcompr or fcompf 10 | -- Initialise numbers 11 | local iStart,iEnd,iMid = 1,#tbl,0 12 | -- Binary Search 13 | while iStart <= iEnd do 14 | -- calculate middle 15 | iMid = (iStart+iEnd)/2 16 | -- get compare value 17 | local value2 = fcompval( tbl[iMid] ) 18 | -- get all values that match 19 | if value == value2 then 20 | local tfound,num = { iMid,iMid },iMid - 1 21 | while value == fcompval( tbl[num] ) do -- ERROR: this may cause fail in fcompval if num is out of range and tbl[num] is nil 22 | tfound[1],num = num,num - 1 23 | end 24 | num = iMid + 1 25 | while value == fcompval( tbl[num] ) do -- ERROR: this may cause fail in fcompval if num is out of range and tbl[num] is nil 26 | tfound[2],num = num,num + 1 27 | end 28 | return tfound 29 | -- keep searching 30 | elseif fcomp( value,value2 ) then 31 | iEnd = iMid - 1 32 | else 33 | iStart = iMid + 1 34 | end 35 | end 36 | end 37 | end 38 | 39 | t = {} 40 | local v = table.binsearch(t, 5); assert(v == nil) 41 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/bubble_sort.lua: -------------------------------------------------------------------------------- 1 | local function bubbleSort(A) 2 | __hint_tbl(A) 3 | local itemCount=#A 4 | local hasChanged 5 | repeat 6 | hasChanged = false 7 | itemCount=itemCount - 1 8 | for i = 1, itemCount do 9 | local l,r = A[i],A[i+1] 10 | __hint_int(l) 11 | __hint_int(r) 12 | if l > r then 13 | A[i], A[i + 1] = r,l 14 | hasChanged = true 15 | end 16 | end 17 | until hasChanged == false 18 | end 19 | 20 | 21 | list_in = {5,6,1,2,9,14,2,15,97,5,6,1,2,9,14,2,15,6,7,8,97,5,6,1,2,9,14,2,15,6,7,8,97} 22 | list = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,} 23 | 24 | iter = 500 25 | iter2 = 1000 26 | 27 | local function test() 28 | for i = 1, #list_in do 29 | list[i] = list_in[i] 30 | end 31 | for i = 1, iter do 32 | bubbleSort(list) 33 | i = i+1 34 | end 35 | end 36 | 37 | for i = 1, iter2 do 38 | test() 39 | end 40 | 41 | local i = 1 42 | while i <= #list do 43 | print(list[i]) 44 | i = i+1 45 | end 46 | 47 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/example1.lua: -------------------------------------------------------------------------------- 1 | local function apply(a,b) 2 | __hint_int(a) 3 | __hint_val(b,1) 4 | return (a*a)+b 5 | end 6 | 7 | apply(1,1) 8 | apply(2,1) 9 | apply(3,1) 10 | apply(4,1) 11 | apply(5,1) 12 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/fail.lua: -------------------------------------------------------------------------------- 1 | -- should fail 2 | local r = true 3 | r = r+1; 4 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/fib.lua: -------------------------------------------------------------------------------- 1 | -- Naive recursive 2 | local function fibonacci_naive(n) 3 | local function inner(m) 4 | if m < 2 then 5 | return m 6 | end 7 | return inner(m-1) + inner(m-2) 8 | end 9 | return inner(n) 10 | end 11 | 12 | -- Tail-optimized recursive 13 | local function fibonacci_tail_call(n) 14 | local function inner(m, a, b) 15 | if m == 0 then 16 | return a 17 | end 18 | return inner(m-1, b, a+b) 19 | end 20 | return inner(n, 0, 1) 21 | end 22 | 23 | local val = 16 24 | 25 | local res1 = fibonacci_naive(val) 26 | local res2 = fibonacci_tail_call(val) 27 | 28 | assert(res1 == res2) 29 | 30 | memo = {nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil} 31 | local function fibonacci_memoized(n) 32 | local function inner(m) 33 | if m < 2 then 34 | return m 35 | end 36 | 37 | if memo[m] then 38 | return memo[m] 39 | else 40 | local res = inner(m-1) + inner(m-2) 41 | memo[m] = res 42 | return res 43 | end 44 | end 45 | return inner(n) 46 | end 47 | 48 | res3 = fibonacci_memoized(val) 49 | assert(res1 == res3) 50 | 51 | 52 | local function fibonacci_iterative(n) 53 | local a, b = 0, 1 54 | local i = 1 55 | 56 | while i <= n do 57 | a, b, i = b, a + b, i + 1 58 | end 59 | return a 60 | end 61 | 62 | res4 = fibonacci_iterative(val) 63 | assert(res1 == res4) 64 | res4 = fibonacci_iterative(val) 65 | assert(res1 == res4) 66 | res4 = fibonacci_iterative(val) 67 | assert(res1 == res4) 68 | res4 = fibonacci_iterative(val) 69 | assert(res1 == res4) 70 | 71 | print(res1) 72 | return res1 73 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/fib2.lua: -------------------------------------------------------------------------------- 1 | local function fib(n) 2 | __hint_int(n) 3 | if n < 2 then 4 | return n 5 | end 6 | return fib(n-1) + fib(n-2) 7 | end 8 | 9 | return fib(39) 10 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/first.lua: -------------------------------------------------------------------------------- 1 | local v = 0; 2 | v = v+1+0; 3 | assert(v~=2) 4 | assert(v~=true) 5 | local r = assert(v==1); 6 | 7 | assert(nil == nil) 8 | 9 | assert ((nil and nil) == nil) 10 | assert ((false and 13) == false) 11 | assert ((true and 13) == 13) 12 | assert ((true and nil) == nil) 13 | assert ((true and false) == false) 14 | assert ((true and true) == true) 15 | assert ((1 and 1) == 1) 16 | assert ((0 and 1) == 1) 17 | assert ((1 and true) == true) 18 | assert ((1 and nil) == nil) 19 | 20 | assert ((nil or nil) == nil) 21 | assert ((nil or true) == true) 22 | assert ((nil or false) == false) 23 | assert ((nil or 1) == 1) 24 | assert ((nil or 0) == 0) 25 | assert ((false or 13) == 13) 26 | assert ((true or 13) == true) 27 | assert ((1 or 1) == 1) 28 | assert ((0 or 1) == 0) 29 | assert ((12 or true) == 12) 30 | assert ((12 or nil) == 12) 31 | 32 | a = 1 33 | assert ((-a) == -1) 34 | a = true 35 | assert ((~a) == false) 36 | a = false 37 | assert ((~a) == true) 38 | a = 1 39 | assert ((~a) == false) 40 | a = nil 41 | assert ((~a) == true) 42 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/gnome_sort.lua: -------------------------------------------------------------------------------- 1 | local function gnomeSort(a) 2 | local i, j = 2, 3 3 | __hint_tbl(a) 4 | while i <= #a do 5 | local l, r = a[i-1], a[i] 6 | local le 7 | 8 | __hint_int(l) 9 | __hint_int(r) 10 | 11 | if l == nil then le = true 12 | elseif r == nil then le = false 13 | elseif l == false then le = true 14 | elseif r == false then le = false 15 | elseif l == true then le = true 16 | elseif r == true then le = false 17 | else le = l <= r 18 | end 19 | 20 | if le then 21 | i = j 22 | j = j + 1 23 | else 24 | a[i-1], a[i] = r,l -- swap 25 | i = i - 1 26 | if i == 1 then -- 1 instead of 0 27 | i = j 28 | j = j + 1 29 | end 30 | end 31 | end 32 | end 33 | 34 | list_in = {5,6,2,9,14,2,15,7,8,97,5,6,1,2,9,14,2,15,6,7,8,97,5,6,1,2,9,14,2,15,6,7,8,97,5,6,1,2,9,14,2,15,6,7,8,97} 35 | list = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0} 36 | 37 | iter = 150 38 | iter2 = 20000 39 | 40 | local function test() 41 | for i = 1, #list_in do 42 | list[i] = list_in[i] 43 | end 44 | for i = 1, iter do 45 | gnomeSort(list) 46 | i = i+1 47 | end 48 | end 49 | 50 | for i = 1, iter2 do 51 | test() 52 | end 53 | 54 | local i = 1 55 | while i < #list do 56 | assert(list[i]<=list[i+1]) 57 | i = i+1 58 | end 59 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/if_then.lua: -------------------------------------------------------------------------------- 1 | local a = 0 2 | if true then 3 | a = 1 4 | end 5 | assert(a==1) 6 | if false then 7 | a = 2 8 | end 9 | assert(a==1) 10 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/loop.lua: -------------------------------------------------------------------------------- 1 | local i = 1 2 | local x = 0 3 | while i <= 10 do 4 | x,i = 0,i+1 5 | end 6 | print(i) 7 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/printing.lua: -------------------------------------------------------------------------------- 1 | print(true) 2 | print(false) 3 | print(1) 4 | print(nil) 5 | print(1+2) 6 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/scopes.lua: -------------------------------------------------------------------------------- 1 | a=nil 2 | print(a); 3 | b = 1; 4 | local f = function() 5 | b = 13 6 | local f2 = function() 7 | x = 10 8 | b = 42 9 | end 10 | local x = 9; 11 | print(b) 12 | f2() 13 | print(x) 14 | print(b) 15 | end 16 | r = f() 17 | print(b) 18 | print(r) 19 | 20 | local sub = function(a,b) 21 | return a-b 22 | end 23 | print(sub(1234,34)) 24 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/spec.lua: -------------------------------------------------------------------------------- 1 | local f = function(a) 2 | __hint_int(a) 3 | return 1+a 4 | end 5 | f(1) 6 | f(1) 7 | f(1) 8 | f(1) 9 | 10 | 11 | local f2 = function(a) 12 | __hint_val(a,2) 13 | return 1+a 14 | end 15 | f2(2) 16 | f2(2) 17 | f2(2) 18 | f2(2) 19 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/spec_fail.lua: -------------------------------------------------------------------------------- 1 | local f = function(a) 2 | __hint_int(a) 3 | return 1+a 4 | end 5 | f(1) 6 | f(1) 7 | f(1) 8 | f(1) 9 | f(nil) 10 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/spec_pos.lua: -------------------------------------------------------------------------------- 1 | local f = function(a) 2 | local x = a+1 3 | __hint_int(a) 4 | return 0 5 | end 6 | t = 1 7 | f(t) 8 | f(t) 9 | f(t) 10 | f(t) 11 | -------------------------------------------------------------------------------- /src/coqjit/progs_lua/table.lua: -------------------------------------------------------------------------------- 1 | a = {1,2,3} 2 | 3 | local test = function(x) 4 | assert(a[-1]==nil) 5 | assert(a[0]==nil) 6 | assert(a[1]==1) 7 | assert(a[2]==x) 8 | assert(a[3]==3) 9 | assert(a[4]==nil) 10 | assert(a[5]==nil) 11 | assert(a[6]==nil) 12 | assert(a[7]==nil) 13 | end 14 | 15 | local write = function(x) 16 | for i=1,1 do 17 | a[2] = x 18 | end 19 | end 20 | 21 | test(2) 22 | test(2) 23 | a[2] = 42 24 | test(42) 25 | a[2] = a 26 | test(a) 27 | 28 | write(12) 29 | test(12) 30 | -------------------------------------------------------------------------------- /src/coqjit/progs_specIR/constprop.specir: -------------------------------------------------------------------------------- 1 | 2 | [Main: Fun1] 3 | 4 | Function Fun1: 5 | Parameters: () 6 | 7 | Version: 8 | [Entry: lbl10] 9 | SPrint "Bonjour" lbl1 10 | reg1 <- 0 lbl2 11 | reg2 <- Call Fun2 (reg1) lbl3 12 | Print reg2 lbl4 13 | reg1 <- Plus reg1 1 lbl5 14 | reg3 <- Eq reg1 15 lbl6 15 | Cond reg3 lbl7 lbl2 16 | Return 0 17 | EndVersion 18 | 19 | EndFunction 20 | 21 | Function Fun2: 22 | Parameters: (reg4) 23 | 24 | Version: 25 | [Entry: lbl1] 26 | reg1 <- 1 lbl2 27 | reg2 <- Plus reg1 20 lbl3 28 | reg13 <- Mult reg4 reg4 lbl4 29 | Return reg13 30 | EndVersion 31 | 32 | EndFunction 33 | 34 | EndProgram 35 | 36 | -------------------------------------------------------------------------------- /src/coqjit/progs_specIR/inline2.specir: -------------------------------------------------------------------------------- 1 | 2 | [Main: Fun1] 3 | 4 | Function Fun1: 5 | Parameters: () 6 | Version: 7 | [Entry: lbl10] 8 | reg1 <- Call Fun3 (1,1) lbl20 9 | reg1 <- Call Fun3 (5,5) lbl30 10 | reg1 <- Call Fun3 (7,7) lbl40 11 | reg1 <- 0 lbl50 12 | reg2 <- Call Fun2 (reg1) lbl60 13 | Print reg2 lbl70 14 | reg1 <- Plus reg1 1 lbl80 15 | reg3 <- Eq reg1 20 lbl90 16 | Cond reg3 lbl100 lbl50 17 | Return 0 18 | EndVersion 19 | EndFunction 20 | 21 | Function Fun2: 22 | Parameters: (reg1) 23 | Version: 24 | [Entry: lbl10] 25 | reg2 <- 0 lbl20 26 | reg2 <- Call Fun3 (reg1,reg1) lbl30 27 | Return reg2 28 | EndVersion 29 | EndFunction 30 | 31 | Function Fun3: 32 | Parameters: (reg1,reg2) 33 | Version: 34 | [Entry: lbl10] 35 | # reg1 = reg2 lbl20 36 | reg3 <- Plus reg1 reg2 lbl30 37 | Return reg3 38 | EndVersion 39 | EndFunction 40 | 41 | EndProgram 42 | -------------------------------------------------------------------------------- /src/coqjit/progs_specIR/native_test.specir: -------------------------------------------------------------------------------- 1 | [Main: Fun1] 2 | 3 | Function Fun1: 4 | Parameters: () 5 | 6 | Version: 7 | [Entry: lbl1] 8 | Nop lbl2 9 | reg2 <- Plus 1 -3 lbl3 10 | reg3 <- Minus reg2 0 lbl4 11 | reg4 <- Mult reg2 reg3 lbl5 12 | reg5 <- Gt reg2 0 lbl6 13 | reg6 <- Lt reg3 reg4 lbl7 14 | reg7 <- Geq reg3 reg2 lbl8 15 | reg8 <- Leq 0 2 lbl9 16 | reg9 <- Eq 0 reg8 lbl10 17 | reg10 <- Uminus reg2 lbl11 18 | reg11 <- Neg reg8 lbl12 19 | reg12 <- 3 lbl13 20 | Print reg2 lbl14 21 | Store Mem[1] <- reg12 lbl15 22 | reg13 <- Load Mem[1] lbl16 23 | Return reg13 24 | EndVersion 25 | 26 | EndFunction 27 | EndProgram 28 | -------------------------------------------------------------------------------- /src/coqjit/progs_specIR/native_test2.specir: -------------------------------------------------------------------------------- 1 | 2 | [Main: Fun1] 3 | 4 | Function Fun1: 5 | Parameters: () 6 | 7 | Version: 8 | [Entry: lbl1] 9 | reg1 <- 0 lbl2 10 | reg2 <- Mult reg1 reg1 lbl21 11 | Store Mem[1] <- reg2 lbl22 12 | reg2 <- Load Mem[1] lbl3 13 | Print reg2 lbl4 14 | reg1 <- Plus reg1 1 lbl5 15 | reg3 <- Eq reg1 15 lbl6 16 | Cond reg3 lbl7 lbl2 17 | Return reg2 18 | EndVersion 19 | 20 | Version: 21 | [Entry: lbl1] 22 | reg1 <- 0 lbl2 23 | reg2 <- Mult reg1 reg1 lbl21 24 | Store Mem[1] <- reg2 lbl211 25 | Assume (Lt reg2 2) Fun1.lbl22 {(reg1,reg1) (reg2, reg2)} [] lbl22 26 | reg2 <- Load Mem[1] lbl3 27 | Print reg2 lbl4 28 | reg1 <- Plus reg1 1 lbl5 29 | reg3 <- Eq reg1 15 lbl6 30 | Cond reg3 lbl7 lbl2 31 | Return reg2 32 | EndVersion 33 | 34 | EndFunction 35 | 36 | EndProgram 37 | 38 | -------------------------------------------------------------------------------- /src/coqjit/progs_specIR/test.specir: -------------------------------------------------------------------------------- 1 | [Main: Fun1] 2 | 3 | Function Fun1: 4 | Parameters: () 5 | Version: [Entry: lbl1] 6 | reg1 <- 0 lbl2 7 | reg1 <- Call Fun2 (reg1,0) lbl3 8 | Return Mult reg1 reg1 9 | EndVersion 10 | EndFunction 11 | 12 | Function Fun2: 13 | Parameters: (reg1,reg2) 14 | Version: [Entry: lbl1] 15 | reg3 <- Mult 14 14 lbl2 16 | reg4 <- 0 lbl3 17 | reg4 <- Call Fun3 (reg1, reg2, reg3) lbl4 18 | Return reg4 19 | EndVersion 20 | EndFunction 21 | 22 | Function Fun3: 23 | Parameters: (reg1,reg2,reg3) 24 | Version: [Entry:lbl1] 25 | reg1 <- Plus reg1 reg2 lbl2 26 | Return (Plus reg1 reg3) 27 | EndVersion 28 | EndFunction 29 | 30 | EndProgram 31 | -------------------------------------------------------------------------------- /src/coqjit/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" 6 | JIT=$DIR/jit 7 | 8 | for t in constprop native_test2 native_test; do 9 | echo "=== RUNNING $t" 10 | p=$DIR/progs_specIR/$t.specir 11 | $JIT $p 12 | $JIT -n $p 13 | $JIT -n -c $p 14 | $JIT -t $p 15 | $JIT -t -n $p 16 | $JIT -k $p 17 | $JIT -n -k $p 18 | done 19 | 20 | 21 | for t in example1 fib first if_then loop printing scopes spec_fail spec spec_pos table; do 22 | echo "=== RUNNING $t" 23 | p=$DIR/progs_lua/$t.lua 24 | $JIT -f $p 25 | $JIT -f -n $p 26 | $JIT -f -n -c $p 27 | $JIT -f -t $p 28 | $JIT -f -t -n $p 29 | $JIT -f -k $p 30 | $JIT -f -n -k $p 31 | done 32 | 33 | for t in bubble_sort fib2 gnome_sort; do 34 | echo "=== RUNNING $t" 35 | p=$DIR/progs_lua/$t.lua 36 | $JIT -f -n $p 37 | $JIT -f -t -n $p 38 | $JIT -f -n -k $p 39 | done 40 | -------------------------------------------------------------------------------- /src/coqjit/test_optim.ml: -------------------------------------------------------------------------------- 1 | (* Tests an optimization on a given program *) 2 | open Common 3 | open BinNums 4 | open Maps 5 | open Values 6 | open SpecIR 7 | open Interpreter 8 | open Jit 9 | open Printf 10 | open Printer 11 | open Camlcoq 12 | open Ast 13 | open Lexer 14 | open Lexing 15 | open Memory 16 | open Assume_insertion 17 | open Assume_insertion_delay 18 | open Framestate_insertion 19 | open Const_prop 20 | open Inlining 21 | open Lowering 22 | open Optimizer 23 | open Profiler_types 24 | 25 | let print_position outx lexbuf = 26 | let pos = lexbuf.lex_curr_p in 27 | fprintf outx "%s:%d:%d" pos.pos_fname 28 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 29 | 30 | 31 | let parse_with_error lexbuf = 32 | try Parser.prog Lexer.read lexbuf with 33 | | SyntaxError msg -> 34 | fprintf stderr "%a: %s\n" print_position lexbuf msg; 35 | None 36 | | Parser.Error -> 37 | fprintf stderr "%a: syntax error\n" print_position lexbuf; 38 | exit (-1) 39 | 40 | let get_program filename: program = 41 | let inx = open_in filename in 42 | let lexbuf = Lexing.from_channel inx in 43 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 44 | let (apo:Ast.aprogram option) = parse_with_error lexbuf in 45 | match apo with 46 | | None -> let _ = close_in inx in failwith "Failed to parse a program" 47 | | Some ap -> let _ = close_in inx in Ast.convert_program ap 48 | 49 | let main = 50 | let _ = Printf.printf "%s" "Testing optimizations\n" in 51 | let path = ref "progs_specIR/test.specir" in 52 | let p = get_program !path in 53 | let fid1 = (Coq_xH) in 54 | let call_lbl1 = Coq_xO(Coq_xH) in (* lbl2 *) 55 | let fs_lbl1 = Coq_xI(Coq_xH) in (* lbl3 *) 56 | let fid2 = Coq_xO(Coq_xH) in 57 | let call_lbl2 = Coq_xI (Coq_xH) in 58 | let fs_lbl2 = Coq_xO(Coq_xO(Coq_xH)) in 59 | let fid3 = Coq_xI(Coq_xH) in 60 | let fs_lbl3 = Coq_xO(Coq_xH) in 61 | let guard = [Binexpr(Eq,Reg Coq_xH,Cst Z0)] in 62 | 63 | let fs_list = (fid1,[fs_lbl1])::(fid2,[fs_lbl2])::(fid3,[fs_lbl3])::[] in 64 | let opt_list = (fid3,AS_INS (guard,fs_lbl3)):: (* insert assume in Fun3 *) 65 | (fid2,INLINE call_lbl2):: (* inline Fun3 in Fun2 *) 66 | (fid1,INLINE call_lbl1)::[] in (* inline Fun2 in Fun1 *) 67 | 68 | begin match (test_optimizer p fs_list opt_list) with 69 | | OK optp -> 70 | Printf.printf "After Optimizations\n %s" (print_program optp) 71 | | Error s -> Printf.printf "%s\n" s 72 | end 73 | -------------------------------------------------------------------------------- /src/native_lib/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | -------------------------------------------------------------------------------- /src/native_lib/Makefile: -------------------------------------------------------------------------------- 1 | LIB=$(shell opam config var lib)/ocaml 2 | 3 | all: native_lib.o 4 | 5 | native_lib.o: native_lib.c 6 | gcc -O2 -g -fPIC -I$(LIB) -c native_lib.c -o native_lib.o 7 | -------------------------------------------------------------------------------- /src/native_lib/native_lib.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | extern void c_fail_prim(const char* msg) { 8 | printf("\033[;33mRun-Time Error:\033[;0m %s\n", msg); 9 | exit(0); 10 | } 11 | extern void c_print_prim(int64_t i) { 12 | printf("\033[;32mOUTPUT:\033[;0m %ld\n", i); 13 | } 14 | extern void c_print_string_prim(const char* msg) { 15 | printf("\033[;32mOUTPUT:\033[;0m %s\n", msg); 16 | } 17 | 18 | extern void c_deopt_prim(int32_t id, int32_t n, int64_t* args) { 19 | static const value * closure_f = NULL; 20 | if (closure_f == NULL) { 21 | closure_f = caml_named_value("ocaml_deopt_prim"); 22 | if (!closure_f) { 23 | caml_failwith("deopt callback not registered"); 24 | } 25 | } 26 | intnat len[1] = {n}; 27 | caml_callback2(*closure_f, 28 | Val_int(id), 29 | caml_ba_alloc(CAML_BA_INT64|CAML_BA_C_LAYOUT, 1, args, len)); 30 | } 31 | 32 | extern void c_call_prim(int32_t id, int32_t nargs, int32_t n, int64_t* args) { 33 | static const value * closure_f = NULL; 34 | if (closure_f == NULL) { 35 | closure_f = caml_named_value("ocaml_call_prim"); 36 | if (!closure_f) { 37 | caml_failwith("call callback not registered"); 38 | } 39 | } 40 | intnat len[1] = {n}; 41 | caml_callback3(*closure_f, 42 | Val_int(id), 43 | Val_int(nargs), 44 | caml_ba_alloc(CAML_BA_INT64|CAML_BA_C_LAYOUT, 1, args, len)); 45 | } 46 | --------------------------------------------------------------------------------