├── tests ├── mod.wasm ├── mod.wat ├── add.wasm ├── const.wasm ├── mul.wasm ├── call.wasm ├── memory.wasm ├── add2.wasm ├── drop.wasm ├── nan.wasm ├── bigrec.wasm ├── loop.wasm ├── shrot.wasm ├── big_const.wasm ├── dune ├── floatadd.wasm ├── floatmul.wasm ├── tablebulk.wasm ├── trunc_sat.wasm ├── const.wat ├── multivalue.wasm ├── table_init.wasm ├── trunc_float.wasm ├── add3_export.wasm ├── memory_init_load.wasm ├── big_const.wat ├── add3_import.wasm ├── nan.wat ├── add.wat ├── drop.wat ├── multivalue.wat ├── mul.wat ├── add2.wat ├── call.wat ├── floatadd.wat ├── tableops.wasm ├── const.md ├── memory.md ├── call.md ├── loop.wat ├── add3_export.wat ├── memory.wat ├── add.md ├── trunc_float.wat ├── drop.md ├── floatmul.wat ├── mul.md ├── big_const.md ├── table_elem_nostart.wasm ├── table_elem_start.wasm ├── add3_import.wat ├── nan.md ├── multivalue.md ├── mod.md ├── table_init.wat ├── add2.md ├── floatmul.md ├── shrot.wat ├── trunc_sat.wat ├── bigrec.wat ├── floatadd.md ├── memory_init_load.wat ├── trunc_float.md ├── add3_export.md ├── tableops.wat ├── loop.md ├── add3_import.md ├── table_init.md ├── bigrec.md ├── trunc_sat.md ├── shrot.md ├── tablebulk.wat ├── memory_init_load.md ├── tableops.md ├── tablebulk.md ├── table_elem_nostart.wat ├── table_elem_start.wat ├── table_elem_start.md └── table_elem_nostart.md ├── .ci └── import_test.v ├── _CoqProject ├── theories ├── definitions.v ├── dune ├── simd_execute.v ├── binary_format_spec.v ├── array.v ├── ansi.v ├── floats.v ├── leb128_tests.v ├── check_toks.v ├── simd.v ├── type_progress.v ├── subtyping.v ├── utf8.v ├── host.v ├── efficient_extraction.v ├── binary_parser_types.v ├── list_extra.v ├── bytes_pp.v ├── extraction_instance.v ├── binary_format_tests.v ├── memory_list.v ├── leb128.v ├── memory.v └── tactic.v ├── .gitmodules ├── src ├── Parray │ ├── dune │ ├── Parray_shim.mli │ ├── Parray_shim.ml │ ├── Parray.mli │ └── Parray.ml ├── wast_execute.mli ├── convert.mli ├── utils.mli ├── convert.ml ├── utils.ml ├── SIMD_ops.mli ├── parse.mli ├── dune ├── extraction.v ├── output.mli ├── parse.ml ├── output.ml ├── execute.mli ├── shim.mli ├── wasm_coq_interpreter.ml ├── shim.ml ├── execute.ml └── SIMD_ops.ml ├── Makefile ├── .gitignore ├── changelogs ├── v2.2.1.md ├── v2.1.0.md ├── v2.2.0.md ├── v2.0.1.md ├── v2.0.2.md ├── v2.0.3.md └── v2.0.md ├── dune-project ├── LICENSE.txt ├── coq-wasm.opam ├── .github └── workflows │ └── main.yml ├── run_wast.sh └── README.md /tests/mod.wasm: -------------------------------------------------------------------------------- 1 | asm -------------------------------------------------------------------------------- /tests/mod.wat: -------------------------------------------------------------------------------- 1 | (module) 2 | -------------------------------------------------------------------------------- /tests/add.wasm: -------------------------------------------------------------------------------- 1 | asm`main 2 | A(Aj -------------------------------------------------------------------------------- /tests/const.wasm: -------------------------------------------------------------------------------- 1 | asm`main 2 | A* -------------------------------------------------------------------------------- /tests/mul.wasm: -------------------------------------------------------------------------------- 1 | asm`main 2 | AAl -------------------------------------------------------------------------------- /.ci/import_test.v: -------------------------------------------------------------------------------- 1 | From Wasm Require Import datatypes pp. 2 | -------------------------------------------------------------------------------- /tests/call.wasm: -------------------------------------------------------------------------------- 1 | asm`main 2 | A*  -------------------------------------------------------------------------------- /tests/memory.wasm: -------------------------------------------------------------------------------- 1 | asm`main 2 | A%A*6A%( -------------------------------------------------------------------------------- /tests/add2.wasm: -------------------------------------------------------------------------------- 1 | asm`main 2 |  j 3 | name -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R _build/default/theories Wasm 2 | -w overwriting-delimiting-key 3 | -------------------------------------------------------------------------------- /tests/drop.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/drop.wasm -------------------------------------------------------------------------------- /tests/nan.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/nan.wasm -------------------------------------------------------------------------------- /tests/bigrec.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/bigrec.wasm -------------------------------------------------------------------------------- /tests/loop.wasm: -------------------------------------------------------------------------------- 1 | asm`mainblock_brbr 2 | @  @  -------------------------------------------------------------------------------- /tests/shrot.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/shrot.wasm -------------------------------------------------------------------------------- /tests/big_const.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/big_const.wasm -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (deps 3 | (package coq-wasm) 4 | (glob_files *.wasm)) 5 | ) 6 | -------------------------------------------------------------------------------- /tests/floatadd.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/floatadd.wasm -------------------------------------------------------------------------------- /tests/floatmul.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/floatmul.wasm -------------------------------------------------------------------------------- /tests/tablebulk.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/tablebulk.wasm -------------------------------------------------------------------------------- /tests/trunc_sat.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/trunc_sat.wasm -------------------------------------------------------------------------------- /theories/definitions.v: -------------------------------------------------------------------------------- 1 | From Wasm Require Export datatypes typing opsem instantiation_spec. 2 | -------------------------------------------------------------------------------- /tests/const.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32) 3 | i32.const 42 4 | ) 5 | ) 6 | -------------------------------------------------------------------------------- /tests/multivalue.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/multivalue.wasm -------------------------------------------------------------------------------- /tests/table_init.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/table_init.wasm -------------------------------------------------------------------------------- /tests/trunc_float.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/trunc_float.wasm -------------------------------------------------------------------------------- /tests/add3_export.wasm: -------------------------------------------------------------------------------- 1 | asm` add3_importadd3 add3_exportnameadd3add3t -------------------------------------------------------------------------------- /tests/memory_init_load.wasm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Coq/HEAD/tests/memory_init_load.wasm -------------------------------------------------------------------------------- /tests/big_const.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32) 3 | i32.const 2000000000 4 | ) 5 | ) 6 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "wast_testsuite"] 2 | path = wast_testsuite 3 | url = https://github.com/WasmCert/testsuite 4 | -------------------------------------------------------------------------------- /src/Parray/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parray) 3 | (modules :standard) 4 | (wrapped false) 5 | (libraries zarith) 6 | ) -------------------------------------------------------------------------------- /tests/add3_import.wasm: -------------------------------------------------------------------------------- 1 | asm`` add2mainadd3 2 |    nameadd2addt -------------------------------------------------------------------------------- /tests/nan.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32) 3 | f32.const nan 4 | i32.reinterpret_f32 5 | ) 6 | ) 7 | -------------------------------------------------------------------------------- /tests/add.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32) 3 | i32.const 40 4 | i32.const 2 5 | i32.add 6 | ) 7 | ) 8 | -------------------------------------------------------------------------------- /tests/drop.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32) 3 | i32.const 42 4 | i32.const 123 5 | drop 6 | ) 7 | ) 8 | -------------------------------------------------------------------------------- /tests/multivalue.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32 i64) 3 | i32.const 42 4 | i64.const 10000 5 | )) 6 | 7 | -------------------------------------------------------------------------------- /tests/mul.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32) 3 | i32.const 7 4 | i32.const 3 5 | i32.mul 6 | ) 7 | ) 8 | 9 | -------------------------------------------------------------------------------- /tests/add2.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (param i32 i32) (result i32) 3 | local.get 0 4 | local.get 1 5 | i32.add) 6 | ) 7 | 8 | -------------------------------------------------------------------------------- /tests/call.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func $hello (result i32) 3 | i32.const 42 4 | ) 5 | (func (export "main") (result i32) 6 | call $hello) 7 | ) 8 | -------------------------------------------------------------------------------- /tests/floatadd.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (param f32 f32) (result f32) 3 | local.get 0 4 | local.get 1 5 | f32.add) 6 | ) 7 | 8 | -------------------------------------------------------------------------------- /tests/tableops.wasm: -------------------------------------------------------------------------------- 1 | asm`pmain A  2 | A A A AA%&A 7name f1f2f3 type1t1e1 -------------------------------------------------------------------------------- /src/wast_execute.mli: -------------------------------------------------------------------------------- 1 | (** Execution of Wast testing script from string. **) 2 | val run_wast_string: Output.verbosity -> int -> int -> string -> unit Execute.Host.host_event -------------------------------------------------------------------------------- /tests/const.md: -------------------------------------------------------------------------------- 1 | This test is a simple constant `i32.const 42` being returned. 2 | 3 | ```sh 4 | $ wasm_coq_interpreter const.wasm -r main 5 | i32.const 42 6 | 7 | ``` 8 | -------------------------------------------------------------------------------- /src/convert.mli: -------------------------------------------------------------------------------- 1 | (** Convert [int] to [Extract.nat]. **) 2 | val to_nat : int -> Extract.nat 3 | 4 | (** Convert [Extract.nat] to [int]. **) 5 | val from_nat : Extract.nat -> int -------------------------------------------------------------------------------- /tests/memory.md: -------------------------------------------------------------------------------- 1 | This test makes use of the `i32.store` and `i32.load` instructions. 2 | 3 | ```sh 4 | $ wasm_coq_interpreter memory.wasm -r main 5 | i32.const 42 6 | 7 | ``` 8 | -------------------------------------------------------------------------------- /tests/call.md: -------------------------------------------------------------------------------- 1 | This test defines a function `$hello` (returning `i32.const 42`) and calls it. 2 | 3 | ```sh 4 | $ wasm_coq_interpreter call.wasm -r main 5 | i32.const 42 6 | 7 | ``` 8 | -------------------------------------------------------------------------------- /tests/loop.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") 3 | (loop 4 | br 1)) 5 | (func (export "block_br") 6 | (block 7 | br 0)) 8 | (func (export "br") 9 | br 0) 10 | ) 11 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Wasm) 3 | (package coq-wasm) 4 | (flags -w "-notation-overridden,-abstract-large-number,-hiding-delimiting-key,-overwriting-delimiting-key") 5 | ) 6 | -------------------------------------------------------------------------------- /tests/add3_export.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $add3t (func (param i32 i32 i32) (result i32))) 3 | (import "add3_import" "add3" (func $add3 (type $add3t))) 4 | (export "add3_export" (func $add3))) 5 | 6 | -------------------------------------------------------------------------------- /tests/memory.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (memory 1) 3 | (func (export "main") (result i32) 4 | i32.const 37 5 | i32.const 42 6 | i32.store 7 | i32.const 37 8 | i32.load 9 | ) 10 | ) 11 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: 2 | opam install . 3 | 4 | SHELL := bash 5 | 6 | SCRIPT := ./run_wast.sh 7 | 8 | FOLDER ?= 9 | FILTER ?= 10 | 11 | .PHONY: run_wast 12 | run_wast: 13 | $(SCRIPT) "$(FOLDER)" "$(FILTER)" 14 | -------------------------------------------------------------------------------- /tests/add.md: -------------------------------------------------------------------------------- 1 | This test features the following addition: 2 | ```wasm 3 | i32.const 40 4 | i32.const 2 5 | i32.add 6 | ``` 7 | 8 | ```sh 9 | $ wasm_coq_interpreter add.wasm -r main 10 | i32.const 42 11 | 12 | ``` 13 | -------------------------------------------------------------------------------- /src/utils.mli: -------------------------------------------------------------------------------- 1 | (** Utility functions *) 2 | 3 | (** Create a string with only one character. *) 4 | val string_of_char : char -> string 5 | 6 | val z_of_int: int -> Big_int_Z.big_int 7 | 8 | val int_of_z: Big_int_Z.big_int -> int -------------------------------------------------------------------------------- /tests/trunc_float.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32 i32 i32) 3 | f32.const 42.69 4 | i32.trunc_f32_s 5 | f32.const -42.69 6 | i32.trunc_f32_s 7 | f64.const -42.69 8 | i32.trunc_f64_s 9 | )) -------------------------------------------------------------------------------- /tests/drop.md: -------------------------------------------------------------------------------- 1 | This test features dropping a value from the stack: 2 | ```wasm 3 | i32.const 42 4 | i32.const 123 5 | drop 6 | ``` 7 | 8 | ```sh 9 | $ wasm_coq_interpreter drop.wasm -r main 10 | i32.const 42 11 | 12 | ``` 13 | -------------------------------------------------------------------------------- /src/convert.ml: -------------------------------------------------------------------------------- 1 | let rec to_nat = function 2 | | 0 -> Extract.O 3 | | n when n > 0 -> Extract.S (to_nat (n - 1)) 4 | | _ -> failwith "not a nat" 5 | 6 | let rec from_nat = function 7 | | Extract.O -> 0 8 | | Extract.S n -> 1 + from_nat n -------------------------------------------------------------------------------- /tests/floatmul.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $t0 (func (result f32))) 3 | (func $calculate (export "main") (type $t0) (result f32) 4 | (f32.mul 5 | (f32.const 0x1.a0aa7ep+7 (;=208.333;)) 6 | (f32.const 0x1.388p+7 (;=156.25;))))) 7 | -------------------------------------------------------------------------------- /tests/mul.md: -------------------------------------------------------------------------------- 1 | This test contains an integer multiplication. 2 | 3 | ```wasm 4 | (i32.mul 5 | (i32.const 7) 6 | (i32.const 3)) 7 | ``` 8 | 9 | ```sh 10 | $ wasm_coq_interpreter mul.wasm -r main 11 | i32.const 21 12 | 13 | ``` 14 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | let string_of_char c = String.make 1 c 2 | 3 | let z_of_int x = 4 | Big_int_Z.big_int_of_int x 5 | 6 | let int_of_z z = 7 | if Big_int_Z.is_int_big_int z then 8 | Big_int_Z.int_of_big_int z 9 | else invalid_arg "int_of_z overflow" -------------------------------------------------------------------------------- /tests/big_const.md: -------------------------------------------------------------------------------- 1 | This test features the parsing and printing of a large i32 numeric value:: 2 | ```wasm 3 | i32.const 2000000000 4 | ``` 5 | 6 | ```sh 7 | $ wasm_coq_interpreter big_const.wasm -r main 8 | i32.const 2000000000 9 | 10 | ``` 11 | -------------------------------------------------------------------------------- /tests/table_elem_nostart.wasm: -------------------------------------------------------------------------------- 1 | asm````p,addTwoaddThreeswapmaintable0 A A  2 | ; j 3 |  jj AA%&AA%&AA%& AAA ZnameaddTwoaddThreeswapmain  ft0ft1 table0elem0elem1 -------------------------------------------------------------------------------- /tests/table_elem_start.wasm: -------------------------------------------------------------------------------- 1 | asm````p,addTwoaddThreeswapmaintable0 A A  2 | ; j 3 |  jj AA%&AA%&AA%& AAA ZnameaddTwoaddThreeswapmain  ft0ft1 table0elem0elem1 -------------------------------------------------------------------------------- /tests/add3_import.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $addt (func (param i32 i32) (result i32))) 3 | (import "add2" "main" (func $add2 (type $addt))) 4 | (func (export "add3") (param i32 i32 i32) (result i32) 5 | local.get 0 6 | local.get 1 7 | call $add2 8 | local.get 2 9 | call $add2 10 | ) 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /tests/nan.md: -------------------------------------------------------------------------------- 1 | This test contains an reinterpretation of f32.nan to a 32-bit integer. 2 | 3 | ```wasm 4 | f32.const nan 5 | i32.reinterpret_f32 6 | ``` 7 | 8 | ```sh 9 | $ wasm_coq_interpreter nan.wasm -r main 10 | i32.const 2143289344 11 | 12 | ``` 13 | Note: 2143289344 = 0x7fc00000 = nan (exponent = 255, mantissa = 4194304). 14 | -------------------------------------------------------------------------------- /tests/multivalue.md: -------------------------------------------------------------------------------- 1 | This test contains a function returning multiple values. 2 | 3 | ```wasm 4 | (module 5 | (func (export "main") (result i32 i64) 6 | i32.const 42 7 | i64.const 10000 8 | )) 9 | ``` 10 | 11 | ```sh 12 | $ wasm_coq_interpreter multivalue.wasm -r main 13 | i32.const 42 14 | i64.const 10000 15 | 16 | ``` 17 | -------------------------------------------------------------------------------- /tests/mod.md: -------------------------------------------------------------------------------- 1 | This is a very minimalistic test, containing just an empty module: 2 | ```wasm 3 | (module) 4 | ``` 5 | 6 | An empty module is syntactically valid, but one can’t execute any function from it. 7 | ```sh 8 | $ wasm_coq_interpreter mod.wasm 9 | wasm_interpreter: The specified function does not exist 10 | [123] 11 | ``` 12 | 13 | -------------------------------------------------------------------------------- /tests/table_init.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func $f (param i32 i32 i32) 3 | local.get 0 4 | local.get 1 5 | local.get 2 6 | table.init 0 1 7 | ) 8 | (func (export "main") 9 | i32.const 0 10 | i32.const 0 11 | i32.const 0 12 | call $f 13 | ) 14 | (table 2 funcref) 15 | (elem 1) 16 | (elem 5) 17 | ) 18 | 19 | -------------------------------------------------------------------------------- /tests/add2.md: -------------------------------------------------------------------------------- 1 | This test features an addition function taking arguments from the CLI. 2 | ```wasm 3 | (module 4 | (func (export "main") (param i32 i32) (result i32) 5 | local.get 0 6 | local.get 1 7 | i32.add) 8 | ) 9 | 10 | ``` 11 | 12 | ```sh 13 | $ wasm_coq_interpreter add2.wasm -r main -a "i32.const 12_3" -a "i32.const -8_1" 14 | i32.const 42 15 | 16 | ``` 17 | -------------------------------------------------------------------------------- /tests/floatmul.md: -------------------------------------------------------------------------------- 1 | This test contains a floating point multiplication. 2 | 3 | Note: 0x1.fca01ep+14 = 32552.029; 208.333 * 156.25 = 32552.0312. 4 | 5 | ```wasm 6 | (f32.mul 7 | (f32.const 0x1.a0aa7ep+7 (;=208.333;)) 8 | (f32.const 0x1.388p+7 (;=156.25;))) 9 | ``` 10 | 11 | ```sh 12 | $ wasm_coq_interpreter floatmul.wasm -r main 13 | f32.const +0x1.fca01ep+14 14 | 15 | ``` 16 | -------------------------------------------------------------------------------- /tests/shrot.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i64 i64 i64 i64 i64) 3 | i64.const 1 4 | i64.const 65 5 | i64.shl 6 | i64.const 1 7 | i64.const 64 8 | i64.shr_u 9 | i64.const -1 10 | i64.const 67 11 | i64.shr_s 12 | i64.const 1 13 | i64.const 65 14 | i64.rotl 15 | i64.const 1 16 | i64.const 65 17 | i64.rotr 18 | )) 19 | -------------------------------------------------------------------------------- /tests/trunc_sat.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32 i32 i32 i64 i64) 3 | f64.const 0x1.a0aa7ep+7 (;=208.333;) 4 | i32.trunc_sat_f64_s 5 | f32.const nan 6 | i32.trunc_sat_f32_u 7 | f32.const -inf 8 | i32.trunc_sat_f32_s 9 | f64.const 0x1.388p+7 (;=156.25;) 10 | i64.trunc_sat_f64_s 11 | f32.const inf 12 | i64.trunc_sat_f32_u 13 | ) 14 | ) 15 | -------------------------------------------------------------------------------- /src/SIMD_ops.mli: -------------------------------------------------------------------------------- 1 | val app_vunop_str : Big_int_Z.big_int -> string -> string 2 | 3 | val app_vbinop_str : Big_int_Z.big_int * (Big_int_Z.big_int list) -> string -> string -> string 4 | 5 | val app_vternop_str : Big_int_Z.big_int -> string -> string -> string -> string 6 | 7 | val app_vtestop_str : Big_int_Z.big_int -> string -> string 8 | 9 | val app_vshiftop_str : Big_int_Z.big_int -> string -> string -> string -------------------------------------------------------------------------------- /tests/bigrec.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "idrec") (param i32) (result i32) 3 | local.get 0 4 | if (result i32) 5 | local.get 0 6 | i32.const 1 7 | i32.sub 8 | call 0 9 | i32.const 1 10 | i32.add 11 | else i32.const 0 12 | end 13 | ) 14 | (func (export "main") (result i32) 15 | i32.const 1048576 16 | call 0 17 | ) 18 | ) 19 | -------------------------------------------------------------------------------- /tests/floatadd.md: -------------------------------------------------------------------------------- 1 | This test features an addition function for floats taking arguments from the CLI. 2 | ```wasm 3 | (module 4 | (func (export "main") (param f32 f32) (result f32) 5 | local.get 0 6 | local.get 1 7 | f32.add) 8 | ) 9 | 10 | ``` 11 | 12 | ```sh 13 | $ wasm_coq_interpreter floatadd.wasm -r main -a "f32.const 12.30" -a "f32.const -1.6_4" 14 | f32.const +0x1.551eb8p+3 15 | 16 | ``` 17 | -------------------------------------------------------------------------------- /tests/memory_init_load.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "main") (result i32 i32 i32) 3 | i32.const 0 4 | i32.load 5 | i32.const 4 6 | i32.load 7 | i32.const 4 8 | i32.const 0 9 | i32.const 4 10 | memory.init $dat2 11 | i32.const 4 12 | i32.load 13 | ) 14 | (memory $mem 2 3) 15 | (data $dat (memory $mem) (offset (i32.const 4)) "\03\03\03\03") 16 | (data $dat2 "\04\04\04\04") 17 | ) 18 | 19 | -------------------------------------------------------------------------------- /tests/trunc_float.md: -------------------------------------------------------------------------------- 1 | This test contains a few trunc instructions on floats. 2 | 3 | ```wasm 4 | (module 5 | (func (export "main") (result i32 i32 i32) 6 | f32.const 42.69 7 | i32.trunc_f32_s 8 | f32.const -42.69 9 | i32.trunc_f32_s 10 | f64.const -42.69 11 | i32.trunc_f64_s 12 | )) 13 | 14 | 15 | ``` 16 | 17 | ```sh 18 | $ wasm_coq_interpreter trunc_float.wasm -r main 19 | i32.const 42 20 | i32.const -42 21 | i32.const -42 22 | 23 | ``` 24 | 25 | -------------------------------------------------------------------------------- /tests/add3_export.md: -------------------------------------------------------------------------------- 1 | This test features exporting an imported function. 2 | ```wasm 3 | (module 4 | (type $add3t (func (param i32 i32 i32) (result i32))) 5 | (import "add3_import" "add3" (func $add3 (type $add3t))) 6 | (export "add3_export" (func $add3)) 7 | ) 8 | 9 | ``` 10 | 11 | ```sh 12 | $ wasm_coq_interpreter add2.wasm add3_import.wasm add3_export.wasm -m add3_export -r add3_export -a "i32.const 12_3" -a "i32.const -8_3" -a "i32.const +2" 13 | i32.const 42 14 | 15 | ``` 16 | -------------------------------------------------------------------------------- /tests/tableops.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $type1 (func (result i32))) 3 | (table $t1 4 funcref) 4 | (func $f1 (result i32) 5 | i32.const 1) 6 | (func $f2 (result i32) 7 | i32.const 2) 8 | (func $f3 (result i32) 9 | i32.const 3) 10 | (elem $e1 $t1 (i32.const 1) $f1 $f2 $f3) 11 | (func (export "main") (result i32) 12 | i32.const 0 13 | i32.const 3 14 | table.get 0 15 | table.set 0 16 | i32.const 0 17 | call_indirect $t1 (type $type1) 18 | ) 19 | ) 20 | 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | /_build/* 3 | /node_modules/ 4 | /_esy/ 5 | /_opam/ 6 | /_destdir/ 7 | 8 | .merlin 9 | *.install 10 | .vscode/settings.json 11 | 12 | *~ 13 | \#*\# 14 | *.swp 15 | 16 | *.log 17 | *.vo 18 | *.vio 19 | *.vos 20 | *.vok 21 | *.glob 22 | *.aux 23 | *.orig 24 | .DS_Store 25 | .lia.cache 26 | .nia.cache 27 | 28 | .saves 29 | .DS_Store 30 | 31 | /wast/ 32 | 33 | /wasm_interpreter 34 | /wasm_coq_interpreter.exe 35 | /history.txt 36 | /profile.json 37 | 38 | !_build/ 39 | !_build/default/src/extract.ml 40 | -------------------------------------------------------------------------------- /changelogs/v2.2.1.md: -------------------------------------------------------------------------------- 1 | # Release 2.2.1 2 | 3 | ## New Features 4 | - Extended the persistent array interfaces to allow bulk update by byte generators. This avoids creating redundant historic versions of memories and should result in a slight speedup in memory update operations. 5 | 6 | ## Refactorings 7 | - Removed dependency on the Uint63 module. The persistent array module now uses OCaml's `int` instead, which is 63-bit on 64-bit OCaml. 8 | 9 | ## Bugfixes 10 | - Corrected an errorneous type alias used in simd vector operations. 11 | -------------------------------------------------------------------------------- /changelogs/v2.1.0.md: -------------------------------------------------------------------------------- 1 | # Release 2.1.0 2 | 3 | ## New Features 4 | - Added the tail call feature extension proposal. This has not been tested against the test suite since the reference `.wast` parser doesn't implement it as part of the standard yet. 5 | 6 | ## Miscellaneous 7 | - `invert_e_typing` now deals with `thread_typing` as well. Some of the old typing inversion code can be simplfied as a result. 8 | - The legacy lookup notation `!!` in `instantiation_properties.v` is now removed. Users dependent on this notation can import the it from the original stdpp library. -------------------------------------------------------------------------------- /tests/loop.md: -------------------------------------------------------------------------------- 1 | This test contains three simple examples of the usage of `br`. 2 | 3 | One is located in a loop, and exits it (`br 0` would infinitively loop): 4 | ```wasm 5 | main 6 | br 1 7 | ``` 8 | The second one is located in a block, and also exits it: 9 | ```wasm 10 | block 11 | br 0 12 | ``` 13 | Finally, the third one is located at the top-level: 14 | ```wasm 15 | br 0 16 | ``` 17 | 18 | ```sh 19 | $ wasm_coq_interpreter loop.wasm -r main 20 | 21 | $ wasm_coq_interpreter loop.wasm -r block_br 22 | 23 | $ wasm_coq_interpreter loop.wasm -r br 24 | 25 | ``` 26 | -------------------------------------------------------------------------------- /tests/add3_import.md: -------------------------------------------------------------------------------- 1 | This test features the import of a function from another module (`add2`). 2 | ```wasm 3 | (module 4 | (type $addt (func (param i32 i32) (result i32))) 5 | (import "add2" "main" (func $add2 (type $addt))) 6 | (func (export "add3") (param i32 i32 i32) (result i32) 7 | local.get 0 8 | local.get 1 9 | call $add2 10 | local.get 2 11 | call $add2 12 | ) 13 | ) 14 | 15 | ``` 16 | 17 | ```sh 18 | $ wasm_coq_interpreter add2.wasm add3_import.wasm -m add3_import -r add3 -a "i32.const 12_3" -a "i32.const -8_0" -a "i32.const -1" 19 | i32.const 42 20 | 21 | ``` 22 | -------------------------------------------------------------------------------- /tests/table_init.md: -------------------------------------------------------------------------------- 1 | This test is a regression test for the `table.init x y` instruction, whose arguments in the binary format are supposed to be in reverse order. 2 | 3 | ```wasm 4 | (module 5 | (func $f (param i32 i32 i32) 6 | local.get 0 7 | local.get 1 8 | local.get 2 9 | table.init 0 1 10 | ) 11 | (func (export "main") 12 | i32.const 0 13 | i32.const 0 14 | i32.const 0 15 | call $f 16 | ) 17 | (table 2 funcref) 18 | (elem 1) 19 | (elem 5) 20 | ) 21 | 22 | ``` 23 | 24 | ```sh 25 | $ wasm_coq_interpreter table_init.wasm -r main 26 | 27 | ``` 28 | 29 | -------------------------------------------------------------------------------- /tests/bigrec.md: -------------------------------------------------------------------------------- 1 | This test features a very deep recursive function call (1048576 nested calls). 2 | ```wasm 3 | (module 4 | (func (export "idrec") (param i32) (result i32) 5 | local.get 0 6 | if (result i32) 7 | local.get 0 8 | i32.const 1 9 | i32.sub 10 | call 0 11 | i32.const 1 12 | i32.add 13 | else i32.const 0 14 | end 15 | ) 16 | (func (export "main") (result i32) 17 | i32.const 1048576 18 | call 0 19 | ) 20 | ) 21 | 22 | ``` 23 | 24 | ```sh 25 | $ wasm_coq_interpreter bigrec.wasm -r main 26 | i32.const 1048576 27 | 28 | ``` 29 | -------------------------------------------------------------------------------- /tests/trunc_sat.md: -------------------------------------------------------------------------------- 1 | This test contains some saturated trunc operations. 2 | 3 | ```wasm 4 | (module 5 | (func (export "main") (result i32 i32 i32 i64 i64) 6 | f64.const 0x1.a0aa7ep+7 (;=208.333;) 7 | i32.trunc_sat_f64_s 8 | f32.const nan 9 | i32.trunc_sat_f32_u 10 | f32.const -inf 11 | i32.trunc_sat_f32_s 12 | f64.const 0x1.388p+7 (;=156.25;) 13 | i64.trunc_sat_f64_s 14 | f32.const inf 15 | i64.trunc_sat_f32_u 16 | ) 17 | ) 18 | ``` 19 | 20 | ```sh 21 | $ wasm_coq_interpreter trunc_sat.wasm -r main 22 | i32.const 208 23 | i32.const 0 24 | i32.const -2147483648 25 | i64.const 156 26 | i64.const -1 27 | 28 | ``` 29 | 30 | -------------------------------------------------------------------------------- /tests/shrot.md: -------------------------------------------------------------------------------- 1 | This test contains a few numeric shifts/rotations. 2 | 3 | ```wasm 4 | (module 5 | (func (export "main") (result i64 i64 i64 i64 i64) 6 | i64.const 1 7 | i64.const 65 8 | i64.shl 9 | i64.const 1 10 | i64.const 64 11 | i64.shr_u 12 | i64.const -1 13 | i64.const 67 14 | i64.shr_s 15 | i64.const 1 16 | i64.const 65 17 | i64.rotl 18 | i64.const 1 19 | i64.const 65 20 | i64.rotr 21 | )) 22 | 23 | 24 | ``` 25 | 26 | ```sh 27 | $ wasm_coq_interpreter shrot.wasm -r main 28 | i64.const 2 29 | i64.const 1 30 | i64.const -1 31 | i64.const 2 32 | i64.const -9223372036854775808 33 | 34 | ``` 35 | 36 | -------------------------------------------------------------------------------- /tests/tablebulk.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $type1 (func (result i32))) 3 | (table $t1 4 funcref) 4 | (func $f1 (result i32) 5 | i32.const 1) 6 | (func $f2 (result i32) 7 | i32.const 2) 8 | (func $f3 (result i32) 9 | i32.const 3) 10 | (elem $e1 $t1 (i32.const 1) $f1 $f2 $f3) 11 | (func (export "main") (result i32) 12 | i32.const 0 13 | i32.const 3 14 | table.get 0 15 | table.set 0 16 | i32.const 3 17 | table.get 0 18 | i32.const 3 19 | table.grow $t1 20 | drop 21 | i32.const 0 22 | i32.const 1 23 | i32.const 2 24 | table.copy $t1 $t1 25 | i32.const 0 26 | call_indirect $t1 (type $type1) 27 | ) 28 | ) 29 | 30 | -------------------------------------------------------------------------------- /tests/memory_init_load.md: -------------------------------------------------------------------------------- 1 | This is a regression test for memarg parsing and also a general test for data segments. 2 | 3 | ```wasm 4 | (module 5 | (func (export "main") (result i32 i32 i32) 6 | i32.const 0 7 | i32.load 8 | i32.const 4 9 | i32.load 10 | i32.const 4 11 | i32.const 0 12 | i32.const 4 13 | memory.init $dat2 14 | i32.const 4 15 | i32.load 16 | ) 17 | (memory $mem 2 3) 18 | (data $dat (memory $mem) (offset (i32.const 4)) "\03\03\03\03") 19 | (data $dat2 "\04\04\04\04") 20 | ) 21 | 22 | ``` 23 | 24 | ```sh 25 | $ wasm_coq_interpreter memory_init_load.wasm -r main 26 | i32.const 0 27 | i32.const 50529027 28 | i32.const 67372036 29 | 30 | ``` 31 | -------------------------------------------------------------------------------- /tests/tableops.md: -------------------------------------------------------------------------------- 1 | This test contains some compositions of table and element-related operations. 2 | 3 | ```wasm 4 | (module 5 | (type $type1 (func (result i32))) 6 | (table $t1 4 funcref) 7 | (func $f1 (result i32) 8 | i32.const 1) 9 | (func $f2 (result i32) 10 | i32.const 2) 11 | (func $f3 (result i32) 12 | i32.const 3) 13 | (elem $e1 $t1 (i32.const 1) $f1 $f2 $f3) 14 | (func (export "main") (result i32) 15 | i32.const 0 16 | i32.const 3 17 | table.get 0 18 | table.set 0 19 | i32.const 0 20 | call_indirect $t1 (type $type1) 21 | ) 22 | ) 23 | ``` 24 | 25 | ```sh 26 | $ wasm_coq_interpreter tableops.wasm -r main 27 | i32.const 3 28 | 29 | ``` 30 | 31 | -------------------------------------------------------------------------------- /src/Parray/Parray_shim.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | val length : 'a t -> Big_int_Z.big_int 3 | val get : 'a t -> Big_int_Z.big_int -> 'a 4 | val set : 'a t -> Big_int_Z.big_int -> 'a -> 'a t 5 | 6 | val set_gen : 'a t -> Big_int_Z.big_int -> Big_int_Z.big_int -> (Big_int_Z.big_int -> 'a) -> 'a t 7 | (** [set_gen p start_pos block_len generator] returns a new persistent array 8 | based on [p] where the range of length [block_len] starting at [start_pos] 9 | is updated by calling [generator] for each index 0 to [block_len - 1]. 10 | [block_len] must be greater than 0. *) 11 | 12 | val default : 'a t -> 'a 13 | val make : Big_int_Z.big_int -> 'a -> 'a t 14 | val make_copy : Big_int_Z.big_int -> 'a -> 'a t -> Big_int_Z.big_int -> 'a t 15 | val copy : 'a t -> 'a t -------------------------------------------------------------------------------- /theories/simd_execute.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool eqtype seq ssrnat. 2 | From Wasm Require Import datatypes. 3 | From Coq Require Import String. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | (* Cannot use Module Type + Declare Module because it doesn't extract *) 10 | Module SIMD_ops. 11 | 12 | Parameter app_vunop_str : vunop -> string -> string. 13 | Parameter app_vbinop_str : vbinop -> string -> string -> string. 14 | Parameter app_vternop_str : vternop -> string -> string -> string -> string. 15 | Parameter app_vtestop_str : vtestop -> string -> string. 16 | Parameter app_vshiftop_str : vshiftop -> string -> string -> string. 17 | 18 | End SIMD_ops. 19 | 20 | Module Export simd_ops_export := SIMD_ops. 21 | 22 | -------------------------------------------------------------------------------- /theories/binary_format_spec.v: -------------------------------------------------------------------------------- 1 | From Wasm Require Import datatypes_properties binary_parser_types. 2 | From Wasm Require Import binary_format_parser binary_format_printer. 3 | From compcert Require Import Integers. 4 | From parseque Require Import Parseque. 5 | Require Import Strings.Byte. 6 | Require Import leb128. 7 | 8 | Inductive repr_unsigned : list byte -> module -> Prop := 9 | . 10 | 11 | Inductive repr_module : list byte -> module -> Prop := 12 | . 13 | 14 | (* TODO: we should have ast->binary->ast = id 15 | but not binary->ast->binary /= id, because of non-unique representation . 16 | 17 | Lemma encode_decode_is_identity : forall m, 18 | (* TODO: probably need some well-formedness condition, for example of block types *) 19 | run_parse_module (binary_of_module m) = Some m. 20 | (* TODO *) 21 | *) 22 | 23 | -------------------------------------------------------------------------------- /tests/tablebulk.md: -------------------------------------------------------------------------------- 1 | This test contains some compositions of table and element-related operations. 2 | 3 | ```wasm 4 | (module 5 | (type $type1 (func (result i32))) 6 | (table $t1 4 funcref) 7 | (func $f1 (result i32) 8 | i32.const 1) 9 | (func $f2 (result i32) 10 | i32.const 2) 11 | (func $f3 (result i32) 12 | i32.const 3) 13 | (elem $e1 $t1 (i32.const 1) $f1 $f2 $f3) 14 | (func (export "main") (result i32) 15 | i32.const 0 16 | i32.const 3 17 | table.get 0 18 | table.set 0 19 | i32.const 3 20 | table.get 0 21 | i32.const 3 22 | table.grow $t1 23 | drop 24 | i32.const 0 25 | i32.const 1 26 | i32.const 2 27 | table.copy $t1 $t1 28 | i32.const 0 29 | call_indirect $t1 (type $type1) 30 | ) 31 | ) 32 | 33 | ``` 34 | 35 | ```sh 36 | $ wasm_coq_interpreter tablebulk.wasm -r main 37 | i32.const 1 38 | 39 | ``` 40 | 41 | -------------------------------------------------------------------------------- /theories/array.v: -------------------------------------------------------------------------------- 1 | (** a naive functional representation of an array *) 2 | (* (C) J. Pichon - see LICENSE.txt *) 3 | 4 | (* this works well when there are few updates *) 5 | Module Type Index_Sig. 6 | Parameter Index : Type. 7 | Parameter index_eqb : Index -> Index -> bool. 8 | Parameter Value : Type. 9 | End Index_Sig. 10 | 11 | Module Make (X : Index_Sig). 12 | Import X. 13 | 14 | Inductive array : Type := 15 | | A_init : Value -> array 16 | | A_update : Index -> Value -> array -> array. 17 | 18 | Definition make (v : Value) : array := 19 | A_init v. 20 | 21 | Fixpoint get (arr : array) (idx : Index) : Value := 22 | match arr with 23 | | A_init a => a 24 | | A_update idx' a arr' => 25 | if index_eqb idx idx' then a 26 | else get arr' idx 27 | end. 28 | 29 | Definition set (arr : array) (idx : Index) (a : Value) : array := 30 | A_update idx a arr. 31 | 32 | End Make. 33 | 34 | -------------------------------------------------------------------------------- /changelogs/v2.2.0.md: -------------------------------------------------------------------------------- 1 | # Release 2.2.0 2 | 3 | ## New Features 4 | - Implemented SIMD execution via eval functions in the reference implementation. The extracted runtime now pass the full Wasm 2.0 test suite. 5 | 6 | ## Refactorings and Infrastructural Changes 7 | - Extraction now extracts Coq's `String.string` to OCaml native `string` instead of `char list`. The signature of various interfaces are updated accordingly. 8 | - Extraction now extracts Coq's binary integers (N/Z/positive) to ZArith's BigInt instead. The original conversion functions are therefore deprecated. New conversion functions between ZArith's BigInt and OCaml's native int are added. This is to avoid cyclic dependencies in the parametric SIMD implementations. 9 | - The testing script `run_wast.sh` and the makefile now support testing a subset of the test suite by passing in a filter argument. For example: `make run_wast FILTER="simd"` runs only the simd tests. -------------------------------------------------------------------------------- /theories/ansi.v: -------------------------------------------------------------------------------- 1 | 2 | (** ANSI escape sequences -- work in progress *) 3 | Require Import Coq.Strings.String. 4 | Open Scope string_scope. 5 | 6 | Definition ansi_escape_char : Ascii.ascii := Ascii.ascii_of_byte Byte.x1b. 7 | 8 | Definition ansi_escape : string := String ansi_escape_char EmptyString. 9 | 10 | Inductive ansi_fg : Type := 11 | | FG_reset 12 | | FG_green 13 | | FG_red 14 | | FG_yellow 15 | | FG_blue 16 | | FG_magenta 17 | | FG_cyan 18 | | FG_bold. 19 | 20 | Definition code_of_fg (fg : ansi_fg) : string := 21 | match fg with 22 | | FG_reset => "0" 23 | | FG_bold => "1" 24 | | FG_red => "31" 25 | | FG_green => "32" 26 | | FG_yellow => "33" 27 | | FG_blue => "34" 28 | | FG_magenta => "35" 29 | | FG_cyan => "36" 30 | end. 31 | 32 | Definition show_fg (fg : ansi_fg) : string := 33 | ansi_escape ++ "[" ++ code_of_fg fg ++ "m". 34 | 35 | Definition with_fg (fg : ansi_fg) (s : string) : string := 36 | show_fg fg ++ s ++ show_fg FG_reset. -------------------------------------------------------------------------------- /theories/floats.v: -------------------------------------------------------------------------------- 1 | From Flocq Require Import Bits. 2 | Require Import Strings.Byte. 3 | Require Import BinNums ZArith.BinInt. 4 | 5 | (* TODO: this to circumvent Flocq's "binary" representation of floats *) 6 | 7 | Definition Z_of_byte (b : byte) : Z := 8 | let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, b8))))))) := Byte.to_bits b in 9 | let inj (b : bool) := if b then Z.one else Z.zero in 10 | Zplus (inj b1) (Z.mul 256 ( 11 | Zplus (inj b1) (Z.mul 256 ( 12 | Zplus (inj b3) (Z.mul 256 ( 13 | Zplus (inj b4) (Z.mul 256 ( 14 | Zplus (inj b5) (Z.mul 256 ( 15 | Zplus (inj b6) (Z.mul 256 ( 16 | Zplus (inj b7) (Z.mul 256 ( 17 | (inj b8))))))))))))))). 18 | 19 | (* little endian *) 20 | Fixpoint Z_of_bytes_aux (acc : Z) (factor : Z) (bs : list byte) := 21 | match bs with 22 | | nil => acc 23 | | cons b bs' => Z_of_bytes_aux (Z.add acc (Z.mul factor (Z_of_byte b))) (Zplus 256 factor) bs' 24 | end. 25 | 26 | Definition Z_of_bytes (bs : list byte) := 27 | Z_of_bytes_aux Z.zero Z.one bs. 28 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.11) 2 | (using coq 0.2) 3 | (using mdx 0.2) 4 | (name coq-wasm) 5 | (version 2.2.1) 6 | 7 | (generate_opam_files true) 8 | (license MIT) 9 | (source (github WasmCert/WasmCert-Coq)) 10 | 11 | (warnings (deprecated_coq_lang_lt_08 disabled)) 12 | 13 | (package 14 | (name coq-wasm) 15 | (synopsis "Wasm formalisation in Coq") 16 | (description "Wasm formalisation in Coq, following the AFP formalisation of Conrad Watt") 17 | (depends 18 | (coq (and (>= 9.0) (< 9.2~))) 19 | (coq-compcert (>= 3.14)) 20 | (coq-ext-lib (>= 0.11.8)) 21 | (coq-mathcomp-ssreflect (and (>= 2.4.0) (<= 2.5~))) 22 | (rocq-parseque (>= 0.2.0)) 23 | (cmdliner (>= 1.1.0)) 24 | (linenoise (>= 1.4.0)) 25 | (mdx (>= 1.9.0)) 26 | (wasm (and (>= 2.0.2) (<= 2.0.2))) 27 | (zarith (>= 1.11)) 28 | ) 29 | (maintainers 30 | "Xiaojia Rao" 31 | "Martin Bodin" 32 | ) 33 | (authors 34 | "Martin Bodin" 35 | "Philippa Gardner" 36 | "Jean Pichon" 37 | "Xiaojia Rao" 38 | "Conrad Watt" 39 | ) 40 | ) 41 | -------------------------------------------------------------------------------- /src/parse.mli: -------------------------------------------------------------------------------- 1 | (** Parsing **) 2 | 3 | (** Trying to guess the module name by the file name provided for the module. *) 4 | val extract_module_name: string -> string 5 | 6 | (* Convert a Wasm text module into the binary format. *) 7 | val binary_of_text: string -> string option 8 | 9 | (** Parse a module given the module string. The text flag specifies whether the argument is in binary format or text format. *) 10 | val parse_module: Output.verbosity -> bool -> string -> Extract.module0 Execute.Host.host_event 11 | 12 | (* Parse a list of modules. *) 13 | val parse_modules: Output.verbosity -> bool -> string list -> (Extract.module0 list) Execute.Host.host_event 14 | 15 | (* Parsing the arguments of a function call in text format. *) 16 | val parse_arg: string -> (Execute.Interpreter.value) option 17 | 18 | (* Parsing a list of arguments from text format string. *) 19 | val parse_args: string list -> (Execute.Interpreter.value list) Execute.Host.host_event 20 | 21 | (* Parsing a wast script from a string. *) 22 | val parse_wast: string -> Wasm.Script.script -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (coq.extraction 2 | (prelude extraction) 3 | (extracted_modules extract) 4 | (theories Wasm) 5 | (flags -w "-extraction-reserved-identifier") 6 | ) 7 | 8 | 9 | (executable 10 | (name wasm_coq_interpreter) 11 | (libraries cmdliner linenoise wasm unix parray zarith) 12 | (modes (best exe)) 13 | (public_name wasm_coq_interpreter) 14 | (promote (into ../)) 15 | ) 16 | 17 | (env (dev (flags (:standard -warn-error -A -w -39 -w -50))) 18 | (release ;; <- notice the change here 19 | (flags (:standard -w -50-32-27-9-69-34-37-33)) 20 | (ocamlopt_flags (:standard -unsafe -noassert -inline 100)))) 21 | ; Removing the following warnings: 22 | ; - 50: unattached documentation comment, as it doesn’t fit the way we document our code. 23 | ; - 39: unused rec flag, as Coq generates a lot of these in its extraction. 24 | ; We could also remove the following, as Coq generates a lot of these in its extraction, but these are useful to track issues in the shim: 25 | ; - 20: this argument will not be used by the function. 26 | ; - 34: unused type 27 | ; - 32: unused value. 28 | 29 | -------------------------------------------------------------------------------- /src/Parray/Parray_shim.ml: -------------------------------------------------------------------------------- 1 | (* A wrapper file for the custom Parray module to take arguments of type `Z.t` instead of OCaml's `int`. 2 | Note that this does not magically allow the 31st bit to be used on 32-bit OCaml distributions. 3 | It is rather for connecting the unbounded integer types in the extracted code to the `int` 4 | length parameter requried by OCaml's `Array.make`. 5 | *) 6 | 7 | type 'a t = 'a Parray.t 8 | 9 | let z_of_int x = 10 | Big_int_Z.big_int_of_int x 11 | 12 | let int_of_z z = 13 | if Big_int_Z.is_int_big_int z then 14 | Big_int_Z.int_of_big_int z 15 | else invalid_arg "int_of_z overflow" 16 | 17 | let length a = z_of_int (Parray.length a) 18 | let make z a = Parray.make (int_of_z z) a 19 | 20 | let copy = Parray.copy 21 | 22 | let make_copy n init arr initlen = 23 | Parray.make_copy (int_of_z n) init arr (int_of_z initlen) 24 | 25 | let get a z = Parray.get a (int_of_z z) 26 | 27 | let set a z v = Parray.set a (int_of_z z) v 28 | 29 | let set_gen a z len gen = 30 | Parray.set_gen a (int_of_z z) (int_of_z len) (fun id -> gen (z_of_int id)) 31 | 32 | let default = Parray.default -------------------------------------------------------------------------------- /tests/table_elem_nostart.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $ft0 (func (param i32 i32) (result i32))) 3 | (type $ft1 (func (param i32 i32 i32) (result i32))) 4 | (func $addTwo (export "addTwo") (type $ft0) 5 | local.get 0 6 | local.get 1 7 | i32.add) 8 | (func $addThree (export "addThree") (type $ft1) 9 | local.get 0 10 | local.get 1 11 | local.get 2 12 | i32.add 13 | i32.add) 14 | (func $swap (export "swap") 15 | i32.const 2 16 | i32.const 1 17 | table.get 0 18 | table.set 0 19 | 20 | i32.const 1 21 | i32.const 0 22 | table.get 0 23 | table.set 0 24 | 25 | i32.const 0 26 | i32.const 2 27 | table.get 0 28 | table.set 0 29 | ) 30 | (func $main (export "main")(result i32) 31 | i32.const 2 32 | i32.const 3 33 | i32.const 0 34 | call_indirect 0 (type $ft0) 35 | ) 36 | (table $table0 (export "table0") 3 funcref) 37 | (elem $elem0 (table $table0) 38 | (offset (i32.const 0)) 39 | funcref (item (ref.func $addThree)) 40 | ) 41 | (elem $elem1 (table $table0) 42 | (offset (i32.const 1)) 43 | funcref (item (ref.func $addTwo)) 44 | ) 45 | ) 46 | 47 | -------------------------------------------------------------------------------- /tests/table_elem_start.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type $ft0 (func (param i32 i32) (result i32))) 3 | (type $ft1 (func (param i32 i32 i32) (result i32))) 4 | (func $addTwo (export "addTwo") (type $ft0) 5 | local.get 0 6 | local.get 1 7 | i32.add) 8 | (func $addThree (export "addThree") (type $ft1) 9 | local.get 0 10 | local.get 1 11 | local.get 2 12 | i32.add 13 | i32.add) 14 | (func $swap (export "swap") 15 | i32.const 2 16 | i32.const 1 17 | table.get 0 18 | table.set 0 19 | 20 | i32.const 1 21 | i32.const 0 22 | table.get 0 23 | table.set 0 24 | 25 | i32.const 0 26 | i32.const 2 27 | table.get 0 28 | table.set 0 29 | ) 30 | (func $main (export "main")(result i32) 31 | i32.const 2 32 | i32.const 3 33 | i32.const 0 34 | call_indirect 0 (type $ft0) 35 | ) 36 | (table $table0 (export "table0") 3 funcref) 37 | (elem $elem0 (table $table0) 38 | (offset (i32.const 0)) 39 | funcref (item (ref.func $addThree)) 40 | ) 41 | (elem $elem1 (table $table0) 42 | (offset (i32.const 1)) 43 | funcref (item (ref.func $addTwo)) 44 | ) 45 | (start $swap) 46 | ) 47 | 48 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2019-2024 Martin Bodin, Philippa Gardner, Jean Pichon, Xiaojia Rao, Conrad Watt 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /theories/leb128_tests.v: -------------------------------------------------------------------------------- 1 | Require Import leb128. 2 | Require Import Coq.Init.Byte Coq.Numbers.BinNums. 3 | Require Import NArith.BinNat ZArith.ZArith. 4 | From parseque Require Import Running Induction. 5 | Require Import check_toks. 6 | 7 | (** Example from Wikipedia article: https://en.wikipedia.org/wiki/LEB128#Unsigned_LEB128 8 | This is the representation of the number [624485]. **) 9 | Definition test_wikipedia : list Byte.byte := 10 | xe5 :: x8e :: x26 :: nil. 11 | 12 | Definition encode_unsigned_check (k : N) := 13 | Singleton (encode_unsigned k). 14 | 15 | Lemma test_wikipedia_encode : 16 | encode_unsigned_check 624485%N = Singleton test_wikipedia. 17 | Proof. 18 | vm_compute. reflexivity. 19 | Qed. 20 | 21 | Definition test_wikipedia_decode : 22 | check_toks test_wikipedia parse_unsigned = Singleton 624485%N. 23 | Proof. 24 | vm_compute. reflexivity. 25 | Qed. 26 | 27 | Definition test_wikipedia_signed: list Byte.byte := 28 | xc0 :: xbb :: x78 :: nil. 29 | 30 | Definition encode_signed_check (k : Z) := 31 | Singleton (encode_signed k). 32 | 33 | Lemma test_wikipedia_signed_encode: 34 | encode_signed_check (-123456)%Z = Singleton test_wikipedia_signed. 35 | Proof. 36 | vm_compute. reflexivity. 37 | Qed. 38 | -------------------------------------------------------------------------------- /coq-wasm.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "2.2.1" 4 | synopsis: "Wasm formalisation in Coq" 5 | description: 6 | "Wasm formalisation in Coq, following the AFP formalisation of Conrad Watt" 7 | maintainer: ["Xiaojia Rao" "Martin Bodin"] 8 | authors: [ 9 | "Martin Bodin" "Philippa Gardner" "Jean Pichon" "Xiaojia Rao" "Conrad Watt" 10 | ] 11 | license: "MIT" 12 | homepage: "https://github.com/WasmCert/WasmCert-Coq" 13 | bug-reports: "https://github.com/WasmCert/WasmCert-Coq/issues" 14 | depends: [ 15 | "dune" {>= "3.11"} 16 | "coq" {>= "9.0" & < "9.2~"} 17 | "coq-compcert" {>= "3.14"} 18 | "coq-ext-lib" {>= "0.11.8"} 19 | "coq-mathcomp-ssreflect" {>= "2.4.0" & <= "2.5~"} 20 | "rocq-parseque" {>= "0.2.0"} 21 | "cmdliner" {>= "1.1.0"} 22 | "linenoise" {>= "1.4.0"} 23 | "mdx" {>= "1.9.0"} 24 | "wasm" {>= "2.0.2" & <= "2.0.2"} 25 | "zarith" {>= "1.11"} 26 | "odoc" {with-doc} 27 | ] 28 | build: [ 29 | ["dune" "subst"] {dev} 30 | [ 31 | "dune" 32 | "build" 33 | "-p" 34 | name 35 | "-j" 36 | jobs 37 | "@install" 38 | "@runtest" {with-test} 39 | "@doc" {with-doc} 40 | ] 41 | ] 42 | dev-repo: "git+https://github.com/WasmCert/WasmCert-Coq.git" 43 | -------------------------------------------------------------------------------- /changelogs/v2.0.1.md: -------------------------------------------------------------------------------- 1 | # Release 2.0.1 2 | 3 | This release is a cumulative update for the repository since the initial release for Wasm 2.0 features, including a bump on the dependency versions (now using Coq 8.19) and several refactorings and feature additions. 4 | 5 | # Upgrade to Coq 8.19 6 | The codebase is now updated to work with Coq 8.19. The other dependencies have also been upgraded correspondingly. 7 | 8 | # Context interpreter refactoring 9 | The context interpreter has been refactored to provide a more faithful version of the progress property. 10 | 11 | # Bugfix for certain numeric operations 12 | The behaviour of `shl_s` has been fixed according to the spec. Further tests are still required as the numerical part is severely under-tested. 13 | 14 | # Added opaque implementation of vector instructions (SIMD) 15 | Added the necessary instructions for the new 2.0 SIMD instructions to be parsed but without any concrete implementations. In a future version, add some hooks to the OCaml implementation of the reference interpreter to support concrete SIMD operations. 16 | 17 | # Binary printer backwards-compatibility 18 | Added an additional check in the binary printer that tries to provide 1.0-compatible binary modules when a Wasm module only used the features from the Wasm 1.0 semantics set. 19 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Test compilation 2 | 3 | on: 4 | push: 5 | pull_request: 6 | types: 7 | - opened 8 | - synchronize 9 | - reopened 10 | - ready_for_review 11 | 12 | workflow_dispatch: 13 | inputs: 14 | 15 | jobs: 16 | build-matrix: 17 | runs-on: ubuntu-latest 18 | if: github.event.pull_request.draft == false 19 | strategy: 20 | matrix: 21 | opam_file: 22 | - 'coq-wasm.opam' 23 | coq_version: 24 | - '9.0' 25 | fail-fast: true 26 | 27 | steps: 28 | - uses: actions/checkout@v2 29 | 30 | - uses: coq-community/docker-coq-action@v1 31 | with: 32 | opam_file: ${{ matrix.opam_file }} 33 | coq_version: ${{ matrix.coq_version }} 34 | 35 | before_install: | 36 | startGroup "install dependencies" 37 | sudo apt update 38 | sudo apt install nano --yes 39 | 40 | sudo chmod 777 ~/. -R 41 | sudo chmod 777 . -R 42 | endGroup 43 | after_script: | 44 | startGroup "List installed packages" 45 | opam list 46 | endGroup 47 | startGroup "Test suites" 48 | dune test 49 | endGroup 50 | startGroup "Test import" 51 | cd .ci/ 52 | coqc import_test.v 53 | cd .. 54 | endGroup 55 | -------------------------------------------------------------------------------- /theories/check_toks.v: -------------------------------------------------------------------------------- 1 | 2 | From compcert Require Import Integers. 3 | From parseque Require Import Parseque Running. 4 | Require Import PeanoNat. 5 | 6 | Section Check. 7 | 8 | Context 9 | {Toks : nat -> Type} `{Sized Toks Byte.byte} 10 | {M : Type -> Type} `{RawMonad M} `{RawAlternative M} `{RawMonadRun M} 11 | {Tok : Type} `{Tokenizer Tok} 12 | {A : Type}. 13 | 14 | Definition check_toks : list Byte.byte -> [ Parser (SizedList Byte.byte) Byte.byte M A ] -> Type := fun s p => 15 | let tokens := s in 16 | let n := List.length tokens in 17 | let input := mkSizedList tokens in 18 | let result := runParser (p n) (Nat.le_refl n) input in 19 | let valid := fun s => match Success.size s with | O => Some (Success.value s) | _ => None end in 20 | match mapM valid (runMonad result) with 21 | | Some (cons hd _) => @Singleton A hd 22 | | _ => False 23 | end. 24 | 25 | Definition run : list Byte.byte -> [ Parser (SizedList Ascii.ascii) Ascii.ascii M A ] -> option A := fun s p => 26 | let tokens := List.map Ascii.ascii_of_byte s in 27 | let n := List.length tokens in 28 | let input := mkSizedList tokens in 29 | let result := runParser (p n) (Nat.le_refl n) input in 30 | let valid := fun s => match Success.size s with | O => Some (Success.value s) | _ => None end in 31 | match mapM valid (runMonad result) with 32 | | Some (cons hd _) => Some hd 33 | | _ => None 34 | end. 35 | 36 | End Check. 37 | -------------------------------------------------------------------------------- /tests/table_elem_start.md: -------------------------------------------------------------------------------- 1 | This test contains a mixture of instructions testing the initialisation of tables using elem segments, as well as the start function invocation. 2 | 3 | ```wasm 4 | (module 5 | (type $ft0 (func (param i32 i32) (result i32))) 6 | (type $ft1 (func (param i32 i32 i32) (result i32))) 7 | (func $addTwo (export "addTwo") (type $ft0) 8 | local.get 0 9 | local.get 1 10 | i32.add) 11 | (func $addThree (export "addThree") (type $ft1) 12 | local.get 0 13 | local.get 1 14 | local.get 2 15 | i32.add 16 | i32.add) 17 | (func $swap (export "swap") 18 | i32.const 2 19 | i32.const 1 20 | table.get 0 21 | table.set 0 22 | 23 | i32.const 1 24 | i32.const 0 25 | table.get 0 26 | table.set 0 27 | 28 | i32.const 0 29 | i32.const 2 30 | table.get 0 31 | table.set 0 32 | ) 33 | (func $main (export "main")(result i32) 34 | i32.const 2 35 | i32.const 3 36 | i32.const 0 37 | call_indirect 0 (type $ft0) 38 | ) 39 | (table $table0 (export "table0") 3 funcref) 40 | (elem $elem0 (table $table0) 41 | (offset (i32.const 0)) 42 | funcref (item (ref.func $addThree)) 43 | ) 44 | (elem $elem1 (table $table0) 45 | (offset (i32.const 1)) 46 | funcref (item (ref.func $addTwo)) 47 | ) 48 | (start $swap) 49 | ) 50 | 51 | 52 | ``` 53 | 54 | ```sh 55 | $ wasm_coq_interpreter table_elem_start.wasm -r main 56 | i32.const 5 57 | 58 | ``` 59 | 60 | -------------------------------------------------------------------------------- /run_wast.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -euo pipefail 3 | 4 | folder="${1:-./wast_testsuite}" 5 | filter="${2:-}" 6 | 7 | shopt -s nullglob 8 | 9 | if [[ -n "$filter" ]]; then 10 | files=( "$folder"/*"$filter"*.wast ) 11 | else 12 | files=( "$folder"/*.wast ) 13 | fi 14 | 15 | if (( ${#files[@]} == 0 )); then 16 | echo "No matching .wast files in '$folder'${filter:+ containing '$filter'}." 17 | exit 0 18 | fi 19 | 20 | total_passed=0 21 | total_tests=0 22 | 23 | for wastfile in "${files[@]}"; do 24 | echo "Running: $wastfile" 25 | tmpfile=$(mktemp) 26 | cleaned=$(mktemp) 27 | 28 | dune exec -- wasm_coq_interpreter --wast "$wastfile" | tee "$tmpfile" 29 | tr -d '\r' < "$tmpfile" | sed 's/\x1b\[[0-9;]*m//g' > "$cleaned" 30 | 31 | if result_line=$(grep -m1 "Result: " "$cleaned"); then 32 | if [[ "$result_line" =~ Result:\ ([0-9]+)/([0-9]+) ]]; then 33 | passed="${BASH_REMATCH[1]}" 34 | total="${BASH_REMATCH[2]}" 35 | total_passed=$((total_passed + passed)) 36 | total_tests=$((total_tests + total)) 37 | else 38 | echo "Regex match failed for $wastfile" 39 | fi 40 | else 41 | echo "No 'Result:' line found for $wastfile" 42 | fi 43 | rm -f "$tmpfile" "$cleaned" 44 | done 45 | 46 | echo "================" 47 | if (( total_tests > 0 )); then 48 | percentage=$(awk "BEGIN { printf \"%.2f\", ($total_passed / $total_tests) * 100 }") 49 | echo "Total Passed: $total_passed/$total_tests ($percentage%)" 50 | else 51 | echo "No tests run." 52 | fi 53 | -------------------------------------------------------------------------------- /tests/table_elem_nostart.md: -------------------------------------------------------------------------------- 1 | This test is the same as the `table_elem_start` test removing the start function declaration. As a result, the `call_indirect` instruction should fail due to a type mismatch, returning a trap. 2 | 3 | ```wasm 4 | (module 5 | (type $ft0 (func (param i32 i32) (result i32))) 6 | (type $ft1 (func (param i32 i32 i32) (result i32))) 7 | (func $addTwo (export "addTwo") (type $ft0) 8 | local.get 0 9 | local.get 1 10 | i32.add) 11 | (func $addThree (export "addThree") (type $ft1) 12 | local.get 0 13 | local.get 1 14 | local.get 2 15 | i32.add 16 | i32.add) 17 | (func $swap (export "swap") 18 | i32.const 2 19 | i32.const 1 20 | table.get 0 21 | table.set 0 22 | 23 | i32.const 1 24 | i32.const 0 25 | table.get 0 26 | table.set 0 27 | 28 | i32.const 0 29 | i32.const 2 30 | table.get 0 31 | table.set 0 32 | ) 33 | (func $main (export "main")(result i32) 34 | i32.const 2 35 | i32.const 3 36 | i32.const 0 37 | call_indirect 0 (type $ft0) 38 | ) 39 | (table $table0 (export "table0") 3 funcref) 40 | (elem $elem0 (table $table0) 41 | (offset (i32.const 0)) 42 | funcref (item (ref.func $addThree)) 43 | ) 44 | (elem $elem1 (table $table0) 45 | (offset (i32.const 1)) 46 | funcref (item (ref.func $addTwo)) 47 | ) 48 | (start $swap) 49 | ) 50 | 51 | 52 | ``` 53 | 54 | ```sh 55 | $ wasm_coq_interpreter table_elem_nostart.wasm -r main 56 | Execution returned a trap; run the interpreter in detailed mode (--vi) for more information 57 | 58 | ``` 59 | 60 | -------------------------------------------------------------------------------- /theories/simd.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrbool eqtype seq ssrnat. 2 | From Coq Require Import BinInt BinNat NArith Lia Uint63 String. 3 | From Wasm Require Import numerics bytes memory common. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Module Type SIMD_Type. 10 | 11 | Parameter v128: Type. 12 | 13 | Parameter v128_default: v128. 14 | 15 | Parameter encode_v128 : v128 -> string. 16 | Parameter decode_v128 : string -> v128. 17 | 18 | End SIMD_Type. 19 | 20 | Module SIMD <: SIMD_Type. 21 | 22 | Definition v128 := bytes. 23 | 24 | Definition v128_default : v128 := nil. 25 | 26 | Definition encode_v128 bs := 27 | let coq_bytes := 28 | List.map byte_of_compcert_byte bs in 29 | string_of_list_byte coq_bytes. 30 | 31 | Definition decode_v128 s := 32 | let bs := list_byte_of_string s in 33 | List.map compcert_byte_of_byte bs. 34 | 35 | Lemma decode_encode_v128: forall v, 36 | decode_v128 (encode_v128 v) = v. 37 | Proof. 38 | induction v => //=. 39 | unfold decode_v128, encode_v128 in *. 40 | rewrite list_byte_of_string_of_list_byte => /=. 41 | rewrite list_byte_of_string_of_list_byte in IHv => /=. 42 | rewrite IHv. 43 | f_equal. 44 | by rewrite compcert_byte_roundtrip. 45 | Qed. 46 | 47 | Lemma encode_decode_v128: forall s, 48 | encode_v128 (decode_v128 s) = s. 49 | Proof. 50 | induction s => //=. 51 | unfold decode_v128, encode_v128 in * => /=. 52 | rewrite coq_byte_roundtrip => /=. 53 | cbn; f_equal. 54 | - by rewrite Ascii.ascii_of_byte_of_ascii. 55 | - by apply IHs. 56 | Qed. 57 | 58 | End SIMD. 59 | 60 | Module Export simd_export := SIMD. 61 | 62 | -------------------------------------------------------------------------------- /changelogs/v2.0.2.md: -------------------------------------------------------------------------------- 1 | # Release 2.0.2 2 | 3 | ## Upgrade to Coq 8.20 4 | The codebase is now updated to work with Coq 8.20. The other dependencies have also been upgraded correspondingly. Note that we are currently using mathcomp version 1.x; this will possibly be updated in a future version. 5 | 6 | ## New features 7 | - Added implementation of the saturating float-to-int instruction. 8 | - The opsem rules for numeric instructions now require a type checking in addition to the numeric proxy operators (`unop/binop/...`). 9 | This type checking is redundant when the type system is enforced. Instead, this change makes the opsem more self-contained as a 10 | standalone definition. 11 | 12 | ## Refactorings 13 | - The subtyping definitions are now refactored into a standalone file `subtyping.v`, relocating from `operations.v`. 14 | - The subtyping relation for function types is now changed to live in `Bool` instead of `Prop` due to its full computability. 15 | - A new file `definitions.v` is added for importing all base definitions of the mechanisation without any proofs. This can be useful for 16 | developments that only use the mechanised definitions but not the proofs. 17 | 18 | ## Bugfix 19 | - Fixed a bug where the signatures of the returned values are incorrect for certain float-to-int conversions. 20 | - Fixed a bug where the binary parser incorrectly parses the order of arguments of the `table.init` instruction (should be reversed) and added a corresponding test. 21 | - Fixed a bug where the binary parser incorrectly parses the order of memory arguments after a recent incorrect change (should be reversed) and added a corresponding test. 22 | 23 | ## Feature Improvements 24 | - Reworked the parser to be cleaner and significantly more efficient. 25 | - Improved the error message when an export function with arguments are invoked (currently not supported). -------------------------------------------------------------------------------- /src/extraction.v: -------------------------------------------------------------------------------- 1 | (** Extraction to OCaml. **) 2 | 3 | From Coq Require Extraction. 4 | From Wasm Require Import 5 | efficient_extraction 6 | datatypes_properties 7 | binary_format_parser 8 | text_format_parser 9 | instantiation_func 10 | interpreter_ctx 11 | type_checker 12 | pp 13 | host 14 | simd_execute 15 | extraction_instance 16 | . 17 | 18 | Require Import compcert.lib.Integers. 19 | Require Import ZArith NArith. 20 | 21 | From Coq Require PArray. 22 | From Coq Require Import 23 | extraction.ExtrOcamlBasic 24 | extraction.ExtrOcamlNativeString 25 | extraction.ExtrOcamlZBigInt 26 | . 27 | 28 | Extraction Language OCaml. 29 | 30 | Extract Constant lookup_N => "EfficientExtraction.lookup_N_safe". 31 | 32 | Extract Constant memory_vec.array "'a" => "Parray_shim.t". 33 | Extraction Inline memory_vec.array. 34 | 35 | (* Requires some custom rerouting *) 36 | 37 | Extract Constant memory_vec.arr_make => "Parray_shim.make". 38 | Extract Constant memory_vec.arr_make_copy => "Parray_shim.make_copy". 39 | Extract Constant memory_vec.arr_get => "Parray_shim.get". 40 | Extract Constant memory_vec.arr_default => "Parray_shim.default". 41 | Extract Constant memory_vec.arr_set => "Parray_shim.set". 42 | Extract Constant memory_vec.arr_set_gen => "Parray_shim.set_gen". 43 | Extract Constant memory_vec.arr_length => "Parray_shim.length". 44 | Extract Constant memory_vec.arr_copy => "Parray_shim.copy". 45 | 46 | Extract Constant SIMD_ops.app_vunop_str => "SIMD_ops.app_vunop_str". 47 | Extract Constant SIMD_ops.app_vbinop_str => "SIMD_ops.app_vbinop_str". 48 | Extract Constant SIMD_ops.app_vternop_str => "SIMD_ops.app_vternop_str". 49 | Extract Constant SIMD_ops.app_vtestop_str => "SIMD_ops.app_vtestop_str". 50 | Extract Constant SIMD_ops.app_vshiftop_str => "SIMD_ops.app_vshiftop_str". 51 | 52 | Extraction "extract" 53 | EfficientExtraction 54 | run_parse_module_str 55 | run_parse_arg 56 | Extraction_instance 57 | . 58 | -------------------------------------------------------------------------------- /theories/type_progress.v: -------------------------------------------------------------------------------- 1 | From Wasm Require Export interpreter_ctx. 2 | From mathcomp Require Import ssreflect ssrbool eqtype. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Section Host. 9 | 10 | Context `{ho: host}. 11 | 12 | (* The same host function well-formedness assumptions from the interpreter *) 13 | Variable host_application_impl : host_state -> store_record -> function_type -> host_function -> list value -> (host_state * option (store_record * result)). 14 | 15 | Hypothesis host_application_impl_correct : 16 | (forall hs s ft hf vs hs' hres, (host_application_impl hs s ft hf vs = (hs', hres)) -> host_application hs s ft hf vs hs' hres). 17 | 18 | (* The progress property is derived from the interpreter. *) 19 | Definition t_progress_interp_ctx: forall (hs: host_state) (s: store_record) (f: frame) es ts, 20 | config_typing s (f, es) ts -> 21 | terminal_form es \/ 22 | (exists hs' s' f' es', reduce hs s f es hs' s' f' es'). 23 | Proof. 24 | move => hs s f es ts Htype. 25 | (* initialise an interpreter cfg tuple *) 26 | destruct (interp_cfg_of_wasm (s, (f, es))) as [[[[s0 ccs] sc] oe] [Hfill Hvalid]]. 27 | (* run the interpreter *) 28 | remember (@run_one_step_ctx _ _ _ host_application_impl host_application_impl_correct hs (s0, ccs, sc, oe) BinNums.N0) as res. 29 | destruct res as [hs' [[[s' ccs'] sc'] oe'] d Hred Hvalid' | s' f' vs Hvalfill | s' f' Htrapfill | Hcontra | Hcontra]; clear Heqres. 30 | (* step *) 31 | - unfold reduce_ctx in Hred. 32 | rewrite Hfill in Hred. 33 | destruct (ctx_to_cfg (s', ccs', sc', oe')) as [[s'' [f'' es'']] | ] => //. 34 | right. 35 | by exists hs', s'', f'', es''. 36 | (* values *) 37 | - rewrite Hvalfill in Hfill; injection Hfill as <- <- <-. 38 | do 2 left. 39 | by apply v_to_e_const. 40 | (* trap *) 41 | - rewrite Htrapfill in Hfill; injection Hfill as <- <- <-. 42 | by left; right. 43 | (* invalid input -- impossible *) 44 | - by apply Hcontra in Hvalid. 45 | (* ill-typed -- impossible *) 46 | - unfold ctx_cfg_typing in Hcontra. 47 | rewrite Hfill in Hcontra. 48 | by apply Hcontra in Htype. 49 | Qed. 50 | 51 | End Host. 52 | -------------------------------------------------------------------------------- /src/output.mli: -------------------------------------------------------------------------------- 1 | (** Functions to control the program output. *) 2 | 3 | type verbosity 4 | 5 | val none : verbosity (** Print nothing. *) 6 | val result : verbosity (** Print the result. *) 7 | val stage : verbosity (** Also print state. *) 8 | val intermediate : verbosity (** Also print intermediate states. *) 9 | val store : verbosity (** Also print stores. *) 10 | 11 | (** Some styles that can be applied to the text. *) 12 | type style 13 | 14 | val normal : style 15 | val bold : style 16 | val green : style 17 | val yellow : style 18 | val red : style 19 | 20 | (** Given the current verbosity level, the minimum verbosity level required, and a function, 21 | only call and print the function if the verbosity level enables it. *) 22 | val debug_info : verbosity -> verbosity -> ?style:style -> (unit -> string) -> unit 23 | 24 | (** Same as [debug_info], but with an additional maximum verbosity. *) 25 | val debug_info_span : verbosity -> verbosity -> verbosity -> ?style:style -> (unit -> string) -> unit 26 | 27 | (* FIXME: @opqrs: this corresponds to your function [terminal_magic], which I’m not sure how to 28 | document. *) 29 | val wait_message : verbosity -> unit 30 | 31 | (** [pending v min ()] prints ["..."] if [v >= min]. 32 | Calling the returned function erase these three dots. *) 33 | val pending : verbosity -> verbosity -> unit -> unit -> unit 34 | 35 | (** Same as [pending], but does it during the computation of the prodived function. *) 36 | val vpending : verbosity -> verbosity -> (unit -> 'a) -> 'a 37 | 38 | (** An output type, returning either a success with a value or an error message. *) 39 | type 'a out = 40 | | OK of 'a 41 | | Error of string 42 | 43 | (** Same as [vpending], but print the action given with the string, and append an ["OK"] 44 | or ["failure"] message depending on the function. *) 45 | val ovpending : verbosity -> verbosity -> ?style:style -> string -> (unit -> 'a out) -> 'a out 46 | 47 | (** Similarly to [ovpending], but the success is provided by the boolean. *) 48 | val bvpending : verbosity -> verbosity -> ?style:style -> string -> (unit -> bool * 'a) -> 'a 49 | 50 | (** A monad for [out]. *) 51 | module Out : sig 52 | 53 | val ( >>= ) : 'a out -> ('a -> 'b out) -> 'b out 54 | val ( let* ) : 'a out -> ('a -> 'b out) -> 'b out 55 | val ( let+ ) : 'a out -> ('a -> 'b) -> 'b out 56 | val ( and+ ) : 'a out -> 'b out -> ('a * 'b) out 57 | val pure : 'a -> 'a out 58 | 59 | (** Conversion function to the usual output of Cmdliner. *) 60 | val convert : 'a out -> [> `Ok of 'a | `Error of bool * string ] 61 | 62 | end 63 | 64 | -------------------------------------------------------------------------------- /src/parse.ml: -------------------------------------------------------------------------------- 1 | (** Parsing **) 2 | open Execute.Interpreter 3 | open Output 4 | 5 | (** Trying to guess the module name by the file name provided for the module. *) 6 | let extract_module_name src = 7 | let name = Filename.basename src in 8 | if (String.length name >= 5 && String.sub name (String.length name - 5) 5 = ".wasm") then 9 | String.sub name 0 (String.length name - 5) 10 | else 11 | if (String.length name >= 4 && String.sub name (String.length name - 4) 4 = ".wat") then 12 | String.sub name 0 (String.length name - 4) 13 | else 14 | name 15 | 16 | let binary_of_text textstr = 17 | let open Wasm.Source in 18 | let (_ovar, wast_def) = Wasm.Parse.Module.parse_string textstr in 19 | match wast_def.it with 20 | | Wasm.Script.Textual wast_module -> 21 | let bin_module = Wasm.Encode.encode wast_module in 22 | Some bin_module 23 | | _ -> None 24 | 25 | let parse_binary_module bin_module = 26 | match Execute.Interpreter.run_parse_module_str bin_module with 27 | | None -> Error "error in parsing module" 28 | | Some m -> OK m 29 | 30 | (** Parse a module given the module string. The text flag specifies whether the argument is in binary format or text format. *) 31 | let parse_module verbosity text mstr = 32 | (** Parsing. *) 33 | Execute.Host.from_out ( 34 | let open Output in 35 | ovpending verbosity stage "parsing" (fun _ -> 36 | if text then 37 | match binary_of_text mstr with 38 | | Some bin_module -> parse_binary_module bin_module 39 | | None -> Error "error in parsing the text module" 40 | else 41 | parse_binary_module mstr 42 | )) 43 | 44 | (* Parse a list of modules. *) 45 | let rec parse_modules_acc verbosity text files acc = 46 | match files with 47 | | [] -> pure acc 48 | | f :: files' -> 49 | let* m = parse_module verbosity text f in 50 | parse_modules_acc verbosity text files' (acc @ [m]) 51 | 52 | let parse_modules verbosity text files = 53 | parse_modules_acc verbosity text files [] 54 | 55 | let parse_arg arg = 56 | Execute.Interpreter.run_parse_arg arg 57 | 58 | (* Parsing the arguments of a function call in text format. *) 59 | let rec parse_args_acc args acc = 60 | (match args with 61 | | [] -> pure acc 62 | | a :: args' -> 63 | (match parse_arg a with 64 | | Some a' -> parse_args_acc args' (acc @ [a']) 65 | | None -> Execute.Host.from_out (Error ("Invalid argument: " ^ a)) 66 | ) 67 | ) 68 | 69 | let parse_args args = 70 | parse_args_acc args [] 71 | 72 | let parse_wast scriptstr = 73 | Wasm.Parse.Script.parse_string scriptstr -------------------------------------------------------------------------------- /src/Parray/Parray.mli: -------------------------------------------------------------------------------- 1 | (************************************************************************) 2 | (* * The Rocq Prover / The Rocq Development Team *) 3 | (* v * Copyright INRIA, CNRS and contributors *) 4 | (* int 20 | val length_int : 'a t -> int 21 | val get : 'a t -> int -> 'a 22 | val set : 'a t -> int -> 'a -> 'a t 23 | 24 | val set_gen : 'a t -> int -> int -> (int -> 'a) -> 'a t 25 | (** [set_gen p start_pos block_len generator] returns a new persistent array 26 | based on [p] where the range of length [block_len] starting at [start_pos] 27 | is updated by calling [generator] for each index 0 to [block_len - 1]. 28 | [block_len] must be greater than 0. *) 29 | 30 | val default : 'a t -> 'a 31 | val make : int -> 'a -> 'a t 32 | val make_copy : int -> 'a -> 'a t -> int -> 'a t 33 | val init : int -> (int -> 'a) -> 'a -> 'a t 34 | val copy : 'a t -> 'a t 35 | 36 | val map : ('a -> 'b) -> 'a t -> 'b t 37 | 38 | val to_array : 'a t -> 'a array * 'a (* default *) 39 | (* 'a should not be float (no Obj.double_tag) *) 40 | 41 | val of_array : 'a array -> 'a (* default *) -> 'a t 42 | 43 | val unsafe_of_obj : Obj.t -> 'a -> 'a t 44 | (* [unsafe_of_obj] injects an untyped mutable array into a persistent one, but 45 | does not perform a copy. This means that if the persistent array is mutated, 46 | the original one will be too. The array must be a non-flat array. *) 47 | 48 | val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a 49 | val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a -------------------------------------------------------------------------------- /theories/subtyping.v: -------------------------------------------------------------------------------- 1 | From Wasm Require Import datatypes_properties. 2 | From mathcomp Require Import ssreflect eqtype ssrbool seq ssrnat. 3 | 4 | (** The mechanisation implements a restricted version of the subtyping system 5 | from the upcoming GC proposal to the current set of Wasm 2.0 types. 6 | Namely, t_1 <: t_2 iff t_1 is the bottom type, or the two types are equal. 7 | 8 | This allows smoother transition into the upcoming proposals and avoids 9 | the need to deal with the artificial stack type in Wasm 2.0, which is a 10 | temporary solution. 11 | 12 | For more details on the GC proposal, check 13 | [https://github.com/WebAssembly/gc/blob/main/proposals/gc/Overview.md] 14 | **) 15 | Section Subtyping. 16 | 17 | Definition value_subtyping (t1: value_type) (t2: value_type) : bool := 18 | (t1 == t2) || (t1 == T_bot). 19 | 20 | Definition values_subtyping (ts1: list value_type) (ts2: list value_type) : bool := 21 | all2 value_subtyping ts1 ts2. 22 | 23 | (** Function subtyping and instruction subtyping are covariant on the types 24 | produced and contravariant on the types consumed. 25 | **) 26 | Definition func_subtyping (tf tf': function_type) : bool := 27 | let '(Tf ts1 ts2) := tf in 28 | let '(Tf ts1' ts2') := tf' in 29 | values_subtyping ts1' ts1 && 30 | values_subtyping ts2 ts2'. 31 | 32 | Definition instr_subtyping (tf tf': function_type) : Prop := 33 | let '(Tf ts1 ts2) := tf in 34 | let '(Tf ts1' ts2') := tf' in 35 | exists ts ts' ts1_sub ts2_sub, 36 | ts1' = ts ++ ts1_sub /\ 37 | ts2' = ts' ++ ts2_sub /\ 38 | values_subtyping ts ts' /\ 39 | values_subtyping ts1_sub ts1 /\ 40 | values_subtyping ts2 ts2_sub. 41 | 42 | End Subtyping. 43 | 44 | Notation "t1 t_inf t1 t2) (List.combine ts1 ts2)) 64 | else 65 | None. 66 | 67 | End Lattice. 68 | -------------------------------------------------------------------------------- /theories/utf8.v: -------------------------------------------------------------------------------- 1 | (* utf8 validity for strings *) 2 | 3 | From Coq Require Import Strings.Byte BinNums List NArith. 4 | 5 | Section utf8. 6 | 7 | Local Open Scope N_scope. 8 | Local Open Scope bool_scope. 9 | 10 | (* Check if a byte is a continuation byte (10xxxxxx) *) 11 | Definition is_cont (b : byte) : bool := 12 | let n := to_N b in (128 <=? n) && (n <=? 191). 13 | 14 | (* Convert N to lower 6 bits (used for continuation bytes) *) 15 | Definition lower_6 (n : N) := N.land n 63. 16 | 17 | Notation " x << e " := (N.shiftl x e) (at level 5). 18 | 19 | Fixpoint utf8_valid (bs : list byte) : bool := 20 | match bs with 21 | | nil => true 22 | | b :: bs' => 23 | let n := to_N b in 24 | if n <=? 127 then 25 | utf8_valid bs' 26 | else if (192 <=? n) && (n <=? 223) then 27 | match bs' with 28 | | b1 :: bs'' => 29 | if is_cont b1 then 30 | let n1 := lower_6 (to_N b1) in 31 | let cp := ((n - 192) << 6) + n1 in 32 | if cp false 35 | end 36 | else if (224 <=? n) && (n <=? 239) then 37 | match bs' with 38 | | b1 :: b2 :: bs'' => 39 | if is_cont b1 && is_cont b2 then 40 | let n1 := lower_6 (to_N b1) in 41 | let n2 := lower_6 (to_N b2) in 42 | let cp := ((n - 224) << 12) + (n1 << 6) + n2 in 43 | if cp false 48 | end 49 | else if (240 <=? n) && (n <=? 247) then 50 | match bs' with 51 | | b1 :: b2 :: b3 :: bs'' => 52 | if is_cont b1 && is_cont b2 && is_cont b3 then 53 | let n1 := lower_6 (to_N b1) in 54 | let n2 := lower_6 (to_N b2) in 55 | let n3 := lower_6 (to_N b3) in 56 | let cp := ((n - 240) << 18) + (n1 << 12) + (n2 << 6) + n3 in 57 | if cp false 62 | end 63 | else false 64 | end. 65 | 66 | End utf8. 67 | -------------------------------------------------------------------------------- /src/output.ml: -------------------------------------------------------------------------------- 1 | type verbosity = int 2 | 3 | let none = 0 4 | let result = 1 5 | let stage = 2 6 | let intermediate = 3 7 | let store = 4 8 | 9 | type style = string 10 | 11 | (* TODO: use notty rather than this ad-hoc mess *) 12 | let ansi_bold = "\x1b[1m" 13 | let ansi_reset = "\x1b[0m" 14 | let ansi_red = "\x1b[31m" 15 | let ansi_green = "\x1b[32m" 16 | let ansi_yellow = "\x1b[33m" 17 | 18 | let normal = ansi_reset 19 | let bold = ansi_bold 20 | let yellow = ansi_yellow 21 | let green = ansi_green 22 | let red = ansi_red 23 | 24 | (** ANSI escape sequence to delete [n] characters. *) 25 | let ansi_delete_chars n = 26 | "\x1b[" ^ string_of_int n ^ "D" 27 | 28 | let debug_info verbosity min_level ?(style=normal) f = 29 | if verbosity >= min_level then ( 30 | Printf.printf "%s%s%s" style (f ()) ansi_reset; 31 | flush stdout; 32 | flush stderr 33 | ) 34 | 35 | let debug_info_span verbosity min_level max_level ?(style=normal) f = 36 | if verbosity <= max_level then debug_info verbosity min_level ~style f 37 | 38 | let wait_message verbosity = 39 | (* yuck *) 40 | debug_info verbosity 2 (fun () -> Printf.sprintf "..."); 41 | debug_info verbosity 1 (fun () -> Printf.sprintf "%s " (ansi_delete_chars 3)); 42 | debug_info verbosity 2 (fun () -> Printf.sprintf "%s" (ansi_delete_chars 1)) 43 | 44 | let pending verbosity min_level _ = 45 | debug_info verbosity min_level (fun _ -> "...") ; 46 | fun _ -> debug_info verbosity min_level (fun _ -> Printf.sprintf "%s" (ansi_delete_chars 3)) 47 | 48 | let vpending verbosity min_level f = 49 | let p = pending verbosity min_level () in 50 | let v = f () in 51 | p () ; 52 | v 53 | 54 | let bvpending verbosity min_level ?(style=normal) msg f = 55 | debug_info verbosity min_level ~style (fun _ -> msg) ; 56 | let (b, r) = vpending verbosity min_level f in 57 | let _ = 58 | if verbosity >= stage then ( 59 | if b then 60 | Printf.printf " %sOK%s\n" ansi_green ansi_reset 61 | else Printf.printf " %sfailure%s\n" ansi_red ansi_reset 62 | ) in 63 | r 64 | 65 | type 'a out = 66 | | OK of 'a 67 | | Error of string 68 | 69 | module Out = struct 70 | 71 | let ( >>= ) = function 72 | | OK a -> fun f -> f a 73 | | Error msg -> fun _ -> Error msg 74 | 75 | let ( let* ) = ( >>= ) 76 | 77 | let pure a = OK a 78 | 79 | let ( let+ ) a f = 80 | let* a = a in 81 | pure (f a) 82 | 83 | let ( and+ ) a b = 84 | let* a = a in 85 | let* b = b in 86 | pure (a, b) 87 | 88 | let convert = function 89 | | OK a -> `Ok a 90 | | Error msg -> `Error (false, msg) 91 | 92 | end 93 | 94 | let ovpending verbosity min_level ?(style=normal) msg f = 95 | bvpending verbosity min_level ~style msg (fun _ -> 96 | let r = f () in 97 | match r with 98 | | OK _ -> (true, r) 99 | | Error _ -> (false, r)) 100 | 101 | -------------------------------------------------------------------------------- /theories/host.v: -------------------------------------------------------------------------------- 1 | (** Axiomatisation of the host. **) 2 | (* (C) M. Bodin - see LICENSE.txt *) 3 | 4 | From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq. 5 | From HB Require Import structures. 6 | From Wasm Require Import common datatypes operations typing memory. 7 | From ExtLib Require Import Structures.Monad. 8 | 9 | (* XXX unused? *) 10 | (* Import Monads. *) 11 | 12 | Set Implicit Arguments. 13 | 14 | (** * General host definitions **) 15 | 16 | (** We provide two versions of the host. 17 | One based on a relation, to be used in the operational semantics, 18 | and one computable based on the [host_monad] monad, to be used in the interpreter. 19 | There is no host state in the host monad: it is entirely caught by the (state) monad. **) 20 | 21 | (** ** Predicate Host **) 22 | 23 | (** We start with a host expressed as a predicate, useful for proofs. **) 24 | 25 | Section Predicate. 26 | 27 | Context `{hfc: host_function_class} `{memory: BlockUpdateMemory}. 28 | (** We assume a set of host functions. **) 29 | 30 | (** The application of a host function either: 31 | - returns [Some (st', result)], returning a new Wasm store and a result (which can be [Trap]), 32 | - diverges, represented as [None] 33 | This can be non-deterministic. **) 34 | 35 | Class host := { 36 | host_state : eqType (** For the relation-based version, we assume some kind of host state. **) ; 37 | host_application : host_state -> store_record -> function_type -> host_function -> seq value -> 38 | host_state -> option (store_record * result) -> Prop 39 | (** An application of the host function. **) ; 40 | 41 | host_application_extension : forall s t st h vs s' st' r, 42 | host_application s st t h vs s' (Some (st', r)) -> 43 | store_extension st st' (** The returned store must be an extension of the original one. **) ; 44 | host_application_typing : forall s t st h vs s' st' r, 45 | host_application s st t h vs s' (Some (st', r)) -> 46 | store_typing st -> 47 | store_typing st' (** [host_application] preserves store typing. **) ; 48 | host_application_respect : forall s t1s t2s st h vs s' st' r, 49 | values_typing st vs t1s -> 50 | host_application s st (Tf t1s t2s) h vs s' (Some (st', r)) -> 51 | result_types_agree st' t2s r (** [host_application] respects types. **) 52 | }. 53 | 54 | End Predicate. 55 | 56 | (** ** Executable Host **) 57 | 58 | (** We start with a host expressed as a predicate, useful for proofs. **) 59 | 60 | Section Executable. 61 | 62 | Context `{hfc: host_function_class} `{memory: Memory}. 63 | 64 | Class executable_host := make_executable_host { 65 | host_event : Type -> Type (** The events that the host actions can yield. **) ; 66 | host_monad : Monad host_event (** They form a monad. **) ; 67 | host_apply : store_record -> function_type -> host_function -> seq value -> 68 | host_event (option (store_record * result)) 69 | (** The application of a host function, returning a value in the monad. **) 70 | }. 71 | 72 | End Executable. 73 | 74 | Arguments host_apply [_ _]. 75 | -------------------------------------------------------------------------------- /changelogs/v2.0.3.md: -------------------------------------------------------------------------------- 1 | # Release 2.0.3 2 | 3 | ## New Features 4 | - Added support for running `.wast` format test scripts. The extracted interpreter is now fully conformant with the Wasm official test suite (SIMD excluded). A mirror of the test suite repository is added as a GitHub submodule. 5 | - Added support for passing arguments via the CLI. 6 | - Added support for executing Wasm text format modules (`.wat`). 7 | - Added an implementation of persistent arrays, adapted from an implementation in the Rocq kernel. The files are located `src/Parray` and licensed under GNU LGPL 2.1 license due to the original license requirement from the Rocq kernel code. 8 | - Added native support for module import/export across multiple modules without manually saving the store states. 9 | - Added implementation of the new sign extension numeric operation. 10 | 11 | ## Refactorings 12 | - Reworked the memory typeclass and properly encapsulated the provided interfaces; the proofs now only use the exposed interfaces instead of inspecting into the list memory implementation. Added a new vector (dynamic array) implementation of memory based on a parametric array, which is extracted to persistent arrays. 13 | 14 | ## Dependency Updates 15 | - Updated the repository to work with MathComp version 2.x. 16 | - Added a new dependency on the Wasm reference implementation for parsing text format and `.wast` scripts. A custom mirror of the official Wasm implementation in the WasmCert organisation is currently used, since the version on `opam` is out of date. 17 | 18 | ## Bugfixes 19 | 20 | ### Parser 21 | - Added utf8 validity check and size checks for names and custom sections in the parser. 22 | - Added a check on requiring the datacount section in the parser. 23 | - Added size bound to the leb128 numerics parsing. 24 | - Fixed a bug where the parser only allows the shortest integer representation for certain leb128-coded arguments. 25 | - Fixed a bug where the arguments of `call_indirect` were parsed in an incorrect order. 26 | - Fixed a bug where the payloads of `nan` were parsed incorrectly. 27 | - Prevented cases where the parser could run indefinitely for certain invalid Wasm modules with large length arguments. 28 | - Fixed a bug where certain variants of `i64.store` instructions were parsed incorrectly. 29 | 30 | ### Type system 31 | - Fixed a bug where the typing of `br_table` was overly restrictive in unreachable code segments due to the subtyping rules. 32 | - Added several missing cases in the `ref` field of the typing context generated during instantiation where the original context was overly restrictive. 33 | 34 | ### Others 35 | - Fixed a bug where `alloc_module` produced incorrect extern values in the export when the module also imports from the host. This bug was introduced during the 2.0 update when the `exportinsts` field was added to the module instance. 36 | - Fixed several bugs in wrapper functions for CompCert numerics on the sign of infinities and zeros in some edge cases. 37 | 38 | ## Miscellaneous 39 | - Several performance-critical operations involving numerics now go through binary integers instead of `nat`. 40 | - Added a call stack depth argument in the interpreter for modelling stack exhaustion for `.wast` test suite. 41 | - Changed extraction of binary-integer-indexed list lookups to a modified function checking for the length first to avoid comparing large binary intergers to `nat` unnecessarily. -------------------------------------------------------------------------------- /theories/efficient_extraction.v: -------------------------------------------------------------------------------- 1 | (* Several functions require safe/efficient extraction targets for OCaml execution *) 2 | From Coq Require Import ZArith List ssreflect ssrbool. 3 | From Wasm Require Import common. 4 | 5 | Open Scope list_scope. 6 | 7 | Module EfficientExtraction. 8 | 9 | (* List lookup without converting the index to nat *) 10 | Fixpoint skip_pos {T: Type} (l: list T) (p: positive) : option (list T) := 11 | match p with 12 | | xH => 13 | match l with 14 | | nil => None 15 | | _ :: l' => Some l' 16 | end 17 | | xO p' => 18 | match skip_pos l p' with 19 | | Some l' => skip_pos l' p' 20 | | None => None 21 | end 22 | | xI p' => 23 | match l with 24 | | nil => None 25 | | _ :: l' => 26 | match skip_pos l' p' with 27 | | Some l'' => skip_pos l'' p' 28 | | None => None 29 | end 30 | end 31 | end. 32 | 33 | (* This design allows list lookup to be done in O(min(n, length l)). *) 34 | Definition lookup_N_safe {T: Type} (l: list T) (n: N) := 35 | match n with 36 | | N0 => List.nth_error l 0 37 | | Npos p => 38 | match skip_pos l p with 39 | | Some (x :: _) => Some x 40 | | _ => None 41 | end 42 | end. 43 | 44 | End EfficientExtraction. 45 | 46 | Section Soundness. 47 | Import EfficientExtraction. 48 | 49 | Lemma skip_pos_eq : forall {T: Type} (l: list T) (p: positive), 50 | (Pos.to_nat p <= length l) -> 51 | skip_pos l p = Some (List.skipn (Pos.to_nat p) l). 52 | Proof. 53 | move => T l p; move: l; induction p; move => l Hlen => //=. 54 | - destruct l => //; simpl in *; try by lias. 55 | do 2 try rewrite IHp => //; try by lias. 56 | + rewrite Pmult_nat_mult. 57 | rewrite skipn_skipn. 58 | do 2 f_equal. 59 | by lias. 60 | + rewrite length_skipn; by lias. 61 | - do 2 try rewrite IHp => //; try by lias. 62 | + rewrite skipn_skipn. 63 | do 2 f_equal. 64 | by lias. 65 | + rewrite length_skipn; by lias. 66 | - destruct l => //; simpl in *; by lias. 67 | Qed. 68 | 69 | Lemma skip_pos_oob : forall {T: Type} (l: list T) (p: positive), 70 | (Pos.to_nat p > length l) -> 71 | skip_pos l p = None. 72 | Proof. 73 | move => T l p; move: l; induction p; move => l Hlen => //=. 74 | - destruct l => //; simpl in *; try by lias. 75 | destruct (Pos.to_nat p <=? length l) eqn:Hlen2; move/Nat.leb_spec0 in Hlen2. 76 | + rewrite skip_pos_eq => //. 77 | apply IHp. 78 | rewrite length_skipn. 79 | by lias. 80 | + by rewrite IHp => //; lias. 81 | - destruct (Pos.to_nat p <=? length l) eqn:Hlen2; move/Nat.leb_spec0 in Hlen2. 82 | + rewrite skip_pos_eq => //. 83 | apply IHp. 84 | rewrite length_skipn. 85 | by lias. 86 | + by rewrite IHp; lias. 87 | - do 2 (destruct l; simpl in *; lias). 88 | Qed. 89 | 90 | Lemma lookup_N_safe_sound: forall {T: Type} (l: list T) (n:N), 91 | lookup_N_safe l n = nth_error l (N.to_nat n). 92 | Proof. 93 | move => T l; destruct n as [ | p] => //=. 94 | destruct (Pos.to_nat p <=? length l) eqn:Hlen; move/Nat.leb_spec0 in Hlen. 95 | - rewrite skip_pos_eq => //. 96 | by rewrite - hd_error_skipn. 97 | - rewrite skip_pos_oob => //; last by lias. 98 | symmetry. 99 | apply nth_error_None. 100 | by lias. 101 | Qed. 102 | 103 | End Soundness. 104 | -------------------------------------------------------------------------------- /theories/binary_parser_types.v: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | (** Datatypes used in the binary parser. **) 4 | (* (C) J. Pichon - see LICENSE.txt *) 5 | 6 | Require Import common. 7 | Require Export numerics datatypes. 8 | From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq. 9 | Require Import Ascii. 10 | 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Unset Printing Implicit Defensive. 14 | 15 | 16 | Definition expr := list basic_instruction. 17 | 18 | Inductive labelidx : Type := 19 | | Mk_labelidx : nat -> labelidx. 20 | 21 | Inductive funcidx : Type := 22 | | Mk_funcidx : nat -> funcidx. 23 | Inductive typeidx : Type := 24 | | Mk_typeidx : nat -> typeidx. 25 | 26 | Inductive localidx : Type := 27 | | Mk_localidx : nat -> localidx. 28 | 29 | Inductive globalidx : Type := 30 | | Mk_globalidx : nat -> globalidx. 31 | 32 | Record limits := Mk_limits { lim_min : nat; lim_max : option nat; }. 33 | 34 | Inductive elem_type : Type := 35 | | elem_type_tt : elem_type (* TODO: am I interpreting the spec correctly? *). 36 | 37 | Record table_type : Type := Mk_table_type { 38 | tt_limits : limits; 39 | tt_elem_type : elem_type; 40 | }. 41 | 42 | Record mem_type : Type := Mk_mem_type { mem_type_lims : limits }. 43 | 44 | Inductive import_desc : Type := 45 | | ID_func : nat -> import_desc 46 | | ID_table : table_type -> import_desc 47 | | ID_mem : mem_type -> import_desc 48 | | ID_global : global_type -> import_desc. 49 | 50 | Definition name := list ascii. 51 | 52 | Record import : Type := Mk_import { 53 | imp_module : name; 54 | imp_name : name; 55 | imp_desc : import_desc; 56 | }. 57 | 58 | Record table := Mk_table { t_type : table_type }. 59 | 60 | Definition mem := limits. 61 | 62 | Record global2 : Type := { 63 | g_type : global_type; 64 | g_init : expr; 65 | }. 66 | 67 | Record start := { start_func : nat; }. 68 | 69 | Record element : Type := { 70 | elem_table : nat; 71 | elem_offset : expr; 72 | elem_init : list nat; 73 | }. 74 | 75 | Record func : Type := { 76 | fc_locals : list value_type; 77 | fc_expr : expr; 78 | }. 79 | 80 | Record data : Type := { 81 | dt_data : nat; 82 | dt_offset : expr; 83 | dt_init : list ascii; 84 | }. 85 | 86 | Inductive export_desc : Type := 87 | | ED_func : nat -> export_desc 88 | | ED_table : nat -> export_desc 89 | | ED_mem : nat -> export_desc 90 | | ED_global : nat -> export_desc. 91 | 92 | Record export : Type := { 93 | exp_name : name; 94 | exp_desc : export_desc; 95 | }. 96 | 97 | Inductive section : Type := 98 | | Sec_custom : list ascii -> section 99 | | Sec_type : list function_type -> section 100 | | Sec_import : list import -> section 101 | | Sec_function : list typeidx -> section 102 | | Sec_table : list table -> section 103 | | Sec_memory : list mem -> section 104 | | Sec_global : list global2 -> section 105 | | Sec_export : list export -> section 106 | | Sec_start : start -> section 107 | | Sec_element : list element -> section 108 | | Sec_code : list func -> section 109 | | Sec_data : list data -> section. 110 | 111 | Record func2 : Type := { 112 | fc2_type : typeidx; 113 | fc2_locals : list value_type; 114 | fc2_body : expr; 115 | }. 116 | 117 | Record module : Type := { 118 | mod_types : list function_type; 119 | mod_funcs : list func2; 120 | mod_tables : list table; 121 | mod_mems : list mem; 122 | mod_globals : list global2; 123 | mod_elements : list element; 124 | mod_data : list data; 125 | mod_start : option start; 126 | mod_imports : list import; 127 | mod_exports : list export; 128 | }. 129 | 130 | *) 131 | -------------------------------------------------------------------------------- /src/execute.mli: -------------------------------------------------------------------------------- 1 | (** Functions to execute the definitions of the [Shim] module. *) 2 | 3 | (** A host implementation. *) 4 | module Host : sig 5 | include Shim.Host 6 | 7 | (** We add the ability to throw error in the monad. *) 8 | val error : string -> 'a host_event 9 | 10 | (** We also add a way to pattern-match the monad. *) 11 | val pmatch : 12 | ('a -> 'b) (** Normal case *) -> 13 | (string -> 'b) (** Error case *) -> 14 | 'a host_event -> 'b host_event 15 | 16 | (** Helper functions to convert between similar monads. *) 17 | val from_out : 'a Output.out -> 'a host_event 18 | val to_out : 'a host_event -> 'a host_event Output.out 19 | 20 | end 21 | 22 | module Interpreter : Shim.InterpreterType with type 'a host_event = 'a Host.host_event 23 | 24 | (* Type of the interpreter evaluation result. 25 | Exhaustion is modelled by the interpreter recording the current stack depth. The depth should not be computed 26 | during run-time due to the interpreter config using a linked-list representation of the frame stack (due to extraction) which 27 | would have led to a linear complexity per length computation. The OCaml host then returns an exhaustion when the current depth 28 | exceeds the maximum allowed depth. 29 | *) 30 | type eval_cfg_result = 31 | | Cfg_res of Interpreter.store_record * Extract.frame * Extract.value0 list 32 | | Cfg_trap of Interpreter.store_record * Extract.frame 33 | | Cfg_err 34 | | Cfg_exhaustion 35 | 36 | (* Evaluating an interpreter configuration fully. *) 37 | val eval_interp_cfg: Output.verbosity -> int -> int -> Interpreter.interp_config_tuple -> int -> eval_cfg_result 38 | 39 | (* Evaluate a Wasm configuration using the interpreter configuration. *) 40 | val eval_wasm_cfg: Output.verbosity -> int -> Interpreter.wasm_config_tuple -> eval_cfg_result 41 | 42 | (* Type of the host extern val store *) 43 | module StringMap : Map.S with type key = string 44 | 45 | (* Host store consists of the module exports store and a module variable name map (from vars to actual names in string). *) 46 | type host_extern_store = ((Interpreter.externval StringMap.t) StringMap.t) * (string StringMap.t) 47 | 48 | (* Get a global variable from the store by a host export name. *) 49 | val global_get: host_extern_store -> Interpreter.store_record -> string -> string -> Extract.value0 Host.host_event 50 | 51 | (* Given a starting state and a list of imports (store references), instantiating a module. 52 | Return the interpreter result after running the instantiation instructions. Does not update the host export store. *) 53 | val instantiate: Output.verbosity -> host_extern_store -> Interpreter.store_record -> Extract.module0 -> eval_cfg_result Host.host_event 54 | 55 | (* A host wrapper for the instantiation function that updates the host export store. *) 56 | val instantiate_host: Output.verbosity -> host_extern_store -> Interpreter.store_record -> string -> Extract.module0 -> (host_extern_store * Interpreter.store_record * eval_cfg_result) Host.host_event 57 | 58 | (* Instantiate a sequence of modules with names. *) 59 | val instantiate_modules: Output.verbosity -> host_extern_store -> Interpreter.store_record -> string list -> Extract.module0 list -> (host_extern_store * Interpreter.store_record) Host.host_event 60 | 61 | (** Given a verbosity level, a host and Wasm state, a list of arguments, a module and function name, and a maximum call depth, invoke the Wasm function. *) 62 | val invoke_func : Output.verbosity -> host_extern_store -> (Interpreter.store_record * Extract.frame) -> Extract.value0 list -> string -> string -> int -> eval_cfg_result Host.host_event 63 | 64 | (** Print the result of a function invocation. *) 65 | val print_invoke_result : Output.verbosity -> eval_cfg_result -> unit -------------------------------------------------------------------------------- /src/shim.mli: -------------------------------------------------------------------------------- 1 | (** Interface between [Extract] and the main files. *) 2 | 3 | module type Host = sig 4 | 5 | (** The type of host functions. *) 6 | type host_function 7 | 8 | (** Equality of host functions. *) 9 | val host_function_eq_dec : host_function -> host_function -> bool 10 | 11 | (** The monad of host events. *) 12 | type 'a host_event 13 | val host_ret : 'a -> 'a host_event 14 | val host_bind : 'a host_event -> ('a -> 'b host_event) -> 'b host_event 15 | 16 | (** Application of a host function in the host monad. *) 17 | val host_apply : 18 | Extract.store_record -> Extract.function_type -> host_function -> Extract.value0 list -> 19 | (Extract.store_record * Extract.result) option host_event 20 | 21 | (** Printing a host function. *) 22 | val show_host_function : host_function -> string 23 | end 24 | 25 | module Extraction_instance : Host 26 | 27 | module type InterpreterType = sig 28 | 29 | module Host : Host 30 | include module type of Host 31 | 32 | (** The usual monadic notations. *) 33 | val ( >>= ) : 'a host_event -> ('a -> 'b host_event) -> 'b host_event 34 | val ( let* ) : 'a host_event -> ('a -> 'b host_event) -> 'b host_event 35 | val ( let+ ) : 'a host_event -> ('a -> 'b) -> 'b host_event 36 | val ( and+ ) : 'a host_event -> 'b host_event -> ('a * 'b) host_event 37 | val pure : 'a -> 'a host_event 38 | 39 | type store_record = Extract.Extraction_instance.store_record 40 | type frame = Extract.frame 41 | type wasm_config_tuple = Extract.config_tuple 42 | type interp_config_tuple = Extract.Extraction_instance.cfg_tuple_ctx 43 | type res_tuple = Extract.Extraction_instance.run_step_ctx_result 44 | type basic_instruction = Extract.basic_instruction 45 | type administrative_instruction = Extract.administrative_instruction 46 | type moduleinst = Extract.moduleinst 47 | type value = Extract.value0 48 | type externval = Extract.extern_value 49 | 50 | val empty_store_record : store_record 51 | 52 | (** Run one step of the interpreter. *) 53 | val run_one_step : 54 | interp_config_tuple -> int -> res_tuple 55 | 56 | (* Given a store and an admin instruction list to run, construct the corresponding interpreter configuration to run. *) 57 | val run_v_init : 58 | store_record -> administrative_instruction list -> interp_config_tuple option 59 | 60 | (* Convert a Wasm configuration tuple (s; f; es) to an interpreter configuration (in theories/interpreter_ctx.v). *) 61 | val interp_cfg_of_wasm : 62 | wasm_config_tuple -> interp_config_tuple 63 | 64 | (* Get a global variable from the Wasm store by its address (externval). *) 65 | val wasm_global_get : 66 | store_record -> externval -> value option 67 | 68 | (** Look-up a specific extracted function of the instantiation. *) 69 | val invoke_extern: 70 | store_record -> externval -> value list -> (administrative_instruction list) option 71 | 72 | (** Perform the instantiation of a module. *) 73 | val interp_instantiate_wrapper : 74 | store_record -> Extract.module0 -> externval list -> wasm_config_tuple option * string 75 | 76 | (** Extracting the import path from the parsed module. *) 77 | val get_import_path: Extract.module0 -> (string * string) list 78 | 79 | (** Extracting the exports from the resulting frame. *) 80 | val get_exports : frame -> (string * externval) list 81 | 82 | (** Parsing. *) 83 | val run_parse_module_str : string -> Extract.module0 option 84 | 85 | val run_parse_arg : string -> Extract.value0 option 86 | 87 | (** Pretty-printing. *) 88 | 89 | val pp_values : Extract.value0 list -> string 90 | val pp_store : int (** The indentation level *) -> store_record -> string 91 | 92 | val pp_cfg_tuple_ctx_except_store : 93 | interp_config_tuple -> string 94 | 95 | val pp_res_cfg_except_store : 96 | interp_config_tuple -> res_tuple -> string 97 | 98 | val pp_es : Extract.administrative_instruction list -> string 99 | 100 | val pp_externval: externval -> string 101 | 102 | val is_canonical_nan: Extract.number_type -> value -> bool 103 | 104 | val is_arithmetic_nan: Extract.number_type -> value -> bool 105 | 106 | val v128_extract_lanes: Extract.vshape -> Extract.SIMD.v128 -> Extract.value_num list 107 | 108 | end 109 | 110 | module Interpreter : functor (EH : Host) -> 111 | InterpreterType 112 | with module Host = EH 113 | and type 'a host_event = 'a EH.host_event 114 | -------------------------------------------------------------------------------- /changelogs/v2.0.md: -------------------------------------------------------------------------------- 1 | # Release 2.0 + Subtyping 2 | 3 | This release for Wasm 2.0 + Subtyping implemented the following changes in the official spec release 2.0: 4 | - Multiple-value blocks; 5 | - Reference types; 6 | - Table instructions; 7 | - Multiple tables; 8 | - Bulk memory and table instructions. 9 | 10 | In addition, this release also implemented the subtyping system from the future funcref/GC proposals. 11 | 12 | The new sign extension, non-trapping float-to-int conversion, and vector types are added but without any concrete implementation. 13 | 14 | ## Updated Components: 15 | - [x] Base opsem/typing definitions; 16 | - [x] Preservation theorems; 17 | - [x] Interpreter and progress theorem; 18 | - [x] Instantiation; 19 | - [x] Instantiation soundness theorems; 20 | - [x] Type checker; 21 | - [x] Type checker correctness theorem; 22 | - [x] Binary printer/parser; 23 | - [x] Code pretty printer; 24 | - [x] Subtyping. 25 | 26 | # Major Structural Changes 27 | 28 | ## Values vs Instructions 29 | Due to the introduction of reference values, values are no longer necessarily basic instructions; function references and external references are expressed as administrative instructions due to their direct usage of store addresses instead of module indices. This change has broken some assumptions that many original proofs and definitions based on -- mostly those related to value typing (see below). 30 | Total and partial conversion operations are now provided for conversion between values and their corresponding instructions: 31 | - `v_to_e/e_to_v` for total conversions; 32 | - `e_to_v_opt` for partial operations. 33 | 34 | ## Value Typing and the Store 35 | Due to the use of store addresses, the new reference values can only be typed given a store. This necessitated the introduction 36 | of a separate `value_typing` relation with respect to a store. In addition, value typing relation now has to be done at the 37 | `e_typing` level (for administrative instructions) as they can no longer be converted to basic instructions and typed using the `const` rule in `be_typing`. New value typing inversion lemmas were added to help reasoning with this change; search for terms involving `value_typing` and `values_typing`. 38 | 39 | ## Threads 40 | Threads are now properly spelt out as a separate type that constitutes the configuration tuple. The old thread-related definitions (e.g. `s_typing`) are renamed to the names used in the standard (e.g. `thread_typing`). 41 | 42 | ## Type System and Subtyping 43 | In addition, this release also implements subtyping introduced in the future funcret/GC proposal as a forward-looking move. There is currently no observable effect in Wasm 2.0 except for typing instructions past unconditional branches, as there is no non-trivial subtypings between any of the base value types. There exists a principal type (potentially with some free type parameters) for every value/instruction, which all possible types of it are supertypes of. 44 | The largest impact of this type system change is that, in the future, values can no longer uniquely typed even if it is well typed. This is not the case in Wasm 2.0 yet, but examples can be introduced in future proposals. 45 | The old `weakening` typing rules are replaced by a subtyping rule as a result of this change, which reflects the shift in the future proposals. 46 | 47 | # Refactorings and Feature Improvements 48 | 49 | ## Host Formulation 50 | The parametric host language is now defined using typeclasses. 51 | The main major benefit is the automatic filling of implicit host parameter, instead of needing to redefine all operations involving anything downstream from function instances and stores. The proof context is also greatly simplified since all these redefinitions no longer exist to occupy a major chunk of the buffer window. 52 | 53 | ## Numerics 54 | - Refactored the old collection of conversion operations *cvtop* to be split up by their individual constructors to better match the spec. 55 | 56 | ## Name Changes 57 | - Changed the name of some types, instructions, and constructors to better match the official spec. 58 | - Instance indices are now simplified to the base `u32` type without additional constructors. 59 | 60 | ## Pretty Printer 61 | - Implemented pretty printing for conversion operations. 62 | 63 | ## Typing 64 | - Massively improved the scope and automation of the typing inversion lemmas. 65 | - Provided a new tactic `resolve_e_typing` that automatically tries to resolve `e_typing` goals, dealing mostly with the operands. 66 | - Provided a separate file for the new subtyping lemmas and tactics. 67 | 68 | ## Type Checker 69 | - Completely reimplemented the type checker, which should now be slightly more efficient (although this should hardly be observable). 70 | 71 | ## Miscellaneous 72 | - Introduced many additional excerpts in comments from the official spec for various definitions. 73 | 74 | # Bug Fixes 75 | - Fixed a bug where the binary printer incorrectly prints all types of reinterpret conversions to 0xBC. 76 | - Fixed a bug where the binary printer sometimes prints indices via a conversion to nat first. 77 | -------------------------------------------------------------------------------- /theories/list_extra.v: -------------------------------------------------------------------------------- 1 | (* Some extra operations on lists. *) 2 | (* (C) J. Pichon, M. Bodin - see LICENSE.txt *) 3 | 4 | Set Implicit Arguments. 5 | 6 | From Coq Require Import List. 7 | From ExtLib Require Import Structures.Monad. 8 | 9 | (** Given list of option types, check that all options are [Some] 10 | and return the corresponding list of values. **) 11 | Fixpoint those0 {A} (l : list (option A)) : option (list A) := 12 | match l with 13 | | nil => Some nil 14 | | None :: xs => None 15 | | (Some y) :: xs => 16 | option_map (fun ys => y :: ys) (those0 xs) 17 | end. 18 | 19 | Local Fixpoint those_aux {A} (acc : option (list A)) (l : list (option A)) : option (list A) := 20 | match acc with 21 | | None => None 22 | | Some ys_rev => 23 | match l with 24 | | nil => Some ys_rev 25 | | None :: xs => None 26 | | Some y :: xs => 27 | those_aux (Some (y :: ys_rev)) xs 28 | end 29 | end. 30 | 31 | (** A tail-recursive variant of [those0]. **) 32 | Definition those {A} (l : list (option A)) : option (list A) := 33 | match those_aux (Some nil) l with 34 | | None => None 35 | | Some l => Some (List.rev l) 36 | end. 37 | 38 | Local Lemma those0_None : forall A (l : list (option A)), 39 | In None l <-> those0 l = None. 40 | Proof. 41 | induction l as [|o l]; simpl. 42 | - split; inversion 1. 43 | - destruct o as [a|]; split; auto. 44 | + rewrite IHl. intros [?|E]; [discriminate|]. rewrite E. auto. 45 | + destruct those0; simpl; try discriminate. rewrite IHl. auto. 46 | Qed. 47 | 48 | Local Lemma those_aux_None : forall A (la : list A) l, 49 | In None l <-> those_aux (Some la) l = None. 50 | Proof. 51 | intros A la l. generalize la. clear la. induction l as [|o l]; intros la; simpl. 52 | - split; inversion 1. 53 | - destruct o as [a|]. 54 | + rewrite <- IHl. split; auto. intros [?|?]; [discriminate|auto]. 55 | + split; auto. 56 | Qed. 57 | 58 | Local Lemma cons_app : forall A (a : A) l, a :: l = (a :: nil) ++ l. 59 | Proof. reflexivity. Qed. 60 | 61 | Local Lemma those_those0_gen : forall A l (la : list A), 62 | Forall (fun o : option A => o <> None) l -> 63 | exists rl rl', 64 | those0 l = Some rl /\ those_aux (Some la) l = Some rl' /\ 65 | List.rev la ++ rl = List.rev rl'. 66 | Proof. 67 | induction l; intros la F. 68 | - repeat eexists. rewrite app_nil_r. reflexivity. 69 | - inversion F. subst. 70 | destruct a as [a|]; try solve [ exfalso; auto ]. 71 | edestruct IHl as (rl&rl'&E1&E2&E3); auto. 72 | repeat eexists. 73 | + simpl. rewrite E1. reflexivity. 74 | + simpl. rewrite E2. reflexivity. 75 | + rewrite <- E3. rewrite cons_app with (l := rl). rewrite cons_app with (l := la). 76 | rewrite rev_app_distr. rewrite <- app_assoc. reflexivity. 77 | Qed. 78 | 79 | (** [those0] and [those] are indeed equivalent. **) 80 | Lemma those_those0 : forall A (l : list (option A)), 81 | those0 l = those l. 82 | Proof. 83 | intros A l. unfold those. 84 | destruct (Forall_Exists_dec (fun o => o <> None) 85 | (fun x => ltac:(destruct x; auto; left; discriminate)) l) as [d|d]. 86 | - eapply those_those0_gen in d. destruct d as (rl&rl'&E1&E2&E3). 87 | rewrite E1. rewrite E2. rewrite <- E3. reflexivity. 88 | - rewrite Exists_exists in d. destruct d as (x&I&E). destruct x. 89 | + exfalso. apply E. discriminate. 90 | + set (I' := I). clearbody I'. 91 | rewrite those0_None in I. rewrite I. 92 | rewrite those_aux_None in I'. rewrite I'. 93 | reflexivity. 94 | Qed. 95 | 96 | Fixpoint mapi_aux {A B} (acc : nat * list B) (f : nat -> A -> B) (xs : list A) : list B := 97 | let '(i, ys_rev) := acc in 98 | match xs with 99 | | nil => 100 | List.rev ys_rev 101 | | cons x xs' => 102 | let y := f i x in 103 | mapi_aux (i + 1, cons y ys_rev) f xs' 104 | end. 105 | 106 | Definition mapi {A B} (f : nat -> A -> B) (xs : list A) : list B := 107 | mapi_aux (0, nil) f xs. 108 | 109 | Definition fold_lefti {A B} (f : nat -> A -> B -> A) (xs : list B) (acc0 : A) : A := 110 | let '(_, acc_end) := 111 | List.fold_left 112 | (fun '(k, acc) x => 113 | (k + 1, f k acc x)) 114 | xs 115 | (0, acc0) in 116 | acc_end. 117 | 118 | Section Monad. 119 | 120 | Import MonadNotation. 121 | 122 | Open Scope monad_scope. 123 | 124 | (** Let us assume a monad. **) 125 | Variable m : Type -> Type. 126 | Context {M : Monad m}. 127 | 128 | (** Calls a function to each of the elements of a list, bindings the results into a new list. **) 129 | Fixpoint bind_list0 {A B} (f : A -> m B) (l : list A) : m (list B) := 130 | match l with 131 | | nil => ret nil 132 | | a :: l => 133 | r <- f a ;; 134 | l' <- bind_list0 f l ;; 135 | ret (r :: l') 136 | end. 137 | 138 | Fixpoint bind_list_aux {A B} (f : A -> m B) acc (l : list A) : m (list B) := 139 | match l with 140 | | nil => ret (List.rev acc) 141 | | a :: l => 142 | r <- f a ;; 143 | bind_list_aux f (r :: acc) l 144 | end. 145 | 146 | (** A tail-recursive version of [bind_list0]. **) 147 | Definition bind_list {A B} (f : A -> m B) := 148 | bind_list_aux f nil. 149 | 150 | End Monad. 151 | 152 | -------------------------------------------------------------------------------- /theories/bytes_pp.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Strings.String. 2 | Open Scope string_scope. 3 | Require Import Strings.Byte. 4 | 5 | (* for pretty-printing *) 6 | Definition hex_small_no_prefix_of_byte (b : byte) := 7 | (* 8 | #!/usr/bin/env ocaml 9 | open Char 10 | let a_code = Char.code 'a' 11 | let show = function 12 | | x when x < 10 -> string_of_int x 13 | | x -> String.make 1 (Char.chr (a_code + x - 10)) 14 | let _ = 15 | for i = 0 to 15 do 16 | for j = 0 to 15 do 17 | let x = show i in 18 | let y = show j in 19 | print_string ("| x" ^ x ^ y ^ " => \"" ^ x ^ y ^ "\"\n") 20 | done 21 | done 22 | *) 23 | match b with 24 | | x00 => "00" 25 | | x01 => "01" 26 | | x02 => "02" 27 | | x03 => "03" 28 | | x04 => "04" 29 | | x05 => "05" 30 | | x06 => "06" 31 | | x07 => "07" 32 | | x08 => "08" 33 | | x09 => "09" 34 | | x0a => "0a" 35 | | x0b => "0b" 36 | | x0c => "0c" 37 | | x0d => "0d" 38 | | x0e => "0e" 39 | | x0f => "0f" 40 | | x10 => "10" 41 | | x11 => "11" 42 | | x12 => "12" 43 | | x13 => "13" 44 | | x14 => "14" 45 | | x15 => "15" 46 | | x16 => "16" 47 | | x17 => "17" 48 | | x18 => "18" 49 | | x19 => "19" 50 | | x1a => "1a" 51 | | x1b => "1b" 52 | | x1c => "1c" 53 | | x1d => "1d" 54 | | x1e => "1e" 55 | | x1f => "1f" 56 | | x20 => "20" 57 | | x21 => "21" 58 | | x22 => "22" 59 | | x23 => "23" 60 | | x24 => "24" 61 | | x25 => "25" 62 | | x26 => "26" 63 | | x27 => "27" 64 | | x28 => "28" 65 | | x29 => "29" 66 | | x2a => "2a" 67 | | x2b => "2b" 68 | | x2c => "2c" 69 | | x2d => "2d" 70 | | x2e => "2e" 71 | | x2f => "2f" 72 | | x30 => "30" 73 | | x31 => "31" 74 | | x32 => "32" 75 | | x33 => "33" 76 | | x34 => "34" 77 | | x35 => "35" 78 | | x36 => "36" 79 | | x37 => "37" 80 | | x38 => "38" 81 | | x39 => "39" 82 | | x3a => "3a" 83 | | x3b => "3b" 84 | | x3c => "3c" 85 | | x3d => "3d" 86 | | x3e => "3e" 87 | | x3f => "3f" 88 | | x40 => "40" 89 | | x41 => "41" 90 | | x42 => "42" 91 | | x43 => "43" 92 | | x44 => "44" 93 | | x45 => "45" 94 | | x46 => "46" 95 | | x47 => "47" 96 | | x48 => "48" 97 | | x49 => "49" 98 | | x4a => "4a" 99 | | x4b => "4b" 100 | | x4c => "4c" 101 | | x4d => "4d" 102 | | x4e => "4e" 103 | | x4f => "4f" 104 | | x50 => "50" 105 | | x51 => "51" 106 | | x52 => "52" 107 | | x53 => "53" 108 | | x54 => "54" 109 | | x55 => "55" 110 | | x56 => "56" 111 | | x57 => "57" 112 | | x58 => "58" 113 | | x59 => "59" 114 | | x5a => "5a" 115 | | x5b => "5b" 116 | | x5c => "5c" 117 | | x5d => "5d" 118 | | x5e => "5e" 119 | | x5f => "5f" 120 | | x60 => "60" 121 | | x61 => "61" 122 | | x62 => "62" 123 | | x63 => "63" 124 | | x64 => "64" 125 | | x65 => "65" 126 | | x66 => "66" 127 | | x67 => "67" 128 | | x68 => "68" 129 | | x69 => "69" 130 | | x6a => "6a" 131 | | x6b => "6b" 132 | | x6c => "6c" 133 | | x6d => "6d" 134 | | x6e => "6e" 135 | | x6f => "6f" 136 | | x70 => "70" 137 | | x71 => "71" 138 | | x72 => "72" 139 | | x73 => "73" 140 | | x74 => "74" 141 | | x75 => "75" 142 | | x76 => "76" 143 | | x77 => "77" 144 | | x78 => "78" 145 | | x79 => "79" 146 | | x7a => "7a" 147 | | x7b => "7b" 148 | | x7c => "7c" 149 | | x7d => "7d" 150 | | x7e => "7e" 151 | | x7f => "7f" 152 | | x80 => "80" 153 | | x81 => "81" 154 | | x82 => "82" 155 | | x83 => "83" 156 | | x84 => "84" 157 | | x85 => "85" 158 | | x86 => "86" 159 | | x87 => "87" 160 | | x88 => "88" 161 | | x89 => "89" 162 | | x8a => "8a" 163 | | x8b => "8b" 164 | | x8c => "8c" 165 | | x8d => "8d" 166 | | x8e => "8e" 167 | | x8f => "8f" 168 | | x90 => "90" 169 | | x91 => "91" 170 | | x92 => "92" 171 | | x93 => "93" 172 | | x94 => "94" 173 | | x95 => "95" 174 | | x96 => "96" 175 | | x97 => "97" 176 | | x98 => "98" 177 | | x99 => "99" 178 | | x9a => "9a" 179 | | x9b => "9b" 180 | | x9c => "9c" 181 | | x9d => "9d" 182 | | x9e => "9e" 183 | | x9f => "9f" 184 | | xa0 => "a0" 185 | | xa1 => "a1" 186 | | xa2 => "a2" 187 | | xa3 => "a3" 188 | | xa4 => "a4" 189 | | xa5 => "a5" 190 | | xa6 => "a6" 191 | | xa7 => "a7" 192 | | xa8 => "a8" 193 | | xa9 => "a9" 194 | | xaa => "aa" 195 | | xab => "ab" 196 | | xac => "ac" 197 | | xad => "ad" 198 | | xae => "ae" 199 | | xaf => "af" 200 | | xb0 => "b0" 201 | | xb1 => "b1" 202 | | xb2 => "b2" 203 | | xb3 => "b3" 204 | | xb4 => "b4" 205 | | xb5 => "b5" 206 | | xb6 => "b6" 207 | | xb7 => "b7" 208 | | xb8 => "b8" 209 | | xb9 => "b9" 210 | | xba => "ba" 211 | | xbb => "bb" 212 | | xbc => "bc" 213 | | xbd => "bd" 214 | | xbe => "be" 215 | | xbf => "bf" 216 | | xc0 => "c0" 217 | | xc1 => "c1" 218 | | xc2 => "c2" 219 | | xc3 => "c3" 220 | | xc4 => "c4" 221 | | xc5 => "c5" 222 | | xc6 => "c6" 223 | | xc7 => "c7" 224 | | xc8 => "c8" 225 | | xc9 => "c9" 226 | | xca => "ca" 227 | | xcb => "cb" 228 | | xcc => "cc" 229 | | xcd => "cd" 230 | | xce => "ce" 231 | | xcf => "cf" 232 | | xd0 => "d0" 233 | | xd1 => "d1" 234 | | xd2 => "d2" 235 | | xd3 => "d3" 236 | | xd4 => "d4" 237 | | xd5 => "d5" 238 | | xd6 => "d6" 239 | | xd7 => "d7" 240 | | xd8 => "d8" 241 | | xd9 => "d9" 242 | | xda => "da" 243 | | xdb => "db" 244 | | xdc => "dc" 245 | | xdd => "dd" 246 | | xde => "de" 247 | | xdf => "df" 248 | | xe0 => "e0" 249 | | xe1 => "e1" 250 | | xe2 => "e2" 251 | | xe3 => "e3" 252 | | xe4 => "e4" 253 | | xe5 => "e5" 254 | | xe6 => "e6" 255 | | xe7 => "e7" 256 | | xe8 => "e8" 257 | | xe9 => "e9" 258 | | xea => "ea" 259 | | xeb => "eb" 260 | | xec => "ec" 261 | | xed => "ed" 262 | | xee => "ee" 263 | | xef => "ef" 264 | | xf0 => "f0" 265 | | xf1 => "f1" 266 | | xf2 => "f2" 267 | | xf3 => "f3" 268 | | xf4 => "f4" 269 | | xf5 => "f5" 270 | | xf6 => "f6" 271 | | xf7 => "f7" 272 | | xf8 => "f8" 273 | | xf9 => "f9" 274 | | xfa => "fa" 275 | | xfb => "fb" 276 | | xfc => "fc" 277 | | xfd => "fd" 278 | | xfe => "fe" 279 | | xff => "ff" 280 | end. 281 | 282 | Definition hex_small_no_prefix_of_bytes (x : list Byte.byte) := 283 | String.concat " " (List.map hex_small_no_prefix_of_byte x). 284 | 285 | Definition hex_small_no_prefix_of_bytes_compact (x : list Byte.byte) := 286 | String.concat "" (List.map hex_small_no_prefix_of_byte x). 287 | -------------------------------------------------------------------------------- /src/wasm_coq_interpreter.ml: -------------------------------------------------------------------------------- 1 | (** Main file for the Wasm interpreter **) 2 | 3 | (** Main function *) 4 | let process_args_and_run verbosity text no_exec max_call_depth srcs func_name src_module_name arg_strings = 5 | let open Execute.Host in 6 | let open Execute.Interpreter in 7 | let open Parse in 8 | try 9 | (** Preparing the files. *) 10 | (** Each file should contain a single Wasm module binary. The modules will be instantiated by their order. *) 11 | let files = 12 | List.map (fun dest -> 13 | if not (Sys.file_exists dest) || Sys.is_directory dest then 14 | invalid_arg (Printf.sprintf "No file %s found." dest) 15 | else 16 | let in_channel = open_in_bin dest in 17 | let s = really_input_string in_channel (in_channel_length in_channel) in 18 | close_in in_channel; 19 | s) srcs in 20 | let mnames = List.map extract_module_name srcs in 21 | let* modules = parse_modules verbosity text files in 22 | let starting_host_store = (Execute.StringMap.empty, Execute.StringMap.empty) in 23 | let starting_store = empty_store_record in 24 | let* (exts, s) = Execute.instantiate_modules verbosity starting_host_store starting_store mnames modules in 25 | let* args = parse_args arg_strings in 26 | (** Running. *) 27 | if no_exec then 28 | Output.( 29 | debug_info verbosity stage (fun _ -> 30 | "skipping interpretation because of --no-exec.\n") ; 31 | pure () 32 | ) 33 | else 34 | let running_module_name = 35 | (if src_module_name = "" then 36 | List.hd (List.rev mnames) 37 | else src_module_name) in 38 | let* ret = Execute.invoke_func verbosity exts (s, Extract.empty_frame) args running_module_name func_name max_call_depth in 39 | Execute.print_invoke_result verbosity ret; 40 | pure () 41 | with Invalid_argument msg -> error msg 42 | 43 | (* Reference interpreter allows only 256 nested calls: 44 | https://github.com/WebAssembly/spec/blob/main/interpreter/main/flags.ml 45 | *) 46 | let wast_budget = 256 47 | 48 | (** Similar to [process_args_and_run], but differs in the output type. *) 49 | let process_args_and_run_out verbosity text no_exec wast_mode wast_timeout max_call_depth srcs func_name src_module_name args = 50 | (if wast_mode then 51 | let files = 52 | List.map (fun dest -> 53 | if not (Sys.file_exists dest) || Sys.is_directory dest then 54 | invalid_arg (Printf.sprintf "No file %s found." dest) 55 | else 56 | let in_channel = open_in_bin dest in 57 | let s = really_input_string in_channel (in_channel_length in_channel) in 58 | close_in in_channel; 59 | s) srcs in 60 | match files with 61 | | [] -> Execute.Host.error "No wast file provided" 62 | | [scriptstr] -> 63 | let wast_max_call_depth = if max_call_depth = -1 then wast_budget else max_call_depth in 64 | Wast_execute.run_wast_string verbosity wast_timeout wast_max_call_depth scriptstr 65 | | _ -> Execute.Host.error "Wast mode does not support multiple files" 66 | else 67 | process_args_and_run verbosity text no_exec max_call_depth srcs func_name src_module_name args) 68 | |> Execute.Host.to_out |> Output.Out.convert 69 | 70 | (** Command line interface *) 71 | 72 | open Cmdliner 73 | 74 | let verbosity = 75 | let mk v l doc = 76 | let doc = "Verbosity level: " ^ doc in 77 | (v, Arg.info l ~doc) in 78 | Arg.(value & vflag Output.result Output.[ 79 | mk none ["vn"; "nothing"] "Print nothing" ; 80 | mk result ["vr"; "result"] "Only print the result" ; 81 | mk stage ["vs"; "stage"] "Print the stage and the result" ; 82 | mk intermediate ["vi"; "intermediate"] "Print all intermediate states, without stores" ; 83 | mk store ["va"; "all"; "store"] "Print everything, including stores" ; 84 | ]) 85 | 86 | let text = 87 | let doc = "Read text format." in 88 | Arg.(value & flag & info ["text"] ~doc) 89 | 90 | let no_exec = 91 | let doc = "Stop before executing (only go up to typechecking)." in 92 | Arg.(value & flag & info ["no-exec"] ~doc) 93 | 94 | let func_name = 95 | let doc = "Name of the Wasm function to run." in 96 | Arg.(value & opt string "" & info ["r"; "run"] ~docv:"NAME" ~doc) 97 | 98 | let module_name = 99 | let doc = "Name of the source Wasm module to locate the function. Defaults to the last module. " in 100 | Arg.(value & opt string "" & info ["m"; "module"] ~docv:"MODULE" ~doc) 101 | 102 | let args = 103 | let doc = "Arguments to passed in to the function" in 104 | Arg.(value & opt_all string [] & info ["a"; "arg"] ~docv:"ARG" ~doc) 105 | 106 | let wast = 107 | let doc = "Running a .wast test suite" in 108 | Arg.(value & flag & info ["wast"] ~docv:"ARG" ~doc) 109 | 110 | let wast_timeout = 111 | let doc = "Set the timeout for running .wast test suites" in 112 | Arg.(value & opt int 10 & info ["t"] ~docv:"ARG" ~doc) 113 | 114 | let max_call_depth = 115 | let doc = "Set the maximum depths of call stack allowed in the interpreter (-1 for unlimited)" in 116 | Arg.(value & opt int (-1) & info ["d"] ~docv:"MAXDEPTH" ~doc) 117 | 118 | let srcs = 119 | let doc = "Source file(s) to interpret." in 120 | let docinfo = 121 | Arg.info [] ~docv:"FILE" ~doc:doc in 122 | Arg.(non_empty & pos_all file [] & docinfo) 123 | 124 | 125 | let cmd = 126 | let doc = "Interpret WebAssembly files" in 127 | let man_xrefs = [] in 128 | let exits = Cmd.Exit.defaults in 129 | let man = 130 | [ `S Manpage.s_bugs; 131 | `P "Report them at https://github.com/WasmCert/WasmCert-Coq/issues"; ] 132 | in 133 | Cmd.v 134 | (Cmd.info "wasm_interpreter" ~version:"c9b010d-dirty" ~doc ~exits ~man ~man_xrefs) 135 | Term.(ret (const process_args_and_run_out $ verbosity $ text $ no_exec $ wast $ wast_timeout $ max_call_depth $ srcs $ func_name $ module_name $ args )) 136 | 137 | 138 | let () = Stdlib.exit @@ 139 | match Cmd.eval_value cmd with 140 | | Ok _ -> Cmd.Exit.ok 141 | | Error _ -> Cmd.Exit.some_error 142 | -------------------------------------------------------------------------------- /theories/extraction_instance.v: -------------------------------------------------------------------------------- 1 | (* The setup for extraction *) 2 | From Coq Require Import String. 3 | From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq. 4 | From HB Require Import structures. 5 | From Wasm Require Import memory host interpreter_ctx instantiation_func pp. 6 | From ExtLib Require Import Structures.Monad. 7 | From ExtLib Require Import IdentityMonad. 8 | 9 | From Wasm Require Import memory_vec. 10 | 11 | Module Memory_instance. 12 | 13 | Definition memory_instance := Memory_vec. 14 | 15 | End Memory_instance. 16 | 17 | Module Extraction_instance. 18 | 19 | Section DummyHost. 20 | 21 | Existing Instance Memory_instance.memory_instance. 22 | 23 | Definition host_function := void. 24 | Definition host_event := ident. 25 | Definition host_ret := @ret _ Monad_ident. 26 | Definition host_bind := @bind _ Monad_ident. 27 | 28 | Definition host_function_eq_dec : forall f1 f2 : host_function, {f1 = f2} + {f1 <> f2}. 29 | Proof. decidable_equality. Defined. 30 | 31 | #[export] 32 | Instance hfc: host_function_class. 33 | Proof. 34 | exact (Build_host_function_class host_function_eq_dec). 35 | Defined. 36 | 37 | Definition host_apply (_ : store_record) (_ : function_type) := 38 | of_void (seq value -> ident (option (store_record * result))). 39 | 40 | #[export] 41 | Instance host_instance : host. 42 | Proof. 43 | by refine {| 44 | host_state := unit; 45 | host_application _ _ _ _ _ _ _ := False 46 | |}. 47 | Defined. 48 | 49 | Definition host_application_impl : host_state -> store_record -> function_type -> host_function -> seq value -> 50 | (host_state * option (store_record * result)). 51 | Proof. 52 | move => ??? hf. 53 | by refine ((of_void _) hf). 54 | Defined. 55 | 56 | Definition host_application_impl_correct : 57 | (forall hs s ft hf vs hs' hres, (host_application_impl hs s ft hf vs = (hs', hres)) -> host_application hs s ft hf vs hs' hres). 58 | Proof. 59 | move => ??? hf; by inversion hf. 60 | Defined. 61 | 62 | End DummyHost. 63 | 64 | 65 | Section Interpreter_ctx_extract. 66 | 67 | Definition empty_frame := empty_frame. 68 | 69 | Definition store_record := store_record. 70 | 71 | Definition cfg_tuple_ctx : Type := cfg_tuple_ctx. 72 | 73 | Definition run_step_ctx_result : host_state -> cfg_tuple_ctx -> BinNums.N -> Type := run_step_ctx_result. 74 | 75 | Definition run_one_step (cfg: cfg_tuple_ctx) (d: BinNums.N) : run_step_ctx_result tt cfg d := run_one_step host_application_impl_correct tt cfg d. 76 | 77 | Definition run_v_init : store_record -> list administrative_instruction -> option cfg_tuple_ctx := run_v_init. 78 | 79 | Definition interp_cfg_of_wasm := interp_cfg_of_wasm. 80 | 81 | End Interpreter_ctx_extract. 82 | 83 | 84 | Section PP. 85 | 86 | Definition pp_values := pp_values. 87 | 88 | Definition pp_store := pp_store. 89 | 90 | Definition pp_cfg_tuple_ctx_except_store := pp_cfg_tuple_ctx_except_store. 91 | 92 | Definition pp_res_cfg_except_store {cfg: cfg_tuple_ctx} {d: BinNums.N} (res: run_step_ctx_result tt cfg d) := pp_res_cfg_except_store res. 93 | 94 | Definition pp_administrative_instructions := pp_administrative_instructions. 95 | 96 | Definition pp_extern_value := pp_extern_value. 97 | 98 | End PP. 99 | 100 | 101 | Section Instantiation_func_extract. 102 | 103 | Definition empty_store_record : store_record := {| 104 | s_funcs := nil; 105 | s_tables := nil; 106 | s_mems := nil; 107 | s_globals := nil; 108 | s_elems := nil; 109 | s_datas := nil; 110 | |}. 111 | 112 | (* Provide a unit host state and convert the starting expression to administrative *) 113 | Definition interp_instantiate_wrapper (s: store_record) (m : module) (v_imps: list extern_value) : option config_tuple * string := 114 | match interp_instantiate tt s m v_imps with 115 | | (Some (hs', s', f, bes), str) => (Some (s', (f, to_e_list bes)), str) 116 | | (None, str) => (None, str) 117 | end. 118 | 119 | Definition string_of_name (n: name) : string := 120 | string_of_list_byte n. 121 | 122 | Definition get_import_path (m: module) : list (string * string) := 123 | map (fun imp => (string_of_name (imp_module imp), string_of_name (imp_name imp))) m.(mod_imports). 124 | 125 | Definition get_exports (f: frame) : list (string * extern_value) := 126 | map (fun exp_inst => (string_of_name (exportinst_name exp_inst), exportinst_val exp_inst)) f.(f_inst).(inst_exports). 127 | 128 | (* Provide the instruction for invoking an external function under a given store *) 129 | Definition invoke_extern (s: store_record) (ext: extern_value) (args: list value) : option (list administrative_instruction) := 130 | match ext with 131 | | EV_func fi => 132 | match lookup_N s.(s_funcs) fi with 133 | | Some (FC_func_native (Tf ts1 ts2) _ _) => 134 | if (those (map (typeof_value s) args) == Some ts1) then 135 | Some (v_to_e_list args ++ [::AI_invoke fi])%list 136 | else None 137 | | _ => None 138 | end 139 | | _ => None 140 | end. 141 | 142 | Definition wasm_global_get (s: store_record) (ext: extern_value) : option value := 143 | match ext with 144 | | EV_global gi => 145 | match lookup_N s.(s_globals) gi with 146 | | Some gv => Some gv.(g_val) 147 | | None => None 148 | end 149 | | _ => None 150 | end. 151 | 152 | End Instantiation_func_extract. 153 | 154 | Section Wast. 155 | 156 | Definition is_canonical_nan (t: number_type) (v: value) : bool := 157 | match t, v with 158 | | Tnum_f32, VAL_num (VAL_float32 c) => Wasm_float.float_is_canonical f32m c 159 | | Tnum_f64, VAL_num (VAL_float64 c) => Wasm_float.float_is_canonical f64m c 160 | | _, _ => false 161 | end. 162 | 163 | Definition is_arithmetic_nan (t: number_type) (v: value) : bool := 164 | match t, v with 165 | | Tnum_f32, VAL_num (VAL_float32 c) => Wasm_float.float_is_arithmetic f32m c 166 | | Tnum_f64, VAL_num (VAL_float64 c) => Wasm_float.float_is_arithmetic f64m c 167 | | _, _ => false 168 | end. 169 | 170 | Definition is_funcref (v: value) : bool := 171 | match v with 172 | | VAL_ref (VAL_ref_func _) => true 173 | | _ => false 174 | end. 175 | 176 | Definition is_externref (v: value) : bool := 177 | match v with 178 | | VAL_ref (VAL_ref_extern _) => true 179 | | _ => false 180 | end. 181 | 182 | Definition v128_extract_lanes (sh: vshape) (v: v128) := 183 | v128_extract_lanes sh SX_S v. 184 | 185 | End Wast. 186 | 187 | End Extraction_instance. 188 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # wasm_coq 2 | A WebAssembly (aka Wasm) formalisation in Coq(Rocq), based on the [official specification](https://webassembly.github.io/spec/core/). 3 | 4 | (C) M. Bodin, P. Gardner, J. Pichon, C. Watt, X. Rao 2019-2025 - see LICENSE.txt 5 | 6 | The quotes from the WebAssembly standard (starting with `std-doc`) are (C) their respective authors. 7 | The files located in `src/Parray` are adapted from the Rocq kernel and therefore licensed under GNU LPGL 2.1 - see `src/Parray/LICENSE.LGPL`. 8 | 9 | The current project formalises Wasm version 2.0 with the following additions: 10 | - [+] Subtyping systems (from the future funcref/GC extension proposals); 11 | - [+] Tail-call. 12 | 13 | SIMD execution is implemented via the corresponding evaluation functions in the reference implementations. The Rocq mechanisation uses opauqe opcodes (from the binary format) for parsing the SIMD instructions and handling their execution. 14 | 15 | A large part of the old Wasm 1.0 formalisation has been published at [FM'21](https://link.springer.com/chapter/10.1007/978-3-030-90870-6_4), with many additions to the repository since then. 16 | 17 | # Components of the Repository 18 | 19 | ## In Publication 20 | 21 | - [x] Core definitions of WasmCert-Coq and WasmRef-Coq. 22 | - [x] Soundness results for WasmRef-Coq (interpreter) with respect to WasmCert-Coq. 23 | - [x] Type safety results for Wasm typing system. 24 | - [x] Soundness and completeness results for the type checker with respect to the typing system. 25 | - [x] Implementing Wasm numerics (via CompCert numerics). 26 | - [x] Soundness results for module instantiation. 27 | - [x] Proof carrying interpreter deriving progress. 28 | - [x] Interpreter with optimised context representations. 29 | 30 | ## Merged 31 | - [x] Updates for Wasm 2.0 + subtyping systems + tail-call. 32 | - [x] Validate WasmRef-Coq (conformance tests). 33 | 34 | # Program Logic 35 | 36 | This repository contains a mechanised Wasm program logic using the Iris framework: [iris branch](https://github.com/WasmCert/WasmCert-Coq/tree/iris-wasm-opam). 37 | 38 | This is migrated from an older build for the [artefact](https://zenodo.org/records/7808708) submitted along with the Iris-Wasm publication at [PLDI'23](https://dl.acm.org/doi/10.1145/3591265). 39 | 40 | A more updated version working with `opam` can be found [here](https://github.com/logsem/iriswasm). 41 | 42 | # Binary Parser (experimental) 43 | This repository contains some experimental work on a parser for the binary format which is currently unverified. 44 | As the parser forms a part of the extracted interpreter, any error in the parser would result in the interpreter reporting `syntax error` for some valid Wasm binaries. Bug reports are appreciated! 45 | 46 | # Usage 47 | 48 | ## Installation and Compilation 49 | 50 | The project can be installed using opam. 51 | 52 | Compiling the dependencies and codebase requires having at least 8 GB of RAM on your computer. 53 | ```bash 54 | opam repo add coq-released https://coq.inria.fr/opam/released 55 | opam install . 56 | ``` 57 | 58 | ## Testing and Conformance 59 | 60 | The project comes with a small set of tests for the extracted interpreter. To run these tests: 61 | ```bash 62 | dune test 63 | ``` 64 | 65 | The project also includes the official test suite as a submodule under `wast_testsuite`. To run the interpreter against the test suite, first pull the test suite submodule: 66 | ```bash 67 | git submodule update --init --recursive 68 | ``` 69 | 70 | Then, run: 71 | ```bash 72 | make run_wast 73 | ``` 74 | The interpreter is expected to pass all the other core tests (last tested on 11th Dec 2025): 75 | ```bash 76 | Total passed: 54004/54004 (100.00%) 77 | ``` 78 | 79 | Running the test suite takes around 2-3 minutes. 80 | 81 | It is also possible to run a selected subset of the test by filtering the file names. For example, 82 | ```bash 83 | make run_wast FILTER="simd" 84 | ``` 85 | runs only the SIMD tests, while 86 | ```bash 87 | make run_wast FILTER="load" 88 | ``` 89 | runs only the test files whose names include `load` (i.e. various memory load instructions both for the Wasm 1.0 values and the v128 values). 90 | 91 | Note that tail-call is not part of the standard yet and is therefore not tested. 92 | 93 | 94 | ## Using the project 95 | 96 | A file `wasm_coq_interpreter` will have been generated under `_build/install`. 97 | It takes as argument a list of Wasm files, followed by a function name to run (with the `-r` flag). 98 | For instance, to interpret the function `main` defined in [tests/add.wasm](tests/add.wasm), run: 99 | ```bash 100 | dune exec -- wasm_coq_interpreter tests/add.wasm -r main 101 | ``` 102 | 103 | The project has experimental support on passing arguments to function calls in the CLI via the `-a` flag. For example: 104 | ```bash 105 | dune exec -- wasm_coq_interpreter tests/add2.wasm -r main -a "i32.const 6" -a "i32.const 36" 106 | ``` 107 | would produce 108 | ```bash 109 | i32.const 42 110 | ``` 111 | 112 | Modules in text format can be run with the `--text` flag. For example: 113 | ```bash 114 | dune exec -- wasm_coq_interpreter tests/add2.wat -r main -a "i32.const 6" -a "i32.const 36" --text 115 | ``` 116 | would produce 117 | ```bash 118 | i32.const 42 119 | ``` 120 | 121 | 122 | The interpreter can also display intermediate states of the operational semantics: 123 | ```bash 124 | dune exec -- wasm_coq_interpreter tests/add.wasm -r main --vi 125 | ``` 126 | would produce: 127 | ```bash 128 | parsing OK 129 | instantiation OK 130 | 131 | Post-instantiation stage for table and memory initialisers... 132 | step 1: 133 | (empty) 134 | 135 | step 2: 136 | Value: 137 | (empty) 138 | success after 2 steps 139 | 140 | Instantiation success 141 | interpreting OK 142 | step 0: 143 | 144 | Executing configuration: 145 | frame 0 146 | with values (empty) 147 | invoke 0 148 | end frame 149 | 150 | step 1: 151 | frame 0 152 | with values (empty) 153 | frame 1 154 | with values (empty) 155 | label 1 156 | label_cont 157 | i32.const 40 158 | i32.const 2 159 | i32.add 160 | end label 161 | end frame 162 | end frame 163 | 164 | step 2: 165 | frame 0 166 | with values (empty) 167 | frame 1 168 | with values (empty) 169 | label 1 170 | label_cont 171 | i32.const 42 172 | end label 173 | end frame 174 | end frame 175 | 176 | step 3: 177 | frame 0 178 | with values (empty) 179 | frame 1 180 | with values (empty) 181 | i32.const 42 182 | end frame 183 | end frame 184 | 185 | step 4: 186 | frame 0 187 | with values (empty) 188 | i32.const 42 189 | end frame 190 | 191 | step 5: 192 | Value: 193 | i32.const 42 194 | 195 | success after 5 steps 196 | ``` 197 | -------------------------------------------------------------------------------- /src/shim.ml: -------------------------------------------------------------------------------- 1 | module type Host = sig 2 | 3 | (** The type of host functions. *) 4 | type host_function 5 | 6 | (** Equality of host functions. *) 7 | val host_function_eq_dec : host_function -> host_function -> bool 8 | 9 | (** The monad of host events. *) 10 | type 'a host_event 11 | val host_ret : 'a -> 'a host_event 12 | val host_bind : 'a host_event -> ('a -> 'b host_event) -> 'b host_event 13 | 14 | (** Application of a host function in the host monad. *) 15 | val host_apply : 16 | Extract.store_record -> Extract.function_type -> host_function -> Extract.value0 list -> 17 | (Extract.store_record * Extract.result) option host_event 18 | 19 | (** Printing a host function. *) 20 | val show_host_function : host_function -> string 21 | end 22 | 23 | module Extraction_instance = struct 24 | include Extract.Extraction_instance 25 | let show_host_function _ = assert false 26 | end 27 | 28 | module type InterpreterType = sig 29 | 30 | module Host : Host 31 | include module type of Host 32 | 33 | val ( >>= ) : 'a host_event -> ('a -> 'b host_event) -> 'b host_event 34 | val ( let* ) : 'a host_event -> ('a -> 'b host_event) -> 'b host_event 35 | val ( let+ ) : 'a host_event -> ('a -> 'b) -> 'b host_event 36 | val ( and+ ) : 'a host_event -> 'b host_event -> ('a * 'b) host_event 37 | val pure : 'a -> 'a host_event 38 | 39 | type store_record = Extract.Extraction_instance.store_record 40 | type frame = Extract.frame 41 | type wasm_config_tuple = Extract.config_tuple 42 | type interp_config_tuple = Extract.Extraction_instance.cfg_tuple_ctx 43 | type res_tuple = Extract.Extraction_instance.run_step_ctx_result 44 | type basic_instruction = Extract.basic_instruction 45 | type administrative_instruction = Extract.administrative_instruction 46 | type moduleinst = Extract.moduleinst 47 | type value = Extract.value0 48 | type externval = Extract.extern_value 49 | 50 | val empty_store_record : store_record 51 | 52 | (** Run one step of the interpreter. *) 53 | val run_one_step : 54 | interp_config_tuple -> int -> res_tuple 55 | 56 | val run_v_init : 57 | store_record -> administrative_instruction list -> interp_config_tuple option 58 | 59 | val interp_cfg_of_wasm : 60 | wasm_config_tuple -> interp_config_tuple 61 | 62 | val wasm_global_get : 63 | store_record -> externval -> value option 64 | 65 | (** Look-up a specific extracted function of the instantiation and invoke with the provided arguments. *) 66 | val invoke_extern : 67 | store_record -> externval -> value list -> (administrative_instruction list) option 68 | 69 | (** Perform the instantiation of a module. *) 70 | val interp_instantiate_wrapper : 71 | store_record -> Extract.module0 -> externval list -> wasm_config_tuple option * string 72 | 73 | val get_import_path: Extract.module0 -> (string * string) list 74 | val get_exports : frame -> (string * externval) list 75 | 76 | val run_parse_module_str : string -> Extract.module0 option 77 | val run_parse_arg : string -> value option 78 | 79 | val pp_values : value list -> string 80 | val pp_store : int -> Dune__exe__Extract.Extraction_instance.store_record -> string 81 | val pp_cfg_tuple_ctx_except_store : 82 | interp_config_tuple -> string 83 | 84 | val pp_res_cfg_except_store : 85 | interp_config_tuple -> res_tuple -> string 86 | val pp_es : Extract.administrative_instruction list -> string 87 | 88 | val pp_externval: externval -> string 89 | 90 | val is_canonical_nan: Extract.number_type -> value -> bool 91 | 92 | val is_arithmetic_nan: Extract.number_type -> value -> bool 93 | 94 | val v128_extract_lanes: Extract.vshape -> Extract.SIMD.v128 -> Extract.value_num list 95 | 96 | end 97 | 98 | module Interpreter = 99 | functor (EH : Host) -> struct 100 | 101 | 102 | module Host = EH 103 | include Host 104 | 105 | let ( >>= ) = host_bind 106 | 107 | let ( let* ) = host_bind 108 | 109 | let pure = host_ret 110 | 111 | let ( let+ ) a f = 112 | let* a = a in 113 | pure (f a) 114 | 115 | let ( and+ ) a b = 116 | let* a = a in 117 | let* b = b in 118 | pure (a, b) 119 | 120 | type store_record = Extract.Extraction_instance.store_record 121 | type frame = Extract.frame 122 | type wasm_config_tuple = Extract.config_tuple 123 | type interp_config_tuple = Extract.Extraction_instance.cfg_tuple_ctx 124 | type res_tuple = Extract.Extraction_instance.run_step_ctx_result 125 | type basic_instruction = Extract.basic_instruction 126 | type administrative_instruction = Extract.administrative_instruction 127 | type moduleinst = Extract.moduleinst 128 | type value = Extract.value0 129 | type externval = Extract.extern_value 130 | 131 | let empty_store_record = Extraction_instance.empty_store_record 132 | 133 | (** Run one step of the interpreter. *) 134 | let run_one_step cfg d = 135 | Extraction_instance.run_one_step cfg (Utils.z_of_int d) 136 | 137 | let run_v_init = Extraction_instance.run_v_init 138 | 139 | let interp_cfg_of_wasm = Extraction_instance.interp_cfg_of_wasm 140 | 141 | let wasm_global_get = 142 | Extraction_instance.wasm_global_get 143 | 144 | let invoke_extern = 145 | Extraction_instance.invoke_extern 146 | 147 | let interp_instantiate_wrapper s m extvals = 148 | let (res, msg) = Extraction_instance.interp_instantiate_wrapper s m extvals in 149 | (res, msg) 150 | 151 | let get_import_path m = 152 | Extraction_instance.get_import_path m 153 | 154 | let get_exports f = 155 | let exps = Extraction_instance.get_exports f in 156 | List.map (fun exp -> let (n, v) = exp in (n, v)) exps 157 | 158 | let run_parse_module_str m = Extract.run_parse_module_str m 159 | 160 | let run_parse_arg a = Extract.run_parse_arg a 161 | 162 | let pp_values l = 163 | Extraction_instance.pp_values l 164 | 165 | let pp_store i st = 166 | Extraction_instance.pp_store (Convert.to_nat i) st 167 | 168 | let pp_cfg_tuple_ctx_except_store r = 169 | Extraction_instance.pp_cfg_tuple_ctx_except_store r 170 | 171 | (* Depth doesn't matter for pretty printing cfg *) 172 | let pp_res_cfg_except_store cfg res = 173 | Extraction_instance.pp_res_cfg_except_store cfg (Utils.z_of_int 0) res 174 | 175 | let pp_es es = 176 | Extraction_instance.pp_administrative_instructions O es 177 | 178 | let pp_externval extval = 179 | Extraction_instance.pp_extern_value extval 180 | 181 | let is_canonical_nan = 182 | Extraction_instance.is_canonical_nan 183 | 184 | let is_arithmetic_nan = 185 | Extraction_instance.is_arithmetic_nan 186 | 187 | let v128_extract_lanes sh v = 188 | Extraction_instance.v128_extract_lanes sh v 189 | end 190 | -------------------------------------------------------------------------------- /theories/binary_format_tests.v: -------------------------------------------------------------------------------- 1 | (** Tests for the binary parser. **) 2 | Require Import Strings.Byte. 3 | From parseque Require Import Parseque. 4 | Require Import BinNat. 5 | From Wasm Require Import binary_format_parser binary_format_printer 6 | datatypes_properties check_toks. 7 | 8 | Open Scope string_scope. 9 | Import Coq.Strings.String.StringSyntax. 10 | Open Scope list_scope. 11 | 12 | Lemma test_unreachable : check_toks (x00 :: nil) parse_be = Running.Singleton BI_unreachable. 13 | Proof. vm_compute. reflexivity. Qed. 14 | 15 | Lemma test_nop : check_toks (x01 :: nil) parse_be = Running.Singleton BI_nop. 16 | Proof. vm_compute. reflexivity. Qed. 17 | 18 | (** An example program. **) 19 | Definition test := 20 | BI_if (BT_valtype None) (BI_testop T_i64 TO_eqz :: nil) (BI_testop T_i64 TO_eqz :: nil). 21 | 22 | (** Its byte representation. **) 23 | Definition test_bytes : list Byte.byte := 24 | x04 :: x40 25 | :: x50 26 | :: x05 27 | :: x50 28 | :: x0b 29 | :: x0b 30 | :: nil. 31 | 32 | (** It is possible to display lists of bytes in a nice way using the following command: 33 | [[ 34 | Compute hex_small_no_prefix_of_bytes test_bytes. 35 | ]] 36 | **) 37 | 38 | Lemma text_binary_correct : binary_of_expr (test :: nil) = test_bytes. 39 | Proof. vm_compute. reflexivity. Qed. 40 | 41 | Lemma text_parse_correct : run_parse_expr test_bytes = Some (test :: nil). 42 | Proof. vm_compute. reflexivity. Qed. 43 | 44 | (** It is possible to display programs in a nice way using the following command: 45 | [[ 46 | Compute option_map pp_basic_instructions (run_parse_expr test_bytes). 47 | ]] 48 | **) 49 | 50 | (** Example from Wikipedia: https://en.wikipedia.org/wiki/WebAssembly#Code_representation 51 | This is the representation of a factorial function. **) 52 | Definition test_wikipedia_byte : list Byte.byte := 53 | x20 :: x00 54 | :: x50 55 | :: x04 :: x7e 56 | :: x42 :: x01 57 | :: x05 58 | :: x20 :: x00 59 | :: x20 :: x00 60 | :: x42 :: x01 61 | :: x7d 62 | :: x10 :: x00 63 | :: x7e 64 | :: x0b 65 | :: nil. 66 | 67 | Definition test_wikipedia := 68 | (BI_local_get 0%N 69 | :: BI_testop T_i64 TO_eqz 70 | :: BI_if (BT_valtype (Some (T_num T_i64))) 71 | (BI_const_num (VAL_int64 Wasm_int.Int64.one) :: nil) 72 | (BI_local_get 0%N 73 | :: BI_local_get 0%N 74 | :: BI_const_num (VAL_int64 Wasm_int.Int64.one) 75 | :: BI_binop T_i64 (Binop_i BOI_sub) 76 | :: BI_call 0%N 77 | :: BI_binop T_i64 (Binop_i BOI_mul) :: nil) :: nil). 78 | 79 | Lemma test_wikipedia_correct : run_parse_bes test_wikipedia_byte = Some test_wikipedia. 80 | Proof. vm_compute. reflexivity. Qed. 81 | 82 | Definition empty_module := {| 83 | mod_types := nil; 84 | mod_funcs := nil; 85 | mod_tables := nil; 86 | mod_mems := nil; 87 | mod_globals := nil; 88 | mod_elems := nil; 89 | mod_datas := nil; 90 | mod_start := None; 91 | mod_imports := nil; 92 | mod_exports := nil; 93 | |}. 94 | 95 | Lemma empty_module_round_trip : run_parse_module (binary_of_module empty_module) = Some empty_module. 96 | Proof. vm_compute. reflexivity. Qed. 97 | 98 | Definition module_type := {| 99 | mod_types := cons (Tf nil (cons (T_num T_i32) nil)) nil; 100 | mod_funcs := nil; 101 | mod_tables := nil; 102 | mod_mems := nil; 103 | mod_globals := nil; 104 | mod_elems := nil; 105 | mod_datas := nil; 106 | mod_start := None; 107 | mod_imports := nil; 108 | mod_exports := nil; 109 | |}. 110 | 111 | Lemma module_type_round_trip : 112 | run_parse_module (binary_of_module module_type) = Some module_type. 113 | Proof. vm_compute. reflexivity. Qed. 114 | 115 | Definition module_type_fun := {| 116 | mod_types := cons (Tf nil (cons (T_num T_i32) nil)) nil; 117 | mod_funcs := 118 | cons {| modfunc_type := 0%N; modfunc_locals := nil; modfunc_body := nil |} nil; 119 | mod_tables := nil; 120 | mod_mems := nil; 121 | mod_globals := nil; 122 | mod_elems := nil; 123 | mod_datas := nil; 124 | mod_start := None; 125 | mod_imports := nil; 126 | mod_exports := nil; 127 | |}. 128 | 129 | Lemma module_type_fun_round_trip : 130 | run_parse_module (binary_of_module module_type_fun) = Some module_type_fun. 131 | Proof. vm_compute. reflexivity. Qed. 132 | 133 | Definition module_42 := {| 134 | mod_types := cons (Tf nil (cons (T_num T_i32) nil)) nil; 135 | mod_funcs := 136 | let e := BI_const_num (VAL_int32 (Wasm_int.Int32.repr (BinInt.Z.of_nat 42))) in 137 | cons {| modfunc_type := 0%N; modfunc_locals := nil; modfunc_body := cons e nil |} nil; 138 | mod_tables := nil; 139 | mod_mems := nil; 140 | mod_globals := nil; 141 | mod_elems := nil; 142 | mod_datas := nil; 143 | mod_start := None; 144 | mod_imports := nil; 145 | mod_exports := nil; 146 | |}. 147 | 148 | Lemma module_42_round_trip : 149 | run_parse_module (binary_of_module module_42) = Some module_42. 150 | Proof. vm_compute. reflexivity. Qed. 151 | 152 | Definition module_42_exported := {| 153 | mod_types := cons (Tf nil (cons (T_num T_i32) nil)) nil; 154 | mod_funcs := 155 | let e := BI_const_num (VAL_int32 (Wasm_int.Int32.repr (BinInt.Z.of_nat 42))) in 156 | cons {| modfunc_type := 0%N; modfunc_locals := nil; modfunc_body := cons e nil |} nil; 157 | mod_tables := nil; 158 | mod_mems := nil; 159 | mod_globals := nil; 160 | mod_elems := nil; 161 | mod_datas := nil; 162 | mod_start := None; 163 | mod_imports := nil; 164 | mod_exports := cons {| modexp_name := String.list_byte_of_string "hello"; modexp_desc := MED_func 0%N; |} nil; 165 | |}. 166 | 167 | Lemma module_42_exported_round_trip : 168 | run_parse_module (binary_of_module module_42_exported) = Some module_42_exported. 169 | Proof. vm_compute. reflexivity. Qed. 170 | 171 | Definition module_tableops := {| 172 | mod_types := cons (Tf nil (cons (T_num T_i32) nil)) nil; 173 | mod_funcs := 174 | let e := BI_const_num (VAL_int32 (Wasm_int.Int32.repr (BinInt.Z.of_nat 1))) in 175 | cons {| modfunc_type := 0%N; modfunc_locals := nil; modfunc_body := cons e nil |} nil; 176 | mod_tables := (cons (Build_module_table (Build_table_type (Build_limits 0%N (Some 4%N)) T_funcref)) nil); 177 | mod_mems := nil; 178 | mod_globals := nil; 179 | mod_elems := (cons (Build_module_element T_funcref (cons (cons (BI_const_num (VAL_int32 (Wasm_int.Int32.repr (BinInt.Z.of_nat 1)))) nil) nil) (ME_active 0%N (cons (BI_const_num (VAL_int32 (Wasm_int.Int32.repr (BinInt.Z.of_nat 1)))) nil))) nil); 180 | mod_datas := nil; 181 | mod_start := None; 182 | mod_imports := nil; 183 | mod_exports := cons {| modexp_name := String.list_byte_of_string "hello"; modexp_desc := MED_func 0%N; |} nil; 184 | |}. 185 | 186 | Lemma module_tableops_exported_round_trip : 187 | run_parse_module (binary_of_module module_tableops) = Some module_tableops. 188 | Proof. vm_compute. reflexivity. Qed. 189 | -------------------------------------------------------------------------------- /theories/memory_list.v: -------------------------------------------------------------------------------- 1 | (** an implementation of Wasm memory based on a list *) 2 | 3 | From mathcomp Require Import ssreflect ssrbool eqtype seq ssrnat. 4 | From Coq Require Import BinNums ZArith NArith Lia. 5 | From Wasm Require Import numerics bytes memory common. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Section MemoryList. 12 | 13 | Context `{def_byte: byte}. 14 | 15 | Record memory_list : Type := { 16 | ml_init : byte := def_byte; 17 | ml_data : list byte; 18 | }. 19 | 20 | Definition ml_make := 21 | fun len => 22 | let capped_len := N.min len byte_limit in 23 | {| ml_data := mkseq (fun _ => def_byte) (N.to_nat capped_len) |}. 24 | 25 | Definition ml_length := 26 | fun ml => N.of_nat (size ml.(ml_data)). 27 | 28 | Definition ml_grow := 29 | fun len_delta ml => 30 | let new_length := N.add len_delta (N.of_nat (length ml.(ml_data))) in 31 | if new_length <=? byte_limit then 32 | Some {| 33 | ml_data := ml.(ml_data) ++ mkseq (fun _ => ml.(ml_init)) (N.to_nat len_delta) 34 | |} 35 | else None. 36 | 37 | Definition ml_lookup := 38 | fun i ml => 39 | if N.ltb i (ml_length ml) then 40 | Some (seq.nth ml.(ml_init) ml.(ml_data) (N.to_nat i)) 41 | else None. 42 | 43 | Definition ml_update := 44 | fun i v ml => 45 | if N.ltb i (ml_length ml) 46 | then Some {| ml_data := set_nth ml.(ml_init) ml.(ml_data) (N.to_nat i) v 47 | |} 48 | else None. 49 | 50 | Lemma ml_lookup_ib: 51 | forall mem i, 52 | (i < ml_length mem)%N -> 53 | ml_lookup i mem <> None. 54 | Proof. 55 | move => mem i => /=. 56 | rewrite /ml_length /ml_lookup. 57 | move => H. 58 | apply N.ltb_lt in H. 59 | by rewrite H. 60 | Qed. 61 | 62 | Lemma ml_lookup_oob: 63 | forall mem i, 64 | (i >= ml_length mem)%N -> 65 | ml_lookup i mem = None. 66 | Proof. 67 | move => mem i => /=. 68 | rewrite /ml_length /ml_lookup. 69 | move => H. 70 | apply N.ge_le in H; move/N.leb_spec0 in H. 71 | rewrite N.leb_antisym in H. 72 | move/negPf in H. 73 | by rewrite H. 74 | Qed. 75 | 76 | Lemma ml_make_length: 77 | forall len, 78 | ml_length (ml_make len) = N.min len byte_limit. 79 | Proof. 80 | move => len => /=. 81 | unfold ml_length, ml_make. 82 | rewrite size_mkseq. 83 | by rewrite N2Nat.id. 84 | Qed. 85 | 86 | Lemma ml_make_lookup: 87 | forall i len, 88 | (i < N.min len byte_limit)%N -> 89 | ml_lookup i (ml_make len) = Some def_byte. 90 | Proof. 91 | move => i len Hlen /=. 92 | unfold ml_lookup. 93 | erewrite ml_make_length; eauto. 94 | move/N.ltb_spec0 in Hlen; rewrite Hlen => /=. 95 | rewrite nth_mkseq => //. 96 | by lias. 97 | Qed. 98 | 99 | Lemma ml_update_length : 100 | forall mem mem' i b, 101 | ml_update i b mem = Some mem' -> 102 | ml_length mem' = ml_length mem. 103 | Proof. 104 | move => mem mem' i b Hupdate. 105 | unfold ml_update in Hupdate. 106 | remove_bools_options. 107 | unfold ml_length in * => /=. 108 | rewrite size_set_nth. 109 | f_equal. 110 | apply/ssrnat.maxn_idPr. 111 | by lias. 112 | Qed. 113 | 114 | Lemma Nat2N_inj_le: forall n m, 115 | n <= m -> 116 | (N.of_nat n <= N.of_nat m)%N. 117 | Proof. 118 | by lias. 119 | Qed. 120 | 121 | Lemma ml_update_lookup : 122 | forall mem mem' i b, 123 | ml_update i b mem = Some mem' -> 124 | ml_lookup i mem' = Some b. 125 | Proof. 126 | move => mem mem' i b Hupdate. 127 | unfold ml_lookup. 128 | erewrite ml_update_length; eauto. 129 | unfold ml_update in *. 130 | remove_bools_options => /=. 131 | by rewrite nth_set_nth /= eq_refl. 132 | Qed. 133 | 134 | Lemma ml_update_lookup_ne: 135 | forall mem mem' i j b, 136 | i <> j -> 137 | ml_update j b mem = Some mem' -> 138 | ml_lookup i mem' = ml_lookup i mem. 139 | Proof. 140 | move => mem mem' i j b Hneq Hupdate. 141 | unfold ml_lookup. 142 | erewrite ml_update_length; eauto. 143 | unfold ml_update in *. 144 | remove_bools_options => /=. 145 | destruct (i //. 146 | f_equal. 147 | rewrite nth_set_nth => /=. 148 | replace ((N.to_nat i) == (N.to_nat j)) with false => //. 149 | by lias. 150 | Qed. 151 | 152 | Lemma ml_grow_length : 153 | forall n mem mem', 154 | ml_grow n mem = Some mem' -> 155 | ml_length mem' = (ml_length mem + n)%N. 156 | Proof. 157 | move => n mem mem' Hgrow. 158 | unfold ml_grow in Hgrow; subst. 159 | unfold ml_length. 160 | remove_bools_options => /=. 161 | move/Nat.leb_spec0 in Hif. 162 | rewrite size_cat size_mkseq. 163 | by lias. 164 | Qed. 165 | 166 | Lemma ml_update_ib: 167 | forall mem i b, 168 | (i < ml_length mem)%N -> 169 | ml_update i b mem <> None. 170 | Proof. 171 | move => mem i b => /=. 172 | rewrite /ml_length /ml_update. 173 | move => H. 174 | apply N.ltb_lt in H. 175 | by rewrite H. 176 | Qed. 177 | 178 | Lemma ml_update_oob: 179 | forall mem i b, 180 | (i >= ml_length mem)%N -> 181 | ml_update i b mem = None. 182 | Proof. 183 | move => mem i b => /=. 184 | rewrite /ml_length /ml_update. 185 | move => H. 186 | apply N.ge_le in H; move/N.leb_spec0 in H. 187 | rewrite N.leb_antisym in H. 188 | move/negPf in H. 189 | by rewrite H. 190 | Qed. 191 | 192 | Lemma ml_grow_lookup : 193 | forall i n mem mem', 194 | (i < ml_length mem)%N -> 195 | ml_grow n mem = Some mem' -> 196 | ml_lookup i mem' = ml_lookup i mem. 197 | Proof. 198 | move => i n mem mem' Hlen Hgrow. 199 | unfold ml_lookup. 200 | move/N.ltb_spec0 in Hlen. 201 | rewrite Hlen. 202 | erewrite ml_grow_length; eauto. 203 | replace (i 214 | ml_grow n mem = Some mem' -> 215 | ml_length mem = len -> 216 | ml_lookup (len + i) mem' = Some mem.(ml_init). 217 | Proof. 218 | move => n len mem mem' i Hlt Hgrow Hlen. 219 | unfold ml_grow in Hgrow; remove_bools_options. 220 | unfold ml_lookup, ml_length => /=. 221 | rewrite size_cat Nat2N.inj_add size_mkseq N2Nat.id. 222 | replace (_ 13 | Byte.of_bits (b7, (b6, (b5, (b4, (b3, (b2, (b1, false))))))) 14 | | _ => (* should never happen *) x00 15 | end. 16 | 17 | Definition rebalance (bytes_produced : list byte) (bits_produced : list bool) (the_bit : bool) : 18 | ((list byte) * (list bool)) := 19 | if Nat.eqb (List.length bits_produced) 6 then (cons (byte_of_7_bits (cons the_bit bits_produced)) bytes_produced, nil) 20 | else (bytes_produced, cons the_bit bits_produced). 21 | 22 | Fixpoint binary_of_aux2 (acc1 : list byte) (acc2 : list bool (* MSB at head *)) (n : positive) : list byte := 23 | (* using lists is very inefficient *) 24 | match n with 25 | | xH => 26 | let (acc1', acc2') := rebalance acc1 acc2 true in 27 | let acc2'' := List.app (List.repeat false (6 - List.length acc2)) acc2' in 28 | cons (byte_of_7_bits acc2'') acc1' 29 | | xI n' => 30 | let (acc1', acc2') := rebalance acc1 acc2 true in 31 | binary_of_aux2 acc1' acc2' n' 32 | | xO n' => 33 | let (acc1', acc2') := rebalance acc1 acc2 false in 34 | binary_of_aux2 acc1' acc2' n' 35 | end. 36 | 37 | Definition incr_mod (len: nat) (pad: nat) : nat := 38 | if Nat.eqb (S len) pad then 0 else (S len). 39 | 40 | (* Convert pos to bits, MSB at head *) 41 | Fixpoint bits_of_pos_pad (acc: list bool) (len: nat) (pad: nat) (n: positive) : list bool := 42 | match n with 43 | | xH => 44 | List.app (List.repeat false (pad - 1 - len)) (cons true acc) 45 | | xI n' => 46 | bits_of_pos_pad (cons true acc) (incr_mod len pad) pad n' 47 | | xO n' => 48 | bits_of_pos_pad (cons false acc) (incr_mod len pad) pad n' 49 | end. 50 | 51 | (* Evaluate two's complement LEB128 encoding. Need LSB at head *) 52 | Fixpoint complement_of_one_two_aux (zeros: nat) (bs: list bool) : list bool := 53 | match bs with 54 | | nil => List.repeat false zeros 55 | | cons true bs' => List.app (List.repeat false zeros) (cons true (List.map negb bs')) 56 | | cons false bs' => complement_of_one_two_aux (S zeros) bs' 57 | end. 58 | 59 | (* MSB at head *) 60 | Definition complement_of_one_two (bs: list bool) : list bool := 61 | List.rev (complement_of_one_two_aux 0 (List.rev bs)). 62 | 63 | Fixpoint bytes_of_bits (bs: list bool): list byte := 64 | match bs with 65 | | cons b1 (cons b2 (cons b3 (cons b4 (cons b5 (cons b6 (cons b7 bs')))))) => 66 | cons (Byte.of_bits (b7, (b6, (b5, (b4, (b3, (b2, (b1, false)))))))) (bytes_of_bits bs') 67 | | _ => (* should never happen *) nil 68 | end. 69 | 70 | Definition make_msb_one (b : byte) : byte := 71 | let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, _))))))) := Byte.to_bits b in 72 | Byte.of_bits (b1, (b2, (b3, (b4, (b5, (b6, (b7, true))))))). 73 | 74 | Definition make_msb_zero (b : byte) : byte := 75 | let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, _))))))) := Byte.to_bits b in 76 | Byte.of_bits (b1, (b2, (b3, (b4, (b5, (b6, (b7, false))))))). 77 | 78 | Definition make_msb_of_non_first_byte_one (bs : list byte) : list byte := 79 | match bs with 80 | | nil => nil 81 | | cons b bs' => cons b (List.map make_msb_one bs') 82 | end. 83 | 84 | (** LSB at head of list *) 85 | Definition encode_unsigned_aux (n : N) : list byte := 86 | match n with 87 | | N0 => cons x00 nil 88 | | Npos n' => make_msb_of_non_first_byte_one (binary_of_aux2 nil nil n') 89 | end. 90 | 91 | Definition encode_unsigned (n : N) : list byte := 92 | List.rev (encode_unsigned_aux n). 93 | 94 | Definition encode_signed_aux (z : Z) : list byte := 95 | match z with 96 | | Z0 => cons x00 nil 97 | | Zpos n' => make_msb_of_non_first_byte_one (binary_of_aux2 nil nil n') 98 | | Zneg n' => make_msb_of_non_first_byte_one 99 | (bytes_of_bits 100 | (complement_of_one_two 101 | (bits_of_pos_pad nil 0 7 n'))) 102 | end. 103 | 104 | Definition encode_signed (z : Z) : list byte := 105 | List.rev (encode_signed_aux z). 106 | 107 | Section Language. 108 | 109 | Context 110 | {Toks : nat -> Type} `{Sized Toks byte} 111 | {M : Type -> Type} `{RawMonad M} `{RawAlternative M}. 112 | 113 | Definition byte_parser A n := Parser Toks byte M A n. 114 | 115 | Definition byte_as_N {n} : byte_parser N n := 116 | Coq.Strings.Byte.to_N <$> anyTok. 117 | 118 | (* parse a final byte *) 119 | Definition parse_unsigned_end {n} : byte_parser N n := 120 | guardM 121 | (fun b => 122 | let '(_, (_, (_, (_, (_, (_, (_, msb))))))) := Byte.to_bits b in 123 | if msb then None else Some (Coq.Strings.Byte.to_N b)) 124 | anyTok. 125 | 126 | (* parse a non-final byte *) 127 | Definition parse_unsigned_ctd {n} : byte_parser N n := 128 | guardM 129 | (fun b => 130 | let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, msb))))))) := Byte.to_bits b in 131 | if msb then Some (Coq.Strings.Byte.to_N (make_msb_zero b)) 132 | else None) 133 | anyTok. 134 | 135 | Section Unsigned_sec. 136 | 137 | Record Unsigned (n : nat) : Type := MkUnsigned 138 | { _unsigned : byte_parser N n; 139 | }. 140 | 141 | Arguments MkUnsigned {_}. 142 | 143 | Context 144 | {Tok : Type} {A B : Type} {n : nat}. 145 | 146 | Definition parse_unsigned_aux : [ Unsigned ] := Fix Unsigned (fun _ rec => 147 | let aux := Induction.map _unsigned _ rec in 148 | let unsigned_ := 149 | parse_unsigned_end <|> 150 | (((fun lsb rest => BinNatDef.N.add lsb (BinNatDef.N.mul 128%N rest)) <$> parse_unsigned_ctd) <*> aux) in 151 | MkUnsigned unsigned_). 152 | 153 | (** top-level function *) 154 | Definition parse_unsigned : [ byte_parser N ] := 155 | fun n => _unsigned n (parse_unsigned_aux n). 156 | 157 | End Unsigned_sec. 158 | 159 | Definition sub_2_7 (k : N) := 160 | BinIntDef.Z.sub (BinInt.Z_of_N k) (BinIntDef.Z.pow (BinInt.Z.of_nat 2) (BinInt.Z.of_nat 7)). 161 | 162 | (* parse a non-final byte *) 163 | Definition parse_signed_end {n} : byte_parser Z n := 164 | guardM 165 | (fun b => 166 | let '(_, (_, (_, (_, (_, (_, (b7, b8))))))) := Byte.to_bits b in 167 | if b8 then None 168 | else if b7 then Some (sub_2_7 (Coq.Strings.Byte.to_N b)) 169 | else Some (ZArith.BinInt.Z_of_N (Coq.Strings.Byte.to_N b))) 170 | anyTok. 171 | 172 | (* parse a final byte *) 173 | Definition parse_signed_ctd {n} : byte_parser Z n := 174 | guardM 175 | (fun b => 176 | let '(_, (_, (_, (_, (_, (_, (_, msb))))))) := Byte.to_bits b in 177 | if msb then Some (sub_2_7 (Coq.Strings.Byte.to_N b)) 178 | else None) 179 | anyTok. 180 | 181 | Section Signed_sec. 182 | 183 | Record Signed (n : nat) : Type := MkSigned 184 | { _signed : byte_parser Z n; 185 | }. 186 | 187 | Arguments MkUnsigned {_}. 188 | 189 | Context 190 | {Tok : Type} {A B : Type} {n : nat}. 191 | 192 | Definition signed_aux : [ Signed ] := Fix Signed (fun _ rec => 193 | let aux := Induction.map _signed _ rec in 194 | let signed_ := 195 | parse_signed_end <|> 196 | (((fun lsb rest => ZArith.BinInt.Zplus lsb (ZArith.BinInt.Zmult 128%Z rest)) <$> parse_signed_ctd) <*> aux) in 197 | MkSigned _ signed_). 198 | 199 | Definition parse_signed : [ byte_parser Z ] := fun n => _signed n (signed_aux n). 200 | 201 | End Signed_sec. 202 | 203 | End Language. 204 | -------------------------------------------------------------------------------- /src/execute.ml: -------------------------------------------------------------------------------- 1 | open Output 2 | 3 | module Host = struct 4 | 5 | (* We build on top of this host, wrapping it inside the type [out]. *) 6 | module Host = Shim.Extraction_instance 7 | 8 | type host_function = Host.host_function 9 | let host_function_eq_dec = Host.host_function_eq_dec 10 | 11 | type 'a host_event = 'a out Host.host_event 12 | let host_ret v = Host.host_ret (OK v) 13 | let host_bind v cont = 14 | Host.host_bind v (function 15 | | OK v -> cont v 16 | | Error msg -> Host.host_ret (Error msg)) 17 | 18 | let host_apply st t h vs = 19 | Host.host_bind (Host.host_apply st t h vs) (fun r -> host_ret r) 20 | 21 | let show_host_function = Host.show_host_function 22 | 23 | let error msg = Host.host_ret (Error msg) 24 | 25 | let pmatch ok error v = 26 | Host.host_bind v (function 27 | | OK v -> host_ret (ok v) 28 | | Error msg -> host_ret (error msg)) 29 | 30 | let from_out = function 31 | | OK v -> host_ret v 32 | | Error msg -> error msg 33 | 34 | exception ToOut of string 35 | 36 | let to_out v = 37 | (* FIXME: This is not the nicest code ever. *) 38 | try OK (pmatch (fun x -> x) (fun msg -> raise (ToOut msg)) v) 39 | with ToOut msg -> Error msg 40 | 41 | end 42 | 43 | module Interpreter = Shim.Interpreter (Host) 44 | 45 | (** An alias of [Host] to be able to retrieve it later. *) 46 | module TopHost = Host 47 | 48 | open Interpreter 49 | 50 | type eval_cfg_result = 51 | | Cfg_res of store_record * frame * value list 52 | | Cfg_trap of store_record * frame 53 | | Cfg_err 54 | | Cfg_exhaustion 55 | 56 | let rec eval_interp_cfg verbosity gen max_call_depth cfg d = 57 | let print_step_header gen = 58 | debug_info verbosity intermediate ~style:bold 59 | (fun () -> Printf.sprintf "step %d:\n" gen) in 60 | let cfg_res = run_one_step cfg d in 61 | print_step_header gen; 62 | debug_info verbosity intermediate 63 | (fun _ -> pp_res_cfg_except_store cfg cfg_res); 64 | match cfg_res with 65 | | RSC_normal (_hs', cfg', d') -> 66 | let d_int = Utils.int_of_z d' in 67 | if (d_int > max_call_depth) && (max_call_depth != (-1)) then begin 68 | debug_info verbosity stage ~style:red (fun _ -> "Call stack exhaustion\n"); 69 | Cfg_exhaustion 70 | end 71 | else 72 | eval_interp_cfg verbosity (gen+1) max_call_depth cfg' d_int 73 | | RSC_value (s, f, vs) -> 74 | debug_info verbosity stage ~style:green (fun _ -> "success after " ^ string_of_int gen ^ " steps\n"); 75 | (Cfg_res (s, f, vs)) 76 | | RSC_trap (s, f) -> 77 | debug_info verbosity stage ~style:red (fun _ -> "trap after " ^ string_of_int gen ^ " steps\n"); 78 | Cfg_trap (s, f) 79 | | RSC_invalid -> 80 | debug_info verbosity stage ~style:red (fun _ -> "Invalid cfg\n"); 81 | Cfg_err 82 | | RSC_error -> 83 | debug_info verbosity stage ~style:red (fun _ -> "Ill-typed input\n"); 84 | Cfg_err 85 | 86 | let eval_wasm_cfg verbosity max_call_depth cfg = 87 | let interp_cfg_inst = interp_cfg_of_wasm cfg in 88 | debug_info verbosity intermediate (fun _ -> 89 | Printf.sprintf "\nExecuting configuration:\n%s\n" (pp_cfg_tuple_ctx_except_store interp_cfg_inst)); 90 | eval_interp_cfg verbosity 1 max_call_depth interp_cfg_inst 0 91 | 92 | 93 | module StringMap = Map.Make(String);; 94 | 95 | type host_extern_store = ((Interpreter.externval StringMap.t) StringMap.t) * (string StringMap.t) 96 | 97 | let global_get hs s modname extname = 98 | let (exts, _) = hs in 99 | match StringMap.find_opt modname exts with 100 | | Some mmap -> 101 | begin match StringMap.find_opt extname mmap with 102 | | Some extval -> 103 | begin match wasm_global_get s extval with 104 | | Some v -> pure v 105 | | None -> TopHost.error "Specified extern value is not a global" 106 | end 107 | | None -> TopHost.error "Extern value not found" 108 | end 109 | | None -> TopHost.error "Module not found" 110 | 111 | let invoke_func verbosity hs sf args modname name max_call_depth = 112 | let (exts, _) = hs in 113 | let (s, f) = sf in 114 | let* es_init = 115 | TopHost.from_out ( 116 | ovpending verbosity stage "interpreting" (fun _ -> 117 | begin match StringMap.find_opt modname exts with 118 | | Some mmap -> 119 | begin match StringMap.find_opt name mmap with 120 | | Some extval -> 121 | begin match invoke_extern s extval args with 122 | | None -> Error ("Unknown function `" ^ name ^ "`, or invalid argument types") 123 | | Some es_init -> OK es_init 124 | end 125 | | None -> Error "The specified function does not exist" 126 | end 127 | | None -> Error "The specified module does not exist" 128 | end 129 | )) in 130 | let cfg_init = (s, (f, es_init)) in 131 | pure (eval_wasm_cfg verbosity max_call_depth cfg_init) 132 | 133 | let print_invoke_result verbosity res = 134 | debug_info verbosity result (fun _ -> 135 | match res with 136 | | Cfg_res (_, _, vs) -> pp_values vs 137 | | Cfg_trap (_, _) -> "Execution returned a trap; run the interpreter in detailed mode (--vi) for more information\n" 138 | | Cfg_err -> "Execution returned an error; run the interpreter in detailed mode (--vi) for more information\n" 139 | | Cfg_exhaustion -> "Fuel exhaustion\n" 140 | ) 141 | 142 | let instantiate_imps verbosity s m imps = 143 | let* wasm_cfg = 144 | TopHost.from_out ( 145 | ovpending verbosity stage "instantiation" (fun _ -> 146 | match interp_instantiate_wrapper s m imps with 147 | | (None, errmsg) -> Error ("instantiation error: " ^ errmsg) 148 | | (Some cfg, _) -> OK cfg)) in 149 | (* No max stack limit for instantiation -- doesn't matter anyway due to initalisers being const exprs *) 150 | pure (eval_wasm_cfg verbosity (-1) wasm_cfg) 151 | 152 | let get_ext_import hs path = 153 | let (m, imp_name) = path in 154 | let (exts, _) = hs in 155 | match StringMap.find_opt m exts with 156 | | Some imps_map -> 157 | StringMap.find_opt imp_name imps_map 158 | | None -> None 159 | 160 | let instantiate verbosity hs s m = 161 | let import_paths = get_import_path m in 162 | let oext_vals = List.map (get_ext_import hs) import_paths in 163 | let ext_vals = List.filter_map (fun x -> x) oext_vals in 164 | if List.length oext_vals = List.length ext_vals then 165 | let* inst_res = instantiate_imps verbosity s m ext_vals in 166 | pure inst_res 167 | else 168 | TopHost.error "invalid module imports" 169 | 170 | let instantiate_host verbosity hs s module_name m = 171 | let* inst_res = instantiate verbosity hs s m in 172 | (* Add the exported instances to the host store. *) 173 | match inst_res with 174 | | Cfg_res (s', f, _vs) -> 175 | let exps = get_exports f in 176 | let exps_str = List.map 177 | (fun exp -> 178 | match exp with 179 | | (exp_name, exp_val) -> exp_name ^ " at " ^ pp_externval exp_val ^ ";") exps in 180 | let exps_map = StringMap.of_seq (List.to_seq exps) in 181 | let (exts, modvarmaps) = hs in 182 | let exts' = StringMap.add module_name exps_map exts in 183 | let hs' = (exts', modvarmaps) in 184 | debug_info verbosity stage (fun _ -> "Adding the following exports to module " ^ module_name ^ " : " ^ (String.concat "" exps_str) ^ "\n"); 185 | pure (hs', s', inst_res) 186 | (* Trap should be counted as an instantiation error eventually, but any store modification needs to persist -- from linking.wast *) 187 | | Cfg_trap (s', _f) -> 188 | pure (hs, s', inst_res) 189 | | Cfg_err -> TopHost.error "invalid module instantiation" 190 | | Cfg_exhaustion -> TopHost.error "instantiation resulted in exhaustion" 191 | 192 | let rec instantiate_modules verbosity hs s names modules = 193 | match (names, modules) with 194 | | ([], _) -> pure (hs, s) 195 | | (name :: names', m :: modules') -> 196 | debug_info verbosity stage (fun () -> "Processing module: " ^ name ^ "\n"); 197 | let* (hs', s', _inst_res) = instantiate_host verbosity hs s name m in 198 | instantiate_modules verbosity hs' s' names' modules' 199 | | _ -> TopHost.error "Invalid module name parsing results" 200 | -------------------------------------------------------------------------------- /src/SIMD_ops.ml: -------------------------------------------------------------------------------- 1 | (* Invoke the reference eval functions corresponding to the binary encodings (from parsing). *) 2 | 3 | open Wasm.V128 4 | 5 | let app_vunop_str op v = 6 | let vw = of_bits v in 7 | let wasm_f = 8 | match Utils.int_of_z op with 9 | | 77 -> V1x128.lognot 10 | | 96 -> I8x16.abs 11 | | 97 -> I8x16.neg 12 | | 98 -> I8x16.popcnt 13 | | 103 -> F32x4.ceil 14 | | 104 -> F32x4.floor 15 | | 105 -> F32x4.trunc 16 | | 106 -> F32x4.nearest 17 | 18 | | 116 -> F64x2.ceil 19 | | 117 -> F64x2.floor 20 | | 122 -> F64x2.trunc 21 | 22 | | 124 -> I16x8_convert.extadd_pairwise_s 23 | | 125 -> I16x8_convert.extadd_pairwise_u 24 | 25 | | 126 -> I32x4_convert.extadd_pairwise_s 26 | | 127 -> I32x4_convert.extadd_pairwise_u 27 | 28 | | 128 -> I16x8.abs 29 | | 129 -> I16x8.neg 30 | | 135 -> I16x8_convert.extend_low_s 31 | | 136 -> I16x8_convert.extend_high_s 32 | | 137 -> I16x8_convert.extend_low_u 33 | | 138 -> I16x8_convert.extend_high_u 34 | 35 | | 148 -> F64x2.nearest 36 | 37 | | 160 -> I32x4.abs 38 | | 161 -> I32x4.neg 39 | | 167 -> I32x4_convert.extend_low_s 40 | | 168 -> I32x4_convert.extend_high_s 41 | | 169 -> I32x4_convert.extend_low_u 42 | | 170 -> I32x4_convert.extend_high_u 43 | 44 | | 192 -> I64x2.abs 45 | | 193 -> I64x2.neg 46 | | 199 -> I64x2_convert.extend_low_s 47 | | 200 -> I64x2_convert.extend_high_s 48 | | 201 -> I64x2_convert.extend_low_u 49 | | 202 -> I64x2_convert.extend_high_u 50 | 51 | | 224 -> F32x4.abs 52 | | 225 -> F32x4.neg 53 | | 227 -> F32x4.sqrt 54 | 55 | | 236 -> F64x2.abs 56 | | 237 -> F64x2.neg 57 | | 239 -> F64x2.sqrt 58 | 59 | | 248 -> I32x4_convert.trunc_sat_f32x4_s 60 | | 249 -> I32x4_convert.trunc_sat_f32x4_u 61 | | 250 -> F32x4_convert.convert_i32x4_s 62 | | 251 -> F32x4_convert.convert_i32x4_u 63 | | 252 -> I32x4_convert.trunc_sat_f64x2_s_zero 64 | | 253 -> I32x4_convert.trunc_sat_f64x2_u_zero 65 | | 254 -> F64x2_convert.convert_i32x4_s (* low missing from the op name *) 66 | | 255 -> F64x2_convert.convert_i32x4_u (* low missing from the op name *) 67 | | 94 -> F32x4_convert.demote_f64x2_zero 68 | | 95 -> F64x2_convert.promote_low_f32x4 69 | | _ -> assert false 70 | in 71 | to_bits (wasm_f vw) 72 | 73 | let app_vbinop_str op_args v1 v2 = 74 | let (op, args) = op_args in 75 | let v1w = of_bits v1 in 76 | let v2w = of_bits v2 in 77 | let iop = Utils.int_of_z op in 78 | let iargs = List.map Utils.int_of_z args in 79 | if iop = 13 then (* shuffle *) 80 | to_bits (V8x16.shuffle v1w v2w iargs) 81 | else 82 | let wasm_f = 83 | match iop with 84 | | 14 -> V8x16.swizzle 85 | | 35 -> I8x16.eq 86 | | 36 -> I8x16.ne 87 | | 37 -> I8x16.lt_s 88 | | 38 -> I8x16.lt_u 89 | | 39 -> I8x16.gt_s 90 | | 40 -> I8x16.gt_u 91 | | 41 -> I8x16.le_s 92 | | 42 -> I8x16.le_u 93 | | 43 -> I8x16.ge_s 94 | | 44 -> I8x16.ge_u 95 | | 45 -> I16x8.eq 96 | | 46 -> I16x8.ne 97 | | 47 -> I16x8.lt_s 98 | | 48 -> I16x8.lt_u 99 | | 49 -> I16x8.gt_s 100 | | 50 -> I16x8.gt_u 101 | | 51 -> I16x8.le_s 102 | | 52 -> I16x8.le_u 103 | | 53 -> I16x8.ge_s 104 | | 54 -> I16x8.ge_u 105 | | 55 -> I32x4.eq 106 | | 56 -> I32x4.ne 107 | | 57 -> I32x4.lt_s 108 | | 58 -> I32x4.lt_u 109 | | 59 -> I32x4.gt_s 110 | | 60 -> I32x4.gt_u 111 | | 61 -> I32x4.le_s 112 | | 62 -> I32x4.le_u 113 | | 63 -> I32x4.ge_s 114 | | 64 -> I32x4.ge_u 115 | | 65 -> F32x4.eq 116 | | 66 -> F32x4.ne 117 | | 67 -> F32x4.lt 118 | | 68 -> F32x4.gt 119 | | 69 -> F32x4.le 120 | | 70 -> F32x4.ge 121 | | 71 -> F64x2.eq 122 | | 72 -> F64x2.ne 123 | | 73 -> F64x2.lt 124 | | 74 -> F64x2.gt 125 | | 75 -> F64x2.le 126 | | 76 -> F64x2.ge 127 | | 78 -> V1x128.and_ 128 | | 79 -> V1x128.andnot 129 | | 80 -> V1x128.or_ 130 | | 81 -> V1x128.xor 131 | | 101 -> I8x16_convert.narrow_s 132 | | 102 -> I8x16_convert.narrow_u 133 | | 110 -> I8x16.add 134 | | 111 -> I8x16.add_sat_s 135 | | 112 -> I8x16.add_sat_u 136 | | 113 -> I8x16.sub 137 | | 114 -> I8x16.sub_sat_s 138 | | 115 -> I8x16.sub_sat_u 139 | | 118 -> I8x16.min_s 140 | | 119 -> I8x16.min_u 141 | | 120 -> I8x16.max_s 142 | | 121 -> I8x16.max_u 143 | | 123 -> I8x16.avgr_u 144 | | 130 -> I16x8.q15mulr_sat_s 145 | | 133 -> I16x8_convert.narrow_s 146 | | 134 -> I16x8_convert.narrow_u 147 | | 142 -> I16x8.add 148 | | 143 -> I16x8.add_sat_s 149 | | 144 -> I16x8.add_sat_u 150 | | 145 -> I16x8.sub 151 | | 146 -> I16x8.sub_sat_s 152 | | 147 -> I16x8.sub_sat_u 153 | | 149 -> I16x8.mul 154 | | 150 -> I16x8.min_s 155 | | 151 -> I16x8.min_u 156 | | 152 -> I16x8.max_s 157 | | 153 -> I16x8.max_u 158 | | 155 -> I16x8.avgr_u 159 | | 156 -> I16x8_convert.extmul_low_s 160 | | 157 -> I16x8_convert.extmul_high_s 161 | | 158 -> I16x8_convert.extmul_low_u 162 | | 159 -> I16x8_convert.extmul_high_u 163 | | 174 -> I32x4.add 164 | | 177 -> I32x4.sub 165 | | 181 -> I32x4.mul 166 | | 182 -> I32x4.min_s 167 | | 183 -> I32x4.min_u 168 | | 184 -> I32x4.max_s 169 | | 185 -> I32x4.max_u 170 | | 186 -> I32x4_convert.dot_s 171 | | 188 -> I32x4_convert.extmul_low_s 172 | | 189 -> I32x4_convert.extmul_high_s 173 | | 190 -> I32x4_convert.extmul_low_u 174 | | 191 -> I32x4_convert.extmul_high_u 175 | 176 | | 206 -> I64x2.add 177 | | 209 -> I64x2.sub 178 | | 213 -> I64x2.mul 179 | 180 | | 214 -> I64x2.eq 181 | | 215 -> I64x2.ne 182 | | 216 -> I64x2.lt_s 183 | | 217 -> I64x2.gt_s 184 | | 218 -> I64x2.le_s 185 | | 219 -> I64x2.ge_s 186 | 187 | | 220 -> I64x2_convert.extmul_low_s 188 | | 221 -> I64x2_convert.extmul_high_s 189 | | 222 -> I64x2_convert.extmul_low_u 190 | | 223 -> I64x2_convert.extmul_high_u 191 | 192 | | 228 -> F32x4.add 193 | | 229 -> F32x4.sub 194 | | 230 -> F32x4.mul 195 | | 231 -> F32x4.div 196 | | 232 -> F32x4.min 197 | | 233 -> F32x4.max 198 | | 234 -> F32x4.pmin 199 | | 235 -> F32x4.pmax 200 | 201 | | 240 -> F64x2.add 202 | | 241 -> F64x2.sub 203 | | 242 -> F64x2.mul 204 | | 243 -> F64x2.div 205 | | 244 -> F64x2.min 206 | | 245 -> F64x2.max 207 | | 246 -> F64x2.pmin 208 | | 247 -> F64x2.pmax 209 | 210 | | _ -> assert false 211 | in 212 | to_bits (wasm_f v1w v2w) 213 | 214 | let app_vternop_str op v1 v2 v3 = 215 | let v1w = of_bits v1 in 216 | let v2w = of_bits v2 in 217 | let v3w = of_bits v3 in 218 | let wasm_f = 219 | match Utils.int_of_z op with 220 | | 82 -> V1x128.bitselect 221 | | _ -> assert false 222 | in 223 | to_bits (wasm_f v1w v2w v3w) 224 | 225 | let encode_bool b = 226 | if b then "\x01" else "\x00" 227 | 228 | let decode_int32 s = 229 | if String.length s < 4 then invalid_arg "int32_of_le_string: need at least 4 bytes"; 230 | let b0 = Char.code s.[0] in 231 | let b1 = Char.code s.[1] in 232 | let b2 = Char.code s.[2] in 233 | let b3 = Char.code s.[3] in 234 | let open Int32 in 235 | logor (of_int b0) 236 | (logor (shift_left (of_int b1) 8) 237 | (logor (shift_left (of_int b2) 16) 238 | (shift_left (of_int b3) 24))) 239 | 240 | let encode_int32 x = 241 | let open Int32 in 242 | String.init 4 (function 243 | | 0 -> Char.chr (to_int (logand x 0xFFl)) 244 | | 1 -> Char.chr (to_int (logand (shift_right x 8) 0xFFl)) 245 | | 2 -> Char.chr (to_int (logand (shift_right x 16) 0xFFl)) 246 | | 3 -> Char.chr (to_int (logand (shift_right x 24) 0xFFl)) 247 | | _ -> assert false) 248 | 249 | let app_vtestop_str op v1 = 250 | let v1w = of_bits v1 in 251 | let op_i = Utils.int_of_z op in 252 | match op_i with 253 | | 83 -> encode_bool (I8x16.any_true v1w) 254 | 255 | | 99 -> encode_bool (I8x16.all_true v1w) 256 | | 131 -> encode_bool (I16x8.all_true v1w) 257 | | 163 -> encode_bool (I32x4.all_true v1w) 258 | | 195 -> encode_bool (I64x2.all_true v1w) 259 | 260 | | 100 -> encode_int32 (I8x16.bitmask v1w) 261 | | 132 -> encode_int32 (I16x8.bitmask v1w) 262 | | 164 -> encode_int32 (I32x4.bitmask v1w) 263 | | 196 -> encode_int32 (I64x2.bitmask v1w) 264 | 265 | | _ -> assert false 266 | 267 | let app_vshiftop_str op v1 v2 = 268 | let v1w = of_bits v1 in 269 | let v2w = decode_int32 v2 in 270 | let wasm_f = 271 | match Utils.int_of_z op with 272 | | 107 -> I8x16.shl 273 | | 108 -> I8x16.shr_s 274 | | 109 -> I8x16.shr_u 275 | 276 | | 139 -> I16x8.shl 277 | | 140 -> I16x8.shr_s 278 | | 141 -> I16x8.shr_u 279 | 280 | | 171 -> I32x4.shl 281 | | 172 -> I32x4.shr_s 282 | | 173 -> I32x4.shr_u 283 | 284 | | 203 -> I64x2.shl 285 | | 204 -> I64x2.shr_s 286 | | 205 -> I64x2.shr_u 287 | 288 | | _ -> assert false 289 | in 290 | to_bits (wasm_f v1w v2w) -------------------------------------------------------------------------------- /src/Parray/Parray.ml: -------------------------------------------------------------------------------- 1 | (************************************************************************) 2 | (* * The Rocq Prover / The Rocq Development Team *) 3 | (* v * Copyright INRIA, CNRS and contributors *) 4 | (* int -> 'a 24 | val unsafe_set : 'a t -> int -> 'a -> unit 25 | val length : 'a t -> int 26 | val make : int -> 'a -> 'a t 27 | val copy : 'a t -> 'a t 28 | val of_array : 'a array -> 'a t 29 | val to_array : 'a t -> 'a array 30 | (* 'a should not be float (no Obj.double_tag) *) 31 | val unsafe_of_obj : Obj.t -> 'a t 32 | end = 33 | struct 34 | type 'a t = Obj.t array 35 | (** Guaranteed to be a non-flat array and no funny business with write 36 | barriers because of the opacity of Obj.t. *) 37 | 38 | let empty = [||] 39 | 40 | let length (v : 'a t) = Array.length v 41 | 42 | let of_array v = 43 | if (Obj.tag (Obj.repr v) == Obj.double_array_tag) then begin 44 | let n = Array.length v in 45 | (* Ensure that we initialize it with a non-float *) 46 | let ans = Array.make n (Obj.repr ()) in 47 | for i = 0 to n - 1 do 48 | Array.unsafe_set ans i (Obj.repr (Array.unsafe_get v i)) 49 | done; 50 | ans 51 | end else 52 | (Obj.magic (Array.copy v)) 53 | 54 | let obj_is_float x = Obj.tag x == Obj.double_tag 55 | 56 | let to_array (type a) (v : a t) : a array = 57 | let () = assert (not (Array.exists obj_is_float v)) in 58 | Obj.magic (Array.copy v) 59 | 60 | let unsafe_of_obj (type a) (v : Obj.t) = 61 | let () = assert (Obj.tag v == 0) in 62 | (Obj.obj v : a t) 63 | 64 | let unsafe_get = Obj.magic Array.unsafe_get 65 | let unsafe_set = Obj.magic Array.unsafe_set 66 | 67 | let make (type a) n (x : a) : a t = 68 | (* Ensure that we initialize it with a non-float *) 69 | let ans = Array.make n (Obj.repr ()) in 70 | let () = Array.fill ans 0 n (Obj.repr x) in 71 | ans 72 | 73 | let copy = Array.copy 74 | 75 | end 76 | 77 | (* Changed to max_int to allow for Wasm's memory limit. This needs 64-bit OCaml to work *) 78 | let max_array_length = max_int 79 | 80 | let max_length = max_array_length 81 | 82 | let to_int i = i 83 | 84 | let trunc_size n = 85 | if 0<=n && n < max_array_length then 86 | to_int n 87 | else max_array_length 88 | 89 | let uarray_get_range a i len = 90 | let res = Array.make len (UArray.unsafe_get a i) in 91 | for j = 1 to len - 1 do 92 | Array.unsafe_set res j (UArray.unsafe_get a (i + j)) 93 | done; 94 | res 95 | 96 | let uarray_set_range a i block = 97 | let len = Array.length block in 98 | for j = 0 to len - 1 do 99 | UArray.unsafe_set a (i + j) (Array.unsafe_get block j) 100 | done 101 | 102 | (* -------------------------------------------------- *) 103 | 104 | type 'a t = ('a kind) ref 105 | and 'a kind = 106 | | Array of 'a UArray.t * 'a 107 | | Updated of int * 'a * 'a t 108 | | BlockUpdated of int * 'a array * 'a t 109 | 110 | let unsafe_of_obj t def = ref (Array (UArray.unsafe_of_obj t, def)) 111 | let of_array t def = ref (Array (UArray.of_array t, def)) 112 | 113 | let rec rerootk t k = 114 | match !t with 115 | | Array (a, _) -> k a 116 | | Updated (i, v, p) -> 117 | let k' a = 118 | let v' = UArray.unsafe_get a i in 119 | UArray.unsafe_set a i v; 120 | t := !p; (* i.e., Array (a, def) *) 121 | p := Updated (i, v', t); 122 | k a in 123 | rerootk p k' 124 | | BlockUpdated (i, old_vals, p) -> 125 | let k' a = 126 | let len = Array.length old_vals in 127 | let v' = uarray_get_range a i len in 128 | uarray_set_range a i old_vals; 129 | t := !p; 130 | p := BlockUpdated (i, v', t); 131 | k a in 132 | rerootk p k' 133 | 134 | let reroot t = rerootk t (fun a -> a) 135 | 136 | let length_int p = 137 | UArray.length (reroot p) 138 | 139 | let length p = length_int p 140 | 141 | let get p n = 142 | let t = reroot p in 143 | let l = UArray.length t in 144 | if 0 <= n && n < l then 145 | UArray.unsafe_get t (to_int n) 146 | else 147 | match !p with 148 | | Array (_, def) -> def 149 | | Updated _ -> assert false 150 | | BlockUpdated _ -> assert false 151 | 152 | let set p n e = 153 | let a = reroot p in 154 | let l = (UArray.length a) in 155 | if 0 <= n && n < l then 156 | let i = to_int n in 157 | let v' = UArray.unsafe_get a i in 158 | UArray.unsafe_set a i e; 159 | let t = ref !p in (* i.e., Array (a, def) *) 160 | p := Updated (i, v', t); 161 | t 162 | else p 163 | 164 | (* --- new function for block set by a generator --- *) 165 | 166 | let set_gen p start_pos block_len generator = 167 | let a = reroot p in 168 | let i = to_int start_pos in 169 | let len = to_int block_len in 170 | let total_len = UArray.length a in 171 | (* Check bounds and block size *) 172 | if 0 <= start_pos && (start_pos + block_len) <= (total_len) then 173 | let old_vals = uarray_get_range a i len in 174 | for j = 0 to len - 1 do 175 | let new_val = generator (j) in 176 | UArray.unsafe_set a (i + j) new_val 177 | done; 178 | let t = ref !p in 179 | p := BlockUpdated (i, old_vals, t); 180 | t 181 | else p 182 | (* ------------------------------ *) 183 | 184 | let default p = 185 | let _ = reroot p in 186 | match !p with 187 | | Array (_,def) -> def 188 | | Updated _ -> assert false 189 | | BlockUpdated _ -> assert false 190 | 191 | let make_int n def = 192 | ref (Array (UArray.make n def, def)) 193 | 194 | let make n def = make_int (trunc_size n) def 195 | 196 | (* An addition to the kernel Parray extraction that initialises with another array acting as an initialiser *) 197 | let make_copy n init arr initlen = 198 | if initlen <= (length arr) then 199 | let trunc_n = trunc_size n in 200 | if (length arr) <= (trunc_n) then 201 | let marr = UArray.make trunc_n init in 202 | let initlen_int = to_int initlen in 203 | for i = 0 to initlen_int - 1 do 204 | UArray.unsafe_set marr i (get arr (i)) 205 | done; 206 | ref (Array (marr, init)) 207 | else assert false 208 | else assert false 209 | 210 | let uinit n f = 211 | if Int.equal n 0 then UArray.empty 212 | else begin 213 | let t = UArray.make n (f 0) in 214 | for i = 1 to n - 1 do 215 | UArray.unsafe_set t i (f i) 216 | done; 217 | t 218 | end 219 | 220 | let init n f def = 221 | let n = trunc_size n in 222 | let t = uinit n f in 223 | ref (Array (t, def)) 224 | 225 | let to_array p = 226 | let _ = reroot p in 227 | match !p with 228 | | Array (t,def) -> UArray.to_array t, def 229 | | Updated _ -> assert false 230 | | BlockUpdated _ -> assert false 231 | 232 | let copy p = 233 | let _ = reroot p in 234 | match !p with 235 | | Array (t, def) -> ref (Array (UArray.copy t, def)) 236 | | Updated _ -> assert false 237 | | BlockUpdated _ -> assert false 238 | 239 | (* Higher order combinators: the callback may update the underlying 240 | array requiring a reroot between each call. To avoid doing n 241 | reroots (-> O(n^2)), we copy if we have to reroot again. *) 242 | 243 | let is_rooted p = match !p with 244 | | Array _ -> true 245 | | Updated _ -> false 246 | | BlockUpdated _ -> false 247 | 248 | type 'a cache = { 249 | orig : 'a t; 250 | mutable self : 'a UArray.t; 251 | mutable rerooted_again : bool; 252 | } 253 | 254 | let make_cache p = { 255 | orig = p; 256 | self = reroot p; 257 | rerooted_again = false; 258 | } 259 | 260 | let uget_cache cache i = 261 | let () = if not cache.rerooted_again && not (is_rooted cache.orig) 262 | then begin 263 | cache.self <- UArray.copy (reroot cache.orig); 264 | cache.rerooted_again <- true 265 | end 266 | in 267 | UArray.unsafe_get cache.self i 268 | 269 | let map f p = 270 | let t = make_cache p in 271 | let len = UArray.length t.self in 272 | let res = uinit len (fun i -> f (uget_cache t i)) in 273 | let def = f (default p) in 274 | ref (Array (res, def)) 275 | 276 | let fold_left f x p = 277 | let r = ref x in 278 | let t = make_cache p in 279 | let len = UArray.length t.self in 280 | for i = 0 to len - 1 do 281 | r := f !r (uget_cache t i) 282 | done; 283 | f !r (default p) 284 | 285 | let fold_left2 f a p1 p2 = 286 | let r = ref a in 287 | let t1 = make_cache p1 in 288 | let len = UArray.length t1.self in 289 | let t2 = make_cache p2 in 290 | if UArray.length t2.self <> len then invalid_arg "Parray.fold_left2"; 291 | for i = 0 to len - 1 do 292 | let v1 = uget_cache t1 i in 293 | let v2 = uget_cache t2 i in 294 | r := f !r v1 v2 295 | done; 296 | f !r (default p1) (default p2) 297 | 298 | -------------------------------------------------------------------------------- /theories/memory.v: -------------------------------------------------------------------------------- 1 | (** a typeclass for a Wasm mem interface and specification *) 2 | 3 | From Coq Require Import BinNat. 4 | From Wasm Require Import bytes common. 5 | From HB Require Import structures. 6 | From mathcomp Require Import ssreflect ssrbool eqtype. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Section Memory. 13 | 14 | (* Some constants regarding Wasm memory *) 15 | Definition page_size : N := 65536%N. 16 | 17 | Definition page_limit : N := 65536%N. 18 | 19 | Definition byte_limit : N := N.mul page_size page_limit. 20 | 21 | Definition wasm_memory_default_byte : byte := #00. 22 | 23 | Class Memory := { 24 | mem_t : Type; 25 | mem_make : N -> mem_t; (* Doesn't take an init, as Wasm forces it to zero *) 26 | mem_length : mem_t -> N; 27 | mem_lookup : N -> mem_t -> option byte; 28 | (* Doesn't have to succeed *) 29 | mem_grow : N -> mem_t -> option mem_t; 30 | mem_update : N -> byte -> mem_t -> option mem_t; 31 | 32 | mem_lookup_ib : 33 | forall mem i, 34 | N.lt i (mem_length mem) -> 35 | mem_lookup i mem <> None; 36 | 37 | mem_lookup_oob : 38 | forall mem i, 39 | N.ge i (mem_length mem) -> 40 | mem_lookup i mem = None; 41 | 42 | mem_make_length : 43 | forall len, 44 | mem_length (mem_make len) = N.min len byte_limit; 45 | 46 | mem_make_lookup : 47 | forall i len, 48 | N.lt i (N.min len byte_limit) -> 49 | mem_lookup i (mem_make len) = Some wasm_memory_default_byte; 50 | 51 | mem_update_lookup : 52 | forall mem mem' i b, 53 | mem_update i b mem = Some mem' -> 54 | mem_lookup i mem' = Some b; 55 | 56 | mem_update_lookup_ne : 57 | forall mem mem' i i' b, 58 | i <> i' -> 59 | mem_update i' b mem = Some mem' -> 60 | mem_lookup i mem' = mem_lookup i mem; 61 | 62 | mem_update_ib : 63 | forall mem i b, 64 | N.lt i (mem_length mem) -> 65 | mem_update i b mem <> None; 66 | 67 | mem_update_oob : 68 | forall mem i b, 69 | N.ge i (mem_length mem) -> 70 | mem_update i b mem = None; 71 | 72 | mem_grow_lookup : 73 | forall i n mem mem', 74 | N.lt i (mem_length mem) -> 75 | mem_grow n mem = Some mem' -> 76 | mem_lookup i mem' = mem_lookup i mem; 77 | 78 | mem_grow_length : 79 | forall n mem mem', 80 | mem_grow n mem = Some mem' -> 81 | mem_length mem' = N.add (mem_length mem) n; 82 | 83 | mem_grow_default: 84 | forall n len mem mem' i, 85 | N.lt i n -> 86 | mem_grow n mem = Some mem' -> 87 | mem_length mem = len -> 88 | mem_lookup (len + i) mem' = Some #00 89 | 90 | }. 91 | 92 | Context `{Memory}. 93 | 94 | Lemma mem_lookup_some_length: forall m i, 95 | mem_lookup i m <> None -> 96 | N.lt i (mem_length m). 97 | Proof. 98 | move => m i Hlookup. 99 | destruct (N.ltb i (mem_length m)) eqn:Hlt; first by lias. 100 | exfalso. 101 | move/N.ltb_spec0 in Hlt. 102 | by apply mem_lookup_oob in Hlt. 103 | Qed. 104 | 105 | Lemma mem_lookup_some_length': forall m i b, 106 | mem_lookup i m = Some b -> 107 | N.lt i (mem_length m). 108 | Proof. 109 | move => m i b Hlookup. 110 | apply mem_lookup_some_length. 111 | by rewrite Hlookup. 112 | Qed. 113 | 114 | Lemma mem_lookup_none_length: forall m i, 115 | mem_lookup i m = None -> 116 | N.ge i (mem_length m). 117 | Proof. 118 | move => m i Hlookup. 119 | destruct (N.ltb i (mem_length m)) eqn:Hlt; move/N.ltb_spec0 in Hlt; last done. 120 | by apply mem_lookup_ib in Hlt. 121 | Qed. 122 | 123 | Lemma mem_update_some_length: forall m i b, 124 | mem_update i b m <> None -> 125 | N.lt i (mem_length m). 126 | Proof. 127 | move => m i b Hupdate. 128 | destruct (N.ltb i (mem_length m)) eqn:Hlt; first by lias. 129 | exfalso. 130 | move/N.ltb_spec0 in Hlt. 131 | by apply mem_update_oob with (b := b) in Hlt. 132 | Qed. 133 | 134 | Lemma mem_update_some_length': forall m i b m', 135 | mem_update i b m = Some m' -> 136 | N.lt i (mem_length m). 137 | Proof. 138 | move => m i b m' Hupdate. 139 | by apply mem_update_some_length with (b := b); rewrite Hupdate. 140 | Qed. 141 | 142 | Lemma mem_update_none_length: forall m i b, 143 | mem_update i b m = None -> 144 | N.ge i (mem_length m). 145 | Proof. 146 | move => m i b Hlookup. 147 | destruct (N.ltb i (mem_length m)) eqn:Hlt; move/N.ltb_spec0 in Hlt; last done. 148 | by apply mem_update_ib with (b := b) in Hlt. 149 | Qed. 150 | 151 | Lemma mem_length_boundary : forall m i, 152 | mem_lookup i m <> None -> 153 | mem_lookup (N.succ i) m = None -> 154 | mem_length m = N.succ i. 155 | Proof. 156 | move => m i Hlookup1 Hlookup2. 157 | apply mem_lookup_some_length in Hlookup1. 158 | apply mem_lookup_none_length in Hlookup2. 159 | apply N.le_succ_l in Hlookup1. 160 | by lias. 161 | Qed. 162 | 163 | Lemma mem_length_extensional_aux: forall m m', 164 | (forall i, (mem_lookup i m == None) = (mem_lookup i m' == None)) -> 165 | ~ (mem_length m < mem_length m')%N. 166 | Proof. 167 | move => m m' Heq Hlt. 168 | specialize (Heq (mem_length m)). 169 | rewrite mem_lookup_oob in Heq; last by lias. 170 | rewrite eq_refl in Heq; symmetry in Heq; move/eqP in Heq. 171 | by specialize (mem_lookup_ib Hlt). 172 | Qed. 173 | 174 | Lemma mem_length_extensional : forall m m', 175 | (forall i, (mem_lookup i m == None) = (mem_lookup i m' == None)) -> 176 | mem_length m = mem_length m'. 177 | Proof. 178 | move => m m' Heq. 179 | specialize (mem_length_extensional_aux Heq) as Hbound1. 180 | assert (~ (mem_length m' < mem_length m)%N) as Hbound2. 181 | { apply mem_length_extensional_aux. 182 | by move => i; specialize (Heq i). 183 | } 184 | by lias. 185 | Qed. 186 | 187 | Lemma mem_update_length : forall i b mem mem', 188 | mem_update i b mem = Some mem' -> 189 | mem_length mem' = mem_length mem. 190 | Proof. 191 | move => i b mem mem' Hupdate. 192 | apply mem_length_extensional; move => j. 193 | destruct (mem_lookup j mem) eqn:Hlookup. 194 | - destruct (N.eqb i j) eqn:Hid; move/N.eqb_spec in Hid; subst. 195 | + apply mem_update_lookup in Hupdate. 196 | by rewrite Hupdate. 197 | + apply mem_update_lookup_ne with (i := j) in Hupdate; last by lias. 198 | by rewrite Hupdate Hlookup. 199 | - specialize (mem_lookup_none_length Hlookup) as Hbound1. 200 | specialize (mem_update_some_length' Hupdate) as Hbound2. 201 | assert (i <> j) as Hneq; first by lias. 202 | rewrite -> mem_update_lookup_ne with (mem := mem) (i := j) (i' := i) (b := b); by lias. 203 | Qed. 204 | 205 | End Memory. 206 | 207 | Section BlockUpdateMemory. 208 | 209 | Class BlockUpdateMemory := { 210 | m: Memory; 211 | mem_update_gen: N -> N -> (N -> byte) -> mem_t -> option mem_t; 212 | 213 | mem_update_gen_ib: 214 | forall n len gen m, 215 | N.le (N.add n len) (mem_length m) -> 216 | mem_update_gen n len gen m <> None; 217 | 218 | mem_update_gen_oob: 219 | forall n len gen m, 220 | N.gt (N.add n len) (mem_length m) -> 221 | mem_update_gen n len gen m = None; 222 | 223 | mem_update_gen_lookup: 224 | forall n len gen m m' i, 225 | mem_update_gen n len gen m = Some m' -> 226 | N.lt i len -> 227 | mem_lookup (N.add n i) m' = Some (gen i); 228 | 229 | mem_update_gen_lookup_lt: 230 | forall n len gen m m' i, 231 | mem_update_gen n len gen m = Some m' -> 232 | N.lt i n -> 233 | mem_lookup i m' = mem_lookup i m; 234 | 235 | mem_update_gen_lookup_ge: 236 | forall n len gen m m' i, 237 | mem_update_gen n len gen m = Some m' -> 238 | N.ge i (N.add n len) -> 239 | mem_lookup i m' = mem_lookup i m; 240 | }. 241 | 242 | #[global] 243 | Instance memory_from_bum `{bum: BlockUpdateMemory} : Memory := m. 244 | 245 | Hint Resolve memory_from_bum : typeclass_instances. 246 | 247 | Context `{BlockUpdateMemory}. 248 | 249 | Lemma mem_update_gen_some_length: forall n len gen m, 250 | mem_update_gen n len gen m <> None -> 251 | N.le (N.add n len) (mem_length m). 252 | Proof. 253 | move => n len gen m Hupdate. 254 | destruct (N.leb (N.add n len) (mem_length m)) eqn:Hle; move/N.leb_spec0 in Hle => //. 255 | exfalso. 256 | apply Hupdate, mem_update_gen_oob. 257 | by lias. 258 | Qed. 259 | 260 | Lemma mem_update_gen_some_length': forall n len gen m b, 261 | mem_update_gen n len gen m = Some b -> 262 | N.le (N.add n len) (mem_length m). 263 | Proof. 264 | move => n len gen m b Hupdate. 265 | apply mem_update_gen_some_length with (gen := gen); eauto. 266 | by rewrite Hupdate. 267 | Qed. 268 | 269 | Lemma mem_update_gen_lookup_ex: forall n len gen m m' i, 270 | mem_update_gen n len gen m = Some m' -> 271 | (mem_lookup i m == None) = (mem_lookup i m' == None). 272 | Proof. 273 | move => n len gen m m' i Hupdate. 274 | destruct (N.ltb i n) eqn:Hlt; move/N.ltb_spec0 in Hlt. 275 | - specialize (mem_update_gen_lookup_lt Hupdate Hlt) as Heq. 276 | by rewrite Heq. 277 | - destruct (N.ltb i (N.add n len)) eqn:Hlt2; move/N.ltb_spec0 in Hlt2. 278 | + assert (N.lt (N.sub i n) len) as Hlt3; first by lias. 279 | specialize (mem_update_gen_lookup Hupdate Hlt3) as Hlookupgen. 280 | replace (n+(i-n)%N)%N with i in Hlookupgen; last by lias. 281 | rewrite Hlookupgen. 282 | assert (mem_lookup i m <> None) as Hlookup. 283 | { apply mem_lookup_ib. 284 | apply mem_update_gen_some_length' in Hupdate. 285 | by lias. 286 | } 287 | by lias. 288 | + specialize (mem_update_gen_lookup_ge Hupdate Hlt2) as Heq. 289 | by rewrite Heq. 290 | Qed. 291 | 292 | Lemma mem_update_gen_length : forall n len gen m m', 293 | mem_update_gen n len gen m = Some m' -> 294 | mem_length m = mem_length m'. 295 | Proof. 296 | move => n len gen m m' Hupdate. 297 | apply mem_length_extensional. 298 | move => i. 299 | destruct (mem_lookup i m) eqn:Hlookup1; 300 | destruct (mem_lookup i m') eqn:Hlookup2 => //=; exfalso. 301 | - move/eqP in Hlookup2. 302 | erewrite <- mem_update_gen_lookup_ex in Hlookup2; eauto. 303 | by rewrite Hlookup1 in Hlookup2. 304 | - move/eqP in Hlookup1. 305 | erewrite -> mem_update_gen_lookup_ex in Hlookup1; eauto. 306 | by rewrite Hlookup2 in Hlookup1. 307 | Qed. 308 | 309 | End BlockUpdateMemory. 310 | -------------------------------------------------------------------------------- /theories/tactic.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq. 2 | From Wasm Require Import properties typing_inversion. 3 | 4 | Ltac size_unequal H := 5 | repeat rewrite length_is_size in H; 6 | revert H; 7 | repeat rewrite size_cat; repeat rewrite size_rev; repeat rewrite size_map; repeat rewrite size_drop; repeat rewrite size_take; simpl; lias. 8 | 9 | (** A common pattern in the proof: using an hypothesis on the form [rev l = l'] to rewrite [l]. **) 10 | Ltac subst_rev_const_list := 11 | repeat lazymatch goal with 12 | | HRevConst: rev ?lconst = ?h :: ?t |- _ => 13 | apply rev_move in HRevConst; rewrite HRevConst; rewrite -cat1s; rewrite rev_cat; 14 | rewrite -v_to_e_cat; rewrite -catA 15 | end. 16 | 17 | (** Simplify the lists in the goal. **) 18 | Ltac simplify_lists := 19 | (** Common rewriting rules. **) 20 | repeat first [ 21 | rewrite drop_rev 22 | | rewrite take_rev 23 | | rewrite revK 24 | | rewrite length_is_size 25 | | rewrite size_take 26 | | rewrite size_drop 27 | | rewrite size_rev 28 | | rewrite size_cat 29 | | rewrite v_to_e_size 30 | | rewrite rev_cat 31 | | rewrite rev_cons -cats1 32 | | rewrite -v_to_e_cat 33 | | rewrite -v_to_e_rev 34 | | rewrite -v_to_e_take 35 | | rewrite -v_to_e_drop]; 36 | (** Putting all the lists into a normal form, as concatenations of as many things. 37 | Because [cat1s] conflicts with [cats0], replacing any occurence of [[X]] to 38 | [[X] ++ [::]], it has to be done separately. 39 | Rewrite with the associated [math goal with] is avoid to deal with existential 40 | vairables. **) 41 | repeat match goal with 42 | |- context C [?x :: ?l] => 43 | lazymatch l with [::] => fail | _ => rewrite -(cat1s x l) end 44 | end; 45 | repeat lazymatch goal with 46 | | |- context C [[::] ++ _] => rewrite cat0s 47 | | |- context C [_ ++ [::]] => rewrite cats0 48 | | |- context C [_ + ?n - ?n] => rewrite addnK 49 | | |- context C [size (_ ++ _)] => rewrite size_cat 50 | | |- context C [take (size ?l) (?l ++ _)] => rewrite take_size_cat 51 | | |- context C [rcons _ _] => rewrite -cats1 52 | | |- context C [(_ ++ _) ++ _] => rewrite -catA 53 | | |- context C [rev [::]] => rewrite rev0 54 | | |- context C [v_to_e_list [::]] => simpl v_to_e_list at 1 55 | | |- context C [v_to_e_list [:: _]] => simpl v_to_e_list at 1 56 | end; 57 | try subst_rev_const_list. 58 | 59 | (** A common scheme in the progress proof, with a continuation. **) 60 | Ltac solve_progress_cont cont := 61 | repeat eexists; 62 | solve [ 63 | apply r_simple; solve [ eauto | constructor; eauto | cont; eauto ] 64 | | cont ]. 65 | 66 | (** The same, but without continuation. **) 67 | Ltac solve_progress := 68 | solve_progress_cont ltac:(fail). 69 | 70 | 71 | (* Looking up from instances, stores, and contexts *) 72 | Ltac inst_typing_lookup := 73 | try multimatch goal with 74 | | H1: inst_typing ?s ?i = Some ?t, 75 | H2: lookup_N (inst_types ?i) ?n = Some _ |- _ => 76 | let Hteq := fresh "Hteq" in 77 | specialize (Logic.eq_sym (inst_typing_type_lookup n H1)) as Hteq; 78 | rewrite H2 in Hteq 79 | | H1: inst_typing ?s ?i = Some ?t, 80 | H2: lookup_N (inst_funcs ?i) _ = Some _ |- _ => 81 | let ft := fresh "ft" in 82 | let Hextft := fresh "Hextft" in 83 | let Hnthft := fresh "Hnthft" in 84 | specialize (inst_typing_func_lookup H1 H2) as [ft [Hextft Hnthft]]; 85 | unfold ext_func_typing in Hextft 86 | | H1: inst_typing ?s ?i = Some ?t, 87 | H2: lookup_N (inst_tables ?i) _ = Some _ |- _ => 88 | let tabt := fresh "tabt" in 89 | let Hexttabt := fresh "Hexttabt" in 90 | let Hnthtabt := fresh "Hnthtabt" in 91 | specialize (inst_typing_table_lookup H1 H2) as [tabt [Hexttabt Hnthtabt]]; 92 | unfold ext_table_typing in Hexttabt 93 | | H1: inst_typing ?s ?i = Some ?t, 94 | H2: lookup_N (inst_mems ?i) _ = Some _ |- _ => 95 | let mt := fresh "mt" in 96 | let Hextmt := fresh "Hextmt" in 97 | let Hnthmt := fresh "Hnthmt" in 98 | specialize (inst_typing_mem_lookup H1 H2) as [mt [Hextmt Hnthmt]]; 99 | unfold ext_mem_typing in Hextmt 100 | | H1: inst_typing ?s ?i = Some ?t, 101 | H2: lookup_N (inst_globals ?i) _ = Some _ |- _ => 102 | let gt := fresh "gt" in 103 | let Hextgt := fresh "Hextgt" in 104 | let Hnthgt := fresh "Hnthgt" in 105 | specialize (inst_typing_global_lookup H1 H2) as [gt [Hextgt Hnthgt]]; 106 | unfold ext_global_typing in Hextgt 107 | | H1: inst_typing ?s ?i = Some ?t, 108 | H2: lookup_N (inst_elems ?i) _ = Some _ |- _ => 109 | let et := fresh "et" in 110 | let ei := fresh "ei" in 111 | let Hnthselem := fresh "Hnthselem" in 112 | let Helemtype := fresh "Helemtype" in 113 | let Hnthet := fresh "Hnthet" in 114 | specialize (inst_typing_elem_lookup H1 H2) as [et [ei [Hnthselem [Helemtype Hnthet]]]] 115 | | H1: inst_typing ?s ?i = Some ?t, 116 | H2: lookup_N (inst_datas ?i) _ = Some _ |- _ => 117 | let dt := fresh "et" in 118 | let di := fresh "di" in 119 | let Hnthsdata := fresh "Hnthsdata" in 120 | let Hdatatype := fresh "Hdatatype" in 121 | let Hnthdt := fresh "Hnthdt" in 122 | specialize (inst_typing_data_lookup H1 H2) as [dt [di [Hnthsdata [Hdatatype Hnthdt]]]] 123 | end. 124 | 125 | Ltac store_typing_lookup := 126 | try multimatch goal with 127 | | H1: store_typing ?s, 128 | H2: lookup_N (s_funcs ?s) _ = Some _ |- _ => 129 | let ft := fresh "ft" in 130 | let Hft := fresh "Hft" in 131 | specialize (store_typing_func_lookup H1 H2) as [ft Hft]; 132 | unfold funcinst_typing in Hft 133 | | H1: store_typing ?s, 134 | H2: lookup_N (s_tables ?s) _ = Some _ |- _ => 135 | let tabt := fresh "tabt" in 136 | let Htabt := fresh "Htabt" in 137 | specialize (store_typing_table_lookup H1 H2) as [tabt Htabt]; 138 | unfold tableinst_typing in Htabt 139 | | H1: store_typing ?s, 140 | H2: lookup_N (s_mems ?s) _ = Some _ |- _ => 141 | let mt := fresh "mt" in 142 | let Hmt := fresh "Hmt" in 143 | specialize (store_typing_mem_lookup H1 H2) as [mt Hmt]; 144 | unfold meminst_typing in Hmt 145 | | H1: store_typing ?s, 146 | H2: lookup_N (s_globals ?s) _ = Some _ |- _ => 147 | let gt := fresh "gt" in 148 | let Hgt := fresh "Hgt" in 149 | specialize (store_typing_global_lookup H1 H2) as [gt Hgt]; 150 | unfold globalinst_typing in Hgt 151 | | H1: store_typing ?s, 152 | H2: lookup_N (s_elems ?s) _ = Some _ |- _ => 153 | let et := fresh "et" in 154 | let Het := fresh "Het" in 155 | specialize (store_typing_elem_lookup H1 H2) as [et Het]; 156 | unfold eleminst_typing in Het 157 | | H1: store_typing ?s, 158 | H2: lookup_N (s_datas ?s) _ = Some _ |- _ => 159 | let dt := fresh "dt" in 160 | let Hdt := fresh "Hdt" in 161 | specialize (store_typing_data_lookup H1 H2) as [dt Hdt]; 162 | unfold datainst_typing in Hdt 163 | end. 164 | 165 | Ltac resolve_store_inst_lookup := 166 | store_typing_lookup; inst_typing_lookup. 167 | 168 | Ltac unfold_store_operations := 169 | repeat match goal with 170 | | _: context [ stab_update _ _ _ _ ] |- _ => 171 | unfold stab_update in *; remove_bools_options 172 | | _: context [ supdate_glob _ _ _ _ ] |- _ => 173 | unfold supdate_glob, supdate_glob_s, sglob_ind, option_bind, option_map in *; remove_bools_options 174 | | _: context [ sglob_val _ _ ] |- _ => 175 | unfold sglob_val, sglob, sglob_ind in *; remove_bools_options 176 | | _: context [ stab_elem _ _ ] |- _ => 177 | unfold stab_elem in *; remove_bools_options 178 | | _: context [ stab_grow _ _ ] |- _ => 179 | unfold stab_grow, growtable in *; remove_bools_options 180 | | _: context [ mem_grow _ _ ] |- _ => 181 | unfold mem_grow in *; remove_bools_options 182 | | _: context [ stab _ _ ] |- _ => 183 | unfold stab in *; remove_bools_options 184 | | _: context [ smem _ _ ] |- _ => 185 | unfold smem in *; remove_bools_options 186 | | _: context [ smem_store _ _ ] |- _ => 187 | unfold smem_store in *; remove_bools_options 188 | | _: context [ smem_store_packed _ _ ] |- _ => 189 | unfold smem_store_packed in *; remove_bools_options 190 | | _: context [ smem_store_vec _ _ ] |- _ => 191 | unfold smem_store_vec in *; remove_bools_options 192 | | _: context [ smem_store_vec_lane _ _ ] |- _ => 193 | unfold smem_store_vec_lane in *; remove_bools_options 194 | | _: context [ smem_grow _ _ ] |- _ => 195 | unfold smem_grow in *; remove_bools_options 196 | | _: context [ smem_ind _ _ ] |- _ => 197 | unfold smem_ind in *; remove_bools_options 198 | | _: context [ selem _ _ ] |- _ => 199 | unfold selem in *; remove_bools_options 200 | | _: context [ sdata _ _ ] |- _ => 201 | unfold sdata in *; remove_bools_options 202 | | _: context [ selem_drop _ _ _ ] |- _ => 203 | unfold selem_drop, selem in *; remove_bools_options 204 | | _: context [ sdata_drop _ _ _ ] |- _ => 205 | unfold sdata_drop, sdata in *; remove_bools_options 206 | end. 207 | 208 | Ltac resolve_if_true_eq := 209 | match goal with 210 | | |- match ?expr with 211 | | true => Some ?x 212 | | false => None 213 | end = Some ?x => 214 | let Htrue := fresh "Htrue" in 215 | assert (expr = true) as Htrue; last by rewrite Htrue 216 | | |- exists x, match ?expr with 217 | | true => _ 218 | | false => None 219 | end = Some x => 220 | let Htrue := fresh "Htrue" in 221 | assert (expr = true) as Htrue; last rewrite Htrue 222 | | |- match ?expr with 223 | | Some _ => _ 224 | | None => None 225 | end = Some ?x => 226 | let Hsome := fresh "Hsome" in 227 | let x := fresh "x" in 228 | assert (exists x, expr = Some x) as [x Hsome]; last rewrite Hsome 229 | | |- exists x, match ?expr with 230 | | Some _ => _ 231 | | None => None 232 | end = Some x => 233 | let Hsome := fresh "Hsome" in 234 | let y := fresh "y" in 235 | assert (exists y, expr = Some y) as [y Hsome]; last rewrite Hsome 236 | end. 237 | 238 | Ltac simplify_multieq := 239 | repeat match goal with 240 | | H1: ?expr = ?x, 241 | H2: ?expr = ?y |- _ => 242 | rewrite H1 in H2 243 | | H: Some ?x = Some ?y |- _ => 244 | let Hinj := fresh "Hinj" in 245 | injection H as Hinj; try subst 246 | end. 247 | 248 | Ltac resolve_e_typing := 249 | repeat lazymatch goal with 250 | (* This is usually required and should be applied at highest priority *) 251 | | H: is_true (?ts1 253 | eapply ety_subtyping; try by eapply instr_subtyping_empty_impl; apply H 254 | | H: ((Tf ?ts1 ?ts2) 256 | eapply ety_subtyping; try by apply H 257 | | |- e_typing _ _ nil _ => 258 | try eapply ety_subtyping; first (by apply ety_a' => //; apply bet_empty; eauto; try apply instr_subtyping_eq); eauto => // 259 | (* | |- context [$VN ?v] => 260 | replace ($VN v) with ($V (VAL_num v)); last done*) 261 | (* | |- e_typing _ _ [::$V _] _ => 262 | try eapply ety_subtyping; first (by apply et_value_typing; resolve_value_principal_typing; eauto); eauto => //*) 263 | | |- e_typing _ _ [::AI_basic _] _ => 264 | try eapply ety_subtyping; first (by apply ety_a' => //; econstructor; eauto; try apply instr_subtyping_eq); eauto => // 265 | | |- e_typing _ _ (v_to_e_list _) _ => 266 | try eapply ety_subtyping; first (by eapply et_values_typing; eauto); eauto => // 267 | (* | |- e_typing _ _ (_ ++ _) _ => 268 | try eapply ety_subtyping; first (eapply et_composition'; eauto); eauto => //*) 269 | | |- e_typing _ _ ((cons ($VN ?v) ?es)) _ => 270 | apply value_num_cons_e_typing 271 | | |- e_typing _ _ ((cons ($V (VAL_vec ?v)) ?es)) _ => 272 | apply value_vec_cons_e_typing 273 | | H: is_true (value_typing ?s ?v ?t) |- 274 | e_typing _ _ ((cons ($V ?v) ?es)) _ => 275 | apply (value_cons_e_typing H) 276 | | H: is_true (value_typing ?s (VAL_ref ?v) ?t) |- 277 | e_typing _ _ ((cons (vref_to_e ?v) ?es)) _ => 278 | replace (vref_to_e v) with ($V (VAL_ref v)); last done; 279 | apply (value_cons_e_typing H) 280 | | H: is_true (values_typing ?s ?vs ?ts) |- 281 | e_typing _ _ ((v_to_e_list ?vs ++ ?es)) _ => 282 | apply (values_cat_e_typing H) 283 | | H : is_true (const_list _) |- _ => 284 | let vs := fresh "vs" in 285 | apply const_es_exists in H as [vs ->]; invert_e_typing 286 | | _ => unfold_store_operations; resolve_subtyping => //; simplify_lists; simplify_multieq; simpl in * => // 287 | end. 288 | --------------------------------------------------------------------------------