From 7a920860be703459002a674ac1979e3fa66f4b0b Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Thu, 22 Aug 2024 20:02:35 +0200 Subject: [PATCH 1/8] Begin facelift Move stuff around and start migrating old encoding to smtml version 0.2.5. --- .ocamlformat | 4 +- {wasp/bin => bin}/dune | 0 {wasp/bin => bin}/main.ml | 0 {wasp/bin => bin}/wasp_ce.ml | 0 {wasp/bin => bin}/wasp_se.ml | 0 dune-project | 17 +- encoding/.github/ISSUE_TEMPLATE/bug_report.md | 28 - .../.github/ISSUE_TEMPLATE/feature_request.md | 20 - encoding/.gitignore | 32 - encoding/.ocamlformat | 1 - encoding/LICENSE | 674 ---------- encoding/Makefile | 18 - encoding/README.md | 49 - encoding/dune-project | 20 - encoding/encoding.opam | 32 - encoding/lib/axioms/axioms.ml | 11 - encoding/lib/constructors/bitVector.ml | 249 ---- encoding/lib/constructors/bitVector.mli | 82 -- encoding/lib/constructors/boolean.ml | 11 - encoding/lib/constructors/boolean.mli | 26 - encoding/lib/constructors/floatingPoint.ml | 177 --- encoding/lib/constructors/floatingPoint.mli | 61 - encoding/lib/constructors/integer.ml | 25 - encoding/lib/constructors/integer.mli | 67 - encoding/lib/constructors/real.ml | 21 - encoding/lib/constructors/real.mli | 55 - encoding/lib/constructors/strings.ml | 12 - encoding/lib/constructors/strings.mli | 23 - encoding/lib/dune | 6 - encoding/lib/exec/eval_numeric.ml | 498 -------- encoding/lib/exec/eval_numeric.mli | 10 - encoding/lib/mappings/z3_mappings.ml | 734 ----------- encoding/lib/mappings/z3_mappings.mli | 11 - encoding/lib/operators/boolOp.ml | 27 - encoding/lib/operators/bvOp.ml | 123 -- encoding/lib/operators/floatOp.ml | 104 -- encoding/lib/operators/intOp.ml | 88 -- encoding/lib/operators/strOp.ml | 25 - encoding/lib/optimizers/optimizer.ml | 41 - encoding/lib/optimizers/optimizer.mli | 21 - encoding/lib/solvers/batch.ml | 78 -- encoding/lib/solvers/batch.mli | 45 - encoding/lib/solvers/incremental.ml | 59 - encoding/lib/solvers/incremental.mli | 28 - encoding/lib/syntax/expression.ml | 588 --------- encoding/lib/syntax/num.ml | 35 - encoding/lib/syntax/symbol.ml | 11 - encoding/lib/syntax/types.ml | 118 -- encoding/lib/syntax/value.ml | 33 - encoding/test/dune | 14 - encoding/test/test_axiom.ml | 17 - encoding/test/test_batch.ml | 32 - encoding/test/test_bool.ml | 8 - encoding/test/test_f32.ml | 20 - encoding/test/test_int.ml | 18 - encoding/test/test_optimizer.ml | 17 - encoding/test/test_str.ml | 46 - {wasp/lib/symbolic => src}/btree.ml | 0 {wasp/lib/symbolic => src}/common/bug.ml | 0 .../lib/symbolic => src}/common/chunktable.ml | 2 +- {wasp/lib/symbolic => src}/common/common.ml | 2 +- {wasp/lib/symbolic => src}/common/counter.ml | 0 src/common/dune | 3 + src/common/evaluations.ml | 195 +++ {wasp/lib/symbolic => src}/common/globals.ml | 0 {wasp/lib/symbolic => src}/common/globals.mli | 0 .../lib/symbolic => src}/common/randArray.ml | 0 src/concolic/dune | 3 + src/concolic/eval.ml | 1128 ++++++++++++++++ src/concolic/evaluations.ml | 103 ++ src/concolic/execution_tree.ml | 56 + .../concolic/execution_tree.mli | 0 src/concolic/heap.ml | 277 ++++ {wasp/lib/symbolic => src}/concolic/heap.mli | 46 +- src/concolic/store.ml | 203 +++ {wasp/lib/symbolic => src}/dune | 2 +- .../lib => src/interpreter}/binary/decode.ml | 0 .../lib => src/interpreter}/binary/decode.mli | 0 .../lib => src/interpreter}/binary/encode.ml | 0 .../lib => src/interpreter}/binary/encode.mli | 0 {wasp/lib => src/interpreter}/binary/utf8.ml | 4 +- {wasp/lib => src/interpreter}/binary/utf8.mli | 0 {wasp/lib => src/interpreter}/dune | 3 +- src/interpreter/exec/eval.ml | 406 ++++++ {wasp/lib => src/interpreter}/exec/eval.mli | 0 .../interpreter}/exec/eval_numeric.ml | 2 +- .../interpreter}/exec/eval_numeric.mli | 0 {wasp/lib => src/interpreter}/exec/f32.ml | 0 .../interpreter}/exec/f32_convert.ml | 0 .../interpreter}/exec/f32_convert.mli | 0 {wasp/lib => src/interpreter}/exec/f64.ml | 0 .../interpreter}/exec/f64_convert.ml | 0 .../interpreter}/exec/f64_convert.mli | 0 {wasp/lib => src/interpreter}/exec/float.ml | 0 {wasp/lib => src/interpreter}/exec/i32.ml | 0 .../interpreter}/exec/i32_convert.ml | 0 .../interpreter}/exec/i32_convert.mli | 0 {wasp/lib => src/interpreter}/exec/i64.ml | 0 .../interpreter}/exec/i64_convert.ml | 0 .../interpreter}/exec/i64_convert.mli | 0 {wasp/lib => src/interpreter}/exec/int.ml | 4 +- .../interpreter}/exec/numeric_error.ml | 0 {wasp/lib => src/interpreter}/host/env.ml | 4 +- .../lib => src/interpreter}/host/spectest.ml | 0 {wasp/lib => src/interpreter}/main/flags.ml | 0 .../lib => src/interpreter}/meta/findlib/META | 0 .../interpreter}/meta/jslib/bsconfig.json | 0 .../interpreter}/meta/jslib/build.sh | 0 .../interpreter}/meta/jslib/wasm.ml | 0 .../interpreter}/meta/travis/build-test.sh | 0 .../interpreter}/meta/travis/install-ocaml.sh | 0 {wasp/lib => src/interpreter}/runtime/func.ml | 0 .../lib => src/interpreter}/runtime/func.mli | 0 .../lib => src/interpreter}/runtime/global.ml | 0 .../interpreter}/runtime/global.mli | 0 .../interpreter}/runtime/instance.ml | 0 .../lib => src/interpreter}/runtime/memory.ml | 0 .../interpreter}/runtime/memory.mli | 0 .../lib => src/interpreter}/runtime/table.ml | 0 .../lib => src/interpreter}/runtime/table.mli | 0 .../lib => src/interpreter}/script/import.ml | 2 +- .../lib => src/interpreter}/script/import.mli | 0 {wasp/lib => src/interpreter}/script/js.ml | 4 +- {wasp/lib => src/interpreter}/script/js.mli | 0 {wasp/lib => src/interpreter}/script/run.ml | 2 +- {wasp/lib => src/interpreter}/script/run.mli | 0 .../lib => src/interpreter}/script/script.ml | 0 {wasp/lib => src/interpreter}/syntax/ast.ml | 0 .../interpreter}/syntax/operators.ml | 0 {wasp/lib => src/interpreter}/syntax/types.ml | 0 .../lib => src/interpreter}/syntax/values.ml | 0 {wasp/lib => src/interpreter}/text/arrange.ml | 144 ++- .../lib => src/interpreter}/text/arrange.mli | 0 {wasp/lib => src/interpreter}/text/lexer.mli | 0 {wasp/lib => src/interpreter}/text/lexer.mll | 0 {wasp/lib => src/interpreter}/text/parse.ml | 0 {wasp/lib => src/interpreter}/text/parse.mli | 0 {wasp/lib => src/interpreter}/text/parser.mly | 1 + {wasp/lib => src/interpreter}/text/print.ml | 0 {wasp/lib => src/interpreter}/text/print.mli | 0 {wasp/lib => src/interpreter}/util/error.ml | 0 {wasp/lib => src/interpreter}/util/error.mli | 0 {wasp/lib => src/interpreter}/util/io.ml | 0 {wasp/lib => src/interpreter}/util/lib.ml | 4 +- {wasp/lib => src/interpreter}/util/lib.mli | 0 {wasp/lib => src/interpreter}/util/sexpr.ml | 0 {wasp/lib => src/interpreter}/util/sexpr.mli | 0 {wasp/lib => src/interpreter}/util/source.ml | 0 {wasp/lib => src/interpreter}/util/source.mli | 0 {wasp/lib => src/interpreter}/valid/valid.ml | 20 +- {wasp/lib => src/interpreter}/valid/valid.mli | 0 {wasp/lib/symbolic => src}/run.ml | 0 {wasp/lib/symbolic => src}/run.mli | 0 src/static/dune | 3 + {wasp/lib/symbolic => src}/static/eval.ml | 0 .../symbolic => src}/static/evaluations.ml | 0 {wasp/lib/symbolic => src}/static/memory.ml | 0 {wasp/lib/symbolic => src}/static/memory.mli | 0 .../lib/symbolic => src}/static/strategies.ml | 0 {wasp/lib/symbolic => src}/static/varmap.ml | 0 .../tests => tests}/btree-manticore/2o1u.wasm | Bin .../tests => tests}/btree-manticore/2o1u.wast | 0 .../tests => tests}/btree-manticore/2o2u.wasm | Bin .../tests => tests}/btree-manticore/2o2u.wast | 0 .../tests => tests}/btree-manticore/2o3u.wasm | Bin .../tests => tests}/btree-manticore/2o3u.wast | 0 .../tests => tests}/btree-manticore/3o1u.wasm | Bin .../tests => tests}/btree-manticore/3o1u.wast | 0 .../tests => tests}/btree-manticore/3o2u.wasm | Bin .../tests => tests}/btree-manticore/3o2u.wast | 0 .../tests => tests}/btree-manticore/3o3u.wasm | Bin .../tests => tests}/btree-manticore/3o3u.wast | 0 .../tests => tests}/btree-manticore/4o1u.wasm | Bin .../tests => tests}/btree-manticore/4o1u.wast | 0 .../tests => tests}/btree-manticore/4o2u.wasm | Bin .../tests => tests}/btree-manticore/4o2u.wast | 0 .../tests => tests}/btree-manticore/4o3u.wasm | Bin .../tests => tests}/btree-manticore/4o3u.wast | 0 .../tests => tests}/btree-manticore/5o1u.wasm | Bin .../tests => tests}/btree-manticore/5o1u.wast | 0 .../tests => tests}/btree-manticore/5o2u.wasm | Bin .../tests => tests}/btree-manticore/5o2u.wast | 0 .../tests => tests}/btree-manticore/5o3u.wasm | Bin .../tests => tests}/btree-manticore/5o3u.wast | 0 .../tests => tests}/btree-manticore/6o1u.wasm | Bin .../tests => tests}/btree-manticore/6o1u.wast | 0 .../tests => tests}/btree-manticore/6o2u.wasm | Bin .../tests => tests}/btree-manticore/6o2u.wast | 0 .../tests => tests}/btree-manticore/6o3u.wasm | Bin .../tests => tests}/btree-manticore/6o3u.wast | 0 .../tests => tests}/btree-manticore/7o1u.wasm | Bin .../tests => tests}/btree-manticore/7o1u.wast | 0 .../tests => tests}/btree-manticore/7o2u.wasm | Bin .../tests => tests}/btree-manticore/7o2u.wast | 0 .../tests => tests}/btree-manticore/7o3u.wasm | Bin .../tests => tests}/btree-manticore/7o3u.wast | 0 .../tests => tests}/btree-manticore/8o1u.wasm | Bin .../tests => tests}/btree-manticore/8o1u.wast | 0 .../tests => tests}/btree-manticore/8o2u.wasm | Bin .../tests => tests}/btree-manticore/8o2u.wast | 0 .../tests => tests}/btree-manticore/9o1u.wasm | Bin .../tests => tests}/btree-manticore/9o1u.wast | 0 .../tests => tests}/btree-manticore/9o2u.wasm | Bin .../tests => tests}/btree-manticore/9o2u.wast | 0 {wasp/tests => tests}/btree/2o1u.wast | 0 {wasp/tests => tests}/btree/2o2u.wast | 0 {wasp/tests => tests}/btree/2o3u.wast | 0 {wasp/tests => tests}/btree/3o1u.wast | 0 {wasp/tests => tests}/btree/3o2u.wast | 0 {wasp/tests => tests}/btree/3o3u.wast | 0 {wasp/tests => tests}/btree/4o1u.wast | 0 {wasp/tests => tests}/btree/4o2u.wast | 0 {wasp/tests => tests}/btree/4o3u.wast | 0 {wasp/tests => tests}/btree/5o1u.wast | 0 {wasp/tests => tests}/btree/5o2u.wast | 0 {wasp/tests => tests}/btree/5o3u.wast | 0 {wasp/tests => tests}/btree/6o1u.wast | 0 {wasp/tests => tests}/btree/6o2u.wast | 0 {wasp/tests => tests}/btree/6o3u.wast | 0 {wasp/tests => tests}/btree/7o1u.wast | 0 {wasp/tests => tests}/btree/7o2u.wast | 0 {wasp/tests => tests}/btree/7o3u.wast | 0 {wasp/tests => tests}/btree/8o1u.wast | 0 {wasp/tests => tests}/btree/8o2u.wast | 0 {wasp/tests => tests}/btree/9o1u.wast | 0 {wasp/tests => tests}/btree/9o2u.wast | 0 {wasp/tests => tests}/btree/BTree.wast | 0 {wasp/tests => tests}/failing/test1.1.wast | 0 {wasp/tests => tests}/failing/test1.wast | 0 {wasp/tests => tests}/failing/test10.wast | 0 {wasp/tests => tests}/failing/test11.wast | 0 {wasp/tests => tests}/failing/test12.wast | 0 {wasp/tests => tests}/failing/test13.wast | 0 {wasp/tests => tests}/failing/test14.wast | 0 {wasp/tests => tests}/failing/test15.wast | 0 {wasp/tests => tests}/failing/test16.wast | 0 {wasp/tests => tests}/failing/test2.wast | 0 {wasp/tests => tests}/failing/test3.wast | 0 {wasp/tests => tests}/failing/test4.wast | 0 {wasp/tests => tests}/failing/test5.wast | 0 {wasp/tests => tests}/failing/test6.wast | 0 {wasp/tests => tests}/failing/test7.wast | 0 {wasp/tests => tests}/failing/test8.wast | 0 {wasp/tests => tests}/failing/test9.wast | 0 {wasp/tests => tests}/passing/test1.wast | 0 {wasp/tests => tests}/passing/test2.wast | 0 {wasp/tests => tests}/passing/test3.wast | 0 {wasp/tests => tests}/passing/test4.wast | 0 {wasp/tests => tests}/passing/test5.wast | 0 {wasp/tests => tests}/passing/test6.1.wast | 0 {wasp/tests => tests}/passing/test6.wast | 0 {wasp/tests => tests}/passing/test7.wast | 0 .../regression/assume_assert.wast | 0 .../regression/assume_restart.wast | 0 .../regression/binop_to_relop.wast | 0 .../regression/borges-simple.wast | 0 {wasp/tests => tests}/regression/borges.wast | 0 .../regression/checkpoints.wast | 0 .../regression/coverage_policy.wast | 0 .../regression/load_store.wast | 0 .../load_store_symbolic_memory.wast | 0 {wasp/tests => tests}/regression/min.wast | 0 .../regression/mutable_globals_hold.wast | 0 {wasp/tests => tests}/regression/nearest.wast | 0 {wasp/tests => tests}/regression/nop.wast | 0 {wasp/tests => tests}/regression/sqrt.wast | 0 {wasp/tests => tests}/regression/static.wast | 0 .../regression/symbolic_memory_holds.wast | 0 ..._concrete_one_symbolic_locals_restart.wast | 0 ..._concrete_one_symbolic_memory_restart.wast | 0 .../two_concrete_one_symbolic_restart.wast | 0 ...rete_one_symbolic_with_assume_restart.wast | 0 {wasp/tests => tests}/run.py | 0 {wasp/tests => tests}/template/Makefile | 0 {wasp/tests => tests}/template/README.md | 0 .../template/lib/include/mockups.h | 0 .../template/lib/include/stdlib.h | 0 {wasp/tests => tests}/template/lib/mockups.c | 0 {wasp/tests => tests}/template/lib/stdlib.c | 0 .../template/src/test-template.c | 0 wasp.opam | 11 +- wasp/dune | 4 - wasp/lib/exec/eval.ml | 399 ------ wasp/lib/symbolic/common/dune | 3 - wasp/lib/symbolic/common/evaluations.ml | 196 --- wasp/lib/symbolic/concolic/dune | 3 - wasp/lib/symbolic/concolic/eval.ml | 1130 ----------------- wasp/lib/symbolic/concolic/evaluations.ml | 106 -- wasp/lib/symbolic/concolic/execution_tree.ml | 50 - wasp/lib/symbolic/concolic/heap.ml | 264 ---- wasp/lib/symbolic/concolic/store.ml | 197 --- wasp/lib/symbolic/static/dune | 3 - waspc.opam | 33 - waspc/bin/dune | 22 +- waspc/dune | 0 295 files changed, 2549 insertions(+), 7065 deletions(-) rename {wasp/bin => bin}/dune (100%) rename {wasp/bin => bin}/main.ml (100%) rename {wasp/bin => bin}/wasp_ce.ml (100%) rename {wasp/bin => bin}/wasp_se.ml (100%) delete mode 100644 encoding/.github/ISSUE_TEMPLATE/bug_report.md delete mode 100644 encoding/.github/ISSUE_TEMPLATE/feature_request.md delete mode 100644 encoding/.gitignore delete mode 100644 encoding/.ocamlformat delete mode 100644 encoding/LICENSE delete mode 100644 encoding/Makefile delete mode 100644 encoding/README.md delete mode 100644 encoding/dune-project delete mode 100644 encoding/encoding.opam delete mode 100644 encoding/lib/axioms/axioms.ml delete mode 100644 encoding/lib/constructors/bitVector.ml delete mode 100644 encoding/lib/constructors/bitVector.mli delete mode 100644 encoding/lib/constructors/boolean.ml delete mode 100644 encoding/lib/constructors/boolean.mli delete mode 100644 encoding/lib/constructors/floatingPoint.ml delete mode 100644 encoding/lib/constructors/floatingPoint.mli delete mode 100644 encoding/lib/constructors/integer.ml delete mode 100644 encoding/lib/constructors/integer.mli delete mode 100644 encoding/lib/constructors/real.ml delete mode 100644 encoding/lib/constructors/real.mli delete mode 100644 encoding/lib/constructors/strings.ml delete mode 100644 encoding/lib/constructors/strings.mli delete mode 100644 encoding/lib/dune delete mode 100644 encoding/lib/exec/eval_numeric.ml delete mode 100644 encoding/lib/exec/eval_numeric.mli delete mode 100644 encoding/lib/mappings/z3_mappings.ml delete mode 100644 encoding/lib/mappings/z3_mappings.mli delete mode 100644 encoding/lib/operators/boolOp.ml delete mode 100644 encoding/lib/operators/bvOp.ml delete mode 100644 encoding/lib/operators/floatOp.ml delete mode 100644 encoding/lib/operators/intOp.ml delete mode 100644 encoding/lib/operators/strOp.ml delete mode 100644 encoding/lib/optimizers/optimizer.ml delete mode 100644 encoding/lib/optimizers/optimizer.mli delete mode 100644 encoding/lib/solvers/batch.ml delete mode 100644 encoding/lib/solvers/batch.mli delete mode 100644 encoding/lib/solvers/incremental.ml delete mode 100644 encoding/lib/solvers/incremental.mli delete mode 100644 encoding/lib/syntax/expression.ml delete mode 100644 encoding/lib/syntax/num.ml delete mode 100644 encoding/lib/syntax/symbol.ml delete mode 100644 encoding/lib/syntax/types.ml delete mode 100644 encoding/lib/syntax/value.ml delete mode 100644 encoding/test/dune delete mode 100644 encoding/test/test_axiom.ml delete mode 100644 encoding/test/test_batch.ml delete mode 100644 encoding/test/test_bool.ml delete mode 100644 encoding/test/test_f32.ml delete mode 100644 encoding/test/test_int.ml delete mode 100644 encoding/test/test_optimizer.ml delete mode 100644 encoding/test/test_str.ml rename {wasp/lib/symbolic => src}/btree.ml (100%) rename {wasp/lib/symbolic => src}/common/bug.ml (100%) rename {wasp/lib/symbolic => src}/common/chunktable.ml (98%) rename {wasp/lib/symbolic => src}/common/common.ml (97%) rename {wasp/lib/symbolic => src}/common/counter.ml (100%) create mode 100644 src/common/dune create mode 100644 src/common/evaluations.ml rename {wasp/lib/symbolic => src}/common/globals.ml (100%) rename {wasp/lib/symbolic => src}/common/globals.mli (100%) rename {wasp/lib/symbolic => src}/common/randArray.ml (100%) create mode 100644 src/concolic/dune create mode 100644 src/concolic/eval.ml create mode 100644 src/concolic/evaluations.ml create mode 100644 src/concolic/execution_tree.ml rename {wasp/lib/symbolic => src}/concolic/execution_tree.mli (100%) create mode 100644 src/concolic/heap.ml rename {wasp/lib/symbolic => src}/concolic/heap.mli (59%) create mode 100644 src/concolic/store.ml rename {wasp/lib/symbolic => src}/dune (58%) rename {wasp/lib => src/interpreter}/binary/decode.ml (100%) rename {wasp/lib => src/interpreter}/binary/decode.mli (100%) rename {wasp/lib => src/interpreter}/binary/encode.ml (100%) rename {wasp/lib => src/interpreter}/binary/encode.mli (100%) rename {wasp/lib => src/interpreter}/binary/utf8.ml (94%) rename {wasp/lib => src/interpreter}/binary/utf8.mli (100%) rename {wasp/lib => src/interpreter}/dune (82%) create mode 100644 src/interpreter/exec/eval.ml rename {wasp/lib => src/interpreter}/exec/eval.mli (100%) rename {wasp/lib => src/interpreter}/exec/eval_numeric.ml (99%) rename {wasp/lib => src/interpreter}/exec/eval_numeric.mli (100%) rename {wasp/lib => src/interpreter}/exec/f32.ml (100%) rename {wasp/lib => src/interpreter}/exec/f32_convert.ml (100%) rename {wasp/lib => src/interpreter}/exec/f32_convert.mli (100%) rename {wasp/lib => src/interpreter}/exec/f64.ml (100%) rename {wasp/lib => src/interpreter}/exec/f64_convert.ml (100%) rename {wasp/lib => src/interpreter}/exec/f64_convert.mli (100%) rename {wasp/lib => src/interpreter}/exec/float.ml (100%) rename {wasp/lib => src/interpreter}/exec/i32.ml (100%) rename {wasp/lib => src/interpreter}/exec/i32_convert.ml (100%) rename {wasp/lib => src/interpreter}/exec/i32_convert.mli (100%) rename {wasp/lib => src/interpreter}/exec/i64.ml (100%) rename {wasp/lib => src/interpreter}/exec/i64_convert.ml (100%) rename {wasp/lib => src/interpreter}/exec/i64_convert.mli (100%) rename {wasp/lib => src/interpreter}/exec/int.ml (99%) rename {wasp/lib => src/interpreter}/exec/numeric_error.ml (100%) rename {wasp/lib => src/interpreter}/host/env.ml (88%) rename {wasp/lib => src/interpreter}/host/spectest.ml (100%) rename {wasp/lib => src/interpreter}/main/flags.ml (100%) rename {wasp/lib => src/interpreter}/meta/findlib/META (100%) rename {wasp/lib => src/interpreter}/meta/jslib/bsconfig.json (100%) rename {wasp/lib => src/interpreter}/meta/jslib/build.sh (100%) rename {wasp/lib => src/interpreter}/meta/jslib/wasm.ml (100%) rename {wasp/lib => src/interpreter}/meta/travis/build-test.sh (100%) rename {wasp/lib => src/interpreter}/meta/travis/install-ocaml.sh (100%) rename {wasp/lib => src/interpreter}/runtime/func.ml (100%) rename {wasp/lib => src/interpreter}/runtime/func.mli (100%) rename {wasp/lib => src/interpreter}/runtime/global.ml (100%) rename {wasp/lib => src/interpreter}/runtime/global.mli (100%) rename {wasp/lib => src/interpreter}/runtime/instance.ml (100%) rename {wasp/lib => src/interpreter}/runtime/memory.ml (100%) rename {wasp/lib => src/interpreter}/runtime/memory.mli (100%) rename {wasp/lib => src/interpreter}/runtime/table.ml (100%) rename {wasp/lib => src/interpreter}/runtime/table.mli (100%) rename {wasp/lib => src/interpreter}/script/import.ml (92%) rename {wasp/lib => src/interpreter}/script/import.mli (100%) rename {wasp/lib => src/interpreter}/script/js.ml (99%) rename {wasp/lib => src/interpreter}/script/js.mli (100%) rename {wasp/lib => src/interpreter}/script/run.ml (99%) rename {wasp/lib => src/interpreter}/script/run.mli (100%) rename {wasp/lib => src/interpreter}/script/script.ml (100%) rename {wasp/lib => src/interpreter}/syntax/ast.ml (100%) rename {wasp/lib => src/interpreter}/syntax/operators.ml (100%) rename {wasp/lib => src/interpreter}/syntax/types.ml (100%) rename {wasp/lib => src/interpreter}/syntax/values.ml (100%) rename {wasp/lib => src/interpreter}/text/arrange.ml (79%) rename {wasp/lib => src/interpreter}/text/arrange.mli (100%) rename {wasp/lib => src/interpreter}/text/lexer.mli (100%) rename {wasp/lib => src/interpreter}/text/lexer.mll (100%) rename {wasp/lib => src/interpreter}/text/parse.ml (100%) rename {wasp/lib => src/interpreter}/text/parse.mli (100%) rename {wasp/lib => src/interpreter}/text/parser.mly (99%) rename {wasp/lib => src/interpreter}/text/print.ml (100%) rename {wasp/lib => src/interpreter}/text/print.mli (100%) rename {wasp/lib => src/interpreter}/util/error.ml (100%) rename {wasp/lib => src/interpreter}/util/error.mli (100%) rename {wasp/lib => src/interpreter}/util/io.ml (100%) rename {wasp/lib => src/interpreter}/util/lib.ml (98%) rename {wasp/lib => src/interpreter}/util/lib.mli (100%) rename {wasp/lib => src/interpreter}/util/sexpr.ml (100%) rename {wasp/lib => src/interpreter}/util/sexpr.mli (100%) rename {wasp/lib => src/interpreter}/util/source.ml (100%) rename {wasp/lib => src/interpreter}/util/source.mli (100%) rename {wasp/lib => src/interpreter}/valid/valid.ml (96%) rename {wasp/lib => src/interpreter}/valid/valid.mli (100%) rename {wasp/lib/symbolic => src}/run.ml (100%) rename {wasp/lib/symbolic => src}/run.mli (100%) create mode 100644 src/static/dune rename {wasp/lib/symbolic => src}/static/eval.ml (100%) rename {wasp/lib/symbolic => src}/static/evaluations.ml (100%) rename {wasp/lib/symbolic => src}/static/memory.ml (100%) rename {wasp/lib/symbolic => src}/static/memory.mli (100%) rename {wasp/lib/symbolic => src}/static/strategies.ml (100%) rename {wasp/lib/symbolic => src}/static/varmap.ml (100%) rename {wasp/tests => tests}/btree-manticore/2o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/2o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/2o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/2o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/2o3u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/2o3u.wast (100%) rename {wasp/tests => tests}/btree-manticore/3o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/3o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/3o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/3o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/3o3u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/3o3u.wast (100%) rename {wasp/tests => tests}/btree-manticore/4o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/4o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/4o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/4o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/4o3u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/4o3u.wast (100%) rename {wasp/tests => tests}/btree-manticore/5o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/5o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/5o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/5o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/5o3u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/5o3u.wast (100%) rename {wasp/tests => tests}/btree-manticore/6o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/6o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/6o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/6o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/6o3u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/6o3u.wast (100%) rename {wasp/tests => tests}/btree-manticore/7o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/7o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/7o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/7o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/7o3u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/7o3u.wast (100%) rename {wasp/tests => tests}/btree-manticore/8o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/8o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/8o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/8o2u.wast (100%) rename {wasp/tests => tests}/btree-manticore/9o1u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/9o1u.wast (100%) rename {wasp/tests => tests}/btree-manticore/9o2u.wasm (100%) rename {wasp/tests => tests}/btree-manticore/9o2u.wast (100%) rename {wasp/tests => tests}/btree/2o1u.wast (100%) rename {wasp/tests => tests}/btree/2o2u.wast (100%) rename {wasp/tests => tests}/btree/2o3u.wast (100%) rename {wasp/tests => tests}/btree/3o1u.wast (100%) rename {wasp/tests => tests}/btree/3o2u.wast (100%) rename {wasp/tests => tests}/btree/3o3u.wast (100%) rename {wasp/tests => tests}/btree/4o1u.wast (100%) rename {wasp/tests => tests}/btree/4o2u.wast (100%) rename {wasp/tests => tests}/btree/4o3u.wast (100%) rename {wasp/tests => tests}/btree/5o1u.wast (100%) rename {wasp/tests => tests}/btree/5o2u.wast (100%) rename {wasp/tests => tests}/btree/5o3u.wast (100%) rename {wasp/tests => tests}/btree/6o1u.wast (100%) rename {wasp/tests => tests}/btree/6o2u.wast (100%) rename {wasp/tests => tests}/btree/6o3u.wast (100%) rename {wasp/tests => tests}/btree/7o1u.wast (100%) rename {wasp/tests => tests}/btree/7o2u.wast (100%) rename {wasp/tests => tests}/btree/7o3u.wast (100%) rename {wasp/tests => tests}/btree/8o1u.wast (100%) rename {wasp/tests => tests}/btree/8o2u.wast (100%) rename {wasp/tests => tests}/btree/9o1u.wast (100%) rename {wasp/tests => tests}/btree/9o2u.wast (100%) rename {wasp/tests => tests}/btree/BTree.wast (100%) rename {wasp/tests => tests}/failing/test1.1.wast (100%) rename {wasp/tests => tests}/failing/test1.wast (100%) rename {wasp/tests => tests}/failing/test10.wast (100%) rename {wasp/tests => tests}/failing/test11.wast (100%) rename {wasp/tests => tests}/failing/test12.wast (100%) rename {wasp/tests => tests}/failing/test13.wast (100%) rename {wasp/tests => tests}/failing/test14.wast (100%) rename {wasp/tests => tests}/failing/test15.wast (100%) rename {wasp/tests => tests}/failing/test16.wast (100%) rename {wasp/tests => tests}/failing/test2.wast (100%) rename {wasp/tests => tests}/failing/test3.wast (100%) rename {wasp/tests => tests}/failing/test4.wast (100%) rename {wasp/tests => tests}/failing/test5.wast (100%) rename {wasp/tests => tests}/failing/test6.wast (100%) rename {wasp/tests => tests}/failing/test7.wast (100%) rename {wasp/tests => tests}/failing/test8.wast (100%) rename {wasp/tests => tests}/failing/test9.wast (100%) rename {wasp/tests => tests}/passing/test1.wast (100%) rename {wasp/tests => tests}/passing/test2.wast (100%) rename {wasp/tests => tests}/passing/test3.wast (100%) rename {wasp/tests => tests}/passing/test4.wast (100%) rename {wasp/tests => tests}/passing/test5.wast (100%) rename {wasp/tests => tests}/passing/test6.1.wast (100%) rename {wasp/tests => tests}/passing/test6.wast (100%) rename {wasp/tests => tests}/passing/test7.wast (100%) rename {wasp/tests => tests}/regression/assume_assert.wast (100%) rename {wasp/tests => tests}/regression/assume_restart.wast (100%) rename {wasp/tests => tests}/regression/binop_to_relop.wast (100%) rename {wasp/tests => tests}/regression/borges-simple.wast (100%) rename {wasp/tests => tests}/regression/borges.wast (100%) rename {wasp/tests => tests}/regression/checkpoints.wast (100%) rename {wasp/tests => tests}/regression/coverage_policy.wast (100%) rename {wasp/tests => tests}/regression/load_store.wast (100%) rename {wasp/tests => tests}/regression/load_store_symbolic_memory.wast (100%) rename {wasp/tests => tests}/regression/min.wast (100%) rename {wasp/tests => tests}/regression/mutable_globals_hold.wast (100%) rename {wasp/tests => tests}/regression/nearest.wast (100%) rename {wasp/tests => tests}/regression/nop.wast (100%) rename {wasp/tests => tests}/regression/sqrt.wast (100%) rename {wasp/tests => tests}/regression/static.wast (100%) rename {wasp/tests => tests}/regression/symbolic_memory_holds.wast (100%) rename {wasp/tests => tests}/regression/two_concrete_one_symbolic_locals_restart.wast (100%) rename {wasp/tests => tests}/regression/two_concrete_one_symbolic_memory_restart.wast (100%) rename {wasp/tests => tests}/regression/two_concrete_one_symbolic_restart.wast (100%) rename {wasp/tests => tests}/regression/two_concrete_one_symbolic_with_assume_restart.wast (100%) rename {wasp/tests => tests}/run.py (100%) rename {wasp/tests => tests}/template/Makefile (100%) rename {wasp/tests => tests}/template/README.md (100%) rename {wasp/tests => tests}/template/lib/include/mockups.h (100%) rename {wasp/tests => tests}/template/lib/include/stdlib.h (100%) rename {wasp/tests => tests}/template/lib/mockups.c (100%) rename {wasp/tests => tests}/template/lib/stdlib.c (100%) rename {wasp/tests => tests}/template/src/test-template.c (100%) delete mode 100644 wasp/dune delete mode 100644 wasp/lib/exec/eval.ml delete mode 100644 wasp/lib/symbolic/common/dune delete mode 100644 wasp/lib/symbolic/common/evaluations.ml delete mode 100644 wasp/lib/symbolic/concolic/dune delete mode 100644 wasp/lib/symbolic/concolic/eval.ml delete mode 100644 wasp/lib/symbolic/concolic/evaluations.ml delete mode 100644 wasp/lib/symbolic/concolic/execution_tree.ml delete mode 100644 wasp/lib/symbolic/concolic/heap.ml delete mode 100644 wasp/lib/symbolic/concolic/store.ml delete mode 100644 wasp/lib/symbolic/static/dune delete mode 100644 waspc.opam delete mode 100644 waspc/dune diff --git a/.ocamlformat b/.ocamlformat index 66fa21ac..f1462252 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.25.1 +version=0.26.2 assignment-operator=end-line break-cases=fit break-fun-decl=wrap @@ -25,7 +25,7 @@ let-binding-spacing=compact let-module=compact margin=80 max-indent=2 -module-item-spacing=compact +module-item-spacing=sparse ocaml-version=4.14.0 ocp-indent-compat=false parens-ite=false diff --git a/wasp/bin/dune b/bin/dune similarity index 100% rename from wasp/bin/dune rename to bin/dune diff --git a/wasp/bin/main.ml b/bin/main.ml similarity index 100% rename from wasp/bin/main.ml rename to bin/main.ml diff --git a/wasp/bin/wasp_ce.ml b/bin/wasp_ce.ml similarity index 100% rename from wasp/bin/wasp_ce.ml rename to bin/wasp_ce.ml diff --git a/wasp/bin/wasp_se.ml b/bin/wasp_se.ml similarity index 100% rename from wasp/bin/wasp_se.ml rename to bin/wasp_se.ml diff --git a/dune-project b/dune-project index 4c9d5483..fa43fda0 100644 --- a/dune-project +++ b/dune-project @@ -17,10 +17,13 @@ (name wasp) (synopsis "WebAssembly Symbolic Processor (WASP)") (description "WASP is a symbolic execution engine for testing and validating Wasm modules.") - (depends base batteries ocamlformat)) - -(package - (name waspc) - (synopsis "") - (description "") - (depends ocaml dune re2 bos pyml cmdliner)) + (depends + batteries + bos + cmdliner + dune + ocaml + (ocamlformat :with-dev-setup) + pyml + re2 + (smtml (>= "0.2.4")))) diff --git a/encoding/.github/ISSUE_TEMPLATE/bug_report.md b/encoding/.github/ISSUE_TEMPLATE/bug_report.md deleted file mode 100644 index d2bfc6b7..00000000 --- a/encoding/.github/ISSUE_TEMPLATE/bug_report.md +++ /dev/null @@ -1,28 +0,0 @@ ---- -name: Bug report -about: Create a report to help us improve -title: '' -labels: bug -assignees: '' - ---- - -**Describe the bug** -A clear and concise description of what the bug is. - -**To Reproduce** -Steps to reproduce the behavior. - -**Expected behavior** -A clear and concise description of what you expected to happen. - -**Screenshots** -If applicable, add screenshots to help explain your problem. - -**Environment (please complete the following information):** - - OS - - OCaml toplevel version - - Z3 Version - -**Additional context** -Add any other context about the problem here. diff --git a/encoding/.github/ISSUE_TEMPLATE/feature_request.md b/encoding/.github/ISSUE_TEMPLATE/feature_request.md deleted file mode 100644 index bbcbbe7d..00000000 --- a/encoding/.github/ISSUE_TEMPLATE/feature_request.md +++ /dev/null @@ -1,20 +0,0 @@ ---- -name: Feature request -about: Suggest an idea for this project -title: '' -labels: '' -assignees: '' - ---- - -**Is your feature request related to a problem? Please describe.** -A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] - -**Describe the solution you'd like** -A clear and concise description of what you want to happen. - -**Describe alternatives you've considered** -A clear and concise description of any alternative solutions or features you've considered. - -**Additional context** -Add any other context or screenshots about the feature request here. diff --git a/encoding/.gitignore b/encoding/.gitignore deleted file mode 100644 index 218cfd7b..00000000 --- a/encoding/.gitignore +++ /dev/null @@ -1,32 +0,0 @@ -_opam -_build -_boot -_perf -_coverage -__pycache__ -*.install - -# vim swap files -*.swp -*.swo - -# emacs lock files -.#* - -# vscode settings -.vscode - -# git-ps hooks -.git-ps - -.duneboot.* -Makefile.dev -src/dune_rules/setup.ml -result - -.DS_Store -nix/profiles/ - -# dkml desktop CI -/msys64 -/.ci diff --git a/encoding/.ocamlformat b/encoding/.ocamlformat deleted file mode 100644 index f9497671..00000000 --- a/encoding/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -profile = conventional diff --git a/encoding/LICENSE b/encoding/LICENSE deleted file mode 100644 index f288702d..00000000 --- a/encoding/LICENSE +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -. diff --git a/encoding/Makefile b/encoding/Makefile deleted file mode 100644 index 98519e4a..00000000 --- a/encoding/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -all: build - -build: - @dune build --profile dev - -install: - @dune install - -uninstall: - @dune uninstall - -clean: - @dune clean - -test: - @dune runtest - -.PHONY: all build install uninstall clean test diff --git a/encoding/README.md b/encoding/README.md deleted file mode 100644 index f5df5b94..00000000 --- a/encoding/README.md +++ /dev/null @@ -1,49 +0,0 @@ -# Encoding - -[![GPL-3.0](https://img.shields.io/github/license/wasp-platform/encoding)](LICENSE) -![Platform](https://img.shields.io/badge/platform-linux%20%7C%20macos-lightgrey) -[![GitHub last commit](https://img.shields.io/github/last-commit/wasp-platform/encoding)](https://github.com/wasp-platform/encoding/commit/main~0) - -Encoding serves as an abstracted constraint-solving wrapper, currently -utilising Z3 as its backend solver. However, future plans for Encoding -include support for other solvers in its backend, such as CVC5. - -## Build from source - -- Install [opam](https://opam.ocaml.org/doc/Install.html). -- Bootstrap the OCaml compiler: - -```sh -opam init -opam switch create 4.14.0 4.14.0 -``` - -- Then, install the library dependencies: - -```sh -git clone https://github.com/wasp-platform/encoding.git -cd encoding -opam install . --deps-only -``` - -- Build and test: - -```sh -make -make test -``` - -- Install `encoding` on your path by running: - -```sh -make install -``` - -## Use encoding in your project - -* To incorporate encoding into your project, you can either build and install -the project sources or add encoding as a submodule to your project: - -```sh -git submodule add https://github.com/wasp-platform/encoding -``` diff --git a/encoding/dune-project b/encoding/dune-project deleted file mode 100644 index 9c689d7e..00000000 --- a/encoding/dune-project +++ /dev/null @@ -1,20 +0,0 @@ -(lang dune 3.0) - -(name encoding) - -(generate_opam_files true) - -(source - (github wasp-platform/encoding)) - -(authors "WASP Platform") - -(maintainers "WASP Platform") - -(license LICENSE) - -(package - (name encoding) - (synopsis "Encoding library") - (description "An OCaml abstraction layer for constraint solvers.") - (depends (ocaml (>= "4.14.0")) dune z3 core ppx_inline_test)) diff --git a/encoding/encoding.opam b/encoding/encoding.opam deleted file mode 100644 index 7574ec88..00000000 --- a/encoding/encoding.opam +++ /dev/null @@ -1,32 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Encoding library" -description: "An OCaml abstraction layer for constraint solvers." -maintainer: ["WASP Platform"] -authors: ["WASP Platform"] -license: "LICENSE" -homepage: "https://github.com/wasp-platform/encoding" -bug-reports: "https://github.com/wasp-platform/encoding/issues" -depends: [ - "ocaml" {>= "4.14.0"} - "dune" {>= "3.0"} - "z3" - "core" - "ppx_inline_test" - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/wasp-platform/encoding.git" diff --git a/encoding/lib/axioms/axioms.ml b/encoding/lib/axioms/axioms.ml deleted file mode 100644 index 980378ef..00000000 --- a/encoding/lib/axioms/axioms.ml +++ /dev/null @@ -1,11 +0,0 @@ -let axioms = - let x = Symbol.mk_symbol `StrType "x" in - [ - Expression.Quantifier - ( Expression.Forall, - [ x ], - Strings.mk_eq - (Integer.mk_to_string (Integer.mk_of_string (Expression.mk_symbol x))) - (Expression.mk_symbol x), - [ [ Integer.mk_of_string (Expression.mk_symbol x) ] ] ); - ] diff --git a/encoding/lib/constructors/bitVector.ml b/encoding/lib/constructors/bitVector.ml deleted file mode 100644 index 552b27f1..00000000 --- a/encoding/lib/constructors/bitVector.ml +++ /dev/null @@ -1,249 +0,0 @@ -open Expression -open Types - -exception Error of string - -let mk_val (i : int) (t : num_type) : expr = - match t with - | `I32Type -> Val (Num (I32 (Int32.of_int i))) - | `I64Type -> Val (Num (I64 (Int64.of_int i))) - | _ -> raise (Error ("mk_val: invalid type '" ^ string_of_num_type t ^ "'")) - -let mk_not (e : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Not - | `I64Type -> I64 I64.Not - | _ -> raise (Error ("mk_not: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_clz (e : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Clz - | `I64Type -> I64 I64.Clz - | _ -> raise (Error ("mk_clz: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_add (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Add - | `I64Type -> I64 I64.Add - | _ -> raise (Error ("mk_add: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_sub (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Sub - | `I64Type -> I64 I64.Sub - | _ -> raise (Error ("mk_sub: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_mul (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Mul - | `I64Type -> I64 I64.Mul - | _ -> raise (Error ("mk_mul: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_div_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.DivU - | `I64Type -> I64 I64.DivU - | _ -> - raise (Error ("mk_div_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_div_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.DivS - | `I64Type -> I64 I64.DivS - | _ -> - raise (Error ("mk_div_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_rem_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.RemU - | `I64Type -> I64 I64.RemU - | _ -> - raise (Error ("mk_rem_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_rem_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.RemS - | `I64Type -> I64 I64.RemS - | _ -> - raise (Error ("mk_rem_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_shl (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Shl - | `I64Type -> I64 I64.Shl - | _ -> raise (Error ("mk_shl: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_shr_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.ShrU - | `I64Type -> I64 I64.ShrU - | _ -> - raise (Error ("mk_shr_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_shr_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.ShrS - | `I64Type -> I64 I64.ShrS - | _ -> - raise (Error ("mk_shr_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_and (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.And - | `I64Type -> I64 I64.And - | _ -> raise (Error ("mk_and: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_or (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Or - | `I64Type -> I64 I64.Or - | _ -> raise (Error ("mk_or: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_xor (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Xor - | `I64Type -> I64 I64.Xor - | _ -> raise (Error ("mk_xor: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_eq (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Eq - | `I64Type -> I64 I64.Eq - | _ -> raise (Error ("mk_eq: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_ne (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.Ne - | `I64Type -> I64 I64.Ne - | _ -> raise (Error ("mk_ne: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_lt_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.LtU - | `I64Type -> I64 I64.LtU - | _ -> - raise (Error ("mk_lt_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_lt_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.LtS - | `I64Type -> I64 I64.LtS - | _ -> - raise (Error ("mk_lt_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_le_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.LeU - | `I64Type -> I64 I64.LeU - | _ -> - raise (Error ("mk_le_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_le_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.LeS - | `I64Type -> I64 I64.LeS - | _ -> - raise (Error ("mk_le_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_gt_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.GtU - | `I64Type -> I64 I64.GtU - | _ -> - raise (Error ("mk_gt_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_gt_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.GtS - | `I64Type -> I64 I64.GtS - | _ -> - raise (Error ("mk_gt_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_ge_u (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.GeU - | `I64Type -> I64 I64.GeU - | _ -> - raise (Error ("mk_ge_u: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_ge_s (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `I32Type -> I32 I32.GeS - | `I64Type -> I64 I64.GeS - | _ -> - raise (Error ("mk_ge_s: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) diff --git a/encoding/lib/constructors/bitVector.mli b/encoding/lib/constructors/bitVector.mli deleted file mode 100644 index 7d16d8d1..00000000 --- a/encoding/lib/constructors/bitVector.mli +++ /dev/null @@ -1,82 +0,0 @@ -open Expression -open Types - -exception Error of string - -val mk_val : int -> num_type -> expr -(** [mk_val i] creates a concrete bitvector value. *) - -val mk_not : expr -> num_type -> expr -(** [mk_not i] create an expression representing [not i]. *) - -val mk_clz : expr -> num_type -> expr -(** [mk_clz i] create an expression representing [clz i]. *) - -val mk_add : expr -> expr -> num_type -> expr -(** [mk_add i1 i2] create an expression representing [i1 + i2]. *) - -val mk_sub : expr -> expr -> num_type -> expr -(** [mk_sub i1 i2] create an expression representing [i1 - i2]. *) - -val mk_mul : expr -> expr -> num_type -> expr -(** [mk_mul i1 i2] create an expression representing [i1 * i2]. *) - -val mk_div_u : expr -> expr -> num_type -> expr -(** [mk_div_u i1 i2] create an expression representing unsigned [i1 / i2]. *) - -val mk_div_s : expr -> expr -> num_type -> expr -(** [mk_div_s i1 i2] create an expression representing signed [i1 / i2]. *) - -val mk_rem_u : expr -> expr -> num_type -> expr -(** [mk_rem_u i1 i2] create an expression representing unsigned [i1 % i2]. *) - -val mk_rem_s : expr -> expr -> num_type -> expr -(** [mk_rem_s i1 i2] create an expression representing signed [i1 % i2]. *) - -val mk_shl : expr -> expr -> num_type -> expr -(** [mk_shl i1 i2] create an expression representing [i1 << i2]. *) - -val mk_shr_u : expr -> expr -> num_type -> expr -(** [mk_shr_u i1 i2] create an expression representing signed [i1 >> i2]. *) - -val mk_shr_s : expr -> expr -> num_type -> expr -(** [mk_shr_u i1 i2] create an expression representing unsigned [i1 >> i2]. *) - -val mk_and : expr -> expr -> num_type -> expr -(** [mk_and i1 i2] create an expression representing unsigned [i1 & i2]. *) - -val mk_or : expr -> expr -> num_type -> expr -(** [mk_or i1 i2] create an expression representing unsigned [i1 | i2]. *) - -val mk_xor : expr -> expr -> num_type -> expr -(** [mk_xor i1 i2] create an expression representing unsigned [i1 ^ i2]. *) - -val mk_eq : expr -> expr -> num_type -> expr -(** [mk_eq i1 i2] create an expression representing [i1 = i2]. *) - -val mk_ne : expr -> expr -> num_type -> expr -(** [mk_ne i1 i2] create an expression representing [not (i1 = i2)]. *) - -val mk_lt_u : expr -> expr -> num_type -> expr -(** [mk_lt_u i1 i2] create an expression representing unsigned [i1 < i2]. *) - -val mk_lt_s : expr -> expr -> num_type -> expr -(** [mk_lt_s i1 i2] create an expression representing signed [i1 < i2]. *) - -val mk_le_u : expr -> expr -> num_type -> expr -(** [mk_le_u i1 i2] create an expression representing unsigned [i1 <= i2]. *) - -val mk_le_s : expr -> expr -> num_type -> expr -(** [mk_le_s i1 i2] create an expression representing signed [i1 <= i2]. *) - -val mk_gt_u : expr -> expr -> num_type -> expr -(** [mk_gt_u i1 i2] create an expression representing unsigned [i1 > i2]. *) - -val mk_gt_s : expr -> expr -> num_type -> expr -(** [mk_gt_s i1 i2] create an expression representing signed [i1 > i2]. *) - -val mk_ge_u : expr -> expr -> num_type -> expr -(** [mk_ge_u i1 i2] create an expression representing unsigned [i1 >= i2]. *) - -val mk_ge_s : expr -> expr -> num_type -> expr -(** [mk_ge_s i1 i2] create an expression representing signed [i1 >= i2]. *) diff --git a/encoding/lib/constructors/boolean.ml b/encoding/lib/constructors/boolean.ml deleted file mode 100644 index eb710e5f..00000000 --- a/encoding/lib/constructors/boolean.ml +++ /dev/null @@ -1,11 +0,0 @@ -open Expression -open Types - -let mk_val (b : bool) : expr = Val (Bool b) -let mk_not (e : expr) : expr = Unop (Bool B.Not, e) -let mk_and (e1 : expr) (e2 : expr) : expr = Binop (Bool B.And, e1, e2) -let mk_or (e1 : expr) (e2 : expr) : expr = Binop (Bool B.Or, e1, e2) -let mk_xor (e1 : expr) (e2 : expr) : expr = Binop (Bool B.Xor, e1, e2) -let mk_eq (e1 : expr) (e2 : expr) : expr = Relop (Bool B.Eq, e1, e2) -let mk_ne (e1 : expr) (e2 : expr) : expr = Relop (Bool B.Ne, e1, e2) -let mk_ite (e1 : expr) (e2 : expr) (e3 : expr) = Triop (Bool B.ITE, e1, e2, e3) diff --git a/encoding/lib/constructors/boolean.mli b/encoding/lib/constructors/boolean.mli deleted file mode 100644 index f8d0b810..00000000 --- a/encoding/lib/constructors/boolean.mli +++ /dev/null @@ -1,26 +0,0 @@ -open Expression - -val mk_val : bool -> expr -(** [mk_val b] creates a concrete boolean value. *) - -val mk_not : expr -> expr -(** [mk_not e] create an expression representing [not e]. *) - -val mk_and : expr -> expr -> expr -(** [mk_and e1 e2] create an expression representing [e1 and e2]. *) - -val mk_or : expr -> expr -> expr -(** [mk_or e1 e2] create an expression representing [e1 or e2]. *) - -val mk_xor : expr -> expr -> expr -(** [mk_xor e1 e2] create an expression representing [e1 xor e2]. *) - -val mk_eq : expr -> expr -> expr -(** [mk_eq e1 e2] create an expression representing [e1 = e2]. *) - -val mk_ne : expr -> expr -> expr -(** [mk_ne e1 e2] create an expression representing [not (e1 = e2)]. *) - -val mk_ite : expr -> expr -> expr -> expr -(** [mk_ite e1 e2 e3] create an expression representing - [if e1 then e2 else e3]*) diff --git a/encoding/lib/constructors/floatingPoint.ml b/encoding/lib/constructors/floatingPoint.ml deleted file mode 100644 index 4e42e5e7..00000000 --- a/encoding/lib/constructors/floatingPoint.ml +++ /dev/null @@ -1,177 +0,0 @@ -open Core -open Expression -open Types - -exception Error of string - -let mk_val (f : float) (t : num_type) : expr = - match t with - | `F32Type -> Val (Num (F32 (Int32.bits_of_float f))) - | `F64Type -> Val (Num (F64 (Int64.bits_of_float f))) - | _ -> raise (Error ("mk_val: invalid type '" ^ string_of_num_type t ^ "'")) - -let mk_neg (e : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Neg - | `F64Type -> F64 F64.Neg - | _ -> raise (Error ("mk_neg: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_abs (e : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Abs - | `F64Type -> F64 F64.Abs - | _ -> raise (Error ("mk_abs: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_sqrt (e : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Sqrt - | `F64Type -> F64 F64.Sqrt - | _ -> - raise (Error ("mk_sqrt: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_nearest (e : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Nearest - | `F64Type -> F64 F64.Nearest - | _ -> - raise - (Error ("mk_nearest: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_is_nan (e : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.IsNan - | `F64Type -> F64 F64.IsNan - | _ -> - raise (Error ("mk_is_nan: invalid type '" ^ string_of_num_type t ^ "'")) - in - Unop (op, e) - -let mk_add (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Add - | `F64Type -> F64 F64.Add - | _ -> raise (Error ("mk_add: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_sub (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Sub - | `F64Type -> F64 F64.Sub - | _ -> raise (Error ("mk_sub: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_mul (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Mul - | `F64Type -> F64 F64.Mul - | _ -> raise (Error ("mk_mul: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_div (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Div - | `F64Type -> F64 F64.Div - | _ -> raise (Error ("mk_div: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_min (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Min - | `F64Type -> F64 F64.Min - | _ -> raise (Error ("mk_min: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_max (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Max - | `F64Type -> F64 F64.Max - | _ -> raise (Error ("mk_max: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_rem (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Rem - | `F64Type -> F64 F64.Rem - | _ -> raise (Error ("mk_max: invalid type '" ^ string_of_num_type t ^ "'")) - in - Binop (op, e1, e2) - -let mk_eq (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Eq - | `F64Type -> F64 F64.Eq - | _ -> raise (Error ("mk_eq: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_ne (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Ne - | `F64Type -> F64 F64.Ne - | _ -> raise (Error ("mk_ne: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_lt (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Lt - | `F64Type -> F64 F64.Lt - | _ -> raise (Error ("mk_lt: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_le (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Le - | `F64Type -> F64 F64.Le - | _ -> raise (Error ("mk_le: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_gt (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Gt - | `F64Type -> F64 F64.Gt - | _ -> raise (Error ("mk_gt: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) - -let mk_ge (e1 : expr) (e2 : expr) (t : num_type) : expr = - let op = - match t with - | `F32Type -> F32 F32.Ge - | `F64Type -> F64 F64.Ge - | _ -> raise (Error ("mk_ge: invalid type '" ^ string_of_num_type t ^ "'")) - in - Relop (op, e1, e2) diff --git a/encoding/lib/constructors/floatingPoint.mli b/encoding/lib/constructors/floatingPoint.mli deleted file mode 100644 index 4db20ea9..00000000 --- a/encoding/lib/constructors/floatingPoint.mli +++ /dev/null @@ -1,61 +0,0 @@ -open Expression -open Types - -exception Error of string - -val mk_val : float -> num_type -> expr -(** [mk_val f] creates a concrete floating-point value. *) - -val mk_neg : expr -> num_type -> expr -(** [mk_neg f] create an expression representing [-f]. *) - -val mk_abs : expr -> num_type -> expr -(** [mk_abs f] create an expression representing [abs(f)]. *) - -val mk_sqrt : expr -> num_type -> expr -(** [mk_sqrt f] create an expression representing [sqrt(f)]. *) - -val mk_nearest : expr -> num_type -> expr -(** [mk_nearest f] create an expression representing [round_nearest(f)]. *) - -val mk_is_nan : expr -> num_type -> expr -(** [mk_is_nan f] create an expression representing [is_nan(f)]. *) - -val mk_add : expr -> expr -> num_type -> expr -(** [mk_add f1 f2] create an expression representing [f1 + f2]. *) - -val mk_sub : expr -> expr -> num_type -> expr -(** [mk_sub f1 f2] create an expression representing [f1 - f2]. *) - -val mk_mul : expr -> expr -> num_type -> expr -(** [mk_mul f1 f2] create an expression representing [f1 * f2]. *) - -val mk_div : expr -> expr -> num_type -> expr -(** [mk_div f1 f2] create an expression representing [f1 / f2]. *) - -val mk_min : expr -> expr -> num_type -> expr -(** [mk_min f1 f2] create an expression representing [min f1 f2]. *) - -val mk_max : expr -> expr -> num_type -> expr -(** [mk_max f1 f2] create an expression representing [max f1 f2]. *) - -val mk_rem : expr -> expr -> num_type -> expr -(** [mk_rem f1 f2] create an expression representing [f1 % f2]. *) - -val mk_eq : expr -> expr -> num_type -> expr -(** [mk_eq f1 f2] create an expression representing [f1 = f2]. *) - -val mk_ne : expr -> expr -> num_type -> expr -(** [mk_ne f1 f2] create an expression representing [not (f1 = f2)]. *) - -val mk_lt : expr -> expr -> num_type -> expr -(** [mk_lt f1 f2] create an expression representing [f1 < f2]. *) - -val mk_le : expr -> expr -> num_type -> expr -(** [mk_le f1 f2] create an expression representing [f1 <= f2]. *) - -val mk_gt : expr -> expr -> num_type -> expr -(** [mk_gt f1 f2] create an expression representing [f1 > f2]. *) - -val mk_ge : expr -> expr -> num_type -> expr -(** [mk_ge f1 f2] create an expression representing [f1 >= f2]. *) diff --git a/encoding/lib/constructors/integer.ml b/encoding/lib/constructors/integer.ml deleted file mode 100644 index 52f2687f..00000000 --- a/encoding/lib/constructors/integer.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Expression -open Types - -let mk_val (i : int) : expr = Val (Int i) -let mk_neg (e : expr) : expr = Unop (Int I.Neg, e) -let mk_add (e1 : expr) (e2 : expr) : expr = Binop (Int I.Add, e1, e2) -let mk_sub (e1 : expr) (e2 : expr) : expr = Binop (Int I.Sub, e1, e2) -let mk_mul (e1 : expr) (e2 : expr) : expr = Binop (Int I.Mul, e1, e2) -let mk_div (e1 : expr) (e2 : expr) : expr = Binop (Int I.Div, e1, e2) -let mk_rem (e1 : expr) (e2 : expr) : expr = Binop (Int I.Rem, e1, e2) -let mk_shl (e1 : expr) (e2 : expr) : expr = Binop (Int I.Shl, e1, e2) -let mk_shr_a (e1 : expr) (e2 : expr) : expr = Binop (Int I.ShrA, e1, e2) -let mk_shr_l (e1 : expr) (e2 : expr) : expr = Binop (Int I.ShrL, e1, e2) -let mk_and (e1 : expr) (e2 : expr) : expr = Binop (Int I.And, e1, e2) -let mk_or (e1 : expr) (e2 : expr) : expr = Binop (Int I.Or, e1, e2) -let mk_xor (e1 : expr) (e2 : expr) : expr = Binop (Int I.Xor, e1, e2) -let mk_pow (e1 : expr) (e2 : expr) : expr = Binop (Int I.Pow, e1, e2) -let mk_eq (e1 : expr) (e2 : expr) : expr = Relop (Int I.Eq, e1, e2) -let mk_ne (e1 : expr) (e2 : expr) : expr = Relop (Int I.Ne, e1, e2) -let mk_lt (e1 : expr) (e2 : expr) : expr = Relop (Int I.Lt, e1, e2) -let mk_le (e1 : expr) (e2 : expr) : expr = Relop (Int I.Le, e1, e2) -let mk_gt (e1 : expr) (e2 : expr) : expr = Relop (Int I.Gt, e1, e2) -let mk_ge (e1 : expr) (e2 : expr) : expr = Relop (Int I.Ge, e1, e2) -let mk_to_string (e : expr) : expr = Cvtop (Int I.ToString, e) -let mk_of_string (e : expr) : expr = Cvtop (Int I.OfString, e) diff --git a/encoding/lib/constructors/integer.mli b/encoding/lib/constructors/integer.mli deleted file mode 100644 index eea494d2..00000000 --- a/encoding/lib/constructors/integer.mli +++ /dev/null @@ -1,67 +0,0 @@ -open Expression - -val mk_val : int -> expr -(** [mk_val i] creates a concrete integer value. *) - -val mk_neg : expr -> expr -(** [mk_neg i] create an expression representing [-i]. *) - -val mk_add : expr -> expr -> expr -(** [mk_add i1 i2] create an expression representing [i1 + i2]. *) - -val mk_sub : expr -> expr -> expr -(** [mk_sub i1 i2] create an expression representing [i1 - i2]. *) - -val mk_mul : expr -> expr -> expr -(** [mk_mul i1 i2] create an expression representing [i1 * i2]. *) - -val mk_div : expr -> expr -> expr -(** [mk_div i1 i2] create an expression representing [i1 / i2]. *) - -val mk_rem : expr -> expr -> expr -(** [mk_rem i1 i2] create an expression representing [i1 % i2]. *) - -val mk_shl : expr -> expr -> expr -(** [mk_shl i1 i2] create an expression representing [i1 << i2]. *) - -val mk_shr_a : expr -> expr -> expr -(** [mk_shr_a i1 i2] create an expression representing [i1 >> i2]. *) - -val mk_shr_l : expr -> expr -> expr -(** [mk_shr_l i1 i2] create an expression representing [i1 >> i2]. *) - -val mk_and : expr -> expr -> expr -(** [mk_and i1 i2] create an expression representing [i1 & i2]. *) - -val mk_or : expr -> expr -> expr -(** [mk_or i1 i2] create an expression representing [i1 | i2]. *) - -val mk_xor : expr -> expr -> expr -(** [mk_xor i1 i2] create an expression representing [i1 xor i2]. *) - -val mk_pow : expr -> expr -> expr -(** [mk_pow i1 i2] create an expression representing [i1 ** i2]. *) - -val mk_eq : expr -> expr -> expr -(** [mk_eq i1 i2] create an expression representing [i1 = i2]. *) - -val mk_ne : expr -> expr -> expr -(** [mk_ne i1 i2] create an expression representing [not (i1 = i2)]. *) - -val mk_lt : expr -> expr -> expr -(** [mk_lt i1 i2] create an expression representing [i1 < i2]. *) - -val mk_le : expr -> expr -> expr -(** [mk_le i1 i2] create an expression representing [i1 <= i2]. *) - -val mk_gt : expr -> expr -> expr -(** [mk_gt i1 i2] create an expression representing [i1 > i2]. *) - -val mk_ge : expr -> expr -> expr -(** [mk_ge i1 i2] create an expression representing [i1 >= i2]. *) - -val mk_to_string : expr -> expr -(** [mk_to_string s] create an expression representing a string *) - -val mk_of_string : expr -> expr -(** [mk_of_string s] create an expression representing an integer *) diff --git a/encoding/lib/constructors/real.ml b/encoding/lib/constructors/real.ml deleted file mode 100644 index 7aad0e68..00000000 --- a/encoding/lib/constructors/real.ml +++ /dev/null @@ -1,21 +0,0 @@ -open Expression -open Types - -let mk_val (f : float) : expr = Val (Real f) -let mk_neg (e : expr) : expr = Unop (Real R.Neg, e) -let mk_abs (e : expr) : expr = Unop (Real R.Abs, e) -let mk_sqrt (e : expr) : expr = Unop (Real R.Sqrt, e) -let mk_add (e1 : expr) (e2 : expr) : expr = Binop (Real R.Add, e1, e2) -let mk_sub (e1 : expr) (e2 : expr) : expr = Binop (Real R.Sub, e1, e2) -let mk_mul (e1 : expr) (e2 : expr) : expr = Binop (Real R.Mul, e1, e2) -let mk_div (e1 : expr) (e2 : expr) : expr = Binop (Real R.Div, e1, e2) -let mk_min (e1 : expr) (e2 : expr) : expr = Binop (Real R.Min, e1, e2) -let mk_max (e1 : expr) (e2 : expr) : expr = Binop (Real R.Max, e1, e2) -let mk_eq (e1 : expr) (e2 : expr) : expr = Relop (Real R.Eq, e1, e2) -let mk_ne (e1 : expr) (e2 : expr) : expr = Relop (Real R.Ne, e1, e2) -let mk_lt (e1 : expr) (e2 : expr) : expr = Relop (Real R.Lt, e1, e2) -let mk_le (e1 : expr) (e2 : expr) : expr = Relop (Real R.Le, e1, e2) -let mk_gt (e1 : expr) (e2 : expr) : expr = Relop (Real R.Gt, e1, e2) -let mk_ge (e1 : expr) (e2 : expr) : expr = Relop (Real R.Ge, e1, e2) -let mk_to_string (e : expr) : expr = Cvtop (Real R.ToString, e) -let mk_of_string (e : expr) : expr = Cvtop (Real R.OfString, e) diff --git a/encoding/lib/constructors/real.mli b/encoding/lib/constructors/real.mli deleted file mode 100644 index ac96b6d8..00000000 --- a/encoding/lib/constructors/real.mli +++ /dev/null @@ -1,55 +0,0 @@ -open Expression - -val mk_val : float -> expr -(** [mk_val f] creates a concrete floating-point value. *) - -val mk_neg : expr -> expr -(** [mk_neg f] create an expression representing [-f]. *) - -val mk_abs : expr -> expr -(** [mk_abs f] create an expression representing [abs(f)]. *) - -val mk_sqrt : expr -> expr -(** [mk_sqrt f] create an expression representing [sqrt(f)]. *) - -val mk_add : expr -> expr -> expr -(** [mk_add f1 f2] create an expression representing [f1 + f2]. *) - -val mk_sub : expr -> expr -> expr -(** [mk_sub f1 f2] create an expression representing [f1 - f2]. *) - -val mk_mul : expr -> expr -> expr -(** [mk_mul f1 f2] create an expression representing [f1 * f2]. *) - -val mk_div : expr -> expr -> expr -(** [mk_div f1 f2] create an expression representing [f1 / f2]. *) - -val mk_min : expr -> expr -> expr -(** [mk_min f1 f2] create an expression representing [min f1 f2]. *) - -val mk_max : expr -> expr -> expr -(** [mk_max f1 f2] create an expression representing [max f1 f2]. *) - -val mk_eq : expr -> expr -> expr -(** [mk_eq f1 f2] create an expression representing [f1 = f2]. *) - -val mk_ne : expr -> expr -> expr -(** [mk_ne f1 f2] create an expression representing [not (f1 = f2)]. *) - -val mk_lt : expr -> expr -> expr -(** [mk_lt f1 f2] create an expression representing [f1 < f2]. *) - -val mk_le : expr -> expr -> expr -(** [mk_le f1 f2] create an expression representing [f1 <= f2]. *) - -val mk_gt : expr -> expr -> expr -(** [mk_gt f1 f2] create an expression representing [f1 > f2]. *) - -val mk_ge : expr -> expr -> expr -(** [mk_ge f1 f2] create an expression representing [f1 >= f2]. *) - -val mk_to_string : expr -> expr -(** [mk_to_string f] create an expression representing a string *) - -val mk_of_string : expr -> expr -(** [mk_of_string f] create an expression representing a real *) diff --git a/encoding/lib/constructors/strings.ml b/encoding/lib/constructors/strings.ml deleted file mode 100644 index e653adfc..00000000 --- a/encoding/lib/constructors/strings.ml +++ /dev/null @@ -1,12 +0,0 @@ -open Expression -open Types - -let mk_val (s : String.t) : expr = Val (Str s) -let mk_len (s : expr) : expr = Unop (Str S.Len, s) -let mk_nth (s : expr) (i : expr) : expr = Binop (Str S.Nth, s, i) -let mk_concat (s1 : expr) (s2 : expr) : expr = Binop (Str S.Concat, s1, s2) -let mk_eq (s1 : expr) (s2 : expr) : expr = Relop (Str S.Eq, s1, s2) -let mk_ne (s1 : expr) (s2 : expr) : expr = Relop (Str S.Ne, s1, s2) - -let mk_substr (s : expr) ~(pos : expr) ~(len : expr) : expr = - Triop (Str S.SubStr, s, pos, len) diff --git a/encoding/lib/constructors/strings.mli b/encoding/lib/constructors/strings.mli deleted file mode 100644 index 09ba30bb..00000000 --- a/encoding/lib/constructors/strings.mli +++ /dev/null @@ -1,23 +0,0 @@ -open Expression - -val mk_val : String.t -> expr -(** [mk_val s] creates a concrete string value. *) - -val mk_len : expr -> expr -(** [mk_len s] create an expression representing [length s]. *) - -val mk_nth : expr -> expr -> expr -(** [mk_nth s i] create an expression representing [s.(i)]. *) - -val mk_concat : expr -> expr -> expr -(** [mk_concat s1 s2] create an expression representing [s1 ^ s2]. *) - -val mk_eq : expr -> expr -> expr -(** [mk_eq s1 s2] create an expression representing [s1 = s2]. *) - -val mk_ne : expr -> expr -> expr -(** [mk_ne s1 s2] create an expression representing [not (s1 = s2)]. *) - -val mk_substr : expr -> pos:expr -> len:expr -> expr -(** [mk_substr s pos len] create an expression representing the substring of - [s] starting in [pos] and with length [len]. *) diff --git a/encoding/lib/dune b/encoding/lib/dune deleted file mode 100644 index 9928c5d7..00000000 --- a/encoding/lib/dune +++ /dev/null @@ -1,6 +0,0 @@ -(include_subdirs unqualified) - -(library - (name encoding) - (public_name encoding) - (libraries core z3)) diff --git a/encoding/lib/exec/eval_numeric.ml b/encoding/lib/exec/eval_numeric.ml deleted file mode 100644 index 390c533d..00000000 --- a/encoding/lib/exec/eval_numeric.ml +++ /dev/null @@ -1,498 +0,0 @@ -open Core -open Types - -exception Num of num_type -exception TypeError of int * Num.t * num_type -exception DivideByZero -exception ConversionToInteger -exception IntegerOverflow - -let of_arg f n v = try f v with Num t -> raise (TypeError (n, v, t)) - -module I32Op = struct - open Types.I32 - open Int32 - - let bitwidth = 32 - let to_value i : Num.t = I32 i - - let of_value n v : t = - of_arg (fun v -> match v with I32 i -> i | _ -> raise (Num `I32Type)) n v - - let cmp_u x op y = op (x + min_value) (y + min_value) - let lt_u x y = cmp_u x ( < ) y - let le_u x y = cmp_u x ( <= ) y - let gt_u x y = cmp_u x ( > ) y - let ge_u x y = cmp_u x ( >= ) y - - let divrem_u n d = - if d = zero then raise DivideByZero - else - let t = shift_right d (Int.( - ) bitwidth 1) in - let n' = n land lnot t in - let q = shift_left (shift_right_logical n' 1 / d) 1 in - let r = n - (q * d) in - if cmp_u r ( < ) d then (q, r) else (q + one, r - d) - - let div_u x y = - let q, _ = divrem_u x y in - q - - let shift f x y = f x (to_int_exn (y land of_int_exn (Int.( - ) bitwidth 1))) - let shl x y = shift shift_left x y - let shr_s x y = shift shift_right x y - let shr_u x y = shift shift_right_logical x y - - let unop (op : I32.unop) : Num.t -> Num.t = - let f = - match op with Clz -> fun i -> of_int_trunc (clz i) | Not -> bit_not - in - fun v -> to_value (f (of_value 1 v)) - - let binop (op : I32.binop) : Num.t -> Num.t -> Num.t = - let f = - match op with - | Add -> ( + ) - | Sub -> ( - ) - | Mul -> ( * ) - | DivS -> ( / ) - | DivU -> div_u - | RemS -> rem - | RemU -> rem - | And -> ( land ) - | Or -> ( lor ) - | Xor -> ( lxor ) - | Shl -> shl - | ShrU -> shr_s - | ShrS -> shr_u - in - fun v1 v2 -> to_value (f (of_value 1 v1) (of_value 2 v2)) - - let relop op : Num.t -> Num.t -> bool = - let f = - match op with - | Eq -> ( = ) - | Ne -> ( <> ) - | LtS -> ( < ) - | LtU -> lt_u - | LeS -> ( >= ) - | LeU -> le_u - | GtS -> ( > ) - | GtU -> gt_u - | GeS -> ( >= ) - | GeU -> ge_u - in - fun v1 v2 -> f (of_value 1 v1) (of_value 2 v2) -end - -module I64Op = struct - open Types.I64 - open Int64 - - let bitwidth = 64 - let to_value i : Num.t = I64 i - - let of_value n v : int64 = - of_arg (fun v -> match v with I64 i -> i | _ -> raise (Num `I64Type)) n v - - let cmp_u x op y = op (x + min_value) (y + min_value) - let lt_u x y = cmp_u x ( < ) y - let le_u x y = cmp_u x ( <= ) y - let gt_u x y = cmp_u x ( > ) y - let ge_u x y = cmp_u x ( >= ) y - - let divrem_u n d = - if d = zero then raise DivideByZero - else - let t = shift_right d (Int.( - ) bitwidth 1) in - let n' = n land lnot t in - let q = shift_left (shift_right_logical n' 1 / d) 1 in - let r = n - (q * d) in - if cmp_u r ( < ) d then (q, r) else (q + one, r - d) - - let div_u x y = - let q, _ = divrem_u x y in - q - - let shift f x y = f x (to_int_exn (y land of_int_exn (Int.( - ) bitwidth 1))) - let shl x y = shift shift_left x y - let shr_s x y = shift shift_right x y - let shr_u x y = shift shift_right_logical x y - - let unop op : Num.t -> Num.t = - let f = match op with Clz -> fun i -> of_int (clz i) | Not -> bit_not in - fun v -> to_value (f (of_value 1 v)) - - let binop op : Num.t -> Num.t -> Num.t = - let f = - match op with - | Add -> ( + ) - | Sub -> ( - ) - | Mul -> ( * ) - | DivS -> ( / ) - | DivU -> div_u - | RemS -> rem - | RemU -> rem - | And -> ( land ) - | Or -> ( lor ) - | Xor -> ( lxor ) - | Shl -> shl - | ShrU -> shr_s - | ShrS -> shr_u - in - fun v1 v2 -> to_value (f (of_value 1 v1) (of_value 2 v2)) - - let relop op : Num.t -> Num.t -> bool = - let f = - match op with - | Eq -> ( = ) - | Ne -> ( <> ) - | LtS -> ( < ) - | LtU -> lt_u - | LeS -> ( >= ) - | LeU -> le_u - | GtS -> ( > ) - | GtU -> gt_u - | GeS -> ( >= ) - | GeU -> ge_u - in - fun v1 v2 -> f (of_value 1 v1) (of_value 2 v2) -end - -module F32Op = struct - open Types.F32 - open Float - - let to_value f : Num.t = F32 f - - let of_value = - of_arg (fun v -> match v with F32 f -> f | _ -> raise (Num `F32Type)) - - let of_float = Int32.bits_of_float - let to_float = Int32.float_of_bits - - let unop op = - let f = - match op with - | Neg -> neg - | Abs -> abs - | Sqrt -> sqrt - | Nearest -> round_nearest - | IsNan -> assert false - in - fun v -> to_value (of_float (f (to_float (of_value 1 v)))) - - let binop op = - let f = - match op with - | Add -> ( + ) - | Sub -> ( - ) - | Mul -> ( * ) - | Div -> ( / ) - | Rem -> ( % ) - | Min -> min - | Max -> max - in - fun v1 v2 -> - to_value - (of_float (f (to_float (of_value 1 v1)) (to_float (of_value 2 v2)))) - - let relop op = - let f = - match op with - | Eq -> ( = ) - | Ne -> ( <> ) - | Lt -> ( < ) - | Le -> ( <= ) - | Gt -> ( > ) - | Ge -> ( >= ) - in - fun v1 v2 -> f (to_float (of_value 1 v1)) (to_float (of_value 2 v2)) -end - -module F64Op = struct - open Types.F64 - open Float - - let to_value f : Num.t = F64 f - - let of_value = - of_arg (fun v -> match v with F64 f -> f | _ -> raise (Num `F64Type)) - - let of_float = Int64.bits_of_float - let to_float = Int64.float_of_bits - - let unop op = - let f = - match op with - | Neg -> neg - | Abs -> abs - | Sqrt -> sqrt - | Nearest -> round_nearest - | IsNan -> assert false - in - fun v -> to_value (of_float (f (to_float (of_value 1 v)))) - - let binop op = - let f = - match op with - | Add -> ( + ) - | Sub -> ( - ) - | Mul -> ( * ) - | Div -> ( / ) - | Rem -> ( % ) - | Min -> min - | Max -> max - in - fun v1 v2 -> - to_value - (of_float (f (to_float (of_value 1 v1)) (to_float (of_value 2 v2)))) - - let relop op = - let f = - match op with - | Eq -> ( = ) - | Ne -> ( <> ) - | Lt -> ( < ) - | Le -> ( <= ) - | Gt -> ( > ) - | Ge -> ( >= ) - in - fun v1 v2 -> f (to_float (of_value 1 v1)) (to_float (of_value 2 v2)) -end - -module I32CvtOp = struct - open I32 - open Int32 - - let trunc_f32_s x = - if x <> x then raise ConversionToInteger - else - let xf = F32Op.to_float x in - if - Float.( - xf >= -Int32.(to_float min_value) || xf < Int32.(to_float min_value)) - then raise IntegerOverflow - else F32Op.of_float xf - - let trunc_f32_u x = - if x <> x then raise ConversionToInteger - else - let xf = F32Op.to_float x in - if Float.(xf >= -.Int32.(to_float min_value) *. 2.0 || xf <= -1.0) then - raise IntegerOverflow - else F32Op.of_float xf - - let trunc_f64_s x = - if Int64.( <> ) x x then raise ConversionToInteger - else - let xf = F64Op.to_float x in - if - Float.( - xf >= -Int64.(to_float min_value) || xf < Int32.(to_float min_value)) - then raise IntegerOverflow - else F32Op.of_float xf - - let trunc_f64_u x = - if Int64.( <> ) x x then raise ConversionToInteger - else - let xf = F64Op.to_float x in - if Float.(xf >= -Int32.(to_float min_value) *. 2.0 || xf <= -1.0) then - raise IntegerOverflow - else F32Op.of_float xf - - let cvtop op v : Num.t = - match op with - | WrapI64 -> I32 (Int64.to_int32_exn (I64Op.of_value 1 v)) - | TruncSF32 -> I32 (trunc_f32_s (F32Op.of_value 1 v)) - | TruncUF32 -> I32 (trunc_f32_u (F32Op.of_value 1 v)) - | TruncSF64 -> I32 (trunc_f64_s (F64Op.of_value 1 v)) - | TruncUF64 -> I32 (trunc_f64_u (F64Op.of_value 1 v)) - | ReinterpretFloat -> I32 (F32Op.of_value 1 v) - | ExtendSI32 -> raise (TypeError (1, v, `I32Type)) - | ExtendUI32 -> raise (TypeError (1, v, `I32Type)) -end - -module I64CvtOp = struct - open I64 - open Int64 - - let extend_i32_u x = Int64.of_int32_exn x land 0x0000_0000_ffff_ffffL - - let trunc_f32_s x = - if Int32.( <> ) x x then raise ConversionToInteger - else - let xf = F32Op.to_float x in - if - Float.( - xf >= -Int64.(to_float min_value) || xf < Int64.(to_float min_value)) - then raise IntegerOverflow - else F64Op.of_float xf - - let trunc_f32_u x = - if Int32.( <> ) x x then raise ConversionToInteger - else - let xf = F32Op.to_float x in - if Float.(xf >= -Int64.(to_float min_value) *. 2.0 || xf <= -1.0) then - raise IntegerOverflow - else if Float.(xf >= -Int64.(to_float min_value)) then - of_float (xf -. (* TODO(ocaml-4.03): 0x1p63 *) 9223372036854775808.0) - lxor min_value - else F64Op.of_float xf - - let trunc_f64_s x = - if x <> x then raise ConversionToInteger - else - let xf = F64Op.to_float x in - if - Float.( - xf >= -Int64.(to_float min_value) || xf < Int64.(to_float min_value)) - then raise IntegerOverflow - else F64Op.of_float xf - - let trunc_f64_u x = - if x <> x then raise ConversionToInteger - else - let xf = F64Op.to_float x in - if Float.(xf >= -Int64.(to_float min_value) *. 2.0 || xf <= -1.0) then - raise IntegerOverflow - else if Float.(xf >= -Int64.(to_float min_value)) then - of_float (xf -. (* TODO(ocaml-4.03): 0x1p63 *) 9223372036854775808.0) - lxor min_value - else F64Op.of_float xf - - let cvtop op v : Num.t = - match op with - | ExtendSI32 -> I64 (of_int32_exn (I32Op.of_value 1 v)) - | ExtendUI32 -> I64 (extend_i32_u (I32Op.of_value 1 v)) - | TruncSF32 -> I64 (trunc_f32_s (F32Op.of_value 1 v)) - | TruncUF32 -> I64 (trunc_f32_u (F32Op.of_value 1 v)) - | TruncSF64 -> I64 (trunc_f64_s (F64Op.of_value 1 v)) - | TruncUF64 -> I64 (trunc_f64_u (F64Op.of_value 1 v)) - | ReinterpretFloat -> I64 (F64Op.of_value 1 v) - | WrapI64 -> raise (TypeError (1, v, `I64Type)) -end - -module F32CvtOp = struct - open F32 - - let demote_f64 x = - let xf = F64Op.to_float x in - if Float.(xf = xf) then F32Op.of_float xf - else - let nan64bits = x in - let sign_field = - Int64.(shift_left (shift_right_logical nan64bits 63) 31) - in - let significand_field = - Int64.(shift_right_logical (shift_left nan64bits 12) 41) - in - let fields = Int64.( lor ) sign_field significand_field in - Int32.( lor ) 0x7fc0_0000l (Int64.to_int32_exn fields) - - let convert_i32_s x = F32Op.of_float (Int32.to_float x) - - let convert_i32_u x = - F32Op.of_float - Int32.( - if x >= zero then to_float x - else to_float (shift_right_logical x 1 lor (x land 1l)) *. 2.0) - - let convert_i64_s x = - F32Op.of_float - Int64.( - if abs x < 0x10_0000_0000_0000L then to_float x - else - let r = if x land 0xfffL = 0L then 0L else 1L in - to_float (shift_right x 12 lor r) - *. (* TODO(ocaml-4.03): 0x1p12 *) 4096.0) - - let convert_i64_u x = - F32Op.of_float - Int64.( - if I64Op.lt_u x 0x10_0000_0000_0000L then to_float x - else - let r = if x land 0xfffL = 0L then 0L else 1L in - to_float (shift_right_logical x 12 lor r) - *. (* TODO(ocaml-4.03): 0x1p12 *) 4096.0) - - let cvtop op v : Num.t = - match op with - | DemoteF64 -> F32 (demote_f64 (F64Op.of_value 1 v)) - | ConvertSI32 -> F32 (convert_i32_s (I32Op.of_value 1 v)) - | ConvertUI32 -> F32 (convert_i32_u (I32Op.of_value 1 v)) - | ConvertSI64 -> F32 (convert_i64_s (I64Op.of_value 1 v)) - | ConvertUI64 -> F32 (convert_i64_u (I64Op.of_value 1 v)) - | ReinterpretInt -> F32 (I32Op.of_value 1 v) - | PromoteF32 -> raise (TypeError (1, v, `F32Type)) - | ToString | OfString -> assert false -end - -module F64CvtOp = struct - open F64 - - let promote_f32 x = - let xf = F32Op.to_float x in - if Float.(xf = xf) then F64Op.of_float xf - else - let nan32bits = I64CvtOp.extend_i32_u x in - let sign_field = - Int64.(shift_left (shift_right_logical nan32bits 31) 63) - in - let significand_field = - Int64.(shift_right_logical (shift_left nan32bits 41) 12) - in - let fields = Int64.( lor ) sign_field significand_field in - Int64.( lor ) 0x7ff8_0000_0000_0000L fields - - let convert_i32_s x = F64Op.of_float (Int32.to_float x) - - (* - * Unlike the other convert_u functions, the high half of the i32 range is - * within the range where f32 can represent odd numbers, so we can't do the - * shift. Instead, we can use int64 signed arithmetic. - *) - let convert_i32_u x = - F64Op.of_float Int64.(to_float (of_int32 x land 0x0000_0000_ffff_ffffL)) - - let convert_i64_s x = F64Op.of_float (Int64.to_float x) - - (* - * Values in the low half of the int64 range can be converted with a signed - * conversion. The high half is beyond the range where f64 can represent odd - * numbers, so we can shift the value right, adjust the least significant - * bit to round correctly, do a conversion, and then scale it back up. - *) - let convert_i64_u x = - F64Op.of_float - Int64.( - if x >= zero then to_float x - else to_float (shift_right_logical x 1 lor (x land 1L)) *. 2.0) - - let cvtop op v : Num.t = - match op with - | PromoteF32 -> F64 (promote_f32 (F32Op.of_value 1 v)) - | ConvertSI32 -> F64 (convert_i32_s (I32Op.of_value 1 v)) - | ConvertUI32 -> F64 (convert_i32_u (I32Op.of_value 1 v)) - | ConvertSI64 -> F64 (convert_i64_s (I64Op.of_value 1 v)) - | ConvertUI64 -> F64 (convert_i64_u (I64Op.of_value 1 v)) - | ReinterpretInt -> F64 (I64Op.of_value 1 v) - | DemoteF64 -> raise (TypeError (1, v, `F64Type)) - | ToString | OfString -> assert false -end - -(* Dispatch *) - -let op i32 i64 f32 f64 = function - | Int _ -> failwith "eval_numeric: Integer evaluations not supported" - | Real _ -> failwith "eval_numeric: Float evaluations not supported" - | I32 x -> i32 x - | I64 x -> i64 x - | F32 x -> f32 x - | F64 x -> f64 x - | Str _ | Bool _ -> assert false - -let eval_unop = op I32Op.unop I64Op.unop F32Op.unop F64Op.unop -let eval_binop = op I32Op.binop I64Op.binop F32Op.binop F64Op.binop -let eval_relop = op I32Op.relop I64Op.relop F32Op.relop F64Op.relop -let eval_cvtop = op I32CvtOp.cvtop I64CvtOp.cvtop F32CvtOp.cvtop F64CvtOp.cvtop diff --git a/encoding/lib/exec/eval_numeric.mli b/encoding/lib/exec/eval_numeric.mli deleted file mode 100644 index 407b34a5..00000000 --- a/encoding/lib/exec/eval_numeric.mli +++ /dev/null @@ -1,10 +0,0 @@ -open Types - -exception DivideByZero -exception Num of num_type -exception TypeError of int * Num.t * num_type - -val eval_unop : unop -> Num.t -> Num.t -val eval_binop : binop -> Num.t -> Num.t -> Num.t -val eval_relop : relop -> Num.t -> Num.t -> bool -val eval_cvtop : cvtop -> Num.t -> Num.t diff --git a/encoding/lib/mappings/z3_mappings.ml b/encoding/lib/mappings/z3_mappings.ml deleted file mode 100644 index 7a5553b5..00000000 --- a/encoding/lib/mappings/z3_mappings.ml +++ /dev/null @@ -1,734 +0,0 @@ -open Core -open Types - -exception Error of string - -let ctx = - Z3.mk_context - [ ("model", "true"); ("proof", "false"); ("unsat_core", "false") ] - -let int_sort = Z3.Arithmetic.Integer.mk_sort ctx -let real_sort = Z3.Arithmetic.Real.mk_sort ctx -let bool_sort = Z3.Boolean.mk_sort ctx -let str_sort = Z3.Seq.mk_string_sort ctx -let bv32_sort = Z3.BitVector.mk_sort ctx 32 -let bv64_sort = Z3.BitVector.mk_sort ctx 64 -let fp32_sort = Z3.FloatingPoint.mk_sort_single ctx -let fp64_sort = Z3.FloatingPoint.mk_sort_double ctx -let rne = Z3.FloatingPoint.RoundingMode.mk_rne ctx -let rtz = Z3.FloatingPoint.RoundingMode.mk_rtz ctx - -let get_sort (e : Types.expr_type) : Z3.Sort.sort = - match e with - | `IntType -> int_sort - | `RealType -> real_sort - | `BoolType -> bool_sort - | `StrType -> str_sort - | `I32Type -> bv32_sort - | `I64Type -> bv64_sort - | `F32Type -> fp32_sort - | `F64Type -> fp64_sort - -let encode_bool ~(to_bv : bool) (cond : Z3.Expr.expr) : Z3.Expr.expr = - let bv_true = Z3.BitVector.mk_numeral ctx "1" 32 - and bv_false = Z3.BitVector.mk_numeral ctx "0" 32 in - if to_bv then Z3.Boolean.mk_ite ctx cond bv_true bv_false else cond - -module IntZ3Op = struct - open I - open Z3 - - let int2str = FuncDecl.mk_func_decl_s ctx "IntToString" [ int_sort ] str_sort - let str2int = FuncDecl.mk_func_decl_s ctx "StringToInt" [ str_sort ] int_sort - let encode_num (i : Int.t) : Expr.expr = Expr.mk_numeral_int ctx i int_sort - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = match op with Neg -> Arithmetic.mk_unary_minus ctx in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Add -> fun v1 v2 -> Arithmetic.mk_add ctx [ v1; v2 ] - | Sub -> fun v1 v2 -> Arithmetic.mk_sub ctx [ v1; v2 ] - | Mul -> fun v1 v2 -> Arithmetic.mk_mul ctx [ v1; v2 ] - | Div -> Arithmetic.mk_div ctx - | Rem -> Arithmetic.Integer.mk_rem ctx - | Pow -> Arithmetic.mk_power ctx - | _ -> raise (Error "Unsupported integer operations") - in - op' e1 e2 - - let encode_relop (op : relop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> Boolean.mk_eq ctx - | Ne -> fun v1 v2 -> Boolean.mk_eq ctx v1 v2 |> Boolean.mk_not ctx - | Lt -> Arithmetic.mk_lt ctx - | Gt -> Arithmetic.mk_gt ctx - | Le -> Arithmetic.mk_le ctx - | Ge -> Arithmetic.mk_ge ctx - in - op' e1 e2 - - let encode_cvtop (op : cvtop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | ToString -> fun v -> FuncDecl.apply int2str [ v ] - | OfString -> fun v -> FuncDecl.apply str2int [ v ] - in - op' e - - let encode_triop (_ : triop) (_ : Expr.expr) (_ : Expr.expr) (_ : Expr.expr) : - Expr.expr = - assert false -end - -module RealZ3Op = struct - open R - open Z3 - - let real2str = - FuncDecl.mk_func_decl_s ctx "RealToString" [ real_sort ] str_sort - - let str2real = - FuncDecl.mk_func_decl_s ctx "StringToReal" [ str_sort ] real_sort - - let encode_num (f : Float.t) : Expr.expr = - Arithmetic.Real.mk_numeral_s ctx (Float.to_string f) - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | Neg -> Arithmetic.mk_unary_minus ctx - | Abs -> - fun e -> - Boolean.mk_ite ctx - (Arithmetic.mk_gt ctx e (encode_num 0.)) - e - (Arithmetic.mk_unary_minus ctx e) - | Sqrt -> fun e -> Arithmetic.mk_power ctx e (encode_num 0.5) - | Nearest | IsNan -> assert false - in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Add -> fun v1 v2 -> Arithmetic.mk_add ctx [ v1; v2 ] - | Sub -> fun v1 v2 -> Arithmetic.mk_sub ctx [ v1; v2 ] - | Mul -> fun v1 v2 -> Arithmetic.mk_mul ctx [ v1; v2 ] - | Div -> Arithmetic.mk_div ctx - | Min -> - fun v1 v2 -> Boolean.mk_ite ctx (Arithmetic.mk_le ctx v1 v2) v1 v2 - | Max -> - fun v1 v2 -> Boolean.mk_ite ctx (Arithmetic.mk_ge ctx v1 v2) v1 v2 - | _ -> assert false - in - op' e1 e2 - - let encode_relop (op : relop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> Boolean.mk_eq ctx - | Ne -> fun v1 v2 -> Boolean.mk_eq ctx v1 v2 |> Boolean.mk_not ctx - | Lt -> Arithmetic.mk_lt ctx - | Gt -> Arithmetic.mk_gt ctx - | Le -> Arithmetic.mk_le ctx - | Ge -> Arithmetic.mk_ge ctx - in - op' e1 e2 - - let encode_cvtop (op : cvtop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | ToString -> fun v -> FuncDecl.apply real2str [ v ] - | OfString -> fun v -> FuncDecl.apply str2real [ v ] - | DemoteF64 | ConvertSI32 | ConvertUI32 | ConvertSI64 | ConvertUI64 - | ReinterpretInt | PromoteF32 -> - assert false - in - op' e - - let encode_triop (_ : triop) (_ : Expr.expr) (_ : Expr.expr) (_ : Expr.expr) : - Expr.expr = - assert false -end - -module BoolZ3Op = struct - open B - open Z3 - - let encode_bool (b : Bool.t) : Expr.expr = Boolean.mk_val ctx b - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = match op with Not -> Boolean.mk_not ctx in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | And -> fun v1 v2 -> Boolean.mk_and ctx [ v1; v2 ] - | Or -> fun v1 v2 -> Boolean.mk_or ctx [ v1; v2 ] - | Xor -> Boolean.mk_xor ctx - in - op' e1 e2 - - let encode_relop (op : relop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> Boolean.mk_eq ctx - | Ne -> fun v1 v2 -> Boolean.mk_eq ctx v1 v2 |> Boolean.mk_not ctx - in - op' e1 e2 - - let encode_cvtop (_ : cvtop) (_ : Expr.expr) : Expr.expr = assert false - - let encode_triop (op : triop) (e1 : Expr.expr) (e2 : Expr.expr) - (e3 : Expr.expr) : Expr.expr = - let op' = match op with ITE -> Boolean.mk_ite ctx in - op' e1 e2 e3 -end - -module StrZ3Op = struct - open S - open Z3 - - let encode_str (s : String.t) : Expr.expr = Seq.mk_string ctx s - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = match op with Len -> Seq.mk_seq_length ctx in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Nth -> - fun v1 v2 -> - Seq.mk_seq_extract ctx v1 v2 (Expr.mk_numeral_int ctx 1 int_sort) - | Concat -> fun v1 v2 -> Seq.mk_seq_concat ctx [ v1; v2 ] - in - op' e1 e2 - - let encode_relop (op : relop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> Boolean.mk_eq ctx - | Ne -> fun v1 v2 -> Boolean.mk_eq ctx v1 v2 |> Boolean.mk_not ctx - in - op' e1 e2 - - let encode_triop (op : triop) (e1 : Expr.expr) (e2 : Expr.expr) - (e3 : Expr.expr) : Expr.expr = - let op' = match op with SubStr -> Seq.mk_seq_extract ctx in - op' e1 e2 e3 - - let encode_cvtop (_ : cvtop) (_ : Expr.expr) : Expr.expr = assert false -end - -module I32Z3Op = struct - open I32 - open Z3 - - let encode_num (i : Int32.t) : Expr.expr = - Expr.mk_numeral_int ctx (Int32.to_int_exn i) bv32_sort - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | Not -> BitVector.mk_not ctx - | Clz -> failwith "I32Z3Op: Clz not supported yet" - in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Add -> BitVector.mk_add ctx - | Sub -> BitVector.mk_sub ctx - | Mul -> BitVector.mk_mul ctx - | DivS -> BitVector.mk_sdiv ctx - | DivU -> BitVector.mk_udiv ctx - | And -> BitVector.mk_and ctx - | Xor -> BitVector.mk_xor ctx - | Or -> BitVector.mk_or ctx - | Shl -> BitVector.mk_shl ctx - | ShrS -> BitVector.mk_ashr ctx - | ShrU -> BitVector.mk_lshr ctx - | RemS -> BitVector.mk_srem ctx - | RemU -> BitVector.mk_urem ctx - in - op' e1 e2 - - let encode_relop ?(to_bv = false) (op : relop) (e1 : Expr.expr) - (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> Boolean.mk_eq ctx - | Ne -> fun x1 x2 -> Boolean.mk_eq ctx x1 x2 |> Boolean.mk_not ctx - | LtU -> BitVector.mk_ult ctx - | LtS -> BitVector.mk_slt ctx - | LeU -> BitVector.mk_ule ctx - | LeS -> BitVector.mk_sle ctx - | GtU -> BitVector.mk_ugt ctx - | GtS -> BitVector.mk_sgt ctx - | GeU -> BitVector.mk_uge ctx - | GeS -> BitVector.mk_sge ctx - in - encode_bool ~to_bv (op' e1 e2) - - let encode_cvtop (op : cvtop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | TruncSF32 -> fun f -> FloatingPoint.mk_to_sbv ctx rtz f 32 - | TruncUF32 -> fun f -> FloatingPoint.mk_to_ubv ctx rtz f 32 - | TruncSF64 -> fun f -> FloatingPoint.mk_to_sbv ctx rtz f 32 - | TruncUF64 -> fun f -> FloatingPoint.mk_to_ubv ctx rtz f 32 - | ReinterpretFloat -> FloatingPoint.mk_to_ieee_bv ctx - | WrapI64 | ExtendSI32 | ExtendUI32 -> assert false - in - op' e - - let encode_triop (_ : triop) (_ : Expr.expr) (_ : Expr.expr) (_ : Expr.expr) : - Expr.expr = - assert false -end - -module I64Z3Op = struct - open I64 - open Z3 - - let encode_num (i : Int64.t) : Expr.expr = - Expr.mk_numeral_int ctx (Int64.to_int_exn i) bv64_sort - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | Not -> BitVector.mk_not ctx - | Clz -> failwith "I64Z3Op: clz supported yet" - in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Add -> BitVector.mk_add ctx - | Sub -> BitVector.mk_sub ctx - | Mul -> BitVector.mk_mul ctx - | DivS -> BitVector.mk_sdiv ctx - | DivU -> BitVector.mk_udiv ctx - | And -> BitVector.mk_and ctx - | Xor -> BitVector.mk_xor ctx - | Or -> BitVector.mk_or ctx - | Shl -> BitVector.mk_shl ctx - | ShrS -> BitVector.mk_ashr ctx - | ShrU -> BitVector.mk_lshr ctx - | RemS -> BitVector.mk_srem ctx - | RemU -> BitVector.mk_urem ctx - in - op' e1 e2 - - let encode_relop ?(to_bv = false) (op : relop) (e1 : Expr.expr) - (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> Boolean.mk_eq ctx - | Ne -> fun x1 x2 -> Boolean.mk_eq ctx x1 x2 |> Boolean.mk_not ctx - | LtU -> BitVector.mk_ult ctx - | LtS -> BitVector.mk_slt ctx - | LeU -> BitVector.mk_ule ctx - | LeS -> BitVector.mk_sle ctx - | GtU -> BitVector.mk_ugt ctx - | GtS -> BitVector.mk_sgt ctx - | GeU -> BitVector.mk_uge ctx - | GeS -> BitVector.mk_sge ctx - in - encode_bool ~to_bv (op' e1 e2) - - let encode_cvtop (op : cvtop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | ExtendSI32 -> BitVector.mk_sign_ext ctx 32 - | ExtendUI32 -> BitVector.mk_zero_ext ctx 32 - (* rounding towards zero (aka truncation) *) - | TruncSF32 -> fun f -> FloatingPoint.mk_to_sbv ctx rtz f 64 - | TruncUF32 -> fun f -> FloatingPoint.mk_to_ubv ctx rtz f 64 - | TruncSF64 -> fun f -> FloatingPoint.mk_to_sbv ctx rtz f 64 - | TruncUF64 -> fun f -> FloatingPoint.mk_to_ubv ctx rtz f 64 - | ReinterpretFloat -> FloatingPoint.mk_to_ieee_bv ctx - | WrapI64 -> assert false - in - op' e - - let encode_triop (_ : triop) (_ : Expr.expr) (_ : Expr.expr) (_ : Expr.expr) : - Expr.expr = - assert false -end - -module F32Z3Op = struct - open F32 - open Z3 - - let f322str = FuncDecl.mk_func_decl_s ctx "F32ToString" [ fp32_sort ] str_sort - let str2f32 = FuncDecl.mk_func_decl_s ctx "StringToF32" [ str_sort ] fp32_sort - - let encode_num (f : Int32.t) : Expr.expr = - FloatingPoint.mk_numeral_f ctx (Int32.float_of_bits f) fp32_sort - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | Neg -> FloatingPoint.mk_neg ctx - | Abs -> FloatingPoint.mk_abs ctx - | Sqrt -> FloatingPoint.mk_sqrt ctx rne - | Nearest -> FloatingPoint.mk_round_to_integral ctx rne - | IsNan -> FloatingPoint.mk_is_nan ctx - in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Add -> FloatingPoint.mk_add ctx rne - | Sub -> FloatingPoint.mk_sub ctx rne - | Mul -> FloatingPoint.mk_mul ctx rne - | Div -> FloatingPoint.mk_div ctx rne - | Min -> FloatingPoint.mk_min ctx - | Max -> FloatingPoint.mk_max ctx - | Rem -> FloatingPoint.mk_rem ctx - in - op' e1 e2 - - let encode_relop ?(to_bv = false) (op : relop) (e1 : Expr.expr) - (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> FloatingPoint.mk_eq ctx - | Ne -> fun x1 x2 -> FloatingPoint.mk_eq ctx x1 x2 |> Boolean.mk_not ctx - | Lt -> FloatingPoint.mk_lt ctx - | Le -> FloatingPoint.mk_leq ctx - | Gt -> FloatingPoint.mk_gt ctx - | Ge -> FloatingPoint.mk_geq ctx - in - encode_bool ~to_bv (op' e1 e2) - - let encode_cvtop (op : cvtop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | DemoteF64 -> fun bv -> FloatingPoint.mk_to_fp_float ctx rne bv fp32_sort - | ConvertSI32 -> - fun bv -> FloatingPoint.mk_to_fp_signed ctx rne bv fp32_sort - | ConvertUI32 -> - fun bv -> FloatingPoint.mk_to_fp_unsigned ctx rne bv fp32_sort - | ConvertSI64 -> - fun bv -> FloatingPoint.mk_to_fp_signed ctx rne bv fp32_sort - | ConvertUI64 -> - fun bv -> FloatingPoint.mk_to_fp_unsigned ctx rne bv fp32_sort - | ReinterpretInt -> fun bv -> FloatingPoint.mk_to_fp_bv ctx bv fp32_sort - | ToString -> fun v -> FuncDecl.apply f322str [ v ] - | OfString -> fun v -> FuncDecl.apply str2f32 [ v ] - | PromoteF32 -> assert false - in - op' e - - let encode_triop (_ : triop) (_ : Expr.expr) (_ : Expr.expr) (_ : Expr.expr) : - Expr.expr = - assert false -end - -module F64Z3Op = struct - open F64 - open Z3 - - let f642str = FuncDecl.mk_func_decl_s ctx "F64ToString" [ fp64_sort ] str_sort - let str2f64 = FuncDecl.mk_func_decl_s ctx "StringToF64" [ str_sort ] fp64_sort - - let encode_num (f : Int64.t) : Expr.expr = - FloatingPoint.mk_numeral_f ctx (Int64.float_of_bits f) fp64_sort - - let encode_unop (op : unop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | Neg -> FloatingPoint.mk_neg ctx - | Abs -> FloatingPoint.mk_abs ctx - | Sqrt -> FloatingPoint.mk_sqrt ctx rne - | Nearest -> FloatingPoint.mk_round_to_integral ctx rne - | IsNan -> FloatingPoint.mk_is_nan ctx - in - op' e - - let encode_binop (op : binop) (e1 : Expr.expr) (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Add -> FloatingPoint.mk_add ctx rne - | Sub -> FloatingPoint.mk_sub ctx rne - | Mul -> FloatingPoint.mk_mul ctx rne - | Div -> FloatingPoint.mk_div ctx rne - | Min -> FloatingPoint.mk_min ctx - | Max -> FloatingPoint.mk_max ctx - | Rem -> FloatingPoint.mk_rem ctx - in - op' e1 e2 - - let encode_relop ?(to_bv = false) (op : relop) (e1 : Expr.expr) - (e2 : Expr.expr) : Expr.expr = - let op' = - match op with - | Eq -> FloatingPoint.mk_eq ctx - | Ne -> fun x1 x2 -> FloatingPoint.mk_eq ctx x1 x2 |> Boolean.mk_not ctx - | Lt -> FloatingPoint.mk_lt ctx - | Le -> FloatingPoint.mk_leq ctx - | Gt -> FloatingPoint.mk_gt ctx - | Ge -> FloatingPoint.mk_geq ctx - in - encode_bool ~to_bv (op' e1 e2) - - let encode_cvtop (op : cvtop) (e : Expr.expr) : Expr.expr = - let op' = - match op with - | PromoteF32 -> - fun bv -> FloatingPoint.mk_to_fp_float ctx rne bv fp64_sort - | ConvertSI32 -> - fun bv -> FloatingPoint.mk_to_fp_signed ctx rne bv fp64_sort - | ConvertUI32 -> - fun bv -> FloatingPoint.mk_to_fp_unsigned ctx rne bv fp64_sort - | ConvertSI64 -> - fun bv -> FloatingPoint.mk_to_fp_signed ctx rne bv fp64_sort - | ConvertUI64 -> - fun bv -> FloatingPoint.mk_to_fp_unsigned ctx rne bv fp64_sort - | ReinterpretInt -> fun bv -> FloatingPoint.mk_to_fp_bv ctx bv fp64_sort - | ToString -> fun v -> FuncDecl.apply f642str [ v ] - | OfString -> fun v -> FuncDecl.apply str2f64 [ v ] - | DemoteF64 -> assert false - in - op' e - - let encode_triop (_ : triop) (_ : Expr.expr) (_ : Expr.expr) (_ : Expr.expr) : - Expr.expr = - assert false -end - -let num i32 i64 f32 f64 : Num.t -> Z3.Expr.expr = function - | I32 x -> i32 x - | I64 x -> i64 x - | F32 x -> f32 x - | F64 x -> f64 x - -let encode_num : Num.t -> Z3.Expr.expr = - num I32Z3Op.encode_num I64Z3Op.encode_num F32Z3Op.encode_num - F64Z3Op.encode_num - -let encode_unop : unop -> Z3.Expr.expr -> Z3.Expr.expr = - op IntZ3Op.encode_unop RealZ3Op.encode_unop BoolZ3Op.encode_unop - StrZ3Op.encode_unop I32Z3Op.encode_unop I64Z3Op.encode_unop - F32Z3Op.encode_unop F64Z3Op.encode_unop - -let encode_binop : binop -> Z3.Expr.expr -> Z3.Expr.expr -> Z3.Expr.expr = - op IntZ3Op.encode_binop RealZ3Op.encode_binop BoolZ3Op.encode_binop - StrZ3Op.encode_binop I32Z3Op.encode_binop I64Z3Op.encode_binop - F32Z3Op.encode_binop F64Z3Op.encode_binop - -let encode_triop : - triop -> Z3.Expr.expr -> Z3.Expr.expr -> Z3.Expr.expr -> Z3.Expr.expr = - op IntZ3Op.encode_triop RealZ3Op.encode_triop BoolZ3Op.encode_triop - StrZ3Op.encode_triop I32Z3Op.encode_triop I64Z3Op.encode_triop - F32Z3Op.encode_triop F64Z3Op.encode_triop - -let encode_relop ~to_bv : relop -> Z3.Expr.expr -> Z3.Expr.expr -> Z3.Expr.expr - = - op IntZ3Op.encode_relop RealZ3Op.encode_relop BoolZ3Op.encode_relop - StrZ3Op.encode_relop - (I32Z3Op.encode_relop ~to_bv) - (I64Z3Op.encode_relop ~to_bv) - (F32Z3Op.encode_relop ~to_bv) - (F64Z3Op.encode_relop ~to_bv) - -let encode_cvtop : cvtop -> Z3.Expr.expr -> Z3.Expr.expr = - op IntZ3Op.encode_cvtop RealZ3Op.encode_cvtop BoolZ3Op.encode_cvtop - StrZ3Op.encode_cvtop I32Z3Op.encode_cvtop I64Z3Op.encode_cvtop - F32Z3Op.encode_cvtop F64Z3Op.encode_cvtop - -let encode_quantifier (t : bool) (vars_list : Symbol.t list) - (body : Z3.Expr.expr) (patterns : Z3.Quantifier.Pattern.pattern list) : - Z3.Expr.expr = - if List.length vars_list > 0 then - let quantified_assertion = - Z3.Quantifier.mk_quantifier_const ctx t - (List.map vars_list ~f:(fun s -> - Z3.Expr.mk_const_s ctx (Symbol.to_string s) - (get_sort (Symbol.type_of s)))) - body None patterns [] None None - in - let quantified_assertion = - Z3.Quantifier.expr_of_quantifier quantified_assertion - in - let quantified_assertion = Z3.Expr.simplify quantified_assertion None in - quantified_assertion - else body - -let rec encode_expr ?(bool_to_bv = false) (e : Expression.t) : Z3.Expr.expr = - let open Expression in - match e with - | Val (Int i) -> IntZ3Op.encode_num i - | Val (Real r) -> RealZ3Op.encode_num r - | Val (Bool b) -> BoolZ3Op.encode_bool b - | Val (Num v) -> encode_num v - | Val (Str s) -> StrZ3Op.encode_str s - | SymPtr (base, offset) -> - let base' = encode_num (I32 base) in - let offset' = encode_expr offset in - I32Z3Op.encode_binop I32.Add base' offset' - | Unop (op, e) -> - let e' = encode_expr e in - encode_unop op e' - | Binop ((Int _ as op), e1, e2) | Binop ((Bool _ as op), e1, e2) -> - let e1' = encode_expr e1 and e2' = encode_expr e2 in - encode_binop op e1' e2' - | Binop (op, e1, e2) -> - let e1' = encode_expr ~bool_to_bv:true e1 - and e2' = encode_expr ~bool_to_bv:true e2 in - encode_binop op e1' e2' - | Triop (op, e1, e2, e3) -> - let e1' = encode_expr ~bool_to_bv e1 - and e2' = encode_expr ~bool_to_bv e2 - and e3' = encode_expr ~bool_to_bv e3 in - encode_triop op e1' e2' e3' - | Relop ((Int _ as op), e1, e2) | Relop ((Bool _ as op), e1, e2) -> - let e1' = encode_expr e1 and e2' = encode_expr e2 in - encode_relop ~to_bv:false op e1' e2' - | Relop (op, e1, e2) -> - let e1' = encode_expr ~bool_to_bv:true e1 - and e2' = encode_expr ~bool_to_bv:true e2 in - encode_relop ~to_bv:bool_to_bv op e1' e2' - | Cvtop (op, e) -> - let e' = encode_expr e in - encode_cvtop op e' - | Symbol s -> - let x = Symbol.to_string s and t = Symbol.type_of s in - Z3.Expr.mk_const_s ctx x (get_sort t) - | Extract (e, h, l) -> - let e' = encode_expr ~bool_to_bv:true e in - Z3.BitVector.mk_extract ctx ((h * 8) - 1) (l * 8) e' - | Concat (e1, e2) -> - let e1' = encode_expr e1 and e2' = encode_expr e2 in - Z3.BitVector.mk_concat ctx e1' e2' - | Quantifier (t, vars, body, patterns) -> - let body' = encode_expr body in - let encode_pattern p = - Z3.Quantifier.mk_pattern ctx (List.map ~f:encode_expr p) - in - let patterns' = List.map ~f:encode_pattern patterns in - let t' = match t with Forall -> true | Exists -> false in - encode_quantifier t' vars body' patterns' - -let expr_to_smtstring (es : Expression.t list) (status : bool) = - let es' = List.map ~f:encode_expr es in - Z3.Params.set_print_mode ctx Z3enums.PRINT_SMTLIB2_COMPLIANT; - Z3.SMT.benchmark_to_smtstring ctx "" "" (Bool.to_string status) "" - (List.tl_exn es') (List.hd_exn es') - -let set (s : string) (i : int) (n : char) = - let bs = Bytes.of_string s in - Bytes.set bs i n; - Bytes.to_string bs - -let int64_of_bv (bv : Z3.Expr.expr) : int64 = - assert (Z3.Expr.is_numeral bv); - Int64.of_string (Z3.BitVector.numeral_to_string bv) - -let int64_of_fp (fp : Z3.Expr.expr) ~(ebits : int) ~(sbits : int) : int64 = - assert (Z3.Expr.is_numeral fp); - if Z3.FloatingPoint.is_numeral_nan ctx fp then - if Z3.FloatingPoint.is_numeral_negative ctx fp then - if sbits = 23 then Int64.of_int32 0xffc0_0000l else 0xfff8_0000_0000_0000L - else if sbits = 23 then Int64.of_int32 0x7fc0_0000l - else 0x7ff8_0000_0000_0000L - else if Z3.FloatingPoint.is_numeral_inf ctx fp then - if Z3.FloatingPoint.is_numeral_negative ctx fp then - if sbits = 23 then Int64.of_int32 (Int32.bits_of_float (-.(1.0 /. 0.0))) - else Int64.bits_of_float (-.(1.0 /. 0.0)) - else if sbits = 23 then Int64.of_int32 (Int32.bits_of_float (1.0 /. 0.0)) - else Int64.bits_of_float (1.0 /. 0.0) - else if Z3.FloatingPoint.is_numeral_zero ctx fp then - if Z3.FloatingPoint.is_numeral_negative ctx fp then - if sbits = 23 then Int64.of_int32 0x8000_0000l else 0x8000_0000_0000_0000L - else if sbits = 23 then Int64.of_int32 (Int32.bits_of_float 0.0) - else Int64.bits_of_float 0.0 - else - let fp = Z3.Expr.to_string fp in - let fp = Stdlib.String.sub fp 4 (String.length fp - 5) in - let fp_list = - List.map ~f:(fun fp -> set fp 0 '0') (String.split ~on:' ' fp) - in - let bit_list = List.map ~f:(fun fp -> Int64.of_string fp) fp_list in - let fp_sign = Int64.shift_left (List.nth_exn bit_list 0) (ebits + sbits) - and exponent = Int64.shift_left (List.nth_exn bit_list 1) sbits - and fraction = List.nth_exn bit_list 2 in - Int64.(fp_sign lor (exponent lor fraction)) - -let value_of_const (model : Z3.Model.model) (c : Expression.t) : Value.t option - = - let t = Expression.type_of c - and interp = Z3.Model.eval model (encode_expr c) true in - let f (e : Z3.Expr.expr) : Value.t = - match (t, Z3.Sort.get_sort_kind (Z3.Expr.get_sort e)) with - | `IntType, Z3enums.INT_SORT -> - Int (Int.of_string (Z3.Arithmetic.Integer.numeral_to_string e)) - | `RealType, Z3enums.REAL_SORT -> - Real (Float.of_string (Z3.Arithmetic.Real.to_decimal_string e 6)) - | `BoolType, Z3enums.BOOL_SORT -> - Bool (Bool.of_string (Z3.Expr.to_string e)) - | `StrType, Z3enums.SEQ_SORT -> Str (Z3.Seq.get_string ctx e) - | `I32Type, Z3enums.BV_SORT -> - Num (I32 (Int64.to_int32_trunc (int64_of_bv e))) - | `I64Type, Z3enums.BV_SORT -> Num (I64 (int64_of_bv e)) - | `F32Type, Z3enums.FLOATING_POINT_SORT -> - let ebits = Z3.FloatingPoint.get_ebits ctx (Z3.Expr.get_sort e) - and sbits = Z3.FloatingPoint.get_sbits ctx (Z3.Expr.get_sort e) - 1 in - Num (F32 (Int64.to_int32_trunc (int64_of_fp e ~ebits ~sbits))) - | `F64Type, Z3enums.FLOATING_POINT_SORT -> - let ebits = Z3.FloatingPoint.get_ebits ctx (Z3.Expr.get_sort e) - and sbits = Z3.FloatingPoint.get_sbits ctx (Z3.Expr.get_sort e) - 1 in - Num (F64 (int64_of_fp e ~ebits ~sbits)) - | _ -> assert false - in - Option.map ~f interp - -let type_of_sort (sort : Z3.Sort.sort) : expr_type = - match Z3.Sort.get_sort_kind sort with - | Z3enums.INT_SORT -> `IntType - | Z3enums.REAL_SORT -> `RealType - | Z3enums.BOOL_SORT -> `BoolType - | Z3enums.SEQ_SORT -> `StrType - | Z3enums.BV_SORT -> - if Z3.BitVector.get_size sort = 32 then `I32Type else `I64Type - | Z3enums.FLOATING_POINT_SORT -> - if Z3.FloatingPoint.get_sbits ctx sort = 23 then `F32Type else `F64Type - | _ -> assert false - -let symbols_of_model (model : Z3.Model.model) : Symbol.t list = - List.map (Z3.Model.get_const_decls model) ~f:(fun const -> - let x = Z3.Symbol.to_string (Z3.FuncDecl.get_name const) in - let t = type_of_sort (Z3.FuncDecl.get_range const) in - Symbol.mk_symbol t x) - -let model_binds (model : Z3.Model.model) (symbols : Symbol.t list) : - (Symbol.t * Value.t) list = - List.fold_left symbols ~init:[] ~f:(fun a s -> - let v = value_of_const model (Expression.mk_symbol s) in - Option.fold ~init:a ~f:(fun a v' -> (s, v') :: a) v) - -let value_binds ?(symbols : Symbol.t list option) (model : Z3.Model.model) : - (Symbol.t * Value.t) list = - let symbols' = Option.value symbols ~default:(symbols_of_model model) in - model_binds model symbols' - -let string_binds (m : Z3.Model.model) : (string * string * string) list = - List.map (Z3.Model.get_const_decls m) ~f:(fun const -> - let sort = Z3.Sort.to_string (Z3.FuncDecl.get_range const) - and name = Z3.Symbol.to_string (Z3.FuncDecl.get_name const) - and interp = - Option.value_map ~default:"" ~f:Z3.Expr.to_string - (Z3.Model.get_const_interp m const) - in - (sort, name, interp)) diff --git a/encoding/lib/mappings/z3_mappings.mli b/encoding/lib/mappings/z3_mappings.mli deleted file mode 100644 index c903c837..00000000 --- a/encoding/lib/mappings/z3_mappings.mli +++ /dev/null @@ -1,11 +0,0 @@ -exception Error of string - -val ctx : Z3.context -val encode_expr : ?bool_to_bv:bool -> Expression.t -> Z3.Expr.expr -val expr_to_smtstring : Expression.t list -> bool -> string -val value_of_const : Z3.Model.model -> Expression.t -> Value.t option - -val value_binds : - ?symbols:Symbol.t list -> Z3.Model.model -> (Symbol.t * Value.t) list - -val string_binds : Z3.Model.model -> (string * string * string) list diff --git a/encoding/lib/operators/boolOp.ml b/encoding/lib/operators/boolOp.ml deleted file mode 100644 index 97ac088b..00000000 --- a/encoding/lib/operators/boolOp.ml +++ /dev/null @@ -1,27 +0,0 @@ -type binop = And | Or | Xor -type unop = Not -type relop = Eq | Ne -type triop = ITE -type cvtop - -let neg_relop (op : relop) : relop = match op with Eq -> Ne | Ne -> Eq - -let string_of_binop (op : binop) : string = - match op with And -> "And" | Or -> "Or" | Xor -> "Xor" - -let pp_string_of_binop (op : binop) : string = - match op with And -> "&&" | Or -> "||" | Xor -> "^" - -let string_of_unop (op : unop) : string = match op with Not -> "Not" -let pp_string_of_unop (op : unop) : string = match op with Not -> "!" - -let string_of_relop (op : relop) : string = - match op with Eq -> "Eq" | Ne -> "Ne" - -let pp_string_of_relop (op : relop) : string = - match op with Eq -> "==" | Ne -> "!=" - -let string_of_cvtop (_ : cvtop) : string = assert false -let pp_string_of_cvtop (_ : cvtop) : string = assert false -let string_of_triop (op : triop) : string = match op with ITE -> "ITE" -let pp_string_of_triop (op : triop) : string = string_of_triop op diff --git a/encoding/lib/operators/bvOp.ml b/encoding/lib/operators/bvOp.ml deleted file mode 100644 index 9664f0e6..00000000 --- a/encoding/lib/operators/bvOp.ml +++ /dev/null @@ -1,123 +0,0 @@ -type binop = - | Add - | Mul - | DivU - | RemU - | ShrU - | And - | Sub - | Shl - | DivS - | RemS - | ShrS - | Or - | Xor - -type unop = Not | Clz (* Falta: Ctz | Popcnt *) -type relop = Eq | LtU | LtS | LeU | LeS | Ne | GtU | GtS | GeU | GeS -type triop - -type cvtop = - | TruncSF32 - | TruncUF32 - | TruncSF64 - | TruncUF64 - | ReinterpretFloat - | WrapI64 - | ExtendSI32 - | ExtendUI32 - -let neg_relop (op : relop) : relop = - match op with - | Eq -> Ne - | Ne -> Eq - | LtU -> GeU - | LtS -> GeS - | GtU -> LeU - | GtS -> LeS - | LeU -> GtU - | LeS -> GtS - | GeU -> LtU - | GeS -> LtS - -(* String representation of an i32 binary operation *) -let string_of_binop (op : binop) : string = - match op with - | Add -> "Add" - | And -> "And" - | Or -> "Or" - | Sub -> "Sub" - | DivS -> "DivS" - | DivU -> "DivU" - | Xor -> "Xor" - | Mul -> "Mul" - | Shl -> "Shl" - | ShrS -> "ShrS" - | ShrU -> "ShrU" - | RemS -> "RemS" - | RemU -> "RemU" - -let pp_string_of_binop (op : binop) : string = - match op with - | Add -> "+" - | And -> "&" - | Or -> "|" - | Sub -> "-" - | DivS -> "/" - | DivU -> "/u" - | Xor -> "^" - | Mul -> "*" - | Shl -> "<<" - | ShrS -> ">>" - | ShrU -> ">>u" - | RemS -> "%" - | RemU -> "%u" - -(* String representation of an i32 unary operation *) -let string_of_unop (op : unop) : string = - match op with Clz -> "Clz" | Not -> "Not" - -let pp_string_of_unop (op : unop) : string = - match op with Clz -> "Clz" | Not -> "Not" - -(* String representation of an i32 relative operation *) -let string_of_relop (op : relop) : string = - match op with - | Eq -> "Eq" - | Ne -> "Ne" - | LtU -> "LtU" - | LtS -> "LtS" - | GtU -> "GtU" - | GtS -> "GtS" - | LeU -> "LeU" - | LeS -> "LeS" - | GeU -> "GeU" - | GeS -> "GeS" - -let pp_string_of_relop (op : relop) : string = - match op with - | Eq -> "==" - | Ne -> "!=" - | LtU -> "<" - | LtS -> "<" - | GtU -> ">" - | GtS -> ">" - | LeU -> "<=" - | LeS -> "<=" - | GeU -> ">=" - | GeS -> ">=" - -let string_of_cvtop (op : cvtop) : string = - match op with - | WrapI64 -> "WrapI64" - | TruncSF32 -> "TruncSF32" - | TruncUF32 -> "TruncUF32" - | TruncSF64 -> "TruncSF64" - | TruncUF64 -> "TruncUF64" - | ReinterpretFloat -> "ReinterpretFloat" - | ExtendSI32 -> "ExtendSI32" - | ExtendUI32 -> "ExtendUI32" - -let pp_string_of_cvtop (op : cvtop) : string = string_of_cvtop op -let string_of_triop (_ : triop) : string = assert false -let pp_string_of_triop (_ : triop) : string = assert false diff --git a/encoding/lib/operators/floatOp.ml b/encoding/lib/operators/floatOp.ml deleted file mode 100644 index 386df8de..00000000 --- a/encoding/lib/operators/floatOp.ml +++ /dev/null @@ -1,104 +0,0 @@ -type binop = Add | Sub | Mul | Div | Min | Max | Rem (* Falta: | CopySign *) - -type unop = - | Neg - | Abs - | Sqrt - | Nearest - | IsNan (* Falta: | Ceil | Floor | Trunc *) - -type relop = Eq | Ne | Lt | Le | Gt | Ge -type triop - -type cvtop = - | DemoteF64 - | ConvertSI32 - | ConvertUI32 - | ConvertSI64 - | ConvertUI64 - | ReinterpretInt - | PromoteF32 - | ToString - | OfString - -let neg_relop (op : relop) : relop = - match op with - | Eq -> Ne - | Ne -> Eq - | Lt -> Ge - | Gt -> Le - | Le -> Gt - | Ge -> Lt - -(* String representation of an f32 binary operation *) -let string_of_binop (op : binop) : string = - match op with - | Add -> "Add" - | Sub -> "Sub" - | Mul -> "Mul" - | Div -> "Div" - | Min -> "Min" - | Max -> "Max" - | Rem -> "Rem" - -let pp_string_of_binop (op : binop) : string = - match op with - | Add -> "+" - | Sub -> "-" - | Mul -> "*" - | Div -> "/" - | Min -> "Min" - | Max -> "Max" - | Rem -> "%" - -(* String representation of an f32 unary operation *) -let string_of_unop (op : unop) : string = - match op with - | Neg -> "Neg" - | Abs -> "Abs" - | Sqrt -> "Sqrt" - | Nearest -> "Nearest" - | IsNan -> "IsNan" - -let pp_string_of_unop (op : unop) : string = - match op with - | Neg -> "-" - | Abs -> "Abs" - | Sqrt -> "Sqrt" - | Nearest -> "Nearest" - | IsNan -> "IsNan" - -(* String representation of an f32 relative operation *) -let string_of_relop (op : relop) : string = - match op with - | Eq -> "Eq" - | Ne -> "Ne" - | Lt -> "Lt" - | Gt -> "Gt" - | Le -> "Le" - | Ge -> "Ge" - -let pp_string_of_relop (op : relop) : string = - match op with - | Eq -> "==" - | Ne -> "!=" - | Lt -> "<" - | Gt -> ">" - | Le -> "<=" - | Ge -> ">=" - -let string_of_cvtop (op : cvtop) : string = - match op with - | DemoteF64 -> "DemoteF64" - | ConvertSI32 -> "ConvertSI32" - | ConvertUI32 -> "ConvertUI32" - | ConvertSI64 -> "ConvertSI64" - | ConvertUI64 -> "ConvertUI64" - | ReinterpretInt -> "ReinterpretInt" - | PromoteF32 -> "PromoteF32" - | ToString -> "ToString" - | OfString -> "ToString" - -let pp_string_of_cvtop (op : cvtop) : string = string_of_cvtop op -let string_of_triop (_ : triop) : string = assert false -let pp_string_of_triop (_ : triop) : string = assert false diff --git a/encoding/lib/operators/intOp.ml b/encoding/lib/operators/intOp.ml deleted file mode 100644 index c0145675..00000000 --- a/encoding/lib/operators/intOp.ml +++ /dev/null @@ -1,88 +0,0 @@ -type binop = - | Add - | Mul - | Div - | Rem - | And - | Sub - | Shl - | ShrA - | ShrL - | Or - | Xor - | Pow - -type unop = Neg -type relop = Eq | Lt | Le | Ne | Gt | Ge -type triop -type cvtop = ToString | OfString - -let neg_relop (op : relop) : relop = - match op with - | Eq -> Ne - | Ne -> Eq - | Lt -> Ge - | Gt -> Le - | Le -> Gt - | Ge -> Lt - -(* String representation of an i32 binary operation *) -let string_of_binop (op : binop) : string = - match op with - | Add -> "Add" - | And -> "And" - | Or -> "Or" - | Sub -> "Sub" - | Div -> "Div" - | Xor -> "Xor" - | Mul -> "Mul" - | Shl -> "Shl" - | ShrA -> "ShrA" - | ShrL -> "ShrU" - | Rem -> "Rem" - | Pow -> "Pow" - -let pp_string_of_binop (op : binop) : string = - match op with - | Add -> "+" - | And -> "&" - | Or -> "|" - | Sub -> "-" - | Div -> "/" - | Xor -> "^" - | Mul -> "*" - | Shl -> "<<" - | ShrA -> ">>a" - | ShrL -> ">>l" - | Rem -> "%" - | Pow -> "**" - -(* String representation of an i32 unary operation *) -let string_of_unop (op : unop) : string = match op with Neg -> "Neg" -let pp_string_of_unop (op : unop) : string = match op with Neg -> "-" - -(* String representation of an i32 relative operation *) -let string_of_relop (op : relop) : string = - match op with - | Eq -> "Eq" - | Ne -> "Ne" - | Lt -> "Lt" - | Gt -> "Gt" - | Le -> "Le" - | Ge -> "Ge" - -let pp_string_of_relop (op : relop) : string = - match op with - | Eq -> "==" - | Ne -> "!=" - | Lt -> "<" - | Gt -> ">" - | Le -> "<=" - | Ge -> ">=" - -let string_of_cvtop (op : cvtop) : string = - match op with ToString -> "ToString" | OfString -> "OfString" - -let pp_string_of_cvtop (op : cvtop) : string = string_of_cvtop op -let string_of_triop (_ : triop) : string = assert false -let pp_string_of_triop (_ : triop) : string = assert false diff --git a/encoding/lib/operators/strOp.ml b/encoding/lib/operators/strOp.ml deleted file mode 100644 index 0e5be66b..00000000 --- a/encoding/lib/operators/strOp.ml +++ /dev/null @@ -1,25 +0,0 @@ -type binop = Nth | Concat -type unop = Len -type relop = Eq | Ne -type triop = SubStr -type cvtop - -let neg_relop (op : relop) : relop = match op with Eq -> Ne | Ne -> Eq - -let string_of_binop (op : binop) : string = - match op with Nth -> "nth" | Concat -> "concat" - -let pp_string_of_binop (op : binop) : string = string_of_binop op -let string_of_unop (op : unop) : string = match op with Len -> "len" -let pp_string_of_unop (op : unop) : string = string_of_unop op -let string_of_triop (op : triop) : string = match op with SubStr -> "substr" -let pp_string_of_triop (op : triop) : string = string_of_triop op - -let string_of_relop (op : relop) : string = - match op with Eq -> "Eq" | Ne -> "Ne" - -let pp_string_of_relop (op : relop) : string = - match op with Eq -> "==" | Ne -> "!=" - -let string_of_cvtop (_ : cvtop) : string = assert false -let pp_string_of_cvtop (op : cvtop) : string = string_of_cvtop op diff --git a/encoding/lib/optimizers/optimizer.ml b/encoding/lib/optimizers/optimizer.ml deleted file mode 100644 index e0f66cd8..00000000 --- a/encoding/lib/optimizers/optimizer.ml +++ /dev/null @@ -1,41 +0,0 @@ -open Core -open Z3 -open Z3_mappings - -exception Unknown - -type t = Optimize.optimize - -let solver_time = ref 0.0 - -let time_call ~f ~accum = - let start = Stdlib.Sys.time () in - let ret = f () in - accum := !accum +. (Stdlib.Sys.time () -. start); - ret - -let create () : t = Optimize.mk_opt ctx -let push (opt : t) : unit = Optimize.push opt -let pop (opt : t) : unit = Optimize.pop opt - -let add (opt : t) (es : Expression.t list) : unit = - Optimize.add opt (List.map ~f:(encode_expr ~bool_to_bv:false) es) - -let check (opt : t) e (pc : Expression.t list) obj = - push opt; - add opt pc; - ignore (obj opt (encode_expr ~bool_to_bv:false e)); - ignore (time_call ~f:(fun () -> Optimize.check opt) ~accum:solver_time); - let model = Optimize.get_model opt in - pop opt; - model - -let maximize (opt : t) (e : Expression.t) (pc : Expression.t list) : - Value.t option = - let model = check opt e pc Optimize.maximize in - Option.value_map model ~default:None ~f:(fun m -> value_of_const m e) - -let minimize (opt : t) (e : Expression.t) (pc : Expression.t list) : - Value.t option = - let model = check opt e pc Optimize.minimize in - Option.value_map model ~default:None ~f:(fun m -> value_of_const m e) diff --git a/encoding/lib/optimizers/optimizer.mli b/encoding/lib/optimizers/optimizer.mli deleted file mode 100644 index 21233f6a..00000000 --- a/encoding/lib/optimizers/optimizer.mli +++ /dev/null @@ -1,21 +0,0 @@ -open Z3 - -type t - -exception Unknown - -val solver_time : float ref -val create : unit -> t -val push : t -> unit -val pop : t -> unit -val add : t -> Expression.t list -> unit - -val check : - t -> - Expression.t -> - Expression.t list -> - (t -> Expr.expr -> Optimize.handle) -> - Model.model option - -val maximize : t -> Expression.t -> Expression.t list -> Value.t option -val minimize : t -> Expression.t -> Expression.t list -> Value.t option diff --git a/encoding/lib/solvers/batch.ml b/encoding/lib/solvers/batch.ml deleted file mode 100644 index 127569fa..00000000 --- a/encoding/lib/solvers/batch.ml +++ /dev/null @@ -1,78 +0,0 @@ -open Core -open Z3_mappings - -exception Unknown - -type t = { solver : s; pc : Expression.t ref } -and s = Z3.Solver.solver - -let solver_time = ref 0.0 -let solver_count = ref 0 - -let time_call f acc = - let start = Stdlib.Sys.time () in - let ret = f () in - acc := !acc +. (Stdlib.Sys.time () -. start); - ret - -let create () = - { solver = Z3.Solver.mk_solver ctx None; pc = ref (Boolean.mk_val true) } - -let interrupt () = Z3.Tactic.interrupt ctx -let clone (s : t) : t = { s with pc = ref !(s.pc) } - -let add (s : t) (e : Expression.t) : unit = - s.pc := Expression.add_constraint e !(s.pc) - -let get_assertions (s : t) : Expression.t = !(s.pc) - -let set_default_axioms (s : t) : unit = - Z3.Solver.add s.solver (List.map ~f:encode_expr Axioms.axioms) - -let check_sat (s : t) (es : Expression.t list) : bool = - let es' = List.map ~f:encode_expr es in - solver_count := !solver_count + 1; - let sat = time_call (fun () -> Z3.Solver.check s.solver es') solver_time in - match sat with - | Z3.Solver.SATISFIABLE -> true - | Z3.Solver.UNSATISFIABLE -> false - | Z3.Solver.UNKNOWN -> raise Unknown - -let check (s : t) (expr : Expression.t option) : bool = - let expression = - encode_expr - (Option.fold expr ~init:!(s.pc) ~f:(fun f e -> - Expression.add_constraint e f)) - in - solver_count := !solver_count + 1; - let sat = - time_call (fun () -> Z3.Solver.check s.solver [ expression ]) solver_time - in - let b = - match sat with - | Z3.Solver.SATISFIABLE -> true - | Z3.Solver.UNSATISFIABLE -> false - | Z3.Solver.UNKNOWN -> raise Unknown - in - b - -let fork (s : t) (e : Expression.t) : bool * bool = - (check s (Some e), check s (Some (Expression.negate_relop e))) - -let model (s : t) : Z3.Model.model Option.t = Z3.Solver.get_model s.solver - -let eval (s : t) (e : Expression.t) (es : Expression.t list) : Value.t option = - let es' = List.map ~f:encode_expr es in - ignore (time_call (fun () -> Z3.Solver.check s.solver es') solver_time); - Option.value_map (model s) ~default:None ~f:(fun m -> value_of_const m e) - -let value_binds ?(symbols : Symbol.t list option) (s : t) : - (Symbol.t * Value.t) list = - Option.value_map (model s) ~default:[] ~f:(value_binds ?symbols) - -let string_binds (s : t) : (string * string * string) list = - Option.value_map (model s) ~default:[] ~f:string_binds - -let find_model (s : t) (es : Expression.t list) : (Symbol.t * Value.t) list = - if check_sat s es then value_binds ~symbols:(Expression.get_symbols es) s - else [] diff --git a/encoding/lib/solvers/batch.mli b/encoding/lib/solvers/batch.mli deleted file mode 100644 index 10a06d03..00000000 --- a/encoding/lib/solvers/batch.mli +++ /dev/null @@ -1,45 +0,0 @@ -exception Unknown - -type t - -val solver_time : float ref -val solver_count : int ref -val create : unit -> t - -val clone : t -> t -(** [clone solver] makes a copy of the current [solver] *) - -val interrupt : unit -> unit -(** [interrupt ()] sends interrupt signal to SMT solver *) - -val set_default_axioms : t -> unit -(** add default axioms to solver *) - -val add : t -> Expression.t -> unit -(** [add solver e] adds assertion [e] to [solver] *) - -val get_assertions : t -> Expression.t -(** [get_assertions solver] returns the current path condition *) - -val check_sat : t -> Expression.t list -> bool -(** [check_sat solver [e1; ...; en]] checks the satisfiability of the - existing pc with [e1, ..., en] but without adding the expressions - as assertions to the solver *) - -val find_model : t -> Expression.t list -> (Symbol.t * Value.t) list -(** [find_model solver [e1; ...; en]] check the satisfiability of the - expressions [e1, ..., en] and returns a list bindings (x |-> v) - mapping the symbol [x] to its concrete value [v] *) - -val check : t -> Expression.t option -> bool -(** [check solver e] *) - -val eval : t -> Expression.t -> Expression.t list -> Value.t option -(** [eval solver e es] evaluates a possible value of the const [e] in the - the context of the assertions [es] *) - -val fork : t -> Expression.t -> bool * bool -(** [fork solver e] checks the satisfiability of the fork on the condition [e] *) - -val value_binds : ?symbols:Symbol.t list -> t -> (Symbol.t * Value.t) list -val string_binds : t -> (string * string * string) list diff --git a/encoding/lib/solvers/incremental.ml b/encoding/lib/solvers/incremental.ml deleted file mode 100644 index a0804877..00000000 --- a/encoding/lib/solvers/incremental.ml +++ /dev/null @@ -1,59 +0,0 @@ -open Core -open Z3_mappings - -exception Unknown - -let solver_time = ref 0.0 -let solver_count = ref 0 - -let time_call f acc = - let start = Stdlib.Sys.time () in - let ret = f () in - acc := !acc +. (Stdlib.Sys.time () -. start); - ret - -type s = Z3.Solver.solver -type t = { solver : s; pc : Expression.t ref } - -let create () : t = - { solver = Z3.Solver.mk_solver ctx None; pc = ref (Boolean.mk_val true) } - -let interrupt () = Z3.Tactic.interrupt ctx - -let clone (e : t) : t = - { solver = Z3.Solver.translate e.solver ctx; pc = ref !(e.pc) } - -let add (e : t) (c : Expression.t) : unit = - e.pc := Expression.add_constraint c !(e.pc); - let ec = encode_expr ~bool_to_bv:false c in - Z3.Solver.add e.solver [ ec ] - -let get_assertions (e : t) : Expression.t = !(e.pc) - -let check (e : t) (expr : Expression.t option) : bool = - let expr' = - Option.to_list (Option.map ~f:(encode_expr ~bool_to_bv:false) expr) - in - let b = - solver_count := !solver_count + 1; - let sat = - time_call (fun () -> Z3.Solver.check e.solver expr') solver_time - in - match sat with - | Z3.Solver.SATISFIABLE -> true - | Z3.Solver.UNKNOWN -> raise Unknown - | Z3.Solver.UNSATISFIABLE -> false - in - b - -let fork (s : t) (e : Expression.t) : bool * bool = - (check s (Some e), check s (Some (Expression.negate_relop e))) - -let model (e : t) : Z3.Model.model Option.t = Z3.Solver.get_model e.solver - -let value_binds ?(symbols : Symbol.t list option) (e : t) : - (Symbol.t * Value.t) list = - Option.value_map (model e) ~default:[] ~f:(value_binds ?symbols) - -let string_binds (e : t) : (string * string * string) list = - Option.value_map (model e) ~default:[] ~f:string_binds diff --git a/encoding/lib/solvers/incremental.mli b/encoding/lib/solvers/incremental.mli deleted file mode 100644 index 5ea355f5..00000000 --- a/encoding/lib/solvers/incremental.mli +++ /dev/null @@ -1,28 +0,0 @@ -exception Unknown - -type t - -val solver_time : float ref -val solver_count : int ref -val create : unit -> t - -val interrupt : unit -> unit -(** [interrupt ()] sends interrupt signal to SMT solver *) - -val clone : t -> t -(** [clone solver] makes a copy of the current [solver] *) - -val add : t -> Expression.t -> unit -(** [add solver e] adds assertion [e] to [solver] *) - -val get_assertions : t -> Expression.t -(** [get_assertions solver] returns the current path condition *) - -val check : t -> Expression.t option -> bool -(** [check solver e] *) - -val fork : t -> Expression.t -> bool * bool -(** [fork solver e] checks the satisfiability of the fork on the condition [e] *) - -val value_binds : ?symbols:Symbol.t list -> t -> (Symbol.t * Value.t) list -val string_binds : t -> (string * string * string) list diff --git a/encoding/lib/syntax/expression.ml b/encoding/lib/syntax/expression.ml deleted file mode 100644 index 81a3c7ff..00000000 --- a/encoding/lib/syntax/expression.ml +++ /dev/null @@ -1,588 +0,0 @@ -open Core -open Types - -exception InvalidRelop - -type qt = Forall | Exists - -type expr = - | Val of Value.t - | SymPtr of Int32.t * expr - | Unop of unop * expr - | Binop of binop * expr * expr - | Relop of relop * expr * expr - | Cvtop of cvtop * expr - | Triop of triop * expr * expr * expr - | Symbol of Symbol.t - | Extract of expr * Int.t * Int.t - | Concat of expr * expr - | Quantifier of qt * Symbol.t list * expr * expr list list - -type t = expr -type pc = expr List.t - -let ( ++ ) (e1 : expr) (e2 : expr) = Concat (e1, e2) -let mk_symbol (s : Symbol.t) = Symbol s - -let mk_symbol_s (t : expr_type) (x : string) : expr = - Symbol (Symbol.mk_symbol t x) - -let is_num (e : expr) : Bool.t = match e with Val (Num _) -> true | _ -> false -let is_val (e : expr) : Bool.t = match e with Val _ -> true | _ -> false -let is_unop (e : expr) : Bool.t = match e with Unop _ -> true | _ -> false -let is_relop (e : expr) : Bool.t = match e with Relop _ -> true | _ -> false -let is_binop (e : expr) : Bool.t = match e with Binop _ -> true | _ -> false -let is_cvtop (e : expr) : Bool.t = match e with Cvtop _ -> true | _ -> false -let is_triop (e : expr) : Bool.t = match e with Triop _ -> true | _ -> false - -let is_concrete (e : expr) : Bool.t = - match e with Val _ | SymPtr (_, Val _) -> true | _ -> false - -let rec equal (e1 : expr) (e2 : expr) : Bool.t = - match (e1, e2) with - | Val v1, Val v2 -> Value.equal v1 v2 - | SymPtr (b1, o1), SymPtr (b2, o2) -> Int32.(b1 = b2) && equal o1 o2 - | Unop (op1, e1), Unop (op2, e2) -> Stdlib.( = ) op1 op2 && equal e1 e2 - | Cvtop (op1, e1), Cvtop (op2, e2) -> Stdlib.( = ) op1 op2 && equal e1 e2 - | Binop (op1, e1, e3), Binop (op2, e2, e4) -> - Stdlib.( = ) op1 op2 && equal e1 e2 && equal e3 e4 - | Relop (op1, e1, e3), Relop (op2, e2, e4) -> - Stdlib.( = ) op1 op2 && equal e1 e2 && equal e3 e4 - | Triop (op1, e1, e3, e5), Triop (op2, e2, e4, e6) -> - Stdlib.( = ) op1 op2 && equal e1 e2 && equal e3 e4 && equal e5 e6 - | Symbol s1, Symbol s2 -> Symbol.equal s1 s2 - | Extract (e1, h1, l1), Extract (e2, h2, l2) -> - equal e1 e2 && Int.(h1 = h2) && Int.(l1 = l2) - | Concat (e1, e3), Concat (e2, e4) -> equal e1 e2 && equal e3 e4 - | Quantifier (q1, vars1, e1, p1), Quantifier (q2, vars2, e2, p2) -> - Stdlib.( = ) q1 q2 - && List.equal Symbol.equal vars1 vars2 - && equal e1 e2 - && List.equal (List.equal equal) p1 p2 - | _ -> false - -let rec length (e : expr) : Int.t = - match e with - | Val _ -> 1 - | SymPtr _ -> 1 - | Unop (_, e) -> 1 + length e - | Binop (_, e1, e2) -> 1 + length e1 + length e2 - | Triop (_, e1, e2, e3) -> 1 + length e1 + length e2 + length e3 - | Relop (_, e1, e2) -> 1 + length e1 + length e2 - | Cvtop (_, e) -> 1 + length e - | Symbol _ -> 1 - | Extract (e, _, _) -> 1 + length e - | Concat (e1, e2) -> 1 + length e1 + length e2 - | Quantifier (_, _, body, _) -> length body - -let get_symbols (e : expr list) : Symbol.t List.t = - let rec symbols e = - match e with - | Val _ -> [] - | SymPtr (_, offset) -> symbols offset - | Unop (_, e1) -> symbols e1 - | Binop (_, e1, e2) -> symbols e1 @ symbols e2 - | Triop (_, e1, e2, e3) -> symbols e1 @ symbols e2 @ symbols e3 - | Relop (_, e1, e2) -> symbols e1 @ symbols e2 - | Cvtop (_, e) -> symbols e - | Symbol s -> [ s ] - | Extract (e, _, _) -> symbols e - | Concat (e1, e2) -> symbols e1 @ symbols e2 - | Quantifier (_, vars, _, _) -> vars - in - List.fold (List.concat_map e ~f:symbols) ~init:[] ~f:(fun accum x -> - if List.mem accum x ~equal:Symbol.equal then accum else x :: accum) - -let rec type_of (e : expr) : expr_type = - (* FIXME: this function can be "simplified" *) - let rec concat_length (e' : expr) : Int.t = - match e' with - | Quantifier _ -> assert false - | Val v -> size (Value.type_of v) - | SymPtr _ -> 4 - | Binop (op, _, _) -> size (Types.type_of op) - | Triop (op, _, _, _) -> size (Types.type_of op) - | Unop (op, _) -> size (Types.type_of op) - | Relop (op, _, _) -> size (Types.type_of op) - | Cvtop (op, _) -> size (Types.type_of op) - | Symbol s -> size (Symbol.type_of s) - | Concat (e1, e2) -> concat_length e1 + concat_length e2 - | Extract (_, h, l) -> h - l - in - match e with - | Val v -> Value.type_of v - | SymPtr _ -> `I32Type - | Binop (op, _, _) -> Types.type_of op - | Triop (op, _, _, _) -> Types.type_of op - | Unop (op, _) -> Types.type_of op - | Relop (op, _, _) -> Types.type_of op - | Cvtop (op, _) -> Types.type_of op - | Symbol s -> Symbol.type_of s - | Extract (_, h, l) -> - let d = h - l in - if d = 4 then `I32Type - else if d = 8 then `I64Type - else failwith "unsupported type length" - | Concat (e1, e2) -> - let len = concat_length (e1 ++ e2) in - let len = - if len < 4 then size (type_of e1) + size (type_of e2) else len - in - if len = 4 then `I32Type - else if len = 8 then `I64Type - else failwith "unsupported type length" - | Quantifier _ -> assert false - -let negate_relop (e : expr) : expr = - match e with - | Relop (op, e1, e2) -> ( - match op with - | Int op' -> Relop (Int (I.neg_relop op'), e1, e2) - | Real op' -> Relop (Real (R.neg_relop op'), e1, e2) - | Bool op' -> Relop (Bool (B.neg_relop op'), e1, e2) - | Str op' -> Relop (Str (S.neg_relop op'), e1, e2) - | I32 op' -> Relop (I32 (I32.neg_relop op'), e1, e2) - | I64 op' -> Relop (I64 (I64.neg_relop op'), e1, e2) - | F32 op' -> Relop (F32 (F32.neg_relop op'), e1, e2) - | F64 op' -> Relop (F64 (F64.neg_relop op'), e1, e2)) - | _ -> raise InvalidRelop - -(** String representation of a expr *) -let rec to_string (e : expr) : String.t = - match e with - | Val v -> Value.to_string v - | SymPtr (base, offset) -> - let str_o = to_string offset in - "(SymPtr " ^ Int32.to_string base ^ " + " ^ str_o ^ ")" - | Unop (op, e) -> - let str_op = - match op with - | Int op -> I.string_of_unop op - | Real op -> R.string_of_unop op - | Bool op -> B.string_of_unop op - | Str op -> S.string_of_unop op - | I32 op -> I32.string_of_unop op - | I64 op -> I64.string_of_unop op - | F32 op -> F32.string_of_unop op - | F64 op -> F64.string_of_unop op - in - "(" ^ str_op ^ " " ^ to_string e ^ ")" - | Binop (op, e1, e2) -> - let str_op = - match op with - | Int op -> I.string_of_binop op - | Real op -> R.string_of_binop op - | Bool op -> B.string_of_binop op - | Str op -> S.string_of_binop op - | I32 op -> I32.string_of_binop op - | I64 op -> I64.string_of_binop op - | F32 op -> F32.string_of_binop op - | F64 op -> F64.string_of_binop op - in - "(" ^ str_op ^ " " ^ to_string e1 ^ ", " ^ to_string e2 ^ ")" - | Relop (op, e1, e2) -> - let str_op = - match op with - | Int op -> I.string_of_relop op - | Real op -> R.string_of_relop op - | Bool op -> B.string_of_relop op - | Str op -> S.string_of_relop op - | I32 op -> I32.string_of_relop op - | I64 op -> I64.string_of_relop op - | F32 op -> F32.string_of_relop op - | F64 op -> F64.string_of_relop op - in - "(" ^ str_op ^ " " ^ to_string e1 ^ ", " ^ to_string e2 ^ ")" - | Triop (op, e1, e2, e3) -> - let str_op = - match op with - | Int op -> I.string_of_triop op - | Real op -> R.string_of_triop op - | Bool op -> B.string_of_triop op - | Str op -> S.string_of_triop op - | I32 op -> I32.string_of_triop op - | I64 op -> I64.string_of_triop op - | F32 op -> F32.string_of_triop op - | F64 op -> F64.string_of_triop op - in - "(" ^ str_op ^ " " ^ to_string e1 ^ ", " ^ to_string e2 ^ ", " - ^ to_string e3 ^ ")" - | Cvtop (op, e) -> - let str_op = - match op with - | Int op -> I.string_of_cvtop op - | Real op -> R.string_of_cvtop op - | Bool op -> B.string_of_cvtop op - | Str op -> S.string_of_cvtop op - | I32 op -> I32.string_of_cvtop op - | I64 op -> I64.string_of_cvtop op - | F32 op -> F32.string_of_cvtop op - | F64 op -> F64.string_of_cvtop op - in - "(" ^ str_op ^ " " ^ to_string e ^ ")" - | Symbol s -> - "(" ^ string_of_type (Symbol.type_of s) ^ " #" ^ Symbol.to_string s ^ ")" - | Extract (e, h, l) -> - "(Extract " ^ to_string e ^ ", " ^ Int.to_string h ^ " " ^ Int.to_string l - ^ ")" - | Concat (e1, e2) -> "(Concat " ^ to_string e1 ^ " " ^ to_string e2 ^ ")" - | Quantifier (qt, vars, body, _) -> - let qt' = match qt with Forall -> "Forall" | Exists -> "Exists" in - let xs' = String.concat ~sep:", " (List.map ~f:Symbol.to_string vars) in - qt' ^ "(" ^ xs' ^ ")" ^ to_string body - -let rec pp_to_string (e : expr) : String.t = - match e with - | Val v -> Value.to_string v - | SymPtr (base, offset) -> - let str_o = pp_to_string offset in - "(SymPtr " ^ Int32.to_string base ^ " + " ^ str_o ^ ")" - (* I32 *) - | Unop (op, e) -> - let str_op = - match op with - | Int op -> I.pp_string_of_unop op - | Real op -> R.pp_string_of_unop op - | Bool op -> B.pp_string_of_unop op - | Str op -> S.pp_string_of_unop op - | I32 op -> I32.pp_string_of_unop op - | I64 op -> I64.pp_string_of_unop op - | F32 op -> F32.pp_string_of_unop op - | F64 op -> F64.pp_string_of_unop op - in - "(" ^ str_op ^ " " ^ pp_to_string e ^ ")" - | Binop (op, e1, e2) -> - let str_op = - match op with - | Int op -> I.pp_string_of_binop op - | Real op -> R.pp_string_of_binop op - | Bool op -> B.pp_string_of_binop op - | Str op -> S.pp_string_of_binop op - | I32 op -> I32.pp_string_of_binop op - | I64 op -> I64.pp_string_of_binop op - | F32 op -> F32.pp_string_of_binop op - | F64 op -> F64.pp_string_of_binop op - in - "(" ^ str_op ^ " " ^ pp_to_string e1 ^ ", " ^ pp_to_string e2 ^ ")" - | Triop (op, e1, e2, e3) -> - let str_op = - match op with - | Int op -> I.pp_string_of_triop op - | Real op -> R.pp_string_of_triop op - | Bool op -> B.pp_string_of_triop op - | Str op -> S.pp_string_of_triop op - | I32 op -> I32.pp_string_of_triop op - | I64 op -> I64.pp_string_of_triop op - | F32 op -> F32.pp_string_of_triop op - | F64 op -> F64.pp_string_of_triop op - in - "(" ^ str_op ^ " " ^ pp_to_string e1 ^ ", " ^ pp_to_string e2 - ^ pp_to_string e3 ^ ")" - | Relop (op, e1, e2) -> - let str_op = - match op with - | Int op -> I.pp_string_of_relop op - | Real op -> R.pp_string_of_relop op - | Bool op -> B.pp_string_of_relop op - | Str op -> S.pp_string_of_relop op - | I32 op -> I32.pp_string_of_relop op - | I64 op -> I64.pp_string_of_relop op - | F32 op -> F32.pp_string_of_relop op - | F64 op -> F64.pp_string_of_relop op - in - "(" ^ str_op ^ " " ^ pp_to_string e1 ^ ", " ^ pp_to_string e2 ^ ")" - | Cvtop (op, e) -> - let str_op = - match op with - | Int op -> I.pp_string_of_cvtop op - | Real op -> R.pp_string_of_cvtop op - | Bool op -> B.pp_string_of_cvtop op - | Str op -> S.pp_string_of_cvtop op - | I32 op -> I32.pp_string_of_cvtop op - | I64 op -> I64.pp_string_of_cvtop op - | F32 op -> F32.pp_string_of_cvtop op - | F64 op -> F64.pp_string_of_cvtop op - in - "(" ^ str_op ^ " " ^ pp_to_string e ^ ")" - | Symbol s -> "#" ^ Symbol.to_string s - | Extract (e, h, l) -> - pp_to_string e ^ "[" ^ Int.to_string l ^ ":" ^ Int.to_string h ^ "]" - | Concat (e1, e2) -> - let str_e1 = pp_to_string e1 and str_e2 = pp_to_string e2 in - "(" ^ str_e1 ^ " ++ " ^ str_e2 ^ ")" - | Quantifier (qt, vars, body, _) -> - let qt' = match qt with Forall -> "Forall" | Exists -> "Exists" in - let xs' = String.concat ~sep:", " (List.map ~f:Symbol.to_string vars) in - qt' ^ "(" ^ xs' ^ ")" ^ pp_to_string body - -let string_of_pc (pc : pc) : String.t = - List.fold_left ~init:"" ~f:(fun acc c -> acc ^ pp_to_string c ^ ";\n ") pc - -let pp_string_of_pc (pc : pc) : String.t = - List.fold_left ~init:"" ~f:(fun acc e -> acc ^ pp_to_string e ^ "; ") pc - -let string_of_values (el : (Num.t * t) List.t) : String.t = - List.fold_left ~init:"" - ~f:(fun a (n, e) -> a ^ Num.to_string n ^ ", " ^ pp_to_string e ^ "\n") - el - -let rec get_ptr (e : expr) : Num.t Option.t = - (* FIXME: this function can be "simplified" *) - match e with - | Quantifier _ | Val _ -> None - | SymPtr (base, _) -> Some (I32 base) - | Unop (_, e) -> get_ptr e - | Binop (_, e1, e2) -> - let p1 = get_ptr e1 in - if Option.is_some p1 then p1 else get_ptr e2 - | Triop (_, e1, e2, e3) -> - let p1 = get_ptr e1 in - if Option.is_some p1 then p1 - else - let p2 = get_ptr e2 in - if Option.is_some p2 then p2 else get_ptr e3 - | Relop (_, e1, e2) -> - let p1 = get_ptr e1 in - if Option.is_some p1 then p1 else get_ptr e2 - | Cvtop (_, e) -> get_ptr e - | Symbol _ -> None - | Extract (e, _, _) -> get_ptr e - | Concat (e1, e2) -> - (* assume concatenation of only one ptr *) - let p1 = get_ptr e1 in - if Option.is_some p1 then p1 else get_ptr e2 - -let concretize_ptr (e : expr) : Num.t Option.t = - (* TODO: this should work with symbolic pointers *) - (* would probably introduce Memory Objects here *) - let open Int32 in - match e with - | Val (Num n) -> Some n - | SymPtr (base, Val (Num (I32 offset))) -> Some (I32 (base + offset)) - | _ -> None - -let concretize_base_ptr (e : expr) : Int32.t Option.t = - match e with SymPtr (base, _) -> Some base | _ -> None - -let to_relop (e : expr) : expr Option.t = - if is_concrete e then None - else if is_relop e then Some e - else Some (Relop (I32 Ne, e, Val (Num (I32 0l)))) - -let nland64 (x : Int64.t) (n : Int.t) = - let rec loop x' n' acc = - if n' = 0 then Int64.(x' land acc) - else loop x' (n' - 1) Int64.(shift_left acc 8 lor 0xffL) - in - loop x n 0L - -let nland32 (x : Int32.t) (n : Int.t) = - let rec loop x' n' acc = - if n' = 0 then Int32.(x' land acc) - else loop x' (n' - 1) Int32.(shift_left acc 8 lor 0xffl) - in - loop x n 0l - -let rec simplify ?(extract = true) (e : expr) : expr = - match e with - | Val v -> Val v - | SymPtr (base, offset) -> SymPtr (base, simplify offset) - | Binop (I32 op, e1, e2) -> ( - let e1' = simplify e1 and e2' = simplify e2 in - match (e1', e2') with - | SymPtr (b1, os1), SymPtr (b2, os2) -> ( - match op with - | Sub when Int32.(b1 = b2) -> simplify (Binop (I32 Sub, os1, os2)) - | _ -> Binop (I32 op, e1', e2')) - | SymPtr (base, offset), _ -> ( - match op with - | Add -> - let new_offset = simplify (Binop (I32 Add, offset, e2')) in - simplify (SymPtr (base, new_offset)) - | Sub -> - let new_offset = simplify (Binop (I32 Sub, offset, e2')) in - simplify (SymPtr (base, new_offset)) - | _ -> Binop (I32 op, e1', e2')) - | _, SymPtr (base, offset) -> ( - match op with - | Add -> - let new_offset = simplify (Binop (I32 Add, offset, e1')) in - simplify (SymPtr (base, new_offset)) - | _ -> Binop (I32 op, e1', e2')) - | Val (Num (I32 0l)), _ -> ( - match op with - | Add | Or | Sub -> e2' - | And | DivS | DivU | Mul | RemS | RemU -> Val (Num (I32 0l)) - | _ -> Binop (I32 op, e1', e2')) - | _, Val (Num (I32 0l)) -> ( - match op with - | Add | Or | Sub -> e1' - | And | Mul -> Val (Num (I32 0l)) - | _ -> Binop (I32 op, e1', e2')) - | Val (Num n1), Val (Num n2) -> - Val (Num (Eval_numeric.eval_binop (I32 op) n1 n2)) - | Binop (I32 op2, x, Val (Num v1)), Val (Num v2) when not (is_num x) -> ( - match (op, op2) with - | Add, Add -> - let v = Eval_numeric.eval_binop (I32 Add) v1 v2 in - Binop (I32 Add, x, Val (Num v)) - | Add, Sub | Sub, Add -> - let v = Eval_numeric.eval_binop (I32 Sub) v1 v2 in - Binop (I32 Add, x, Val (Num v)) - | Sub, Sub -> - let v = Eval_numeric.eval_binop (I32 Add) v1 v2 in - Binop (I32 Sub, x, Val (Num v)) - | _, _ -> Binop (I32 op, e1', e2')) - | (bop, Val (Num (I32 1l)) | Val (Num (I32 1l)), bop) - when is_relop bop && Stdlib.( = ) op And -> - bop - | _ -> Binop (I32 op, e1', e2')) - | Binop (I64 op, e1, e2) -> ( - let e1' = simplify e1 and e2' = simplify e2 in - match (e1', e2') with - | SymPtr (b1, os1), SymPtr (b2, os2) -> ( - match op with - | Sub when Int32.(b1 = b2) -> simplify (Binop (I64 Sub, os1, os2)) - | _ -> Binop (I64 op, e1', e2')) - | SymPtr (base, offset), _ -> ( - match op with - | Add -> - let new_offset = simplify (Binop (I64 Add, offset, e2')) in - simplify (SymPtr (base, new_offset)) - | Sub -> - let new_offset = simplify (Binop (I64 Sub, offset, e2')) in - simplify (SymPtr (base, new_offset)) - | _ -> Binop (I64 op, e1', e2')) - | _, SymPtr (base, offset) -> ( - match op with - | Add -> - let new_offset = simplify (Binop (I64 Add, offset, e1')) in - simplify (SymPtr (base, new_offset)) - | _ -> Binop (I64 op, e1', e2')) - | Val (Num (I64 0L)), _ -> ( - match op with - | Add | Or | Sub -> e2' - | And | DivS | DivU | Mul | RemS | RemU -> Val (Num (I64 0L)) - | _ -> Binop (I64 op, e1', e2')) - | _, Val (Num (I64 0L)) -> ( - match op with - | Add | Or | Sub -> e1' - | And | Mul -> Val (Num (I64 0L)) - | _ -> Binop (I64 op, e1', e2')) - | Val (Num v1), Val (Num v2) -> - Val (Num (Eval_numeric.eval_binop (I64 op) v1 v2)) - | Binop (I64 op2, x, Val (Num v1)), Val (Num v2) when not (is_num x) -> ( - match (op, op2) with - | Add, Add -> - let v = Eval_numeric.eval_binop (I64 Add) v1 v2 in - Binop (I64 Add, x, Val (Num v)) - | Add, Sub | Sub, Add -> - let v = Eval_numeric.eval_binop (I64 Sub) v1 v2 in - Binop (I64 Add, x, Val (Num v)) - | Sub, Sub -> - let v = Eval_numeric.eval_binop (I64 Add) v1 v2 in - Binop (I64 Sub, x, Val (Num v)) - | _, _ -> Binop (I64 op, e1', e2')) - | (bop, Val (Num (I64 1L)) | Val (Num (I64 1L)), bop) - when is_relop bop && Stdlib.( = ) op And -> - bop - | _ -> Binop (I64 op, e1', e2')) - | Relop (I32 op, e1, e2) -> ( - let e1' = simplify e1 and e2' = simplify e2 in - match (e1', e2') with - | Val (Num v1), Val (Num v2) -> - let ret = Eval_numeric.eval_relop (I32 op) v1 v2 in - Val (Num (Num.num_of_bool ret)) - | SymPtr (_, _), Val (Num (I32 0l)) | Val (Num (I32 0l)), SymPtr (_, _) - -> ( - match op with - | Eq -> Val (Num (I32 0l)) - | Ne -> Val (Num (I32 1l)) - | _ -> Relop (I32 op, e1', e2')) - | SymPtr (b1, os1), SymPtr (b2, os2) -> ( - let open Int32 in - match op with - | Eq when b1 = b2 -> Relop (I32 Eq, os1, os2) - | Eq when b1 <> b2 -> Val (Num (I32 0l)) - | Ne when b1 = b2 -> Relop (I32 Ne, os1, os2) - | Ne when b1 <> b2 -> Val (Num (I32 1l)) - | LtU when b1 = b2 -> Relop (I32 LtU, os1, os2) - | LeU when b1 = b2 -> Relop (I32 LeU, os1, os2) - | LtU -> Relop (I32 LtU, Val (Num (I32 b1)), Val (Num (I32 b2))) - | LeU -> Relop (I32 LeU, Val (Num (I32 b1)), Val (Num (I32 b2))) - | GtU when b1 = b2 -> Relop (I32 GtU, os1, os2) - | GeU when b1 = b2 -> Relop (I32 GeU, os1, os2) - | GtU -> Relop (I32 GtU, Val (Num (I32 b1)), Val (Num (I32 b2))) - | GeU -> Relop (I32 GeU, Val (Num (I32 b1)), Val (Num (I32 b2))) - | _ -> Relop (I32 op, e1', e2')) - | _ -> Relop (I32 op, e1', e2')) - | Extract (_, _, _) when not extract -> e - | Extract (s, h, l) when extract -> ( - match s with - | Val (Num (I64 x)) -> - let x' = nland64 (Int64.shift_right x (l * 8)) (h - l) in - Val (Num (I64 x')) - | _ when h - l = size (type_of s) -> s - | _ -> e) - | Concat (e1, e2) -> ( - let e1' = simplify ~extract:false e1 - and e2' = simplify ~extract:false e2 in - match (e1', e2') with - | ( Extract (Val (Num (I64 x2)), h2, l2), - Extract (Val (Num (I64 x1)), h1, l1) ) -> - let d1 = h1 - l1 and d2 = h2 - l2 in - let x1' = nland64 (Int64.shift_right x1 (l1 * 8)) d1 - and x2' = nland64 (Int64.shift_right x2 (l2 * 8)) d2 in - let x = Int64.(shift_left x2' (Int.( * ) d1 8) lor x1') in - Extract (Val (Num (I64 x)), d1 + d2, 0) - | ( Extract (Val (Num (I32 x2)), h2, l2), - Extract (Val (Num (I32 x1)), h1, l1) ) -> - let d1 = h1 - l1 and d2 = h2 - l2 in - let x1' = nland32 (Int32.shift_right x1 (l1 * 8)) d1 - and x2' = nland32 (Int32.shift_right x2 (l2 * 8)) d2 in - let x = Int32.(shift_left x2' (Int.( * ) d1 8) lor x1') in - Extract (Val (Num (I32 x)), d1 + d2, 0) - | Extract (s1, h, m1), Extract (s2, m2, l) - when Stdlib.( = ) s1 s2 && m1 = m2 -> - Extract (s1, h, l) - | ( Extract (Val (Num (I64 x2)), h2, l2), - Concat (Extract (Val (Num (I64 x1)), h1, l1), se) ) - when not (is_num se) -> - let d1 = h1 - l1 and d2 = h2 - l2 in - let x1' = nland64 (Int64.shift_right x1 (l1 * 8)) d1 - and x2' = nland64 (Int64.shift_right x2 (l2 * 8)) d2 in - let x = Int64.(shift_left x2' (Int.( * ) d1 8) lor x1') in - Extract (Val (Num (I64 x)), d1 + d2, 0) ++ se - | _ -> e1' ++ e2') - | _ -> e - -let mk_relop ?(reduce : bool = true) (e : expr) (t : num_type) : expr = - let e = if reduce then simplify e else e in - if is_relop e then e - else - let zero = Value.Num (Num.default_value t) in - let e' = - match t with - | `I32Type -> Relop (I32 Ne, e, Val zero) - | `I64Type -> Relop (I64 Ne, e, Val zero) - | `F32Type -> Relop (F32 Ne, e, Val zero) - | `F64Type -> Relop (F64 Ne, e, Val zero) - in - simplify e' - -let add_constraint ?(neg : bool = false) (e : expr) (pc : expr) : expr = - let cond = - let c = to_relop (simplify e) in - if neg then Option.map ~f:negate_relop c else c - in - match (cond, pc) with - | None, _ -> pc - | Some cond, Val (Bool true) -> cond - | Some cond, _ -> Binop (Bool B.And, cond, pc) - -let insert_pc ?(neg : bool = false) (e : expr) (pc : pc) : pc = - let cond = - let c = to_relop (simplify e) in - if neg then Option.map ~f:negate_relop c else c - in - Option.fold ~init:pc ~f:(fun pc a -> a :: pc) cond diff --git a/encoding/lib/syntax/num.ml b/encoding/lib/syntax/num.ml deleted file mode 100644 index 6bc3b7b1..00000000 --- a/encoding/lib/syntax/num.ml +++ /dev/null @@ -1,35 +0,0 @@ -open Core -open Types - -type t = (Int32.t, Int64.t, Int32.t, Int64.t) num - -let ( = ) (n1 : t) (n2 : t) : bool = - match (n1, n2) with - | I32 i1, I32 i2 -> Int32.(i1 = i2) - | I64 i1, I64 i2 -> Int64.(i1 = i2) - | F32 i1, F32 i2 -> Int32.(i1 = i2) - | F64 i1, F64 i2 -> Int64.(i1 = i2) - | _ -> false - -let type_of (n : t) = - match n with - | I32 _ -> `I32Type - | I64 _ -> `I64Type - | F32 _ -> `F32Type - | F64 _ -> `F64Type - -let default_value (t : num_type) : t = - match t with - | `I32Type -> I32 0l - | `I64Type -> I64 0L - | `F32Type -> F32 (Int32.bits_of_float 0.0) - | `F64Type -> F64 (Int64.bits_of_float 0.0) - -let to_string (n : t) : string = - match n with - | I32 i -> Int32.to_string i - | I64 i -> Int64.to_string i - | F32 f -> Float.to_string (Int32.float_of_bits f) - | F64 f -> Float.to_string (Int64.float_of_bits f) - -let num_of_bool (b : bool) : t = I32 (if b then 1l else 0l) diff --git a/encoding/lib/syntax/symbol.ml b/encoding/lib/syntax/symbol.ml deleted file mode 100644 index 63733c7e..00000000 --- a/encoding/lib/syntax/symbol.ml +++ /dev/null @@ -1,11 +0,0 @@ -open Types - -type t = { sort : expr_type; name : string } - -let mk_symbol (sort : expr_type) (name : string) = { sort; name } - -let equal (s1 : t) (s2 : t) : bool = - s1.sort = s2.sort && String.equal s1.name s2.name - -let type_of (s : t) : expr_type = s.sort -let to_string (s : t) : string = s.name diff --git a/encoding/lib/syntax/types.ml b/encoding/lib/syntax/types.ml deleted file mode 100644 index cf6fb0e3..00000000 --- a/encoding/lib/syntax/types.ml +++ /dev/null @@ -1,118 +0,0 @@ -type ('i32, 'i64, 'f32, 'f64) num = - | I32 of 'i32 - | I64 of 'i64 - | F32 of 'f32 - | F64 of 'f64 - -type ('i, 'r, 'b, 'str, 'i32, 'i64, 'f32, 'f64) op = - | Int of 'i - | Real of 'r - | Bool of 'b - | Str of 'str - | I32 of 'i32 - | I64 of 'i64 - | F32 of 'f32 - | F64 of 'f64 - -module I = IntOp -module B = BoolOp -module S = StrOp -module R = FloatOp -module I32 = BvOp -module I64 = BvOp -module F32 = FloatOp -module F64 = FloatOp - -type triop = - ( I.triop, - R.triop, - B.triop, - S.triop, - I32.triop, - I64.triop, - F32.triop, - F64.triop ) - op - -type binop = - ( I.binop, - R.binop, - B.binop, - S.binop, - I32.binop, - I64.binop, - F32.binop, - F64.binop ) - op - -type unop = - (I.unop, R.unop, B.unop, S.unop, I32.unop, I64.unop, F32.unop, F64.unop) op - -type relop = - ( I.relop, - R.relop, - B.relop, - S.relop, - I32.relop, - I64.relop, - F32.relop, - F64.relop ) - op - -type cvtop = - ( I.cvtop, - R.cvtop, - B.cvtop, - S.cvtop, - I32.cvtop, - I64.cvtop, - F32.cvtop, - F64.cvtop ) - op - -type num_type = [ `I32Type | `I64Type | `F32Type | `F64Type ] -type expr_type = [ num_type | `IntType | `RealType | `BoolType | `StrType ] - -let op i r b s i32 i64 f32 f64 = function - | Int x -> i x - | Real x -> r x - | Bool x -> b x - | Str x -> s x - | I32 x -> i32 x - | I64 x -> i64 x - | F32 x -> f32 x - | F64 x -> f64 x - -let type_of op = - match op with - | Int _ -> `IntType - | Real _ -> `RealType - | Bool _ -> `BoolType - | Str _ -> `StrType - | I32 _ -> `I32Type - | I64 _ -> `I64Type - | F32 _ -> `F32Type - | F64 _ -> `F64Type - -let size_of_num_type (t : num_type) : int = - match t with `I32Type | `F32Type -> 4 | `I64Type | `F64Type -> 8 - -let size (t : expr_type) : int = - match t with - | #num_type as t' -> size_of_num_type t' - | `IntType | `RealType | `BoolType | `StrType -> assert false - -let string_of_num_type (t : num_type) : string = - match t with - | `I32Type -> "I32Type" - | `I64Type -> "I64Type" - | `F32Type -> "F32Type" - | `F64Type -> "F64Type" - -let string_of_type (t : expr_type) : string = - match t with - | #num_type as t' -> string_of_num_type t' - | `IntType -> "IntType" - | `RealType -> "FltType" - | `BoolType -> "BoolType" - | `StrType -> "StrType" diff --git a/encoding/lib/syntax/value.ml b/encoding/lib/syntax/value.ml deleted file mode 100644 index 742e9669..00000000 --- a/encoding/lib/syntax/value.ml +++ /dev/null @@ -1,33 +0,0 @@ -open Types - -type t = - | Int of Int.t - | Real of Float.t - | Bool of Bool.t - | Num of Num.t - | Str of String.t - -let equal (v1 : t) (v2 : t) : Bool.t = - match (v1, v2) with - | Int x1, Int x2 -> Int.equal x1 x2 - | Real x1, Real x2 -> Float.equal x1 x2 - | Bool x1, Bool x2 -> Bool.equal x1 x2 - | Num x1, Num x2 -> Num.(x1 = x2) - | Str x1, Str x2 -> String.equal x1 x2 - | _ -> false - -let type_of (v : t) : expr_type = - match v with - | Int _ -> `IntType - | Real _ -> `RealType - | Bool _ -> `BoolType - | Num n -> Num.type_of n - | Str _ -> `StrType - -let to_string (v : t) : String.t = - match v with - | Int x -> Int.to_string x - | Real x -> Float.to_string x - | Bool x -> Bool.to_string x - | Num x -> Num.to_string x - | Str x -> "\"" ^ x ^ "\"" diff --git a/encoding/test/dune b/encoding/test/dune deleted file mode 100644 index 7cd24ad9..00000000 --- a/encoding/test/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (name unit_tests) - (modules - test_int - test_f32 - test_bool - test_str - test_batch - test_optimizer - test_axiom) - (inline_tests) - (preprocess - (pps ppx_inline_test)) - (libraries encoding)) diff --git a/encoding/test/test_axiom.ml b/encoding/test/test_axiom.ml deleted file mode 100644 index f6cd7ada..00000000 --- a/encoding/test/test_axiom.ml +++ /dev/null @@ -1,17 +0,0 @@ -open Encoding - -let solver = Batch.create () -let _ = Batch.set_default_axioms solver -let encode f = try ignore (Z3_mappings.encode_expr f) with exn -> raise exn - -let%test_unit _ = encode (List.hd Axioms.axioms) - -let%test _ = - let x = Expression.mk_symbol_s `StrType "x" - and y = Expression.mk_symbol_s `StrType "y" in - Batch.check_sat solver - [ - Strings.mk_ne x y; - Integer.mk_eq (Integer.mk_val 0) (Integer.mk_of_string x); - Integer.mk_eq (Integer.mk_val 0) (Integer.mk_of_string y); - ] diff --git a/encoding/test/test_batch.ml b/encoding/test/test_batch.ml deleted file mode 100644 index ccba7deb..00000000 --- a/encoding/test/test_batch.ml +++ /dev/null @@ -1,32 +0,0 @@ -open Encoding - -let solver = Batch.create () -let x = Expression.mk_symbol_s `IntType "x" -let y = Expression.mk_symbol_s `BoolType "y" - -(* check_sat *) -let%test "check_sat-unconstrained" = Batch.check_sat solver [ y ] - -let%test "check_sat-constrained" = - Batch.check_sat solver [ Integer.mk_gt x (Integer.mk_val 0) ] - -(* eval *) -let%test "eval-unsat" = - Option.is_none (Batch.eval solver x [ Boolean.mk_val false ]) - -let%test "eval-unconstrained" = Option.is_some (Batch.eval solver x []) - -let%test "eval-constrained_int" = - Some (Value.Int 5) - = Batch.eval solver x [ Integer.mk_eq x (Integer.mk_val 5) ] - -let%test "eval-constrained_bool" = - let pc = [ Boolean.mk_eq y (Boolean.mk_val true) ] in - Some (Value.Bool true) = Batch.eval solver y pc - -let%test "value_binds" = - let symbol_y = Symbol.mk_symbol `BoolType "y" in - let pc = [ Boolean.mk_eq y (Boolean.mk_val false) ] in - assert (Batch.check_sat solver pc); - [ (symbol_y, Value.Bool false) ] - = Batch.value_binds solver ~symbols:[ symbol_y ] diff --git a/encoding/test/test_bool.ml b/encoding/test/test_bool.ml deleted file mode 100644 index f2b40232..00000000 --- a/encoding/test/test_bool.ml +++ /dev/null @@ -1,8 +0,0 @@ -open Encoding - -let solver = Batch.create () -let x = Expression.mk_symbol_s `BoolType "x" - -let%test "test_not" = - let pc = [ Boolean.mk_not (Boolean.mk_eq x (Boolean.mk_val true)) ] in - Some (Value.Bool false) = Batch.eval solver x pc diff --git a/encoding/test/test_f32.ml b/encoding/test/test_f32.ml deleted file mode 100644 index a94b717c..00000000 --- a/encoding/test/test_f32.ml +++ /dev/null @@ -1,20 +0,0 @@ -open Encoding - -let solver = Batch.create () -let x = Expression.mk_symbol_s `F32Type "x" -let nan = FloatingPoint.mk_val Float.nan `F32Type - -let%test "deterministic_nan" = - let pc = - [ - Boolean.mk_not (FloatingPoint.mk_is_nan x `F32Type); - FloatingPoint.mk_is_nan x `F32Type; - ] - in - false = Batch.check_sat solver pc - -let%test "nondeterministic_nan" = - let pc = - [ FloatingPoint.mk_ne x nan `F32Type; FloatingPoint.mk_is_nan x `F32Type ] - in - true = Batch.check_sat solver pc diff --git a/encoding/test/test_int.ml b/encoding/test/test_int.ml deleted file mode 100644 index f1cb5fd2..00000000 --- a/encoding/test/test_int.ml +++ /dev/null @@ -1,18 +0,0 @@ -open Encoding - -let solver = Batch.create () -let encode e = try ignore (Z3_mappings.encode_expr e) with exn -> raise exn -let one = Integer.mk_val Int.one -let minus_one = Integer.mk_val Int.minus_one -let zero = Integer.mk_val Int.zero -let x = Expression.mk_symbol_s `IntType "x" - -(* Encoding *) -let%test_unit _ = encode one -let%test_unit _ = encode minus_one -let%test_unit _ = encode zero -let%test_unit _ = encode x -(* Satisfiability *) -let%test _ = Batch.check_sat solver [ Integer.mk_gt x zero ] -let%test _ = Batch.check_sat solver [ Integer.mk_gt one minus_one ] -let%test _ = Batch.check_sat solver [ Integer.mk_eq (Integer.mk_pow x one) x ] diff --git a/encoding/test/test_optimizer.ml b/encoding/test/test_optimizer.ml deleted file mode 100644 index 20b74a6e..00000000 --- a/encoding/test/test_optimizer.ml +++ /dev/null @@ -1,17 +0,0 @@ -open Encoding - -let opt = Optimizer.create () -let x = Expression.mk_symbol_s `IntType "x" - -(* Satisfiability *) -let%test "opt_min" = - let pc = - [ Integer.mk_ge x (Integer.mk_val 0); Integer.mk_lt x (Integer.mk_val 5) ] - in - Some (Value.Int 0) = Optimizer.minimize opt x pc - -let%test "opt_max" = - let pc = - [ Integer.mk_ge x (Integer.mk_val 0); Integer.mk_lt x (Integer.mk_val 5) ] - in - Some (Value.Int 4) = Optimizer.maximize opt x pc diff --git a/encoding/test/test_str.ml b/encoding/test/test_str.ml deleted file mode 100644 index 7e432beb..00000000 --- a/encoding/test/test_str.ml +++ /dev/null @@ -1,46 +0,0 @@ -open Encoding - -let solver = Batch.create () -let encode e = try ignore (Z3_mappings.encode_expr e) with exn -> raise exn -let abc = Strings.mk_val "abc" -let x = Expression.mk_symbol_s `StrType "x" -let zero = Integer.mk_val 0 -let two = Integer.mk_val 2 - -(* Encoding *) -let%test_unit _ = encode abc -let%test_unit _ = encode x - -(* Satisfiability *) -let%test "test_concrete_len" = - Batch.check_sat solver - [ Integer.mk_ge (Strings.mk_len x) (Strings.mk_len abc) ] - -let%test "test_constrained_len" = - not - (Batch.check_sat solver - [ - Integer.mk_eq (Strings.mk_len x) (Integer.mk_val 4); - Integer.mk_eq (Strings.mk_len x) (Strings.mk_len abc); - ]) - -let%test "test_concrete_substr" = - let pc = - [ - Strings.mk_eq - (Strings.mk_substr abc ~pos:zero ~len:two) - (Strings.mk_val "ab"); - ] - in - Batch.check_sat solver pc - -let%test "test_symb_substr" = - let pc = - [ - Strings.mk_eq x abc; - Integer.mk_eq - (Strings.mk_len (Strings.mk_substr x ~pos:zero ~len:two)) - (Integer.mk_val 2); - ] - in - Some (Value.Str "abc") = Batch.eval solver x pc diff --git a/wasp/lib/symbolic/btree.ml b/src/btree.ml similarity index 100% rename from wasp/lib/symbolic/btree.ml rename to src/btree.ml diff --git a/wasp/lib/symbolic/common/bug.ml b/src/common/bug.ml similarity index 100% rename from wasp/lib/symbolic/common/bug.ml rename to src/common/bug.ml diff --git a/wasp/lib/symbolic/common/chunktable.ml b/src/common/chunktable.ml similarity index 98% rename from wasp/lib/symbolic/common/chunktable.ml rename to src/common/chunktable.ml index cf3d6daa..8c2f2734 100644 --- a/wasp/lib/symbolic/common/chunktable.ml +++ b/src/common/chunktable.ml @@ -1,5 +1,5 @@ -open Encoding open Bug +open Smtml type t = (int32, int32) Hashtbl.t diff --git a/wasp/lib/symbolic/common/common.ml b/src/common/common.ml similarity index 97% rename from wasp/lib/symbolic/common/common.ml rename to src/common/common.ml index 43a5be3e..5cde95f3 100644 --- a/wasp/lib/symbolic/common/common.ml +++ b/src/common/common.ml @@ -49,7 +49,7 @@ let write_test_case ?(witness = false) test_data : unit = Interpreter.Io.save_file filename test_data let numeric_error at = function - | Evaluations.UnsupportedOp m -> m ^ ": unsupported operation" + | Evaluations.Unsupported_op m -> m ^ ": unsupported operation" | Interpreter.Numeric_error.IntegerOverflow -> "integer overflow" | Interpreter.Numeric_error.IntegerDivideByZero -> "integer divide by zero" | Interpreter.Numeric_error.InvalidConversionToInteger -> diff --git a/wasp/lib/symbolic/common/counter.ml b/src/common/counter.ml similarity index 100% rename from wasp/lib/symbolic/common/counter.ml rename to src/common/counter.ml diff --git a/src/common/dune b/src/common/dune new file mode 100644 index 00000000..02e3c36e --- /dev/null +++ b/src/common/dune @@ -0,0 +1,3 @@ +(library + (name common) + (libraries smtml interpreter batteries)) diff --git a/src/common/evaluations.ml b/src/common/evaluations.ml new file mode 100644 index 00000000..25e0ab7f --- /dev/null +++ b/src/common/evaluations.ml @@ -0,0 +1,195 @@ +open Smtml +open Expr +open Ty +open Interpreter.Ast + +exception Unsupported_op of string + +let to_value (n : Num.t) : Interpreter.Values.value = + let open Interpreter in + match n with + | Num.I32 i -> Values.I32 i + | Num.I64 i -> Values.I64 i + | Num.F32 f -> Values.F32 (F32.of_bits f) + | Num.F64 f -> Values.F64 (F64.of_bits f) + | Num.I8 _ -> assert false + +let of_value (v : Interpreter.Values.value) : Num.t = + let open Interpreter in + match v with + | Values.I32 i -> Num.I32 i + | Values.I64 i -> Num.I64 i + | Values.F32 f -> Num.F32 (F32.to_bits f) + | Values.F64 f -> Num.F64 (F64.to_bits f) + +let ty_of_num_type (t : Interpreter.Types.value_type) = + let open Interpreter in + match t with + | Types.I32Type -> Ty_bitv 32 + | Types.I64Type -> Ty_bitv 64 + | Types.F32Type -> Ty_fp 32 + | Types.F64Type -> Ty_fp 64 + +let f32_unop op e = + match op with + | F32Op.Neg -> unop (Ty_fp 32) Neg e + | F32Op.Abs -> unop (Ty_fp 32) Abs e + | F32Op.Sqrt -> unop (Ty_fp 32) Sqrt e + | F32Op.Nearest -> unop (Ty_fp 32) Nearest e + | F32Op.Ceil -> unop (Ty_fp 32) Ceil e + | F32Op.Floor -> unop (Ty_fp 32) Floor e + | F32Op.Trunc -> unop (Ty_fp 32) Trunc e + +let f64_unop op e = + match op with + | F64Op.Neg -> unop (Ty_fp 64) Neg e + | F64Op.Abs -> unop (Ty_fp 64) Abs e + | F64Op.Sqrt -> unop (Ty_fp 64) Sqrt e + | F64Op.Nearest -> unop (Ty_fp 64) Nearest e + | F64Op.Ceil -> unop (Ty_fp 64) Ceil e + | F64Op.Floor -> unop (Ty_fp 64) Floor e + | F64Op.Trunc -> unop (Ty_fp 64) Trunc e + +let i32_binop op e1 e2 = + match op with + | I32Op.Add -> binop (Ty_bitv 32) Add e1 e2 + | I32Op.And -> binop (Ty_bitv 32) And e1 e2 + | I32Op.Or -> binop (Ty_bitv 32) Or e1 e2 + | I32Op.Sub -> binop (Ty_bitv 32) Sub e1 e2 + | I32Op.DivS -> binop (Ty_bitv 32) Div e1 e2 + | I32Op.DivU -> binop (Ty_bitv 32) DivU e1 e2 + | I32Op.Xor -> binop (Ty_bitv 32) Xor e1 e2 + | I32Op.Mul -> binop (Ty_bitv 32) Mul e1 e2 + | I32Op.Shl -> binop (Ty_bitv 32) Shl e1 e2 + | I32Op.ShrS -> binop (Ty_bitv 32) ShrA e1 e2 + | I32Op.ShrU -> binop (Ty_bitv 32) ShrL e1 e2 + | I32Op.RemS -> binop (Ty_bitv 32) Rem e1 e2 + | I32Op.RemU -> binop (Ty_bitv 32) RemU e1 e2 + | I32Op.Rotl -> binop (Ty_bitv 32) Rotl e1 e2 + | I32Op.Rotr -> binop (Ty_bitv 32) Rotr e1 e2 + +let i64_binop op e1 e2 = + match op with + | I64Op.Add -> binop (Ty_bitv 64) Add e1 e2 + | I64Op.And -> binop (Ty_bitv 64) And e1 e2 + | I64Op.Or -> binop (Ty_bitv 64) Or e1 e2 + | I64Op.Sub -> binop (Ty_bitv 64) Sub e1 e2 + | I64Op.DivS -> binop (Ty_bitv 64) Div e1 e2 + | I64Op.DivU -> binop (Ty_bitv 64) DivU e1 e2 + | I64Op.Xor -> binop (Ty_bitv 64) Xor e1 e2 + | I64Op.Mul -> binop (Ty_bitv 64) Mul e1 e2 + | I64Op.Shl -> binop (Ty_bitv 64) Shl e1 e2 + | I64Op.ShrS -> binop (Ty_bitv 64) ShrA e1 e2 + | I64Op.ShrU -> binop (Ty_bitv 64) ShrL e1 e2 + | I64Op.RemS -> binop (Ty_bitv 64) Rem e1 e2 + | I64Op.RemU -> binop (Ty_bitv 64) RemU e1 e2 + | I64Op.Rotl -> binop (Ty_bitv 64) Rotl e1 e2 + | I64Op.Rotr -> binop (Ty_bitv 64) Rotr e1 e2 + +let f32_binop op e1 e2 = + match op with + | F32Op.Add -> binop (Ty_fp 32) Add e1 e2 + | F32Op.Sub -> binop (Ty_fp 32) Sub e1 e2 + | F32Op.Div -> binop (Ty_fp 32) Div e1 e2 + | F32Op.Mul -> binop (Ty_fp 32) Mul e1 e2 + | F32Op.Min -> binop (Ty_fp 32) Min e1 e2 + | F32Op.Max -> binop (Ty_fp 32) Max e1 e2 + | F32Op.CopySign -> failwith "eval F32Binop: TODO CopySign" + +let f64_binop op e1 e2 = + match op with + | F64Op.Add -> binop (Ty_fp 64) Add e1 e2 + | F64Op.Sub -> binop (Ty_fp 64) Sub e1 e2 + | F64Op.Div -> binop (Ty_fp 64) Div e1 e2 + | F64Op.Mul -> binop (Ty_fp 64) Mul e1 e2 + | F64Op.Min -> binop (Ty_fp 64) Min e1 e2 + | F64Op.Max -> binop (Ty_fp 64) Max e1 e2 + | F64Op.CopySign -> failwith "eval F64Binop: TODO CopySign" + +let i32_relop op e1 e2 = + match op with + | I32Op.Eq -> relop Ty_bool Eq e1 e2 + | I32Op.Ne -> relop Ty_bool Ne e1 e2 + | I32Op.LtU -> relop (Ty_bitv 32) LtU e1 e2 + | I32Op.LtS -> relop (Ty_bitv 32) Lt e1 e2 + | I32Op.GtU -> relop (Ty_bitv 32) GtU e1 e2 + | I32Op.GtS -> relop (Ty_bitv 32) Gt e1 e2 + | I32Op.LeU -> relop (Ty_bitv 32) LeU e1 e2 + | I32Op.LeS -> relop (Ty_bitv 32) Le e1 e2 + | I32Op.GeU -> relop (Ty_bitv 32) GeU e1 e2 + | I32Op.GeS -> relop (Ty_bitv 32) Ge e1 e2 + +let i64_relop op e1 e2 = + match op with + | I64Op.Eq -> relop Ty_bool Eq e1 e2 + | I64Op.Ne -> relop Ty_bool Ne e1 e2 + | I64Op.LtU -> relop (Ty_bitv 64) LtU e1 e2 + | I64Op.LtS -> relop (Ty_bitv 64) Lt e1 e2 + | I64Op.GtU -> relop (Ty_bitv 64) GtU e1 e2 + | I64Op.GtS -> relop (Ty_bitv 64) Gt e1 e2 + | I64Op.LeU -> relop (Ty_bitv 64) LeU e1 e2 + | I64Op.LeS -> relop (Ty_bitv 64) Le e1 e2 + | I64Op.GeU -> relop (Ty_bitv 64) GeU e1 e2 + | I64Op.GeS -> relop (Ty_bitv 64) Ge e1 e2 + +let f32_relop op e1 e2 = + match op with + | F32Op.Eq -> relop (Ty_fp 32) Eq e1 e2 + | F32Op.Ne -> relop (Ty_fp 32) Ne e1 e2 + | F32Op.Lt -> relop (Ty_fp 32) Lt e1 e2 + | F32Op.Gt -> relop (Ty_fp 32) Gt e1 e2 + | F32Op.Le -> relop (Ty_fp 32) Le e1 e2 + | F32Op.Ge -> relop (Ty_fp 32) Ge e1 e2 + +let f64_relop op e1 e2 = + match op with + | F64Op.Eq -> relop (Ty_fp 64) Eq e1 e2 + | F64Op.Ne -> relop (Ty_fp 64) Ne e1 e2 + | F64Op.Lt -> relop (Ty_fp 64) Lt e1 e2 + | F64Op.Gt -> relop (Ty_fp 64) Gt e1 e2 + | F64Op.Le -> relop (Ty_fp 64) Le e1 e2 + | F64Op.Ge -> relop (Ty_fp 64) Ge e1 e2 + +(* TODO: sign bit *) +let i32_cvtop op s = + match op with + (* 64bit integer is taken modulo 2^32 i.e., top 32 bits are lost *) + | I32Op.WrapI64 -> extract s ~high:4 ~low:0 + | I32Op.TruncSF32 -> cvtop (Ty_bitv 32) TruncSF32 s + | I32Op.TruncUF32 -> cvtop (Ty_bitv 32) TruncUF32 s + | I32Op.TruncSF64 -> cvtop (Ty_bitv 32) TruncSF64 s + | I32Op.TruncUF64 -> cvtop (Ty_bitv 32) TruncUF64 s + | I32Op.ReinterpretFloat -> cvtop (Ty_bitv 32) Reinterpret_float s + | I32Op.ExtendSI32 -> failwith "TypeError" + | I32Op.ExtendUI32 -> failwith "TypeError" + +let i64_cvtop op s = + match op with + | I64Op.ExtendSI32 -> cvtop (Ty_bitv 64) (Sign_extend 32) s + | I64Op.ExtendUI32 -> cvtop (Ty_bitv 64) (Zero_extend 32) s + | I64Op.TruncSF32 -> cvtop (Ty_bitv 64) TruncSF32 s + | I64Op.TruncUF32 -> cvtop (Ty_bitv 64) TruncUF32 s + | I64Op.TruncSF64 -> cvtop (Ty_bitv 64) TruncSF64 s + | I64Op.TruncUF64 -> cvtop (Ty_bitv 64) TruncUF64 s + | I64Op.ReinterpretFloat -> cvtop (Ty_bitv 64) Reinterpret_float s + | I64Op.WrapI64 -> failwith "TypeError" + +let f32_cvtop op s = + match op with + | F32Op.DemoteF64 -> cvtop (Ty_fp 32) DemoteF64 s + | F32Op.ConvertSI32 -> cvtop (Ty_fp 32) ConvertSI32 s + | F32Op.ConvertUI32 -> cvtop (Ty_fp 32) ConvertUI32 s + | F32Op.ConvertSI64 -> cvtop (Ty_fp 32) ConvertSI64 s + | F32Op.ConvertUI64 -> cvtop (Ty_fp 32) ConvertUI64 s + | F32Op.ReinterpretInt -> cvtop (Ty_fp 32) Reinterpret_int s + | F32Op.PromoteF32 -> failwith "TypeError" + +let f64_cvtop op s = + match op with + | F64Op.PromoteF32 -> cvtop (Ty_fp 64) PromoteF32 s + | F64Op.ConvertSI32 -> cvtop (Ty_fp 64) ConvertSI32 s + | F64Op.ConvertUI32 -> cvtop (Ty_fp 64) ConvertUI32 s + | F64Op.ConvertSI64 -> cvtop (Ty_fp 64) ConvertSI64 s + | F64Op.ConvertUI64 -> cvtop (Ty_fp 64) ConvertUI64 s + | F64Op.ReinterpretInt -> cvtop (Ty_fp 64) Reinterpret_int s + | F64Op.DemoteF64 -> failwith "TypeError" diff --git a/wasp/lib/symbolic/common/globals.ml b/src/common/globals.ml similarity index 100% rename from wasp/lib/symbolic/common/globals.ml rename to src/common/globals.ml diff --git a/wasp/lib/symbolic/common/globals.mli b/src/common/globals.mli similarity index 100% rename from wasp/lib/symbolic/common/globals.mli rename to src/common/globals.mli diff --git a/wasp/lib/symbolic/common/randArray.ml b/src/common/randArray.ml similarity index 100% rename from wasp/lib/symbolic/common/randArray.ml rename to src/common/randArray.ml diff --git a/src/concolic/dune b/src/concolic/dune new file mode 100644 index 00000000..b2ee7d58 --- /dev/null +++ b/src/concolic/dune @@ -0,0 +1,3 @@ +(library + (name concolic) + (libraries interpreter common smtml)) diff --git a/src/concolic/eval.ml b/src/concolic/eval.ml new file mode 100644 index 00000000..ea05b268 --- /dev/null +++ b/src/concolic/eval.ml @@ -0,0 +1,1128 @@ +open Evaluations +open Common +open Smtml +open Value +open Interpreter.Ast +open Interpreter.Source +open Interpreter.Instance +module Batch = Smtml.Solver.Batch (Smtml.Z3_mappings) + +let memory_error at = function + | Heap.InvalidAddress a -> + Int64.to_string a ^ ":address not found in hashtable" + | Heap.Bounds -> "out of bounds memory access" + | Interpreter.Memory.SizeOverflow -> "memory size overflow" + | Interpreter.Memory.SizeLimit -> "memory size limit reached" + | Interpreter.Memory.Type -> Crash.error at "type mismatch at memory access" + | exn -> raise exn + +type policy = + | Random + | Depth + | Breadth + +type interruption = + | Limit + | Failure of Expr.t + | Bug of Bug.bug + +type value = Num.t * Expr.t + +type 'a stack = 'a list + +type frame = + { inst : module_inst + ; locals : value ref list + } + +type code = value stack * sym_admin_instr list + +and sym_admin_instr = sym_admin_instr' phrase + +and sym_admin_instr' = + | Plain of instr' + | Invoke of func_inst + | Trapping of string + | Returning of value stack + | Breaking of int32 * value stack + | Label of int * instr list * code + | Frame of int * frame * code + | Interrupt of interruption + | Restart of Expr.t + +type config = + { frame : frame + ; glob : value Globals.t + ; code : code + ; mem : Heap.t + ; store : Store.t + ; heap : Chunktable.t + ; pc : Expr.t + ; bp : bp list + ; tree : tree ref + ; budget : int + ; call_stack : region Stack.t + } + +and tree = config ref Execution_tree.t ref + +and bp = + | Branchpoint of Expr.t * tree + | Checkpoint of config ref + +let frame inst locals = { inst; locals } + +let clone_frame (f : frame) : frame = + frame f.inst (List.map (fun l -> ref !l) f.locals) + +let rec clone_admin_instr e = + let it = + match e.it with + | Label (n, es0, (vs, es)) -> + Label (n, es0, (vs, List.map clone_admin_instr es)) + | Frame (n, frame, (vs, es)) -> + Frame (n, clone_frame frame, (vs, List.map clone_admin_instr es)) + | _ -> e.it + in + { it; at = e.at } + +let clone (c : config) : Heap.t * config = + let vs, es = c.code in + let frame = clone_frame c.frame in + let glob = Globals.copy c.glob in + let code = (vs, List.map clone_admin_instr es) in + let mem, mem' = Heap.clone c.mem in + let store = Store.copy c.store in + let heap = Chunktable.copy c.heap in + let pc = c.pc in + let bp = [] in + let tree = ref !(c.tree) in + let budget = c.budget in + let call_stack = Stack.copy c.call_stack in + ( mem' + , { frame; glob; code; mem; store; heap; pc; bp; tree; budget; call_stack } ) + +let config inst vs es mem glob tree = + { frame = frame inst [] + ; glob + ; code = (vs, es) + ; mem + ; store = Store.create [] + ; heap = Chunktable.create () + ; pc = Expr.value True + ; bp = [] + ; tree + ; budget = Interpreter.Flags.budget + ; call_stack = Stack.create () + } + +exception BugException of config * region * Bug.bug + +let head = ref Execution_tree.(Node (None, None, ref Leaf, ref Leaf)) + +let step_cnt = ref 0 + +let iterations = ref 0 + +let loop_start = ref 0. + +let logs = ref [] + +let solver = Batch.create () + +let debug str = if !Interpreter.Flags.trace then print_endline str + +let parse_policy (p : string) : policy option = + match p with + | "random" -> Some Random + | "depth" -> Some Depth + | "breadth" -> Some Breadth + | _ -> None + +let string_of_interruption : interruption -> string = function + | Limit -> "Analysis Limit" + | Failure _ -> "Assertion Failure" + | Bug b -> Bug.string_of_bug b + +let plain e = Plain e.it @@ e.at + +let lookup category list x = + try Interpreter.Lib.List32.nth list x.it + with Failure _ -> + Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) + +let type_ (inst : module_inst) x = lookup "type" inst.types x + +let func (inst : module_inst) x = lookup "function" inst.funcs x + +let table (inst : module_inst) x = lookup "table" inst.tables x + +let memory (inst : module_inst) x = lookup "memory" inst.memories x + +let global (inst : module_inst) x = lookup "global" inst.globals x + +let local (frame : frame) x = lookup "local" frame.locals x + +let elem inst x i at = + match Interpreter.Table.load (table inst x) i with + | Interpreter.Table.Uninitialized -> + Trap.error at ("uninitialized element " ^ Int32.to_string i) + | f -> f + | exception Interpreter.Table.Bounds -> + Trap.error at ("undefined element " ^ Int32.to_string i) + +let func_elem inst x i at = + match elem inst x i at with + | FuncElem f -> f + | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) + +let take n (vs : 'a stack) at = + try Interpreter.Lib.List.take n vs + with Failure _ -> Crash.error at "stack underflow" + +let drop n (vs : 'a stack) at = + try Interpreter.Lib.List.drop n vs + with Failure _ -> Crash.error at "stack underflow" + +let add_constraint ?neg:_ _ _ = assert false + +let branch_on_cond bval c pc tree = + let tree', to_branch = + if bval then Execution_tree.move_true !tree + else Execution_tree.move_false !tree + in + tree := tree'; + if to_branch then Some (add_constraint ~neg:bval c pc) else None + +module type Checkpoint = sig + val is_checkpoint : config -> bool +end + +module NoCheckpoint : Checkpoint = struct + let is_checkpoint (_ : config) : bool = false +end + +module FuncCheckpoint : Checkpoint = struct + let visited = Hashtbl.create Interpreter.Flags.hashtbl_default_size + + let is_checkpoint (c : config) : bool = + let func = Stack.top c.call_stack in + if Hashtbl.mem visited func then false + else ( + Hashtbl.add visited func true; + Execution_tree.can_branch !(c.tree) ) +end + +module RandCheckpoint : Checkpoint = struct + let is_checkpoint (c : config) : bool = + Execution_tree.can_branch !(c.tree) && Random.bool () +end + +module DepthCheckpoint : Checkpoint = struct + let count = Counter.create () + + let is_checkpoint (_c : config) : bool = false + (* let size_pc = Expression.length c.pc in *) + (* Execution_tree.can_branch !(c.tree) *) + (* && size_pc mod 10 = 0 *) + (* && Counter.get_and_inc count size_pc < 5 *) +end + +module type Stepper = sig + val step : config -> config +end + +module ConcolicStepper (C : Checkpoint) : Stepper = struct + let rec step (c : config) : config = + let { frame + ; glob + ; code = vs, es + ; mem + ; store + ; heap + ; pc + ; bp + ; tree + ; call_stack + ; _ + } = + c + in + let e = List.hd es in + let vs', es', mem', pc', bp' = + match (e.it, vs) with + | Plain e', vs -> ( + match (e', vs) with + | Unreachable, vs -> + (vs, [ Trapping "unreachable executed" @@ e.at ], mem, pc, bp) + | Nop, vs -> (vs, [], mem, pc, bp) + | Block (ts, es'), vs -> + let es' = + [ Label (List.length ts, [], ([], List.map plain es')) @@ e.at ] + in + (vs, es', mem, pc, bp) + | Loop (_, es'), vs -> + ( vs + , [ Label (0, [ e' @@ e.at ], ([], List.map plain es')) @@ e.at ] + , mem + , pc + , bp ) + | If (ts, es1, es2), (I32 i, ex) :: vs' + when not Expr.(is_symbolic (simplify ex)) -> + if i = 0l then (vs', [ Plain (Block (ts, es2)) @@ e.at ], mem, pc, bp) + else (vs', [ Plain (Block (ts, es1)) @@ e.at ], mem, pc, bp) + | If (ts, es1, es2), (I32 i, ex) :: vs' -> + let b, es1', es2' = + ( i <> 0l + , [ Plain (Block (ts, es1)) @@ e.at ] + , [ Plain (Block (ts, es2)) @@ e.at ] ) + in + let mem', bp = + let pc' = add_constraint ~neg:b ex pc in + if not (C.is_checkpoint c) then (mem, bp) + else + let mem, c' = clone c in + ignore (branch_on_cond (not b) ex c'.pc c'.tree); + let es' = (if not b then es1' else es2') @ List.tl es in + let cp = ref { c' with code = (vs', es'); pc = pc' } in + Execution_tree.update_node !(c'.tree) cp; + (mem, Checkpoint cp :: bp) + in + let bp' = + Option.fold ~init:bp + ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) + (branch_on_cond b ex pc tree) + in + let pc' = add_constraint ~neg:(not b) ex pc in + (vs', (if b then es1' else es2'), mem', pc', bp') + | Br x, vs -> ([], [ Breaking (x.it, vs) @@ e.at ], mem, pc, bp) + | BrIf x, (I32 i, ex) :: vs' when not Expr.(is_symbolic (simplify ex)) + -> + if i = 0l then (vs', [], mem, pc, bp) + else (vs', [ Plain (Br x) @@ e.at ], mem, pc, bp) + | BrIf x, (I32 i, ex) :: vs' -> + let b, es1', es2' = (i <> 0l, [ Plain (Br x) @@ e.at ], []) in + let mem', bp = + let pc' = add_constraint ~neg:b ex pc in + if not (C.is_checkpoint c) then (mem, bp) + else + let mem, c' = clone c in + ignore (branch_on_cond (not b) ex c'.pc c'.tree); + let es' = (if not b then es1' else es2') @ List.tl es in + let cp = ref { c' with code = (vs', es'); pc = pc' } in + Execution_tree.update_node !(c'.tree) cp; + (mem, Checkpoint cp :: bp) + in + let bp' = + Option.fold ~init:bp + ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) + (branch_on_cond b ex pc tree) + in + let pc' = add_constraint ~neg:(not b) ex pc in + (vs', (if b then es1' else es2'), mem', pc', bp') + | BrTable (xs, x), (I32 i, _) :: vs' + when Interpreter.I32.ge_u i (Interpreter.Lib.List32.length xs) -> + (vs', [ Plain (Br x) @@ e.at ], mem, pc, bp) + | BrTable (xs, _), (I32 i, _) :: vs' -> + ( vs' + , [ Plain (Br (Interpreter.Lib.List32.nth xs i)) @@ e.at ] + , mem + , pc + , bp ) + | Return, vs -> ([], [ Returning vs @@ e.at ], mem, pc, bp) + | Call x, vs -> (vs, [ Invoke (func frame.inst x) @@ e.at ], mem, pc, bp) + | CallIndirect x, (I32 i, _) :: vs -> + let func = func_elem frame.inst (0l @@ e.at) i e.at in + if type_ frame.inst x <> Interpreter.Func.type_of func then + (vs, [ Trapping "indirect call type mismatch" @@ e.at ], mem, pc, bp) + else (vs, [ Invoke func @@ e.at ], mem, pc, bp) + | Drop, _ :: vs' -> (vs', [], mem, pc, bp) + | Select, (I32 i, ve) :: v2 :: v1 :: vs' + when not Expr.(is_symbolic (simplify ve)) -> + if i = 0l then (v2 :: vs', [], mem, pc, bp) + else (v1 :: vs', [], mem, pc, bp) + | Select, (I32 i, ve) :: v2 :: v1 :: vs' -> + let b, vs1, vs2 = (i <> 0l, v1 :: vs', v2 :: vs') in + let mem', bp = + let pc' = add_constraint ~neg:b ve pc in + if not (C.is_checkpoint c) then (mem, bp) + else + let mem, c' = clone c in + ignore (branch_on_cond (not b) ve c'.pc c'.tree); + let vs' = if not b then vs1 else vs2 in + let cp = ref { c' with code = (vs', List.tl es); pc = pc' } in + Execution_tree.update_node !(c'.tree) cp; + (mem, Checkpoint cp :: bp) + in + let bp' = + Option.fold ~init:bp + ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) + (branch_on_cond b ve pc tree) + in + let pc' = add_constraint ~neg:(not b) ve pc in + ((if b then vs1 else vs2), [], mem', pc', bp') + | LocalGet x, vs -> (!(local frame x) :: vs, [], mem, pc, bp) + | LocalSet x, (v, ex) :: vs' -> + local frame x := (v, Expr.simplify ex); + (vs', [], mem, pc, bp) + | LocalTee x, (v, ex) :: vs' -> + local frame x := (v, Expr.simplify ex); + (!(local frame x) :: vs', [], mem, pc, bp) + | GlobalGet x, vs -> (Globals.find glob x.it :: vs, [], mem, pc, bp) + | GlobalSet x, v :: vs' -> + Globals.add glob x.it v; + (vs', [], mem, pc, bp) + | Load { offset; ty; sz; _ }, (I32 i, sym_ptr) :: vs' -> ( + try + let base = Interpreter.I64_convert.extend_i32_u i in + (* overflow check *) + let ptr = concretize_base_ptr (Expr.simplify sym_ptr) in + match + Option.bind ptr (fun bp -> + Chunktable.check_access heap bp (I32 i) offset ) + with + | Some b -> (vs', [ Interrupt (Bug b) @@ e.at ], mem, pc, bp) + | None -> + let ty = Evaluations.ty_of_num_type ty in + let v, e = + match sz with + | None -> Heap.load_value mem base offset ty + | Some (sz, ext) -> Heap.load_packed sz ext mem base offset ty + in + ((v, e) :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (memory_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Store { offset; sz; _ }, (v, ex) :: (I32 i, sym_ptr) :: vs' -> ( + try + let base = Interpreter.I64_convert.extend_i32_u i in + let ptr = concretize_base_ptr (Expr.simplify sym_ptr) in + match + Option.bind ptr (fun bp -> + Chunktable.check_access heap bp (I32 i) offset ) + with + | Some b -> (vs', [ Interrupt (Bug b) @@ e.at ], mem, pc, bp) + | None -> + let ex = Expr.simplify ex in + ( match sz with + | None -> Heap.store_value mem base offset (v, ex) + | Some sz -> Heap.store_packed sz mem base offset (v, ex) ); + (vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (memory_error e.at exn) @@ e.at ], mem, pc, bp) ) + | MemorySize, vs -> + let mem' = memory frame.inst (0l @@ e.at) in + let v : Num.t = I32 (Interpreter.Memory.size mem') in + ((v, Expr.value (Num v)) :: vs, [], mem, pc, bp) + | MemoryGrow, (I32 delta, _) :: vs' -> + let mem' = memory frame.inst (0l @@ e.at) in + let old_size = Interpreter.Memory.size mem' in + let result = + let open Interpreter in + Num.I32 + ( try + Memory.grow mem' delta; + old_size + with + | Memory.SizeOverflow | Memory.SizeLimit | Memory.OutOfMemory -> + -1l ) + in + ((result, Expr.value (Num result)) :: vs', [], mem, pc, bp) + | Const v, vs -> + let v = Evaluations.of_value v.it in + ((v, Expr.value (Num v)) :: vs, [], mem, pc, bp) + | Test testop, v :: vs' -> ( + try (eval_testop v testop :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Compare relop, v2 :: v1 :: vs' -> ( + try (eval_relop v1 v2 relop :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Unary unop, v :: vs' -> ( + try (eval_unop v unop :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Binary binop, v2 :: v1 :: vs' -> ( + try (eval_binop v1 v2 binop :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Convert cvtop, v :: vs' -> ( + try (eval_cvtop cvtop v :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Dup, v :: vs' -> (v :: v :: vs', [], mem, pc, bp) + | SymAssert, (I32 0l, _) :: vs' -> + debug ">>> Assert FAILED! Stopping..."; + (vs', [ Interrupt (Failure pc) @@ e.at ], mem, pc, bp) + | SymAssert, (I32 _, ex) :: vs' when not Expr.(is_symbolic (simplify ex)) + -> + (vs', [], mem, pc, bp) + | SymAssert, (I32 _, ex) :: vs' -> ( + let formulas = add_constraint ~neg:true ex pc in + match Batch.check solver [ formulas ] with + | `Unsat -> (vs', [], mem, pc, bp) + | `Sat -> ( + match Batch.model solver ~symbols:(Store.get_key_types store) with + | None -> assert false + | Some model -> + let binds = Model.get_bindings model in + Store.update store binds; + (vs', [ Interrupt (Failure pc) @@ e.at ], mem, pc, bp) ) + | `Unknown -> assert false ) + | SymAssume, (I32 i, ex) :: vs' when not Expr.(is_symbolic (simplify ex)) + -> + let unsat = Expr.value False in + if i = 0l then (vs', [ Restart unsat @@ e.at ], mem, pc, bp) + else (vs', [], mem, pc, bp) + | SymAssume, (I32 i, ex) :: vs' -> + if i = 0l then + (vs', [ Restart (add_constraint ex pc) @@ e.at ], mem, pc, bp) + else ( + debug ">>> Assume passed. Continuing execution..."; + let tree', _ = Execution_tree.move_true !tree in + tree := tree'; + (vs', [], mem, add_constraint ex pc, bp) ) + | Symbolic (ty, b), (I32 i, _) :: vs' -> + let base = Interpreter.I64_convert.extend_i32_u i in + let symbol = if i = 0l then "x" else Heap.load_string mem base in + let x = Store.next store symbol in + let ty' = Evaluations.ty_of_num_type ty in + let v = Store.get store x ty' b in + ((v, Expr.symbol (Symbol.make ty' x)) :: vs', [], mem, pc, bp) + | Boolop boolop, (v2, sv2) :: (v1, sv1) :: vs' -> ( + let sv2' = mk_relop sv2 (Num.type_of v2) in + let v2' = Num.(num_of_bool (not (v2 = default_value (type_of v2)))) in + let sv1' = mk_relop sv1 (Num.type_of v1) in + let v1' = Num.(num_of_bool (not (v1 = default_value (type_of v1)))) in + try + let v3, sv3 = eval_binop (v1', sv1') (v2', sv2') boolop in + ((v3, simplify sv3) :: vs', [], mem, pc, bp) + with exn -> + (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + | Alloc, (I32 a, sa) :: (I32 b, sb) :: vs' -> + Hashtbl.add heap b a; + ((I32 b, SymPtr (b, Val (Num (I32 0l)))) :: vs', [], mem, pc, bp) + | Free, (I32 i, _) :: vs' -> + let es' = + if not (Hashtbl.mem heap i) then + [ Interrupt (Bug Bug.InvalidFree) @@ e.at ] + else ( + Hashtbl.remove heap i; + [] ) + in + (vs', es', mem, pc, bp) + | GetSymInt32 x, vs' -> + let v = + try Store.find store x + with Not_found -> + Crash.error e.at "Symbolic variable was not in store." + in + ((v, Expression.mk_symbol_s `I32Type x) :: vs', [], mem, pc, bp) + | GetSymInt64 x, vs' -> + let v = + try Store.find store x + with Not_found -> + Crash.error e.at "Symbolic variable was not in store." + in + ((v, Expression.mk_symbol_s `I64Type x) :: vs', [], mem, pc, bp) + | GetSymFloat32 x, vs' -> + let v = + try Store.find store x + with Not_found -> + Crash.error e.at "Symbolic variable was not in store." + in + ((v, Expression.mk_symbol_s `F32Type x) :: vs', [], mem, pc, bp) + | GetSymFloat64 x, vs' -> + let v = + try Store.find store x + with Not_found -> + Crash.error e.at "Symbolic variable was not in store." + in + ((v, Expression.mk_symbol_s `F64Type x) :: vs', [], mem, pc, bp) + | TernaryOp, (I32 r2, s_r2) :: (I32 r1, s_r1) :: (I32 c, s_c) :: vs' -> + let r : Num.t = I32 (if c = 0l then r2 else r1) in + let s_c' = to_relop (simplify s_c) in + let v, pc' = + match s_c' with + | None -> ((r, if c = 0l then s_r2 else s_r1), pc) + | Some s -> + let x = Store.next store "__ternary" in + Store.add store x r; + let s_x = Expression.mk_symbol_s `I32Type x in + let t_eq = Relop (I32 I32.Eq, s_x, s_r1) in + let t_imp = Binop (I32 I32.Or, negate_relop s, t_eq) in + let f_eq = Relop (I32 I32.Eq, s_x, s_r2) in + let f_imp = Binop (I32 I32.Or, s, f_eq) in + let cond = Binop (I32 I32.And, t_imp, f_imp) in + ( (r, s_x) + , Expression.add_constraint + (Relop (I32 I32.Ne, cond, Val (Num (I32 0l)))) + pc ) + in + (v :: vs', [], mem, pc', bp) + | PrintStack, vs' -> + debug + ( Interpreter.Source.string_of_pos e.at.left + ^ ":VS:\n" + ^ Expression.string_of_values vs' ); + (vs', [], mem, pc, bp) + | PrintPC, vs' -> + debug + ( Interpreter.Source.string_of_pos e.at.left + ^ ":PC: " + ^ Expression.(pp_to_string pc) ); + (vs', [], mem, pc, bp) + | PrintMemory, vs' -> + debug ("Mem:\n" ^ Heap.to_string mem); + (vs', [], mem, pc, bp) + | PrintBtree, vs' -> + Printf.printf "B TREE STATE: \n\n"; + (* Btree.print_b_tree mem; *) + (vs', [], mem, pc, bp) + | CompareExpr, (v1, ex1) :: (v2, ex2) :: vs' -> + let res : Num.t * Expression.t = + match (ex1, ex2) with + | Symbol s1, Symbol s2 -> + if Symbol.equal s1 s2 then (I32 1l, Integer.mk_eq ex1 ex2) + else (I32 0l, Integer.mk_ne ex1 ex2) + | _, _ -> + eval_relop (v1, ex1) (v2, ex2) + (Interpreter.Values.I32 Interpreter.Ast.I32Op.Eq) + in + (res :: vs', [], mem, pc, bp) + | IsSymbolic, (I32 n, _) :: (I32 i, _) :: vs' -> + let base = Interpreter.I64_convert.extend_i32_u i in + let _, v = Heap.load_bytes mem base (Int32.to_int n) in + let result : Num.t = I32 (match v with Val _ -> 0l | _ -> 1l) in + ((result, Val (Num result)) :: vs', [], mem, pc, bp) + | SetPriority, _ :: _ :: _ :: vs' -> (vs', [], mem, pc, bp) + | PopPriority, _ :: vs' -> (vs', [], mem, pc, bp) + | _ -> Crash.error e.at "missing or ill-typed operand on stack" ) + | Trapping msg, vs -> assert false + | Interrupt i, vs -> assert false + | Restart pc, vs -> assert false + | Returning vs', vs -> Crash.error e.at "undefined frame" + | Breaking (k, vs'), vs -> Crash.error e.at "undefined label" + | Label (n, es0, (vs', [])), vs -> (vs' @ vs, [], mem, pc, bp) + | Label (n, es0, (vs', { it = Restart pc'; at } :: es')), vs -> + ( vs + , [ Restart pc' @@ at; Label (n, es0, (vs', es')) @@ e.at ] + , mem + , pc + , bp ) + | Label (n, es0, (vs', { it = Interrupt i; at } :: es')), vs -> + ( vs + , [ Interrupt i @@ at; Label (n, es0, (vs', es')) @@ e.at ] + , mem + , pc + , bp ) + | Label (n, es0, (vs', { it = Trapping msg; at } :: es')), vs -> + (vs, [ Trapping msg @@ at ], mem, pc, bp) + | Label (n, es0, (vs', { it = Returning vs0; at } :: es')), vs -> + (vs, [ Returning vs0 @@ at ], mem, pc, bp) + | Label (n, es0, (vs', { it = Breaking (0l, vs0); at } :: es')), vs -> + (take n vs0 e.at @ vs, List.map plain es0, mem, pc, bp) + | Label (n, es0, (vs', { it = Breaking (k, vs0); at } :: es')), vs -> + (vs, [ Breaking (Int32.sub k 1l, vs0) @@ at ], mem, pc, bp) + | Label (n, es0, code'), vs -> + let c' = step { c with code = code' } in + List.iter + (fun bp -> + match bp with + | Branchpoint _ -> () + | Checkpoint cp -> + let es' = (Label (n, es0, !cp.code) @@ e.at) :: List.tl es in + cp := { !cp with code = (vs, es') } ) + c'.bp; + (vs, [ Label (n, es0, c'.code) @@ e.at ], c'.mem, c'.pc, c'.bp) + | Frame (n, frame', (vs', [])), vs -> + ignore (Stack.pop call_stack); + (vs' @ vs, [], mem, pc, bp) + | Frame (n, frame', (vs', { it = Restart pc'; at } :: es')), vs -> + ( vs + , [ Restart pc' @@ at; Frame (n, frame', (vs', es')) @@ e.at ] + , mem + , pc + , bp ) + | Frame (n, frame', (vs', { it = Interrupt i; at } :: es')), vs -> + ( vs + , [ Interrupt i @@ at; Frame (n, frame', (vs', es')) @@ e.at ] + , mem + , pc + , bp ) + | Frame (n, frame', (vs', { it = Trapping msg; at } :: es')), vs -> + (vs, [ Trapping msg @@ at ], mem, pc, bp) + | Frame (n, frame', (vs', { it = Returning vs0; at } :: es')), vs -> + (take n vs0 e.at @ vs, [], mem, pc, bp) + | Frame (n, frame', code'), vs -> + let c' = + step + { frame = frame' + ; glob = c.glob + ; code = code' + ; mem = c.mem + ; heap = c.heap + ; store = c.store + ; pc = c.pc + ; bp = c.bp + ; tree = c.tree + ; budget = c.budget - 1 + ; call_stack = c.call_stack + } + in + List.iter + (fun bp -> + match bp with + | Branchpoint _ -> () + | Checkpoint cp -> + let es' = (Frame (n, !cp.frame, !cp.code) @@ e.at) :: List.tl es + and frame' = clone_frame frame in + cp := { !cp with frame = frame'; code = (vs, es') } ) + c'.bp; + (vs, [ Frame (n, c'.frame, c'.code) @@ e.at ], c'.mem, c'.pc, c'.bp) + | Invoke func, vs when c.budget = 0 -> + (vs, [ Interrupt Limit @@ e.at ], mem, pc, bp) + | Invoke func, vs -> ( + let symbolic_arg t = + let x = Store.next store "arg" in + let v = Store.get store x t false in + (v, Expression.mk_symbol_s t x) + in + let (Interpreter.Types.FuncType (ins, out)) = + Interpreter.Func.type_of func + in + let n = List.length ins in + let vs = + if n > 0 && List.length vs = 0 then + List.map (fun t -> symbolic_arg (Evaluations.to_num_type t)) ins + else vs + in + let args, vs' = (take n vs e.at, drop n vs e.at) in + match func with + | Interpreter.Func.AstFunc (t, inst', f) -> + Stack.push f.at call_stack; + let locals' = + List.map + (fun v -> (v, Val (Num v))) + (List.map + (fun t -> Num.default_value (Evaluations.to_num_type t)) + f.it.locals ) + in + let locals'' = List.rev args @ locals' in + let code' = ([], [ Plain (Block (out, f.it.body)) @@ f.at ]) in + let frame' = { inst = !inst'; locals = List.map ref locals'' } in + (vs', [ Frame (List.length out, frame', code') @@ e.at ], mem, pc, bp) + | Interpreter.Func.HostFunc (t, f) -> failwith "HostFunc error" ) + in + step_cnt := !step_cnt + 1; + { c with code = (vs', es' @ List.tl es); mem = mem'; pc = pc'; bp = bp' } +end + +let get_reason (err_t, at) : string = + let loc = + Interpreter.Source.string_of_pos at.left + ^ if at.right = at.left then "" else "-" ^ string_of_pos at.right + in + "{" ^ "\"type\" : \"" ^ err_t ^ "\", " ^ "\"line\" : \"" ^ loc ^ "\"" ^ "}" + +let write_report error loop_time : unit = + if !Interpreter.Flags.log then print_logs !logs; + let spec, reason = + match error with None -> (true, "{}") | Some e -> (false, get_reason e) + in + let report_str = + "{" ^ "\"specification\": " ^ string_of_bool spec ^ ", " ^ "\"reason\" : " + ^ reason ^ ", " ^ "\"loop_time\" : \"" ^ string_of_float loop_time ^ "\", " + ^ "\"solver_time\" : \"" + ^ string_of_float !Batch.solver_time + ^ "\", " ^ "\"paths_explored\" : " ^ string_of_int !iterations ^ ", " + ^ "\"solver_counter\" : " + ^ string_of_int !Batch.solver_count + ^ ", " ^ "\"instruction_counter\" : " ^ string_of_int !step_cnt ^ "}" + in + Interpreter.Io.save_file + (Filename.concat !Interpreter.Flags.output "report.json") + report_str + +let rec update_admin_instr f e = + let it = + match e.it with + | Plain e -> Plain e + | Invoke f -> Invoke f + | Trapping exn -> Trapping exn + | Returning vs -> Returning (List.map f vs) + | Breaking (n, vs) -> Breaking (n, List.map f vs) + | Label (n, es0, (vs, es)) -> + Label (n, es0, (List.map f vs, List.map (update_admin_instr f) es)) + | Frame (n, frame, (vs, es)) -> + List.iter (fun l -> l := f !l) frame.locals; + Frame (n, frame, (List.map f vs, List.map (update_admin_instr f) es)) + | Interrupt i -> Interrupt i + | Restart pc -> Restart pc + in + { it; at = e.at } + +let update c (vs, es) pc symbols = + let binds = Batch.value_binds solver ~symbols in + Store.update c.store binds; + Heap.update c.mem c.store; + let f store (_, expr) = (Store.eval store expr, expr) in + List.iter (fun l -> l := f c.store !l) c.frame.locals; + let code = + (List.map (f c.store) vs, List.map (update_admin_instr (f c.store)) es) + in + { c with code; pc } + +let reset c glob code mem = + let binds = Batch.value_binds solver ~symbols:(Store.get_key_types c.store) in + Store.reset c.store; + Store.init c.store binds; + let glob = Globals.copy glob in + Hashtbl.reset c.heap; + c.tree := head; + { c with + frame = frame empty_module_inst [] + ; code + ; glob + ; mem = Heap.memcpy mem + ; pc = Boolean.mk_val true + ; bp = [] + ; budget = Interpreter.Flags.budget + } + +let s_reset (c : config) : config = + let binds = Batch.value_binds solver ~symbols:(Store.get_key_types c.store) in + Store.update c.store binds; + Heap.update c.mem c.store; + let f store (_, expr) = (Store.eval store expr, expr) in + List.iter (fun l -> l := f c.store !l) c.frame.locals; + c.tree := head; + let vs, es = c.code in + let code = + (List.map (f c.store) vs, List.map (update_admin_instr (f c.store)) es) + in + { c with code } + +module Guided_search (L : WorkList) (S : Stepper) = struct + let enqueue (pc_wl, cp_wl) branch_points : unit = + List.iter + (fun bp -> + match bp with + | Branchpoint (pc, node) -> L.push (pc, node) pc_wl + | Checkpoint cp -> L.push cp cp_wl ) + branch_points + + let rec eval (c : config) wls : config = + match c.code with + | vs, [] -> c + | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg + | vs, { it = Interrupt Limit; at } :: _ -> { c with code = (vs, []) } + | vs, { it = Interrupt i; at } :: _ -> c + | vs, { it = Restart pc; at } :: _ -> + iterations := !iterations - 1; + c + | vs, es -> + let c' = S.step c in + enqueue wls c'.bp; + eval { c' with bp = [] } wls + + let rec find_sat_pc pcs = + if L.is_empty pcs then None + else + let pc, node = L.pop pcs in + if not (Batch.check_sat solver [ pc ]) then find_sat_pc pcs + else Some (pc, Execution_tree.find node) + + let rec find_sat_cp cps = + if L.is_empty cps then None + else + let cp = L.pop cps in + if not (Batch.check_sat solver [ !cp.pc ]) then find_sat_cp cps + else Some (!cp.pc, Some cp) + + let find_sat_path (pcs, cps) = + match find_sat_cp cps with None -> find_sat_pc pcs | Some _ as cp -> cp + + let invoke (c : config) (test_suite : string) = + let glob0 = Globals.copy c.glob + and code0 = c.code + and mem0 = Heap.memcpy c.mem in + let pc_wl = L.create () + and cp_wl = L.create () in + (* Main concolic loop *) + let rec loop c = + iterations := !iterations + 1; + let { code; store; bp; tree; _ } = eval c (pc_wl, cp_wl) in + enqueue (pc_wl, cp_wl) bp; + match code with + | vs, { it = Interrupt i; at } :: _ -> + write_test_case ~witness:true (Store.to_json store); + Some (string_of_interruption i, at) + | vs, { it = Restart pc; _ } :: es when Batch.check_sat solver [ pc ] -> + let tree', _ = Execution_tree.move_true !(c.tree) in + c.tree := tree'; + loop (update c (vs, es) pc (Store.get_key_types store)) + | _ -> ( + write_test_case (Store.to_json store); + match find_sat_path (pc_wl, cp_wl) with + | None -> None + | Some (pc', None) -> loop (reset c glob0 code0 mem0) + | Some (pc', Some cp) -> + let _, c' = clone !cp in + loop (update c' c'.code c'.pc (Expression.get_symbols [ pc' ])) ) + in + loop c + + let s_invoke (c : config) (test_suite : string) : (string * region) option = + let _, c0 = clone c in + let wl = L.create () in + let rec eval (c : config) : config = + match c.code with + | vs, [] -> c + | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg + | vs, { it = Restart pc; at } :: es -> c + | vs, { it = Interrupt i; at } :: es -> c + | vs, es -> + let c' = S.step c in + List.iter + (fun bp -> + let pc = + match bp with + | Checkpoint cp -> !cp.pc + | Branchpoint (pc, _) -> pc + in + L.push pc wl ) + c'.bp; + eval { c' with bp = [] } + in + let rec find_sat_pc pcs = + if L.is_empty pcs then false + else if not (Batch.check_sat solver [ L.pop pcs ]) then find_sat_pc pcs + else true + in + (* Main concolic loop *) + let rec loop (c : config) = + iterations := !iterations + 1; + let { code; store; bp; pc; _ } = eval c in + List.iter + (fun bp -> + let pc = + match bp with Checkpoint cp -> !cp.pc | Branchpoint (pc, _) -> pc + in + L.push pc wl ) + bp; + match code with + | vs, { it = Interrupt i; at } :: _ -> + write_test_case ~witness:true (Store.to_json store); + Some (string_of_interruption i, at) + | vs, { it = Restart pc; _ } :: es -> + print_endline "--- attempting restart ---"; + iterations := !iterations - 1; + if Batch.check_sat solver [ pc ] then + loop (update c (vs, es) pc (Store.get_key_types store)) + else if L.is_empty wl || not (find_sat_pc wl) then None + else + let _, c' = clone c0 in + loop (s_reset c') + | _ -> + write_test_case (Store.to_json store); + if L.is_empty wl || not (find_sat_pc wl) then None + else + let _, c' = clone c0 in + loop (s_reset c') + in + let error = loop c in + error + + let p_invoke (c : config) (test_suite : string) : + (Expression.t, string * region) result = + let rec eval (c : config) : config = + match c.code with + | vs, [] -> c + | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg + | vs, { it = Restart pc; at } :: es -> + c (* TODO: probably need to change this *) + | vs, { it = Interrupt i; at } :: es -> c + | vs, es -> + let c' = S.step c in + eval c' + in + let c' = eval c in + let res = + match c'.code with + | vs, { it = Interrupt i; at } :: _ -> + write_test_case ~witness:true (Store.to_json c'.store); + Result.error (string_of_interruption i, at) + | _ -> + write_test_case (Store.to_json c'.store); + Result.ok c.pc + in + res +end + +module NoCheckpointStepper = ConcolicStepper (NoCheckpoint) +module FuncCheckpointStepper = ConcolicStepper (FuncCheckpoint) +module RandCheckpointStepper = ConcolicStepper (RandCheckpoint) +module DepthCheckpointStepper = ConcolicStepper (DepthCheckpoint) +module DFS = Guided_search (Stack) (NoCheckpointStepper) +module BFS = Guided_search (Queue) (NoCheckpointStepper) +module RND = Guided_search (RandArray) (NoCheckpointStepper) + +let exiter _ = + let loop_time = Sys.time () -. !loop_start in + write_report None loop_time; + exit 0 + +let set_timeout (time_limit : int) : unit = + if time_limit > 0 then ( + Sys.(set_signal sigalrm (Signal_handle exiter)); + ignore (Unix.alarm time_limit) ) + +let main (func : func_inst) (vs : value list) (inst : module_inst) + (mem0 : Heap.t) = + let open Interpreter in + set_timeout !Flags.timeout; + let test_suite = Filename.concat !Flags.output "test_suite" in + Io.safe_mkdir test_suite; + let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in + let glob = + Globals.of_seq + (Seq.mapi + (fun i a -> + let v = Global.load a in + ( Int32.of_int i + , (Evaluations.of_value v, Expr.value (Num (Evaluations.of_value v))) + ) ) + (List.to_seq inst.globals) ) + in + let c = + config empty_module_inst (List.rev vs) + [ Invoke func @@ at ] + mem0 glob (ref head) + in + let invoke = + match parse_policy !Flags.policy with + | None -> Crash.error at ("invalid search policy '" ^ !Flags.policy ^ "'") + | Some Depth -> DFS.invoke + | Some Breadth -> BFS.invoke + | Some Random -> RND.invoke + in + ( if !Interpreter.Flags.log then + let get_finished () : int = !iterations in + logger logs get_finished exiter loop_start ); + loop_start := Sys.time (); + let error = invoke c test_suite in + write_report error (Sys.time () -. !loop_start) + +let i32 (v : Interpreter.Values.value) at = + match v with + | Interpreter.Values.I32 i -> i + | _ -> Crash.error at "type error: i32 value expected" + +let create_func (inst : module_inst) (f : func) : func_inst = + Interpreter.Func.alloc (type_ inst f.it.ftype) (ref inst) f + +let create_table (_ : module_inst) (tab : table) : table_inst = + let { ttype } = tab.it in + Interpreter.Table.alloc ttype + +let create_memory (_ : module_inst) (mem : memory) : memory_inst = + let { mtype } = mem.it in + Interpreter.Memory.alloc mtype + +let create_global (inst : module_inst) (glob : global) : global_inst = + let { gtype; value } = glob.it in + let v = Interpreter.Eval.eval_const inst value in + Interpreter.Global.alloc gtype v + +let create_export (inst : module_inst) (ex : export) : export_inst = + let { name; edesc } = ex.it in + let ext = + match edesc.it with + | FuncExport x -> ExternFunc (func inst x) + | TableExport x -> ExternTable (table inst x) + | MemoryExport x -> ExternMemory (memory inst x) + | GlobalExport x -> ExternGlobal (global inst x) + in + (name, ext) + +let init_func (inst : module_inst) (func : func_inst) = + match func with + | Interpreter.Func.AstFunc (_, inst_ref, _) -> inst_ref := inst + | _ -> assert false + +let init_table (inst : module_inst) (seg : table_segment) = + let open Interpreter in + let { index; offset = const; init } = seg.it in + let tab = table inst index in + let offset = i32 (Eval.eval_const inst const) const.at in + let end_ = Int32.(add offset (of_int (List.length init))) in + let bound = Table.size tab in + if I32.lt_u bound end_ || I32.lt_u end_ offset then + Link.error seg.at "elements segment does not fit table"; + fun () -> + Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init) + +let init_memory (inst : module_inst) (sym_mem : Heap.t) (seg : memory_segment) = + let open Interpreter in + let { index; offset = const; init } = seg.it in + let mem = memory inst index in + let offset' = i32 (Eval.eval_const inst const) const.at in + let offset = I64_convert.extend_i32_u offset' in + let end_ = Int64.(add offset (of_int (String.length init))) in + let bound = Memory.bound mem in + if I64.lt_u bound end_ || I64.lt_u end_ offset then + Link.error seg.at "data segment does not fit memory"; + fun () -> Heap.store_bytes sym_mem offset init + +let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : + module_inst = + let open Interpreter in + if not (Types.match_extern_type (extern_type_of ext) (import_type m im)) then + Link.error im.at "incompatible import type"; + match ext with + | ExternFunc func -> { inst with funcs = func :: inst.funcs } + | ExternTable tab -> { inst with tables = tab :: inst.tables } + | ExternMemory mem -> { inst with memories = mem :: inst.memories } + | ExternGlobal glob -> { inst with globals = glob :: inst.globals } + +let init (m : module_) (exts : extern list) = + let open Interpreter in + let { imports + ; tables + ; memories + ; globals + ; funcs + ; types + ; exports + ; elems + ; data + ; start + } = + m.it + in + if List.length exts <> List.length imports then + Link.error m.at "wrong number of imports provided for initialisation"; + let inst0 = + { (List.fold_right2 (add_import m) exts imports empty_module_inst) with + types = List.map (fun type_ -> type_.it) types + } + in + let fs = List.map (create_func inst0) funcs in + let inst1 = + { inst0 with + funcs = inst0.funcs @ fs + ; tables = inst0.tables @ List.map (create_table inst0) tables + ; memories = inst0.memories @ List.map (create_memory inst0) memories + ; globals = inst0.globals @ List.map (create_global inst0) globals + } + in + let inst = { inst1 with exports = List.map (create_export inst1) exports } in + List.iter (init_func inst) fs; + let init_elems = List.map (init_table inst) elems in + let memory = Heap.alloc Flags.hashtbl_default_size in + let init_datas = List.map (init_memory inst memory) data in + List.iter (fun f -> f ()) init_elems; + List.iter (fun f -> f ()) init_datas; + Lib.Option.app (fun x -> ignore (main (func inst x) [] inst memory)) start; + (memory, inst) diff --git a/src/concolic/evaluations.ml b/src/concolic/evaluations.ml new file mode 100644 index 00000000..f4b8b082 --- /dev/null +++ b/src/concolic/evaluations.ml @@ -0,0 +1,103 @@ +open Common.Evaluations +open Smtml +open Ty +open Expr +open Value +open Interpreter.Ast + +(* Evaluate a unary operation *) +let eval_unop ((c, s) : Num.t * Expr.t) (op : Interpreter.Ast.unop) : + Num.t * Expr.t = + let open Expr in + let open Value in + let concrete = + of_value (Interpreter.Eval_numeric.eval_unop op (to_value c)) + in + let symbolic = + match Expr.view s with + | Val (Num _) -> Expr.value (Num concrete) + | _ -> ( + match op with + | Interpreter.Values.F32 x -> f32_unop x s + | Interpreter.Values.F64 x -> f64_unop x s + | Interpreter.Values.I32 _ | Interpreter.Values.I64 _ -> + raise (Unsupported_op "eval_unop: ints") ) + in + (concrete, symbolic) + +(* Evaluate a binary operation *) +let eval_binop ((c1, s1) : Num.t * Expr.t) ((c2, s2) : Num.t * Expr.t) + (op : Interpreter.Ast.binop) : Num.t * Expr.t = + let concrete = + of_value + (Interpreter.Eval_numeric.eval_binop op (to_value c1) (to_value c2)) + in + let symbolic = + match (Expr.view s1, Expr.view s2) with + | Val (Num _), Val (Num _) -> Expr.value (Num concrete) + | _ -> ( + match op with + | Interpreter.Values.I32 x -> i32_binop x s1 s2 + | Interpreter.Values.I64 x -> i64_binop x s1 s2 + | Interpreter.Values.F32 x -> f32_binop x s1 s2 + | Interpreter.Values.F64 x -> f64_binop x s1 s2 ) + in + (concrete, symbolic) + +(* Evaluate a test operation *) +let eval_testop ((c, s) : Num.t * Expr.t) (op : testop) : Num.t * Expr.t = + let concrete = + Num.num_of_bool (Interpreter.Eval_numeric.eval_testop op (to_value c)) + in + let symbolic = + match Expr.view s with + | Val (Num _) -> Expr.value (Num concrete) + | Ptr { base = _; offset } when not (Expr.is_symbolic offset) -> + Expr.value (Num concrete) + | _ -> ( + match op with + | Interpreter.Values.I32 I32Op.Eqz -> + relop Ty_bool Eq s (Expr.value (Num (Num.I32 0l))) + | Interpreter.Values.I64 I64Op.Eqz -> + relop Ty_bool Eq s (Expr.value (Num (Num.I64 0L))) + | _ -> failwith "eval_testop: floats" ) + in + (concrete, symbolic) + +(* Evaluate a relative operation *) +let eval_relop ((c1, s1) : Num.t * Expr.t) ((c2, s2) : Num.t * Expr.t) + (op : Interpreter.Ast.relop) : Num.t * Expr.t = + let concrete = + Num.num_of_bool + (Interpreter.Eval_numeric.eval_relop op (to_value c1) (to_value c2)) + in + let symbolic = + match (Expr.view s1, Expr.view s2) with + | Val (Num _), Val (Num _) -> Expr.value (Num concrete) + | _ -> ( + match op with + | Interpreter.Values.I32 x -> i32_relop x s1 s2 + | Interpreter.Values.I64 x -> i64_relop x s1 s2 + | Interpreter.Values.F32 x -> f32_relop x s1 s2 + | Interpreter.Values.F64 x -> f64_relop x s1 s2 ) + in + (concrete, symbolic) + +let eval_cvtop (op : Interpreter.Ast.cvtop) ((c, s) : Num.t * Expr.t) : + Num.t * Expr.t = + let concrete = + of_value (Interpreter.Eval_numeric.eval_cvtop op (to_value c)) + in + let symbolic = + match Expr.view s with + | Val (Num _) -> Expr.value (Num concrete) + | _ -> ( + let (* dispatch cvtop func *) + open Interpreter in + match op with + | Values.I32 x -> i32_cvtop x s + | Values.I64 x -> i64_cvtop x s + | Values.F32 x -> f32_cvtop x s + | Values.F64 x -> f64_cvtop x s ) + in + (concrete, symbolic) diff --git a/src/concolic/execution_tree.ml b/src/concolic/execution_tree.ml new file mode 100644 index 00000000..c6afa94c --- /dev/null +++ b/src/concolic/execution_tree.ml @@ -0,0 +1,56 @@ +type 'a t = + | Leaf + | Node of 'a parent * 'a option * 'a left * 'a right + +and 'a parent = 'a t ref option + +and 'a left = 'a t ref + +and 'a right = 'a t ref + +exception Invalid_branch + +let is_leaf (t : 'a t ref) : bool = match !t with Leaf -> true | _ -> false + +let is_node (t : 'a t ref) : bool = not (is_leaf t) + +let can_branch (t : 'a t ref) : bool = + match !t with + | Leaf -> true + | Node (_, _, l, r) -> ( + match (!l, !r) with Leaf, Leaf -> true | _ -> false ) + +let rec update_node (t : 'a t ref) (v : 'a) : unit = + match !t with + | Leaf -> () + | Node (p, _, l, r) -> + update_node l v; + update_node r v; + t := Node (p, Some v, l, r) + +let find (t : 'a t ref) : 'a option = + match !t with Leaf -> None | Node (_, v, _, _) -> v + +let move_true (t : 'a t ref) : 'a left * bool = + match !t with + | Leaf -> + let l = ref (Node (Some t, None, ref Leaf, ref Leaf)) + and r = ref (Node (Some t, None, ref Leaf, ref Leaf)) in + t := Node (None, None, l, r); + (l, true) + | Node (_, v, l, _) -> + let b = can_branch t in + if is_leaf l then l := Node (Some t, v, ref Leaf, ref Leaf); + (l, b) + +let move_false (t : 'a t ref) : 'a right * bool = + match !t with + | Leaf -> + let l = ref (Node (Some t, None, ref Leaf, ref Leaf)) + and r = ref (Node (Some t, None, ref Leaf, ref Leaf)) in + t := Node (None, None, l, r); + (r, true) + | Node (_, v, _, r) -> + let b = can_branch t in + if is_leaf r then r := Node (Some t, v, ref Leaf, ref Leaf); + (r, b) diff --git a/wasp/lib/symbolic/concolic/execution_tree.mli b/src/concolic/execution_tree.mli similarity index 100% rename from wasp/lib/symbolic/concolic/execution_tree.mli rename to src/concolic/execution_tree.mli diff --git a/src/concolic/heap.ml b/src/concolic/heap.ml new file mode 100644 index 00000000..7a612d76 --- /dev/null +++ b/src/concolic/heap.ml @@ -0,0 +1,277 @@ +open Smtml +open Interpreter.Memory + +type size = int32 + +type address = int64 + +type offset = int32 + +type store = int * Expr.t + +type memory = (address, store) Hashtbl.t + +type t = + { map : memory + ; parent : t option + } + +exception Bounds + +exception InvalidAddress of address + +let packed_size = function Pack8 -> 1 | Pack16 -> 2 | Pack32 -> 4 + +let alloc (sz : int) : t = { map = Hashtbl.create sz; parent = None } + +let size (h : t) : int = + let rec size' accum = function + | None -> accum + | Some h' -> size' (Hashtbl.length h'.map + accum) h'.parent + in + size' (Hashtbl.length h.map) h.parent + +let memcpy (h : t) : t = { map = Hashtbl.copy h.map; parent = h.parent } + +let to_seq (h : t) : (address * store) Seq.t = + let rec to_seq' (acc : (address * store) Seq.t) = function + | None -> acc + | Some h' -> to_seq' (Seq.append (Hashtbl.to_seq h'.map) acc) h'.parent + in + to_seq' (Hashtbl.to_seq h.map) h.parent + +let clone (h : t) : t * t = + ( { map = Hashtbl.create Interpreter.Flags.hashtbl_default_size + ; parent = Some h + } + , { map = Hashtbl.create Interpreter.Flags.hashtbl_default_size + ; parent = Some h + } ) + +let add_seq (h : t) (l : (address * store) Seq.t) : unit = + Seq.iter (fun (a, s) -> Hashtbl.replace h.map a s) l + +let to_list (h : t) : (address * store) list = + Hashtbl.fold (fun a s acc -> (a, s) :: acc) h.map [] + +let to_string (mem : t) : string = + let lst = List.sort (fun (a, _) (b, _) -> compare a b) (to_list mem) in + List.fold_right + (fun (a, (v, e)) b -> + "(" ^ Int64.to_string a ^ "->" ^ "(" ^ string_of_int v ^ ", " + ^ Expr.to_string e ^ ")" ^ ")\n" ^ b ) + lst "" + +let store_byte (h : t) (a : address) (b : store) : unit = + Hashtbl.replace h.map a b + +let load_byte (h : t) (a : address) : store = + let rec load_byte' heap = + match Hashtbl.find_opt heap.map a with + | Some b -> Some b + | None -> Option.bind heap.parent load_byte' + in + match Hashtbl.find_opt h.map a with + | Some b -> b + | None -> ( + match Option.bind h.parent load_byte' with + | Some b -> b + | None -> (0, Expr.make (Extract (Expr.value (Num (I64 0L)), 1, 0))) ) + +let concat bs = List.(fold_left (fun acc e -> Expr.concat e acc) (hd bs) (tl bs)) + +let load_bytes (h : t) (a : address) (n : int) : string * Expr.t = + let buf = Buffer.create n in + let rec rec_loop i acc = + if i = n - 1 then acc + else + let chr, schr = load_byte h Int64.(add a (of_int i)) in + Buffer.add_char buf (Char.chr chr); + rec_loop (i + 1) (schr :: acc) + in + let schrs = Expr.simplify (concat (rec_loop 0 [])) in + (Buffer.contents buf, schrs) + +let load_string (h : t) (a : address) : string = + let rec loop a acc = + let c, _ = load_byte h a in + if c = 0 then acc else loop (Int64.add a 1L) (acc ^ Char.(escaped (chr c))) + in + loop a "" + +let store_bytes (h : t) (a : address) (bs : string) : unit = + for i = String.length bs - 1 downto 0 do + let b = Char.code bs.[i] in + let sb = + Expr.(extract (value (Num (I64 (Int64.of_int b)))) ~high:1 ~low:0) + in + store_byte h Int64.(add a (of_int i)) (b, sb) + done + +let effective_address (a : Int64.t) (o : offset) : address = + let ea = Int64.(add a (of_int32 o)) in + if Smtml.Eval.relop (Ty_bitv 64) LtU (Num (I64 ea)) (Num (I64 a)) then + raise Bounds; + ea + +let loadn (h : t) (a : address) (o : offset) (n : int) = + assert (n > 0 && n <= 8); + let rec loop a n acc = + if n = 0 then acc + else + let x, lacc = acc + and cv, se = load_byte h a in + let x' = Int64.(logor (of_int cv) (shift_left x 8)) in + loop (Int64.sub a 1L) (n - 1) (x', se :: lacc) + in + loop Int64.(add (effective_address a o) (of_int (n - 1))) n (0L, []) + +let storen (h : t) (a : address) (o : offset) (n : int) (x : int64 * Expr.t) : + unit = + assert (n > 0 && n <= 8); + let rec loop a i n x = + if n > i then ( + let concrete, symbolic = x in + let b = Int64.to_int concrete land 0xff in + store_byte h a (b, Expr.make @@ Extract (symbolic, i + 1, i)); + loop (Int64.add a 1L) (i + 1) n (Int64.shift_right concrete 8, symbolic) ) + in + loop (effective_address a o) 0 n x + +let load_value (h : t) (a : address) (o : offset) (t : Ty.t) : Num.t * Expr.t = + let n, exprs = loadn h a o (Ty.size t) in + let expr = Expr.simplify (Expr.simplify (concat exprs)) in + let (n' : Num.t), (expr' : Expr.t) = + match t with + | Ty.Ty_bitv 32 -> + let e = + match Expr.view expr with + | Val (Num (I64 _)) -> Expr.value (Num (I32 (Int64.to_int32 n))) + | _ -> expr + in + (I32 (Int64.to_int32 n), e) + | Ty.Ty_bitv 64 -> (I64 n, expr) + | Ty.Ty_fp 32 -> + let e = + match Expr.view expr with + | Val (Num (I64 v)) -> Expr.value (Num (F32 (Int64.to_int32 v))) + | Cvtop (Ty.Ty_bitv 32, Reinterpret_float, v) -> v + | _ -> Expr.cvtop (Ty.Ty_fp 32) Reinterpret_int expr + in + (F32 (Int64.to_int32 n), e) + | Ty.Ty_fp 64 -> + let e = + match Expr.view expr with + | Val (Num (I64 n)) -> Expr.value (Num (F64 n)) + | Cvtop (Ty.Ty_bitv 64, Reinterpret_float, v) -> v + | _ -> Expr.cvtop (Ty_fp 64) Reinterpret_int expr + in + (F64 n, e) + | _ -> assert false + in + (n', expr') + +let store_value (h : t) (a : address) (o : offset) (v : Num.t * Expr.t) : unit = + let cv, sv = v in + let cv', (sv' : Expr.t) = + match cv with + | I32 x -> + let e = + match Expr.view sv with + | Val (Num (I32 x)) -> Expr.value (Num (I64 (Int64.of_int32 x))) + | _ -> sv + in + (Int64.of_int32 x, e) + | I64 x -> (x, sv) + | F32 x -> + let e = + match Expr.view sv with + | Val (Num (F32 n)) -> Expr.value (Num (I64 (Int64.of_int32 n))) + | _ -> Expr.cvtop (Ty_bitv 32) Reinterpret_float sv + in + (Int64.of_int32 x, e) + | F64 x -> + let e = + match Expr.view sv with + | Val (Num (F64 x)) -> Expr.value (Num (I64 x)) + | _ -> Expr.cvtop (Ty_bitv 64) Reinterpret_float sv + in + (x, e) + | _ -> assert false + in + storen h a o (Ty.size (Num.type_of cv)) (cv', sv') + +let extend x n = function + | ZX -> x + | SX -> + let sh = 64 - (8 * n) in + Int64.(shift_right (shift_left x sh) sh) + +let load_packed (sz : pack_size) (ext : extension) (h : t) (a : address) + (o : offset) (t : Ty.t) : Num.t * Expr.t = + let n = packed_size sz in + let cv, sv = loadn h a o n in + let cv = extend cv n ext in + let x' : Num.t = + match t with + | Ty_bitv 32 -> I32 (Int64.to_int32 cv) + | Ty_bitv 64 -> I64 cv + | _ -> raise Type + in + let sv' : Expr.t = + let v = Expr.simplify (Expr.simplify (concat sv)) in + match Expr.view v with + | Val (Num (I64 x)) -> ( + match t with + | Ty_bitv 32 -> Expr.value (Num (I32 (Int64.to_int32 x))) + | _ -> v ) + | Ptr _ -> v + | _ -> + let rec loop acc i = + if i >= Ty.size t then acc + else + loop + (acc @ [ Expr.make @@ Extract (Expr.value (Num (I64 0L)), 1, 0) ]) + (i + 1) + in + concat (loop sv (List.length sv)) + in + (x', sv') + +let store_packed (sz : pack_size) (h : t) (a : address) (o : offset) + (v : Num.t * Expr.t) : unit = + let n = packed_size sz in + let cv, sv = v in + let x = + match cv with I32 x -> Int64.of_int32 x | I64 x -> x | _ -> raise Type + in + let sx : Expr.t = + match Expr.view sv with + | Val (Num (I32 x)) -> Expr.value (Num (I64 (Int64.of_int32 x))) + | _ -> sv + in + storen h a o n (x, sx) + +let update (h : t) (store : Store.t) : unit = + let eval_heap heap sto = + Hashtbl.iter + (fun a (_, se) -> + let i = + match Store.eval sto se with + | Num (I32 x) -> Int32.to_int x + | Num (I64 x) -> Int64.to_int x + | Num (F32 x) -> Int32.to_int x + | Num (F64 x) -> Int64.to_int x + | _ -> assert false + in + store_byte heap a (i, se) ) + heap.map + in + let rec update' = function + | None -> () + | Some h' -> + eval_heap h' store; + update' h'.parent + in + eval_heap h store; + update' h.parent diff --git a/wasp/lib/symbolic/concolic/heap.mli b/src/concolic/heap.mli similarity index 59% rename from wasp/lib/symbolic/concolic/heap.mli rename to src/concolic/heap.mli index 6c05a7df..081fb1d9 100644 --- a/wasp/lib/symbolic/concolic/heap.mli +++ b/src/concolic/heap.mli @@ -1,43 +1,57 @@ -open Encoding -open Types +open Smtml open Interpreter.Memory type memory + type t + type size = int32 + type address = int64 + type offset = int32 -type store = int * Expression.t + +type store = int * Expr.t exception Bounds + exception InvalidAddress of address val packed_size : pack_size -> int + val alloc : int -> t + val size : t -> int + val memcpy : t -> t + val clone : t -> t * t + val add_seq : t -> (address * store) Seq.t -> unit + val to_seq : t -> (address * store) Seq.t + val update : t -> Store.t -> unit + val to_list : t -> (address * store) list + val to_string : t -> string + val load_byte : t -> address -> store + val store_byte : t -> address -> store -> unit + val load_string : t -> address -> string -val load_bytes : t -> address -> int -> string * Expression.t + +val load_bytes : t -> address -> int -> string * Expr.t + val store_bytes : t -> address -> string -> unit -val load_value : t -> address -> offset -> num_type -> Num.t * Expression.t -val store_value : t -> address -> offset -> Num.t * Expression.t -> unit + +val load_value : t -> address -> offset -> Ty.t -> Num.t * Expr.t + +val store_value : t -> address -> offset -> Num.t * Expr.t -> unit val load_packed : - pack_size -> - extension -> - t -> - address -> - offset -> - num_type -> - Num.t * Expression.t - -val store_packed : - pack_size -> t -> address -> offset -> Num.t * Expression.t -> unit + pack_size -> extension -> t -> address -> offset -> Ty.t -> Num.t * Expr.t + +val store_packed : pack_size -> t -> address -> offset -> Num.t * Expr.t -> unit diff --git a/src/concolic/store.ml b/src/concolic/store.ml new file mode 100644 index 00000000..a421cc35 --- /dev/null +++ b/src/concolic/store.ml @@ -0,0 +1,203 @@ +open Common +open Smtml + +type name = string + +type bind = name * Num.t + +type store = + { sym : name Counter.t + ; ord : name Stack.t + ; map : (name, Num.t) Hashtbl.t + } + +type t = store + +let reset (s : t) : unit = + Counter.clear s.sym; + Hashtbl.clear s.map; + Stack.clear s.ord + +let copy (s : t) : t = + let sym = Counter.copy s.sym + and ord = Stack.copy s.ord + and map = Hashtbl.copy s.map in + { sym; ord; map } + +let clear (s : t) : unit = Hashtbl.clear s.map + +let init (s : t) (binds : (Symbol.t * Value.t) list) : unit = + List.iter + (fun (x, v) -> + match v with + | Value.Num n -> Hashtbl.replace s.map (Symbol.to_string x) n + | _ -> assert false ) + binds + +let from_parts (sym : name Counter.t) (ord : name Stack.t) + (map : (name, Num.t) Hashtbl.t) : t = + { sym; ord; map } + +let create (binds : (Symbol.t * Value.t) list) : t = + let s = + { sym = Counter.create () + ; ord = Stack.create () + ; map = Hashtbl.create Interpreter.Flags.hashtbl_default_size + } + in + init s binds; + s + +let add (s : t) (x : name) (v : Num.t) : unit = + Stack.push x s.ord; + Hashtbl.replace s.map x v + +let find (s : t) (x : name) : Num.t = Hashtbl.find s.map x + +let find_opt (s : t) (x : name) : Num.t option = Hashtbl.find_opt s.map x + +let exists (s : t) (x : name) : bool = Hashtbl.mem s.map x + +let get (s : t) (x : name) (ty : Ty.t) (b : bool) : Num.t = + let v = + match find_opt s x with + | Some v -> v + | None -> ( + match ty with + | Ty.Ty_bitv 32 -> + Num.I32 (Int32.of_int (Random.int (if b then 2 else 127))) + | Ty.Ty_bitv 64 -> Num.I64 (Int64.of_int (Random.int 127)) + | Ty.Ty_fp 32 -> Num.F32 (Int32.bits_of_float (Random.float 127.0)) + | Ty.Ty_fp 64 -> Num.F64 (Int64.bits_of_float (Random.float 127.0)) + | _ -> assert false ) + in + add s x v; + v + +let next (s : t) (x : name) : name = + let id = Counter.get_and_inc s.sym x in + if id = 0 then x else x ^ "_" ^ string_of_int id + +let is_empty (s : t) : bool = 0 = Hashtbl.length s.map + +let update (s : t) (binds : (Symbol.t * Value.t) list) : unit = + List.iter + (fun (x, v) -> + match v with + | Value.Num n -> Hashtbl.replace s.map (Symbol.to_string x) n + | _ -> assert false ) + binds + +let to_json (s : t) : string = + let jsonify_bind (b : bind) : string = + let n, v = b in + "{" ^ "\"name\" : \"" ^ n ^ "\", " ^ "\"value\" : \"" ^ Num.to_string v + ^ "\", " ^ "\"type\" : \"" + ^ Ty.string_of_type (Num.type_of v) + ^ "\"" ^ "}" + in + "[" + ^ String.concat "," + (Seq.fold_left + (fun a x -> jsonify_bind (x, find s x) :: a) + [] (Stack.to_seq s.ord) ) + ^ "]" + +let strings_to_json string_env : string = + let jsonify_bind b : string = + let t, x, v = b in + "{" ^ "\"name\" : \"" ^ x ^ "\", " ^ "\"value\" : \"" ^ v ^ "\", " + ^ "\"type\" : \"" ^ t ^ "\"" ^ "}" + in + "[" ^ String.concat ", " (List.map jsonify_bind string_env) ^ "]" + +let to_string (s : t) : string = + Seq.fold_left + (fun a k -> + let v = find s k in + a ^ "(" ^ k ^ "->" ^ Num.to_string v ^ ")\n" ) + "" (Stack.to_seq s.ord) + +let get_key_types (s : t) : Symbol.t list = + Hashtbl.fold (fun k v acc -> Symbol.make (Num.type_of v) k :: acc) s.map [] + +let to_expr (s : t) : Expr.t list = + Hashtbl.fold + (fun k (n : Num.t) acc -> + let e = + match n with + | Num.I32 _ -> + let sym = Expr.symbol (Symbol.make (Ty.Ty_bitv 32) k) in + Expr.(relop Ty.Ty_bool Ty.Eq sym (value (Value.Num n))) + | Num.I64 _ -> + let sym = Expr.symbol (Symbol.make (Ty.Ty_bitv 64) k) in + Expr.(relop Ty.Ty_bool Ty.Eq sym (value (Value.Num n))) + | Num.F32 _ -> + let sym = Expr.symbol (Symbol.make (Ty.Ty_fp 32) k) in + Expr.(relop (Ty.Ty_fp 32) Ty.Eq sym (value (Value.Num n))) + | Num.F64 _ -> + let sym = Expr.symbol (Symbol.make (Ty.Ty_fp 64) k) in + Expr.(relop (Ty.Ty_fp 64) Ty.Eq sym (value (Value.Num n))) + | _ -> assert false + in + e :: acc ) + s.map [] + +let int64_of_value (v : Value.t) : int64 = + match v with + | Num (I32 i | F32 i) -> Int64.of_int32 i + | Num (I64 i | F64 i) -> i + | _ -> assert false + +let rec eval (env : t) (e : Expr.t) : Value.t = + let open Ty in + let open Expr in + match Expr.(view (simplify e)) with + | Ptr { base; offset } -> + let b = Value.Num (Num.I32 base) in + Smtml.Eval.binop (Ty_bitv 32) Add b (eval env offset) + | Val (Value.Num _ as v) -> v + | Binop (ty, op, e1, e2) -> + let v1 = eval env e1 in + let v2 = eval env e2 in + Smtml.Eval.binop ty op v1 v2 + | Unop (ty, op, e') -> + let v = eval env e' in + Smtml.Eval.unop ty op v + | Relop (ty, op, e1, e2) -> + let v1 = eval env e1 in + let v2 = eval env e2 in + Num (Num.num_of_bool (Smtml.Eval.relop ty op v1 v2)) + | Cvtop (ty, op, e) -> + let v = eval env e in + Smtml.Eval.cvtop ty op v + | Symbol s -> ( + let x = Symbol.to_string s in + match find_opt env x with + | Some v -> Num v + | None -> + let v : Num.t = + match Symbol.type_of s with + | Ty.Ty_bitv 32 -> I32 (Int32.of_int (Random.int 127)) + | Ty.Ty_bitv 64 -> I64 (Int64.of_int (Random.int 127)) + | Ty.Ty_fp 32 -> F32 (Int32.bits_of_float (Random.float 127.0)) + | Ty.Ty_fp 64 -> F64 (Int64.bits_of_float (Random.float 127.0)) + | _ -> assert false + in + Hashtbl.replace env.map x v; + Num v ) + | Extract (e, _, _) -> + let _v = int64_of_value (eval env e) in + (* Num (I64 (Expr.nland64 (Int64.shift_right v (l * 8)) (h - l))) *) + assert false + | Concat (e1, e2) -> ( + let v1 = int64_of_value (eval env e1) in + let v2 = int64_of_value (eval env e2) in + match (Expr.view e1, Expr.view e2) with + | Extract (_, h1, l1), Extract (_, h2, l2) -> + let i = Int64.(logor (shift_left v1 (l1 * 8)) (shift_left v2 (l2 * 8))) in + Num (if h1 - l2 + (h2 - l2) = 4 then I32 (Int64.to_int32 i) else I64 i) + | Extract (_, _, l), Concat _ -> + Num (I64 Int64.(logor (shift_left v1 (l * 8)) v2)) + | _ -> assert false ) + | Val _ | Triop _ | List _ | Naryop _ | App _ -> assert false diff --git a/wasp/lib/symbolic/dune b/src/dune similarity index 58% rename from wasp/lib/symbolic/dune rename to src/dune index e562ab03..a373d064 100644 --- a/wasp/lib/symbolic/dune +++ b/src/dune @@ -3,4 +3,4 @@ (library (name wasp) (modules :standard \ btree) - (libraries interpreter concolic static encoding)) + (libraries interpreter concolic static smtml)) diff --git a/wasp/lib/binary/decode.ml b/src/interpreter/binary/decode.ml similarity index 100% rename from wasp/lib/binary/decode.ml rename to src/interpreter/binary/decode.ml diff --git a/wasp/lib/binary/decode.mli b/src/interpreter/binary/decode.mli similarity index 100% rename from wasp/lib/binary/decode.mli rename to src/interpreter/binary/decode.mli diff --git a/wasp/lib/binary/encode.ml b/src/interpreter/binary/encode.ml similarity index 100% rename from wasp/lib/binary/encode.ml rename to src/interpreter/binary/encode.ml diff --git a/wasp/lib/binary/encode.mli b/src/interpreter/binary/encode.mli similarity index 100% rename from wasp/lib/binary/encode.mli rename to src/interpreter/binary/encode.mli diff --git a/wasp/lib/binary/utf8.ml b/src/interpreter/binary/utf8.ml similarity index 94% rename from wasp/lib/binary/utf8.ml rename to src/interpreter/binary/utf8.ml index 61d13955..813be230 100644 --- a/wasp/lib/binary/utf8.ml +++ b/src/interpreter/binary/utf8.ml @@ -6,7 +6,7 @@ let rec encode ns = Lib.String.implode (List.map Char.chr (encode' ns)) and encode' = function | [] -> [] - | n :: ns when n < 0 -> raise Utf8 + | n :: _ when n < 0 -> raise Utf8 | n :: ns when n < 0x80 -> n :: encode' ns | n :: ns when n < 0x800 -> (0xc0 lor (n lsr 6)) :: con n :: encode' ns | n :: ns when n < 0x10000 -> @@ -29,7 +29,7 @@ let rec decode s = decode' (List.map Char.code (Lib.String.explode s)) and decode' = function | [] -> [] | b1 :: bs when b1 < 0x80 -> code 0x0 b1 :: decode' bs - | b1 :: bs when b1 < 0xc0 -> raise Utf8 + | b1 :: _ when b1 < 0xc0 -> raise Utf8 | b1 :: b2 :: bs when b1 < 0xe0 -> code 0x80 (((b1 land 0x1f) lsl 6) + con b2) :: decode' bs | b1 :: b2 :: b3 :: bs when b1 < 0xf0 -> diff --git a/wasp/lib/binary/utf8.mli b/src/interpreter/binary/utf8.mli similarity index 100% rename from wasp/lib/binary/utf8.mli rename to src/interpreter/binary/utf8.mli diff --git a/wasp/lib/dune b/src/interpreter/dune similarity index 82% rename from wasp/lib/dune rename to src/interpreter/dune index bee2aa85..a9400b4f 100644 --- a/wasp/lib/dune +++ b/src/interpreter/dune @@ -1,8 +1,7 @@ (include_subdirs unqualified) (library - (name interpreter) - (modules :standard \ wasm)) + (name interpreter)) (subdir text diff --git a/src/interpreter/exec/eval.ml b/src/interpreter/exec/eval.ml new file mode 100644 index 00000000..ca57f153 --- /dev/null +++ b/src/interpreter/exec/eval.ml @@ -0,0 +1,406 @@ +open Values +open Types +open Instance +open Ast +open Source [@@@ocaml.warning "-27"] + +(* Errors *) + +module Link = Error.Make () +module Trap = Error.Make () +module Crash = Error.Make () +module Exhaustion = Error.Make () + +exception Link = Link.Error + +exception Trap = Trap.Error + +exception Crash = Crash.Error (* failure that cannot happen in valid code *) + +exception Exhaustion = Exhaustion.Error + +let memory_error at = function + | Memory.Bounds -> "out of bounds memory access" + | Memory.SizeOverflow -> "memory size overflow" + | Memory.SizeLimit -> "memory size limit reached" + | Memory.Type -> Crash.error at "type mismatch at memory access" + | exn -> raise exn + +let numeric_error at = function + | Numeric_error.IntegerOverflow -> "integer overflow" + | Numeric_error.IntegerDivideByZero -> "integer divide by zero" + | Numeric_error.InvalidConversionToInteger -> "invalid conversion to integer" + | Eval_numeric.TypeError (i, v, t) -> + Crash.error at + ( "type error, expected " + ^ Types.string_of_value_type t + ^ " as operand " ^ string_of_int i ^ ", got " + ^ Types.string_of_value_type (type_of v) ) + | exn -> raise exn + +(* Administrative Expressions & Configurations *) + +type 'a stack = 'a list + +type frame = + { inst : module_inst + ; locals : value ref list + } + +type code = value stack * admin_instr list + +and admin_instr = admin_instr' phrase + +and admin_instr' = + | Plain of instr' + | Invoke of func_inst + | Trapping of string + | Returning of value stack + | Breaking of int32 * value stack + | Label of int * instr list * code + | Frame of int * frame * code + +type config = + { frame : frame + ; code : code + ; budget : int (* to model stack overflow *) + } + +let frame inst locals = { inst; locals } + +let config inst vs es = { frame = frame inst []; code = (vs, es); budget = 300 } + +let plain e = Plain e.it @@ e.at + +let lookup category list x = + try Lib.List32.nth list x.it + with Failure _ -> + Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) + +let type_ (inst : module_inst) x = lookup "type" inst.types x + +let func (inst : module_inst) x = lookup "function" inst.funcs x + +let table (inst : module_inst) x = lookup "table" inst.tables x + +let memory (inst : module_inst) x = lookup "memory" inst.memories x + +let global (inst : module_inst) x = lookup "global" inst.globals x + +let local (frame : frame) x = lookup "local" frame.locals x + +let elem inst x i at = + match Table.load (table inst x) i with + | Table.Uninitialized -> + Trap.error at ("uninitialized element " ^ Int32.to_string i) + | f -> f + | exception Table.Bounds -> + Trap.error at ("undefined element " ^ Int32.to_string i) + +let func_elem inst x i at = + match elem inst x i at with + | FuncElem f -> f + | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) + +let take n (vs : 'a stack) at = + try Lib.List.take n vs with Failure _ -> Crash.error at "stack underflow" + +let drop n (vs : 'a stack) at = + try Lib.List.drop n vs with Failure _ -> Crash.error at "stack underflow" + +(* Evaluation *) + +(* + * Conventions: + * e : instr + * v : value + * es : instr list + * vs : value stack + * c : config + *) + +let rec step (c : config) : config = + let { frame; code = vs, es; _ } = c in + let e = List.hd es in + let vs', es' = + match (e.it, vs) with + | Plain e', vs -> ( + match (e', vs) with + | Unreachable, vs -> (vs, [ Trapping "unreachable executed" @@ e.at ]) + | Nop, vs -> (vs, []) + | Block (ts, es'), vs -> + (vs, [ Label (List.length ts, [], ([], List.map plain es')) @@ e.at ]) + | Loop (_, es'), vs -> + (vs, [ Label (0, [ e' @@ e.at ], ([], List.map plain es')) @@ e.at ]) + | If (ts, _, es2), I32 0l :: vs' -> + (vs', [ Plain (Block (ts, es2)) @@ e.at ]) + | If (ts, es1, _), I32 _ :: vs' -> + (vs', [ Plain (Block (ts, es1)) @@ e.at ]) + | Br x, vs -> ([], [ Breaking (x.it, vs) @@ e.at ]) + | BrIf _, I32 0l :: vs' -> (vs', []) + | BrIf x, I32 _ :: vs' -> (vs', [ Plain (Br x) @@ e.at ]) + | BrTable (xs, x), I32 i :: vs' when I32.ge_u i (Lib.List32.length xs) -> + (vs', [ Plain (Br x) @@ e.at ]) + | BrTable (xs, x), I32 i :: vs' -> + (vs', [ Plain (Br (Lib.List32.nth xs i)) @@ e.at ]) + | Return, vs -> ([], [ Returning vs @@ e.at ]) + | Call x, vs -> (vs, [ Invoke (func frame.inst x) @@ e.at ]) + | CallIndirect x, I32 i :: vs -> + let func = func_elem frame.inst (0l @@ e.at) i e.at in + if type_ frame.inst x <> Func.type_of func then + (vs, [ Trapping "indirect call type mismatch" @@ e.at ]) + else (vs, [ Invoke func @@ e.at ]) + | Drop, v :: vs' -> (vs', []) + | Select, I32 0l :: v2 :: v1 :: vs' -> (v2 :: vs', []) + | Select, I32 i :: v2 :: v1 :: vs' -> (v1 :: vs', []) + | LocalGet x, vs -> (!(local frame x) :: vs, []) + | LocalSet x, v :: vs' -> + local frame x := v; + (* x-ésima variavel tem o valor v, avalia para o pointer daquela local *) + ( vs' + , [] + (* tira da stack e nao ha mais intruções depois --> este codigo vai ficar igual *) + ) + | LocalTee x, v :: vs' -> + local frame x := v; + (v :: vs', []) + | GlobalGet x, vs -> (Global.load (global frame.inst x) :: vs, []) + | GlobalSet x, v :: vs' -> ( + try + Global.store (global frame.inst x) v; + (vs', []) + with + | Global.NotMutable -> Crash.error e.at "write to immutable global" + | Global.Type -> Crash.error e.at "type mismatch at global write" ) + | Load { offset; ty; sz; _ }, I32 i :: vs' -> ( + (* agr n interessa pq nao tamos a ver a heap*) + Printf.printf "--- A LOAD WAS MADE ----\n"; + let mem = memory frame.inst (0l @@ e.at) in + let addr = I64_convert.extend_i32_u i in + try + let v = + match sz with + | None -> Memory.load_value mem addr offset ty + | Some (sz, ext) -> Memory.load_packed sz ext mem addr offset ty + in + (v :: vs', []) + with exn -> (vs', [ Trapping (memory_error e.at exn) @@ e.at ]) ) + | Store { offset; sz; _ }, v :: I32 i :: vs' -> ( + (* agr n interessa pq nao tamos a ver a heap*) + Printf.printf "--- A STORE WAS MADE ---\n"; + let mem = memory frame.inst (0l @@ e.at) in + let addr = I64_convert.extend_i32_u i in + try + ( match sz with + | None -> Memory.store_value mem addr offset v + | Some sz -> Memory.store_packed sz mem addr offset v ); + (vs', []) + with exn -> (vs', [ Trapping (memory_error e.at exn) @@ e.at ]) ) + | MemorySize, vs -> + let mem = memory frame.inst (0l @@ e.at) in + (I32 (Memory.size mem) :: vs, []) + | MemoryGrow, I32 delta :: vs' -> + let mem = memory frame.inst (0l @@ e.at) in + let old_size = Memory.size mem in + let result = + try + Memory.grow mem delta; + old_size + with Memory.SizeOverflow | Memory.SizeLimit | Memory.OutOfMemory -> + -1l + in + (I32 result :: vs', []) + | Const v, vs -> (v.it :: vs, []) + | Test testop, v :: vs' -> ( + try (value_of_bool (Eval_numeric.eval_testop testop v) :: vs', []) + with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ]) ) + | Compare relop, v2 :: v1 :: vs' -> ( + try (value_of_bool (Eval_numeric.eval_relop relop v1 v2) :: vs', []) + with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ]) ) + | Unary unop, v :: vs' -> ( + try (Eval_numeric.eval_unop unop v :: vs', []) + with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ]) ) + | Binary binop, v2 :: v1 :: vs' -> ( + try (Eval_numeric.eval_binop binop v1 v2 :: vs', []) + with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ]) ) + | Convert cvtop, v :: vs' -> ( + try (Eval_numeric.eval_cvtop cvtop v :: vs', []) + with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ]) ) + | _ -> + let s1 = string_of_values (List.rev vs) in + let s2 = string_of_value_types (List.map type_of (List.rev vs)) in + Crash.error e.at + ("missing or ill-typed operand on stack (" ^ s1 ^ " : " ^ s2 ^ ")") ) + | Trapping msg, vs -> assert false + | Returning vs', vs -> Crash.error e.at "undefined frame" + | Breaking (k, vs'), vs -> Crash.error e.at "undefined label" + | Label (n, es0, (vs', [])), vs -> (vs' @ vs, []) + | Label (n, es0, (vs', { it = Trapping msg; at } :: es')), vs -> + (vs, [ Trapping msg @@ at ]) + | Label (n, es0, (vs', { it = Returning vs0; at } :: es')), vs -> + (vs, [ Returning vs0 @@ at ]) + | Label (n, es0, (vs', { it = Breaking (0l, vs0); at } :: es')), vs -> + (take n vs0 e.at @ vs, List.map plain es0) + | Label (n, es0, (vs', { it = Breaking (k, vs0); at } :: es')), vs -> + (vs, [ Breaking (Int32.sub k 1l, vs0) @@ at ]) + | Label (n, es0, code'), vs -> + let c' = step { c with code = code' } in + (vs, [ Label (n, es0, c'.code) @@ e.at ]) + | Frame (n, frame', (vs', [])), vs -> (vs' @ vs, []) + | Frame (n, frame', (vs', { it = Trapping msg; at } :: es')), vs -> + (vs, [ Trapping msg @@ at ]) + | Frame (n, frame', (vs', { it = Returning vs0; at } :: es')), vs -> + (take n vs0 e.at @ vs, []) + | Frame (n, frame', code'), vs -> + let c' = step { frame = frame'; code = code'; budget = c.budget - 1 } in + (vs, [ Frame (n, c'.frame, c'.code) @@ e.at ]) + | Invoke func, vs when c.budget = 0 -> + Exhaustion.error e.at "call stack exhausted" + | Invoke func, vs -> ( + let (FuncType (ins, out)) = Func.type_of func in + let n = List.length ins in + let args, vs' = (take n vs e.at, drop n vs e.at) in + match func with + | Func.AstFunc (t, inst', f) -> + let locals' = List.rev args @ List.map default_value f.it.locals in + let code' = ([], [ Plain (Block (out, f.it.body)) @@ f.at ]) in + let frame' = { inst = !inst'; locals = List.map ref locals' } in + (vs', [ Frame (List.length out, frame', code') @@ e.at ]) + | Func.HostFunc (t, f) -> ( + try (List.rev (f (List.rev args)) @ vs', []) + with Crash (_, msg) -> Crash.error e.at msg ) ) + in + { c with code = (vs', es' @ List.tl es) } + +let rec eval (c : config) : value stack = + match c.code with + | vs, [] -> vs + | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg + | vs, es -> eval (step c) + +(* Functions & Constants *) + +let invoke (func : func_inst) (vs : value list) : value list = + let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in + let (FuncType (ins, out)) = Func.type_of func in + if List.map Values.type_of vs <> ins then + Crash.error at "wrong number or types of arguments"; + let c = config empty_module_inst (List.rev vs) [ Invoke func @@ at ] in + try List.rev (eval c) + with Stack_overflow -> Exhaustion.error at "call stack exhausted" + +let eval_const (inst : module_inst) (const : const) : value = + let c = config inst [] (List.map plain const.it) in + match eval c with + | [ v ] -> v + | _ -> Crash.error const.at "wrong number of results on stack" + +let i32 (v : value) at = + match v with + | I32 i -> i + | _ -> Crash.error at "type error: i32 value expected" + +(* Modules *) + +let create_func (inst : module_inst) (f : func) : func_inst = + Func.alloc (type_ inst f.it.ftype) (ref inst) f + +let create_table (_ : module_inst) (tab : table) : table_inst = + let { ttype } = tab.it in + Table.alloc ttype + +let create_memory (_ : module_inst) (mem : memory) : memory_inst = + let { mtype } = mem.it in + Memory.alloc mtype + +let create_global (inst : module_inst) (glob : global) : global_inst = + let { gtype; value } = glob.it in + let v = eval_const inst value in + Global.alloc gtype v + +let create_export (inst : module_inst) (ex : export) : export_inst = + let { name; edesc } = ex.it in + let ext = + match edesc.it with + | FuncExport x -> ExternFunc (func inst x) + | TableExport x -> ExternTable (table inst x) + | MemoryExport x -> ExternMemory (memory inst x) + | GlobalExport x -> ExternGlobal (global inst x) + in + (name, ext) + +let init_func (inst : module_inst) (func : func_inst) = + match func with + | Func.AstFunc (_, inst_ref, _) -> inst_ref := inst + | _ -> assert false + +let init_table (inst : module_inst) (seg : table_segment) = + let { index; offset = const; init } = seg.it in + let tab = table inst index in + let offset = i32 (eval_const inst const) const.at in + let end_ = Int32.(add offset (of_int (List.length init))) in + let bound = Table.size tab in + if I32.lt_u bound end_ || I32.lt_u end_ offset then + Link.error seg.at "elements segment does not fit table"; + fun () -> + Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init) + +let init_memory (inst : module_inst) (seg : memory_segment) = + let { index; offset = const; init } = seg.it in + let mem = memory inst index in + let offset' = i32 (eval_const inst const) const.at in + let offset = I64_convert.extend_i32_u offset' in + let end_ = Int64.(add offset (of_int (String.length init))) in + let bound = Memory.bound mem in + if I64.lt_u bound end_ || I64.lt_u end_ offset then + Link.error seg.at "data segment does not fit memory"; + fun () -> Memory.store_bytes mem offset init + +let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : + module_inst = + if not (match_extern_type (extern_type_of ext) (import_type m im)) then + Link.error im.at "incompatible import type"; + match ext with + | ExternFunc func -> { inst with funcs = func :: inst.funcs } + | ExternTable tab -> { inst with tables = tab :: inst.tables } + | ExternMemory mem -> { inst with memories = mem :: inst.memories } + | ExternGlobal glob -> { inst with globals = glob :: inst.globals } + +let init (m : module_) (exts : extern list) : module_inst = + let { imports + ; tables + ; memories + ; globals + ; funcs + ; types + ; exports + ; elems + ; data + ; start + } = + m.it + in + if List.length exts <> List.length imports then + Link.error m.at "wrong number of imports provided for initialisation"; + let inst0 = + { (List.fold_right2 (add_import m) exts imports empty_module_inst) with + types = List.map (fun type_ -> type_.it) types + } + in + let fs = List.map (create_func inst0) funcs in + let inst1 = + { inst0 with + funcs = inst0.funcs @ fs + ; tables = inst0.tables @ List.map (create_table inst0) tables + ; memories = inst0.memories @ List.map (create_memory inst0) memories + ; globals = inst0.globals @ List.map (create_global inst0) globals + } + in + let inst = { inst1 with exports = List.map (create_export inst1) exports } in + List.iter (init_func inst) fs; + let init_elems = List.map (init_table inst) elems in + let init_datas = List.map (init_memory inst) data in + List.iter (fun f -> f ()) init_elems; + List.iter (fun f -> f ()) init_datas; + Lib.Option.app (fun x -> ignore (invoke (func inst x) [])) start; + inst diff --git a/wasp/lib/exec/eval.mli b/src/interpreter/exec/eval.mli similarity index 100% rename from wasp/lib/exec/eval.mli rename to src/interpreter/exec/eval.mli diff --git a/wasp/lib/exec/eval_numeric.ml b/src/interpreter/exec/eval_numeric.ml similarity index 99% rename from wasp/lib/exec/eval_numeric.ml rename to src/interpreter/exec/eval_numeric.ml index 89d90e70..292ed033 100644 --- a/wasp/lib/exec/eval_numeric.ml +++ b/src/interpreter/exec/eval_numeric.ml @@ -100,7 +100,7 @@ module FloatOp (FXX : Float.S) (Value : ValueType with type t = FXX.t) = struct in fun v1 v2 -> to_value (f (of_value 1 v1) (of_value 2 v2)) - let testop op = assert false + let testop _ = assert false let relop op = let f = diff --git a/wasp/lib/exec/eval_numeric.mli b/src/interpreter/exec/eval_numeric.mli similarity index 100% rename from wasp/lib/exec/eval_numeric.mli rename to src/interpreter/exec/eval_numeric.mli diff --git a/wasp/lib/exec/f32.ml b/src/interpreter/exec/f32.ml similarity index 100% rename from wasp/lib/exec/f32.ml rename to src/interpreter/exec/f32.ml diff --git a/wasp/lib/exec/f32_convert.ml b/src/interpreter/exec/f32_convert.ml similarity index 100% rename from wasp/lib/exec/f32_convert.ml rename to src/interpreter/exec/f32_convert.ml diff --git a/wasp/lib/exec/f32_convert.mli b/src/interpreter/exec/f32_convert.mli similarity index 100% rename from wasp/lib/exec/f32_convert.mli rename to src/interpreter/exec/f32_convert.mli diff --git a/wasp/lib/exec/f64.ml b/src/interpreter/exec/f64.ml similarity index 100% rename from wasp/lib/exec/f64.ml rename to src/interpreter/exec/f64.ml diff --git a/wasp/lib/exec/f64_convert.ml b/src/interpreter/exec/f64_convert.ml similarity index 100% rename from wasp/lib/exec/f64_convert.ml rename to src/interpreter/exec/f64_convert.ml diff --git a/wasp/lib/exec/f64_convert.mli b/src/interpreter/exec/f64_convert.mli similarity index 100% rename from wasp/lib/exec/f64_convert.mli rename to src/interpreter/exec/f64_convert.mli diff --git a/wasp/lib/exec/float.ml b/src/interpreter/exec/float.ml similarity index 100% rename from wasp/lib/exec/float.ml rename to src/interpreter/exec/float.ml diff --git a/wasp/lib/exec/i32.ml b/src/interpreter/exec/i32.ml similarity index 100% rename from wasp/lib/exec/i32.ml rename to src/interpreter/exec/i32.ml diff --git a/wasp/lib/exec/i32_convert.ml b/src/interpreter/exec/i32_convert.ml similarity index 100% rename from wasp/lib/exec/i32_convert.ml rename to src/interpreter/exec/i32_convert.ml diff --git a/wasp/lib/exec/i32_convert.mli b/src/interpreter/exec/i32_convert.mli similarity index 100% rename from wasp/lib/exec/i32_convert.mli rename to src/interpreter/exec/i32_convert.mli diff --git a/wasp/lib/exec/i64.ml b/src/interpreter/exec/i64.ml similarity index 100% rename from wasp/lib/exec/i64.ml rename to src/interpreter/exec/i64.ml diff --git a/wasp/lib/exec/i64_convert.ml b/src/interpreter/exec/i64_convert.ml similarity index 100% rename from wasp/lib/exec/i64_convert.ml rename to src/interpreter/exec/i64_convert.ml diff --git a/wasp/lib/exec/i64_convert.mli b/src/interpreter/exec/i64_convert.mli similarity index 100% rename from wasp/lib/exec/i64_convert.mli rename to src/interpreter/exec/i64_convert.mli diff --git a/wasp/lib/exec/int.ml b/src/interpreter/exec/int.ml similarity index 99% rename from wasp/lib/exec/int.ml rename to src/interpreter/exec/int.ml index e09badaf..a5cd474c 100644 --- a/wasp/lib/exec/int.ml +++ b/src/interpreter/exec/int.ml @@ -115,7 +115,7 @@ struct (* result is floored (which is the same as truncating for unsigned values) *) let div_u x y = - let q, r = divrem_u x y in + let q, _ = divrem_u x y in q (* result has the sign of the dividend *) @@ -124,7 +124,7 @@ struct else Rep.rem x y let rem_u x y = - let q, r = divrem_u x y in + let _, r = divrem_u x y in r let and_ = Rep.logand diff --git a/wasp/lib/exec/numeric_error.ml b/src/interpreter/exec/numeric_error.ml similarity index 100% rename from wasp/lib/exec/numeric_error.ml rename to src/interpreter/exec/numeric_error.ml diff --git a/wasp/lib/host/env.ml b/src/interpreter/host/env.ml similarity index 88% rename from wasp/lib/host/env.ml rename to src/interpreter/host/env.ml index 402302f3..8502944f 100644 --- a/wasp/lib/host/env.ml +++ b/src/interpreter/host/env.ml @@ -15,12 +15,12 @@ let type_error v t = ("type error, expected " ^ string_of_value_type t ^ ", got " ^ string_of_value_type (type_of v)) -let empty = function [] -> () | vs -> error "type error, too many arguments" +let empty = function [] -> () | _ -> error "type error, too many arguments" let single = function | [] -> error "type error, missing arguments" | [ v ] -> v - | vs -> error "type error, too many arguments" + | _ -> error "type error, too many arguments" let int = function I32 i -> Int32.to_int i | v -> type_error v I32Type diff --git a/wasp/lib/host/spectest.ml b/src/interpreter/host/spectest.ml similarity index 100% rename from wasp/lib/host/spectest.ml rename to src/interpreter/host/spectest.ml diff --git a/wasp/lib/main/flags.ml b/src/interpreter/main/flags.ml similarity index 100% rename from wasp/lib/main/flags.ml rename to src/interpreter/main/flags.ml diff --git a/wasp/lib/meta/findlib/META b/src/interpreter/meta/findlib/META similarity index 100% rename from wasp/lib/meta/findlib/META rename to src/interpreter/meta/findlib/META diff --git a/wasp/lib/meta/jslib/bsconfig.json b/src/interpreter/meta/jslib/bsconfig.json similarity index 100% rename from wasp/lib/meta/jslib/bsconfig.json rename to src/interpreter/meta/jslib/bsconfig.json diff --git a/wasp/lib/meta/jslib/build.sh b/src/interpreter/meta/jslib/build.sh similarity index 100% rename from wasp/lib/meta/jslib/build.sh rename to src/interpreter/meta/jslib/build.sh diff --git a/wasp/lib/meta/jslib/wasm.ml b/src/interpreter/meta/jslib/wasm.ml similarity index 100% rename from wasp/lib/meta/jslib/wasm.ml rename to src/interpreter/meta/jslib/wasm.ml diff --git a/wasp/lib/meta/travis/build-test.sh b/src/interpreter/meta/travis/build-test.sh similarity index 100% rename from wasp/lib/meta/travis/build-test.sh rename to src/interpreter/meta/travis/build-test.sh diff --git a/wasp/lib/meta/travis/install-ocaml.sh b/src/interpreter/meta/travis/install-ocaml.sh similarity index 100% rename from wasp/lib/meta/travis/install-ocaml.sh rename to src/interpreter/meta/travis/install-ocaml.sh diff --git a/wasp/lib/runtime/func.ml b/src/interpreter/runtime/func.ml similarity index 100% rename from wasp/lib/runtime/func.ml rename to src/interpreter/runtime/func.ml diff --git a/wasp/lib/runtime/func.mli b/src/interpreter/runtime/func.mli similarity index 100% rename from wasp/lib/runtime/func.mli rename to src/interpreter/runtime/func.mli diff --git a/wasp/lib/runtime/global.ml b/src/interpreter/runtime/global.ml similarity index 100% rename from wasp/lib/runtime/global.ml rename to src/interpreter/runtime/global.ml diff --git a/wasp/lib/runtime/global.mli b/src/interpreter/runtime/global.mli similarity index 100% rename from wasp/lib/runtime/global.mli rename to src/interpreter/runtime/global.mli diff --git a/wasp/lib/runtime/instance.ml b/src/interpreter/runtime/instance.ml similarity index 100% rename from wasp/lib/runtime/instance.ml rename to src/interpreter/runtime/instance.ml diff --git a/wasp/lib/runtime/memory.ml b/src/interpreter/runtime/memory.ml similarity index 100% rename from wasp/lib/runtime/memory.ml rename to src/interpreter/runtime/memory.ml diff --git a/wasp/lib/runtime/memory.mli b/src/interpreter/runtime/memory.mli similarity index 100% rename from wasp/lib/runtime/memory.mli rename to src/interpreter/runtime/memory.mli diff --git a/wasp/lib/runtime/table.ml b/src/interpreter/runtime/table.ml similarity index 100% rename from wasp/lib/runtime/table.ml rename to src/interpreter/runtime/table.ml diff --git a/wasp/lib/runtime/table.mli b/src/interpreter/runtime/table.mli similarity index 100% rename from wasp/lib/runtime/table.mli rename to src/interpreter/runtime/table.mli diff --git a/wasp/lib/script/import.ml b/src/interpreter/script/import.ml similarity index 92% rename from wasp/lib/script/import.ml rename to src/interpreter/script/import.ml index 65fa2abb..6b8b4f74 100644 --- a/wasp/lib/script/import.ml +++ b/src/interpreter/script/import.ml @@ -14,7 +14,7 @@ let registry = ref Registry.empty let register name lookup = registry := Registry.add name lookup !registry let lookup (m : module_) (im : import) : Instance.extern = - let { module_name; item_name; idesc } = im.it in + let { module_name; item_name; _ } = im.it in let t = import_type m im in try Registry.find module_name !registry item_name t with Not_found -> diff --git a/wasp/lib/script/import.mli b/src/interpreter/script/import.mli similarity index 100% rename from wasp/lib/script/import.mli rename to src/interpreter/script/import.mli diff --git a/wasp/lib/script/js.ml b/src/interpreter/script/js.ml similarity index 99% rename from wasp/lib/script/js.ml rename to src/interpreter/script/js.ml index 268b0bf9..db4524f7 100644 --- a/wasp/lib/script/js.ml +++ b/src/interpreter/script/js.ml @@ -219,9 +219,9 @@ let invoke ft lits at = List.map (fun lit -> Const lit @@ at) lits @ [ Call (0l @@ at) @@ at ] ) let get t at = ([], GlobalImport t @@ at, [ GlobalGet (0l @@ at) @@ at ]) -let run ts at = ([], []) +let run _ _ = ([], []) -let assert_return ress ts at = +let assert_return ress _ at = let test res = match res.it with | LitResult lit -> diff --git a/wasp/lib/script/js.mli b/src/interpreter/script/js.mli similarity index 100% rename from wasp/lib/script/js.mli rename to src/interpreter/script/js.mli diff --git a/wasp/lib/script/run.ml b/src/interpreter/script/run.ml similarity index 99% rename from wasp/lib/script/run.ml rename to src/interpreter/script/run.ml index d0649aa8..44d635c1 100644 --- a/wasp/lib/script/run.ml +++ b/src/interpreter/script/run.ml @@ -157,7 +157,7 @@ let input_binary_file file run = close_in ic; raise exn -let input_js_file file run = +let input_js_file file _ = raise (Sys_error (file ^ ": unrecognized input file type")) let input_file file run = diff --git a/wasp/lib/script/run.mli b/src/interpreter/script/run.mli similarity index 100% rename from wasp/lib/script/run.mli rename to src/interpreter/script/run.mli diff --git a/wasp/lib/script/script.ml b/src/interpreter/script/script.ml similarity index 100% rename from wasp/lib/script/script.ml rename to src/interpreter/script/script.ml diff --git a/wasp/lib/syntax/ast.ml b/src/interpreter/syntax/ast.ml similarity index 100% rename from wasp/lib/syntax/ast.ml rename to src/interpreter/syntax/ast.ml diff --git a/wasp/lib/syntax/operators.ml b/src/interpreter/syntax/operators.ml similarity index 100% rename from wasp/lib/syntax/operators.ml rename to src/interpreter/syntax/operators.ml diff --git a/wasp/lib/syntax/types.ml b/src/interpreter/syntax/types.ml similarity index 100% rename from wasp/lib/syntax/types.ml rename to src/interpreter/syntax/types.ml diff --git a/wasp/lib/syntax/values.ml b/src/interpreter/syntax/values.ml similarity index 100% rename from wasp/lib/syntax/values.ml rename to src/interpreter/syntax/values.ml diff --git a/wasp/lib/text/arrange.ml b/src/interpreter/text/arrange.ml similarity index 79% rename from wasp/lib/text/arrange.ml rename to src/interpreter/text/arrange.ml index a7d103c3..dadd338b 100644 --- a/wasp/lib/text/arrange.ml +++ b/src/interpreter/text/arrange.ml @@ -8,7 +8,9 @@ open Sexpr (* Generic formatting *) let nat n = I32.to_string_u (I32.of_int_u n) + let nat32 = I32.to_string_u + let add_hex_char buf c = Printf.bprintf buf "\\%02x" (Char.code c) let add_char buf = function @@ -32,13 +34,21 @@ let string_with iter add_char s = Buffer.contents buf let bytes = string_with String.iter add_hex_char + let string = string_with String.iter add_char + let name = string_with List.iter add_unicode_char + let list_of_opt = function None -> [] | Some x -> [ x ] + let list f xs = List.map f xs + let listi f xs = List.mapi f xs + let opt f xo = list f (list_of_opt xo) + let tab head f xs = if xs = [] then [] else [ Node (head, list f xs) ] + let atom f x = Atom (f x) let break_bytes s = @@ -52,14 +62,18 @@ let break_string s = (* Types *) let value_type t = string_of_value_type t + let elem_type t = string_of_elem_type t + let decls kind ts = tab kind (atom value_type) ts + let stack_type ts = decls "result" ts let func_type (FuncType (ins, out)) = Node ("func", decls "param" ins @ decls "result" out) let struct_type = func_type + let limits nat { min; max } = String.concat " " (nat min :: opt nat max) let global_type = function @@ -71,9 +85,9 @@ let global_type = function module IntOp = struct open Ast.IntOp - let testop xx = function Eqz -> "eqz" + let testop _ = function Eqz -> "eqz" - let relop xx = function + let relop _ = function | Eq -> "eq" | Ne -> "ne" | LtS -> "lt_s" @@ -85,9 +99,9 @@ module IntOp = struct | GeS -> "ge_s" | GeU -> "ge_u" - let unop xx = function Clz -> "clz" | Ctz -> "ctz" | Popcnt -> "popcnt" + let unop _ = function Clz -> "clz" | Ctz -> "ctz" | Popcnt -> "popcnt" - let binop xx = function + let binop _ = function | Add -> "add" | Sub -> "sub" | Mul -> "mul" @@ -118,9 +132,9 @@ end module FloatOp = struct open Ast.FloatOp - let testop xx _ = assert false + let testop _ _ = assert false - let relop xx = function + let relop _ = function | Eq -> "eq" | Ne -> "ne" | Lt -> "lt" @@ -128,7 +142,7 @@ module FloatOp = struct | Le -> "le" | Ge -> "ge" - let unop xx = function + let unop _ = function | Neg -> "neg" | Abs -> "abs" | Ceil -> "ceil" @@ -137,7 +151,7 @@ module FloatOp = struct | Nearest -> "nearest" | Sqrt -> "sqrt" - let binop xx = function + let binop _ = function | Add -> "add" | Sub -> "sub" | Mul -> "mul" @@ -167,9 +181,13 @@ let oper (intop, floatop) op = | F64 o -> floatop "64" o let unop = oper (IntOp.unop, FloatOp.unop) + let binop = oper (IntOp.binop, FloatOp.binop) + let testop = oper (IntOp.testop, FloatOp.testop) + let relop = oper (IntOp.relop, FloatOp.relop) + let cvtop = oper (IntOp.cvtop, FloatOp.cvtop) let pack_size = function @@ -188,7 +206,7 @@ let loadop op = match op.sz with | None -> memop "load" op (size op.ty) | Some (sz, ext) -> - memop ("load" ^ pack_size sz ^ extension ext) op (Memory.packed_size sz) + memop ("load" ^ pack_size sz ^ extension ext) op (Memory.packed_size sz) let storeop op = match op.sz with @@ -198,7 +216,9 @@ let storeop op = (* Expressions *) let var x = nat32 x.it + let value v = string_of_value v.it + let constop v = value_type (type_of v.it) ^ ".const" let rec instr e = @@ -211,13 +231,13 @@ let rec instr e = | Block (ts, es) -> ("block", stack_type ts @ list instr es) | Loop (ts, es) -> ("loop", stack_type ts @ list instr es) | If (ts, es1, es2) -> - ( "if", - stack_type ts - @ [ Node ("then", list instr es1); Node ("else", list instr es2) ] ) + ( "if" + , stack_type ts + @ [ Node ("then", list instr es1); Node ("else", list instr es2) ] ) | Br x -> ("br " ^ var x, []) | BrIf x -> ("br_if " ^ var x, []) | BrTable (xs, x) -> - ("br_table " ^ String.concat " " (list var (xs @ [ x ])), []) + ("br_table " ^ String.concat " " (list var (xs @ [ x ])), []) | Return -> ("return", []) | Call x -> ("call " ^ var x, []) | CallIndirect x -> ("call_indirect", [ Node ("type " ^ var x, []) ]) @@ -247,12 +267,14 @@ let const c = list instr c.it let func_with_name name f = let { ftype; locals; body } = f.it in Node - ( "func" ^ name, - [ Node ("type " ^ var ftype, []) ] + ( "func" ^ name + , [ Node ("type " ^ var ftype, []) ] @ decls "local" locals @ list instr body ) let func_with_index off i f = func_with_name (" $" ^ nat (off + i)) f + let func f = func_with_name "" f + let start x = Node ("start " ^ var x, []) (* Tables & memories *) @@ -270,6 +292,7 @@ let segment head dat seg = Node (head, atom var index :: Node ("offset", const offset) :: dat init) let elems seg = segment "elem" (list (atom var)) seg + let data seg = segment "data" break_bytes seg (* Modules *) @@ -279,26 +302,25 @@ let typedef i ty = Node ("type $" ^ nat i, [ struct_type ty.it ]) let import_desc fx tx mx gx d = match d.it with | FuncImport x -> - incr fx; - Node ("func $" ^ nat (!fx - 1), [ Node ("type", [ atom var x ]) ]) + incr fx; + Node ("func $" ^ nat (!fx - 1), [ Node ("type", [ atom var x ]) ]) | TableImport t -> - incr tx; - table 0 (!tx - 1) ({ ttype = t } @@ d.at) + incr tx; + table 0 (!tx - 1) ({ ttype = t } @@ d.at) | MemoryImport t -> - incr mx; - memory 0 (!mx - 1) ({ mtype = t } @@ d.at) + incr mx; + memory 0 (!mx - 1) ({ mtype = t } @@ d.at) | GlobalImport t -> - incr gx; - Node ("global $" ^ nat (!gx - 1), [ global_type t ]) + incr gx; + Node ("global $" ^ nat (!gx - 1), [ global_type t ]) let import fx tx mx gx im = let { module_name; item_name; idesc } = im.it in Node - ( "import", - [ - atom name module_name; - atom name item_name; - import_desc fx tx mx gx idesc; + ( "import" + , [ atom name module_name + ; atom name item_name + ; import_desc fx tx mx gx idesc ] ) let export_desc d = @@ -327,8 +349,8 @@ let module_with_var_opt x_opt m = let gx = ref 0 in let imports = list (import fx tx mx gx) m.it.imports in Node - ( "module" ^ var_opt x_opt, - listi typedef m.it.types @ imports + ( "module" ^ var_opt x_opt + , listi typedef m.it.types @ imports @ listi (table !tx) m.it.tables @ listi (memory !mx) m.it.memories @ listi (global !gx) m.it.globals @@ -357,26 +379,26 @@ let definition mode x_opt def = try match mode with | `Textual -> - let rec unquote def = - match def.it with - | Textual m -> m - | Encoded (_, bs) -> Decode.decode "" bs - | Quoted (_, s) -> unquote (Parse.string_to_module s) - in - module_with_var_opt x_opt (unquote def) + let rec unquote def = + match def.it with + | Textual m -> m + | Encoded (_, bs) -> Decode.decode "" bs + | Quoted (_, s) -> unquote (Parse.string_to_module s) + in + module_with_var_opt x_opt (unquote def) | `Binary -> - let rec unquote def = - match def.it with - | Textual m -> Encode.encode m - | Encoded (_, bs) -> Encode.encode (Decode.decode "" bs) - | Quoted (_, s) -> unquote (Parse.string_to_module s) - in - binary_module_with_var_opt x_opt (unquote def) - | `Original -> ( + let rec unquote def = match def.it with - | Textual m -> module_with_var_opt x_opt m - | Encoded (_, bs) -> binary_module_with_var_opt x_opt bs - | Quoted (_, s) -> quoted_module_with_var_opt x_opt s) + | Textual m -> Encode.encode m + | Encoded (_, bs) -> Encode.encode (Decode.decode "" bs) + | Quoted (_, s) -> unquote (Parse.string_to_module s) + in + binary_module_with_var_opt x_opt (unquote def) + | `Original -> ( + match def.it with + | Textual m -> module_with_var_opt x_opt m + | Encoded (_, bs) -> binary_module_with_var_opt x_opt bs + | Quoted (_, s) -> quoted_module_with_var_opt x_opt s ) with Parse.Syntax _ -> quoted_module_with_var_opt x_opt "" let access x_opt n = String.concat " " [ var_opt x_opt; name n ] @@ -384,7 +406,7 @@ let access x_opt n = String.concat " " [ var_opt x_opt; name n ] let action act = match act.it with | Invoke (x_opt, name, lits) -> - Node ("invoke" ^ access x_opt name, List.map literal lits) + Node ("invoke" ^ access x_opt name, List.map literal lits) | Get (x_opt, name) -> Node ("get" ^ access x_opt name, []) let nan = function @@ -395,28 +417,28 @@ let result res = match res.it with | LitResult lit -> literal lit | NanResult nanop -> ( - match nanop.it with - | Values.I32 _ | Values.I64 _ -> assert false - | Values.F32 n -> Node ("f32.const " ^ nan n, []) - | Values.F64 n -> Node ("f64.const " ^ nan n, [])) + match nanop.it with + | Values.I32 _ | Values.I64 _ -> assert false + | Values.F32 n -> Node ("f32.const " ^ nan n, []) + | Values.F64 n -> Node ("f64.const " ^ nan n, []) ) let assertion mode ass = match ass.it with | AssertMalformed (def, re) -> - Node - ("assert_malformed", [ definition `Original None def; Atom (string re) ]) + Node + ("assert_malformed", [ definition `Original None def; Atom (string re) ]) | AssertInvalid (def, re) -> - Node ("assert_invalid", [ definition mode None def; Atom (string re) ]) + Node ("assert_invalid", [ definition mode None def; Atom (string re) ]) | AssertUnlinkable (def, re) -> - Node ("assert_unlinkable", [ definition mode None def; Atom (string re) ]) + Node ("assert_unlinkable", [ definition mode None def; Atom (string re) ]) | AssertUninstantiable (def, re) -> - Node ("assert_trap", [ definition mode None def; Atom (string re) ]) + Node ("assert_trap", [ definition mode None def; Atom (string re) ]) | AssertReturn (act, results) -> - Node ("assert_return", action act :: List.map result results) + Node ("assert_return", action act :: List.map result results) | AssertTrap (act, re) -> - Node ("assert_trap", [ action act; Atom (string re) ]) + Node ("assert_trap", [ action act; Atom (string re) ]) | AssertExhaustion (act, re) -> - Node ("assert_exhaustion", [ action act; Atom (string re) ]) + Node ("assert_exhaustion", [ action act; Atom (string re) ]) let command mode cmd = match cmd.it with diff --git a/wasp/lib/text/arrange.mli b/src/interpreter/text/arrange.mli similarity index 100% rename from wasp/lib/text/arrange.mli rename to src/interpreter/text/arrange.mli diff --git a/wasp/lib/text/lexer.mli b/src/interpreter/text/lexer.mli similarity index 100% rename from wasp/lib/text/lexer.mli rename to src/interpreter/text/lexer.mli diff --git a/wasp/lib/text/lexer.mll b/src/interpreter/text/lexer.mll similarity index 100% rename from wasp/lib/text/lexer.mll rename to src/interpreter/text/lexer.mll diff --git a/wasp/lib/text/parse.ml b/src/interpreter/text/parse.ml similarity index 100% rename from wasp/lib/text/parse.ml rename to src/interpreter/text/parse.ml diff --git a/wasp/lib/text/parse.mli b/src/interpreter/text/parse.mli similarity index 100% rename from wasp/lib/text/parse.mli rename to src/interpreter/text/parse.mli diff --git a/wasp/lib/text/parser.mly b/src/interpreter/text/parser.mly similarity index 99% rename from wasp/lib/text/parser.mly rename to src/interpreter/text/parser.mly index 73a098c8..a84e008d 100644 --- a/wasp/lib/text/parser.mly +++ b/src/interpreter/text/parser.mly @@ -5,6 +5,7 @@ open Ast open Operators open Script +[@@@ocaml.warning "-27"] (* Error handling *) diff --git a/wasp/lib/text/print.ml b/src/interpreter/text/print.ml similarity index 100% rename from wasp/lib/text/print.ml rename to src/interpreter/text/print.ml diff --git a/wasp/lib/text/print.mli b/src/interpreter/text/print.mli similarity index 100% rename from wasp/lib/text/print.mli rename to src/interpreter/text/print.mli diff --git a/wasp/lib/util/error.ml b/src/interpreter/util/error.ml similarity index 100% rename from wasp/lib/util/error.ml rename to src/interpreter/util/error.ml diff --git a/wasp/lib/util/error.mli b/src/interpreter/util/error.mli similarity index 100% rename from wasp/lib/util/error.mli rename to src/interpreter/util/error.mli diff --git a/wasp/lib/util/io.ml b/src/interpreter/util/io.ml similarity index 100% rename from wasp/lib/util/io.ml rename to src/interpreter/util/io.ml diff --git a/wasp/lib/util/lib.ml b/src/interpreter/util/lib.ml similarity index 98% rename from wasp/lib/util/lib.ml rename to src/interpreter/util/lib.ml index a3925bde..398542a2 100644 --- a/wasp/lib/util/lib.ml +++ b/src/interpreter/util/lib.ml @@ -92,8 +92,8 @@ module List = struct and index_where' p xs i = match xs with | [] -> None - | x :: xs' when p x -> Some i - | x :: xs' -> index_where' p xs' (i + 1) + | x :: _ when p x -> Some i + | _ :: xs' -> index_where' p xs' (i + 1) let index_of x = index_where (( = ) x) diff --git a/wasp/lib/util/lib.mli b/src/interpreter/util/lib.mli similarity index 100% rename from wasp/lib/util/lib.mli rename to src/interpreter/util/lib.mli diff --git a/wasp/lib/util/sexpr.ml b/src/interpreter/util/sexpr.ml similarity index 100% rename from wasp/lib/util/sexpr.ml rename to src/interpreter/util/sexpr.ml diff --git a/wasp/lib/util/sexpr.mli b/src/interpreter/util/sexpr.mli similarity index 100% rename from wasp/lib/util/sexpr.mli rename to src/interpreter/util/sexpr.mli diff --git a/wasp/lib/util/source.ml b/src/interpreter/util/source.ml similarity index 100% rename from wasp/lib/util/source.ml rename to src/interpreter/util/source.ml diff --git a/wasp/lib/util/source.mli b/src/interpreter/util/source.mli similarity index 100% rename from wasp/lib/util/source.mli rename to src/interpreter/util/source.mli diff --git a/wasp/lib/valid/valid.ml b/src/interpreter/valid/valid.ml similarity index 96% rename from wasp/lib/valid/valid.ml rename to src/interpreter/valid/valid.ml index 3547881d..a7a3feff 100644 --- a/wasp/lib/valid/valid.ml +++ b/src/interpreter/valid/valid.ml @@ -102,7 +102,7 @@ let push (ell1, ts1) (ell2, ts2) = ( (if ell1 = Ellipses || ell2 = Ellipses then Ellipses else NoEllipses), ts2 @ ts1 ) -let peek i (ell, ts) = try List.nth (List.rev ts) i with Failure _ -> None +let peek i (_ , ts) = try List.nth (List.rev ts) i with Failure _ -> None (* Type Synthesis *) @@ -225,7 +225,7 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type = | LocalSet x -> [ local c x ] --> [] | LocalTee x -> [ local c x ] --> [ local c x ] | GlobalGet x -> - let (GlobalType (t, mut)) = global c x in + let (GlobalType (t, _)) = global c x in [] --> [ t ] | GlobalSet x -> let (GlobalType (t, mut)) = global c x in @@ -261,8 +261,8 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type = | Convert cvtop -> let t1, t2 = type_cvtop e.at cvtop in [ t1 ] --> [ t2 ] - | Symbolic (t, b) -> [ I32Type ] --> [ t ] - | Boolop boolop -> [ I32Type; I32Type ] --> [ I32Type ] + | Symbolic (t, _) -> [ I32Type ] --> [ t ] + | Boolop _ -> [ I32Type; I32Type ] --> [ I32Type ] | Alloc -> [ I32Type; I32Type ] --> [ I32Type ] | Free -> [ I32Type ] --> [] | SymInt32 _ -> [] --> [ I32Type ] @@ -317,7 +317,7 @@ let check_limits { min; max } range at msg = require (I32.le_u min max) at "size minimum must not be greater than maximum" -let check_value_type (t : value_type) at = () +let check_value_type (_ : value_type) _ = () let check_func_type (ft : func_type) at = let (FuncType (ins, out)) = ft in @@ -334,7 +334,7 @@ let check_memory_type (mt : memory_type) at = check_limits lim 0x1_0000L at "memory size must be at most 65536 pages (4GiB)" let check_global_type (gt : global_type) at = - let (GlobalType (t, mut)) = gt in + let (GlobalType (t, _)) = gt in check_value_type t at (* Functions & Constants *) @@ -375,11 +375,11 @@ let check_const (c : context) (const : const) (t : value_type) = (* Tables, Memories, & Globals *) -let check_table (c : context) (tab : table) = +let check_table (_ : context) (tab : table) = let { ttype } = tab.it in check_table_type ttype tab.at -let check_memory (c : context) (mem : memory) = +let check_memory (_ : context) (mem : memory) = let { mtype } = mem.it in check_memory_type mtype mem.at @@ -390,13 +390,13 @@ let check_elem (c : context) (seg : table_segment) = ignore (List.map (func c) init) let check_data (c : context) (seg : memory_segment) = - let { index; offset; init } = seg.it in + let { index; offset; _ } = seg.it in check_const c offset I32Type; ignore (memory c index) let check_global (c : context) (glob : global) = let { gtype; value } = glob.it in - let (GlobalType (t, mut)) = gtype in + let (GlobalType (t, _)) = gtype in check_const c value t (* Modules *) diff --git a/wasp/lib/valid/valid.mli b/src/interpreter/valid/valid.mli similarity index 100% rename from wasp/lib/valid/valid.mli rename to src/interpreter/valid/valid.mli diff --git a/wasp/lib/symbolic/run.ml b/src/run.ml similarity index 100% rename from wasp/lib/symbolic/run.ml rename to src/run.ml diff --git a/wasp/lib/symbolic/run.mli b/src/run.mli similarity index 100% rename from wasp/lib/symbolic/run.mli rename to src/run.mli diff --git a/src/static/dune b/src/static/dune new file mode 100644 index 00000000..31c9b7cf --- /dev/null +++ b/src/static/dune @@ -0,0 +1,3 @@ +(library + (name static) + (libraries interpreter common smtml concolic)) diff --git a/wasp/lib/symbolic/static/eval.ml b/src/static/eval.ml similarity index 100% rename from wasp/lib/symbolic/static/eval.ml rename to src/static/eval.ml diff --git a/wasp/lib/symbolic/static/evaluations.ml b/src/static/evaluations.ml similarity index 100% rename from wasp/lib/symbolic/static/evaluations.ml rename to src/static/evaluations.ml diff --git a/wasp/lib/symbolic/static/memory.ml b/src/static/memory.ml similarity index 100% rename from wasp/lib/symbolic/static/memory.ml rename to src/static/memory.ml diff --git a/wasp/lib/symbolic/static/memory.mli b/src/static/memory.mli similarity index 100% rename from wasp/lib/symbolic/static/memory.mli rename to src/static/memory.mli diff --git a/wasp/lib/symbolic/static/strategies.ml b/src/static/strategies.ml similarity index 100% rename from wasp/lib/symbolic/static/strategies.ml rename to src/static/strategies.ml diff --git a/wasp/lib/symbolic/static/varmap.ml b/src/static/varmap.ml similarity index 100% rename from wasp/lib/symbolic/static/varmap.ml rename to src/static/varmap.ml diff --git a/wasp/tests/btree-manticore/2o1u.wasm b/tests/btree-manticore/2o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/2o1u.wasm rename to tests/btree-manticore/2o1u.wasm diff --git a/wasp/tests/btree-manticore/2o1u.wast b/tests/btree-manticore/2o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/2o1u.wast rename to tests/btree-manticore/2o1u.wast diff --git a/wasp/tests/btree-manticore/2o2u.wasm b/tests/btree-manticore/2o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/2o2u.wasm rename to tests/btree-manticore/2o2u.wasm diff --git a/wasp/tests/btree-manticore/2o2u.wast b/tests/btree-manticore/2o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/2o2u.wast rename to tests/btree-manticore/2o2u.wast diff --git a/wasp/tests/btree-manticore/2o3u.wasm b/tests/btree-manticore/2o3u.wasm similarity index 100% rename from wasp/tests/btree-manticore/2o3u.wasm rename to tests/btree-manticore/2o3u.wasm diff --git a/wasp/tests/btree-manticore/2o3u.wast b/tests/btree-manticore/2o3u.wast similarity index 100% rename from wasp/tests/btree-manticore/2o3u.wast rename to tests/btree-manticore/2o3u.wast diff --git a/wasp/tests/btree-manticore/3o1u.wasm b/tests/btree-manticore/3o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/3o1u.wasm rename to tests/btree-manticore/3o1u.wasm diff --git a/wasp/tests/btree-manticore/3o1u.wast b/tests/btree-manticore/3o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/3o1u.wast rename to tests/btree-manticore/3o1u.wast diff --git a/wasp/tests/btree-manticore/3o2u.wasm b/tests/btree-manticore/3o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/3o2u.wasm rename to tests/btree-manticore/3o2u.wasm diff --git a/wasp/tests/btree-manticore/3o2u.wast b/tests/btree-manticore/3o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/3o2u.wast rename to tests/btree-manticore/3o2u.wast diff --git a/wasp/tests/btree-manticore/3o3u.wasm b/tests/btree-manticore/3o3u.wasm similarity index 100% rename from wasp/tests/btree-manticore/3o3u.wasm rename to tests/btree-manticore/3o3u.wasm diff --git a/wasp/tests/btree-manticore/3o3u.wast b/tests/btree-manticore/3o3u.wast similarity index 100% rename from wasp/tests/btree-manticore/3o3u.wast rename to tests/btree-manticore/3o3u.wast diff --git a/wasp/tests/btree-manticore/4o1u.wasm b/tests/btree-manticore/4o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/4o1u.wasm rename to tests/btree-manticore/4o1u.wasm diff --git a/wasp/tests/btree-manticore/4o1u.wast b/tests/btree-manticore/4o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/4o1u.wast rename to tests/btree-manticore/4o1u.wast diff --git a/wasp/tests/btree-manticore/4o2u.wasm b/tests/btree-manticore/4o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/4o2u.wasm rename to tests/btree-manticore/4o2u.wasm diff --git a/wasp/tests/btree-manticore/4o2u.wast b/tests/btree-manticore/4o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/4o2u.wast rename to tests/btree-manticore/4o2u.wast diff --git a/wasp/tests/btree-manticore/4o3u.wasm b/tests/btree-manticore/4o3u.wasm similarity index 100% rename from wasp/tests/btree-manticore/4o3u.wasm rename to tests/btree-manticore/4o3u.wasm diff --git a/wasp/tests/btree-manticore/4o3u.wast b/tests/btree-manticore/4o3u.wast similarity index 100% rename from wasp/tests/btree-manticore/4o3u.wast rename to tests/btree-manticore/4o3u.wast diff --git a/wasp/tests/btree-manticore/5o1u.wasm b/tests/btree-manticore/5o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/5o1u.wasm rename to tests/btree-manticore/5o1u.wasm diff --git a/wasp/tests/btree-manticore/5o1u.wast b/tests/btree-manticore/5o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/5o1u.wast rename to tests/btree-manticore/5o1u.wast diff --git a/wasp/tests/btree-manticore/5o2u.wasm b/tests/btree-manticore/5o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/5o2u.wasm rename to tests/btree-manticore/5o2u.wasm diff --git a/wasp/tests/btree-manticore/5o2u.wast b/tests/btree-manticore/5o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/5o2u.wast rename to tests/btree-manticore/5o2u.wast diff --git a/wasp/tests/btree-manticore/5o3u.wasm b/tests/btree-manticore/5o3u.wasm similarity index 100% rename from wasp/tests/btree-manticore/5o3u.wasm rename to tests/btree-manticore/5o3u.wasm diff --git a/wasp/tests/btree-manticore/5o3u.wast b/tests/btree-manticore/5o3u.wast similarity index 100% rename from wasp/tests/btree-manticore/5o3u.wast rename to tests/btree-manticore/5o3u.wast diff --git a/wasp/tests/btree-manticore/6o1u.wasm b/tests/btree-manticore/6o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/6o1u.wasm rename to tests/btree-manticore/6o1u.wasm diff --git a/wasp/tests/btree-manticore/6o1u.wast b/tests/btree-manticore/6o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/6o1u.wast rename to tests/btree-manticore/6o1u.wast diff --git a/wasp/tests/btree-manticore/6o2u.wasm b/tests/btree-manticore/6o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/6o2u.wasm rename to tests/btree-manticore/6o2u.wasm diff --git a/wasp/tests/btree-manticore/6o2u.wast b/tests/btree-manticore/6o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/6o2u.wast rename to tests/btree-manticore/6o2u.wast diff --git a/wasp/tests/btree-manticore/6o3u.wasm b/tests/btree-manticore/6o3u.wasm similarity index 100% rename from wasp/tests/btree-manticore/6o3u.wasm rename to tests/btree-manticore/6o3u.wasm diff --git a/wasp/tests/btree-manticore/6o3u.wast b/tests/btree-manticore/6o3u.wast similarity index 100% rename from wasp/tests/btree-manticore/6o3u.wast rename to tests/btree-manticore/6o3u.wast diff --git a/wasp/tests/btree-manticore/7o1u.wasm b/tests/btree-manticore/7o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/7o1u.wasm rename to tests/btree-manticore/7o1u.wasm diff --git a/wasp/tests/btree-manticore/7o1u.wast b/tests/btree-manticore/7o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/7o1u.wast rename to tests/btree-manticore/7o1u.wast diff --git a/wasp/tests/btree-manticore/7o2u.wasm b/tests/btree-manticore/7o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/7o2u.wasm rename to tests/btree-manticore/7o2u.wasm diff --git a/wasp/tests/btree-manticore/7o2u.wast b/tests/btree-manticore/7o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/7o2u.wast rename to tests/btree-manticore/7o2u.wast diff --git a/wasp/tests/btree-manticore/7o3u.wasm b/tests/btree-manticore/7o3u.wasm similarity index 100% rename from wasp/tests/btree-manticore/7o3u.wasm rename to tests/btree-manticore/7o3u.wasm diff --git a/wasp/tests/btree-manticore/7o3u.wast b/tests/btree-manticore/7o3u.wast similarity index 100% rename from wasp/tests/btree-manticore/7o3u.wast rename to tests/btree-manticore/7o3u.wast diff --git a/wasp/tests/btree-manticore/8o1u.wasm b/tests/btree-manticore/8o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/8o1u.wasm rename to tests/btree-manticore/8o1u.wasm diff --git a/wasp/tests/btree-manticore/8o1u.wast b/tests/btree-manticore/8o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/8o1u.wast rename to tests/btree-manticore/8o1u.wast diff --git a/wasp/tests/btree-manticore/8o2u.wasm b/tests/btree-manticore/8o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/8o2u.wasm rename to tests/btree-manticore/8o2u.wasm diff --git a/wasp/tests/btree-manticore/8o2u.wast b/tests/btree-manticore/8o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/8o2u.wast rename to tests/btree-manticore/8o2u.wast diff --git a/wasp/tests/btree-manticore/9o1u.wasm b/tests/btree-manticore/9o1u.wasm similarity index 100% rename from wasp/tests/btree-manticore/9o1u.wasm rename to tests/btree-manticore/9o1u.wasm diff --git a/wasp/tests/btree-manticore/9o1u.wast b/tests/btree-manticore/9o1u.wast similarity index 100% rename from wasp/tests/btree-manticore/9o1u.wast rename to tests/btree-manticore/9o1u.wast diff --git a/wasp/tests/btree-manticore/9o2u.wasm b/tests/btree-manticore/9o2u.wasm similarity index 100% rename from wasp/tests/btree-manticore/9o2u.wasm rename to tests/btree-manticore/9o2u.wasm diff --git a/wasp/tests/btree-manticore/9o2u.wast b/tests/btree-manticore/9o2u.wast similarity index 100% rename from wasp/tests/btree-manticore/9o2u.wast rename to tests/btree-manticore/9o2u.wast diff --git a/wasp/tests/btree/2o1u.wast b/tests/btree/2o1u.wast similarity index 100% rename from wasp/tests/btree/2o1u.wast rename to tests/btree/2o1u.wast diff --git a/wasp/tests/btree/2o2u.wast b/tests/btree/2o2u.wast similarity index 100% rename from wasp/tests/btree/2o2u.wast rename to tests/btree/2o2u.wast diff --git a/wasp/tests/btree/2o3u.wast b/tests/btree/2o3u.wast similarity index 100% rename from wasp/tests/btree/2o3u.wast rename to tests/btree/2o3u.wast diff --git a/wasp/tests/btree/3o1u.wast b/tests/btree/3o1u.wast similarity index 100% rename from wasp/tests/btree/3o1u.wast rename to tests/btree/3o1u.wast diff --git a/wasp/tests/btree/3o2u.wast b/tests/btree/3o2u.wast similarity index 100% rename from wasp/tests/btree/3o2u.wast rename to tests/btree/3o2u.wast diff --git a/wasp/tests/btree/3o3u.wast b/tests/btree/3o3u.wast similarity index 100% rename from wasp/tests/btree/3o3u.wast rename to tests/btree/3o3u.wast diff --git a/wasp/tests/btree/4o1u.wast b/tests/btree/4o1u.wast similarity index 100% rename from wasp/tests/btree/4o1u.wast rename to tests/btree/4o1u.wast diff --git a/wasp/tests/btree/4o2u.wast b/tests/btree/4o2u.wast similarity index 100% rename from wasp/tests/btree/4o2u.wast rename to tests/btree/4o2u.wast diff --git a/wasp/tests/btree/4o3u.wast b/tests/btree/4o3u.wast similarity index 100% rename from wasp/tests/btree/4o3u.wast rename to tests/btree/4o3u.wast diff --git a/wasp/tests/btree/5o1u.wast b/tests/btree/5o1u.wast similarity index 100% rename from wasp/tests/btree/5o1u.wast rename to tests/btree/5o1u.wast diff --git a/wasp/tests/btree/5o2u.wast b/tests/btree/5o2u.wast similarity index 100% rename from wasp/tests/btree/5o2u.wast rename to tests/btree/5o2u.wast diff --git a/wasp/tests/btree/5o3u.wast b/tests/btree/5o3u.wast similarity index 100% rename from wasp/tests/btree/5o3u.wast rename to tests/btree/5o3u.wast diff --git a/wasp/tests/btree/6o1u.wast b/tests/btree/6o1u.wast similarity index 100% rename from wasp/tests/btree/6o1u.wast rename to tests/btree/6o1u.wast diff --git a/wasp/tests/btree/6o2u.wast b/tests/btree/6o2u.wast similarity index 100% rename from wasp/tests/btree/6o2u.wast rename to tests/btree/6o2u.wast diff --git a/wasp/tests/btree/6o3u.wast b/tests/btree/6o3u.wast similarity index 100% rename from wasp/tests/btree/6o3u.wast rename to tests/btree/6o3u.wast diff --git a/wasp/tests/btree/7o1u.wast b/tests/btree/7o1u.wast similarity index 100% rename from wasp/tests/btree/7o1u.wast rename to tests/btree/7o1u.wast diff --git a/wasp/tests/btree/7o2u.wast b/tests/btree/7o2u.wast similarity index 100% rename from wasp/tests/btree/7o2u.wast rename to tests/btree/7o2u.wast diff --git a/wasp/tests/btree/7o3u.wast b/tests/btree/7o3u.wast similarity index 100% rename from wasp/tests/btree/7o3u.wast rename to tests/btree/7o3u.wast diff --git a/wasp/tests/btree/8o1u.wast b/tests/btree/8o1u.wast similarity index 100% rename from wasp/tests/btree/8o1u.wast rename to tests/btree/8o1u.wast diff --git a/wasp/tests/btree/8o2u.wast b/tests/btree/8o2u.wast similarity index 100% rename from wasp/tests/btree/8o2u.wast rename to tests/btree/8o2u.wast diff --git a/wasp/tests/btree/9o1u.wast b/tests/btree/9o1u.wast similarity index 100% rename from wasp/tests/btree/9o1u.wast rename to tests/btree/9o1u.wast diff --git a/wasp/tests/btree/9o2u.wast b/tests/btree/9o2u.wast similarity index 100% rename from wasp/tests/btree/9o2u.wast rename to tests/btree/9o2u.wast diff --git a/wasp/tests/btree/BTree.wast b/tests/btree/BTree.wast similarity index 100% rename from wasp/tests/btree/BTree.wast rename to tests/btree/BTree.wast diff --git a/wasp/tests/failing/test1.1.wast b/tests/failing/test1.1.wast similarity index 100% rename from wasp/tests/failing/test1.1.wast rename to tests/failing/test1.1.wast diff --git a/wasp/tests/failing/test1.wast b/tests/failing/test1.wast similarity index 100% rename from wasp/tests/failing/test1.wast rename to tests/failing/test1.wast diff --git a/wasp/tests/failing/test10.wast b/tests/failing/test10.wast similarity index 100% rename from wasp/tests/failing/test10.wast rename to tests/failing/test10.wast diff --git a/wasp/tests/failing/test11.wast b/tests/failing/test11.wast similarity index 100% rename from wasp/tests/failing/test11.wast rename to tests/failing/test11.wast diff --git a/wasp/tests/failing/test12.wast b/tests/failing/test12.wast similarity index 100% rename from wasp/tests/failing/test12.wast rename to tests/failing/test12.wast diff --git a/wasp/tests/failing/test13.wast b/tests/failing/test13.wast similarity index 100% rename from wasp/tests/failing/test13.wast rename to tests/failing/test13.wast diff --git a/wasp/tests/failing/test14.wast b/tests/failing/test14.wast similarity index 100% rename from wasp/tests/failing/test14.wast rename to tests/failing/test14.wast diff --git a/wasp/tests/failing/test15.wast b/tests/failing/test15.wast similarity index 100% rename from wasp/tests/failing/test15.wast rename to tests/failing/test15.wast diff --git a/wasp/tests/failing/test16.wast b/tests/failing/test16.wast similarity index 100% rename from wasp/tests/failing/test16.wast rename to tests/failing/test16.wast diff --git a/wasp/tests/failing/test2.wast b/tests/failing/test2.wast similarity index 100% rename from wasp/tests/failing/test2.wast rename to tests/failing/test2.wast diff --git a/wasp/tests/failing/test3.wast b/tests/failing/test3.wast similarity index 100% rename from wasp/tests/failing/test3.wast rename to tests/failing/test3.wast diff --git a/wasp/tests/failing/test4.wast b/tests/failing/test4.wast similarity index 100% rename from wasp/tests/failing/test4.wast rename to tests/failing/test4.wast diff --git a/wasp/tests/failing/test5.wast b/tests/failing/test5.wast similarity index 100% rename from wasp/tests/failing/test5.wast rename to tests/failing/test5.wast diff --git a/wasp/tests/failing/test6.wast b/tests/failing/test6.wast similarity index 100% rename from wasp/tests/failing/test6.wast rename to tests/failing/test6.wast diff --git a/wasp/tests/failing/test7.wast b/tests/failing/test7.wast similarity index 100% rename from wasp/tests/failing/test7.wast rename to tests/failing/test7.wast diff --git a/wasp/tests/failing/test8.wast b/tests/failing/test8.wast similarity index 100% rename from wasp/tests/failing/test8.wast rename to tests/failing/test8.wast diff --git a/wasp/tests/failing/test9.wast b/tests/failing/test9.wast similarity index 100% rename from wasp/tests/failing/test9.wast rename to tests/failing/test9.wast diff --git a/wasp/tests/passing/test1.wast b/tests/passing/test1.wast similarity index 100% rename from wasp/tests/passing/test1.wast rename to tests/passing/test1.wast diff --git a/wasp/tests/passing/test2.wast b/tests/passing/test2.wast similarity index 100% rename from wasp/tests/passing/test2.wast rename to tests/passing/test2.wast diff --git a/wasp/tests/passing/test3.wast b/tests/passing/test3.wast similarity index 100% rename from wasp/tests/passing/test3.wast rename to tests/passing/test3.wast diff --git a/wasp/tests/passing/test4.wast b/tests/passing/test4.wast similarity index 100% rename from wasp/tests/passing/test4.wast rename to tests/passing/test4.wast diff --git a/wasp/tests/passing/test5.wast b/tests/passing/test5.wast similarity index 100% rename from wasp/tests/passing/test5.wast rename to tests/passing/test5.wast diff --git a/wasp/tests/passing/test6.1.wast b/tests/passing/test6.1.wast similarity index 100% rename from wasp/tests/passing/test6.1.wast rename to tests/passing/test6.1.wast diff --git a/wasp/tests/passing/test6.wast b/tests/passing/test6.wast similarity index 100% rename from wasp/tests/passing/test6.wast rename to tests/passing/test6.wast diff --git a/wasp/tests/passing/test7.wast b/tests/passing/test7.wast similarity index 100% rename from wasp/tests/passing/test7.wast rename to tests/passing/test7.wast diff --git a/wasp/tests/regression/assume_assert.wast b/tests/regression/assume_assert.wast similarity index 100% rename from wasp/tests/regression/assume_assert.wast rename to tests/regression/assume_assert.wast diff --git a/wasp/tests/regression/assume_restart.wast b/tests/regression/assume_restart.wast similarity index 100% rename from wasp/tests/regression/assume_restart.wast rename to tests/regression/assume_restart.wast diff --git a/wasp/tests/regression/binop_to_relop.wast b/tests/regression/binop_to_relop.wast similarity index 100% rename from wasp/tests/regression/binop_to_relop.wast rename to tests/regression/binop_to_relop.wast diff --git a/wasp/tests/regression/borges-simple.wast b/tests/regression/borges-simple.wast similarity index 100% rename from wasp/tests/regression/borges-simple.wast rename to tests/regression/borges-simple.wast diff --git a/wasp/tests/regression/borges.wast b/tests/regression/borges.wast similarity index 100% rename from wasp/tests/regression/borges.wast rename to tests/regression/borges.wast diff --git a/wasp/tests/regression/checkpoints.wast b/tests/regression/checkpoints.wast similarity index 100% rename from wasp/tests/regression/checkpoints.wast rename to tests/regression/checkpoints.wast diff --git a/wasp/tests/regression/coverage_policy.wast b/tests/regression/coverage_policy.wast similarity index 100% rename from wasp/tests/regression/coverage_policy.wast rename to tests/regression/coverage_policy.wast diff --git a/wasp/tests/regression/load_store.wast b/tests/regression/load_store.wast similarity index 100% rename from wasp/tests/regression/load_store.wast rename to tests/regression/load_store.wast diff --git a/wasp/tests/regression/load_store_symbolic_memory.wast b/tests/regression/load_store_symbolic_memory.wast similarity index 100% rename from wasp/tests/regression/load_store_symbolic_memory.wast rename to tests/regression/load_store_symbolic_memory.wast diff --git a/wasp/tests/regression/min.wast b/tests/regression/min.wast similarity index 100% rename from wasp/tests/regression/min.wast rename to tests/regression/min.wast diff --git a/wasp/tests/regression/mutable_globals_hold.wast b/tests/regression/mutable_globals_hold.wast similarity index 100% rename from wasp/tests/regression/mutable_globals_hold.wast rename to tests/regression/mutable_globals_hold.wast diff --git a/wasp/tests/regression/nearest.wast b/tests/regression/nearest.wast similarity index 100% rename from wasp/tests/regression/nearest.wast rename to tests/regression/nearest.wast diff --git a/wasp/tests/regression/nop.wast b/tests/regression/nop.wast similarity index 100% rename from wasp/tests/regression/nop.wast rename to tests/regression/nop.wast diff --git a/wasp/tests/regression/sqrt.wast b/tests/regression/sqrt.wast similarity index 100% rename from wasp/tests/regression/sqrt.wast rename to tests/regression/sqrt.wast diff --git a/wasp/tests/regression/static.wast b/tests/regression/static.wast similarity index 100% rename from wasp/tests/regression/static.wast rename to tests/regression/static.wast diff --git a/wasp/tests/regression/symbolic_memory_holds.wast b/tests/regression/symbolic_memory_holds.wast similarity index 100% rename from wasp/tests/regression/symbolic_memory_holds.wast rename to tests/regression/symbolic_memory_holds.wast diff --git a/wasp/tests/regression/two_concrete_one_symbolic_locals_restart.wast b/tests/regression/two_concrete_one_symbolic_locals_restart.wast similarity index 100% rename from wasp/tests/regression/two_concrete_one_symbolic_locals_restart.wast rename to tests/regression/two_concrete_one_symbolic_locals_restart.wast diff --git a/wasp/tests/regression/two_concrete_one_symbolic_memory_restart.wast b/tests/regression/two_concrete_one_symbolic_memory_restart.wast similarity index 100% rename from wasp/tests/regression/two_concrete_one_symbolic_memory_restart.wast rename to tests/regression/two_concrete_one_symbolic_memory_restart.wast diff --git a/wasp/tests/regression/two_concrete_one_symbolic_restart.wast b/tests/regression/two_concrete_one_symbolic_restart.wast similarity index 100% rename from wasp/tests/regression/two_concrete_one_symbolic_restart.wast rename to tests/regression/two_concrete_one_symbolic_restart.wast diff --git a/wasp/tests/regression/two_concrete_one_symbolic_with_assume_restart.wast b/tests/regression/two_concrete_one_symbolic_with_assume_restart.wast similarity index 100% rename from wasp/tests/regression/two_concrete_one_symbolic_with_assume_restart.wast rename to tests/regression/two_concrete_one_symbolic_with_assume_restart.wast diff --git a/wasp/tests/run.py b/tests/run.py similarity index 100% rename from wasp/tests/run.py rename to tests/run.py diff --git a/wasp/tests/template/Makefile b/tests/template/Makefile similarity index 100% rename from wasp/tests/template/Makefile rename to tests/template/Makefile diff --git a/wasp/tests/template/README.md b/tests/template/README.md similarity index 100% rename from wasp/tests/template/README.md rename to tests/template/README.md diff --git a/wasp/tests/template/lib/include/mockups.h b/tests/template/lib/include/mockups.h similarity index 100% rename from wasp/tests/template/lib/include/mockups.h rename to tests/template/lib/include/mockups.h diff --git a/wasp/tests/template/lib/include/stdlib.h b/tests/template/lib/include/stdlib.h similarity index 100% rename from wasp/tests/template/lib/include/stdlib.h rename to tests/template/lib/include/stdlib.h diff --git a/wasp/tests/template/lib/mockups.c b/tests/template/lib/mockups.c similarity index 100% rename from wasp/tests/template/lib/mockups.c rename to tests/template/lib/mockups.c diff --git a/wasp/tests/template/lib/stdlib.c b/tests/template/lib/stdlib.c similarity index 100% rename from wasp/tests/template/lib/stdlib.c rename to tests/template/lib/stdlib.c diff --git a/wasp/tests/template/src/test-template.c b/tests/template/src/test-template.c similarity index 100% rename from wasp/tests/template/src/test-template.c rename to tests/template/src/test-template.c diff --git a/wasp.opam b/wasp.opam index a1aedb21..a0a3ff82 100644 --- a/wasp.opam +++ b/wasp.opam @@ -9,10 +9,15 @@ license: "LICENSE" homepage: "https://github.com/wasp-platform/wasp" bug-reports: "https://github.com/wasp-platform/wasp/issues" depends: [ - "dune" {>= "3.0"} - "base" "batteries" - "ocamlformat" + "bos" + "cmdliner" + "dune" {>= "3.0"} + "ocaml" + "ocamlformat" {with-dev-setup} + "pyml" + "re2" + "smtml" {>= "0.2.4"} "odoc" {with-doc} ] build: [ diff --git a/wasp/dune b/wasp/dune deleted file mode 100644 index 859bb8a9..00000000 --- a/wasp/dune +++ /dev/null @@ -1,4 +0,0 @@ -(env - (dev - (flags - (-w +a-3-4-27-42-44-45-70 -warn-error +a)))) diff --git a/wasp/lib/exec/eval.ml b/wasp/lib/exec/eval.ml deleted file mode 100644 index 6d13a2c9..00000000 --- a/wasp/lib/exec/eval.ml +++ /dev/null @@ -1,399 +0,0 @@ -open Values -open Types -open Instance -open Ast -open Source - -(* Errors *) - -module Link = Error.Make () -module Trap = Error.Make () -module Crash = Error.Make () -module Exhaustion = Error.Make () - -exception Link = Link.Error -exception Trap = Trap.Error -exception Crash = Crash.Error (* failure that cannot happen in valid code *) -exception Exhaustion = Exhaustion.Error - -let memory_error at = function - | Memory.Bounds -> "out of bounds memory access" - | Memory.SizeOverflow -> "memory size overflow" - | Memory.SizeLimit -> "memory size limit reached" - | Memory.Type -> Crash.error at "type mismatch at memory access" - | exn -> raise exn - -let numeric_error at = function - | Numeric_error.IntegerOverflow -> "integer overflow" - | Numeric_error.IntegerDivideByZero -> "integer divide by zero" - | Numeric_error.InvalidConversionToInteger -> "invalid conversion to integer" - | Eval_numeric.TypeError (i, v, t) -> - Crash.error at - ("type error, expected " - ^ Types.string_of_value_type t - ^ " as operand " ^ string_of_int i ^ ", got " - ^ Types.string_of_value_type (type_of v)) - | exn -> raise exn - -(* Administrative Expressions & Configurations *) - -type 'a stack = 'a list -type frame = { inst : module_inst; locals : value ref list } - -type code = value stack * admin_instr list -and admin_instr = admin_instr' phrase - -and admin_instr' = - | Plain of instr' - | Invoke of func_inst - | Trapping of string - | Returning of value stack - | Breaking of int32 * value stack - | Label of int * instr list * code - | Frame of int * frame * code - -type config = { - frame : frame; - code : code; - budget : int; (* to model stack overflow *) -} - -let frame inst locals = { inst; locals } -let config inst vs es = { frame = frame inst []; code = (vs, es); budget = 300 } -let plain e = Plain e.it @@ e.at - -let lookup category list x = - try Lib.List32.nth list x.it - with Failure _ -> - Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) - -let type_ (inst : module_inst) x = lookup "type" inst.types x -let func (inst : module_inst) x = lookup "function" inst.funcs x -let table (inst : module_inst) x = lookup "table" inst.tables x -let memory (inst : module_inst) x = lookup "memory" inst.memories x -let global (inst : module_inst) x = lookup "global" inst.globals x -let local (frame : frame) x = lookup "local" frame.locals x - -let elem inst x i at = - match Table.load (table inst x) i with - | Table.Uninitialized -> - Trap.error at ("uninitialized element " ^ Int32.to_string i) - | f -> f - | exception Table.Bounds -> - Trap.error at ("undefined element " ^ Int32.to_string i) - -let func_elem inst x i at = - match elem inst x i at with - | FuncElem f -> f - | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) - -let take n (vs : 'a stack) at = - try Lib.List.take n vs with Failure _ -> Crash.error at "stack underflow" - -let drop n (vs : 'a stack) at = - try Lib.List.drop n vs with Failure _ -> Crash.error at "stack underflow" - -(* Evaluation *) - -(* - * Conventions: - * e : instr - * v : value - * es : instr list - * vs : value stack - * c : config - *) - -let rec step (c : config) : config = - let { frame; code = vs, es; _ } = c in - let e = List.hd es in - let vs', es' = - match (e.it, vs) with - | Plain e', vs -> ( - match (e', vs) with - | Unreachable, vs -> (vs, [ Trapping "unreachable executed" @@ e.at ]) - | Nop, vs -> (vs, []) - | Block (ts, es'), vs -> - ( vs, - [ Label (List.length ts, [], ([], List.map plain es')) @@ e.at ] - ) - | Loop (ts, es'), vs -> - (vs, [ Label (0, [ e' @@ e.at ], ([], List.map plain es')) @@ e.at ]) - | If (ts, es1, es2), I32 0l :: vs' -> - (vs', [ Plain (Block (ts, es2)) @@ e.at ]) - | If (ts, es1, es2), I32 i :: vs' -> - (vs', [ Plain (Block (ts, es1)) @@ e.at ]) - | Br x, vs -> ([], [ Breaking (x.it, vs) @@ e.at ]) - | BrIf x, I32 0l :: vs' -> (vs', []) - | BrIf x, I32 i :: vs' -> (vs', [ Plain (Br x) @@ e.at ]) - | BrTable (xs, x), I32 i :: vs' when I32.ge_u i (Lib.List32.length xs) - -> - (vs', [ Plain (Br x) @@ e.at ]) - | BrTable (xs, x), I32 i :: vs' -> - (vs', [ Plain (Br (Lib.List32.nth xs i)) @@ e.at ]) - | Return, vs -> ([], [ Returning vs @@ e.at ]) - | Call x, vs -> (vs, [ Invoke (func frame.inst x) @@ e.at ]) - | CallIndirect x, I32 i :: vs -> - let func = func_elem frame.inst (0l @@ e.at) i e.at in - if type_ frame.inst x <> Func.type_of func then - (vs, [ Trapping "indirect call type mismatch" @@ e.at ]) - else (vs, [ Invoke func @@ e.at ]) - | Drop, v :: vs' -> (vs', []) - | Select, I32 0l :: v2 :: v1 :: vs' -> (v2 :: vs', []) - | Select, I32 i :: v2 :: v1 :: vs' -> (v1 :: vs', []) - | LocalGet x, vs -> (!(local frame x) :: vs, []) - | LocalSet x, v :: vs' -> - local frame x := v; - (* x-ésima variavel tem o valor v, avalia para o pointer daquela local *) - ( vs', - [] - (* tira da stack e nao ha mais intruções depois --> este codigo vai ficar igual *) - ) - | LocalTee x, v :: vs' -> - local frame x := v; - (v :: vs', []) - | GlobalGet x, vs -> (Global.load (global frame.inst x) :: vs, []) - | GlobalSet x, v :: vs' -> ( - try - Global.store (global frame.inst x) v; - (vs', []) - with - | Global.NotMutable -> Crash.error e.at "write to immutable global" - | Global.Type -> Crash.error e.at "type mismatch at global write") - | Load { offset; ty; sz; _ }, I32 i :: vs' -> ( - (* agr n interessa pq nao tamos a ver a heap*) - Printf.printf "--- A LOAD WAS MADE ----\n"; - let mem = memory frame.inst (0l @@ e.at) in - let addr = I64_convert.extend_i32_u i in - try - let v = - match sz with - | None -> Memory.load_value mem addr offset ty - | Some (sz, ext) -> Memory.load_packed sz ext mem addr offset ty - in - (v :: vs', []) - with exn -> (vs', [ Trapping (memory_error e.at exn) @@ e.at ])) - | Store { offset; sz; _ }, v :: I32 i :: vs' -> ( - (* agr n interessa pq nao tamos a ver a heap*) - Printf.printf "--- A STORE WAS MADE ---\n"; - let mem = memory frame.inst (0l @@ e.at) in - let addr = I64_convert.extend_i32_u i in - try - (match sz with - | None -> Memory.store_value mem addr offset v - | Some sz -> Memory.store_packed sz mem addr offset v); - (vs', []) - with exn -> (vs', [ Trapping (memory_error e.at exn) @@ e.at ])) - | MemorySize, vs -> - let mem = memory frame.inst (0l @@ e.at) in - (I32 (Memory.size mem) :: vs, []) - | MemoryGrow, I32 delta :: vs' -> - let mem = memory frame.inst (0l @@ e.at) in - let old_size = Memory.size mem in - let result = - try - Memory.grow mem delta; - old_size - with - | Memory.SizeOverflow | Memory.SizeLimit | Memory.OutOfMemory -> - -1l - in - (I32 result :: vs', []) - | Const v, vs -> (v.it :: vs, []) - | Test testop, v :: vs' -> ( - try (value_of_bool (Eval_numeric.eval_testop testop v) :: vs', []) - with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ])) - | Compare relop, v2 :: v1 :: vs' -> ( - try (value_of_bool (Eval_numeric.eval_relop relop v1 v2) :: vs', []) - with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ])) - | Unary unop, v :: vs' -> ( - try (Eval_numeric.eval_unop unop v :: vs', []) - with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ])) - | Binary binop, v2 :: v1 :: vs' -> ( - try (Eval_numeric.eval_binop binop v1 v2 :: vs', []) - with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ])) - | Convert cvtop, v :: vs' -> ( - try (Eval_numeric.eval_cvtop cvtop v :: vs', []) - with exn -> (vs', [ Trapping (numeric_error e.at exn) @@ e.at ])) - | _ -> - let s1 = string_of_values (List.rev vs) in - let s2 = string_of_value_types (List.map type_of (List.rev vs)) in - Crash.error e.at - ("missing or ill-typed operand on stack (" ^ s1 ^ " : " ^ s2 ^ ")") - ) - | Trapping msg, vs -> assert false - | Returning vs', vs -> Crash.error e.at "undefined frame" - | Breaking (k, vs'), vs -> Crash.error e.at "undefined label" - | Label (n, es0, (vs', [])), vs -> (vs' @ vs, []) - | Label (n, es0, (vs', { it = Trapping msg; at } :: es')), vs -> - (vs, [ Trapping msg @@ at ]) - | Label (n, es0, (vs', { it = Returning vs0; at } :: es')), vs -> - (vs, [ Returning vs0 @@ at ]) - | Label (n, es0, (vs', { it = Breaking (0l, vs0); at } :: es')), vs -> - (take n vs0 e.at @ vs, List.map plain es0) - | Label (n, es0, (vs', { it = Breaking (k, vs0); at } :: es')), vs -> - (vs, [ Breaking (Int32.sub k 1l, vs0) @@ at ]) - | Label (n, es0, code'), vs -> - let c' = step { c with code = code' } in - (vs, [ Label (n, es0, c'.code) @@ e.at ]) - | Frame (n, frame', (vs', [])), vs -> (vs' @ vs, []) - | Frame (n, frame', (vs', { it = Trapping msg; at } :: es')), vs -> - (vs, [ Trapping msg @@ at ]) - | Frame (n, frame', (vs', { it = Returning vs0; at } :: es')), vs -> - (take n vs0 e.at @ vs, []) - | Frame (n, frame', code'), vs -> - let c' = step { frame = frame'; code = code'; budget = c.budget - 1 } in - (vs, [ Frame (n, c'.frame, c'.code) @@ e.at ]) - | Invoke func, vs when c.budget = 0 -> - Exhaustion.error e.at "call stack exhausted" - | Invoke func, vs -> ( - let (FuncType (ins, out)) = Func.type_of func in - let n = List.length ins in - let args, vs' = (take n vs e.at, drop n vs e.at) in - match func with - | Func.AstFunc (t, inst', f) -> - let locals' = List.rev args @ List.map default_value f.it.locals in - let code' = ([], [ Plain (Block (out, f.it.body)) @@ f.at ]) in - let frame' = { inst = !inst'; locals = List.map ref locals' } in - (vs', [ Frame (List.length out, frame', code') @@ e.at ]) - | Func.HostFunc (t, f) -> ( - try (List.rev (f (List.rev args)) @ vs', []) - with Crash (_, msg) -> Crash.error e.at msg)) - in - { c with code = (vs', es' @ List.tl es) } - -let rec eval (c : config) : value stack = - match c.code with - | vs, [] -> vs - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, es -> eval (step c) - -(* Functions & Constants *) - -let invoke (func : func_inst) (vs : value list) : value list = - let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in - let (FuncType (ins, out)) = Func.type_of func in - if List.map Values.type_of vs <> ins then - Crash.error at "wrong number or types of arguments"; - let c = config empty_module_inst (List.rev vs) [ Invoke func @@ at ] in - try List.rev (eval c) - with Stack_overflow -> Exhaustion.error at "call stack exhausted" - -let eval_const (inst : module_inst) (const : const) : value = - let c = config inst [] (List.map plain const.it) in - match eval c with - | [ v ] -> v - | vs -> Crash.error const.at "wrong number of results on stack" - -let i32 (v : value) at = - match v with - | I32 i -> i - | _ -> Crash.error at "type error: i32 value expected" - -(* Modules *) - -let create_func (inst : module_inst) (f : func) : func_inst = - Func.alloc (type_ inst f.it.ftype) (ref inst) f - -let create_table (inst : module_inst) (tab : table) : table_inst = - let { ttype } = tab.it in - Table.alloc ttype - -let create_memory (inst : module_inst) (mem : memory) : memory_inst = - let { mtype } = mem.it in - Memory.alloc mtype - -let create_global (inst : module_inst) (glob : global) : global_inst = - let { gtype; value } = glob.it in - let v = eval_const inst value in - Global.alloc gtype v - -let create_export (inst : module_inst) (ex : export) : export_inst = - let { name; edesc } = ex.it in - let ext = - match edesc.it with - | FuncExport x -> ExternFunc (func inst x) - | TableExport x -> ExternTable (table inst x) - | MemoryExport x -> ExternMemory (memory inst x) - | GlobalExport x -> ExternGlobal (global inst x) - in - (name, ext) - -let init_func (inst : module_inst) (func : func_inst) = - match func with - | Func.AstFunc (_, inst_ref, _) -> inst_ref := inst - | _ -> assert false - -let init_table (inst : module_inst) (seg : table_segment) = - let { index; offset = const; init } = seg.it in - let tab = table inst index in - let offset = i32 (eval_const inst const) const.at in - let end_ = Int32.(add offset (of_int (List.length init))) in - let bound = Table.size tab in - if I32.lt_u bound end_ || I32.lt_u end_ offset then - Link.error seg.at "elements segment does not fit table"; - fun () -> - Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init) - -let init_memory (inst : module_inst) (seg : memory_segment) = - let { index; offset = const; init } = seg.it in - let mem = memory inst index in - let offset' = i32 (eval_const inst const) const.at in - let offset = I64_convert.extend_i32_u offset' in - let end_ = Int64.(add offset (of_int (String.length init))) in - let bound = Memory.bound mem in - if I64.lt_u bound end_ || I64.lt_u end_ offset then - Link.error seg.at "data segment does not fit memory"; - fun () -> Memory.store_bytes mem offset init - -let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : - module_inst = - if not (match_extern_type (extern_type_of ext) (import_type m im)) then - Link.error im.at "incompatible import type"; - match ext with - | ExternFunc func -> { inst with funcs = func :: inst.funcs } - | ExternTable tab -> { inst with tables = tab :: inst.tables } - | ExternMemory mem -> { inst with memories = mem :: inst.memories } - | ExternGlobal glob -> { inst with globals = glob :: inst.globals } - -let init (m : module_) (exts : extern list) : module_inst = - let { - imports; - tables; - memories; - globals; - funcs; - types; - exports; - elems; - data; - start; - } = - m.it - in - if List.length exts <> List.length imports then - Link.error m.at "wrong number of imports provided for initialisation"; - let inst0 = - { - (List.fold_right2 (add_import m) exts imports empty_module_inst) with - types = List.map (fun type_ -> type_.it) types; - } - in - let fs = List.map (create_func inst0) funcs in - let inst1 = - { - inst0 with - funcs = inst0.funcs @ fs; - tables = inst0.tables @ List.map (create_table inst0) tables; - memories = inst0.memories @ List.map (create_memory inst0) memories; - globals = inst0.globals @ List.map (create_global inst0) globals; - } - in - let inst = { inst1 with exports = List.map (create_export inst1) exports } in - List.iter (init_func inst) fs; - let init_elems = List.map (init_table inst) elems in - let init_datas = List.map (init_memory inst) data in - List.iter (fun f -> f ()) init_elems; - List.iter (fun f -> f ()) init_datas; - Lib.Option.app (fun x -> ignore (invoke (func inst x) [])) start; - inst diff --git a/wasp/lib/symbolic/common/dune b/wasp/lib/symbolic/common/dune deleted file mode 100644 index a330541f..00000000 --- a/wasp/lib/symbolic/common/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name common) - (libraries base encoding batteries interpreter)) diff --git a/wasp/lib/symbolic/common/evaluations.ml b/wasp/lib/symbolic/common/evaluations.ml deleted file mode 100644 index 5c7ad477..00000000 --- a/wasp/lib/symbolic/common/evaluations.ml +++ /dev/null @@ -1,196 +0,0 @@ -open Encoding -open Expression -open Types -open I64 -open F64 -open Interpreter.Ast - -exception UnsupportedOp of string - -let to_value (n : Num.t) : Interpreter.Values.value = - let open Interpreter in - match n with - | I32 i -> Values.I32 i - | I64 i -> Values.I64 i - | F32 f -> Values.F32 (F32.of_bits f) - | F64 f -> Values.F64 (F64.of_bits f) - -let of_value (v : Interpreter.Values.value) : Num.t = - let open Interpreter in - match v with - | Values.I32 i -> I32 i - | Values.I64 i -> I64 i - | Values.F32 f -> F32 (F32.to_bits f) - | Values.F64 f -> F64 (F64.to_bits f) - -let to_num_type (t : Interpreter.Types.value_type) = - let open Interpreter in - match t with - | Types.I32Type -> `I32Type - | Types.I64Type -> `I64Type - | Types.F32Type -> `F32Type - | Types.F64Type -> `F64Type - -let f32_unop op e = - match op with - | F32Op.Neg -> FloatingPoint.mk_neg e `F32Type - | F32Op.Abs -> FloatingPoint.mk_abs e `F32Type - | F32Op.Sqrt -> FloatingPoint.mk_sqrt e `F32Type - | F32Op.Nearest -> FloatingPoint.mk_nearest e `F32Type - | F32Op.Ceil -> raise (UnsupportedOp "eval_unop: Ceil") - | F32Op.Floor -> raise (UnsupportedOp "eval_unop: Floor") - | F32Op.Trunc -> raise (UnsupportedOp "eval_unop: Trunc") - -let f64_unop op e = - match op with - | F64Op.Neg -> FloatingPoint.mk_neg e `F64Type - | F64Op.Abs -> FloatingPoint.mk_abs e `F64Type - | F64Op.Sqrt -> FloatingPoint.mk_sqrt e `F64Type - | F64Op.Nearest -> FloatingPoint.mk_nearest e `F64Type - | F64Op.Ceil -> raise (UnsupportedOp "eval_unop: Ceil") - | F64Op.Floor -> raise (UnsupportedOp "eval_unop: Floor") - | F64Op.Trunc -> raise (UnsupportedOp "eval_unop: Trunc") - -let i32_binop op e1 e2 = - match op with - | I32Op.Add -> BitVector.mk_add e1 e2 `I32Type - | I32Op.And -> BitVector.mk_and e1 e2 `I32Type - | I32Op.Or -> BitVector.mk_or e1 e2 `I32Type - | I32Op.Sub -> BitVector.mk_sub e1 e2 `I32Type - | I32Op.DivS -> BitVector.mk_div_s e1 e2 `I32Type - | I32Op.DivU -> BitVector.mk_div_u e1 e2 `I32Type - | I32Op.Xor -> BitVector.mk_xor e1 e2 `I32Type - | I32Op.Mul -> BitVector.mk_mul e1 e2 `I32Type - | I32Op.Shl -> BitVector.mk_shl e1 e2 `I32Type - | I32Op.ShrS -> BitVector.mk_shr_s e1 e2 `I32Type - | I32Op.ShrU -> BitVector.mk_shr_u e1 e2 `I32Type - | I32Op.RemS -> BitVector.mk_rem_s e1 e2 `I32Type - | I32Op.RemU -> BitVector.mk_rem_u e1 e2 `I32Type - | I32Op.Rotl -> failwith "eval I32Binop: TODO Rotl" - | I32Op.Rotr -> failwith "eval I32Binop: TODO Rotr" - -let i64_binop op e1 e2 = - match op with - | I64Op.Add -> BitVector.mk_add e1 e2 `I64Type - | I64Op.And -> BitVector.mk_and e1 e2 `I64Type - | I64Op.Or -> BitVector.mk_or e1 e2 `I64Type - | I64Op.Sub -> BitVector.mk_sub e1 e2 `I64Type - | I64Op.DivS -> BitVector.mk_div_s e1 e2 `I64Type - | I64Op.DivU -> BitVector.mk_div_u e1 e2 `I64Type - | I64Op.Xor -> BitVector.mk_xor e1 e2 `I64Type - | I64Op.Mul -> BitVector.mk_mul e1 e2 `I64Type - | I64Op.Shl -> BitVector.mk_shl e1 e2 `I64Type - | I64Op.ShrS -> BitVector.mk_shr_s e1 e2 `I64Type - | I64Op.ShrU -> BitVector.mk_shr_u e1 e2 `I64Type - | I64Op.RemS -> BitVector.mk_rem_s e1 e2 `I64Type - | I64Op.RemU -> BitVector.mk_rem_u e1 e2 `I64Type - | I64Op.Rotl -> failwith "eval I64Binop: TODO Rotl" - | I64Op.Rotr -> failwith "eval I64Binop: TODO Rotr" - -let f32_binop op e1 e2 = - match op with - | F32Op.Add -> FloatingPoint.mk_add e1 e2 `F32Type - | F32Op.Sub -> FloatingPoint.mk_sub e1 e2 `F32Type - | F32Op.Div -> FloatingPoint.mk_div e1 e2 `F32Type - | F32Op.Mul -> FloatingPoint.mk_mul e1 e2 `F32Type - | F32Op.Min -> FloatingPoint.mk_min e1 e2 `F32Type - | F32Op.Max -> FloatingPoint.mk_max e1 e2 `F32Type - | F32Op.CopySign -> failwith "eval F32Binop: TODO CopySign" - -let f64_binop op e1 e2 = - match op with - | F64Op.Add -> FloatingPoint.mk_add e1 e2 `F64Type - | F64Op.Sub -> FloatingPoint.mk_sub e1 e2 `F64Type - | F64Op.Div -> FloatingPoint.mk_div e1 e2 `F64Type - | F64Op.Mul -> FloatingPoint.mk_mul e1 e2 `F64Type - | F64Op.Min -> FloatingPoint.mk_min e1 e2 `F64Type - | F64Op.Max -> FloatingPoint.mk_max e1 e2 `F64Type - | F64Op.CopySign -> failwith "eval F64Binop: TODO CopySign" - -let i32_relop op e1 e2 = - match op with - | I32Op.Eq -> BitVector.mk_eq e1 e2 `I32Type - | I32Op.Ne -> BitVector.mk_ne e1 e2 `I32Type - | I32Op.LtU -> BitVector.mk_lt_u e1 e2 `I32Type - | I32Op.LtS -> BitVector.mk_lt_s e1 e2 `I32Type - | I32Op.GtU -> BitVector.mk_gt_u e1 e2 `I32Type - | I32Op.GtS -> BitVector.mk_gt_s e1 e2 `I32Type - | I32Op.LeU -> BitVector.mk_le_u e1 e2 `I32Type - | I32Op.LeS -> BitVector.mk_le_s e1 e2 `I32Type - | I32Op.GeU -> BitVector.mk_ge_u e1 e2 `I32Type - | I32Op.GeS -> BitVector.mk_ge_s e1 e2 `I32Type - -let i64_relop op e1 e2 = - match op with - | I64Op.Eq -> BitVector.mk_eq e1 e2 `I64Type - | I64Op.Ne -> BitVector.mk_ne e1 e2 `I64Type - | I64Op.LtU -> BitVector.mk_lt_u e1 e2 `I64Type - | I64Op.LtS -> BitVector.mk_lt_s e1 e2 `I64Type - | I64Op.GtU -> BitVector.mk_gt_u e1 e2 `I64Type - | I64Op.GtS -> BitVector.mk_gt_s e1 e2 `I64Type - | I64Op.LeU -> BitVector.mk_le_u e1 e2 `I64Type - | I64Op.LeS -> BitVector.mk_le_s e1 e2 `I64Type - | I64Op.GeU -> BitVector.mk_ge_u e1 e2 `I64Type - | I64Op.GeS -> BitVector.mk_ge_s e1 e2 `I64Type - -let f32_relop op e1 e2 = - match op with - | F32Op.Eq -> FloatingPoint.mk_eq e1 e2 `F32Type - | F32Op.Ne -> FloatingPoint.mk_ne e1 e2 `F32Type - | F32Op.Lt -> FloatingPoint.mk_lt e1 e2 `F32Type - | F32Op.Gt -> FloatingPoint.mk_gt e1 e2 `F32Type - | F32Op.Le -> FloatingPoint.mk_le e1 e2 `F32Type - | F32Op.Ge -> FloatingPoint.mk_ge e1 e2 `F32Type - -let f64_relop op e1 e2 = - match op with - | F64Op.Eq -> FloatingPoint.mk_eq e1 e2 `F64Type - | F64Op.Ne -> FloatingPoint.mk_ne e1 e2 `F64Type - | F64Op.Lt -> FloatingPoint.mk_lt e1 e2 `F64Type - | F64Op.Gt -> FloatingPoint.mk_gt e1 e2 `F64Type - | F64Op.Le -> FloatingPoint.mk_le e1 e2 `F64Type - | F64Op.Ge -> FloatingPoint.mk_ge e1 e2 `F64Type - -(* TODO: sign bit *) -let i32_cvtop op s = - match op with - (* 64bit integer is taken modulo 2^32 i.e., top 32 bits are lost *) - | I32Op.WrapI64 -> Extract (s, 4, 0) - | I32Op.TruncSF32 -> Cvtop (I32 TruncSF32, s) - | I32Op.TruncUF32 -> Cvtop (I32 TruncUF32, s) - | I32Op.TruncSF64 -> Cvtop (I32 TruncSF64, s) - | I32Op.TruncUF64 -> Cvtop (I32 TruncUF64, s) - | I32Op.ReinterpretFloat -> Cvtop (I32 ReinterpretFloat, s) - | I32Op.ExtendSI32 -> raise (Eval_numeric.TypeError (1, I32 1l, `I32Type)) - | I32Op.ExtendUI32 -> raise (Eval_numeric.TypeError (1, I32 1l, `I32Type)) - -let i64_cvtop op s = - match op with - | I64Op.ExtendSI32 -> Cvtop (I64 ExtendSI32, s) - | I64Op.ExtendUI32 -> Cvtop (I64 ExtendUI32, s) - | I64Op.TruncSF32 -> Cvtop (I64 TruncSF32, s) - | I64Op.TruncUF32 -> Cvtop (I64 TruncUF32, s) - | I64Op.TruncSF64 -> Cvtop (I64 TruncSF64, s) - | I64Op.TruncUF64 -> Cvtop (I64 TruncUF64, s) - | I64Op.ReinterpretFloat -> Cvtop (I64 ReinterpretFloat, s) - | I64Op.WrapI64 -> raise (Eval_numeric.TypeError (1, I64 1L, `I64Type)) - -let f32_cvtop op s = - match op with - | F32Op.DemoteF64 -> Cvtop (F32 DemoteF64, s) - | F32Op.ConvertSI32 -> Cvtop (F32 ConvertSI32, s) - | F32Op.ConvertUI32 -> Cvtop (F32 ConvertUI32, s) - | F32Op.ConvertSI64 -> Cvtop (F32 ConvertSI64, s) - | F32Op.ConvertUI64 -> Cvtop (F32 ConvertUI64, s) - | F32Op.ReinterpretInt -> Cvtop (F32 ReinterpretInt, s) - | F32Op.PromoteF32 -> raise (Eval_numeric.TypeError (1, F32 1l, `F32Type)) - -let f64_cvtop op s = - match op with - | F64Op.PromoteF32 -> Cvtop (F64 PromoteF32, s) - | F64Op.ConvertSI32 -> Cvtop (F64 ConvertSI32, s) - | F64Op.ConvertUI32 -> Cvtop (F64 ConvertUI32, s) - | F64Op.ConvertSI64 -> Cvtop (F64 ConvertSI64, s) - | F64Op.ConvertUI64 -> Cvtop (F64 ConvertUI64, s) - | F64Op.ReinterpretInt -> Cvtop (F64 ReinterpretInt, s) - | F64Op.DemoteF64 -> raise (Eval_numeric.TypeError (1, F64 1L, `F64Type)) diff --git a/wasp/lib/symbolic/concolic/dune b/wasp/lib/symbolic/concolic/dune deleted file mode 100644 index cddd42f6..00000000 --- a/wasp/lib/symbolic/concolic/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name concolic) - (libraries base interpreter common encoding)) diff --git a/wasp/lib/symbolic/concolic/eval.ml b/wasp/lib/symbolic/concolic/eval.ml deleted file mode 100644 index 28166908..00000000 --- a/wasp/lib/symbolic/concolic/eval.ml +++ /dev/null @@ -1,1130 +0,0 @@ -open Evaluations -open Common -open Encoding -open Value -open Expression -open Types -open Interpreter.Ast -open Interpreter.Source -open Interpreter.Instance - -let memory_error at = function - | Heap.InvalidAddress a -> - Int64.to_string a ^ ":address not found in hashtable" - | Heap.Bounds -> "out of bounds memory access" - | Interpreter.Memory.SizeOverflow -> "memory size overflow" - | Interpreter.Memory.SizeLimit -> "memory size limit reached" - | Interpreter.Memory.Type -> Crash.error at "type mismatch at memory access" - | exn -> raise exn - -type policy = Random | Depth | Breadth -type interruption = Limit | Failure of Expression.t | Bug of Bug.bug -type value = Num.t * Expression.t -type 'a stack = 'a list -type frame = { inst : module_inst; locals : value ref list } - -type code = value stack * sym_admin_instr list -and sym_admin_instr = sym_admin_instr' phrase - -and sym_admin_instr' = - | Plain of instr' - | Invoke of func_inst - | Trapping of string - | Returning of value stack - | Breaking of int32 * value stack - | Label of int * instr list * code - | Frame of int * frame * code - | Interrupt of interruption - | Restart of Expression.t - -type config = { - frame : frame; - glob : value Globals.t; - code : code; - mem : Heap.t; - store : Store.t; - heap : Chunktable.t; - pc : Expression.t; - bp : bp list; - tree : tree ref; - budget : int; - call_stack : region Stack.t; -} - -and tree = config ref Execution_tree.t ref -and bp = Branchpoint of Expression.t * tree | Checkpoint of config ref - -let frame inst locals = { inst; locals } - -let clone_frame (f : frame) : frame = - frame f.inst (List.map (fun l -> ref !l) f.locals) - -let rec clone_admin_instr e = - let it = - match e.it with - | Label (n, es0, (vs, es)) -> - Label (n, es0, (vs, List.map clone_admin_instr es)) - | Frame (n, frame, (vs, es)) -> - Frame (n, clone_frame frame, (vs, List.map clone_admin_instr es)) - | _ -> e.it - in - { it; at = e.at } - -let clone (c : config) : Heap.t * config = - let vs, es = c.code in - let frame = clone_frame c.frame - and glob = Globals.copy c.glob - and code = (vs, List.map clone_admin_instr es) - and mem, mem' = Heap.clone c.mem - and store = Store.copy c.store - and heap = Chunktable.copy c.heap - and pc = c.pc - and bp = [] - and tree = ref !(c.tree) - and budget = c.budget - and call_stack = Stack.copy c.call_stack in - ( mem', - { frame; glob; code; mem; store; heap; pc; bp; tree; budget; call_stack } ) - -let config inst vs es mem glob tree = - { - frame = frame inst []; - glob; - code = (vs, es); - mem; - store = Store.create []; - heap = Chunktable.create (); - pc = Boolean.mk_val true; - bp = []; - tree; - budget = Interpreter.Flags.budget; - call_stack = Stack.create (); - } - -exception BugException of config * region * Bug.bug - -let head = ref Execution_tree.(Node (None, None, ref Leaf, ref Leaf)) -let step_cnt = ref 0 -let iterations = ref 0 -let loop_start = ref 0. -let logs = ref [] -let solver = Batch.create () -let debug str = if !Interpreter.Flags.trace then print_endline str - -let parse_policy (p : string) : policy option = - match p with - | "random" -> Some Random - | "depth" -> Some Depth - | "breadth" -> Some Breadth - | _ -> None - -let string_of_interruption : interruption -> string = function - | Limit -> "Analysis Limit" - | Failure _ -> "Assertion Failure" - | Bug b -> Bug.string_of_bug b - -let plain e = Plain e.it @@ e.at - -let lookup category list x = - try Interpreter.Lib.List32.nth list x.it - with Failure _ -> - Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) - -let type_ (inst : module_inst) x = lookup "type" inst.types x -let func (inst : module_inst) x = lookup "function" inst.funcs x -let table (inst : module_inst) x = lookup "table" inst.tables x -let memory (inst : module_inst) x = lookup "memory" inst.memories x -let global (inst : module_inst) x = lookup "global" inst.globals x -let local (frame : frame) x = lookup "local" frame.locals x - -let elem inst x i at = - match Interpreter.Table.load (table inst x) i with - | Interpreter.Table.Uninitialized -> - Trap.error at ("uninitialized element " ^ Int32.to_string i) - | f -> f - | exception Interpreter.Table.Bounds -> - Trap.error at ("undefined element " ^ Int32.to_string i) - -let func_elem inst x i at = - match elem inst x i at with - | FuncElem f -> f - | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) - -let take n (vs : 'a stack) at = - try Interpreter.Lib.List.take n vs - with Failure _ -> Crash.error at "stack underflow" - -let drop n (vs : 'a stack) at = - try Interpreter.Lib.List.drop n vs - with Failure _ -> Crash.error at "stack underflow" - -let branch_on_cond bval c pc tree = - let tree', to_branch = - if bval then Execution_tree.move_true !tree - else Execution_tree.move_false !tree - in - tree := tree'; - if to_branch then Some (Expression.add_constraint ~neg:bval c pc) else None - -module type Checkpoint = sig - val is_checkpoint : config -> bool -end - -module NoCheckpoint : Checkpoint = struct - let is_checkpoint (_ : config) : bool = false -end - -module FuncCheckpoint : Checkpoint = struct - let visited = Hashtbl.create Interpreter.Flags.hashtbl_default_size - - let is_checkpoint (c : config) : bool = - let func = Stack.top c.call_stack in - if Hashtbl.mem visited func then false - else ( - Hashtbl.add visited func true; - Execution_tree.can_branch !(c.tree)) -end - -module RandCheckpoint : Checkpoint = struct - let is_checkpoint (c : config) : bool = - Execution_tree.can_branch !(c.tree) && Random.bool () -end - -module DepthCheckpoint : Checkpoint = struct - let count = Counter.create () - - let is_checkpoint (c : config) : bool = - let size_pc = Expression.length c.pc in - Execution_tree.can_branch !(c.tree) - && size_pc mod 10 = 0 - && Counter.get_and_inc count size_pc < 5 -end - -module type Stepper = sig - val step : config -> config -end - -module ConcolicStepper (C : Checkpoint) : Stepper = struct - let rec step (c : config) : config = - let { - frame; - glob; - code = vs, es; - mem; - store; - heap; - pc; - bp; - tree; - call_stack; - _; - } = - c - in - let e = List.hd es in - let vs', es', mem', pc', bp' = - match (e.it, vs) with - | Plain e', vs -> ( - match (e', vs) with - | Unreachable, vs -> - (vs, [ Trapping "unreachable executed" @@ e.at ], mem, pc, bp) - | Nop, vs -> (vs, [], mem, pc, bp) - | Block (ts, es'), vs -> - let es' = - [ Label (List.length ts, [], ([], List.map plain es')) @@ e.at ] - in - (vs, es', mem, pc, bp) - | Loop (ts, es'), vs -> - ( vs, - [ Label (0, [ e' @@ e.at ], ([], List.map plain es')) @@ e.at ], - mem, - pc, - bp ) - | If (ts, es1, es2), (I32 i, ex) :: vs' when is_concrete (simplify ex) - -> - if i = 0l then - (vs', [ Plain (Block (ts, es2)) @@ e.at ], mem, pc, bp) - else (vs', [ Plain (Block (ts, es1)) @@ e.at ], mem, pc, bp) - | If (ts, es1, es2), (I32 i, ex) :: vs' -> - let b, es1', es2' = - ( i <> 0l, - [ Plain (Block (ts, es1)) @@ e.at ], - [ Plain (Block (ts, es2)) @@ e.at ] ) - in - let mem', bp = - let pc' = Expression.add_constraint ~neg:b ex pc in - if not (C.is_checkpoint c) then (mem, bp) - else - let mem, c' = clone c in - ignore (branch_on_cond (not b) ex c'.pc c'.tree); - let es' = (if not b then es1' else es2') @ List.tl es in - let cp = ref { c' with code = (vs', es'); pc = pc' } in - Execution_tree.update_node !(c'.tree) cp; - (mem, Checkpoint cp :: bp) - in - let bp' = - Base.Option.fold ~init:bp - ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) - (branch_on_cond b ex pc tree) - in - let pc' = Expression.add_constraint ~neg:(not b) ex pc in - (vs', (if b then es1' else es2'), mem', pc', bp') - | Br x, vs -> ([], [ Breaking (x.it, vs) @@ e.at ], mem, pc, bp) - | BrIf x, (I32 i, ex) :: vs' when is_concrete (simplify ex) -> - if i = 0l then (vs', [], mem, pc, bp) - else (vs', [ Plain (Br x) @@ e.at ], mem, pc, bp) - | BrIf x, (I32 i, ex) :: vs' -> - let b, es1', es2' = (i <> 0l, [ Plain (Br x) @@ e.at ], []) in - let mem', bp = - let pc' = Expression.add_constraint ~neg:b ex pc in - if not (C.is_checkpoint c) then (mem, bp) - else - let mem, c' = clone c in - ignore (branch_on_cond (not b) ex c'.pc c'.tree); - let es' = (if not b then es1' else es2') @ List.tl es in - let cp = ref { c' with code = (vs', es'); pc = pc' } in - Execution_tree.update_node !(c'.tree) cp; - (mem, Checkpoint cp :: bp) - in - let bp' = - Base.Option.fold ~init:bp - ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) - (branch_on_cond b ex pc tree) - in - let pc' = Expression.add_constraint ~neg:(not b) ex pc in - (vs', (if b then es1' else es2'), mem', pc', bp') - | BrTable (xs, x), (I32 i, _) :: vs' - when Interpreter.I32.ge_u i (Interpreter.Lib.List32.length xs) -> - (vs', [ Plain (Br x) @@ e.at ], mem, pc, bp) - | BrTable (xs, x), (I32 i, _) :: vs' -> - ( vs', - [ Plain (Br (Interpreter.Lib.List32.nth xs i)) @@ e.at ], - mem, - pc, - bp ) - | Return, vs -> ([], [ Returning vs @@ e.at ], mem, pc, bp) - | Call x, vs -> - (vs, [ Invoke (func frame.inst x) @@ e.at ], mem, pc, bp) - | CallIndirect x, (I32 i, _) :: vs -> - let func = func_elem frame.inst (0l @@ e.at) i e.at in - if type_ frame.inst x <> Interpreter.Func.type_of func then - ( vs, - [ Trapping "indirect call type mismatch" @@ e.at ], - mem, - pc, - bp ) - else (vs, [ Invoke func @@ e.at ], mem, pc, bp) - | Drop, v :: vs' -> (vs', [], mem, pc, bp) - | Select, (I32 i, ve) :: v2 :: v1 :: vs' - when is_concrete (simplify ve) -> - if i = 0l then (v2 :: vs', [], mem, pc, bp) - else (v1 :: vs', [], mem, pc, bp) - | Select, (I32 i, ve) :: v2 :: v1 :: vs' -> - let b, vs1, vs2 = (i <> 0l, v1 :: vs', v2 :: vs') in - let mem', bp = - let pc' = Expression.add_constraint ~neg:b ve pc in - if not (C.is_checkpoint c) then (mem, bp) - else - let mem, c' = clone c in - ignore (branch_on_cond (not b) ve c'.pc c'.tree); - let vs' = if not b then vs1 else vs2 in - let cp = ref { c' with code = (vs', List.tl es); pc = pc' } in - Execution_tree.update_node !(c'.tree) cp; - (mem, Checkpoint cp :: bp) - in - let bp' = - Base.Option.fold ~init:bp - ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) - (branch_on_cond b ve pc tree) - in - let pc' = Expression.add_constraint ~neg:(not b) ve pc in - ((if b then vs1 else vs2), [], mem', pc', bp') - | LocalGet x, vs -> (!(local frame x) :: vs, [], mem, pc, bp) - | LocalSet x, (v, ex) :: vs' -> - local frame x := (v, simplify ex); - (vs', [], mem, pc, bp) - | LocalTee x, (v, ex) :: vs' -> - local frame x := (v, simplify ex); - (!(local frame x) :: vs', [], mem, pc, bp) - | GlobalGet x, vs -> (Globals.find glob x.it :: vs, [], mem, pc, bp) - | GlobalSet x, v :: vs' -> - Globals.add glob x.it v; - (vs', [], mem, pc, bp) - | Load { offset; ty; sz; _ }, (I32 i, sym_ptr) :: vs' -> ( - try - let base = Interpreter.I64_convert.extend_i32_u i in - (* overflow check *) - let ptr = concretize_base_ptr (simplify sym_ptr) in - match - Option.bind ptr (fun bp -> - Chunktable.check_access heap bp (I32 i) offset) - with - | Some b -> (vs', [ Interrupt (Bug b) @@ e.at ], mem, pc, bp) - | None -> - let v, e = - match sz with - | None -> - Heap.load_value mem base offset - (Evaluations.to_num_type ty) - | Some (sz, ext) -> - Heap.load_packed sz ext mem base offset - (Evaluations.to_num_type ty) - in - ((v, e) :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (memory_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Store { offset; sz; _ }, (v, ex) :: (I32 i, sym_ptr) :: vs' -> ( - try - let base = Interpreter.I64_convert.extend_i32_u i in - let ptr = concretize_base_ptr (simplify sym_ptr) in - match - Option.bind ptr (fun bp -> - Chunktable.check_access heap bp (I32 i) offset) - with - | Some b -> (vs', [ Interrupt (Bug b) @@ e.at ], mem, pc, bp) - | None -> - (match sz with - | None -> Heap.store_value mem base offset (v, simplify ex) - | Some sz -> - Heap.store_packed sz mem base offset (v, simplify ex)); - (vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (memory_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | MemorySize, vs -> - let mem' = memory frame.inst (0l @@ e.at) in - let v : Num.t = I32 (Interpreter.Memory.size mem') in - ((v, Val (Num v)) :: vs, [], mem, pc, bp) - | MemoryGrow, (I32 delta, _) :: vs' -> - let mem' = memory frame.inst (0l @@ e.at) in - let old_size = Interpreter.Memory.size mem' in - let result = - let open Interpreter in - try - Memory.grow mem' delta; - old_size - with - | Memory.SizeOverflow | Memory.SizeLimit | Memory.OutOfMemory -> - -1l - in - ((I32 result, Val (Num (I32 result))) :: vs', [], mem, pc, bp) - | Const v, vs -> - let v' = Evaluations.of_value v.it in - ((v', Val (Num v')) :: vs, [], mem, pc, bp) - | Test testop, v :: vs' -> ( - try (eval_testop v testop :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Compare relop, v2 :: v1 :: vs' -> ( - try (eval_relop v1 v2 relop :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Unary unop, v :: vs' -> ( - try (eval_unop v unop :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Binary binop, v2 :: v1 :: vs' -> ( - try (eval_binop v1 v2 binop :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Convert cvtop, v :: vs' -> ( - try (eval_cvtop cvtop v :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Dup, v :: vs' -> (v :: v :: vs', [], mem, pc, bp) - | SymAssert, (I32 0l, ex) :: vs' -> - debug ">>> Assert FAILED! Stopping..."; - (vs', [ Interrupt (Failure pc) @@ e.at ], mem, pc, bp) - | SymAssert, (I32 i, ex) :: vs' when is_concrete (simplify ex) -> - (vs', [], mem, pc, bp) - | SymAssert, (I32 i, ex) :: vs' -> - let formulas = Expression.add_constraint ~neg:true ex pc in - if not (Batch.check_sat solver [ formulas ]) then - (vs', [], mem, pc, bp) - else - let binds = - Batch.value_binds solver ~symbols:(Store.get_key_types store) - in - Store.update store binds; - (vs', [ Interrupt (Failure pc) @@ e.at ], mem, pc, bp) - | SymAssume, (I32 i, ex) :: vs' when is_concrete (simplify ex) -> - let unsat = Boolean.mk_val false in - if i = 0l then (vs', [ Restart unsat @@ e.at ], mem, pc, bp) - else (vs', [], mem, pc, bp) - | SymAssume, (I32 i, ex) :: vs' -> - if i = 0l then - ( vs', - [ Restart (Expression.add_constraint ex pc) @@ e.at ], - mem, - pc, - bp ) - else ( - debug ">>> Assume passed. Continuing execution..."; - let tree', _ = Execution_tree.move_true !tree in - tree := tree'; - (vs', [], mem, Expression.add_constraint ex pc, bp)) - | Symbolic (ty, b), (I32 i, _) :: vs' -> - let base = Interpreter.I64_convert.extend_i32_u i in - let symbol = if i = 0l then "x" else Heap.load_string mem base in - let x = Store.next store symbol in - let ty' = Evaluations.to_num_type ty in - let v = Store.get store x ty' b in - ((v, Expression.mk_symbol_s ty' x) :: vs', [], mem, pc, bp) - | Boolop boolop, (v2, sv2) :: (v1, sv1) :: vs' -> ( - let sv2' = mk_relop sv2 (Num.type_of v2) in - let v2' = - Num.(num_of_bool (not (v2 = default_value (type_of v2)))) - in - let sv1' = mk_relop sv1 (Num.type_of v1) in - let v1' = - Num.(num_of_bool (not (v1 = default_value (type_of v1)))) - in - try - let v3, sv3 = eval_binop (v1', sv1') (v2', sv2') boolop in - ((v3, simplify sv3) :: vs', [], mem, pc, bp) - with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) - ) - | Alloc, (I32 a, sa) :: (I32 b, sb) :: vs' -> - Hashtbl.add heap b a; - ((I32 b, SymPtr (b, Val (Num (I32 0l)))) :: vs', [], mem, pc, bp) - | Free, (I32 i, _) :: vs' -> - let es' = - if not (Hashtbl.mem heap i) then - [ Interrupt (Bug Bug.InvalidFree) @@ e.at ] - else ( - Hashtbl.remove heap i; - []) - in - (vs', es', mem, pc, bp) - | GetSymInt32 x, vs' -> - let v = - try Store.find store x - with Not_found -> - Crash.error e.at "Symbolic variable was not in store." - in - ((v, Expression.mk_symbol_s `I32Type x) :: vs', [], mem, pc, bp) - | GetSymInt64 x, vs' -> - let v = - try Store.find store x - with Not_found -> - Crash.error e.at "Symbolic variable was not in store." - in - ((v, Expression.mk_symbol_s `I64Type x) :: vs', [], mem, pc, bp) - | GetSymFloat32 x, vs' -> - let v = - try Store.find store x - with Not_found -> - Crash.error e.at "Symbolic variable was not in store." - in - ((v, Expression.mk_symbol_s `F32Type x) :: vs', [], mem, pc, bp) - | GetSymFloat64 x, vs' -> - let v = - try Store.find store x - with Not_found -> - Crash.error e.at "Symbolic variable was not in store." - in - ((v, Expression.mk_symbol_s `F64Type x) :: vs', [], mem, pc, bp) - | TernaryOp, (I32 r2, s_r2) :: (I32 r1, s_r1) :: (I32 c, s_c) :: vs' - -> - let r : Num.t = I32 (if c = 0l then r2 else r1) in - let s_c' = to_relop (simplify s_c) in - let v, pc' = - match s_c' with - | None -> ((r, if c = 0l then s_r2 else s_r1), pc) - | Some s -> - let x = Store.next store "__ternary" in - Store.add store x r; - let s_x = Expression.mk_symbol_s `I32Type x in - let t_eq = Relop (I32 I32.Eq, s_x, s_r1) in - let t_imp = Binop (I32 I32.Or, negate_relop s, t_eq) in - let f_eq = Relop (I32 I32.Eq, s_x, s_r2) in - let f_imp = Binop (I32 I32.Or, s, f_eq) in - let cond = Binop (I32 I32.And, t_imp, f_imp) in - ( (r, s_x), - Expression.add_constraint - (Relop (I32 I32.Ne, cond, Val (Num (I32 0l)))) - pc ) - in - (v :: vs', [], mem, pc', bp) - | PrintStack, vs' -> - debug - (Interpreter.Source.string_of_pos e.at.left - ^ ":VS:\n" - ^ Expression.string_of_values vs'); - (vs', [], mem, pc, bp) - | PrintPC, vs' -> - debug - (Interpreter.Source.string_of_pos e.at.left - ^ ":PC: " - ^ Expression.(pp_to_string pc)); - (vs', [], mem, pc, bp) - | PrintMemory, vs' -> - debug ("Mem:\n" ^ Heap.to_string mem); - (vs', [], mem, pc, bp) - | PrintBtree, vs' -> - Printf.printf "B TREE STATE: \n\n"; - (* Btree.print_b_tree mem; *) - (vs', [], mem, pc, bp) - | CompareExpr, (v1, ex1) :: (v2, ex2) :: vs' -> - let res : Num.t * Expression.t = - match (ex1, ex2) with - | Symbol s1, Symbol s2 -> - if Symbol.equal s1 s2 then (I32 1l, Integer.mk_eq ex1 ex2) - else (I32 0l, Integer.mk_ne ex1 ex2) - | _, _ -> - eval_relop (v1, ex1) (v2, ex2) - (Interpreter.Values.I32 Interpreter.Ast.I32Op.Eq) - in - (res :: vs', [], mem, pc, bp) - | IsSymbolic, (I32 n, _) :: (I32 i, _) :: vs' -> - let base = Interpreter.I64_convert.extend_i32_u i in - let _, v = Heap.load_bytes mem base (Int32.to_int n) in - let result : Num.t = I32 (match v with Val _ -> 0l | _ -> 1l) in - ((result, Val (Num result)) :: vs', [], mem, pc, bp) - | SetPriority, _ :: _ :: _ :: vs' -> (vs', [], mem, pc, bp) - | PopPriority, _ :: vs' -> (vs', [], mem, pc, bp) - | _ -> Crash.error e.at "missing or ill-typed operand on stack") - | Trapping msg, vs -> assert false - | Interrupt i, vs -> assert false - | Restart pc, vs -> assert false - | Returning vs', vs -> Crash.error e.at "undefined frame" - | Breaking (k, vs'), vs -> Crash.error e.at "undefined label" - | Label (n, es0, (vs', [])), vs -> (vs' @ vs, [], mem, pc, bp) - | Label (n, es0, (vs', { it = Restart pc'; at } :: es')), vs -> - ( vs, - [ Restart pc' @@ at; Label (n, es0, (vs', es')) @@ e.at ], - mem, - pc, - bp ) - | Label (n, es0, (vs', { it = Interrupt i; at } :: es')), vs -> - ( vs, - [ Interrupt i @@ at; Label (n, es0, (vs', es')) @@ e.at ], - mem, - pc, - bp ) - | Label (n, es0, (vs', { it = Trapping msg; at } :: es')), vs -> - (vs, [ Trapping msg @@ at ], mem, pc, bp) - | Label (n, es0, (vs', { it = Returning vs0; at } :: es')), vs -> - (vs, [ Returning vs0 @@ at ], mem, pc, bp) - | Label (n, es0, (vs', { it = Breaking (0l, vs0); at } :: es')), vs -> - (take n vs0 e.at @ vs, List.map plain es0, mem, pc, bp) - | Label (n, es0, (vs', { it = Breaking (k, vs0); at } :: es')), vs -> - (vs, [ Breaking (Int32.sub k 1l, vs0) @@ at ], mem, pc, bp) - | Label (n, es0, code'), vs -> - let c' = step { c with code = code' } in - List.iter - (fun bp -> - match bp with - | Branchpoint _ -> () - | Checkpoint cp -> - let es' = (Label (n, es0, !cp.code) @@ e.at) :: List.tl es in - cp := { !cp with code = (vs, es') }) - c'.bp; - (vs, [ Label (n, es0, c'.code) @@ e.at ], c'.mem, c'.pc, c'.bp) - | Frame (n, frame', (vs', [])), vs -> - ignore (Stack.pop call_stack); - (vs' @ vs, [], mem, pc, bp) - | Frame (n, frame', (vs', { it = Restart pc'; at } :: es')), vs -> - ( vs, - [ Restart pc' @@ at; Frame (n, frame', (vs', es')) @@ e.at ], - mem, - pc, - bp ) - | Frame (n, frame', (vs', { it = Interrupt i; at } :: es')), vs -> - ( vs, - [ Interrupt i @@ at; Frame (n, frame', (vs', es')) @@ e.at ], - mem, - pc, - bp ) - | Frame (n, frame', (vs', { it = Trapping msg; at } :: es')), vs -> - (vs, [ Trapping msg @@ at ], mem, pc, bp) - | Frame (n, frame', (vs', { it = Returning vs0; at } :: es')), vs -> - (take n vs0 e.at @ vs, [], mem, pc, bp) - | Frame (n, frame', code'), vs -> - let c' = - step - { - frame = frame'; - glob = c.glob; - code = code'; - mem = c.mem; - heap = c.heap; - store = c.store; - pc = c.pc; - bp = c.bp; - tree = c.tree; - budget = c.budget - 1; - call_stack = c.call_stack; - } - in - List.iter - (fun bp -> - match bp with - | Branchpoint _ -> () - | Checkpoint cp -> - let es' = - (Frame (n, !cp.frame, !cp.code) @@ e.at) :: List.tl es - and frame' = clone_frame frame in - cp := { !cp with frame = frame'; code = (vs, es') }) - c'.bp; - (vs, [ Frame (n, c'.frame, c'.code) @@ e.at ], c'.mem, c'.pc, c'.bp) - | Invoke func, vs when c.budget = 0 -> - (vs, [ Interrupt Limit @@ e.at ], mem, pc, bp) - | Invoke func, vs -> ( - let symbolic_arg t = - let x = Store.next store "arg" in - let v = Store.get store x t false in - (v, Expression.mk_symbol_s t x) - in - let (Interpreter.Types.FuncType (ins, out)) = - Interpreter.Func.type_of func - in - let n = List.length ins in - let vs = - if n > 0 && List.length vs = 0 then - List.map (fun t -> symbolic_arg (Evaluations.to_num_type t)) ins - else vs - in - let args, vs' = (take n vs e.at, drop n vs e.at) in - match func with - | Interpreter.Func.AstFunc (t, inst', f) -> - Stack.push f.at call_stack; - let locals' = - List.map - (fun v -> (v, Val (Num v))) - (List.map - (fun t -> Num.default_value (Evaluations.to_num_type t)) - f.it.locals) - in - let locals'' = List.rev args @ locals' in - let code' = ([], [ Plain (Block (out, f.it.body)) @@ f.at ]) in - let frame' = { inst = !inst'; locals = List.map ref locals'' } in - ( vs', - [ Frame (List.length out, frame', code') @@ e.at ], - mem, - pc, - bp ) - | Interpreter.Func.HostFunc (t, f) -> failwith "HostFunc error") - in - step_cnt := !step_cnt + 1; - { c with code = (vs', es' @ List.tl es); mem = mem'; pc = pc'; bp = bp' } -end - -let get_reason (err_t, at) : string = - let loc = - Interpreter.Source.string_of_pos at.left - ^ if at.right = at.left then "" else "-" ^ string_of_pos at.right - in - "{" ^ "\"type\" : \"" ^ err_t ^ "\", " ^ "\"line\" : \"" ^ loc ^ "\"" ^ "}" - -let write_report error loop_time : unit = - if !Interpreter.Flags.log then print_logs !logs; - let spec, reason = - match error with None -> (true, "{}") | Some e -> (false, get_reason e) - in - let report_str = - "{" ^ "\"specification\": " ^ string_of_bool spec ^ ", " ^ "\"reason\" : " - ^ reason ^ ", " ^ "\"loop_time\" : \"" ^ string_of_float loop_time ^ "\", " - ^ "\"solver_time\" : \"" - ^ string_of_float !Batch.solver_time - ^ "\", " ^ "\"paths_explored\" : " ^ string_of_int !iterations ^ ", " - ^ "\"solver_counter\" : " - ^ string_of_int !Batch.solver_count - ^ ", " ^ "\"instruction_counter\" : " ^ string_of_int !step_cnt ^ "}" - in - Interpreter.Io.save_file - (Filename.concat !Interpreter.Flags.output "report.json") - report_str - -let rec update_admin_instr f e = - let it = - match e.it with - | Plain e -> Plain e - | Invoke f -> Invoke f - | Trapping exn -> Trapping exn - | Returning vs -> Returning (List.map f vs) - | Breaking (n, vs) -> Breaking (n, List.map f vs) - | Label (n, es0, (vs, es)) -> - Label (n, es0, (List.map f vs, List.map (update_admin_instr f) es)) - | Frame (n, frame, (vs, es)) -> - List.iter (fun l -> l := f !l) frame.locals; - Frame (n, frame, (List.map f vs, List.map (update_admin_instr f) es)) - | Interrupt i -> Interrupt i - | Restart pc -> Restart pc - in - { it; at = e.at } - -let update c (vs, es) pc symbols = - let binds = Batch.value_binds solver ~symbols in - Store.update c.store binds; - Heap.update c.mem c.store; - let f store (_, expr) = (Store.eval store expr, expr) in - List.iter (fun l -> l := f c.store !l) c.frame.locals; - let code = - (List.map (f c.store) vs, List.map (update_admin_instr (f c.store)) es) - in - { c with code; pc } - -let reset c glob code mem = - let binds = Batch.value_binds solver ~symbols:(Store.get_key_types c.store) in - Store.reset c.store; - Store.init c.store binds; - let glob = Globals.copy glob in - Hashtbl.reset c.heap; - c.tree := head; - { - c with - frame = frame empty_module_inst []; - code; - glob; - mem = Heap.memcpy mem; - pc = Boolean.mk_val true; - bp = []; - budget = Interpreter.Flags.budget; - } - -let s_reset (c : config) : config = - let binds = Batch.value_binds solver ~symbols:(Store.get_key_types c.store) in - Store.update c.store binds; - Heap.update c.mem c.store; - let f store (_, expr) = (Store.eval store expr, expr) in - List.iter (fun l -> l := f c.store !l) c.frame.locals; - c.tree := head; - let vs, es = c.code in - let code = - (List.map (f c.store) vs, List.map (update_admin_instr (f c.store)) es) - in - { c with code } - -module Guided_search (L : WorkList) (S : Stepper) = struct - let enqueue (pc_wl, cp_wl) branch_points : unit = - List.iter - (fun bp -> - match bp with - | Branchpoint (pc, node) -> L.push (pc, node) pc_wl - | Checkpoint cp -> L.push cp cp_wl) - branch_points - - let rec eval (c : config) wls : config = - match c.code with - | vs, [] -> c - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, { it = Interrupt Limit; at } :: _ -> { c with code = (vs, []) } - | vs, { it = Interrupt i; at } :: _ -> c - | vs, { it = Restart pc; at } :: _ -> - iterations := !iterations - 1; - c - | vs, es -> - let c' = S.step c in - enqueue wls c'.bp; - eval { c' with bp = [] } wls - - let rec find_sat_pc pcs = - if L.is_empty pcs then None - else - let pc, node = L.pop pcs in - if not (Batch.check_sat solver [ pc ]) then find_sat_pc pcs - else Some (pc, Execution_tree.find node) - - let rec find_sat_cp cps = - if L.is_empty cps then None - else - let cp = L.pop cps in - if not (Batch.check_sat solver [ !cp.pc ]) then find_sat_cp cps - else Some (!cp.pc, Some cp) - - let find_sat_path (pcs, cps) = - match find_sat_cp cps with None -> find_sat_pc pcs | Some _ as cp -> cp - - let invoke (c : config) (test_suite : string) = - let glob0 = Globals.copy c.glob - and code0 = c.code - and mem0 = Heap.memcpy c.mem in - let pc_wl = L.create () and cp_wl = L.create () in - (* Main concolic loop *) - let rec loop c = - iterations := !iterations + 1; - let { code; store; bp; tree; _ } = eval c (pc_wl, cp_wl) in - enqueue (pc_wl, cp_wl) bp; - match code with - | vs, { it = Interrupt i; at } :: _ -> - write_test_case ~witness:true (Store.to_json store); - Some (string_of_interruption i, at) - | vs, { it = Restart pc; _ } :: es when Batch.check_sat solver [ pc ] -> - let tree', _ = Execution_tree.move_true !(c.tree) in - c.tree := tree'; - loop (update c (vs, es) pc (Store.get_key_types store)) - | _ -> ( - write_test_case (Store.to_json store); - match find_sat_path (pc_wl, cp_wl) with - | None -> None - | Some (pc', None) -> loop (reset c glob0 code0 mem0) - | Some (pc', Some cp) -> - let _, c' = clone !cp in - loop (update c' c'.code c'.pc (Expression.get_symbols [ pc' ]))) - in - loop c - - let s_invoke (c : config) (test_suite : string) : (string * region) option = - let _, c0 = clone c in - let wl = L.create () in - let rec eval (c : config) : config = - match c.code with - | vs, [] -> c - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, { it = Restart pc; at } :: es -> c - | vs, { it = Interrupt i; at } :: es -> c - | vs, es -> - let c' = S.step c in - List.iter - (fun bp -> - let pc = - match bp with - | Checkpoint cp -> !cp.pc - | Branchpoint (pc, _) -> pc - in - L.push pc wl) - c'.bp; - eval { c' with bp = [] } - in - let rec find_sat_pc pcs = - if L.is_empty pcs then false - else if not (Batch.check_sat solver [ L.pop pcs ]) then find_sat_pc pcs - else true - in - (* Main concolic loop *) - let rec loop (c : config) = - iterations := !iterations + 1; - let { code; store; bp; pc; _ } = eval c in - List.iter - (fun bp -> - let pc = - match bp with Checkpoint cp -> !cp.pc | Branchpoint (pc, _) -> pc - in - L.push pc wl) - bp; - match code with - | vs, { it = Interrupt i; at } :: _ -> - write_test_case ~witness:true (Store.to_json store); - Some (string_of_interruption i, at) - | vs, { it = Restart pc; _ } :: es -> - print_endline "--- attempting restart ---"; - iterations := !iterations - 1; - if Batch.check_sat solver [ pc ] then - loop (update c (vs, es) pc (Store.get_key_types store)) - else if L.is_empty wl || not (find_sat_pc wl) then None - else - let _, c' = clone c0 in - loop (s_reset c') - | _ -> - write_test_case (Store.to_json store); - if L.is_empty wl || not (find_sat_pc wl) then None - else - let _, c' = clone c0 in - loop (s_reset c') - in - let error = loop c in - error - - let p_invoke (c : config) (test_suite : string) : - (Expression.t, string * region) result = - let rec eval (c : config) : config = - match c.code with - | vs, [] -> c - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, { it = Restart pc; at } :: es -> - c (* TODO: probably need to change this *) - | vs, { it = Interrupt i; at } :: es -> c - | vs, es -> - let c' = S.step c in - eval c' - in - let c' = eval c in - let res = - match c'.code with - | vs, { it = Interrupt i; at } :: _ -> - write_test_case ~witness:true (Store.to_json c'.store); - Result.error (string_of_interruption i, at) - | _ -> - write_test_case (Store.to_json c'.store); - Result.ok c.pc - in - res -end - -module NoCheckpointStepper = ConcolicStepper (NoCheckpoint) -module FuncCheckpointStepper = ConcolicStepper (FuncCheckpoint) -module RandCheckpointStepper = ConcolicStepper (RandCheckpoint) -module DepthCheckpointStepper = ConcolicStepper (DepthCheckpoint) -module DFS = Guided_search (Stack) (NoCheckpointStepper) -module BFS = Guided_search (Queue) (NoCheckpointStepper) -module RND = Guided_search (RandArray) (NoCheckpointStepper) - -let exiter i : unit = - Batch.interrupt (); - let loop_time = Sys.time () -. !loop_start in - write_report None loop_time; - exit 0 - -let set_timeout (time_limit : int) : unit = - if time_limit > 0 then ( - Sys.(set_signal sigalrm (Signal_handle exiter)); - ignore (Unix.alarm time_limit)) - -let main (func : func_inst) (vs : value list) (inst : module_inst) - (mem0 : Heap.t) = - let open Interpreter in - set_timeout !Flags.timeout; - let test_suite = Filename.concat !Flags.output "test_suite" in - Io.safe_mkdir test_suite; - let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in - let glob = - Globals.of_seq - (Seq.mapi - (fun i a -> - let v = Global.load a in - ( Int32.of_int i, - (Evaluations.of_value v, Val (Num (Evaluations.of_value v))) )) - (List.to_seq inst.globals)) - in - let c = - config empty_module_inst (List.rev vs) - [ Invoke func @@ at ] - mem0 glob (ref head) - in - let invoke = - match parse_policy !Flags.policy with - | None -> Crash.error at ("invalid search policy '" ^ !Flags.policy ^ "'") - | Some Depth -> DFS.invoke - | Some Breadth -> BFS.invoke - | Some Random -> RND.invoke - in - (if !Interpreter.Flags.log then - let get_finished () : int = !iterations in - logger logs get_finished exiter loop_start); - loop_start := Sys.time (); - let error = invoke c test_suite in - write_report error (Sys.time () -. !loop_start) - -let i32 (v : Interpreter.Values.value) at = - match v with - | Interpreter.Values.I32 i -> i - | _ -> Crash.error at "type error: i32 value expected" - -let create_func (inst : module_inst) (f : func) : func_inst = - Interpreter.Func.alloc (type_ inst f.it.ftype) (ref inst) f - -let create_table (inst : module_inst) (tab : table) : table_inst = - let { ttype } = tab.it in - Interpreter.Table.alloc ttype - -let create_memory (inst : module_inst) (mem : memory) : memory_inst = - let { mtype } = mem.it in - Interpreter.Memory.alloc mtype - -let create_global (inst : module_inst) (glob : global) : global_inst = - let { gtype; value } = glob.it in - let v = Interpreter.Eval.eval_const inst value in - Interpreter.Global.alloc gtype v - -let create_export (inst : module_inst) (ex : export) : export_inst = - let { name; edesc } = ex.it in - let ext = - match edesc.it with - | FuncExport x -> ExternFunc (func inst x) - | TableExport x -> ExternTable (table inst x) - | MemoryExport x -> ExternMemory (memory inst x) - | GlobalExport x -> ExternGlobal (global inst x) - in - (name, ext) - -let init_func (inst : module_inst) (func : func_inst) = - match func with - | Interpreter.Func.AstFunc (_, inst_ref, _) -> inst_ref := inst - | _ -> assert false - -let init_table (inst : module_inst) (seg : table_segment) = - let open Interpreter in - let { index; offset = const; init } = seg.it in - let tab = table inst index in - let offset = i32 (Eval.eval_const inst const) const.at in - let end_ = Int32.(add offset (of_int (List.length init))) in - let bound = Table.size tab in - if I32.lt_u bound end_ || I32.lt_u end_ offset then - Link.error seg.at "elements segment does not fit table"; - fun () -> - Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init) - -let init_memory (inst : module_inst) (sym_mem : Heap.t) (seg : memory_segment) = - let open Interpreter in - let { index; offset = const; init } = seg.it in - let mem = memory inst index in - let offset' = i32 (Eval.eval_const inst const) const.at in - let offset = I64_convert.extend_i32_u offset' in - let end_ = Int64.(add offset (of_int (String.length init))) in - let bound = Memory.bound mem in - if I64.lt_u bound end_ || I64.lt_u end_ offset then - Link.error seg.at "data segment does not fit memory"; - fun () -> Heap.store_bytes sym_mem offset init - -let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : - module_inst = - let open Interpreter in - if not (Types.match_extern_type (extern_type_of ext) (import_type m im)) then - Link.error im.at "incompatible import type"; - match ext with - | ExternFunc func -> { inst with funcs = func :: inst.funcs } - | ExternTable tab -> { inst with tables = tab :: inst.tables } - | ExternMemory mem -> { inst with memories = mem :: inst.memories } - | ExternGlobal glob -> { inst with globals = glob :: inst.globals } - -let init (m : module_) (exts : extern list) = - let open Interpreter in - let { - imports; - tables; - memories; - globals; - funcs; - types; - exports; - elems; - data; - start; - } = - m.it - in - if List.length exts <> List.length imports then - Link.error m.at "wrong number of imports provided for initialisation"; - let inst0 = - { - (List.fold_right2 (add_import m) exts imports empty_module_inst) with - types = List.map (fun type_ -> type_.it) types; - } - in - let fs = List.map (create_func inst0) funcs in - let inst1 = - { - inst0 with - funcs = inst0.funcs @ fs; - tables = inst0.tables @ List.map (create_table inst0) tables; - memories = inst0.memories @ List.map (create_memory inst0) memories; - globals = inst0.globals @ List.map (create_global inst0) globals; - } - in - let inst = { inst1 with exports = List.map (create_export inst1) exports } in - List.iter (init_func inst) fs; - let init_elems = List.map (init_table inst) elems in - let memory = Heap.alloc Flags.hashtbl_default_size in - let init_datas = List.map (init_memory inst memory) data in - List.iter (fun f -> f ()) init_elems; - List.iter (fun f -> f ()) init_datas; - Lib.Option.app (fun x -> ignore (main (func inst x) [] inst memory)) start; - (memory, inst) diff --git a/wasp/lib/symbolic/concolic/evaluations.ml b/wasp/lib/symbolic/concolic/evaluations.ml deleted file mode 100644 index f77fcaaa..00000000 --- a/wasp/lib/symbolic/concolic/evaluations.ml +++ /dev/null @@ -1,106 +0,0 @@ -open Common.Evaluations -open Encoding -open Value -open Expression -open Types -open I64 -open Interpreter.Ast - -(* Evaluate a unary operation *) -let eval_unop (e : Num.t * expr) (op : Interpreter.Ast.unop) : Num.t * expr = - let c, s = e in - let c' = of_value (Interpreter.Eval_numeric.eval_unop op (to_value c)) in - let s' = - match s with - | Val (Num _) -> Val (Num c') - | _ -> ( - let (* dispatch *) - open Interpreter in - match op with - | Values.F32 x -> f32_unop x s - | Values.F64 x -> f64_unop x s - | Values.I32 _ | Values.I64 _ -> raise (UnsupportedOp "eval_unop: ints") - ) - in - (c', s') - -(* Evaluate a binary operation *) -let eval_binop (e1 : Num.t * t) (e2 : Num.t * t) (op : Interpreter.Ast.binop) : - Num.t * t = - let c1, s1 = e1 and c2, s2 = e2 in - let c = - of_value - (Interpreter.Eval_numeric.eval_binop op (to_value c1) (to_value c2)) - in - let s = - match (s1, s2) with - | Val (Num _), Val (Num _) -> Val (Num c) - | _ -> ( - let (* dispatch *) - open Interpreter in - match op with - | Values.I32 x -> i32_binop x s1 s2 - | Values.I64 x -> i64_binop x s1 s2 - | Values.F32 x -> f32_binop x s1 s2 - | Values.F64 x -> f64_binop x s1 s2) - in - (c, s) - -(* Evaluate a test operation *) -let eval_testop (e : Num.t * t) (op : testop) : Num.t * t = - let c, s = e in - let c' = - Num.num_of_bool (Interpreter.Eval_numeric.eval_testop op (to_value c)) - in - let s' = - match s with - | Val (Num _) -> Val (Num c') - | SymPtr (b, Val (Num _)) -> Val (Num c') - | _ -> ( - match op with - | Interpreter.Values.I32 I32Op.Eqz -> - Relop (I32 Eq, s, Val (Num (I32 0l))) - | Interpreter.Values.I64 I64Op.Eqz -> - Relop (I64 Eq, s, Val (Num (I64 0L))) - | _ -> failwith "eval_testop: floats") - in - (c', s') - -(* Evaluate a relative operation *) -let eval_relop (e1 : Num.t * t) (e2 : Num.t * t) (op : Interpreter.Ast.relop) : - Num.t * t = - let c1, s1 = e1 and c2, s2 = e2 in - let c = - Num.num_of_bool - (Interpreter.Eval_numeric.eval_relop op (to_value c1) (to_value c2)) - in - let s = - match (s1, s2) with - | Val (Num _), Val (Num _) -> Val (Num c) - | _ -> ( - let (* dispatch *) - open Interpreter in - match op with - | Values.I32 x -> i32_relop x s1 s2 - | Values.I64 x -> i64_relop x s1 s2 - | Values.F32 x -> f32_relop x s1 s2 - | Values.F64 x -> f64_relop x s1 s2) - in - (c, s) - -let eval_cvtop (op : Interpreter.Ast.cvtop) (e : Num.t * t) : Num.t * t = - let c, s = e in - let c = of_value (Interpreter.Eval_numeric.eval_cvtop op (to_value c)) in - let s = - match s with - | Val (Num _) -> Val (Num c) - | _ -> ( - let (* dispatch cvtop func *) - open Interpreter in - match op with - | Values.I32 x -> i32_cvtop x s - | Values.I64 x -> i64_cvtop x s - | Values.F32 x -> f32_cvtop x s - | Values.F64 x -> f64_cvtop x s) - in - (c, s) diff --git a/wasp/lib/symbolic/concolic/execution_tree.ml b/wasp/lib/symbolic/concolic/execution_tree.ml deleted file mode 100644 index c4ffbaff..00000000 --- a/wasp/lib/symbolic/concolic/execution_tree.ml +++ /dev/null @@ -1,50 +0,0 @@ -type 'a t = Leaf | Node of 'a parent * 'a option * 'a left * 'a right -and 'a parent = 'a t ref option -and 'a left = 'a t ref -and 'a right = 'a t ref - -exception Invalid_branch - -let is_leaf (t : 'a t ref) : bool = match !t with Leaf -> true | _ -> false -let is_node (t : 'a t ref) : bool = not (is_leaf t) - -let can_branch (t : 'a t ref) : bool = - match !t with - | Leaf -> true - | Node (_, _, l, r) -> ( - match (!l, !r) with Leaf, Leaf -> true | _ -> false) - -let rec update_node (t : 'a t ref) (v : 'a) : unit = - match !t with - | Leaf -> () - | Node (p, _, l, r) -> - update_node l v; - update_node r v; - t := Node (p, Some v, l, r) - -let find (t : 'a t ref) : 'a option = - match !t with Leaf -> None | Node (_, v, _, _) -> v - -let move_true (t : 'a t ref) : 'a left * bool = - match !t with - | Leaf -> - let l = ref (Node (Some t, None, ref Leaf, ref Leaf)) - and r = ref (Node (Some t, None, ref Leaf, ref Leaf)) in - t := Node (None, None, l, r); - (l, true) - | Node (parent, v, l, r) -> - let b = can_branch t in - if is_leaf l then l := Node (Some t, v, ref Leaf, ref Leaf); - (l, b) - -let move_false (t : 'a t ref) : 'a right * bool = - match !t with - | Leaf -> - let l = ref (Node (Some t, None, ref Leaf, ref Leaf)) - and r = ref (Node (Some t, None, ref Leaf, ref Leaf)) in - t := Node (None, None, l, r); - (r, true) - | Node (parent, v, l, r) -> - let b = can_branch t in - if is_leaf r then r := Node (Some t, v, ref Leaf, ref Leaf); - (r, b) diff --git a/wasp/lib/symbolic/concolic/heap.ml b/wasp/lib/symbolic/concolic/heap.ml deleted file mode 100644 index d23cd06b..00000000 --- a/wasp/lib/symbolic/concolic/heap.ml +++ /dev/null @@ -1,264 +0,0 @@ -open Encoding -open Value -open Types -open Expression -open Interpreter.Memory - -type size = int32 -type address = int64 -type offset = int32 -type store = int * Expression.t -type memory = (address, store) Hashtbl.t -type t = { map : memory; parent : t option } - -exception Bounds -exception InvalidAddress of address - -let packed_size = function Pack8 -> 1 | Pack16 -> 2 | Pack32 -> 4 -let alloc (sz : int) : t = { map = Hashtbl.create sz; parent = None } - -let size (h : t) : int = - let rec size' accum = function - | None -> accum - | Some h' -> size' (Hashtbl.length h'.map + accum) h'.parent - in - size' (Hashtbl.length h.map) h.parent - -let memcpy (h : t) : t = { map = Hashtbl.copy h.map; parent = h.parent } - -let to_seq (h : t) : (address * store) Seq.t = - let rec to_seq' (acc : (address * store) Seq.t) = function - | None -> acc - | Some h' -> to_seq' (Seq.append (Hashtbl.to_seq h'.map) acc) h'.parent - in - to_seq' (Hashtbl.to_seq h.map) h.parent - -let clone (h : t) : t * t = - ( { - map = Hashtbl.create Interpreter.Flags.hashtbl_default_size; - parent = Some h; - }, - { - map = Hashtbl.create Interpreter.Flags.hashtbl_default_size; - parent = Some h; - } ) - -let add_seq (h : t) (l : (address * store) Seq.t) : unit = - Seq.iter (fun (a, s) -> Hashtbl.replace h.map a s) l - -let to_list (h : t) : (address * store) list = - Hashtbl.fold (fun a s acc -> (a, s) :: acc) h.map [] - -let to_string (mem : t) : string = - let lst = List.sort (fun (a, _) (b, _) -> compare a b) (to_list mem) in - List.fold_right - (fun (a, (v, e)) b -> - "(" ^ Int64.to_string a ^ "->" ^ "(" ^ string_of_int v ^ ", " - ^ Expression.to_string e ^ ")" ^ ")\n" ^ b) - lst "" - -let store_byte (h : t) (a : address) (b : store) : unit = - Hashtbl.replace h.map a b - -let load_byte (h : t) (a : address) : store = - let rec load_byte' heap = - match Hashtbl.find_opt heap.map a with - | Some b -> Some b - | None -> Option.bind heap.parent load_byte' - in - match Hashtbl.find_opt h.map a with - | Some b -> b - | None -> ( - match Option.bind h.parent load_byte' with - | Some b -> b - | None -> (0, Extract (Val (Num (I64 0L)), 1, 0))) - -let concat bs = List.(fold_left (fun acc e -> e ++ acc) (hd bs) (tl bs)) - -let load_bytes (h : t) (a : address) (n : int) : string * Expression.t = - let buf = Buffer.create n in - let rec rec_loop i acc = - if i = n - 1 then acc - else - let chr, schr = load_byte h Int64.(add a (of_int i)) in - Buffer.add_char buf (Char.chr chr); - rec_loop (i + 1) (schr :: acc) - in - let schrs = simplify (concat (rec_loop 0 [])) in - (Buffer.contents buf, schrs) - -let load_string (h : t) (a : address) : string = - let rec loop a acc = - let c, _ = load_byte h a in - if c = 0 then acc else loop (Int64.add a 1L) (acc ^ Char.(escaped (chr c))) - in - loop a "" - -let store_bytes (h : t) (a : address) (bs : string) : unit = - for i = String.length bs - 1 downto 0 do - let b = Char.code bs.[i] in - let sb = Extract (Val (Num (I64 (Int64.of_int b))), 1, 0) in - store_byte h Int64.(add a (of_int i)) (b, sb) - done - -let effective_address (a : Int64.t) (o : offset) : address = - let ea = Int64.(add a (of_int32 o)) in - if Eval_numeric.eval_relop (I64 I64.LtU) (I64 ea) (I64 a) then raise Bounds; - ea - -let loadn (h : t) (a : address) (o : offset) (n : int) = - assert (n > 0 && n <= 8); - let rec loop a n acc = - if n = 0 then acc - else - let x, lacc = acc and cv, se = load_byte h a in - let x' = Int64.(logor (of_int cv) (shift_left x 8)) in - loop (Int64.sub a 1L) (n - 1) (x', se :: lacc) - in - loop Int64.(add (effective_address a o) (of_int (n - 1))) n (0L, []) - -let storen (h : t) (a : address) (o : offset) (n : int) - (x : int64 * Expression.t) : unit = - assert (n > 0 && n <= 8); - let rec loop a i n x = - if n > i then ( - let cv, se = x in - let b = Int64.to_int cv land 0xff in - store_byte h a (b, Extract (se, i + 1, i)); - loop (Int64.add a 1L) (i + 1) n (Int64.shift_right cv 8, se)) - in - loop (effective_address a o) 0 n x - -let load_value (h : t) (a : address) (o : offset) (t : num_type) : - Num.t * Expression.t = - let n, exprs = loadn h a o (Types.size_of_num_type t) in - let expr = simplify ~extract:true (simplify (concat exprs)) in - let (n' : Num.t), (expr' : Expression.t) = - match t with - | `I32Type -> - let e = - match expr with - | Val (Num (I64 n)) -> Val (Num (I32 (Int64.to_int32 n))) - | _ -> expr - in - (I32 (Int64.to_int32 n), e) - | `I64Type -> (I64 n, expr) - | `F32Type -> - let e = - match expr with - | Val (Num (I64 v)) -> Val (Num (F32 (Int64.to_int32 v))) - | Cvtop (I32 I32.ReinterpretFloat, v) -> v - | _ -> Cvtop (F32 F32.ReinterpretInt, expr) - in - (F32 (Int64.to_int32 n), e) - | `F64Type -> - let e = - match expr with - | Val (Num (I64 n)) -> Val (Num (F64 n)) - | Cvtop (I64 I64.ReinterpretFloat, v) -> v - | _ -> Cvtop (F64 F64.ReinterpretInt, expr) - in - (F64 n, e) - in - (n', expr') - -let store_value (h : t) (a : address) (o : offset) (v : Num.t * Expression.t) : - unit = - let cv, sv = v in - let cv', (sv' : Expression.t) = - match cv with - | I32 x -> - let e = - match sv with - | Val (Num (I32 x)) -> Val (Num (I64 (Int64.of_int32 x))) - | _ -> sv - in - (Int64.of_int32 x, e) - | I64 x -> (x, sv) - | F32 x -> - let e = - match sv with - | Val (Num (F32 n)) -> Val (Num (I64 (Int64.of_int32 n))) - | _ -> Cvtop (I32 I32.ReinterpretFloat, sv) - in - (Int64.of_int32 x, e) - | F64 x -> - let e = - match sv with - | Val (Num (F64 x)) -> Val (Num (I64 x)) - | _ -> Cvtop (I64 I64.ReinterpretFloat, sv) - in - (x, e) - in - storen h a o (Types.size (Num.type_of cv)) (cv', sv') - -let extend x n = function - | ZX -> x - | SX -> - let sh = 64 - (8 * n) in - Int64.(shift_right (shift_left x sh) sh) - -let load_packed (sz : pack_size) (ext : extension) (h : t) (a : address) - (o : offset) (t : num_type) : Num.t * Expression.t = - let n = packed_size sz in - let cv, sv = loadn h a o n in - let cv = extend cv n ext in - let x' : Num.t = - match t with - | `I32Type -> I32 (Int64.to_int32 cv) - | `I64Type -> I64 cv - | _ -> raise Type - in - let sv' : Expression.t = - match simplify ~extract:true (simplify (concat sv)) with - | Val (Num (I64 x)) -> ( - match t with - | `I32Type -> Val (Num (I32 (Int64.to_int32 x))) - | _ -> Val (Num (I64 x))) - | SymPtr (b, o) -> SymPtr (b, o) - | _ -> - let rec loop acc i = - if i >= Types.size_of_num_type t then acc - else loop (acc @ [ Extract (Val (Num (I64 0L)), 1, 0) ]) (i + 1) - in - concat (loop sv (List.length sv)) - in - (x', sv') - -let store_packed (sz : pack_size) (h : t) (a : address) (o : offset) - (v : Num.t * Expression.t) : unit = - let n = packed_size sz in - let cv, sv = v in - let x = - match cv with I32 x -> Int64.of_int32 x | I64 x -> x | _ -> raise Type - in - let sx : Expression.t = - match sv with - | Val (Num (I32 x)) -> Val (Num (I64 (Int64.of_int32 x))) - | Val (Num (I64 x)) -> Val (Num (I64 x)) - | _ -> sv - in - storen h a o n (x, sx) - -let update (h : t) (store : Store.t) : unit = - let eval_heap heap sto = - Hashtbl.iter - (fun a (_, se) -> - let i = - match Store.eval store se with - | I32 x -> Int32.to_int x - | I64 x -> Int64.to_int x - | F32 x -> Int32.to_int x - | F64 x -> Int64.to_int x - in - store_byte heap a (i, se)) - heap.map - in - let rec update' = function - | None -> () - | Some h' -> - eval_heap h' store; - update' h'.parent - in - eval_heap h store; - update' h.parent diff --git a/wasp/lib/symbolic/concolic/store.ml b/wasp/lib/symbolic/concolic/store.ml deleted file mode 100644 index 2d4028d2..00000000 --- a/wasp/lib/symbolic/concolic/store.ml +++ /dev/null @@ -1,197 +0,0 @@ -open Common -open Encoding -open Encoding.Types -open Encoding.Expression - -type name = string -type bind = name * Num.t - -type store = { - sym : name Counter.t; - ord : name Stack.t; - map : (name, Num.t) Hashtbl.t; -} - -type t = store - -let reset (s : t) : unit = - Counter.clear s.sym; - Hashtbl.clear s.map; - Stack.clear s.ord - -let copy (s : t) : t = - let sym = Counter.copy s.sym - and ord = Stack.copy s.ord - and map = Hashtbl.copy s.map in - { sym; ord; map } - -let clear (s : t) : unit = Hashtbl.clear s.map - -let init (s : t) (binds : (Symbol.t * Value.t) list) : unit = - List.iter - (fun (x, v) -> - match v with - | Value.Num n -> Hashtbl.replace s.map (Symbol.to_string x) n - | _ -> assert false) - binds - -let from_parts (sym : name Counter.t) (ord : name Stack.t) - (map : (name, Num.t) Hashtbl.t) : t = - { sym; ord; map } - -let create (binds : (Symbol.t * Value.t) list) : t = - let s = - { - sym = Counter.create (); - ord = Stack.create (); - map = Hashtbl.create Interpreter.Flags.hashtbl_default_size; - } - in - init s binds; - s - -let add (s : t) (x : name) (v : Num.t) : unit = - Stack.push x s.ord; - Hashtbl.replace s.map x v - -let find (s : t) (x : name) : Num.t = Hashtbl.find s.map x -let find_opt (s : t) (x : name) : Num.t option = Hashtbl.find_opt s.map x -let exists (s : t) (x : name) : bool = Hashtbl.mem s.map x - -let get (s : t) (x : name) (ty : expr_type) (b : bool) : Num.t = - let v = - match find_opt s x with - | Some v -> v - | None -> ( - match ty with - | `I32Type -> I32 (Int32.of_int (Random.int (if b then 2 else 127))) - | `I64Type -> I64 (Int64.of_int (Random.int 127)) - | `F32Type -> F32 (Int32.bits_of_float (Random.float 127.0)) - | `F64Type -> F64 (Int64.bits_of_float (Random.float 127.0)) - | _ -> assert false) - in - add s x v; - v - -let next (s : t) (x : name) : name = - let id = Counter.get_and_inc s.sym x in - if id = 0 then x else x ^ "_" ^ string_of_int id - -let is_empty (s : t) : bool = 0 = Hashtbl.length s.map - -let update (s : t) (binds : (Symbol.t * Value.t) list) : unit = - List.iter - (fun (x, v) -> - match v with - | Value.Num n -> Hashtbl.replace s.map (Symbol.to_string x) n - | _ -> assert false) - binds - -let to_json (s : t) : string = - let jsonify_bind (b : bind) : string = - let n, v = b in - "{" ^ "\"name\" : \"" ^ n ^ "\", " ^ "\"value\" : \"" ^ Num.to_string v - ^ "\", " ^ "\"type\" : \"" - ^ Types.string_of_type (Num.type_of v) - ^ "\"" ^ "}" - in - "[" - ^ String.concat "," - (Seq.fold_left - (fun a x -> jsonify_bind (x, find s x) :: a) - [] (Stack.to_seq s.ord)) - ^ "]" - -let strings_to_json string_env : string = - let jsonify_bind b : string = - let t, x, v = b in - "{" ^ "\"name\" : \"" ^ x ^ "\", " ^ "\"value\" : \"" ^ v ^ "\", " - ^ "\"type\" : \"" ^ t ^ "\"" ^ "}" - in - "[" ^ String.concat ", " (List.map jsonify_bind string_env) ^ "]" - -let to_string (s : t) : string = - Seq.fold_left - (fun a k -> - let v = find s k in - a ^ "(" ^ k ^ "->" ^ Num.to_string v ^ ")\n") - "" (Stack.to_seq s.ord) - -let get_key_types (s : t) : Symbol.t list = - Hashtbl.fold - (fun k v acc -> Symbol.mk_symbol (Num.type_of v) k :: acc) - s.map [] - -let to_expr (s : t) : expr list = - Hashtbl.fold - (fun k (n : Num.t) acc -> - let e = - match n with - | I32 _ -> - BitVector.mk_eq (mk_symbol_s `I32Type k) (Val (Value.Num n)) - `I32Type - | I64 _ -> - BitVector.mk_eq (mk_symbol_s `I64Type k) (Val (Value.Num n)) - `I64Type - | F32 _ -> - FloatingPoint.mk_eq (mk_symbol_s `F32Type k) (Val (Value.Num n)) - `F32Type - | F64 _ -> - FloatingPoint.mk_eq (mk_symbol_s `F64Type k) (Val (Value.Num n)) - `F64Type - in - e :: acc) - s.map [] - -let int64_of_value (v : Num.t) : int64 = - match v with I32 i | F32 i -> Int64.of_int32 i | I64 i | F64 i -> i - -let rec eval (env : t) (e : expr) : Num.t = - match simplify e with - | SymPtr (b, o) -> - let b : Num.t = I32 b in - Eval_numeric.eval_binop (I32 I32.Add) b (eval env o) - | Val (Value.Num n) -> n - | Binop (op, e1, e2) -> - let v1 = eval env e1 and v2 = eval env e2 in - Eval_numeric.eval_binop op v1 v2 - | Unop (op, e') -> - let v = eval env e' in - Eval_numeric.eval_unop op v - | Relop (op, e1, e2) -> - let v1 = eval env e1 and v2 = eval env e2 in - Num.num_of_bool (Eval_numeric.eval_relop op v1 v2) - | Cvtop (op, e') -> - let v = eval env e' in - Eval_numeric.eval_cvtop op v - | Symbol s -> ( - let x = Symbol.to_string s in - match find_opt env x with - | Some v -> v - | None -> - let v : Num.t = - match Symbol.type_of s with - | `I32Type -> I32 (Int32.of_int (Random.int 127)) - | `I64Type -> I64 (Int64.of_int (Random.int 127)) - | `F32Type -> F32 (Int32.bits_of_float (Random.float 127.0)) - | `F64Type -> F64 (Int64.bits_of_float (Random.float 127.0)) - | _ -> assert false - in - Hashtbl.replace env.map x v; - v) - | Extract (e', h, l) -> - let v = int64_of_value (eval env e') in - I64 (nland64 (Int64.shift_right v (l * 8)) (h - l)) - | Concat (e1, e2) -> ( - let v1 = int64_of_value (eval env e1) - and v2 = int64_of_value (eval env e2) in - match (e1, e2) with - | Extract (_, h1, l1), Extract (_, h2, l2) -> - let i = - Int64.(logor (shift_left v1 (l1 * 8)) (shift_left v2 (l2 * 8))) - in - if h1 - l2 + (h2 - l2) = 4 then I32 (Int64.to_int32 i) else I64 i - | Extract (_, h, l), Concat _ -> - I64 Int64.(logor (shift_left v1 (l * 8)) v2) - | _ -> assert false) - | Val _ | Triop _ | Quantifier _ -> assert false diff --git a/wasp/lib/symbolic/static/dune b/wasp/lib/symbolic/static/dune deleted file mode 100644 index f190e859..00000000 --- a/wasp/lib/symbolic/static/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name static) - (libraries interpreter common encoding concolic)) diff --git a/waspc.opam b/waspc.opam deleted file mode 100644 index b9fbdb6f..00000000 --- a/waspc.opam +++ /dev/null @@ -1,33 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "" -description: "" -maintainer: ["WASP Platform"] -authors: ["WASP Platform"] -license: "LICENSE" -homepage: "https://github.com/wasp-platform/wasp" -bug-reports: "https://github.com/wasp-platform/wasp/issues" -depends: [ - "ocaml" - "dune" {>= "3.0"} - "re2" - "bos" - "pyml" - "cmdliner" - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/wasp-platform/wasp.git" diff --git a/waspc/bin/dune b/waspc/bin/dune index 131a6c51..89e9c8ea 100644 --- a/waspc/bin/dune +++ b/waspc/bin/dune @@ -1,11 +1,11 @@ -(executable - (package waspc) - (public_name waspc) - (name main) - (libraries - wasp - waspc - re2 - bos - pyml - cmdliner)) +; (executable +; (package waspc) +; (public_name waspc) +; (name main) +; (libraries +; wasp +; waspc +; re2 +; bos +; pyml +; cmdliner)) diff --git a/waspc/dune b/waspc/dune deleted file mode 100644 index e69de29b..00000000 From faa79df68bd268dac70240e1b1918a996a112b58 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Fri, 23 Aug 2024 11:39:29 +0200 Subject: [PATCH 2/8] Delete unecessary stuff --- .gitignore | 4 ---- env.sh | 1 - 2 files changed, 5 deletions(-) delete mode 100755 env.sh diff --git a/.gitignore b/.gitignore index 5803988b..2dc2e8bd 100644 --- a/.gitignore +++ b/.gitignore @@ -27,9 +27,5 @@ result .DS_Store nix/profiles/ -# dkml desktop CI -/msys64 -/.ci - **/wasp-out/ bin/libc.wasm diff --git a/env.sh b/env.sh deleted file mode 100755 index 0ca0b24d..00000000 --- a/env.sh +++ /dev/null @@ -1 +0,0 @@ -export PATH="$PWD"/bin From 545058ab30a58fd88bd4e5cdd16c2deb871cf099 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Fri, 23 Aug 2024 11:47:18 +0200 Subject: [PATCH 3/8] Add build.yml workflow --- .github/workflows/build.yml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 .github/workflows/build.yml diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 00000000..0905b834 --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,34 @@ +name: Build + +on: + push: + branches: main + pull_request: + branches: main + +jobs: + build: + strategy: + fail-fast: false + runs-on: ubuntu-latest + env: + # allow opam depext to yes package manager prompts + OPAMCONFIRMLEVEL: unsafe-yes + steps: + - name: Checkout + uses: actions/checkout@v4 + + - name: Setup OCaml 4.14 + uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: 4.14 + dune-cache: true + + - name: Install dependencies + run: opam install -y . --deps-only --with-test + + - name: Build + run: opam exec -- dune build @install + + - name: Test + run: opam exec -- dune runtest From c059b1546084faee617b21e77b6d8c90686fc794 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Sat, 24 Aug 2024 09:40:16 +0200 Subject: [PATCH 4/8] Fmt --- src/common/bug.ml | 5 +- src/common/chunktable.ml | 23 +- src/common/common.ml | 27 ++- src/common/counter.ml | 5 +- src/common/evaluations.ml | 2 +- src/common/globals.ml | 5 + src/common/globals.mli | 6 + src/common/randArray.ml | 4 + src/concolic/execution_tree.mli | 13 +- src/interpreter/binary/decode.ml | 221 ++++++++++--------- src/interpreter/binary/encode.ml | 270 ++++++++++++----------- src/interpreter/binary/encode.mli | 1 + src/interpreter/binary/utf8.ml | 21 +- src/interpreter/binary/utf8.mli | 1 + src/interpreter/exec/eval.ml | 4 +- src/interpreter/exec/eval.mli | 5 + src/interpreter/exec/eval_numeric.ml | 6 + src/interpreter/exec/eval_numeric.mli | 4 + src/interpreter/exec/f32.ml | 4 + src/interpreter/exec/f32_convert.ml | 6 +- src/interpreter/exec/f32_convert.mli | 5 + src/interpreter/exec/f64.ml | 4 + src/interpreter/exec/f64_convert.ml | 2 +- src/interpreter/exec/f64_convert.mli | 5 + src/interpreter/exec/float.ml | 83 ++++++- src/interpreter/exec/i32_convert.mli | 5 + src/interpreter/exec/i64_convert.ml | 9 +- src/interpreter/exec/i64_convert.mli | 6 + src/interpreter/exec/int.ml | 92 +++++++- src/interpreter/exec/numeric_error.ml | 2 + src/interpreter/host/env.ml | 4 +- src/interpreter/host/spectest.ml | 6 +- src/interpreter/main/flags.ml | 19 ++ src/interpreter/runtime/func.ml | 2 + src/interpreter/runtime/func.mli | 3 + src/interpreter/runtime/global.ml | 9 +- src/interpreter/runtime/global.mli | 8 + src/interpreter/runtime/instance.ml | 33 +-- src/interpreter/runtime/memory.ml | 35 ++- src/interpreter/runtime/memory.mli | 29 ++- src/interpreter/runtime/table.ml | 17 +- src/interpreter/runtime/table.mli | 13 ++ src/interpreter/script/import.ml | 5 +- src/interpreter/script/import.mli | 6 +- src/interpreter/script/js.ml | 180 ++++++++-------- src/interpreter/script/run.ml | 278 ++++++++++++------------ src/interpreter/script/run.mli | 5 + src/interpreter/script/script.ml | 11 +- src/interpreter/syntax/ast.ml | 167 +++++++++----- src/interpreter/syntax/operators.ml | 173 +++++++++++++++ src/interpreter/syntax/types.ml | 23 +- src/interpreter/syntax/values.ml | 5 + src/interpreter/text/arrange.mli | 3 + src/interpreter/text/lexer.mli | 1 + src/interpreter/text/parse.ml | 6 +- src/interpreter/text/parse.mli | 2 + src/interpreter/text/print.ml | 2 + src/interpreter/text/print.mli | 2 + src/interpreter/util/error.ml | 1 + src/interpreter/util/error.mli | 1 + src/interpreter/util/lib.ml | 19 +- src/interpreter/util/lib.mli | 29 +++ src/interpreter/util/sexpr.ml | 32 +-- src/interpreter/util/sexpr.mli | 6 +- src/interpreter/util/source.ml | 19 +- src/interpreter/util/source.mli | 23 +- src/interpreter/valid/valid.ml | 299 ++++++++++++++------------ waspc/lib/instrumentor.ml | 4 +- 68 files changed, 1569 insertions(+), 757 deletions(-) diff --git a/src/common/bug.ml b/src/common/bug.ml index 6b621f5f..578a0990 100644 --- a/src/common/bug.ml +++ b/src/common/bug.ml @@ -1,4 +1,7 @@ -type bug = Overflow | UAF | InvalidFree +type bug = + | Overflow + | UAF + | InvalidFree exception BugException of bug * Interpreter.Source.region * string diff --git a/src/common/chunktable.ml b/src/common/chunktable.ml index 8c2f2734..b3190b2d 100644 --- a/src/common/chunktable.ml +++ b/src/common/chunktable.ml @@ -7,25 +7,30 @@ let replace (ct : t) (address : int32) (size : int32) = Hashtbl.replace ct address size let copy (ct : t) = Hashtbl.copy ct + let create () = Hashtbl.create Interpreter.Flags.hashtbl_default_size + let find (ct : t) (low : int32) = Hashtbl.find ct low + let find_opt (ct : t) (low : int32) = Hashtbl.find_opt ct low + let mem (ct : t) (base : int32) = Hashtbl.mem ct base + let remove (ct : t) (base : int32) = Hashtbl.remove ct base let check_access (ct : t) (base_ptr : int32) (ptr : Num.t) (offset : int32) = let low = base_ptr in match find_opt ct low with | Some chunk_size -> - let high = Int64.(add (of_int32 low) (of_int32 chunk_size)) in - let ptr_i64 = - Int64.of_int32 - (Interpreter.Values.I32Value.of_value (Evaluations.to_value ptr)) - in - let ptr_val = Int64.(add ptr_i64 (of_int32 offset)) in - (* ptr_val \notin [low, high[ => overflow *) - if ptr_val < Int64.of_int32 low || ptr_val >= high then Some Overflow - else None + let high = Int64.(add (of_int32 low) (of_int32 chunk_size)) in + let ptr_i64 = + Int64.of_int32 + (Interpreter.Values.I32Value.of_value (Evaluations.to_value ptr)) + in + let ptr_val = Int64.(add ptr_i64 (of_int32 offset)) in + (* ptr_val \notin [low, high[ => overflow *) + if ptr_val < Int64.of_int32 low || ptr_val >= high then Some Overflow + else None | None -> Some UAF let alloc (ct : t) (base : int32) (sz : int32) = replace ct base sz diff --git a/src/common/common.ml b/src/common/common.ml index 5cde95f3..cbd2a38e 100644 --- a/src/common/common.ml +++ b/src/common/common.ml @@ -10,8 +10,11 @@ module Crash = Interpreter.Error.Make () module Exhaustion = Interpreter.Error.Make () exception Link = Link.Error + exception Trap = Trap.Error + exception Crash = Crash.Error + exception Exhaustion = Exhaustion.Error module type WorkList = sig @@ -20,10 +23,15 @@ module type WorkList = sig exception Empty val create : unit -> 'a t + val push : 'a -> 'a t -> unit + val pop : 'a t -> 'a + val add_seq : 'a t -> 'a Seq.t -> unit + val is_empty : 'a t -> bool + val length : 'a t -> int end @@ -53,14 +61,13 @@ let numeric_error at = function | Interpreter.Numeric_error.IntegerOverflow -> "integer overflow" | Interpreter.Numeric_error.IntegerDivideByZero -> "integer divide by zero" | Interpreter.Numeric_error.InvalidConversionToInteger -> - "invalid conversion to integer" + "invalid conversion to integer" | Interpreter.Eval_numeric.TypeError (i, v, t) -> - Crash.error at - ("type error, expected " - ^ Interpreter.Types.string_of_value_type t - ^ " as operand " ^ string_of_int i ^ ", got " - ^ Interpreter.Types.string_of_value_type (Interpreter.Values.type_of v) - ) + Crash.error at + ( "type error, expected " + ^ Interpreter.Types.string_of_value_type t + ^ " as operand " ^ string_of_int i ^ ", got " + ^ Interpreter.Types.string_of_value_type (Interpreter.Values.type_of v) ) | exn -> raise exn let print_logs (logs : (int * int * int) list) : unit = @@ -80,7 +87,7 @@ let print_logs (logs : (int * int * int) list) : unit = Interpreter.Io.save_file log_file logs_string let logger (logs : (int * int * int) list ref) (get_finished : unit -> int) - (exiter : int -> unit) (loop_start : float ref) : unit = + (exiter : int -> unit) (loop_start : float ref) : unit = let cnt = ref 1 in let log () : unit = let pcs = get_finished () in @@ -95,11 +102,11 @@ let logger (logs : (int * int * int) list ref) (get_finished : unit -> int) in let timeout = !Interpreter.Flags.timeout in let handler = - if timeout > 0 then (fun (_ : int) -> + if timeout > 0 then ( fun (_ : int) -> log (); if Sys.time () -. !loop_start >= Float.of_int timeout then ( print_logs !logs; - exiter 0)) + exiter 0 ) ) else fun (_ : int) -> log () in Sys.(set_signal sigalrm (Signal_handle handler)); diff --git a/src/common/counter.ml b/src/common/counter.ml index 524ca545..eb933edb 100644 --- a/src/common/counter.ml +++ b/src/common/counter.ml @@ -1,8 +1,11 @@ type count = int + type 'a t = ('a, count) Hashtbl.t let create () : 'a t = Hashtbl.create Interpreter.Flags.hashtbl_default_size + let clear (cnt : 'a t) : unit = Hashtbl.clear cnt + let copy (cnt : 'a t) : 'a t = Hashtbl.copy cnt let reset (cnt : 'a t) : unit = @@ -27,5 +30,5 @@ let to_string (cnt : 'a t) : string = Seq.fold_left (fun a b -> let k, c = b in - a ^ "(" ^ k ^ "-> cnt=" ^ string_of_int c ^ ")\n") + a ^ "(" ^ k ^ "-> cnt=" ^ string_of_int c ^ ")\n" ) "" (Hashtbl.to_seq cnt) diff --git a/src/common/evaluations.ml b/src/common/evaluations.ml index 25e0ab7f..86875ad7 100644 --- a/src/common/evaluations.ml +++ b/src/common/evaluations.ml @@ -165,7 +165,7 @@ let i32_cvtop op s = let i64_cvtop op s = match op with - | I64Op.ExtendSI32 -> cvtop (Ty_bitv 64) (Sign_extend 32) s + | I64Op.ExtendSI32 -> cvtop (Ty_bitv 64) (Sign_extend 32) s | I64Op.ExtendUI32 -> cvtop (Ty_bitv 64) (Zero_extend 32) s | I64Op.TruncSF32 -> cvtop (Ty_bitv 64) TruncSF32 s | I64Op.TruncUF32 -> cvtop (Ty_bitv 64) TruncUF32 s diff --git a/src/common/globals.ml b/src/common/globals.ml index 688d0bb7..f0849661 100644 --- a/src/common/globals.ml +++ b/src/common/globals.ml @@ -1,10 +1,15 @@ type 'a globals = (int32, 'a) Hashtbl.t + type 'a t = 'a globals let create () = Hashtbl.create Interpreter.Flags.hashtbl_default_size + let copy g = Hashtbl.copy g + let add g i v = Hashtbl.replace g i v + let find g i = Hashtbl.find g i + let to_seq g = Hashtbl.to_seq g let of_seq (seq : (int32 * 'a) Seq.t) : 'a t = diff --git a/src/common/globals.mli b/src/common/globals.mli index 64b924d2..22d51ff5 100644 --- a/src/common/globals.mli +++ b/src/common/globals.mli @@ -1,9 +1,15 @@ type 'a globals + type 'a t = 'a globals val create : unit -> 'a t + val copy : 'a t -> 'a t + val add : 'a t -> int32 -> 'a -> unit + val find : 'a t -> int32 -> 'a + val of_seq : (int32 * 'a) Seq.t -> 'a t + val convert : 'a t -> ('a -> 'b) -> 'b t diff --git a/src/common/randArray.ml b/src/common/randArray.ml index 875c3546..ea252fce 100644 --- a/src/common/randArray.ml +++ b/src/common/randArray.ml @@ -3,9 +3,13 @@ type 'a t = 'a BatDynArray.t exception Empty let create () = BatDynArray.create () + let is_empty a = BatDynArray.empty a + let push v a = BatDynArray.add a v + let add_seq (a : 'a t) (s : 'a Seq.t) : unit = Seq.iter (fun v -> push v a) s + let length = BatDynArray.length let pop (a : 'a t) : 'a = diff --git a/src/concolic/execution_tree.mli b/src/concolic/execution_tree.mli index b2f1325b..153aa45d 100644 --- a/src/concolic/execution_tree.mli +++ b/src/concolic/execution_tree.mli @@ -1,14 +1,25 @@ -type 'a t = Leaf | Node of 'a parent * 'a option * 'a left * 'a right +type 'a t = + | Leaf + | Node of 'a parent * 'a option * 'a left * 'a right + and 'a parent = 'a t ref option + and 'a left = 'a t ref + and 'a right = 'a t ref exception Invalid_branch val is_leaf : 'a t ref -> bool + val is_node : 'a t ref -> bool + val can_branch : 'a t ref -> bool + val update_node : 'a t ref -> 'a -> unit + val find : 'a t ref -> 'a option + val move_true : 'a t ref -> 'a left * bool + val move_false : 'a t ref -> 'a right * bool diff --git a/src/interpreter/binary/decode.ml b/src/interpreter/binary/decode.ml index 3b155d82..0671e0e5 100644 --- a/src/interpreter/binary/decode.ml +++ b/src/interpreter/binary/decode.ml @@ -1,13 +1,21 @@ (* Decoding stream *) -type stream = { name : string; bytes : string; pos : int ref } +type stream = + { name : string + ; bytes : string + ; pos : int ref + } exception EOS let stream name bs = { name; bytes = bs; pos = ref 0 } + let len s = String.length s.bytes + let pos s = !(s.pos) + let eos s = pos s = len s + let check n s = if pos s + n > len s then raise EOS let skip n s = @@ -15,6 +23,7 @@ let skip n s = s.pos := !(s.pos) + n let read s = Char.code s.bytes.[!(s.pos)] + let peek s = if eos s then None else Some (read s) let get s = @@ -35,21 +44,27 @@ module Code = Error.Make () exception Code = Code.Error let string_of_byte b = Printf.sprintf "%02x" b + let position s pos = Source.{ file = s.name; line = -1; column = pos } let region s left right = Source.{ left = position s left; right = position s right } let error s pos msg = raise (Code (region s pos pos, msg)) + let require b s pos msg = if not b then error s pos msg let guard f s = try f s with EOS -> error s (len s) "unexpected end of section or function" let get = guard get + let get_string n = guard (get_string n) + let skip n = guard (skip n) + let expect b s msg = require (guard get s = b) s (pos s - 1) msg + let illegal s pos b = error s pos ("illegal opcode " ^ string_of_byte b) let at f s = @@ -99,11 +114,17 @@ let rec vsN n s = else Int64.(logor x (shift_left (vsN (n - 7) s) 7)) let vu1 s = Int64.to_int (vuN 1 s) + let vu32 s = Int64.to_int32 (vuN 32 s) + let vs7 s = Int64.to_int (vsN 7 s) + let vs32 s = Int64.to_int32 (vsN 32 s) + let vs64 s = vsN 64 s + let f32 s = F32.of_bits (u32 s) + let f64 s = F64.of_bits (u64 s) let len32 s = @@ -162,16 +183,16 @@ let elem_type s = let stack_type s = match peek s with | Some 0x40 -> - skip 1 s; - [] + skip 1 s; + [] | _ -> [ value_type s ] let func_type s = match vs7 s with | -0x20 -> - let ins = vec value_type s in - let out = vec value_type s in - FuncType (ins, out) + let ins = vec value_type s in + let out = vec value_type s in + FuncType (ins, out) | _ -> error s (pos s - 1) "invalid function type" let limits vu s = @@ -206,7 +227,9 @@ open Ast open Operators let var s = vu32 s + let op s = u8 s + let end_ s = expect 0x0b s "END opcode expected" let memop s = @@ -221,43 +244,43 @@ let rec instr s = | 0x00 -> unreachable | 0x01 -> nop | 0x02 -> - let ts = stack_type s in - let es' = instr_block s in - end_ s; - block ts es' + let ts = stack_type s in + let es' = instr_block s in + end_ s; + block ts es' | 0x03 -> - let ts = stack_type s in - let es' = instr_block s in - end_ s; - loop ts es' + let ts = stack_type s in + let es' = instr_block s in + end_ s; + loop ts es' | 0x04 -> - let ts = stack_type s in - let es1 = instr_block s in - if peek s = Some 0x05 then ( - expect 0x05 s "ELSE or END opcode expected"; - let es2 = instr_block s in - end_ s; - if_ ts es1 es2) - else ( - end_ s; - if_ ts es1 []) + let ts = stack_type s in + let es1 = instr_block s in + if peek s = Some 0x05 then ( + expect 0x05 s "ELSE or END opcode expected"; + let es2 = instr_block s in + end_ s; + if_ ts es1 es2 ) + else ( + end_ s; + if_ ts es1 [] ) | 0x05 -> error s pos "misplaced ELSE opcode" | (0x06 | 0x07 | 0x08 | 0x09 | 0x0a) as b -> illegal s pos b | 0x0b -> error s pos "misplaced END opcode" | 0x0c -> br (at var s) | 0x0d -> br_if (at var s) | 0x0e -> - let xs = vec (at var) s in - let x = at var s in - br_table xs x + let xs = vec (at var) s in + let x = at var s in + br_table xs x | 0x0f -> return | 0x10 -> call (at var s) | 0x11 -> - let x = at var s in - expect 0x00 s "zero flag expected"; - call_indirect x + let x = at var s in + expect 0x00 s "zero flag expected"; + call_indirect x | (0x12 | 0x13 | 0x14 | 0x15 | 0x16 | 0x17 | 0x18 | 0x19) as b -> - illegal s pos b + illegal s pos b | 0x1a -> drop | 0x1b -> select | (0x1c | 0x1d | 0x1e | 0x1f) as b -> illegal s pos b @@ -268,80 +291,80 @@ let rec instr s = | 0x24 -> global_set (at var s) | (0x25 | 0x26 | 0x27) as b -> illegal s pos b | 0x28 -> - let a, o = memop s in - i32_load a o + let a, o = memop s in + i32_load a o | 0x29 -> - let a, o = memop s in - i64_load a o + let a, o = memop s in + i64_load a o | 0x2a -> - let a, o = memop s in - f32_load a o + let a, o = memop s in + f32_load a o | 0x2b -> - let a, o = memop s in - f64_load a o + let a, o = memop s in + f64_load a o | 0x2c -> - let a, o = memop s in - i32_load8_s a o + let a, o = memop s in + i32_load8_s a o | 0x2d -> - let a, o = memop s in - i32_load8_u a o + let a, o = memop s in + i32_load8_u a o | 0x2e -> - let a, o = memop s in - i32_load16_s a o + let a, o = memop s in + i32_load16_s a o | 0x2f -> - let a, o = memop s in - i32_load16_u a o + let a, o = memop s in + i32_load16_u a o | 0x30 -> - let a, o = memop s in - i64_load8_s a o + let a, o = memop s in + i64_load8_s a o | 0x31 -> - let a, o = memop s in - i64_load8_u a o + let a, o = memop s in + i64_load8_u a o | 0x32 -> - let a, o = memop s in - i64_load16_s a o + let a, o = memop s in + i64_load16_s a o | 0x33 -> - let a, o = memop s in - i64_load16_u a o + let a, o = memop s in + i64_load16_u a o | 0x34 -> - let a, o = memop s in - i64_load32_s a o + let a, o = memop s in + i64_load32_s a o | 0x35 -> - let a, o = memop s in - i64_load32_u a o + let a, o = memop s in + i64_load32_u a o | 0x36 -> - let a, o = memop s in - i32_store a o + let a, o = memop s in + i32_store a o | 0x37 -> - let a, o = memop s in - i64_store a o + let a, o = memop s in + i64_store a o | 0x38 -> - let a, o = memop s in - f32_store a o + let a, o = memop s in + f32_store a o | 0x39 -> - let a, o = memop s in - f64_store a o + let a, o = memop s in + f64_store a o | 0x3a -> - let a, o = memop s in - i32_store8 a o + let a, o = memop s in + i32_store8 a o | 0x3b -> - let a, o = memop s in - i32_store16 a o + let a, o = memop s in + i32_store16 a o | 0x3c -> - let a, o = memop s in - i64_store8 a o + let a, o = memop s in + i64_store8 a o | 0x3d -> - let a, o = memop s in - i64_store16 a o + let a, o = memop s in + i64_store16 a o | 0x3e -> - let a, o = memop s in - i64_store32 a o + let a, o = memop s in + i64_store32 a o | 0x3f -> - expect 0x00 s "zero flag expected"; - memory_size + expect 0x00 s "zero flag expected"; + memory_size | 0x40 -> - expect 0x00 s "zero flag expected"; - memory_grow + expect 0x00 s "zero flag expected"; + memory_grow | 0x41 -> i32_const (at vs32 s) | 0x42 -> i64_const (at vs64 s) | 0x43 -> f32_const (at f32 s) @@ -477,9 +500,9 @@ and instr_block' s es = match peek s with | None | Some (0x05 | 0x0b) -> es | _ -> - let pos = pos s in - let e' = instr s in - instr_block' s (Source.(e' @@ region s pos pos) :: es) + let pos = pos s in + let e' = instr s in + instr_block' s (Source.(e' @@ region s pos pos) :: es) let const s = let c = at instr_block s in @@ -504,14 +527,14 @@ let id s = | 9 -> `ElemSection | 10 -> `CodeSection | 11 -> `DataSection - | _ -> error s (pos s) "invalid section id") + | _ -> error s (pos s) "invalid section id" ) bo let section_with_size tag f default s = match id s with | Some tag' when tag' = tag -> - ignore (u8 s); - sized f s + ignore (u8 s); + sized f s | _ -> default let section tag f default s = section_with_size tag (fun _ -> f) default s @@ -519,6 +542,7 @@ let section tag f default s = section_with_size tag (fun _ -> f) default s (* Type section *) let type_ s = at func_type s + let type_section s = section `TypeSection (vec type_) [] s (* Import section *) @@ -619,11 +643,13 @@ let segment dat s = { index; offset; init } let table_segment s = segment (vec (at var)) s + let elem_section s = section `ElemSection (vec (at table_segment)) [] s (* Data section *) let memory_segment s = segment string s + let data_section s = section `DataSection (vec (at memory_segment)) [] s (* Custom section *) @@ -677,17 +703,16 @@ let module_ s = Source.(fun t f -> { f.it with ftype = t } @@ f.at) func_types func_bodies in - { - types; - tables; - memories; - globals; - funcs; - imports; - exports; - elems; - data; - start; + { types + ; tables + ; memories + ; globals + ; funcs + ; imports + ; exports + ; elems + ; data + ; start } let decode name bs = at module_ (stream name bs) diff --git a/src/interpreter/binary/encode.ml b/src/interpreter/binary/encode.ml index 56fee433..23e176c7 100644 --- a/src/interpreter/binary/encode.ml +++ b/src/interpreter/binary/encode.ml @@ -10,12 +10,19 @@ exception Code = Code.Error (* Encoding stream *) -type stream = { buf : Buffer.t; patches : (int * char) list ref } +type stream = + { buf : Buffer.t + ; patches : (int * char) list ref + } let stream () = { buf = Buffer.create 8192; patches = ref [] } + let pos s = Buffer.length s.buf + let put s b = Buffer.add_char s.buf b + let put_string s bs = Buffer.add_string s.buf bs + let patch s pos b = s.patches := (pos, b) :: !(s.patches) let to_string s = @@ -40,32 +47,37 @@ let encode m = let u32 i = Int32.( u16 (to_int (logand i 0xffffl)); - u16 (to_int (shift_right i 16))) + u16 (to_int (shift_right i 16)) ) let u64 i = Int64.( u32 (to_int32 (logand i 0xffffffffL)); - u32 (to_int32 (shift_right i 32))) + u32 (to_int32 (shift_right i 32)) ) let rec vu64 i = let b = Int64.(to_int (logand i 0x7fL)) in if 0L <= i && i < 128L then u8 b else ( u8 (b lor 0x80); - vu64 (Int64.shift_right_logical i 7)) + vu64 (Int64.shift_right_logical i 7) ) let rec vs64 i = let b = Int64.(to_int (logand i 0x7fL)) in if -64L <= i && i < 64L then u8 b else ( u8 (b lor 0x80); - vs64 (Int64.shift_right i 7)) + vs64 (Int64.shift_right i 7) ) let vu1 i = vu64 Int64.(logand (of_int i) 1L) + let vu32 i = vu64 Int64.(logand (of_int32 i) 0xffffffffL) + let vs7 i = vs64 (Int64.of_int i) + let vs32 i = vs64 (Int64.of_int32 i) + let f32 x = u32 (F32.to_bits x) + let f64 x = u64 (F64.to_bits x) let len i = @@ -80,7 +92,9 @@ let encode m = put_string s bs let name n = string (Utf8.encode n) + let list f xs = List.iter f xs + let opt f xo = Lib.Option.app f xo let vec f xs = @@ -119,14 +133,14 @@ let encode m = | [] -> vs7 (-0x40) | [ t ] -> value_type t | _ -> - Code.error Source.no_region - "cannot encode stack type with arity > 1 (yet)" + Code.error Source.no_region + "cannot encode stack type with arity > 1 (yet)" let func_type = function | FuncType (ins, out) -> - vs7 (-0x20); - vec value_type ins; - vec value_type out + vs7 (-0x20); + vec value_type ins; + vec value_type out let limits vu { min; max } = bool (max <> None); @@ -135,16 +149,17 @@ let encode m = let table_type = function | TableType (lim, t) -> - elem_type t; - limits vu32 lim + elem_type t; + limits vu32 lim let memory_type = function MemoryType lim -> limits vu32 lim + let mutability = function Immutable -> u8 0 | Mutable -> u8 1 let global_type = function | GlobalType (t, mut) -> - value_type t; - mutability mut + value_type t; + mutability mut (* Expressions *) @@ -154,6 +169,7 @@ let encode m = open Memory let op n = u8 n + let end_ () = op 0x0b let memop { align; offset; _ } = @@ -167,148 +183,148 @@ let encode m = | Unreachable -> op 0x00 | Nop -> op 0x01 | Block (ts, es) -> - op 0x02; - stack_type ts; - list instr es; - end_ () + op 0x02; + stack_type ts; + list instr es; + end_ () | Loop (ts, es) -> - op 0x03; - stack_type ts; - list instr es; - end_ () + op 0x03; + stack_type ts; + list instr es; + end_ () | If (ts, es1, es2) -> - op 0x04; - stack_type ts; - list instr es1; - if es2 <> [] then op 0x05; - list instr es2; - end_ () + op 0x04; + stack_type ts; + list instr es1; + if es2 <> [] then op 0x05; + list instr es2; + end_ () | Br x -> - op 0x0c; - var x + op 0x0c; + var x | BrIf x -> - op 0x0d; - var x + op 0x0d; + var x | BrTable (xs, x) -> - op 0x0e; - vec var xs; - var x + op 0x0e; + vec var xs; + var x | Return -> op 0x0f | Call x -> - op 0x10; - var x + op 0x10; + var x | CallIndirect x -> - op 0x11; - var x; - u8 0x00 + op 0x11; + var x; + u8 0x00 | Drop -> op 0x1a | Select -> op 0x1b | LocalGet x -> - op 0x20; - var x + op 0x20; + var x | LocalSet x -> - op 0x21; - var x + op 0x21; + var x | LocalTee x -> - op 0x22; - var x + op 0x22; + var x | GlobalGet x -> - op 0x23; - var x + op 0x23; + var x | GlobalSet x -> - op 0x24; - var x + op 0x24; + var x | Load ({ ty = I32Type; sz = None; _ } as mo) -> - op 0x28; - memop mo + op 0x28; + memop mo | Load ({ ty = I64Type; sz = None; _ } as mo) -> - op 0x29; - memop mo + op 0x29; + memop mo | Load ({ ty = F32Type; sz = None; _ } as mo) -> - op 0x2a; - memop mo + op 0x2a; + memop mo | Load ({ ty = F64Type; sz = None; _ } as mo) -> - op 0x2b; - memop mo + op 0x2b; + memop mo | Load ({ ty = I32Type; sz = Some (Pack8, SX); _ } as mo) -> - op 0x2c; - memop mo + op 0x2c; + memop mo | Load ({ ty = I32Type; sz = Some (Pack8, ZX); _ } as mo) -> - op 0x2d; - memop mo + op 0x2d; + memop mo | Load ({ ty = I32Type; sz = Some (Pack16, SX); _ } as mo) -> - op 0x2e; - memop mo + op 0x2e; + memop mo | Load ({ ty = I32Type; sz = Some (Pack16, ZX); _ } as mo) -> - op 0x2f; - memop mo + op 0x2f; + memop mo | Load { ty = I32Type; sz = Some (Pack32, _); _ } -> assert false | Load ({ ty = I64Type; sz = Some (Pack8, SX); _ } as mo) -> - op 0x30; - memop mo + op 0x30; + memop mo | Load ({ ty = I64Type; sz = Some (Pack8, ZX); _ } as mo) -> - op 0x31; - memop mo + op 0x31; + memop mo | Load ({ ty = I64Type; sz = Some (Pack16, SX); _ } as mo) -> - op 0x32; - memop mo + op 0x32; + memop mo | Load ({ ty = I64Type; sz = Some (Pack16, ZX); _ } as mo) -> - op 0x33; - memop mo + op 0x33; + memop mo | Load ({ ty = I64Type; sz = Some (Pack32, SX); _ } as mo) -> - op 0x34; - memop mo + op 0x34; + memop mo | Load ({ ty = I64Type; sz = Some (Pack32, ZX); _ } as mo) -> - op 0x35; - memop mo + op 0x35; + memop mo | Load { ty = F32Type | F64Type; sz = Some _; _ } -> assert false | Store ({ ty = I32Type; sz = None; _ } as mo) -> - op 0x36; - memop mo + op 0x36; + memop mo | Store ({ ty = I64Type; sz = None; _ } as mo) -> - op 0x37; - memop mo + op 0x37; + memop mo | Store ({ ty = F32Type; sz = None; _ } as mo) -> - op 0x38; - memop mo + op 0x38; + memop mo | Store ({ ty = F64Type; sz = None; _ } as mo) -> - op 0x39; - memop mo + op 0x39; + memop mo | Store ({ ty = I32Type; sz = Some Pack8; _ } as mo) -> - op 0x3a; - memop mo + op 0x3a; + memop mo | Store ({ ty = I32Type; sz = Some Pack16; _ } as mo) -> - op 0x3b; - memop mo + op 0x3b; + memop mo | Store { ty = I32Type; sz = Some Pack32; _ } -> assert false | Store ({ ty = I64Type; sz = Some Pack8; _ } as mo) -> - op 0x3c; - memop mo + op 0x3c; + memop mo | Store ({ ty = I64Type; sz = Some Pack16; _ } as mo) -> - op 0x3d; - memop mo + op 0x3d; + memop mo | Store ({ ty = I64Type; sz = Some Pack32; _ } as mo) -> - op 0x3e; - memop mo + op 0x3e; + memop mo | Store { ty = F32Type | F64Type; sz = Some _; _ } -> assert false | MemorySize -> - op 0x3f; - u8 0x00 + op 0x3f; + u8 0x00 | MemoryGrow -> - op 0x40; - u8 0x00 + op 0x40; + u8 0x00 | Const { it = I32 c; _ } -> - op 0x41; - vs32 c + op 0x41; + vs32 c | Const { it = I64 c; _ } -> - op 0x42; - vs64 c + op 0x42; + vs64 c | Const { it = F32 c; _ } -> - op 0x43; - f32 c + op 0x43; + f32 c | Const { it = F64 c; _ } -> - op 0x44; - f64 c + op 0x44; + f64 c | Test (I32 I32Op.Eqz) -> op 0x45 | Test (I64 I64Op.Eqz) -> op 0x50 | Test (F32 _) -> assert false @@ -453,27 +469,28 @@ let encode m = let g = gap32 () in let p = pos s in f x; - patch_gap32 g (pos s - p)) + patch_gap32 g (pos s - p) ) (* Type section *) let type_ t = func_type t.it + let type_section ts = section 1 (vec type_) ts (ts <> []) (* Import section *) let import_desc d = match d.it with | FuncImport x -> - u8 0x00; - var x + u8 0x00; + var x | TableImport t -> - u8 0x01; - table_type t + u8 0x01; + table_type t | MemoryImport t -> - u8 0x02; - memory_type t + u8 0x02; + memory_type t | GlobalImport t -> - u8 0x03; - global_type t + u8 0x03; + global_type t let import im = let { module_name; item_name; idesc } = im.it in @@ -485,6 +502,7 @@ let encode m = (* Function section *) let func f = var f.it.ftype + let func_section fs = section 3 (vec func) fs (fs <> []) (* Table section *) @@ -513,17 +531,17 @@ let encode m = let export_desc d = match d.it with | FuncExport x -> - u8 0; - var x + u8 0; + var x | TableExport x -> - u8 1; - var x + u8 1; + var x | MemoryExport x -> - u8 2; - var x + u8 2; + var x | GlobalExport x -> - u8 3; - var x + u8 3; + var x let export ex = let { name = n; edesc } = ex.it in @@ -566,10 +584,12 @@ let encode m = dat init let table_segment seg = segment (vec var) seg + let elem_section elems = section 9 (vec table_segment) elems (elems <> []) (* Data section *) let memory_segment seg = segment string seg + let data_section data = section 11 (vec memory_segment) data (data <> []) (* Module *) diff --git a/src/interpreter/binary/encode.mli b/src/interpreter/binary/encode.mli index 25eec44c..def834d0 100644 --- a/src/interpreter/binary/encode.mli +++ b/src/interpreter/binary/encode.mli @@ -1,4 +1,5 @@ exception Code of Source.region * string val version : int32 + val encode : Ast.module_ -> string diff --git a/src/interpreter/binary/utf8.ml b/src/interpreter/binary/utf8.ml index 813be230..d5e83c34 100644 --- a/src/interpreter/binary/utf8.ml +++ b/src/interpreter/binary/utf8.ml @@ -10,12 +10,12 @@ and encode' = function | n :: ns when n < 0x80 -> n :: encode' ns | n :: ns when n < 0x800 -> (0xc0 lor (n lsr 6)) :: con n :: encode' ns | n :: ns when n < 0x10000 -> - (0xe0 lor (n lsr 12)) :: con (n lsr 6) :: con n :: encode' ns + (0xe0 lor (n lsr 12)) :: con (n lsr 6) :: con n :: encode' ns | n :: ns when n < 0x110000 -> - (0xf0 lor (n lsr 18)) - :: con (n lsr 12) - :: con (n lsr 6) - :: con n :: encode' ns + (0xf0 lor (n lsr 18)) + :: con (n lsr 12) + :: con (n lsr 6) + :: con n :: encode' ns | _ -> raise Utf8 let con b = if b land 0xc0 = 0x80 then b land 0x3f else raise Utf8 @@ -31,12 +31,11 @@ and decode' = function | b1 :: bs when b1 < 0x80 -> code 0x0 b1 :: decode' bs | b1 :: _ when b1 < 0xc0 -> raise Utf8 | b1 :: b2 :: bs when b1 < 0xe0 -> - code 0x80 (((b1 land 0x1f) lsl 6) + con b2) :: decode' bs + code 0x80 (((b1 land 0x1f) lsl 6) + con b2) :: decode' bs | b1 :: b2 :: b3 :: bs when b1 < 0xf0 -> - code 0x800 (((b1 land 0x0f) lsl 12) + (con b2 lsl 6) + con b3) - :: decode' bs + code 0x800 (((b1 land 0x0f) lsl 12) + (con b2 lsl 6) + con b3) :: decode' bs | b1 :: b2 :: b3 :: b4 :: bs when b1 < 0xf8 -> - code 0x10000 - (((b1 land 0x07) lsl 18) + (con b2 lsl 12) + (con b3 lsl 6) + con b4) - :: decode' bs + code 0x10000 + (((b1 land 0x07) lsl 18) + (con b2 lsl 12) + (con b3 lsl 6) + con b4) + :: decode' bs | _ -> raise Utf8 diff --git a/src/interpreter/binary/utf8.mli b/src/interpreter/binary/utf8.mli index 3b5994a3..9552d9b7 100644 --- a/src/interpreter/binary/utf8.mli +++ b/src/interpreter/binary/utf8.mli @@ -1,4 +1,5 @@ exception Utf8 val decode : string -> int list (* raises Utf8 *) + val encode : int list -> string (* raises Utf8 *) diff --git a/src/interpreter/exec/eval.ml b/src/interpreter/exec/eval.ml index ca57f153..ac873f04 100644 --- a/src/interpreter/exec/eval.ml +++ b/src/interpreter/exec/eval.ml @@ -2,7 +2,9 @@ open Values open Types open Instance open Ast -open Source [@@@ocaml.warning "-27"] +open Source + +[@@@ocaml.warning "-27"] (* Errors *) diff --git a/src/interpreter/exec/eval.mli b/src/interpreter/exec/eval.mli index 9a1f09ad..10b718bf 100644 --- a/src/interpreter/exec/eval.mli +++ b/src/interpreter/exec/eval.mli @@ -2,10 +2,15 @@ open Values open Instance exception Link of Source.region * string + exception Trap of Source.region * string + exception Crash of Source.region * string + exception Exhaustion of Source.region * string val eval_const : module_inst -> Ast.const -> value + val init : Ast.module_ -> extern list -> module_inst (* raises Link, Trap *) + val invoke : func_inst -> value list -> value list (* raises Trap *) diff --git a/src/interpreter/exec/eval_numeric.ml b/src/interpreter/exec/eval_numeric.ml index 292ed033..a20ccb4d 100644 --- a/src/interpreter/exec/eval_numeric.ml +++ b/src/interpreter/exec/eval_numeric.ml @@ -13,6 +13,7 @@ module IntOp (IXX : Int.S) (Value : ValueType with type t = IXX.t) = struct open Ast.IntOp let to_value = Value.to_value + let of_value = of_arg Value.of_value let unop op = @@ -72,6 +73,7 @@ module FloatOp (FXX : Float.S) (Value : ValueType with type t = FXX.t) = struct open Ast.FloatOp let to_value = Value.to_value + let of_value = of_arg Value.of_value let unop op = @@ -187,7 +189,11 @@ let op i32 i64 f32 f64 = function | F64 x -> f64 x let eval_unop = op I32Op.unop I64Op.unop F32Op.unop F64Op.unop + let eval_binop = op I32Op.binop I64Op.binop F32Op.binop F64Op.binop + let eval_testop = op I32Op.testop I64Op.testop F32Op.testop F64Op.testop + let eval_relop = op I32Op.relop I64Op.relop F32Op.relop F64Op.relop + let eval_cvtop = op I32CvtOp.cvtop I64CvtOp.cvtop F32CvtOp.cvtop F64CvtOp.cvtop diff --git a/src/interpreter/exec/eval_numeric.mli b/src/interpreter/exec/eval_numeric.mli index 7435b3c6..ecedfcd2 100644 --- a/src/interpreter/exec/eval_numeric.mli +++ b/src/interpreter/exec/eval_numeric.mli @@ -3,7 +3,11 @@ open Values exception TypeError of int * value * Types.value_type val eval_unop : Ast.unop -> value -> value + val eval_binop : Ast.binop -> value -> value -> value + val eval_testop : Ast.testop -> value -> bool + val eval_relop : Ast.relop -> value -> value -> bool + val eval_cvtop : Ast.cvtop -> value -> value diff --git a/src/interpreter/exec/f32.ml b/src/interpreter/exec/f32.ml index ac423ac9..d4bb4aa1 100644 --- a/src/interpreter/exec/f32.ml +++ b/src/interpreter/exec/f32.ml @@ -7,8 +7,12 @@ include Float.Make (struct include Int32 let mantissa = 23 + let pos_nan = 0x7fc0_0000l + let neg_nan = 0xffc0_0000l + let bare_nan = 0x7f80_0000l + let to_hex_string = Printf.sprintf "%lx" end) diff --git a/src/interpreter/exec/f32_convert.ml b/src/interpreter/exec/f32_convert.ml index 8adaf719..f311d117 100644 --- a/src/interpreter/exec/f32_convert.ml +++ b/src/interpreter/exec/f32_convert.ml @@ -24,7 +24,7 @@ let convert_i32_u x = F32.of_float Int32.( if x >= zero then to_float x - else to_float (logor (shift_right_logical x 1) (logand x 1l)) *. 2.0) + else to_float (logor (shift_right_logical x 1) (logand x 1l)) *. 2.0 ) (* * Values that are too large would get rounded when represented in f64, @@ -39,7 +39,7 @@ let convert_i64_s x = else let r = if logand x 0xfffL = 0L then 0L else 1L in to_float (logor (shift_right x 12) r) - *. (* TODO(ocaml-4.03): 0x1p12 *) 4096.0) + *. (* TODO(ocaml-4.03): 0x1p12 *) 4096.0 ) let convert_i64_u x = F32.of_float @@ -48,6 +48,6 @@ let convert_i64_u x = else let r = if logand x 0xfffL = 0L then 0L else 1L in to_float (logor (shift_right_logical x 12) r) - *. (* TODO(ocaml-4.03): 0x1p12 *) 4096.0) + *. (* TODO(ocaml-4.03): 0x1p12 *) 4096.0 ) let reinterpret_i32 = F32.of_bits diff --git a/src/interpreter/exec/f32_convert.mli b/src/interpreter/exec/f32_convert.mli index 1b1b579d..065793c8 100644 --- a/src/interpreter/exec/f32_convert.mli +++ b/src/interpreter/exec/f32_convert.mli @@ -1,8 +1,13 @@ (* WebAssembly-compatible type conversions to f32 implementation *) val demote_f64 : F64.t -> F32.t + val convert_i32_s : I32.t -> F32.t + val convert_i32_u : I32.t -> F32.t + val convert_i64_s : I64.t -> F32.t + val convert_i64_u : I64.t -> F32.t + val reinterpret_i32 : I32.t -> F32.t diff --git a/src/interpreter/exec/f64.ml b/src/interpreter/exec/f64.ml index 0fe16df8..745e8344 100644 --- a/src/interpreter/exec/f64.ml +++ b/src/interpreter/exec/f64.ml @@ -2,8 +2,12 @@ include Float.Make (struct include Int64 let mantissa = 52 + let pos_nan = 0x7ff8_0000_0000_0000L + let neg_nan = 0xfff8_0000_0000_0000L + let bare_nan = 0x7ff0_0000_0000_0000L + let to_hex_string = Printf.sprintf "%Lx" end) diff --git a/src/interpreter/exec/f64_convert.ml b/src/interpreter/exec/f64_convert.ml index 0cfedc82..290111f8 100644 --- a/src/interpreter/exec/f64_convert.ml +++ b/src/interpreter/exec/f64_convert.ml @@ -35,6 +35,6 @@ let convert_i64_u x = F64.of_float Int64.( if x >= zero then to_float x - else to_float (logor (shift_right_logical x 1) (logand x 1L)) *. 2.0) + else to_float (logor (shift_right_logical x 1) (logand x 1L)) *. 2.0 ) let reinterpret_i64 = F64.of_bits diff --git a/src/interpreter/exec/f64_convert.mli b/src/interpreter/exec/f64_convert.mli index 9ed693be..9cbabf2f 100644 --- a/src/interpreter/exec/f64_convert.mli +++ b/src/interpreter/exec/f64_convert.mli @@ -1,8 +1,13 @@ (* WebAssembly-compatible type conversions to f64 implementation *) val promote_f32 : F32.t -> F64.t + val convert_i32_s : I32.t -> F64.t + val convert_i32_u : I32.t -> F64.t + val convert_i64_s : I64.t -> F64.t + val convert_i64_u : I64.t -> F64.t + val reinterpret_i64 : I64.t -> F64.t diff --git a/src/interpreter/exec/float.ml b/src/interpreter/exec/float.ml index a76a1316..14b27d84 100644 --- a/src/interpreter/exec/float.ml +++ b/src/interpreter/exec/float.ml @@ -2,58 +2,105 @@ module type RepType = sig type t val mantissa : int + val zero : t + val min_int : t + val max_int : t + val pos_nan : t + val neg_nan : t + val bare_nan : t + val bits_of_float : float -> t + val float_of_bits : t -> float + val of_string : string -> t + val to_string : t -> string + val to_hex_string : t -> string + val lognot : t -> t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t end module type S = sig type t + type bits val pos_nan : t + val neg_nan : t + val is_inf : t -> bool + val is_nan : t -> bool + val of_float : float -> t + val to_float : t -> float + val of_string : string -> t + val to_string : t -> string + val of_bits : bits -> t + val to_bits : t -> bits + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val sqrt : t -> t + val min : t -> t -> t + val max : t -> t -> t + val ceil : t -> t + val floor : t -> t + val trunc : t -> t + val nearest : t -> t + val abs : t -> t + val neg : t -> t + val copysign : t -> t -> t + val eq : t -> t -> bool + val ne : t -> t -> bool + val lt : t -> t -> bool + val le : t -> t -> bool + val gt : t -> t -> bool + val ge : t -> t -> bool + val zero : t + val rand : float -> t end @@ -61,17 +108,27 @@ module Make (Rep : RepType) : S with type bits = Rep.t = struct let _ = assert (Rep.mantissa <= 52) type t = Rep.t + type bits = Rep.t let pos_inf = Rep.bits_of_float (1.0 /. 0.0) + let neg_inf = Rep.bits_of_float (-.(1.0 /. 0.0)) + let pos_nan = Rep.pos_nan + let neg_nan = Rep.neg_nan + let bare_nan = Rep.bare_nan + let of_float = Rep.bits_of_float + let to_float = Rep.float_of_bits + let of_bits x = x + let to_bits x = x + let is_inf x = x = pos_inf || x = neg_inf let is_nan x = @@ -124,12 +181,19 @@ module Make (Rep : RepType) : S with type bits = Rep.t = struct if t = t then of_float t else determine_unary_nan x let zero = of_float 0.0 + let add x y = binary x ( +. ) y + let sub x y = binary x ( -. ) y + let mul x y = binary x ( *. ) y + let div x y = binary x ( /. ) y + let sqrt x = unary sqrt x + let ceil x = unary ceil x + let floor x = unary floor x let trunc x = @@ -183,13 +247,21 @@ module Make (Rep : RepType) : S with type bits = Rep.t = struct (* abs, neg, copysign are purely bitwise operations, even on NaN values *) let abs x = Rep.logand x Rep.max_int + let neg x = Rep.logxor x Rep.min_int + let copysign x y = Rep.logor (abs x) (Rep.logand y Rep.min_int) + let eq x y = to_float x = to_float y + let ne x y = to_float x <> to_float y + let lt x y = to_float x < to_float y + let gt x y = to_float x > to_float y + let le x y = to_float x <= to_float y + let ge x y = to_float x >= to_float y (* @@ -197,7 +269,9 @@ module Make (Rep : RepType) : S with type bits = Rep.t = struct * This is a gross hack to detect rounding during parsing of floats. *) let is_hex c = ('0' <= c && c <= '9') || ('A' <= c && c <= 'F') + let is_exp hex c = c = if hex then 'P' else 'E' + let at_end hex s i = i = String.length s || is_exp hex s.[i] let rec skip_non_hex s i = @@ -216,9 +290,9 @@ module Make (Rep : RepType) : S with type bits = Rep.t = struct | true, false -> if at_end hex s2 (skip_zeroes s2 i2') then 0 else -1 | false, true -> if at_end hex s1 (skip_zeroes s1 i1') then 0 else 1 | false, false -> ( - match compare s1.[i1'] s2.[i2'] with - | 0 -> compare_mantissa_str' hex s1 (i1' + 1) s2 (i2' + 1) - | n -> n) + match compare s1.[i1'] s2.[i2'] with + | 0 -> compare_mantissa_str' hex s1 (i1' + 1) s2 (i2' + 1) + | n -> n ) let compare_mantissa_str hex s1 s2 = let s1' = String.uppercase_ascii s1 in @@ -318,13 +392,14 @@ module Make (Rep : RepType) : S with type bits = Rep.t = struct (* String conversion that groups digits for readability *) let is_digit c = '0' <= c && c <= '9' + let isnt_digit c = not (is_digit c) let rec add_digits buf s i j k = if i < j then ( if k = 0 then Buffer.add_char buf '_'; Buffer.add_char buf s.[i]; - add_digits buf s (i + 1) j ((k + 2) mod 3)) + add_digits buf s (i + 1) j ((k + 2) mod 3) ) let group_digits s = let len = String.length s in diff --git a/src/interpreter/exec/i32_convert.mli b/src/interpreter/exec/i32_convert.mli index 20e4eb40..82403f9a 100644 --- a/src/interpreter/exec/i32_convert.mli +++ b/src/interpreter/exec/i32_convert.mli @@ -1,8 +1,13 @@ (* WebAssembly-compatible type conversions to i32 implementation *) val wrap_i64 : I64.t -> I32.t + val trunc_f32_s : F32.t -> I32.t + val trunc_f32_u : F32.t -> I32.t + val trunc_f64_s : F64.t -> I32.t + val trunc_f64_u : F64.t -> I32.t + val reinterpret_f32 : F32.t -> I32.t diff --git a/src/interpreter/exec/i64_convert.ml b/src/interpreter/exec/i64_convert.ml index f9aece9f..e6f70693 100644 --- a/src/interpreter/exec/i64_convert.ml +++ b/src/interpreter/exec/i64_convert.ml @@ -1,6 +1,7 @@ (* WebAssembly-compatible type conversions to i64 implementation *) let extend_i32_s x = Int64.of_int32 x + let extend_i32_u x = Int64.logand (Int64.of_int32 x) 0x0000_0000_ffff_ffffL let trunc_f32_s x = @@ -21,8 +22,8 @@ let trunc_f32_u x = Int64.( logxor (of_float - (xf -. (* TODO(ocaml-4.03): 0x1p63 *) 9223372036854775808.0)) - min_int) + (xf -. (* TODO(ocaml-4.03): 0x1p63 *) 9223372036854775808.0) ) + min_int ) else Int64.of_float xf let trunc_f64_s x = @@ -43,8 +44,8 @@ let trunc_f64_u x = Int64.( logxor (of_float - (xf -. (* TODO(ocaml-4.03): 0x1p63 *) 9223372036854775808.0)) - min_int) + (xf -. (* TODO(ocaml-4.03): 0x1p63 *) 9223372036854775808.0) ) + min_int ) else Int64.of_float xf let reinterpret_f64 = F64.to_bits diff --git a/src/interpreter/exec/i64_convert.mli b/src/interpreter/exec/i64_convert.mli index 02a0ce45..4d0aede3 100644 --- a/src/interpreter/exec/i64_convert.mli +++ b/src/interpreter/exec/i64_convert.mli @@ -1,9 +1,15 @@ (* WebAssembly-compatible type conversions to i64 implementation *) val extend_i32_s : I32.t -> I64.t + val extend_i32_u : I32.t -> I64.t + val trunc_f32_s : F32.t -> I64.t + val trunc_f32_u : F32.t -> I64.t + val trunc_f64_s : F64.t -> I64.t + val trunc_f64_u : F64.t -> I64.t + val reinterpret_f64 : F64.t -> I64.t diff --git a/src/interpreter/exec/int.ml b/src/interpreter/exec/int.ml index a5cd474c..7fe68cd5 100644 --- a/src/interpreter/exec/int.ml +++ b/src/interpreter/exec/int.ml @@ -2,72 +2,133 @@ module type RepType = sig type t val zero : t + val one : t + val minus_one : t + val max_int : t + val min_int : t + val neg : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t (* raises Division_by_zero *) + val rem : t -> t -> t (* raises Division_by_zero *) + val logand : t -> t -> t + val lognot : t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t + val shift_right_logical : t -> int -> t + val of_int : int -> t + val to_int : t -> int + val to_string : t -> string + val bitwidth : int end module type S = sig type t + type bits val of_bits : bits -> t + val to_bits : t -> bits + val zero : t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div_s : t -> t -> t (* raises IntegerDivideByZero, IntegerOverflow *) + val div_u : t -> t -> t (* raises IntegerDivideByZero *) + val rem_s : t -> t -> t (* raises IntegerDivideByZero *) + val rem_u : t -> t -> t (* raises IntegerDivideByZero *) + val and_ : t -> t -> t + val or_ : t -> t -> t + val xor : t -> t -> t + val shl : t -> t -> t + val shr_s : t -> t -> t + val shr_u : t -> t -> t + val rotl : t -> t -> t + val rotr : t -> t -> t + val clz : t -> t + val ctz : t -> t + val popcnt : t -> t + val eqz : t -> bool + val eq : t -> t -> bool + val ne : t -> t -> bool + val lt_s : t -> t -> bool + val lt_u : t -> t -> bool + val le_s : t -> t -> bool + val le_u : t -> t -> bool + val gt_s : t -> t -> bool + val gt_u : t -> t -> bool + val ge_s : t -> t -> bool + val ge_u : t -> t -> bool + val of_int_s : int -> t + val of_int_u : int -> t + val of_string_s : string -> t + val of_string_u : string -> t + val of_string : string -> t + val to_string_s : t -> string + val to_string_u : t -> string + val rand : int -> t end @@ -93,17 +154,24 @@ struct if cmp_u r ( < ) d then (q, r) else (Rep.add q Rep.one, Rep.sub r d) type t = Rep.t + type bits = Rep.t let of_bits x = x + let to_bits x = x + let zero = Rep.zero + let one = Rep.one + let ten = Rep.of_int 10 (* add, sub, and mul are sign-agnostic and do not trap on overflow. *) let add = Rep.add + let sub = Rep.sub + let mul = Rep.mul (* result is truncated toward zero *) @@ -128,7 +196,9 @@ struct r let and_ = Rep.logand + let or_ = Rep.logor + let xor = Rep.logxor (* WebAssembly's shifts mask the shift count according to the bitwidth. *) @@ -136,7 +206,9 @@ struct f x (Rep.to_int (Rep.logand y (Rep.of_int (Rep.bitwidth - 1)))) let shl x y = shift Rep.shift_left x y + let shr_s x y = shift Rep.shift_right x y + let shr_u x y = shift Rep.shift_right_logical x y (* We must mask the count to implement rotates via shifts. *) @@ -180,17 +252,29 @@ struct Rep.of_int (loop 0 Rep.bitwidth x) let eqz x = x = Rep.zero + let eq x y = x = y + let ne x y = x <> y + let lt_s x y = x < y + let lt_u x y = cmp_u x ( < ) y + let le_s x y = x <= y + let le_u x y = cmp_u x ( <= ) y + let gt_s x y = x > y + let gt_u x y = cmp_u x ( > ) y + let ge_s x y = x >= y + let ge_u x y = cmp_u x ( >= ) y + let of_int_s = Rep.of_int + let of_int_u i = and_ (Rep.of_int i) (or_ (shl (Rep.of_int max_int) one) one) (* String conversion that allows leading signs and unsigned values *) @@ -238,9 +322,9 @@ struct match s.[0] with | '+' -> parse_int 1 | '-' -> - let n = parse_int 1 in - require (ge_s (sub n one) minus_one); - Rep.neg n + let n = parse_int 1 in + require (ge_s (sub n one) minus_one); + Rep.neg n | _ -> parse_int 0 let of_string_s s = @@ -259,7 +343,7 @@ struct if i < j then ( if k = 0 then Buffer.add_char buf '_'; Buffer.add_char buf s.[i]; - add_digits buf s (i + 1) j ((k + 2) mod 3)) + add_digits buf s (i + 1) j ((k + 2) mod 3) ) let group_digits s = let len = String.length s in diff --git a/src/interpreter/exec/numeric_error.ml b/src/interpreter/exec/numeric_error.ml index 0dcf7bc1..0cd9d06a 100644 --- a/src/interpreter/exec/numeric_error.ml +++ b/src/interpreter/exec/numeric_error.ml @@ -1,3 +1,5 @@ exception IntegerOverflow + exception IntegerDivideByZero + exception InvalidConversionToInteger diff --git a/src/interpreter/host/env.ml b/src/interpreter/host/env.ml index 8502944f..64e43829 100644 --- a/src/interpreter/host/env.ml +++ b/src/interpreter/host/env.ml @@ -12,8 +12,8 @@ let error msg = raise (Eval.Crash (Source.no_region, msg)) let type_error v t = error - ("type error, expected " ^ string_of_value_type t ^ ", got " - ^ string_of_value_type (type_of v)) + ( "type error, expected " ^ string_of_value_type t ^ ", got " + ^ string_of_value_type (type_of v) ) let empty = function [] -> () | _ -> error "type error, too many arguments" diff --git a/src/interpreter/host/spectest.ml b/src/interpreter/host/spectest.ml index 31d4fb81..3ad7b693 100644 --- a/src/interpreter/host/spectest.ml +++ b/src/interpreter/host/spectest.ml @@ -17,7 +17,9 @@ let global (GlobalType (t, _) as gt) = Global.alloc gt v let table = Table.alloc (TableType ({ min = 10l; max = Some 20l }, FuncRefType)) + let memory = Memory.alloc (MemoryType { min = 1l; max = Some 2l }) + let func f t = Func.alloc_host t (f t) let print_value v = @@ -34,9 +36,9 @@ let lookup name t = | "print", _ -> ExternFunc (func print (FuncType ([], []))) | "print_i32", _ -> ExternFunc (func print (FuncType ([ I32Type ], []))) | "print_i32_f32", _ -> - ExternFunc (func print (FuncType ([ I32Type; F32Type ], []))) + ExternFunc (func print (FuncType ([ I32Type; F32Type ], []))) | "print_f64_f64", _ -> - ExternFunc (func print (FuncType ([ F64Type; F64Type ], []))) + ExternFunc (func print (FuncType ([ F64Type; F64Type ], []))) | "print_f32", _ -> ExternFunc (func print (FuncType ([ F32Type ], []))) | "print_f64", _ -> ExternFunc (func print (FuncType ([ F64Type ], []))) | "global_i32", _ -> ExternGlobal (global (GlobalType (I32Type, Immutable))) diff --git a/src/interpreter/main/flags.ml b/src/interpreter/main/flags.ml index bca16f65..b34ce29a 100644 --- a/src/interpreter/main/flags.ml +++ b/src/interpreter/main/flags.ml @@ -1,20 +1,39 @@ let interactive = ref false + let trace = ref false + let unchecked = ref false + let print_sig = ref false + let dry = ref false + let width = ref 80 + let harness = ref true + let output = ref "output" + let simplify = ref true + let timeout = ref 895 + let concrete = ref false + let static = ref false + let queries = ref false + let policy = ref "breadth" + let encoding = ref "incremental" + let memory = ref "map" + let budget = 10000 + let hashtbl_default_size = 128 + let fixed_numbers = ref [ 0; 1; 2; 4; 8; 256; 4096 ] + let log = ref false diff --git a/src/interpreter/runtime/func.ml b/src/interpreter/runtime/func.ml index 52cb5260..d6438ad3 100644 --- a/src/interpreter/runtime/func.ml +++ b/src/interpreter/runtime/func.ml @@ -8,7 +8,9 @@ and 'inst func = | HostFunc of func_type * (value list -> value list) let alloc ft inst f = AstFunc (ft, inst, f) + let alloc_host ft f = HostFunc (ft, f) + let type_of = function AstFunc (ft, _, _) -> ft | HostFunc (ft, _) -> ft let get_inst (f : 'inst t) : 'inst option = diff --git a/src/interpreter/runtime/func.mli b/src/interpreter/runtime/func.mli index 06c85ba3..b85c7731 100644 --- a/src/interpreter/runtime/func.mli +++ b/src/interpreter/runtime/func.mli @@ -8,6 +8,9 @@ and 'inst func = | HostFunc of func_type * (value list -> value list) val alloc : func_type -> 'inst -> Ast.func -> 'inst func + val alloc_host : func_type -> (value list -> value list) -> 'inst func + val type_of : 'inst func -> func_type + val get_inst : 'inst t -> 'inst option diff --git a/src/interpreter/runtime/global.ml b/src/interpreter/runtime/global.ml index f2e34687..0c4a870b 100644 --- a/src/interpreter/runtime/global.ml +++ b/src/interpreter/runtime/global.ml @@ -1,10 +1,15 @@ open Types open Values -type global = { mutable content : value; mut : mutability } +type global = + { mutable content : value + ; mut : mutability + } + type t = global exception Type + exception NotMutable let alloc (GlobalType (t, mut)) v = @@ -12,6 +17,7 @@ let alloc (GlobalType (t, mut)) v = { content = v; mut } let type_of glob = GlobalType (type_of glob.content, glob.mut) + let load glob = glob.content let store glob v = @@ -20,6 +26,7 @@ let store glob v = glob.content <- v let safe_store glob v = if glob.mut = Mutable then glob.content <- v + let globcpy (glob : global) : global = alloc (type_of glob) glob.content let contents (globs : global list) : value list = diff --git a/src/interpreter/runtime/global.mli b/src/interpreter/runtime/global.mli index c9cdbf4d..17522cf7 100644 --- a/src/interpreter/runtime/global.mli +++ b/src/interpreter/runtime/global.mli @@ -2,15 +2,23 @@ open Types open Values type global + type t = global exception Type + exception NotMutable val alloc : global_type -> value -> global (* raises Type *) + val type_of : global -> global_type + val load : global -> value + val store : global -> value -> unit (* raises Type, NotMutable *) + val safe_store : global -> value -> unit + val globcpy : global -> global + val contents : global list -> value list diff --git a/src/interpreter/runtime/instance.ml b/src/interpreter/runtime/instance.ml index 21a7f2cd..98503f0c 100644 --- a/src/interpreter/runtime/instance.ml +++ b/src/interpreter/runtime/instance.ml @@ -1,18 +1,22 @@ open Types -type module_inst = { - types : func_type list; - funcs : func_inst list; - tables : table_inst list; - memories : memory_inst list; - globals : global_inst list; - exports : export_inst list; -} +type module_inst = + { types : func_type list + ; funcs : func_inst list + ; tables : table_inst list + ; memories : memory_inst list + ; globals : global_inst list + ; exports : export_inst list + } and func_inst = module_inst ref Func.t + and table_inst = Table.t + and memory_inst = Memory.t + and global_inst = Global.t + and export_inst = Ast.name * extern and extern = @@ -35,13 +39,12 @@ let clone (m : module_inst) : module_inst = { types; funcs; tables; memories; globals; exports } let empty_module_inst = - { - types = []; - funcs = []; - tables = []; - memories = []; - globals = []; - exports = []; + { types = [] + ; funcs = [] + ; tables = [] + ; memories = [] + ; globals = [] + ; exports = [] } let extern_type_of = function diff --git a/src/interpreter/runtime/memory.ml b/src/interpreter/runtime/memory.ml index 108f27ab..5c5066b1 100644 --- a/src/interpreter/runtime/memory.ml +++ b/src/interpreter/runtime/memory.ml @@ -4,22 +4,43 @@ open Types open Values type size = int32 (* number of pages *) + type address = int64 + type offset = int32 -type pack_size = Pack8 | Pack16 | Pack32 -type extension = SX | ZX + +type pack_size = + | Pack8 + | Pack16 + | Pack32 + +type extension = + | SX + | ZX + type memory' = (int, int8_unsigned_elt, c_layout) Array1.t -type memory = { mutable content : memory'; max : size option } + +type memory = + { mutable content : memory' + ; max : size option + } + type t = memory exception Type + exception Bounds + exception SizeOverflow + exception SizeLimit + exception OutOfMemory let page_size = 0x10000L (* 64 KiB *) + let packed_size = function Pack8 -> 1 | Pack16 -> 2 | Pack32 -> 4 + let within_limits n = function None -> true | Some max -> I32.le_u n max let create n = @@ -37,7 +58,9 @@ let alloc (MemoryType { min; max }) = { content = create min; max } let bound mem = Array1_64.dim mem.content + let size mem = Int64.(to_int32 (div (bound mem) page_size)) + let type_of mem = MemoryType { min = size mem; max = mem.max } let grow mem delta = @@ -94,7 +117,7 @@ let storen mem a o n x = let rec loop a n x = if n > 0 then ( Int64.(loop (add a 1L) (n - 1) (shift_right x 8)); - store_byte mem a (Int64.to_int x land 0xff)) + store_byte mem a (Int64.to_int x land 0xff) ) in loop (effective_address a o) n x @@ -119,8 +142,8 @@ let store_value mem a o v = let extend x n = function | ZX -> x | SX -> - let sh = 64 - (8 * n) in - Int64.(shift_right (shift_left x sh) sh) + let sh = 64 - (8 * n) in + Int64.(shift_right (shift_left x sh) sh) let load_packed sz ext mem a o t = assert (packed_size sz <= Types.size t); diff --git a/src/interpreter/runtime/memory.mli b/src/interpreter/runtime/memory.mli index 17b7e950..74561458 100644 --- a/src/interpreter/runtime/memory.mli +++ b/src/interpreter/runtime/memory.mli @@ -2,32 +2,57 @@ open Types open Values type memory + type t = memory + type size = int32 (* number of pages *) + type address = int64 + type offset = int32 -type pack_size = Pack8 | Pack16 | Pack32 -type extension = SX | ZX + +type pack_size = + | Pack8 + | Pack16 + | Pack32 + +type extension = + | SX + | ZX exception Type + exception Bounds + exception SizeOverflow + exception SizeLimit + exception OutOfMemory val page_size : int64 + val packed_size : pack_size -> int + val alloc : memory_type -> memory (* raises SizeOverflow, OutOfMemory *) + val type_of : memory -> memory_type + val size : memory -> size + val bound : memory -> address + val grow : memory -> size -> unit + val memcpy : memory -> memory (* raises SizeLimit, SizeOverflow, OutOfMemory *) val load_byte : memory -> address -> int (* raises Bounds *) + val store_byte : memory -> address -> int -> unit (* raises Bounds *) + val load_bytes : memory -> address -> int -> string (* raises Bounds *) + val store_bytes : memory -> address -> string -> unit (* raises Bounds *) val load_value : diff --git a/src/interpreter/runtime/table.ml b/src/interpreter/runtime/table.ml index 30eacdb9..97f305c5 100644 --- a/src/interpreter/runtime/table.ml +++ b/src/interpreter/runtime/table.ml @@ -1,21 +1,27 @@ open Types type size = int32 + type index = int32 + type elem = .. + type elem += Uninitialized + type table' = elem array -type table = { - mutable content : table'; - max : size option; - elem_type : elem_type; -} +type table = + { mutable content : table' + ; max : size option + ; elem_type : elem_type + } type t = table exception Bounds + exception SizeOverflow + exception SizeLimit let within_limits size = function None -> true | Some max -> I32.le_u size max @@ -29,6 +35,7 @@ let alloc (TableType ({ min; max }, elem_type)) = { content = create min; max; elem_type } let size tab = Lib.Array32.length tab.content + let type_of tab = TableType ({ min = size tab; max = tab.max }, tab.elem_type) let grow tab delta = diff --git a/src/interpreter/runtime/table.mli b/src/interpreter/runtime/table.mli index 143ee63e..dfd2e8d2 100644 --- a/src/interpreter/runtime/table.mli +++ b/src/interpreter/runtime/table.mli @@ -1,20 +1,33 @@ open Types type table + type t = table + type size = int32 + type index = int32 + type elem = .. + type elem += Uninitialized exception Bounds + exception SizeOverflow + exception SizeLimit val alloc : table_type -> table + val type_of : table -> table_type + val size : table -> size + val grow : table -> size -> unit (* raises SizeOverflow, SizeLimit *) + val load : table -> index -> elem (* raises Bounds *) + val store : table -> index -> elem -> unit (* raises Bounds *) + val blit : table -> index -> elem list -> unit (* raises Bounds *) diff --git a/src/interpreter/script/import.ml b/src/interpreter/script/import.ml index 6b8b4f74..405b1fef 100644 --- a/src/interpreter/script/import.ml +++ b/src/interpreter/script/import.ml @@ -11,6 +11,7 @@ module Registry = Map.Make (struct end) let registry = ref Registry.empty + let register name lookup = registry := Registry.add name lookup !registry let lookup (m : module_) (im : import) : Instance.extern = @@ -19,7 +20,7 @@ let lookup (m : module_) (im : import) : Instance.extern = try Registry.find module_name !registry item_name t with Not_found -> Unknown.error im.at - ("unknown import \"" ^ string_of_name module_name ^ "\".\"" - ^ string_of_name item_name ^ "\"") + ( "unknown import \"" ^ string_of_name module_name ^ "\".\"" + ^ string_of_name item_name ^ "\"" ) let link m = List.map (lookup m) m.it.imports diff --git a/src/interpreter/script/import.mli b/src/interpreter/script/import.mli index 7919297e..6be19a04 100644 --- a/src/interpreter/script/import.mli +++ b/src/interpreter/script/import.mli @@ -3,6 +3,6 @@ exception Unknown of Source.region * string val link : Ast.module_ -> Instance.extern list (* raises Unknown *) val register : - Ast.name -> - (Ast.name -> Types.extern_type -> Instance.extern (* raises Not_found *)) -> - unit + Ast.name + -> (Ast.name -> Types.extern_type -> Instance.extern (* raises Not_found *)) + -> unit diff --git a/src/interpreter/script/js.ml b/src/interpreter/script/js.ml index db4524f7..48e09f7e 100644 --- a/src/interpreter/script/js.ml +++ b/src/interpreter/script/js.ml @@ -150,7 +150,11 @@ end) module Map = Map.Make (String) type exports = extern_type NameMap.t -type modules = { mutable env : exports Map.t; mutable current : int } + +type modules = + { mutable env : exports Map.t + ; mutable current : int + } let exports m : exports = List.fold_left @@ -158,6 +162,7 @@ let exports m : exports = NameMap.empty m.it.exports let modules () : modules = { env = Map.empty; current = 0 } + let current_var (mods : modules) = "$" ^ string_of_int mods.current let of_var_opt (mods : modules) = function @@ -176,16 +181,16 @@ let lookup (mods : modules) x_opt name at = with Not_found -> raise (Eval.Crash - ( at, - if x_opt = None then "no module defined within script" + ( at + , if x_opt = None then "no module defined within script" else "unknown module " ^ of_var_opt mods x_opt ^ " within script" - )) + ) ) in try NameMap.find name exports with Not_found -> raise (Eval.Crash - (at, "unknown export \"" ^ string_of_name name ^ "\" within module")) + (at, "unknown export \"" ^ string_of_name name ^ "\" within module") ) (* Wrappers *) @@ -214,51 +219,50 @@ let abs_mask_of = function | I64Type | F64Type -> Values.I64 Int64.max_int let invoke ft lits at = - ( [ ft @@ at ], - FuncImport (1l @@ at) @@ at, - List.map (fun lit -> Const lit @@ at) lits @ [ Call (0l @@ at) @@ at ] ) + ( [ ft @@ at ] + , FuncImport (1l @@ at) @@ at + , List.map (fun lit -> Const lit @@ at) lits @ [ Call (0l @@ at) @@ at ] ) let get t at = ([], GlobalImport t @@ at, [ GlobalGet (0l @@ at) @@ at ]) + let run _ _ = ([], []) let assert_return ress _ at = let test res = match res.it with | LitResult lit -> - let t', reinterpret = reinterpret_of (Values.type_of lit.it) in - [ - reinterpret @@ at; - Const lit @@ at; - reinterpret @@ at; - Compare (eq_of t') @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at; - ] + let t', reinterpret = reinterpret_of (Values.type_of lit.it) in + [ reinterpret @@ at + ; Const lit @@ at + ; reinterpret @@ at + ; Compare (eq_of t') @@ at + ; Test (Values.I32 I32Op.Eqz) @@ at + ; BrIf (0l @@ at) @@ at + ] | NanResult nanop -> - let nan = - match nanop.it with - | Values.I32 _ | Values.I64 _ -> assert false - | Values.F32 n | Values.F64 n -> n - in - let nan_bitmask_of = - match nan with - | CanonicalNan -> - abs_mask_of - (* must only differ from the canonical NaN in its sign bit *) - | ArithmeticNan -> canonical_nan_of - (* can be any NaN that's one everywhere the canonical NaN is one *) - in - let t = Values.type_of nanop.it in - let t', reinterpret = reinterpret_of t in - [ - reinterpret @@ at; - Const (nan_bitmask_of t' @@ at) @@ at; - Binary (and_of t') @@ at; - Const (canonical_nan_of t' @@ at) @@ at; - Compare (eq_of t') @@ at; - Test (Values.I32 I32Op.Eqz) @@ at; - BrIf (0l @@ at) @@ at; - ] + let nan = + match nanop.it with + | Values.I32 _ | Values.I64 _ -> assert false + | Values.F32 n | Values.F64 n -> n + in + let nan_bitmask_of = + match nan with + | CanonicalNan -> + abs_mask_of + (* must only differ from the canonical NaN in its sign bit *) + | ArithmeticNan -> canonical_nan_of + (* can be any NaN that's one everywhere the canonical NaN is one *) + in + let t = Values.type_of nanop.it in + let t', reinterpret = reinterpret_of t in + [ reinterpret @@ at + ; Const (nan_bitmask_of t' @@ at) @@ at + ; Binary (and_of t') @@ at + ; Const (canonical_nan_of t' @@ at) @@ at + ; Compare (eq_of t') @@ at + ; Test (Values.I32 I32Op.Eqz) @@ at + ; BrIf (0l @@ at) @@ at + ] in ([], List.flatten (List.rev_map test ress)) @@ -271,8 +275,8 @@ let wrap module_name item_name wrap_action wrap_assertion at = let edesc = FuncExport item @@ at in let exports = [ { name = Utf8.decode "run"; edesc } @@ at ] in let body = - [ - Block ([], action @ assertion @ [ Return @@ at ]) @@ at; Unreachable @@ at; + [ Block ([], action @ assertion @ [ Return @@ at ]) @@ at + ; Unreachable @@ at ] in let funcs = [ { ftype = 0l @@ at; locals; body } @@ at ] in @@ -297,7 +301,7 @@ let add_char buf c = if c < '\x20' || c >= '\x7f' then add_hex_char buf c else ( if c = '\"' || c = '\\' then Buffer.add_char buf '\\'; - Buffer.add_char buf c) + Buffer.add_char buf c ) let add_unicode_char buf uc = if uc < 0x20 || uc >= 0x7f then Printf.bprintf buf "\\u{%02x}" uc @@ -311,7 +315,9 @@ let of_string_with iter add_char s = Buffer.contents buf let of_bytes = of_string_with String.iter add_hex_char + let of_string = of_string_with String.iter add_char + let of_name = of_string_with List.iter add_unicode_char let of_float z = @@ -337,17 +343,17 @@ let of_result res = match res.it with | LitResult lit -> of_literal lit | NanResult nanop -> ( - match nanop.it with - | Values.I32 _ | Values.I64 _ -> assert false - | Values.F32 n | Values.F64 n -> of_nan n) + match nanop.it with + | Values.I32 _ | Values.I64 _ -> assert false + | Values.F32 n | Values.F64 n -> of_nan n ) let rec of_definition def = match def.it with | Textual m -> of_bytes (Encode.encode m) | Encoded (_, bs) -> of_bytes bs | Quoted (_, s) -> ( - try of_definition (Parse.string_to_module s) - with Parse.Syntax _ -> of_bytes "") + try of_definition (Parse.string_to_module s) + with Parse.Syntax _ -> of_bytes "" ) let of_wrapper mods x_opt name wrap_action wrap_assertion at = let x = of_var_opt mods x_opt in @@ -357,22 +363,22 @@ let of_wrapper mods x_opt name wrap_action wrap_assertion at = let of_action mods act = match act.it with - | Invoke (x_opt, name, lits) -> ( - ( "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^ "[" - ^ String.concat ", " (List.map of_literal lits) - ^ "])", - match lookup mods x_opt name act.at with - | ExternFuncType ft when not (is_js_func_type ft) -> - let (FuncType (_, out)) = ft in - Some (of_wrapper mods x_opt name (invoke ft lits), out) - | _ -> None )) - | Get (x_opt, name) -> ( - ( "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")", - match lookup mods x_opt name act.at with - | ExternGlobalType gt when not (is_js_global_type gt) -> - let (GlobalType (t, _)) = gt in - Some (of_wrapper mods x_opt name (get gt), [ t ]) - | _ -> None )) + | Invoke (x_opt, name, lits) -> + ( "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^ "[" + ^ String.concat ", " (List.map of_literal lits) + ^ "])" + , match lookup mods x_opt name act.at with + | ExternFuncType ft when not (is_js_func_type ft) -> + let (FuncType (_, out)) = ft in + Some (of_wrapper mods x_opt name (invoke ft lits), out) + | _ -> None ) + | Get (x_opt, name) -> + ( "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")" + , match lookup mods x_opt name act.at with + | ExternGlobalType gt when not (is_js_global_type gt) -> + let (GlobalType (t, _)) = gt in + Some (of_wrapper mods x_opt name (get gt), [ t ]) + | _ -> None ) let of_assertion' mods act name args wrapper_opt = let act_js, act_wrapper_opt = of_action mods act in @@ -380,12 +386,12 @@ let of_assertion' mods act name args wrapper_opt = match act_wrapper_opt with | None -> js ^ ";" | Some (act_wrapper, out) -> - let run_name, wrapper = - match wrapper_opt with - | None -> (name, run) - | Some wrapper -> ("run", wrapper) - in - run_name ^ "(() => " ^ act_wrapper (wrapper out) act.at ^ "); // " ^ js + let run_name, wrapper = + match wrapper_opt with + | None -> (name, run) + | Some wrapper -> ("run", wrapper) + in + run_name ^ "(() => " ^ act_wrapper (wrapper out) act.at ^ "); // " ^ js let of_assertion mods ass = match ass.it with @@ -393,13 +399,13 @@ let of_assertion mods ass = | AssertInvalid (def, _) -> "assert_invalid(" ^ of_definition def ^ ");" | AssertUnlinkable (def, _) -> "assert_unlinkable(" ^ of_definition def ^ ");" | AssertUninstantiable (def, _) -> - "assert_uninstantiable(" ^ of_definition def ^ ");" + "assert_uninstantiable(" ^ of_definition def ^ ");" | AssertReturn (act, ress) -> - of_assertion' mods act "assert_return" (List.map of_result ress) - (Some (assert_return ress)) + of_assertion' mods act "assert_return" (List.map of_result ress) + (Some (assert_return ress)) | AssertTrap (act, _) -> of_assertion' mods act "assert_trap" [] None | AssertExhaustion (act, _) -> - of_assertion' mods act "assert_exhaustion" [] None + of_assertion' mods act "assert_exhaustion" [] None let of_command mods cmd = "\n// " @@ -410,19 +416,19 @@ let of_command mods cmd = ^ match cmd.it with | Module (x_opt, def) -> - let rec unquote def = - match def.it with - | Textual m -> m - | Encoded (_, bs) -> Decode.decode "binary" bs - | Quoted (_, s) -> unquote (Parse.string_to_module s) - in - bind mods x_opt (unquote def); - "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" - ^ - if x_opt = None then "" - else "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n" + let rec unquote def = + match def.it with + | Textual m -> m + | Encoded (_, bs) -> Decode.decode "binary" bs + | Quoted (_, s) -> unquote (Parse.string_to_module s) + in + bind mods x_opt (unquote def); + "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" + ^ + if x_opt = None then "" + else "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n" | Register (name, x_opt) -> - "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n" + "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n" | Action act -> of_assertion' mods act "run" [] None ^ "\n" | Assertion ass -> of_assertion mods ass ^ "\n" | Meta _ -> assert false diff --git a/src/interpreter/script/run.ml b/src/interpreter/script/run.ml index 44d635c1..978922ea 100644 --- a/src/interpreter/script/run.ml +++ b/src/interpreter/script/run.ml @@ -8,7 +8,9 @@ module Assert = Error.Make () module IO = Error.Make () exception Abort = Abort.Error + exception Assert = Assert.Error + exception IO = IO.Error let trace name = if !Flags.trace then print_endline ("-- " ^ name) @@ -16,9 +18,13 @@ let trace name = if !Flags.trace then print_endline ("-- " ^ name) (* File types *) let binary_ext = "wasm" + let sexpr_ext = "wat" + let script_binary_ext = "bin.wast" + let script_ext = "wast" + let js_ext = "js" let dispatch_file_ext on_binary on_sexpr on_script_binary on_script on_js file = @@ -120,7 +126,7 @@ let input_sexpr name lexbuf run = input_from (fun _ -> let var_opt, def = Parse.parse name lexbuf Parse.Module in - [ Module (var_opt, def) @@ no_region ]) + [ Module (var_opt, def) @@ no_region ] ) run let input_binary name buf run = @@ -263,9 +269,9 @@ let string_of_result r = match r with | LitResult v -> Values.string_of_value v.it | NanResult nanop -> ( - match nanop.it with - | Values.I32 _ | Values.I64 _ -> assert false - | Values.F32 n | Values.F64 n -> string_of_nan n) + match nanop.it with + | Values.I32 _ | Values.I64 _ -> assert false + | Values.F32 n | Values.F64 n -> string_of_nan n ) let string_of_results = function | [ r ] -> string_of_result r @@ -282,9 +288,13 @@ let print_results rs = module Map = Map.Make (String) let quote : script ref = ref [] + let scripts : script Map.t ref = ref Map.empty + let modules : Ast.module_ Map.t ref = ref Map.empty + let instances : Instance.module_inst Map.t ref = ref Map.empty + let registry : Instance.module_inst Map.t ref = ref Map.empty let bind map x_opt y = @@ -296,11 +306,13 @@ let lookup category map x_opt at = try Map.find key !map with Not_found -> IO.error at - (if key = "" then "no " ^ category ^ " defined" - else "unknown " ^ category ^ " " ^ key) + ( if key = "" then "no " ^ category ^ " defined" + else "unknown " ^ category ^ " " ^ key ) let lookup_script = lookup "script" scripts + let lookup_module = lookup "module" modules + let lookup_instance = lookup "module" instances let lookup_registry module_name item_name _t = @@ -314,30 +326,30 @@ let rec run_definition def : Ast.module_ = match def.it with | Textual m -> m | Encoded (name, bs) -> - trace "Decoding..."; - Decode.decode name bs + trace "Decoding..."; + Decode.decode name bs | Quoted (_, s) -> - trace "Parsing quote..."; - let def' = Parse.string_to_module s in - run_definition def' + trace "Parsing quote..."; + let def' = Parse.string_to_module s in + run_definition def' let run_action act : Values.value list = match act.it with | Invoke (x_opt, name, vs) -> ( - trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in - match Instance.export inst name with - | Some (Instance.ExternFunc f) -> - Eval.invoke f (List.map (fun v -> v.it) vs) - | Some _ -> Assert.error act.at "export is not a function" - | None -> Assert.error act.at "undefined export") + trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + match Instance.export inst name with + | Some (Instance.ExternFunc f) -> + Eval.invoke f (List.map (fun v -> v.it) vs) + | Some _ -> Assert.error act.at "export is not a function" + | None -> Assert.error act.at "undefined export" ) | Get (x_opt, name) -> ( - trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in - match Instance.export inst name with - | Some (Instance.ExternGlobal gl) -> [ Global.load gl ] - | Some _ -> Assert.error act.at "export is not a global" - | None -> Assert.error act.at "undefined export") + trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + match Instance.export inst name with + | Some (Instance.ExternGlobal gl) -> [ Global.load gl ] + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" ) let assert_result at got expect = let open Values in @@ -348,23 +360,23 @@ let assert_result at got expect = match r with | LitResult v' -> v <> v'.it | NanResult nanop -> ( - match (nanop.it, v) with - | F32 CanonicalNan, F32 z -> z <> F32.pos_nan && z <> F32.neg_nan - | F64 CanonicalNan, F64 z -> z <> F64.pos_nan && z <> F64.neg_nan - | F32 ArithmeticNan, F32 z -> - let pos_nan = F32.to_bits F32.pos_nan in - Int32.logand (F32.to_bits z) pos_nan <> pos_nan - | F64 ArithmeticNan, F64 z -> - let pos_nan = F64.to_bits F64.pos_nan in - Int64.logand (F64.to_bits z) pos_nan <> pos_nan - | _, _ -> false)) + match (nanop.it, v) with + | F32 CanonicalNan, F32 z -> z <> F32.pos_nan && z <> F32.neg_nan + | F64 CanonicalNan, F64 z -> z <> F64.pos_nan && z <> F64.neg_nan + | F32 ArithmeticNan, F32 z -> + let pos_nan = F32.to_bits F32.pos_nan in + Int32.logand (F32.to_bits z) pos_nan <> pos_nan + | F64 ArithmeticNan, F64 z -> + let pos_nan = F64.to_bits F64.pos_nan in + Int64.logand (F64.to_bits z) pos_nan <> pos_nan + | _, _ -> false ) ) got expect then ( print_string "Result: "; print_values got; print_string "Expect: "; print_results expect; - Assert.error at "wrong return values") + Assert.error at "wrong return values" ) let assert_message at name msg re = if @@ -373,138 +385,138 @@ let assert_message at name msg re = then ( print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error at ("wrong " ^ name ^ " error")) + Assert.error at ("wrong " ^ name ^ " error") ) let run_assertion ass = match ass.it with | AssertMalformed (def, re) -> ( - trace "Asserting malformed..."; - match ignore (run_definition def) with - | exception Decode.Code (_, msg) -> - assert_message ass.at "decoding" msg re - | exception Parse.Syntax (_, msg) -> - assert_message ass.at "parsing" msg re - | _ -> Assert.error ass.at "expected decoding/parsing error") + trace "Asserting malformed..."; + match ignore (run_definition def) with + | exception Decode.Code (_, msg) -> assert_message ass.at "decoding" msg re + | exception Parse.Syntax (_, msg) -> assert_message ass.at "parsing" msg re + | _ -> Assert.error ass.at "expected decoding/parsing error" ) | AssertInvalid (def, re) -> ( - trace "Asserting invalid..."; - match - let m = run_definition def in - Valid.check_module m - with - | exception Valid.Invalid (_, msg) -> - assert_message ass.at "validation" msg re - | _ -> Assert.error ass.at "expected validation error") - | AssertUnlinkable (def, re) -> ( - trace "Asserting unlinkable..."; + trace "Asserting invalid..."; + match let m = run_definition def in - if not !Flags.unchecked then Valid.check_module m; - match - let imports = Import.link m in - ignore (Eval.init m imports) - with - | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> - assert_message ass.at "linking" msg re - | _ -> Assert.error ass.at "expected linking error") + Valid.check_module m + with + | exception Valid.Invalid (_, msg) -> + assert_message ass.at "validation" msg re + | _ -> Assert.error ass.at "expected validation error" ) + | AssertUnlinkable (def, re) -> ( + trace "Asserting unlinkable..."; + let m = run_definition def in + if not !Flags.unchecked then Valid.check_module m; + match + let imports = Import.link m in + ignore (Eval.init m imports) + with + | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> + assert_message ass.at "linking" msg re + | _ -> Assert.error ass.at "expected linking error" ) | AssertUninstantiable (def, re) -> ( - trace "Asserting trap..."; - let m = run_definition def in - if not !Flags.unchecked then Valid.check_module m; - match - let imports = Import.link m in - ignore (Eval.init m imports) - with - | exception Eval.Trap (_, msg) -> - assert_message ass.at "instantiation" msg re - | _ -> Assert.error ass.at "expected instantiation error") + trace "Asserting trap..."; + let m = run_definition def in + if not !Flags.unchecked then Valid.check_module m; + match + let imports = Import.link m in + ignore (Eval.init m imports) + with + | exception Eval.Trap (_, msg) -> + assert_message ass.at "instantiation" msg re + | _ -> Assert.error ass.at "expected instantiation error" ) | AssertReturn (act, rs) -> - trace "Asserting return..."; - let got_vs = run_action act in - let expect_rs = List.map (fun r -> r.it) rs in - assert_result ass.at got_vs expect_rs + trace "Asserting return..."; + let got_vs = run_action act in + let expect_rs = List.map (fun r -> r.it) rs in + assert_result ass.at got_vs expect_rs | AssertTrap (act, re) -> ( - trace "Asserting trap..."; - match run_action act with - | exception Eval.Trap (_, msg) -> assert_message ass.at "runtime" msg re - | _ -> Assert.error ass.at "expected runtime error") + trace "Asserting trap..."; + match run_action act with + | exception Eval.Trap (_, msg) -> assert_message ass.at "runtime" msg re + | _ -> Assert.error ass.at "expected runtime error" ) | AssertExhaustion (act, re) -> ( - trace "Asserting exhaustion..."; - match run_action act with - | exception Eval.Exhaustion (_, msg) -> - assert_message ass.at "exhaustion" msg re - | _ -> Assert.error ass.at "expected exhaustion error") + trace "Asserting exhaustion..."; + match run_action act with + | exception Eval.Exhaustion (_, msg) -> + assert_message ass.at "exhaustion" msg re + | _ -> Assert.error ass.at "expected exhaustion error" ) let rec run_command cmd = match cmd.it with | Module (x_opt, def) -> - quote := cmd :: !quote; - let m = run_definition def in - if not !Flags.unchecked then ( - trace "Checking..."; - Valid.check_module m; - if !Flags.print_sig then ( - trace "Signature:"; - print_module x_opt m)); - bind scripts x_opt [ cmd ]; - bind modules x_opt m; - if not !Flags.dry then ( - trace "Initializing..."; - let imports = Import.link m in - let inst = Eval.init m imports in - bind instances x_opt inst) + quote := cmd :: !quote; + let m = run_definition def in + if not !Flags.unchecked then ( + trace "Checking..."; + Valid.check_module m; + if !Flags.print_sig then ( + trace "Signature:"; + print_module x_opt m ) ); + bind scripts x_opt [ cmd ]; + bind modules x_opt m; + if not !Flags.dry then ( + trace "Initializing..."; + let imports = Import.link m in + let inst = Eval.init m imports in + bind instances x_opt inst ) | Register (name, x_opt) -> - quote := cmd :: !quote; - if not !Flags.dry then ( - trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt cmd.at in - registry := Map.add (Utf8.encode name) inst !registry; - Import.register name (lookup_registry (Utf8.encode name))) + quote := cmd :: !quote; + if not !Flags.dry then ( + trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt cmd.at in + registry := Map.add (Utf8.encode name) inst !registry; + Import.register name (lookup_registry (Utf8.encode name)) ) | Action act -> - quote := cmd :: !quote; - if not !Flags.dry then - let vs = run_action act in - if vs <> [] then print_values vs + quote := cmd :: !quote; + if not !Flags.dry then + let vs = run_action act in + if vs <> [] then print_values vs | Assertion ass -> - quote := cmd :: !quote; - if not !Flags.dry then run_assertion ass + quote := cmd :: !quote; + if not !Flags.dry then run_assertion ass | Meta cmd -> run_meta cmd and run_meta cmd = match cmd.it with | Script (x_opt, script) -> - run_quote_script script; - bind scripts x_opt (lookup_script None cmd.at) + run_quote_script script; + bind scripts x_opt (lookup_script None cmd.at) | Input (x_opt, file) -> - (try - if not (input_file file run_quote_script) then - Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg); - bind scripts x_opt (lookup_script None cmd.at); - if x_opt <> None then ( - bind modules x_opt (lookup_module None cmd.at); - if not !Flags.dry then - bind instances x_opt (lookup_instance None cmd.at)) + ( try + if not (input_file file run_quote_script) then + Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg ); + bind scripts x_opt (lookup_script None cmd.at); + if x_opt <> None then ( + bind modules x_opt (lookup_module None cmd.at); + if not !Flags.dry then bind instances x_opt (lookup_instance None cmd.at) + ) | Output (x_opt, Some file) -> ( - try - output_file file - (fun () -> lookup_script x_opt cmd.at) - (fun () -> lookup_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) + try + output_file file + (fun () -> lookup_script x_opt cmd.at) + (fun () -> lookup_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg ) | Output (x_opt, None) -> ( - try output_stdout (fun () -> lookup_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) + try output_stdout (fun () -> lookup_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg ) and run_script script = List.iter run_command script and run_quote_script script = let save_quote = !quote in quote := []; - (try run_script script - with exn -> - quote := save_quote; - raise exn); + ( try run_script script + with exn -> + quote := save_quote; + raise exn ); bind scripts None (List.rev !quote); quote := !quote @ save_quote let run_file file = input_file file run_script + let run_string string = input_string string run_script + let run_stdin () = input_stdin run_script diff --git a/src/interpreter/script/run.mli b/src/interpreter/script/run.mli index 986e989e..ffff21d9 100644 --- a/src/interpreter/script/run.mli +++ b/src/interpreter/script/run.mli @@ -1,8 +1,13 @@ exception Abort of Source.region * string + exception Assert of Source.region * string + exception IO of Source.region * string val trace : string -> unit + val run_string : string -> bool + val run_file : string -> bool + val run_stdin : unit -> unit diff --git a/src/interpreter/script/script.ml b/src/interpreter/script/script.ml index c8d2ce7e..427585f8 100644 --- a/src/interpreter/script/script.ml +++ b/src/interpreter/script/script.ml @@ -14,11 +14,18 @@ and action' = | Get of var option * Ast.name type nanop = nanop' Source.phrase + and nanop' = (unit, unit, nan, nan) Values.op -and nan = CanonicalNan | ArithmeticNan + +and nan = + | CanonicalNan + | ArithmeticNan type result = result' Source.phrase -and result' = LitResult of Ast.literal | NanResult of nanop + +and result' = + | LitResult of Ast.literal + | NanResult of nanop type assertion = assertion' Source.phrase diff --git a/src/interpreter/syntax/ast.ml b/src/interpreter/syntax/ast.ml index f5aa5103..7373319e 100644 --- a/src/interpreter/syntax/ast.ml +++ b/src/interpreter/syntax/ast.ml @@ -21,7 +21,10 @@ open Types (* Operators *) module IntOp = struct - type unop = Clz | Ctz | Popcnt + type unop = + | Clz + | Ctz + | Popcnt type binop = | Add @@ -41,7 +44,18 @@ module IntOp = struct | Rotr type testop = Eqz - type relop = Eq | Ne | LtS | LtU | GtS | GtU | LeS | LeU | GeS | GeU + + type relop = + | Eq + | Ne + | LtS + | LtU + | GtS + | GtU + | LeS + | LeU + | GeS + | GeU type cvtop = | ExtendSI32 @@ -55,10 +69,33 @@ module IntOp = struct end module FloatOp = struct - type unop = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt - type binop = Add | Sub | Mul | Div | Min | Max | CopySign + type unop = + | Neg + | Abs + | Ceil + | Floor + | Trunc + | Nearest + | Sqrt + + type binop = + | Add + | Sub + | Mul + | Div + | Min + | Max + | CopySign + type testop - type relop = Eq | Ne | Lt | Gt | Le | Ge + + type relop = + | Eq + | Ne + | Lt + | Gt + | Le + | Ge type cvtop = | ConvertSI32 @@ -76,25 +113,32 @@ module F32Op = FloatOp module F64Op = FloatOp type unop = (I32Op.unop, I64Op.unop, F32Op.unop, F64Op.unop) Values.op + type binop = (I32Op.binop, I64Op.binop, F32Op.binop, F64Op.binop) Values.op + type testop = (I32Op.testop, I64Op.testop, F32Op.testop, F64Op.testop) Values.op + type relop = (I32Op.relop, I64Op.relop, F32Op.relop, F64Op.relop) Values.op + type cvtop = (I32Op.cvtop, I64Op.cvtop, F32Op.cvtop, F64Op.cvtop) Values.op -type 'a memop = { - ty : value_type; - align : int; - offset : Memory.offset; - sz : 'a option; -} +type 'a memop = + { ty : value_type + ; align : int + ; offset : Memory.offset + ; sz : 'a option + } type loadop = (Memory.pack_size * Memory.extension) memop + type storeop = Memory.pack_size memop (* Expressions *) type var = int32 Source.phrase + type literal = Values.value Source.phrase + type name = int list type instr = instr' Source.phrase @@ -162,23 +206,40 @@ and instr' = type const = instr list Source.phrase type global = global' Source.phrase -and global' = { gtype : global_type; value : const } + +and global' = + { gtype : global_type + ; value : const + } type func = func' Source.phrase -and func' = { ftype : var; locals : value_type list; body : instr list } + +and func' = + { ftype : var + ; locals : value_type list + ; body : instr list + } (* Tables & Memories *) type table = table' Source.phrase + and table' = { ttype : table_type } type memory = memory' Source.phrase + and memory' = { mtype : memory_type } type 'data segment = 'data segment' Source.phrase -and 'data segment' = { index : var; offset : const; init : 'data } + +and 'data segment' = + { index : var + ; offset : const + ; init : 'data + } type table_segment = var list segment + type memory_segment = string segment (* Modules *) @@ -194,7 +255,11 @@ and export_desc' = | GlobalExport of var type export = export' Source.phrase -and export' = { name : name; edesc : export_desc } + +and export' = + { name : name + ; edesc : export_desc + } type import_desc = import_desc' Source.phrase @@ -205,37 +270,41 @@ and import_desc' = | GlobalImport of global_type type import = import' Source.phrase -and import' = { module_name : name; item_name : name; idesc : import_desc } + +and import' = + { module_name : name + ; item_name : name + ; idesc : import_desc + } type module_ = module_' Source.phrase -and module_' = { - types : type_ list; - globals : global list; - tables : table list; - memories : memory list; - funcs : func list; - start : var option; - elems : var list segment list; - data : string segment list; - imports : import list; - exports : export list; -} +and module_' = + { types : type_ list + ; globals : global list + ; tables : table list + ; memories : memory list + ; funcs : func list + ; start : var option + ; elems : var list segment list + ; data : string segment list + ; imports : import list + ; exports : export list + } (* Auxiliary functions *) let empty_module = - { - types = []; - globals = []; - tables = []; - memories = []; - funcs = []; - start = None; - elems = []; - data = []; - imports = []; - exports = []; + { types = [] + ; globals = [] + ; tables = [] + ; memories = [] + ; funcs = [] + ; start = None + ; elems = [] + ; data = [] + ; imports = [] + ; exports = [] } open Source @@ -257,19 +326,19 @@ let export_type (m : module_) (ex : export) : extern_type = let open Lib.List32 in match edesc.it with | FuncExport x -> - let fts = - funcs its @ List.map (fun f -> func_type_for m f.it.ftype) m.it.funcs - in - ExternFuncType (nth fts x.it) + let fts = + funcs its @ List.map (fun f -> func_type_for m f.it.ftype) m.it.funcs + in + ExternFuncType (nth fts x.it) | TableExport x -> - let tts = tables its @ List.map (fun t -> t.it.ttype) m.it.tables in - ExternTableType (nth tts x.it) + let tts = tables its @ List.map (fun t -> t.it.ttype) m.it.tables in + ExternTableType (nth tts x.it) | MemoryExport x -> - let mts = memories its @ List.map (fun m -> m.it.mtype) m.it.memories in - ExternMemoryType (nth mts x.it) + let mts = memories its @ List.map (fun m -> m.it.mtype) m.it.memories in + ExternMemoryType (nth mts x.it) | GlobalExport x -> - let gts = globals its @ List.map (fun g -> g.it.gtype) m.it.globals in - ExternGlobalType (nth gts x.it) + let gts = globals its @ List.map (fun g -> g.it.gtype) m.it.globals in + ExternGlobalType (nth gts x.it) let string_of_name n = let b = Buffer.create 16 in diff --git a/src/interpreter/syntax/operators.ml b/src/interpreter/syntax/operators.ml index f7432f03..63df1e62 100644 --- a/src/interpreter/syntax/operators.ml +++ b/src/interpreter/syntax/operators.ml @@ -5,45 +5,79 @@ open Memory open Ast let i32_const n = Const (I32 n.it @@ n.at) + let i64_const n = Const (I64 n.it @@ n.at) + let f32_const n = Const (F32 n.it @@ n.at) + let f64_const n = Const (F64 n.it @@ n.at) + let unreachable = Unreachable + let nop = Nop + let drop = Drop + let select = Select + let block ts es = Block (ts, es) + let loop ts es = Loop (ts, es) + let br x = Br x + let br_if x = BrIf x + let br_table xs x = BrTable (xs, x) + let if_ ts es1 es2 = If (ts, es1, es2) + let return = Return + let call x = Call x + let call_indirect x = CallIndirect x + let local_get x = LocalGet x + let local_set x = LocalSet x + let local_tee x = LocalTee x + let global_get x = GlobalGet x + let global_set x = GlobalSet x (* NEW OPERATIONS *) let duplicate = Dup + let get_sym_int32 x = GetSymInt32 x + let get_sym_int64 x = GetSymInt64 x + let get_sym_float32 x = GetSymFloat32 x + let get_sym_float64 x = GetSymFloat64 x + let print_stack = PrintStack + let print_memory = PrintMemory + let print_btree = PrintBtree + let print_pc = PrintPC + let print_value = PrintValue + let compare_expr = CompareExpr + let set_priority = SetPriority + let pop_priority = PopPriority (* SYMBOLIC EXECUTION *) let sym_assert = SymAssert + let sym_assume = SymAssume let symbolic p = @@ -51,20 +85,32 @@ let symbolic p = Symbolic (t, b) let i32_logand = Boolop (I32 I32Op.And) + let i32_logor = Boolop (I32 I32Op.Or) + let ternary_op = TernaryOp + let alloc = Alloc + let free = Free (* LIBC SUMM APIs *) let is_symbolic = IsSymbolic + let sym_int32 x = SymInt32 x + let sym_int64 x = SymInt64 x + let sym_float32 x = SymFloat32 x + let sym_float64 x = SymFloat64 x + let i32_load align offset = Load { ty = I32Type; align; offset; sz = None } + let i64_load align offset = Load { ty = I64Type; align; offset; sz = None } + let f32_load align offset = Load { ty = F32Type; align; offset; sz = None } + let f64_load align offset = Load { ty = F64Type; align; offset; sz = None } let i32_load8_s align offset = @@ -98,8 +144,11 @@ let i64_load32_u align offset = Load { ty = I64Type; align; offset; sz = Some (Pack32, ZX) } let i32_store align offset = Store { ty = I32Type; align; offset; sz = None } + let i64_store align offset = Store { ty = I64Type; align; offset; sz = None } + let f32_store align offset = Store { ty = F32Type; align; offset; sz = None } + let f64_store align offset = Store { ty = F64Type; align; offset; sz = None } let i32_store8 align offset = @@ -118,127 +167,251 @@ let i64_store32 align offset = Store { ty = I64Type; align; offset; sz = Some Pack32 } let i32_clz = Unary (I32 I32Op.Clz) + let i32_ctz = Unary (I32 I32Op.Ctz) + let i32_popcnt = Unary (I32 I32Op.Popcnt) + let i64_clz = Unary (I64 I64Op.Clz) + let i64_ctz = Unary (I64 I64Op.Ctz) + let i64_popcnt = Unary (I64 I64Op.Popcnt) + let f32_neg = Unary (F32 F32Op.Neg) + let f32_abs = Unary (F32 F32Op.Abs) + let f32_sqrt = Unary (F32 F32Op.Sqrt) + let f32_ceil = Unary (F32 F32Op.Ceil) + let f32_floor = Unary (F32 F32Op.Floor) + let f32_trunc = Unary (F32 F32Op.Trunc) + let f32_nearest = Unary (F32 F32Op.Nearest) + let f64_neg = Unary (F64 F64Op.Neg) + let f64_abs = Unary (F64 F64Op.Abs) + let f64_sqrt = Unary (F64 F64Op.Sqrt) + let f64_ceil = Unary (F64 F64Op.Ceil) + let f64_floor = Unary (F64 F64Op.Floor) + let f64_trunc = Unary (F64 F64Op.Trunc) + let f64_nearest = Unary (F64 F64Op.Nearest) + let i32_add = Binary (I32 I32Op.Add) + let i32_sub = Binary (I32 I32Op.Sub) + let i32_mul = Binary (I32 I32Op.Mul) + let i32_div_s = Binary (I32 I32Op.DivS) + let i32_div_u = Binary (I32 I32Op.DivU) + let i32_rem_s = Binary (I32 I32Op.RemS) + let i32_rem_u = Binary (I32 I32Op.RemU) + let i32_and = Binary (I32 I32Op.And) + let i32_or = Binary (I32 I32Op.Or) + let i32_xor = Binary (I32 I32Op.Xor) + let i32_shl = Binary (I32 I32Op.Shl) + let i32_shr_s = Binary (I32 I32Op.ShrS) + let i32_shr_u = Binary (I32 I32Op.ShrU) + let i32_rotl = Binary (I32 I32Op.Rotl) + let i32_rotr = Binary (I32 I32Op.Rotr) + let i64_add = Binary (I64 I64Op.Add) + let i64_sub = Binary (I64 I64Op.Sub) + let i64_mul = Binary (I64 I64Op.Mul) + let i64_div_s = Binary (I64 I64Op.DivS) + let i64_div_u = Binary (I64 I64Op.DivU) + let i64_rem_s = Binary (I64 I64Op.RemS) + let i64_rem_u = Binary (I64 I64Op.RemU) + let i64_and = Binary (I64 I64Op.And) + let i64_or = Binary (I64 I64Op.Or) + let i64_xor = Binary (I64 I64Op.Xor) + let i64_shl = Binary (I64 I64Op.Shl) + let i64_shr_s = Binary (I64 I64Op.ShrS) + let i64_shr_u = Binary (I64 I64Op.ShrU) + let i64_rotl = Binary (I64 I64Op.Rotl) + let i64_rotr = Binary (I64 I64Op.Rotr) + let f32_add = Binary (F32 F32Op.Add) + let f32_sub = Binary (F32 F32Op.Sub) + let f32_mul = Binary (F32 F32Op.Mul) + let f32_div = Binary (F32 F32Op.Div) + let f32_min = Binary (F32 F32Op.Min) + let f32_max = Binary (F32 F32Op.Max) + let f32_copysign = Binary (F32 F32Op.CopySign) + let f64_add = Binary (F64 F64Op.Add) + let f64_sub = Binary (F64 F64Op.Sub) + let f64_mul = Binary (F64 F64Op.Mul) + let f64_div = Binary (F64 F64Op.Div) + let f64_min = Binary (F64 F64Op.Min) + let f64_max = Binary (F64 F64Op.Max) + let f64_copysign = Binary (F64 F64Op.CopySign) + let i32_eqz = Test (I32 I32Op.Eqz) + let i64_eqz = Test (I64 I64Op.Eqz) + let i32_eq = Compare (I32 I32Op.Eq) + let i32_ne = Compare (I32 I32Op.Ne) + let i32_lt_s = Compare (I32 I32Op.LtS) + let i32_lt_u = Compare (I32 I32Op.LtU) + let i32_le_s = Compare (I32 I32Op.LeS) + let i32_le_u = Compare (I32 I32Op.LeU) + let i32_gt_s = Compare (I32 I32Op.GtS) + let i32_gt_u = Compare (I32 I32Op.GtU) + let i32_ge_s = Compare (I32 I32Op.GeS) + let i32_ge_u = Compare (I32 I32Op.GeU) + let i64_eq = Compare (I64 I64Op.Eq) + let i64_ne = Compare (I64 I64Op.Ne) + let i64_lt_s = Compare (I64 I64Op.LtS) + let i64_lt_u = Compare (I64 I64Op.LtU) + let i64_le_s = Compare (I64 I64Op.LeS) + let i64_le_u = Compare (I64 I64Op.LeU) + let i64_gt_s = Compare (I64 I64Op.GtS) + let i64_gt_u = Compare (I64 I64Op.GtU) + let i64_ge_s = Compare (I64 I64Op.GeS) + let i64_ge_u = Compare (I64 I64Op.GeU) + let f32_eq = Compare (F32 F32Op.Eq) + let f32_ne = Compare (F32 F32Op.Ne) + let f32_lt = Compare (F32 F32Op.Lt) + let f32_le = Compare (F32 F32Op.Le) + let f32_gt = Compare (F32 F32Op.Gt) + let f32_ge = Compare (F32 F32Op.Ge) + let f64_eq = Compare (F64 F64Op.Eq) + let f64_ne = Compare (F64 F64Op.Ne) + let f64_lt = Compare (F64 F64Op.Lt) + let f64_le = Compare (F64 F64Op.Le) + let f64_gt = Compare (F64 F64Op.Gt) + let f64_ge = Compare (F64 F64Op.Ge) + let i32_wrap_i64 = Convert (I32 I32Op.WrapI64) + let i32_trunc_f32_s = Convert (I32 I32Op.TruncSF32) + let i32_trunc_f32_u = Convert (I32 I32Op.TruncUF32) + let i32_trunc_f64_s = Convert (I32 I32Op.TruncSF64) + let i32_trunc_f64_u = Convert (I32 I32Op.TruncUF64) + let i64_extend_i32_s = Convert (I64 I64Op.ExtendSI32) + let i64_extend_i32_u = Convert (I64 I64Op.ExtendUI32) + let i64_trunc_f32_s = Convert (I64 I64Op.TruncSF32) + let i64_trunc_f32_u = Convert (I64 I64Op.TruncUF32) + let i64_trunc_f64_s = Convert (I64 I64Op.TruncSF64) + let i64_trunc_f64_u = Convert (I64 I64Op.TruncUF64) + let f32_convert_i32_s = Convert (F32 F32Op.ConvertSI32) + let f32_convert_i32_u = Convert (F32 F32Op.ConvertUI32) + let f32_convert_i64_s = Convert (F32 F32Op.ConvertSI64) + let f32_convert_i64_u = Convert (F32 F32Op.ConvertUI64) + let f32_demote_f64 = Convert (F32 F32Op.DemoteF64) + let f64_convert_i32_s = Convert (F64 F64Op.ConvertSI32) + let f64_convert_i32_u = Convert (F64 F64Op.ConvertUI32) + let f64_convert_i64_s = Convert (F64 F64Op.ConvertSI64) + let f64_convert_i64_u = Convert (F64 F64Op.ConvertUI64) + let f64_promote_f32 = Convert (F64 F64Op.PromoteF32) + let i32_reinterpret_f32 = Convert (I32 I32Op.ReinterpretFloat) + let i64_reinterpret_f64 = Convert (I64 I64Op.ReinterpretFloat) + let f32_reinterpret_i32 = Convert (F32 F32Op.ReinterpretInt) + let f64_reinterpret_i64 = Convert (F64 F64Op.ReinterpretInt) + let memory_size = MemorySize + let memory_grow = MemoryGrow diff --git a/src/interpreter/syntax/types.ml b/src/interpreter/syntax/types.ml index f1a78fc6..48c2b66c 100644 --- a/src/interpreter/syntax/types.ml +++ b/src/interpreter/syntax/types.ml @@ -1,13 +1,30 @@ (* Types *) -type value_type = I32Type | I64Type | F32Type | F64Type +type value_type = + | I32Type + | I64Type + | F32Type + | F64Type + type elem_type = FuncRefType + type stack_type = value_type list + type func_type = FuncType of stack_type * stack_type -type 'a limits = { min : 'a; max : 'a option } -type mutability = Immutable | Mutable + +type 'a limits = + { min : 'a + ; max : 'a option + } + +type mutability = + | Immutable + | Mutable + type table_type = TableType of Int32.t limits * elem_type + type memory_type = MemoryType of Int32.t limits + type global_type = GlobalType of value_type * mutability type extern_type = diff --git a/src/interpreter/syntax/values.ml b/src/interpreter/syntax/values.ml index b542977b..c13c42ce 100644 --- a/src/interpreter/syntax/values.ml +++ b/src/interpreter/syntax/values.ml @@ -52,6 +52,7 @@ module type ValueType = sig type t val to_value : t -> value + val of_value : value -> t (* raise Value *) end @@ -59,6 +60,7 @@ module I32Value = struct type t = I32.t let to_value i = I32 i + let of_value = function I32 i -> i | _ -> raise (Value I32Type) end @@ -66,6 +68,7 @@ module I64Value = struct type t = I64.t let to_value i = I64 i + let of_value = function I64 i -> i | _ -> raise (Value I64Type) end @@ -73,6 +76,7 @@ module F32Value = struct type t = F32.t let to_value i = F32 i + let of_value = function F32 z -> z | _ -> raise (Value F32Type) end @@ -80,5 +84,6 @@ module F64Value = struct type t = F64.t let to_value i = F64 i + let of_value = function F64 z -> z | _ -> raise (Value F64Type) end diff --git a/src/interpreter/text/arrange.mli b/src/interpreter/text/arrange.mli index c53a563e..a95f98d1 100644 --- a/src/interpreter/text/arrange.mli +++ b/src/interpreter/text/arrange.mli @@ -1,6 +1,9 @@ open Sexpr val instr : Ast.instr -> sexpr + val func : Ast.func -> sexpr + val module_ : Ast.module_ -> sexpr + val script : [ `Textual | `Binary ] -> Script.script -> sexpr list diff --git a/src/interpreter/text/lexer.mli b/src/interpreter/text/lexer.mli index 3566ad6b..f5f2c3cd 100644 --- a/src/interpreter/text/lexer.mli +++ b/src/interpreter/text/lexer.mli @@ -1,2 +1,3 @@ val convert_pos : Lexing.position -> Source.pos + val token : Lexing.lexbuf -> Parser.token (* raises Source.Error *) diff --git a/src/interpreter/text/parse.ml b/src/interpreter/text/parse.ml index b02efd34..dab62d26 100644 --- a/src/interpreter/text/parse.ml +++ b/src/interpreter/text/parse.ml @@ -13,9 +13,8 @@ let parse' name lexbuf start = let region' = if region <> Source.no_region then region else - { - Source.left = Lexer.convert_pos lexbuf.Lexing.lex_start_p; - Source.right = Lexer.convert_pos lexbuf.Lexing.lex_curr_p; + { Source.left = Lexer.convert_pos lexbuf.Lexing.lex_start_p + ; Source.right = Lexer.convert_pos lexbuf.Lexing.lex_curr_p } in raise (Syntax (region', s)) @@ -30,4 +29,5 @@ let string_to start s = parse "string" lexbuf start let string_to_script s = string_to Script s + let string_to_module s = snd (string_to Module s) diff --git a/src/interpreter/text/parse.mli b/src/interpreter/text/parse.mli index 639438b6..c20f9788 100644 --- a/src/interpreter/text/parse.mli +++ b/src/interpreter/text/parse.mli @@ -6,5 +6,7 @@ type 'a start = exception Syntax of Source.region * string val parse : string -> Lexing.lexbuf -> 'a start -> 'a (* raises Syntax *) + val string_to_script : string -> Script.script (* raises Syntax *) + val string_to_module : string -> Script.definition (* raises Syntax *) diff --git a/src/interpreter/text/print.ml b/src/interpreter/text/print.ml index 3fe3822a..b33caad8 100644 --- a/src/interpreter/text/print.ml +++ b/src/interpreter/text/print.ml @@ -1,5 +1,7 @@ let instr oc width e = Sexpr.output oc width (Arrange.instr e) + let func oc width f = Sexpr.output oc width (Arrange.func f) + let module_ oc width m = Sexpr.output oc width (Arrange.module_ m) let script oc width mode s = diff --git a/src/interpreter/text/print.mli b/src/interpreter/text/print.mli index 3b65c6a5..054ba09c 100644 --- a/src/interpreter/text/print.mli +++ b/src/interpreter/text/print.mli @@ -1,5 +1,7 @@ val instr : out_channel -> int -> Ast.instr -> unit + val func : out_channel -> int -> Ast.func -> unit + val module_ : out_channel -> int -> Ast.module_ -> unit val script : diff --git a/src/interpreter/util/error.ml b/src/interpreter/util/error.ml index d7ff0f2c..14c89215 100644 --- a/src/interpreter/util/error.ml +++ b/src/interpreter/util/error.ml @@ -2,5 +2,6 @@ module Make () = struct exception Error of Source.region * string let warn at m = prerr_endline (Source.string_of_region at ^ ": warning: " ^ m) + let error at m = raise (Error (at, m)) end diff --git a/src/interpreter/util/error.mli b/src/interpreter/util/error.mli index dd1f1707..afd2b805 100644 --- a/src/interpreter/util/error.mli +++ b/src/interpreter/util/error.mli @@ -2,5 +2,6 @@ module Make () : sig exception Error of Source.region * string val warn : Source.region -> string -> unit + val error : Source.region -> string -> 'a (* raises Error *) end diff --git a/src/interpreter/util/lib.ml b/src/interpreter/util/lib.ml index 398542a2..735da89e 100644 --- a/src/interpreter/util/lib.ml +++ b/src/interpreter/util/lib.ml @@ -1,12 +1,13 @@ module Fun = struct let curry f x y = f (x, y) + let uncurry f (x, y) = f x y let rec repeat n f x = if n = 0 then () else ( f x; - repeat (n - 1) f x) + repeat (n - 1) f x ) end module Int = struct @@ -58,9 +59,11 @@ end module List = struct let rec make n x = make' n x [] + and make' n x xs = if n = 0 then xs else make' (n - 1) x (x :: xs) let rec table n f = table' n f [] + and table' n f xs = if n = 0 then xs else table' (n - 1) f (f (n - 1) :: xs) let rec take n xs = @@ -83,8 +86,8 @@ module List = struct let rec split_last = function | x :: [] -> ([], x) | x :: xs -> - let ys, y = split_last xs in - (x :: ys, y) + let ys, y = split_last xs in + (x :: ys, y) | [] -> failwith "split_last" let rec index_where p xs = index_where' p xs 0 @@ -100,13 +103,12 @@ module List = struct let rec map_filter f = function | [] -> [] | x :: xs -> ( - match f x with - | None -> map_filter f xs - | Some y -> y :: map_filter f xs) + match f x with None -> map_filter f xs | Some y -> y :: map_filter f xs ) end module List32 = struct let rec make n x = make' n x [] + and make' n x xs = if n = 0l then xs else make' (Int32.sub n 1l) x (x :: xs) let rec length xs = length' xs 0l @@ -149,6 +151,7 @@ module Array32 = struct else Int32.to_int i let get a i = Array.get a (index_of_int32 i) + let set a i x = Array.set a (index_of_int32 i) x let blit a1 i1 a2 i2 n = @@ -170,13 +173,17 @@ module Bigarray = struct if i < 0L || i > Int64.of_int max_int then -1 else Int64.to_int i let get a i = Array1.get a (index_of_int64 i) + let set a i x = Array1.set a (index_of_int64 i) x + let sub a i n = Array1.sub a (index_of_int64 i) (index_of_int64 n) end end module Option = struct let get o x = match o with Some y -> y | None -> x + let map f = function Some x -> Some (f x) | None -> None + let app f = function Some x -> f x | None -> () end diff --git a/src/interpreter/util/lib.mli b/src/interpreter/util/lib.mli index 7f4fe7c6..ed7bf6e5 100644 --- a/src/interpreter/util/lib.mli +++ b/src/interpreter/util/lib.mli @@ -2,35 +2,53 @@ module Fun : sig val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c + val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c + val repeat : int -> ('a -> unit) -> 'a -> unit end module List : sig val make : int -> 'a -> 'a list + val table : int -> (int -> 'a) -> 'a list + val take : int -> 'a list -> 'a list (* raises Failure *) + val drop : int -> 'a list -> 'a list (* raises Failure *) + val last : 'a list -> 'a (* raises Failure *) + val split_last : 'a list -> 'a list * 'a (* raises Failure *) + val index_of : 'a -> 'a list -> int option + val index_where : ('a -> bool) -> 'a list -> int option + val map_filter : ('a -> 'b option) -> 'a list -> 'b list end module List32 : sig val make : int32 -> 'a -> 'a list + val length : 'a list -> int32 + val nth : 'a list -> int32 -> 'a (* raises Failure *) + val take : int32 -> 'a list -> 'a list (* raises Failure *) + val drop : int32 -> 'a list -> 'a list (* raises Failure *) end module Array32 : sig val make : int32 -> 'a -> 'a array + val length : 'a array -> int32 + val get : 'a array -> int32 -> 'a + val set : 'a array -> int32 -> 'a -> unit + val blit : 'a array -> int32 -> 'a array -> int32 -> int32 -> unit end @@ -39,28 +57,39 @@ module Bigarray : sig module Array1_64 : sig val create : ('a, 'b) kind -> 'c layout -> int64 -> ('a, 'b, 'c) Array1.t + val dim : ('a, 'b, 'c) Array1.t -> int64 + val get : ('a, 'b, 'c) Array1.t -> int64 -> 'a + val set : ('a, 'b, 'c) Array1.t -> int64 -> 'a -> unit + val sub : ('a, 'b, 'c) Array1.t -> int64 -> int64 -> ('a, 'b, 'c) Array1.t end end module Option : sig val get : 'a option -> 'a -> 'a + val map : ('a -> 'b) -> 'a option -> 'b option + val app : ('a -> unit) -> 'a option -> unit end module Int : sig val log2 : int -> int + val is_power_of_two : int -> bool end module String : sig val implode : char list -> string + val explode : string -> char list + val split : string -> char -> string list + val breakup : string -> int -> string list + val find_from_opt : (char -> bool) -> string -> int -> int option end diff --git a/src/interpreter/util/sexpr.ml b/src/interpreter/util/sexpr.ml index a9a6718c..662f74b6 100644 --- a/src/interpreter/util/sexpr.ml +++ b/src/interpreter/util/sexpr.ml @@ -1,8 +1,15 @@ -type sexpr = Atom of string | Node of string * sexpr list -type rope = Leaf of string | Concat of rope list +type sexpr = + | Atom of string + | Node of string * sexpr list + +type rope = + | Leaf of string + | Concat of rope list let ( ^+ ) s r = Concat [ Leaf s; r ] + let ( +^ ) r s = Concat [ r; Leaf s ] + let rec iter f = function Leaf s -> f s | Concat rs -> List.iter (iter f) rs let rec concat = function @@ -12,17 +19,15 @@ let rec concat = function let rec pp off width = function | Atom s -> (String.length s, Leaf s) | Node (s, xs) -> - let lens, rs = List.split (List.map (pp (off + 2) width) xs) in - let len = - String.length s + List.length rs + List.fold_left ( + ) 2 lens - in - let sep, fin = - if off + len <= width then (" ", "") - else - let indent = String.make off ' ' in - ("\n " ^ indent, "\n" ^ indent) - in - (len, "(" ^+ s ^+ (Concat (List.map (fun r -> sep ^+ r) rs) +^ fin +^ ")")) + let lens, rs = List.split (List.map (pp (off + 2) width) xs) in + let len = String.length s + List.length rs + List.fold_left ( + ) 2 lens in + let sep, fin = + if off + len <= width then (" ", "") + else + let indent = String.make off ' ' in + ("\n " ^ indent, "\n" ^ indent) + in + (len, "(" ^+ s ^+ (Concat (List.map (fun r -> sep ^+ r) rs) +^ fin +^ ")")) let output oc width x = iter (output_string oc) (snd (pp 0 width x)); @@ -30,4 +35,5 @@ let output oc width x = flush oc let print = output stdout + let to_string width x = concat (snd (pp 0 width x)) ^ "\n" diff --git a/src/interpreter/util/sexpr.mli b/src/interpreter/util/sexpr.mli index 54e17712..d0e257a6 100644 --- a/src/interpreter/util/sexpr.mli +++ b/src/interpreter/util/sexpr.mli @@ -1,5 +1,9 @@ -type sexpr = Atom of string | Node of string * sexpr list +type sexpr = + | Atom of string + | Node of string * sexpr list val output : out_channel -> int -> sexpr -> unit + val print : int -> sexpr -> unit + val to_string : int -> sexpr -> string diff --git a/src/interpreter/util/source.ml b/src/interpreter/util/source.ml index 54a14174..399fb5f2 100644 --- a/src/interpreter/util/source.ml +++ b/src/interpreter/util/source.ml @@ -1,12 +1,25 @@ -type pos = { file : string; line : int; column : int } -type region = { left : pos; right : pos } -type 'a phrase = { at : region; it : 'a } +type pos = + { file : string + ; line : int + ; column : int + } + +type region = + { left : pos + ; right : pos + } + +type 'a phrase = + { at : region + ; it : 'a + } let ( @@ ) x region = { it = x; at = region } (* Positions and regions *) let no_pos = { file = ""; line = 0; column = 0 } + let no_region = { left = no_pos; right = no_pos } let string_of_pos pos = diff --git a/src/interpreter/util/source.mli b/src/interpreter/util/source.mli index 4ede9eb3..e89a6f71 100644 --- a/src/interpreter/util/source.mli +++ b/src/interpreter/util/source.mli @@ -1,10 +1,27 @@ -type pos = { file : string; line : int; column : int } -type region = { left : pos; right : pos } -type 'a phrase = { at : region; it : 'a } +type pos = + { file : string + ; line : int + ; column : int + } + +type region = + { left : pos + ; right : pos + } + +type 'a phrase = + { at : region + ; it : 'a + } val no_pos : pos + val no_region : region + val string_of_pos : pos -> string + val string_of_region : region -> string + val get_line : region -> int + val ( @@ ) : 'a -> region -> 'a phrase diff --git a/src/interpreter/valid/valid.ml b/src/interpreter/valid/valid.ml index a7a3feff..7778e66c 100644 --- a/src/interpreter/valid/valid.ml +++ b/src/interpreter/valid/valid.ml @@ -9,31 +9,31 @@ module Invalid = Error.Make () exception Invalid = Invalid.Error let error = Invalid.error + let require b at s = if not b then error at s (* Context *) -type context = { - types : func_type list; - funcs : func_type list; - tables : table_type list; - memories : memory_type list; - globals : global_type list; - locals : value_type list; - results : value_type list; - labels : stack_type list; -} +type context = + { types : func_type list + ; funcs : func_type list + ; tables : table_type list + ; memories : memory_type list + ; globals : global_type list + ; locals : value_type list + ; results : value_type list + ; labels : stack_type list + } let empty_context = - { - types = []; - funcs = []; - tables = []; - memories = []; - globals = []; - locals = []; - results = []; - labels = []; + { types = [] + ; funcs = [] + ; tables = [] + ; memories = [] + ; globals = [] + ; locals = [] + ; results = [] + ; labels = [] } let lookup category list x = @@ -42,11 +42,17 @@ let lookup category list x = error x.at ("unknown " ^ category ^ " " ^ Int32.to_string x.it) let type_ (c : context) x = lookup "type" c.types x + let func (c : context) x = lookup "function" c.funcs x + let table (c : context) x = lookup "table" c.tables x + let memory (c : context) x = lookup "memory" c.memories x + let global (c : context) x = lookup "global" c.globals x + let local (c : context) x = lookup "local" c.locals x + let label (c : context) x = lookup "label" c.labels x (* Stack typing *) @@ -60,12 +66,21 @@ let label (c : context) x = lookup "label" c.labels x * of unknown types, in order to handle stack polymorphism algorithmically. *) -type ellipses = NoEllipses | Ellipses +type ellipses = + | NoEllipses + | Ellipses + type infer_stack_type = ellipses * value_type option list -type op_type = { ins : infer_stack_type; outs : infer_stack_type } + +type op_type = + { ins : infer_stack_type + ; outs : infer_stack_type + } let known = List.map (fun t -> Some t) + let stack ts = (NoEllipses, known ts) + let ( -~> ) ts1 ts2 = { ins = (NoEllipses, ts1); outs = (NoEllipses, ts2) } let ( --> ) ts1 ts2 = @@ -86,8 +101,8 @@ let check_stack ts1 ts2 at = require (List.length ts1 = List.length ts2 && List.for_all2 eq_ty ts1 ts2) at - ("type mismatch: operator requires " ^ string_of_infer_types ts1 - ^ " but stack has " ^ string_of_infer_types ts2) + ( "type mismatch: operator requires " ^ string_of_infer_types ts1 + ^ " but stack has " ^ string_of_infer_types ts2 ) let pop (ell1, ts1) (ell2, ts2) at = let n1 = List.length ts1 in @@ -99,52 +114,56 @@ let pop (ell1, ts1) (ell2, ts2) at = let push (ell1, ts1) (ell2, ts2) = assert (ell1 = NoEllipses || ts2 = []); - ( (if ell1 = Ellipses || ell2 = Ellipses then Ellipses else NoEllipses), - ts2 @ ts1 ) + ( (if ell1 = Ellipses || ell2 = Ellipses then Ellipses else NoEllipses) + , ts2 @ ts1 ) -let peek i (_ , ts) = try List.nth (List.rev ts) i with Failure _ -> None +let peek i (_, ts) = try List.nth (List.rev ts) i with Failure _ -> None (* Type Synthesis *) let type_value = Values.type_of + let type_unop = Values.type_of + let type_binop = Values.type_of + let type_testop = Values.type_of + let type_relop = Values.type_of let type_cvtop at = function | Values.I32 cvtop -> - let open I32Op in - ( (match cvtop with - | ExtendSI32 | ExtendUI32 -> error at "invalid conversion" - | WrapI64 -> I64Type - | TruncSF32 | TruncUF32 | ReinterpretFloat -> F32Type - | TruncSF64 | TruncUF64 -> F64Type), - I32Type ) + let open I32Op in + ( ( match cvtop with + | ExtendSI32 | ExtendUI32 -> error at "invalid conversion" + | WrapI64 -> I64Type + | TruncSF32 | TruncUF32 | ReinterpretFloat -> F32Type + | TruncSF64 | TruncUF64 -> F64Type ) + , I32Type ) | Values.I64 cvtop -> - let open I64Op in - ( (match cvtop with - | ExtendSI32 | ExtendUI32 -> I32Type - | WrapI64 -> error at "invalid conversion" - | TruncSF32 | TruncUF32 -> F32Type - | TruncSF64 | TruncUF64 | ReinterpretFloat -> F64Type), - I64Type ) + let open I64Op in + ( ( match cvtop with + | ExtendSI32 | ExtendUI32 -> I32Type + | WrapI64 -> error at "invalid conversion" + | TruncSF32 | TruncUF32 -> F32Type + | TruncSF64 | TruncUF64 | ReinterpretFloat -> F64Type ) + , I64Type ) | Values.F32 cvtop -> - let open F32Op in - ( (match cvtop with - | ConvertSI32 | ConvertUI32 | ReinterpretInt -> I32Type - | ConvertSI64 | ConvertUI64 -> I64Type - | PromoteF32 -> error at "invalid conversion" - | DemoteF64 -> F64Type), - F32Type ) + let open F32Op in + ( ( match cvtop with + | ConvertSI32 | ConvertUI32 | ReinterpretInt -> I32Type + | ConvertSI64 | ConvertUI64 -> I64Type + | PromoteF32 -> error at "invalid conversion" + | DemoteF64 -> F64Type ) + , F32Type ) | Values.F64 cvtop -> - let open F64Op in - ( (match cvtop with - | ConvertSI32 | ConvertUI32 -> I32Type - | ConvertSI64 | ConvertUI64 | ReinterpretInt -> I64Type - | PromoteF32 -> F32Type - | DemoteF64 -> error at "invalid conversion"), - F64Type ) + let open F64Op in + ( ( match cvtop with + | ConvertSI32 | ConvertUI32 -> I32Type + | ConvertSI64 | ConvertUI64 | ReinterpretInt -> I64Type + | PromoteF32 -> F32Type + | DemoteF64 -> error at "invalid conversion" ) + , F64Type ) (* Expressions *) @@ -154,10 +173,10 @@ let check_memop (c : context) (memop : 'a memop) get_sz at = match get_sz memop.sz with | None -> size memop.ty | Some sz -> - require - (memop.ty = I64Type || sz <> Memory.Pack32) - at "memory size too big"; - Memory.packed_size sz + require + (memop.ty = I64Type || sz <> Memory.Pack32) + at "memory size too big"; + Memory.packed_size sz in require (1 lsl memop.align <= size) @@ -192,75 +211,75 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type = | Nop -> [] --> [] | Drop -> [ peek 0 s ] -~> [] | Select -> - let t = peek 1 s in - [ t; t; Some I32Type ] -~> [ t ] + let t = peek 1 s in + [ t; t; Some I32Type ] -~> [ t ] | Block (ts, es) -> - check_arity (List.length ts) e.at; - check_block { c with labels = ts :: c.labels } es ts e.at; - [] --> ts + check_arity (List.length ts) e.at; + check_block { c with labels = ts :: c.labels } es ts e.at; + [] --> ts | Loop (ts, es) -> - check_arity (List.length ts) e.at; - check_block { c with labels = [] :: c.labels } es ts e.at; - [] --> ts + check_arity (List.length ts) e.at; + check_block { c with labels = [] :: c.labels } es ts e.at; + [] --> ts | If (ts, es1, es2) -> - check_arity (List.length ts) e.at; - check_block { c with labels = ts :: c.labels } es1 ts e.at; - check_block { c with labels = ts :: c.labels } es2 ts e.at; - [ I32Type ] --> ts + check_arity (List.length ts) e.at; + check_block { c with labels = ts :: c.labels } es1 ts e.at; + check_block { c with labels = ts :: c.labels } es2 ts e.at; + [ I32Type ] --> ts | Br x -> label c x -->... [] | BrIf x -> (label c x @ [ I32Type ]) --> label c x | BrTable (xs, x) -> - let ts = label c x in - List.iter (fun x' -> check_stack (known ts) (known (label c x')) x'.at) xs; - (label c x @ [ I32Type ]) -->... [] + let ts = label c x in + List.iter (fun x' -> check_stack (known ts) (known (label c x')) x'.at) xs; + (label c x @ [ I32Type ]) -->... [] | Return -> c.results -->... [] | Call x -> - let (FuncType (ins, out)) = func c x in - ins --> out + let (FuncType (ins, out)) = func c x in + ins --> out | CallIndirect x -> - ignore (table c (0l @@ e.at)); - let (FuncType (ins, out)) = type_ c x in - (ins @ [ I32Type ]) --> out + ignore (table c (0l @@ e.at)); + let (FuncType (ins, out)) = type_ c x in + (ins @ [ I32Type ]) --> out | LocalGet x -> [] --> [ local c x ] | LocalSet x -> [ local c x ] --> [] | LocalTee x -> [ local c x ] --> [ local c x ] | GlobalGet x -> - let (GlobalType (t, _)) = global c x in - [] --> [ t ] + let (GlobalType (t, _)) = global c x in + [] --> [ t ] | GlobalSet x -> - let (GlobalType (t, mut)) = global c x in - require (mut = Mutable) x.at "global is immutable"; - [ t ] --> [] + let (GlobalType (t, mut)) = global c x in + require (mut = Mutable) x.at "global is immutable"; + [ t ] --> [] | Load memop -> - check_memop c memop (Lib.Option.map fst) e.at; - [ I32Type ] --> [ memop.ty ] + check_memop c memop (Lib.Option.map fst) e.at; + [ I32Type ] --> [ memop.ty ] | Store memop -> - check_memop c memop (fun sz -> sz) e.at; - [ I32Type; memop.ty ] --> [] + check_memop c memop (fun sz -> sz) e.at; + [ I32Type; memop.ty ] --> [] | MemorySize -> - ignore (memory c (0l @@ e.at)); - [] --> [ I32Type ] + ignore (memory c (0l @@ e.at)); + [] --> [ I32Type ] | MemoryGrow -> - ignore (memory c (0l @@ e.at)); - [ I32Type ] --> [ I32Type ] + ignore (memory c (0l @@ e.at)); + [ I32Type ] --> [ I32Type ] | Const v -> - let t = type_value v.it in - [] --> [ t ] + let t = type_value v.it in + [] --> [ t ] | Test testop -> - let t = type_testop testop in - [ t ] --> [ I32Type ] + let t = type_testop testop in + [ t ] --> [ I32Type ] | Compare relop -> - let t = type_relop relop in - [ t; t ] --> [ I32Type ] + let t = type_relop relop in + [ t; t ] --> [ I32Type ] | Unary unop -> - let t = type_unop unop in - [ t ] --> [ t ] + let t = type_unop unop in + [ t ] --> [ t ] | Binary binop -> - let t = type_binop binop in - [ t; t ] --> [ t ] + let t = type_binop binop in + [ t; t ] --> [ t ] | Convert cvtop -> - let t1, t2 = type_cvtop e.at cvtop in - [ t1 ] --> [ t2 ] + let t1, t2 = type_cvtop e.at cvtop in + [ t1 ] --> [ t2 ] | Symbolic (t, _) -> [ I32Type ] --> [ t ] | Boolop _ -> [ I32Type; I32Type ] --> [ I32Type ] | Alloc -> [ I32Type; I32Type ] --> [ I32Type ] @@ -291,10 +310,10 @@ and check_seq (c : context) (es : instr list) : infer_stack_type = match es with | [] -> stack [] | _ -> - let es', e = Lib.List.split_last es in - let s = check_seq c es' in - let { ins; outs } = check_instr c e s in - push outs (pop ins s e.at) + let es', e = Lib.List.split_last es in + let s = check_seq c es' in + let { ins; outs } = check_instr c e s in + push outs (pop ins s e.at) and check_block (c : context) (es : instr list) (ts : stack_type) at = let s = check_seq c es in @@ -302,9 +321,9 @@ and check_block (c : context) (es : instr list) (ts : stack_type) at = require (snd s' = []) at - ("type mismatch: operator requires " ^ string_of_stack_type ts - ^ " but stack has " - ^ string_of_infer_types (snd s)) + ( "type mismatch: operator requires " ^ string_of_stack_type ts + ^ " but stack has " + ^ string_of_infer_types (snd s) ) (* Types *) @@ -313,9 +332,9 @@ let check_limits { min; max } range at msg = match max with | None -> () | Some max -> - require (I64.le_u (Int64.of_int32 max) range) at msg; - require (I32.le_u min max) at - "size minimum must not be greater than maximum" + require (I64.le_u (Int64.of_int32 max) range) at msg; + require (I32.le_u min max) at + "size minimum must not be greater than maximum" let check_value_type (_ : value_type) _ = () @@ -363,8 +382,8 @@ let is_const (c : context) (e : instr) = match e.it with | Const _ -> true | GlobalGet x -> - let (GlobalType (_, mut)) = global c x in - mut = Immutable + let (GlobalType (_, mut)) = global c x in + mut = Immutable | _ -> false let check_const (c : context) (const : const) (t : value_type) = @@ -406,7 +425,7 @@ let check_start (c : context) (start : var option) = (fun x -> require (func c x = FuncType ([], [])) - x.at "start function must not have parameters or results") + x.at "start function must not have parameters or results" ) start let check_import (im : import) (c : context) : context = @@ -414,14 +433,14 @@ let check_import (im : import) (c : context) : context = match idesc.it with | FuncImport x -> { c with funcs = type_ c x :: c.funcs } | TableImport tt -> - check_table_type tt idesc.at; - { c with tables = tt :: c.tables } + check_table_type tt idesc.at; + { c with tables = tt :: c.tables } | MemoryImport mt -> - check_memory_type mt idesc.at; - { c with memories = mt :: c.memories } + check_memory_type mt idesc.at; + { c with memories = mt :: c.memories } | GlobalImport gt -> - check_global_type gt idesc.at; - { c with globals = gt :: c.globals } + check_global_type gt idesc.at; + { c with globals = gt :: c.globals } module NameSet = Set.Make (struct type t = Ast.name @@ -431,27 +450,26 @@ end) let check_export (c : context) (set : NameSet.t) (ex : export) : NameSet.t = let { name; edesc } = ex.it in - (match edesc.it with + ( match edesc.it with | FuncExport x -> ignore (func c x) | TableExport x -> ignore (table c x) | MemoryExport x -> ignore (memory c x) - | GlobalExport x -> ignore (global c x)); + | GlobalExport x -> ignore (global c x) ); require (not (NameSet.mem name set)) ex.at "duplicate export name"; NameSet.add name set let check_module (m : module_) = - let { - types; - imports; - tables; - memories; - globals; - funcs; - start; - elems; - data; - exports; - } = + let { types + ; imports + ; tables + ; memories + ; globals + ; funcs + ; start + ; elems + ; data + ; exports + } = m.it in let c0 = @@ -459,11 +477,10 @@ let check_module (m : module_) = { empty_context with types = List.map (fun ty -> ty.it) types } in let c1 = - { - c0 with - funcs = c0.funcs @ List.map (fun f -> type_ c0 f.it.ftype) funcs; - tables = c0.tables @ List.map (fun tab -> tab.it.ttype) tables; - memories = c0.memories @ List.map (fun mem -> mem.it.mtype) memories; + { c0 with + funcs = c0.funcs @ List.map (fun f -> type_ c0 f.it.ftype) funcs + ; tables = c0.tables @ List.map (fun tab -> tab.it.ttype) tables + ; memories = c0.memories @ List.map (fun mem -> mem.it.mtype) memories } in let c = diff --git a/waspc/lib/instrumentor.ml b/waspc/lib/instrumentor.ml index c712b177..96e6fb6d 100644 --- a/waspc/lib/instrumentor.ml +++ b/waspc/lib/instrumentor.ml @@ -1,4 +1,5 @@ let py_module = lazy (Py.Import.import_module "instrumentor") + let import_module () = Lazy.force py_module let instrument data includes = @@ -6,6 +7,7 @@ let instrument data includes = let kwargs = [ ("data", Py.String.of_string data) ; ("includes", Py.List.of_list @@ List.map Py.String.of_string includes) - ] in + ] + in Py.String.to_string @@ Py.Callable.to_function_with_keywords callable [||] kwargs From e2f4e760d376b306ce5516db3c7ae568980a8505 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Sat, 24 Aug 2024 09:53:08 +0200 Subject: [PATCH 5/8] Make concolic typecheck Makes wasp concolic typecheck and start adding binary with cmdliner. --- bin/dune | 20 +- bin/main.ml | 65 +--- bin/options.ml | 7 + bin/wasp-c | 10 - bin/wasp_ce.ml | 71 ----- src/concolic/checkpoint_intf.ml | 5 + src/concolic/eval.ml | 516 ++++++++++++++++++++------------ src/dune | 2 +- src/run.ml | 331 ++++++++++---------- src/run.mli | 8 +- src/static/dune | 6 +- 11 files changed, 533 insertions(+), 508 deletions(-) create mode 100644 bin/options.ml delete mode 100755 bin/wasp-c delete mode 100644 bin/wasp_ce.ml create mode 100644 src/concolic/checkpoint_intf.ml diff --git a/bin/dune b/bin/dune index cc3799ce..72ea30f4 100644 --- a/bin/dune +++ b/bin/dune @@ -1,20 +1,6 @@ (executable (package wasp) (name main) - (public_name wasm) - (modules main) - (libraries interpreter)) - -(executable - (package wasp) - (name wasp_ce) - (public_name wasp-ce) - (modules wasp_ce) - (libraries interpreter wasp)) - -(executable - (package wasp) - (name wasp_se) - (public_name wasp-se) - (modules wasp_se) - (libraries interpreter wasp)) + (public_name wasp) + (modules main options) + (libraries cmdliner interpreter wasp)) diff --git a/bin/main.ml b/bin/main.ml index 51bf1323..d45112bf 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,61 +1,8 @@ -open Interpreter +let main filename = Format.printf "%a@." Fpath.pp filename -let name = "wasm" -let version = "1.0" +let cli = + let open Cmdliner in + let info = Cmd.info "wasp" ~version:"%%VERSION%%" in + Cmd.v info Term.(const main $ Options.file0) -let configure () = - Import.register (Utf8.decode "spectest") Spectest.lookup; - Import.register (Utf8.decode "env") Env.lookup - -let banner () = print_endline (name ^ " " ^ version) -let usage = "Usage: " ^ name ^ " [option] [file ...]" -let args = ref [] -let add_arg source = args := !args @ [ source ] -let quote s = "\"" ^ String.escaped s ^ "\"" - -let argspec = - Arg.align - [ - ( "-", - Arg.Set Flags.interactive, - " run interactively (default if no files given)" ); - ("-e", Arg.String add_arg, " evaluate string"); - ( "-i", - Arg.String (fun file -> add_arg ("(input " ^ quote file ^ ")")), - " read script from file" ); - ( "-o", - Arg.String (fun file -> add_arg ("(output " ^ quote file ^ ")")), - " write module to file" ); - ( "-w", - Arg.Int (fun n -> Flags.width := n), - " configure output width (default is 80)" ); - ("-s", Arg.Set Flags.print_sig, " show module signatures"); - ("-u", Arg.Set Flags.unchecked, " unchecked, do not perform validation"); - ("-h", Arg.Clear Flags.harness, " exclude harness for JS conversion"); - ("-d", Arg.Set Flags.dry, " dry, do not run program"); - ("-t", Arg.Set Flags.trace, " trace execution"); - ( "-v", - Arg.Unit - (fun () -> - banner (); - exit 0), - " show version" ); - ] - -let () = - Printexc.record_backtrace true; - try - configure (); - Arg.parse argspec (fun file -> add_arg ("(input " ^ quote file ^ ")")) usage; - List.iter (fun arg -> if not (Run.run_string arg) then exit 1) !args; - if !args = [] then Flags.interactive := true; - if !Flags.interactive then ( - Flags.print_sig := true; - banner (); - Run.run_stdin ()) - with exn -> - flush_all (); - prerr_endline - (Sys.argv.(0) ^ ": uncaught exception " ^ Printexc.to_string exn); - Printexc.print_backtrace stderr; - exit 2 +let () = exit (Cmdliner.Cmd.eval cli) diff --git a/bin/options.ml b/bin/options.ml new file mode 100644 index 00000000..338805d6 --- /dev/null +++ b/bin/options.ml @@ -0,0 +1,7 @@ +open Cmdliner + +let path = ((fun s -> `Ok (Fpath.v s)), Fpath.pp) + +let file0 = + let doc = "input file to analyse" in + Arg.(required & pos 0 (some path) None & info [] ~doc ~docv:"FILE") diff --git a/bin/wasp-c b/bin/wasp-c deleted file mode 100755 index b74d1dcc..00000000 --- a/bin/wasp-c +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/env bash - -SCRIPT_DIR=$(dirname $0) -MODULE_DIR=$(dirname $SCRIPT_DIR) - -export LD_PATH=${SCRIPT_DIR} -export PYTHONPATH=${MODULE_DIR}/waspc/py -export LIBC=${MODULE_DIR}/share/libc/ - -waspc -I ${LIBC} $@ diff --git a/bin/wasp_ce.ml b/bin/wasp_ce.ml deleted file mode 100644 index dbb1e703..00000000 --- a/bin/wasp_ce.ml +++ /dev/null @@ -1,71 +0,0 @@ -open Interpreter - -let name = "WebAssembly Concolic Executor" -let version = "v0.2.3" - -let configure () = - Import.register (Utf8.decode "spectest") Spectest.lookup; - Import.register (Utf8.decode "env") Env.lookup - -let banner () = print_endline (name ^ " " ^ version) -let usage = "Usage: " ^ name ^ " [option] [file ...]" -let args = ref [] -let add_arg source = args := !args @ [ source ] -let quote s = "\"" ^ String.escaped s ^ "\"" - -let argspec = - Arg.align - [ - ( "-", - Arg.Set Flags.interactive, - " run interactively (default if no files given)" ); - ("-e", Arg.String add_arg, " evaluate string"); - ( "-i", - Arg.String (fun file -> add_arg ("(input " ^ quote file ^ ")")), - " read script from file" ); - ( "-o", - Arg.String (fun file -> add_arg ("(output " ^ quote file ^ ")")), - " write module to file" ); - ("-s", Arg.Set Flags.print_sig, " show module signatures"); - ("-u", Arg.Set Flags.unchecked, " unchecked, do not perform validation"); - ("-d", Arg.Set Flags.dry, " dry, do not run program"); - ("-t", Arg.Set Flags.trace, " trace execution"); - ( "-v", - Arg.Unit - (fun () -> - banner (); - exit 0), - " show version" ); - ("--timeout", Arg.Set_int Flags.timeout, " time limit (default=900s)"); - ( "--workspace", - Arg.Set_string Flags.output, - " directory to output report and test-suite (default=output)" ); - ( "--no-simplify", - Arg.Clear Flags.simplify, - " do not perform algebraic simplifications of symbolic expressions" ); - ( "--policy", - Arg.Set_string Flags.policy, - " search policy random|depth|breadth (default: random)" ); - ( "--queries", - Arg.Set Flags.queries, - " output solver queries in .smt2 format" ); - ("--log", Arg.Set Flags.log, " logs paths and memory"); - ] - -let () = - Printexc.record_backtrace true; - try - configure (); - Arg.parse argspec (fun file -> add_arg ("(input " ^ quote file ^ ")")) usage; - List.iter (fun arg -> if not (Wasp.Run.run_string_ce arg) then exit 1) !args; - if !args = [] then Flags.interactive := true; - if !Flags.interactive then ( - Flags.print_sig := true; - banner (); - Wasp.Run.run_stdin ()) - with exn -> - flush_all (); - prerr_endline - (Sys.argv.(0) ^ ": uncaught exception " ^ Printexc.to_string exn); - Printexc.print_backtrace stderr; - exit 2 diff --git a/src/concolic/checkpoint_intf.ml b/src/concolic/checkpoint_intf.ml new file mode 100644 index 00000000..52323cdb --- /dev/null +++ b/src/concolic/checkpoint_intf.ml @@ -0,0 +1,5 @@ +module type S = sig + type config + + val is_checkpoint : config -> bool +end diff --git a/src/concolic/eval.ml b/src/concolic/eval.ml index ea05b268..1be7723b 100644 --- a/src/concolic/eval.ml +++ b/src/concolic/eval.ml @@ -1,11 +1,22 @@ -open Evaluations -open Common open Smtml open Value -open Interpreter.Ast -open Interpreter.Source -open Interpreter.Instance +module Ast = Interpreter.Ast module Batch = Smtml.Solver.Batch (Smtml.Z3_mappings) +module Bug = Common.Bug +module Counter = Common.Counter +module Crash = Common.Crash +module Chunktable = Common.Chunktable + +module Evaluations = struct + include Common.Evaluations + include Evaluations +end + +module Flags = Interpreter.Flags +module Globals = Common.Globals +module Instance = Interpreter.Instance +module Source = Interpreter.Source +module Trap = Common.Trap let memory_error at = function | Heap.InvalidAddress a -> @@ -31,21 +42,21 @@ type value = Num.t * Expr.t type 'a stack = 'a list type frame = - { inst : module_inst + { inst : Instance.module_inst ; locals : value ref list } type code = value stack * sym_admin_instr list -and sym_admin_instr = sym_admin_instr' phrase +and sym_admin_instr = sym_admin_instr' Source.phrase and sym_admin_instr' = - | Plain of instr' - | Invoke of func_inst + | Plain of Ast.instr' + | Invoke of Instance.func_inst | Trapping of string | Returning of value stack | Breaking of int32 * value stack - | Label of int * instr list * code + | Label of int * Ast.instr list * code | Frame of int * frame * code | Interrupt of interruption | Restart of Expr.t @@ -61,7 +72,7 @@ type config = ; bp : bp list ; tree : tree ref ; budget : int - ; call_stack : region Stack.t + ; call_stack : Source.region Stack.t } and tree = config ref Execution_tree.t ref @@ -76,6 +87,7 @@ let clone_frame (f : frame) : frame = frame f.inst (List.map (fun l -> ref !l) f.locals) let rec clone_admin_instr e = + let open Source in let it = match e.it with | Label (n, es0, (vs, es)) -> @@ -116,7 +128,7 @@ let config inst vs es mem glob tree = ; call_stack = Stack.create () } -exception BugException of config * region * Bug.bug +exception BugException of config * Source.region * Bug.bug let head = ref Execution_tree.(Node (None, None, ref Leaf, ref Leaf)) @@ -130,7 +142,13 @@ let logs = ref [] let solver = Batch.create () -let debug str = if !Interpreter.Flags.trace then print_endline str +let debug0 fmt = if !Flags.trace then Format.eprintf fmt + +let debug1 fmt a = if !Flags.trace then Format.eprintf fmt a + +let debug2 fmt a b = if !Flags.trace then Format.eprintf fmt a b + +let debug3 fmt a b c = if !Flags.trace then Format.eprintf fmt a b c let parse_policy (p : string) : policy option = match p with @@ -144,22 +162,25 @@ let string_of_interruption : interruption -> string = function | Failure _ -> "Assertion Failure" | Bug b -> Bug.string_of_bug b -let plain e = Plain e.it @@ e.at +let plain e = + let open Source in + Plain e.it @@ e.at let lookup category list x = + let open Source in try Interpreter.Lib.List32.nth list x.it with Failure _ -> Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) -let type_ (inst : module_inst) x = lookup "type" inst.types x +let type_ (inst : Instance.module_inst) x = lookup "type" inst.types x -let func (inst : module_inst) x = lookup "function" inst.funcs x +let func (inst : Instance.module_inst) x = lookup "function" inst.funcs x -let table (inst : module_inst) x = lookup "table" inst.tables x +let table (inst : Instance.module_inst) x = lookup "table" inst.tables x -let memory (inst : module_inst) x = lookup "memory" inst.memories x +let memory (inst : Instance.module_inst) x = lookup "memory" inst.memories x -let global (inst : module_inst) x = lookup "global" inst.globals x +let global (inst : Instance.module_inst) x = lookup "global" inst.globals x let local (frame : frame) x = lookup "local" frame.locals x @@ -172,6 +193,7 @@ let elem inst x i at = Trap.error at ("undefined element " ^ Int32.to_string i) let func_elem inst x i at = + let open Instance in match elem inst x i at with | FuncElem f -> f | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) @@ -184,6 +206,33 @@ let drop n (vs : 'a stack) at = try Interpreter.Lib.List.drop n vs with Failure _ -> Crash.error at "stack underflow" +let default_value = function + | Ty.Ty_bitv 32 -> Num.I32 0l + | Ty.Ty_bitv 64 -> I64 0L + | Ty.Ty_fp 32 -> F32 (Int32.bits_of_float 0.) + | Ty.Ty_fp 64 -> F64 (Int64.bits_of_float 0.) + | _ -> assert false + +let to_relop e = + match Expr.view e with + | Val _ | Ptr _ | Relop _ -> None + | _ -> Some (Expr.relop Ty_bool Ne e (Expr.value (Num (I32 0l)))) + +let mk_relop ?(reduce : bool = true) (e : Expr.t) (ty : Ty.t) = + let e = if reduce then Expr.simplify e else e in + match Expr.view e with + | Relop _ -> e + | _ -> ( + let zero = Value.Num (default_value ty) in + Expr.simplify + @@ + match ty with + | Ty_bitv 32 -> Expr.relop Ty_bool Ne e (Expr.value zero) + | Ty_bitv 64 -> Expr.relop Ty_bool Ne e (Expr.value zero) + | Ty_fp 32 -> Expr.relop (Ty_fp 32) Ne e (Expr.value zero) + | Ty_fp 64 -> Expr.relop (Ty_fp 64) Ne e (Expr.value zero) + | _ -> assert false ) + let add_constraint ?neg:_ _ _ = assert false let branch_on_cond bval c pc tree = @@ -194,15 +243,18 @@ let branch_on_cond bval c pc tree = tree := tree'; if to_branch then Some (add_constraint ~neg:bval c pc) else None -module type Checkpoint = sig - val is_checkpoint : config -> bool -end +let concretize_base_ptr e = + match Expr.view e with Ptr { base; _ } -> Some base | _ -> None + +module NoCheckpoint : Checkpoint_intf.S with type config = config = struct + type nonrec config = config -module NoCheckpoint : Checkpoint = struct let is_checkpoint (_ : config) : bool = false end -module FuncCheckpoint : Checkpoint = struct +module FuncCheckpoint : Checkpoint_intf.S with type config = config = struct + type nonrec config = config + let visited = Hashtbl.create Interpreter.Flags.hashtbl_default_size let is_checkpoint (c : config) : bool = @@ -213,13 +265,17 @@ module FuncCheckpoint : Checkpoint = struct Execution_tree.can_branch !(c.tree) ) end -module RandCheckpoint : Checkpoint = struct +module RandCheckpoint : Checkpoint_intf.S with type config = config = struct + type nonrec config = config + let is_checkpoint (c : config) : bool = Execution_tree.can_branch !(c.tree) && Random.bool () end -module DepthCheckpoint : Checkpoint = struct - let count = Counter.create () +module DepthCheckpoint : Checkpoint_intf.S with type config = config = struct + type nonrec config = config + + let _ = Counter.create () let is_checkpoint (_c : config) : bool = false (* let size_pc = Expression.length c.pc in *) @@ -232,7 +288,15 @@ module type Stepper = sig val step : config -> config end -module ConcolicStepper (C : Checkpoint) : Stepper = struct +module ConcolicStepper (C : Checkpoint_intf.S with type config = config) : + Stepper = struct + open Source + + let pp_value fmt (n, e) = Format.fprintf fmt "(%a, %a)" Num.pp n Expr.pp e + + let pp_value_list fmt vs = + Format.pp_print_list ~pp_sep:Format.pp_print_newline pp_value fmt vs + let rec step (c : config) : config = let { frame ; glob @@ -289,9 +353,9 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct (mem, Checkpoint cp :: bp) in let bp' = - Option.fold ~init:bp - ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) - (branch_on_cond b ex pc tree) + match branch_on_cond b ex pc tree with + | None -> bp + | Some pc -> Branchpoint (pc, !tree) :: bp in let pc' = add_constraint ~neg:(not b) ex pc in (vs', (if b then es1' else es2'), mem', pc', bp') @@ -314,9 +378,9 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct (mem, Checkpoint cp :: bp) in let bp' = - Option.fold ~init:bp - ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) - (branch_on_cond b ex pc tree) + match branch_on_cond b ex pc tree with + | None -> bp + | Some pc -> Branchpoint (pc, !tree) :: bp in let pc' = add_constraint ~neg:(not b) ex pc in (vs', (if b then es1' else es2'), mem', pc', bp') @@ -355,9 +419,9 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct (mem, Checkpoint cp :: bp) in let bp' = - Option.fold ~init:bp - ~f:(fun br pc -> Branchpoint (pc, !tree) :: br) - (branch_on_cond b ve pc tree) + match branch_on_cond b ve pc tree with + | None -> bp + | Some pc -> Branchpoint (pc, !tree) :: bp in let pc' = add_constraint ~neg:(not b) ve pc in ((if b then vs1 else vs2), [], mem', pc', bp') @@ -383,7 +447,7 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct with | Some b -> (vs', [ Interrupt (Bug b) @@ e.at ], mem, pc, bp) | None -> - let ty = Evaluations.ty_of_num_type ty in + let ty = Common.Evaluations.ty_of_num_type ty in let v, e = match sz with | None -> Heap.load_value mem base offset ty @@ -431,28 +495,48 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct let v = Evaluations.of_value v.it in ((v, Expr.value (Num v)) :: vs, [], mem, pc, bp) | Test testop, v :: vs' -> ( - try (eval_testop v testop :: vs', [], mem, pc, bp) + try (Evaluations.eval_testop v testop :: vs', [], mem, pc, bp) with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + ( vs' + , [ Trapping (Common.numeric_error e.at exn) @@ e.at ] + , mem + , pc + , bp ) ) | Compare relop, v2 :: v1 :: vs' -> ( - try (eval_relop v1 v2 relop :: vs', [], mem, pc, bp) + try (Evaluations.eval_relop v1 v2 relop :: vs', [], mem, pc, bp) with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + ( vs' + , [ Trapping (Common.numeric_error e.at exn) @@ e.at ] + , mem + , pc + , bp ) ) | Unary unop, v :: vs' -> ( - try (eval_unop v unop :: vs', [], mem, pc, bp) + try (Evaluations.eval_unop v unop :: vs', [], mem, pc, bp) with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + ( vs' + , [ Trapping (Common.numeric_error e.at exn) @@ e.at ] + , mem + , pc + , bp ) ) | Binary binop, v2 :: v1 :: vs' -> ( - try (eval_binop v1 v2 binop :: vs', [], mem, pc, bp) + try (Evaluations.eval_binop v1 v2 binop :: vs', [], mem, pc, bp) with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + ( vs' + , [ Trapping (Common.numeric_error e.at exn) @@ e.at ] + , mem + , pc + , bp ) ) | Convert cvtop, v :: vs' -> ( - try (eval_cvtop cvtop v :: vs', [], mem, pc, bp) + try (Evaluations.eval_cvtop cvtop v :: vs', [], mem, pc, bp) with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) + ( vs' + , [ Trapping (Common.numeric_error e.at exn) @@ e.at ] + , mem + , pc + , bp ) ) | Dup, v :: vs' -> (v :: v :: vs', [], mem, pc, bp) | SymAssert, (I32 0l, _) :: vs' -> - debug ">>> Assert FAILED! Stopping..."; + debug0 ">>> Assert FAILED! Stopping...@."; (vs', [ Interrupt (Failure pc) @@ e.at ], mem, pc, bp) | SymAssert, (I32 _, ex) :: vs' when not Expr.(is_symbolic (simplify ex)) -> @@ -478,7 +562,7 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct if i = 0l then (vs', [ Restart (add_constraint ex pc) @@ e.at ], mem, pc, bp) else ( - debug ">>> Assume passed. Continuing execution..."; + debug0 ">>> Assume passed. Continuing execution...@."; let tree', _ = Execution_tree.move_true !tree in tree := tree'; (vs', [], mem, add_constraint ex pc, bp) ) @@ -491,17 +575,26 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct ((v, Expr.symbol (Symbol.make ty' x)) :: vs', [], mem, pc, bp) | Boolop boolop, (v2, sv2) :: (v1, sv1) :: vs' -> ( let sv2' = mk_relop sv2 (Num.type_of v2) in - let v2' = Num.(num_of_bool (not (v2 = default_value (type_of v2)))) in + let v2' = + Num.(num_of_bool (not (v2 = default_value (Num.type_of v2)))) + in let sv1' = mk_relop sv1 (Num.type_of v1) in let v1' = Num.(num_of_bool (not (v1 = default_value (type_of v1)))) in try - let v3, sv3 = eval_binop (v1', sv1') (v2', sv2') boolop in - ((v3, simplify sv3) :: vs', [], mem, pc, bp) + let v3, sv3 = + Evaluations.eval_binop (v1', sv1') (v2', sv2') boolop + in + ((v3, Expr.simplify sv3) :: vs', [], mem, pc, bp) with exn -> - (vs', [ Trapping (numeric_error e.at exn) @@ e.at ], mem, pc, bp) ) - | Alloc, (I32 a, sa) :: (I32 b, sb) :: vs' -> - Hashtbl.add heap b a; - ((I32 b, SymPtr (b, Val (Num (I32 0l)))) :: vs', [], mem, pc, bp) + ( vs' + , [ Trapping (Common.numeric_error e.at exn) @@ e.at ] + , mem + , pc + , bp ) ) + | Alloc, (I32 size, _) :: (I32 base, _) :: vs' -> + let ptr = Expr.ptr base (Expr.value (Num (I32 0l))) in + Hashtbl.add heap base size; + ((I32 base, ptr) :: vs', [], mem, pc, bp) | Free, (I32 i, _) :: vs' -> let es' = if not (Hashtbl.mem heap i) then @@ -517,93 +610,93 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct with Not_found -> Crash.error e.at "Symbolic variable was not in store." in - ((v, Expression.mk_symbol_s `I32Type x) :: vs', [], mem, pc, bp) + ((v, Expr.symbol (Symbol.make (Ty_bitv 32) x)) :: vs', [], mem, pc, bp) | GetSymInt64 x, vs' -> let v = try Store.find store x with Not_found -> Crash.error e.at "Symbolic variable was not in store." in - ((v, Expression.mk_symbol_s `I64Type x) :: vs', [], mem, pc, bp) + ((v, Expr.symbol (Symbol.make (Ty_bitv 64) x)) :: vs', [], mem, pc, bp) | GetSymFloat32 x, vs' -> let v = try Store.find store x with Not_found -> Crash.error e.at "Symbolic variable was not in store." in - ((v, Expression.mk_symbol_s `F32Type x) :: vs', [], mem, pc, bp) + ((v, Expr.symbol (Symbol.make (Ty_fp 32) x)) :: vs', [], mem, pc, bp) | GetSymFloat64 x, vs' -> let v = try Store.find store x with Not_found -> Crash.error e.at "Symbolic variable was not in store." in - ((v, Expression.mk_symbol_s `F64Type x) :: vs', [], mem, pc, bp) + ((v, Expr.symbol (Symbol.make (Ty_fp 64) x)) :: vs', [], mem, pc, bp) | TernaryOp, (I32 r2, s_r2) :: (I32 r1, s_r1) :: (I32 c, s_c) :: vs' -> let r : Num.t = I32 (if c = 0l then r2 else r1) in - let s_c' = to_relop (simplify s_c) in + let s_c' = to_relop (Expr.simplify s_c) in let v, pc' = match s_c' with | None -> ((r, if c = 0l then s_r2 else s_r1), pc) | Some s -> let x = Store.next store "__ternary" in Store.add store x r; - let s_x = Expression.mk_symbol_s `I32Type x in - let t_eq = Relop (I32 I32.Eq, s_x, s_r1) in - let t_imp = Binop (I32 I32.Or, negate_relop s, t_eq) in - let f_eq = Relop (I32 I32.Eq, s_x, s_r2) in - let f_imp = Binop (I32 I32.Or, s, f_eq) in - let cond = Binop (I32 I32.And, t_imp, f_imp) in + let s_x = Expr.symbol (Symbol.make (Ty_bitv 32) x) in + let t_eq = Expr.relop Ty_bool Eq s_x s_r1 in + let t_imp = + Expr.binop (Ty_bitv 32) Or (Expr.unop Ty_bool Not s) t_eq + in + let f_eq = Expr.relop Ty_bool Eq s_x s_r2 in + let f_imp = Expr.binop (Ty_bitv 32) Or s f_eq in + let cond = Expr.binop (Ty_bitv 32) And t_imp f_imp in ( (r, s_x) - , Expression.add_constraint - (Relop (I32 I32.Ne, cond, Val (Num (I32 0l)))) + , add_constraint + (Expr.relop Ty_bool Ne cond (Expr.value (Num (I32 0l)))) pc ) in (v :: vs', [], mem, pc', bp) | PrintStack, vs' -> - debug - ( Interpreter.Source.string_of_pos e.at.left - ^ ":VS:\n" - ^ Expression.string_of_values vs' ); + debug3 "%s:VS:@\n%a@." + (Interpreter.Source.string_of_pos e.at.left) + pp_value_list vs'; (vs', [], mem, pc, bp) | PrintPC, vs' -> - debug - ( Interpreter.Source.string_of_pos e.at.left - ^ ":PC: " - ^ Expression.(pp_to_string pc) ); + debug3 "%s:PC: %a@." + (Interpreter.Source.string_of_pos e.at.left) + Expr.pp pc; (vs', [], mem, pc, bp) | PrintMemory, vs' -> - debug ("Mem:\n" ^ Heap.to_string mem); + debug1 "Mem:@\n%s@." (Heap.to_string mem); (vs', [], mem, pc, bp) | PrintBtree, vs' -> Printf.printf "B TREE STATE: \n\n"; (* Btree.print_b_tree mem; *) (vs', [], mem, pc, bp) | CompareExpr, (v1, ex1) :: (v2, ex2) :: vs' -> - let res : Num.t * Expression.t = - match (ex1, ex2) with + let res : Num.t * Expr.t = + match (Expr.view ex1, Expr.view ex2) with | Symbol s1, Symbol s2 -> - if Symbol.equal s1 s2 then (I32 1l, Integer.mk_eq ex1 ex2) - else (I32 0l, Integer.mk_ne ex1 ex2) + if Symbol.equal s1 s2 then (I32 1l, Expr.relop Ty_bool Eq ex1 ex2) + else (I32 0l, Expr.relop Ty_bool Ne ex1 ex2) | _, _ -> - eval_relop (v1, ex1) (v2, ex2) + Evaluations.eval_relop (v1, ex1) (v2, ex2) (Interpreter.Values.I32 Interpreter.Ast.I32Op.Eq) in (res :: vs', [], mem, pc, bp) | IsSymbolic, (I32 n, _) :: (I32 i, _) :: vs' -> let base = Interpreter.I64_convert.extend_i32_u i in let _, v = Heap.load_bytes mem base (Int32.to_int n) in - let result : Num.t = I32 (match v with Val _ -> 0l | _ -> 1l) in - ((result, Val (Num result)) :: vs', [], mem, pc, bp) + let result = Num.num_of_bool (Expr.is_symbolic v) in + ((result, Expr.value (Num result)) :: vs', [], mem, pc, bp) | SetPriority, _ :: _ :: _ :: vs' -> (vs', [], mem, pc, bp) | PopPriority, _ :: vs' -> (vs', [], mem, pc, bp) | _ -> Crash.error e.at "missing or ill-typed operand on stack" ) - | Trapping msg, vs -> assert false - | Interrupt i, vs -> assert false - | Restart pc, vs -> assert false - | Returning vs', vs -> Crash.error e.at "undefined frame" - | Breaking (k, vs'), vs -> Crash.error e.at "undefined label" - | Label (n, es0, (vs', [])), vs -> (vs' @ vs, [], mem, pc, bp) + | Trapping _, _ -> assert false + | Interrupt _, _ -> assert false + | Restart _, _ -> assert false + | Returning _, _ -> Crash.error e.at "undefined frame" + | Breaking (_, _), _ -> Crash.error e.at "undefined label" + | Label (_, _, (vs', [])), vs -> (vs' @ vs, [], mem, pc, bp) | Label (n, es0, (vs', { it = Restart pc'; at } :: es')), vs -> ( vs , [ Restart pc' @@ at; Label (n, es0, (vs', es')) @@ e.at ] @@ -616,13 +709,13 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct , mem , pc , bp ) - | Label (n, es0, (vs', { it = Trapping msg; at } :: es')), vs -> + | Label (_, _, (_, { it = Trapping msg; at } :: _)), vs -> (vs, [ Trapping msg @@ at ], mem, pc, bp) - | Label (n, es0, (vs', { it = Returning vs0; at } :: es')), vs -> + | Label (_, _, (_, { it = Returning vs0; at } :: _)), vs -> (vs, [ Returning vs0 @@ at ], mem, pc, bp) - | Label (n, es0, (vs', { it = Breaking (0l, vs0); at } :: es')), vs -> + | Label (n, es0, (_, { it = Breaking (0l, vs0); _ } :: _)), vs -> (take n vs0 e.at @ vs, List.map plain es0, mem, pc, bp) - | Label (n, es0, (vs', { it = Breaking (k, vs0); at } :: es')), vs -> + | Label (_, _, (_, { it = Breaking (k, vs0); at } :: _)), vs -> (vs, [ Breaking (Int32.sub k 1l, vs0) @@ at ], mem, pc, bp) | Label (n, es0, code'), vs -> let c' = step { c with code = code' } in @@ -635,7 +728,7 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct cp := { !cp with code = (vs, es') } ) c'.bp; (vs, [ Label (n, es0, c'.code) @@ e.at ], c'.mem, c'.pc, c'.bp) - | Frame (n, frame', (vs', [])), vs -> + | Frame (_, _, (vs', [])), vs -> ignore (Stack.pop call_stack); (vs' @ vs, [], mem, pc, bp) | Frame (n, frame', (vs', { it = Restart pc'; at } :: es')), vs -> @@ -650,9 +743,9 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct , mem , pc , bp ) - | Frame (n, frame', (vs', { it = Trapping msg; at } :: es')), vs -> + | Frame (_, _, (_, { it = Trapping msg; at } :: _)), vs -> (vs, [ Trapping msg @@ at ], mem, pc, bp) - | Frame (n, frame', (vs', { it = Returning vs0; at } :: es')), vs -> + | Frame (n, _, (_, { it = Returning vs0; _ } :: _)), vs -> (take n vs0 e.at @ vs, [], mem, pc, bp) | Frame (n, frame', code'), vs -> let c' = @@ -680,13 +773,13 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct cp := { !cp with frame = frame'; code = (vs, es') } ) c'.bp; (vs, [ Frame (n, c'.frame, c'.code) @@ e.at ], c'.mem, c'.pc, c'.bp) - | Invoke func, vs when c.budget = 0 -> + | Invoke _, vs when c.budget = 0 -> (vs, [ Interrupt Limit @@ e.at ], mem, pc, bp) | Invoke func, vs -> ( - let symbolic_arg t = + let symbolic_arg ty = let x = Store.next store "arg" in - let v = Store.get store x t false in - (v, Expression.mk_symbol_s t x) + let v = Store.get store x ty false in + (v, Expr.symbol (Symbol.make ty x)) in let (Interpreter.Types.FuncType (ins, out)) = Interpreter.Func.type_of func @@ -694,39 +787,40 @@ module ConcolicStepper (C : Checkpoint) : Stepper = struct let n = List.length ins in let vs = if n > 0 && List.length vs = 0 then - List.map (fun t -> symbolic_arg (Evaluations.to_num_type t)) ins + List.map (fun t -> symbolic_arg (Evaluations.ty_of_num_type t)) ins else vs in let args, vs' = (take n vs e.at, drop n vs e.at) in match func with - | Interpreter.Func.AstFunc (t, inst', f) -> + | Interpreter.Func.AstFunc (_, inst', f) -> Stack.push f.at call_stack; let locals' = List.map - (fun v -> (v, Val (Num v))) + (fun v -> (v, Expr.value (Num v))) (List.map - (fun t -> Num.default_value (Evaluations.to_num_type t)) + (fun t -> default_value (Evaluations.ty_of_num_type t)) f.it.locals ) in let locals'' = List.rev args @ locals' in let code' = ([], [ Plain (Block (out, f.it.body)) @@ f.at ]) in let frame' = { inst = !inst'; locals = List.map ref locals'' } in (vs', [ Frame (List.length out, frame', code') @@ e.at ], mem, pc, bp) - | Interpreter.Func.HostFunc (t, f) -> failwith "HostFunc error" ) + | Interpreter.Func.HostFunc (_, _) -> failwith "HostFunc error" ) in step_cnt := !step_cnt + 1; { c with code = (vs', es' @ List.tl es); mem = mem'; pc = pc'; bp = bp' } end let get_reason (err_t, at) : string = + let open Source in let loc = - Interpreter.Source.string_of_pos at.left + Source.string_of_pos at.left ^ if at.right = at.left then "" else "-" ^ string_of_pos at.right in "{" ^ "\"type\" : \"" ^ err_t ^ "\", " ^ "\"line\" : \"" ^ loc ^ "\"" ^ "}" let write_report error loop_time : unit = - if !Interpreter.Flags.log then print_logs !logs; + if !Interpreter.Flags.log then Common.print_logs !logs; let spec, reason = match error with None -> (true, "{}") | Some e -> (false, get_reason e) in @@ -745,6 +839,7 @@ let write_report error loop_time : unit = report_str let rec update_admin_instr f e = + let open Source in let it = match e.it with | Plain e -> Plain e @@ -763,10 +858,13 @@ let rec update_admin_instr f e = { it; at = e.at } let update c (vs, es) pc symbols = - let binds = Batch.value_binds solver ~symbols in + let model = Option.get (Batch.model ~symbols solver) in + let binds = Model.get_bindings model in Store.update c.store binds; Heap.update c.mem c.store; - let f store (_, expr) = (Store.eval store expr, expr) in + let f store (_, expr) = + ((match Store.eval store expr with Num n -> n | _ -> assert false), expr) + in List.iter (fun l -> l := f c.store !l) c.frame.locals; let code = (List.map (f c.store) vs, List.map (update_admin_instr (f c.store)) es) @@ -774,27 +872,35 @@ let update c (vs, es) pc symbols = { c with code; pc } let reset c glob code mem = - let binds = Batch.value_binds solver ~symbols:(Store.get_key_types c.store) in + let model = + Option.get (Batch.model ~symbols:(Store.get_key_types c.store) solver) + in + let binds = Model.get_bindings model in Store.reset c.store; Store.init c.store binds; let glob = Globals.copy glob in Hashtbl.reset c.heap; c.tree := head; { c with - frame = frame empty_module_inst [] + frame = frame Instance.empty_module_inst [] ; code ; glob ; mem = Heap.memcpy mem - ; pc = Boolean.mk_val true + ; pc = Expr.value True ; bp = [] ; budget = Interpreter.Flags.budget } let s_reset (c : config) : config = - let binds = Batch.value_binds solver ~symbols:(Store.get_key_types c.store) in + let model = + Option.get (Batch.model ~symbols:(Store.get_key_types c.store) solver) + in + let binds = Model.get_bindings model in Store.update c.store binds; Heap.update c.mem c.store; - let f store (_, expr) = (Store.eval store expr, expr) in + let f store (_, expr) = + ((match Store.eval store expr with Num n -> n | _ -> assert false), expr) + in List.iter (fun l -> l := f c.store !l) c.frame.locals; c.tree := head; let vs, es = c.code in @@ -803,7 +909,7 @@ let s_reset (c : config) : config = in { c with code } -module Guided_search (L : WorkList) (S : Stepper) = struct +module Guided_search (L : Common.WorkList) (S : Stepper) = struct let enqueue (pc_wl, cp_wl) branch_points : unit = List.iter (fun bp -> @@ -814,14 +920,14 @@ module Guided_search (L : WorkList) (S : Stepper) = struct let rec eval (c : config) wls : config = match c.code with - | vs, [] -> c - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, { it = Interrupt Limit; at } :: _ -> { c with code = (vs, []) } - | vs, { it = Interrupt i; at } :: _ -> c - | vs, { it = Restart pc; at } :: _ -> + | _, [] -> c + | _, { it = Trapping msg; at } :: _ -> Trap.error at msg + | vs, { it = Interrupt Limit; _ } :: _ -> { c with code = (vs, []) } + | _, { it = Interrupt _; _ } :: _ -> c + | _, { it = Restart _; _ } :: _ -> iterations := !iterations - 1; c - | vs, es -> + | _, _ -> let c' = S.step c in enqueue wls c'.bp; eval { c' with bp = [] } wls @@ -830,20 +936,24 @@ module Guided_search (L : WorkList) (S : Stepper) = struct if L.is_empty pcs then None else let pc, node = L.pop pcs in - if not (Batch.check_sat solver [ pc ]) then find_sat_pc pcs - else Some (pc, Execution_tree.find node) + match Batch.check solver [ pc ] with + | `Sat -> Some (pc, Execution_tree.find node) + | `Unsat -> find_sat_pc pcs + | `Unknown -> assert false let rec find_sat_cp cps = if L.is_empty cps then None else let cp = L.pop cps in - if not (Batch.check_sat solver [ !cp.pc ]) then find_sat_cp cps - else Some (!cp.pc, Some cp) + match Batch.check solver [ !cp.pc ] with + | `Sat -> Some (!cp.pc, Some cp) + | `Unsat -> find_sat_cp cps + | `Unknown -> assert false let find_sat_path (pcs, cps) = match find_sat_cp cps with None -> find_sat_pc pcs | Some _ as cp -> cp - let invoke (c : config) (test_suite : string) = + let invoke (c : config) (_test_suite : string) = let glob0 = Globals.copy c.glob and code0 = c.code and mem0 = Heap.memcpy c.mem in @@ -852,37 +962,39 @@ module Guided_search (L : WorkList) (S : Stepper) = struct (* Main concolic loop *) let rec loop c = iterations := !iterations + 1; - let { code; store; bp; tree; _ } = eval c (pc_wl, cp_wl) in + let { code; store; bp; _ } = eval c (pc_wl, cp_wl) in enqueue (pc_wl, cp_wl) bp; match code with - | vs, { it = Interrupt i; at } :: _ -> - write_test_case ~witness:true (Store.to_json store); + | _, { it = Interrupt i; at } :: _ -> + Common.write_test_case ~witness:true (Store.to_json store); Some (string_of_interruption i, at) - | vs, { it = Restart pc; _ } :: es when Batch.check_sat solver [ pc ] -> + | vs, { it = Restart pc; _ } :: es + when match Batch.check solver [ pc ] with `Sat -> true | _ -> false -> let tree', _ = Execution_tree.move_true !(c.tree) in c.tree := tree'; loop (update c (vs, es) pc (Store.get_key_types store)) | _ -> ( - write_test_case (Store.to_json store); + Common.write_test_case (Store.to_json store); match find_sat_path (pc_wl, cp_wl) with | None -> None - | Some (pc', None) -> loop (reset c glob0 code0 mem0) + | Some (_, None) -> loop (reset c glob0 code0 mem0) | Some (pc', Some cp) -> let _, c' = clone !cp in - loop (update c' c'.code c'.pc (Expression.get_symbols [ pc' ])) ) + loop (update c' c'.code c'.pc (Expr.get_symbols [ pc' ])) ) in loop c - let s_invoke (c : config) (test_suite : string) : (string * region) option = + let s_invoke (c : config) (_test_suite : string) : + (string * Source.region) option = let _, c0 = clone c in let wl = L.create () in let rec eval (c : config) : config = match c.code with - | vs, [] -> c - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, { it = Restart pc; at } :: es -> c - | vs, { it = Interrupt i; at } :: es -> c - | vs, es -> + | _, [] -> c + | _, { it = Trapping msg; at } :: _ -> Trap.error at msg + | _, { it = Restart _; _ } :: _ -> c + | _, { it = Interrupt _; _ } :: _ -> c + | _, _ -> let c' = S.step c in List.iter (fun bp -> @@ -897,13 +1009,16 @@ module Guided_search (L : WorkList) (S : Stepper) = struct in let rec find_sat_pc pcs = if L.is_empty pcs then false - else if not (Batch.check_sat solver [ L.pop pcs ]) then find_sat_pc pcs - else true + else + (* FIXME: Don't we lose this pc? *) + match Batch.check solver [ L.pop pcs ] with + | `Sat -> true + | `Unsat | `Unknown -> find_sat_pc pcs in (* Main concolic loop *) let rec loop (c : config) = iterations := !iterations + 1; - let { code; store; bp; pc; _ } = eval c in + let { code; store; bp; _ } = eval c in List.iter (fun bp -> let pc = @@ -912,20 +1027,21 @@ module Guided_search (L : WorkList) (S : Stepper) = struct L.push pc wl ) bp; match code with - | vs, { it = Interrupt i; at } :: _ -> - write_test_case ~witness:true (Store.to_json store); + | _, { it = Interrupt i; at } :: _ -> + Common.write_test_case ~witness:true (Store.to_json store); Some (string_of_interruption i, at) - | vs, { it = Restart pc; _ } :: es -> + | vs, { it = Restart pc; _ } :: es -> ( print_endline "--- attempting restart ---"; iterations := !iterations - 1; - if Batch.check_sat solver [ pc ] then - loop (update c (vs, es) pc (Store.get_key_types store)) - else if L.is_empty wl || not (find_sat_pc wl) then None - else - let _, c' = clone c0 in - loop (s_reset c') + match Batch.check solver [ pc ] with + | `Sat -> loop (update c (vs, es) pc (Store.get_key_types store)) + | `Unsat | `Unknown -> + if L.is_empty wl || not (find_sat_pc wl) then None + else + let _, c' = clone c0 in + loop (s_reset c') ) | _ -> - write_test_case (Store.to_json store); + Common.write_test_case (Store.to_json store); if L.is_empty wl || not (find_sat_pc wl) then None else let _, c' = clone c0 in @@ -934,27 +1050,27 @@ module Guided_search (L : WorkList) (S : Stepper) = struct let error = loop c in error - let p_invoke (c : config) (test_suite : string) : - (Expression.t, string * region) result = + let p_invoke (c : config) (_test_suite : string) : + (Expr.t, string * Source.region) result = let rec eval (c : config) : config = match c.code with - | vs, [] -> c - | vs, { it = Trapping msg; at } :: _ -> Trap.error at msg - | vs, { it = Restart pc; at } :: es -> + | _, [] -> c + | _, { it = Trapping msg; at } :: _ -> Trap.error at msg + | _, { it = Restart _; _ } :: _ -> c (* TODO: probably need to change this *) - | vs, { it = Interrupt i; at } :: es -> c - | vs, es -> + | _, { it = Interrupt _; _ } :: _ -> c + | _, _ -> let c' = S.step c in eval c' in let c' = eval c in let res = match c'.code with - | vs, { it = Interrupt i; at } :: _ -> - write_test_case ~witness:true (Store.to_json c'.store); + | _, { it = Interrupt i; at } :: _ -> + Common.write_test_case ~witness:true (Store.to_json c'.store); Result.error (string_of_interruption i, at) | _ -> - write_test_case (Store.to_json c'.store); + Common.write_test_case (Store.to_json c'.store); Result.ok c.pc in res @@ -966,7 +1082,7 @@ module RandCheckpointStepper = ConcolicStepper (RandCheckpoint) module DepthCheckpointStepper = ConcolicStepper (DepthCheckpoint) module DFS = Guided_search (Stack) (NoCheckpointStepper) module BFS = Guided_search (Queue) (NoCheckpointStepper) -module RND = Guided_search (RandArray) (NoCheckpointStepper) +module RND = Guided_search (Common.RandArray) (NoCheckpointStepper) let exiter _ = let loop_time = Sys.time () -. !loop_start in @@ -978,13 +1094,15 @@ let set_timeout (time_limit : int) : unit = Sys.(set_signal sigalrm (Signal_handle exiter)); ignore (Unix.alarm time_limit) ) -let main (func : func_inst) (vs : value list) (inst : module_inst) - (mem0 : Heap.t) = +let main (func : Instance.func_inst) (vs : value list) + (inst : Instance.module_inst) (mem0 : Heap.t) = let open Interpreter in set_timeout !Flags.timeout; let test_suite = Filename.concat !Flags.output "test_suite" in Io.safe_mkdir test_suite; - let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in + let at = + match func with Func.AstFunc (_, _, f) -> f.at | _ -> Source.no_region + in let glob = Globals.of_seq (Seq.mapi @@ -996,8 +1114,8 @@ let main (func : func_inst) (vs : value list) (inst : module_inst) (List.to_seq inst.globals) ) in let c = - config empty_module_inst (List.rev vs) - [ Invoke func @@ at ] + config Instance.empty_module_inst (List.rev vs) + Source.[ Invoke func @@ at ] mem0 glob (ref head) in let invoke = @@ -1009,7 +1127,7 @@ let main (func : func_inst) (vs : value list) (inst : module_inst) in ( if !Interpreter.Flags.log then let get_finished () : int = !iterations in - logger logs get_finished exiter loop_start ); + Common.logger logs get_finished exiter loop_start ); loop_start := Sys.time (); let error = invoke c test_suite in write_report error (Sys.time () -. !loop_start) @@ -1019,23 +1137,34 @@ let i32 (v : Interpreter.Values.value) at = | Interpreter.Values.I32 i -> i | _ -> Crash.error at "type error: i32 value expected" -let create_func (inst : module_inst) (f : func) : func_inst = +let create_func inst f = + let open Ast in + let open Source in Interpreter.Func.alloc (type_ inst f.it.ftype) (ref inst) f -let create_table (_ : module_inst) (tab : table) : table_inst = +let create_table _ tab = + let open Ast in + let open Source in let { ttype } = tab.it in Interpreter.Table.alloc ttype -let create_memory (_ : module_inst) (mem : memory) : memory_inst = +let create_memory _ mem = + let open Ast in + let open Source in let { mtype } = mem.it in Interpreter.Memory.alloc mtype -let create_global (inst : module_inst) (glob : global) : global_inst = +let create_global inst glob = + let open Ast in + let open Source in let { gtype; value } = glob.it in let v = Interpreter.Eval.eval_const inst value in Interpreter.Global.alloc gtype v -let create_export (inst : module_inst) (ex : export) : export_inst = +let create_export inst ex = + let open Ast in + let open Source in + let open Instance in let { name; edesc } = ex.it in let ext = match edesc.it with @@ -1046,25 +1175,30 @@ let create_export (inst : module_inst) (ex : export) : export_inst = in (name, ext) -let init_func (inst : module_inst) (func : func_inst) = +let init_func inst func = match func with | Interpreter.Func.AstFunc (_, inst_ref, _) -> inst_ref := inst | _ -> assert false -let init_table (inst : module_inst) (seg : table_segment) = +let init_table inst seg = + let open Ast in let open Interpreter in + let open Source in let { index; offset = const; init } = seg.it in let tab = table inst index in let offset = i32 (Eval.eval_const inst const) const.at in let end_ = Int32.(add offset (of_int (List.length init))) in let bound = Table.size tab in if I32.lt_u bound end_ || I32.lt_u end_ offset then - Link.error seg.at "elements segment does not fit table"; + Common.Link.error seg.at "elements segment does not fit table"; fun () -> - Table.blit tab offset (List.map (fun x -> FuncElem (func inst x)) init) + Table.blit tab offset + (List.map (fun x -> Instance.FuncElem (func inst x)) init) -let init_memory (inst : module_inst) (sym_mem : Heap.t) (seg : memory_segment) = +let init_memory inst sym_mem seg = + let open Ast in let open Interpreter in + let open Source in let { index; offset = const; init } = seg.it in let mem = memory inst index in let offset' = i32 (Eval.eval_const inst const) const.at in @@ -1072,22 +1206,24 @@ let init_memory (inst : module_inst) (sym_mem : Heap.t) (seg : memory_segment) = let end_ = Int64.(add offset (of_int (String.length init))) in let bound = Memory.bound mem in if I64.lt_u bound end_ || I64.lt_u end_ offset then - Link.error seg.at "data segment does not fit memory"; + Common.Link.error seg.at "data segment does not fit memory"; fun () -> Heap.store_bytes sym_mem offset init -let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : - module_inst = +let add_import m ext im inst = let open Interpreter in - if not (Types.match_extern_type (extern_type_of ext) (import_type m im)) then - Link.error im.at "incompatible import type"; + let open Instance in + if not (Types.match_extern_type (extern_type_of ext) (Ast.import_type m im)) + then Common.Link.error im.Source.at "incompatible import type"; match ext with | ExternFunc func -> { inst with funcs = func :: inst.funcs } | ExternTable tab -> { inst with tables = tab :: inst.tables } | ExternMemory mem -> { inst with memories = mem :: inst.memories } | ExternGlobal glob -> { inst with globals = glob :: inst.globals } -let init (m : module_) (exts : extern list) = +let init m exts = + let open Ast in let open Interpreter in + let open Source in let { imports ; tables ; memories @@ -1102,9 +1238,9 @@ let init (m : module_) (exts : extern list) = m.it in if List.length exts <> List.length imports then - Link.error m.at "wrong number of imports provided for initialisation"; + Common.Link.error m.at "wrong number of imports provided for initialisation"; let inst0 = - { (List.fold_right2 (add_import m) exts imports empty_module_inst) with + { (List.fold_right2 (add_import m) exts imports Instance.empty_module_inst) with types = List.map (fun type_ -> type_.it) types } in diff --git a/src/dune b/src/dune index a373d064..0af2843a 100644 --- a/src/dune +++ b/src/dune @@ -3,4 +3,4 @@ (library (name wasp) (modules :standard \ btree) - (libraries interpreter concolic static smtml)) + (libraries interpreter smtml concolic)) diff --git a/src/run.ml b/src/run.ml index e7044e38..78034521 100644 --- a/src/run.ml +++ b/src/run.ml @@ -1,5 +1,3 @@ -open Encoding.Value -open Encoding.Expression open Interpreter open Script open Source @@ -11,7 +9,9 @@ module Assert = Error.Make () module IO = Error.Make () exception Abort = Abort.Error + exception Assert = Assert.Error + exception IO = IO.Error let trace name = if !Flags.trace then print_endline ("-- " ^ name) @@ -19,9 +19,13 @@ let trace name = if !Flags.trace then print_endline ("-- " ^ name) (* File types *) let binary_ext = "wasm" + let sexpr_ext = "wat" + let script_binary_ext = "bin.wast" + let script_ext = "wast" + let js_ext = "js" let dispatch_file_ext on_binary on_sexpr on_script_binary on_script on_js file = @@ -123,7 +127,7 @@ let input_sexpr name lexbuf run = input_from (fun _ -> let var_opt, def = Parse.parse name lexbuf Parse.Module in - [ Module (var_opt, def) @@ no_region ]) + [ Module (var_opt, def) @@ no_region ] ) run let input_binary name buf run = @@ -160,7 +164,7 @@ let input_binary_file file run = close_in ic; raise exn -let input_js_file file run = +let input_js_file file _run = raise (Sys_error (file ^ ": unrecognized input file type")) let input_file file run = @@ -170,11 +174,11 @@ let input_file file run = (input_sexpr_file (input_script Parse.Script)) input_js_file file run -let input_string string run = +let input_string string ~callback = trace ("Running (\"" ^ String.escaped string ^ "\")..."); let lexbuf = Lexing.from_string string in trace "Parsing..."; - input_script Parse.Script "string" lexbuf run + input_script Parse.Script "string" lexbuf callback (* Interactive *) @@ -266,9 +270,9 @@ let string_of_result r = match r with | LitResult v -> Values.string_of_value v.it | NanResult nanop -> ( - match nanop.it with - | Values.I32 _ | Values.I64 _ -> assert false - | Values.F32 n | Values.F64 n -> string_of_nan n) + match nanop.it with + | Values.I32 _ | Values.I64 _ -> assert false + | Values.F32 n | Values.F64 n -> string_of_nan n ) let string_of_results = function | [ r ] -> string_of_result r @@ -285,10 +289,15 @@ let print_results rs = module Map = Map.Make (String) let quote : script ref = ref [] + let scripts : script Map.t ref = ref Map.empty + let modules : Ast.module_ Map.t ref = ref Map.empty + let instances : Instance.module_inst Map.t ref = ref Map.empty + let registry : Instance.module_inst Map.t ref = ref Map.empty + let memories : Concolic.Heap.t Map.t ref = ref Map.empty let bind map x_opt y = @@ -300,12 +309,15 @@ let lookup category map x_opt at = try Map.find key !map with Not_found -> IO.error at - (if key = "" then "no " ^ category ^ " defined" - else "unknown " ^ category ^ " " ^ key) + ( if key = "" then "no " ^ category ^ " defined" + else "unknown " ^ category ^ " " ^ key ) let lookup_script = lookup "script" scripts + let lookup_module = lookup "module" modules + let lookup_instance = lookup "module" instances + let lookup_memory = lookup "memory" memories let lookup_registry module_name item_name _t = @@ -319,32 +331,32 @@ let rec run_definition def : Ast.module_ = match def.it with | Textual m -> m | Encoded (name, bs) -> - trace "Decoding..."; - Decode.decode name bs + trace "Decoding..."; + Decode.decode name bs | Quoted (_, s) -> - trace "Parsing quote..."; - let def' = Parse.string_to_module s in - run_definition def' + trace "Parsing quote..."; + let def' = Parse.string_to_module s in + run_definition def' let run_action act invoke : Values.value list = match act.it with | Invoke (x_opt, name, vs) -> ( - trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in - let memory = lookup_memory x_opt act.at in - match Instance.export inst name with - | Some (Instance.ExternFunc f) -> - invoke f vs inst memory; - [] - | Some _ -> Assert.error act.at "export is not a function" - | None -> Assert.error act.at "undefined export") + trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + let memory = lookup_memory x_opt act.at in + match Instance.export inst name with + | Some (Instance.ExternFunc f) -> + invoke f vs inst memory; + [] + | Some _ -> Assert.error act.at "export is not a function" + | None -> Assert.error act.at "undefined export" ) | Get (x_opt, name) -> ( - trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt act.at in - match Instance.export inst name with - | Some (Instance.ExternGlobal gl) -> [ Global.load gl ] - | Some _ -> Assert.error act.at "export is not a global" - | None -> Assert.error act.at "undefined export") + trace ("Getting global \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt act.at in + match Instance.export inst name with + | Some (Instance.ExternGlobal gl) -> [ Global.load gl ] + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" ) let assert_result at got expect = let open Values in @@ -355,23 +367,23 @@ let assert_result at got expect = match r with | LitResult v' -> v <> v'.it | NanResult nanop -> ( - match (nanop.it, v) with - | F32 CanonicalNan, F32 z -> z <> F32.pos_nan && z <> F32.neg_nan - | F64 CanonicalNan, F64 z -> z <> F64.pos_nan && z <> F64.neg_nan - | F32 ArithmeticNan, F32 z -> - let pos_nan = F32.to_bits F32.pos_nan in - Int32.logand (F32.to_bits z) pos_nan <> pos_nan - | F64 ArithmeticNan, F64 z -> - let pos_nan = F64.to_bits F64.pos_nan in - Int64.logand (F64.to_bits z) pos_nan <> pos_nan - | _, _ -> false)) + match (nanop.it, v) with + | F32 CanonicalNan, F32 z -> z <> F32.pos_nan && z <> F32.neg_nan + | F64 CanonicalNan, F64 z -> z <> F64.pos_nan && z <> F64.neg_nan + | F32 ArithmeticNan, F32 z -> + let pos_nan = F32.to_bits F32.pos_nan in + Int32.logand (F32.to_bits z) pos_nan <> pos_nan + | F64 ArithmeticNan, F64 z -> + let pos_nan = F64.to_bits F64.pos_nan in + Int64.logand (F64.to_bits z) pos_nan <> pos_nan + | _, _ -> false ) ) got expect then ( print_string "Result: "; print_values got; print_string "Expect: "; print_results expect; - Assert.error at "wrong return values") + Assert.error at "wrong return values" ) let assert_message at name msg re = if @@ -380,126 +392,124 @@ let assert_message at name msg re = then ( print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); - Assert.error at ("wrong " ^ name ^ " error")) + Assert.error at ("wrong " ^ name ^ " error") ) let run_assertion ass invoke = match ass.it with | AssertMalformed (def, re) -> ( - trace "Asserting malformed..."; - match ignore (run_definition def) with - | exception Decode.Code (_, msg) -> - assert_message ass.at "decoding" msg re - | exception Parse.Syntax (_, msg) -> - assert_message ass.at "parsing" msg re - | _ -> Assert.error ass.at "expected decoding/parsing error") + trace "Asserting malformed..."; + match ignore (run_definition def) with + | exception Decode.Code (_, msg) -> assert_message ass.at "decoding" msg re + | exception Parse.Syntax (_, msg) -> assert_message ass.at "parsing" msg re + | _ -> Assert.error ass.at "expected decoding/parsing error" ) | AssertInvalid (def, re) -> ( - trace "Asserting invalid..."; - match - let m = run_definition def in - Valid.check_module m - with - | exception Valid.Invalid (_, msg) -> - assert_message ass.at "validation" msg re - | _ -> Assert.error ass.at "expected validation error") - | AssertUnlinkable (def, re) -> ( - trace "Asserting unlinkable..."; + trace "Asserting invalid..."; + match let m = run_definition def in - if not !Flags.unchecked then Valid.check_module m; - match - let imports = Import.link m in - ignore (Concolic.Eval.init m imports) - with - | exception (Import.Unknown (_, msg) | Common.Link (_, msg)) -> - assert_message ass.at "linking" msg re - | _ -> Assert.error ass.at "expected linking error") + Valid.check_module m + with + | exception Valid.Invalid (_, msg) -> + assert_message ass.at "validation" msg re + | _ -> Assert.error ass.at "expected validation error" ) + | AssertUnlinkable (def, re) -> ( + trace "Asserting unlinkable..."; + let m = run_definition def in + if not !Flags.unchecked then Valid.check_module m; + match + let imports = Import.link m in + ignore (Concolic.Eval.init m imports) + with + | exception (Import.Unknown (_, msg) | Common.Link (_, msg)) -> + assert_message ass.at "linking" msg re + | _ -> Assert.error ass.at "expected linking error" ) | AssertUninstantiable (def, re) -> ( - trace "Asserting trap..."; - let m = run_definition def in - if not !Flags.unchecked then Valid.check_module m; - match - let imports = Import.link m in - ignore (Concolic.Eval.init m imports) - with - | exception Common.Trap (_, msg) -> - assert_message ass.at "instantiation" msg re - | _ -> Assert.error ass.at "expected instantiation error") + trace "Asserting trap..."; + let m = run_definition def in + if not !Flags.unchecked then Valid.check_module m; + match + let imports = Import.link m in + ignore (Concolic.Eval.init m imports) + with + | exception Common.Trap (_, msg) -> + assert_message ass.at "instantiation" msg re + | _ -> Assert.error ass.at "expected instantiation error" ) | AssertReturn (act, rs) -> - trace "Asserting return..."; - let got_vs = run_action act invoke in - let expect_rs = List.map (fun r -> r.it) rs in - assert_result ass.at got_vs expect_rs + trace "Asserting return..."; + let got_vs = run_action act invoke in + let expect_rs = List.map (fun r -> r.it) rs in + assert_result ass.at got_vs expect_rs | AssertTrap (act, re) -> ( - trace "Asserting trap..."; - match run_action act invoke with - | exception Common.Trap (_, msg) -> assert_message ass.at "runtime" msg re - | _ -> Assert.error ass.at "expected runtime error") + trace "Asserting trap..."; + match run_action act invoke with + | exception Common.Trap (_, msg) -> assert_message ass.at "runtime" msg re + | _ -> Assert.error ass.at "expected runtime error" ) | AssertExhaustion (act, re) -> ( - trace "Asserting exhaustion..."; - match run_action act invoke with - | exception Common.Exhaustion (_, msg) -> - assert_message ass.at "exhaustion" msg re - | _ -> Assert.error ass.at "expected exhaustion error") + trace "Asserting exhaustion..."; + match run_action act invoke with + | exception Common.Exhaustion (_, msg) -> + assert_message ass.at "exhaustion" msg re + | _ -> Assert.error ass.at "expected exhaustion error" ) let rec run_command cmd invoke = match cmd.it with | Module (x_opt, def) -> - quote := cmd :: !quote; - let m = run_definition def in - if not !Flags.unchecked then ( - trace "Checking..."; - Valid.check_module m; - if !Flags.print_sig then ( - trace "Signature:"; - print_module x_opt m)); - bind scripts x_opt [ cmd ]; - bind modules x_opt m; - if not !Flags.dry then ( - trace "Initializing..."; - let imports = Import.link m in - let memory, inst = Concolic.Eval.init m imports in - bind memories x_opt memory; - bind instances x_opt inst) + quote := cmd :: !quote; + let m = run_definition def in + if not !Flags.unchecked then ( + trace "Checking..."; + Valid.check_module m; + if !Flags.print_sig then ( + trace "Signature:"; + print_module x_opt m ) ); + bind scripts x_opt [ cmd ]; + bind modules x_opt m; + if not !Flags.dry then ( + trace "Initializing..."; + let imports = Import.link m in + let memory, inst = Concolic.Eval.init m imports in + bind memories x_opt memory; + bind instances x_opt inst ) | Register (name, x_opt) -> - quote := cmd :: !quote; - if not !Flags.dry then ( - trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); - let inst = lookup_instance x_opt cmd.at in - registry := Map.add (Utf8.encode name) inst !registry; - Import.register name (lookup_registry (Utf8.encode name))) + quote := cmd :: !quote; + if not !Flags.dry then ( + trace ("Registering module \"" ^ Ast.string_of_name name ^ "\"..."); + let inst = lookup_instance x_opt cmd.at in + registry := Map.add (Utf8.encode name) inst !registry; + Import.register name (lookup_registry (Utf8.encode name)) ) | Action act -> - quote := cmd :: !quote; - if not !Flags.dry then - let vs = run_action act invoke in - if vs <> [] then print_values vs + quote := cmd :: !quote; + if not !Flags.dry then + let vs = run_action act invoke in + if vs <> [] then print_values vs | Assertion ass -> - quote := cmd :: !quote; - if not !Flags.dry then run_assertion ass invoke + quote := cmd :: !quote; + if not !Flags.dry then run_assertion ass invoke | Meta cmd -> run_meta cmd invoke and run_meta cmd invoke = match cmd.it with | Script (x_opt, script) -> - run_quote_script script invoke; - bind scripts x_opt (lookup_script None cmd.at) + run_quote_script script invoke; + bind scripts x_opt (lookup_script None cmd.at) | Input (x_opt, file) -> - (try - if not (input_file file (fun s -> run_quote_script s invoke)) then - Abort.error cmd.at "aborting" - with Sys_error msg -> IO.error cmd.at msg); - bind scripts x_opt (lookup_script None cmd.at); - if x_opt <> None then ( - bind modules x_opt (lookup_module None cmd.at); - if not !Flags.dry then - bind instances x_opt (lookup_instance None cmd.at)) + ( try + if not (input_file file (fun s -> run_quote_script s invoke)) then + Abort.error cmd.at "aborting" + with Sys_error msg -> IO.error cmd.at msg ); + bind scripts x_opt (lookup_script None cmd.at); + if x_opt <> None then ( + bind modules x_opt (lookup_module None cmd.at); + if not !Flags.dry then bind instances x_opt (lookup_instance None cmd.at) + ) | Output (x_opt, Some file) -> ( - try - output_file file - (fun () -> lookup_script x_opt cmd.at) - (fun () -> lookup_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) + try + output_file file + (fun () -> lookup_script x_opt cmd.at) + (fun () -> lookup_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg ) | Output (x_opt, None) -> ( - try output_stdout (fun () -> lookup_module x_opt cmd.at) - with Sys_error msg -> IO.error cmd.at msg) + try output_stdout (fun () -> lookup_module x_opt cmd.at) + with Sys_error msg -> IO.error cmd.at msg ) and run_script script invoke = List.iter (fun cmd -> run_command cmd invoke) script @@ -507,31 +517,42 @@ and run_script script invoke = and run_quote_script script invoke = let save_quote = !quote in quote := []; - (try run_script script invoke - with exn -> - quote := save_quote; - raise exn); + ( try run_script script invoke + with exn -> + quote := save_quote; + raise exn ); bind scripts None (List.rev !quote); quote := !quote @ save_quote -let invoke_ce f vs inst = +let invoke_concolic f vs inst = Concolic.Eval.main f (List.map (fun v -> let v' = Common.Evaluations.of_value v.it in - (v', Val (Num v'))) - vs) + (v', Smtml.Expr.value (Num v')) ) + vs ) inst -let invoke_se f vs _ = - Static.Eval.invoke f - (List.map - (fun v -> - let v' = Common.Evaluations.of_value v.it in - Val (Num v')) - vs) +(* let invoke_se f vs _ = *) +(* Static.Eval.invoke f *) +(* (List.map *) +(* (fun v -> *) +(* let v' = Common.Evaluations.of_value v.it in *) +(* Val (Num v')) *) +(* vs) *) + +let run_file _file = + (* input_file file run_script *) + assert false + +let run_string_concolic string = + input_string string ~callback:(fun s -> run_script s invoke_concolic) + +(* let run_string_se string = *) +(* input_string string ~callback:(fun s -> run_script s invoke_se) *) + +let _ = input_stdin -let run_file file = input_file file run_script -let run_string_ce string = input_string string (fun s -> run_script s invoke_ce) -let run_string_se string = input_string string (fun s -> run_script s invoke_se) -let run_stdin () = input_stdin run_script +let run_stdin () = + (* input_stdin run_script *) + assert false diff --git a/src/run.mli b/src/run.mli index 27c7fe28..b8ca5bf7 100644 --- a/src/run.mli +++ b/src/run.mli @@ -1,11 +1,15 @@ open Interpreter exception Abort of Source.region * string + exception Assert of Source.region * string + exception IO of Source.region * string val trace : string -> unit -val run_string_ce : string -> bool -val run_string_se : string -> bool + +val run_string_concolic : string -> bool + val run_file : string -> bool + val run_stdin : unit -> unit diff --git a/src/static/dune b/src/static/dune index 31c9b7cf..5cc5e7a0 100644 --- a/src/static/dune +++ b/src/static/dune @@ -1,3 +1,3 @@ -(library - (name static) - (libraries interpreter common smtml concolic)) +; (library +; (name static) +; (libraries interpreter common smtml concolic)) From 6d734a14861f6a42abceeec73f63b8170085f781 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Sat, 24 Aug 2024 09:53:57 +0200 Subject: [PATCH 6/8] Fmt static --- bin/wasp_se.ml | 88 +- src/static/eval.ml | 1602 +++++++++++++++++-------------------- src/static/evaluations.ml | 98 ++- src/static/memory.ml | 150 ++-- src/static/memory.mli | 25 +- src/static/strategies.ml | 139 ++-- src/static/varmap.ml | 17 +- 7 files changed, 1022 insertions(+), 1097 deletions(-) diff --git a/bin/wasp_se.ml b/bin/wasp_se.ml index 3e124fff..4f9be121 100644 --- a/bin/wasp_se.ml +++ b/bin/wasp_se.ml @@ -1,6 +1,7 @@ open Interpreter let name = "WebAssembly Static Executor" + let version = "v0.1" let configure () = @@ -8,56 +9,59 @@ let configure () = Import.register (Utf8.decode "env") Env.lookup let banner () = print_endline (name ^ " " ^ version) + let usage = "Usage: " ^ name ^ " [option] [file ...]" + let args = ref [] + let add_arg source = args := !args @ [ source ] + let quote s = "\"" ^ String.escaped s ^ "\"" let argspec = Arg.align - [ - ( "-", - Arg.Set Flags.interactive, - " run interactively (default if no files given)" ); - ("-e", Arg.String add_arg, " evaluate string"); - ( "-i", - Arg.String (fun file -> add_arg ("(input " ^ quote file ^ ")")), - " read script from file" ); - ( "-o", - Arg.String (fun file -> add_arg ("(output " ^ quote file ^ ")")), - " write module to file" ); - ("-s", Arg.Set Flags.print_sig, " show module signatures"); - ("-u", Arg.Set Flags.unchecked, " unchecked, do not perform validation"); - ("-h", Arg.Clear Flags.harness, " exclude harness for JS conversion"); - ("-d", Arg.Set Flags.dry, " dry, do not run program"); - ("-t", Arg.Set Flags.trace, " trace execution"); - ( "-v", - Arg.Unit + [ ( "-" + , Arg.Set Flags.interactive + , " run interactively (default if no files given)" ) + ; ("-e", Arg.String add_arg, " evaluate string") + ; ( "-i" + , Arg.String (fun file -> add_arg ("(input " ^ quote file ^ ")")) + , " read script from file" ) + ; ( "-o" + , Arg.String (fun file -> add_arg ("(output " ^ quote file ^ ")")) + , " write module to file" ) + ; ("-s", Arg.Set Flags.print_sig, " show module signatures") + ; ("-u", Arg.Set Flags.unchecked, " unchecked, do not perform validation") + ; ("-h", Arg.Clear Flags.harness, " exclude harness for JS conversion") + ; ("-d", Arg.Set Flags.dry, " dry, do not run program") + ; ("-t", Arg.Set Flags.trace, " trace execution") + ; ( "-v" + , Arg.Unit (fun () -> banner (); - exit 0), - " show version" ); - ("--timeout", Arg.Set_int Flags.timeout, " time limit (default=900s)"); - ( "--workspace", - Arg.Set_string Flags.output, - " directory to output report and test-suite (default=output)" ); - ( "--policy", - Arg.Set_string Flags.policy, - " search policy random|depth|breadth|breadth-l|half-breadth (default: \ - random)" ); - ( "--encoding", - Arg.Set_string Flags.encoding, - " encoding policy incremental|batch (default: incremental)" ); - ( "--memory", - Arg.Set_string Flags.memory, - " memory backend map|lazy|tree (default: map)" ); - ( "--queries", - Arg.Set Flags.queries, - " output solver queries in .smt2 format" ); - ( "--allocs", - Arg.Int (fun i -> Flags.fixed_numbers := i :: !Flags.fixed_numbers), - " add allocation size to be tested on symbolic allocations" ); - ("--log", Arg.Set Flags.log, " logs paths and memory"); + exit 0 ) + , " show version" ) + ; ("--timeout", Arg.Set_int Flags.timeout, " time limit (default=900s)") + ; ( "--workspace" + , Arg.Set_string Flags.output + , " directory to output report and test-suite (default=output)" ) + ; ( "--policy" + , Arg.Set_string Flags.policy + , " search policy random|depth|breadth|breadth-l|half-breadth (default: \ + random)" ) + ; ( "--encoding" + , Arg.Set_string Flags.encoding + , " encoding policy incremental|batch (default: incremental)" ) + ; ( "--memory" + , Arg.Set_string Flags.memory + , " memory backend map|lazy|tree (default: map)" ) + ; ( "--queries" + , Arg.Set Flags.queries + , " output solver queries in .smt2 format" ) + ; ( "--allocs" + , Arg.Int (fun i -> Flags.fixed_numbers := i :: !Flags.fixed_numbers) + , " add allocation size to be tested on symbolic allocations" ) + ; ("--log", Arg.Set Flags.log, " logs paths and memory") ] let () = @@ -70,7 +74,7 @@ let () = if !Flags.interactive then ( Flags.print_sig := true; banner (); - Wasp.Run.run_stdin ()) + Wasp.Run.run_stdin () ) with exn -> flush_all (); prerr_endline diff --git a/src/static/eval.ml b/src/static/eval.ml index eb0e6b03..fa26bfe9 100644 --- a/src/static/eval.ml +++ b/src/static/eval.ml @@ -43,18 +43,21 @@ let lookup category list x = Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) let type_ (inst : module_inst) x = lookup "type" inst.types x + let func (inst : module_inst) x = lookup "function" inst.funcs x + let table (inst : module_inst) x = lookup "table" inst.tables x + let local (frame : sym_frame) x = lookup "local" frame.sym_locals x let elem inst x i at = let open Interpreter in match Table.load (table inst x) i with | Table.Uninitialized -> - Trap.error at ("uninitialized element " ^ Int32.to_string i) + Trap.error at ("uninitialized element " ^ Int32.to_string i) | f -> f | exception Table.Bounds -> - Trap.error at ("undefined element " ^ Int32.to_string i) + Trap.error at ("undefined element " ^ Int32.to_string i) let func_elem inst x i at = match elem inst x i at with @@ -108,31 +111,36 @@ module type Encoder = sig type t val create : unit -> t + val clone : t -> t + val add : t -> expr -> unit + val get_assertions : t -> expr + val check : t -> expr option -> bool + val fork : t -> expr -> bool * bool val value_binds : - ?symbols:Encoding.Symbol.t list -> - t -> - (Encoding.Symbol.t * Encoding.Value.t) list + ?symbols:Encoding.Symbol.t list + -> t + -> (Encoding.Symbol.t * Encoding.Value.t) list val string_binds : t -> (string * string * string) list end module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : Interpreter = struct - type sym_config = { - sym_frame : sym_frame; - sym_code : sym_code; - sym_mem : SM.t; - sym_budget : int; (* to model stack overflow *) - varmap : Varmap.t; - sym_globals : expr Globals.t; - encoder : E.t; - } + type sym_config = + { sym_frame : sym_frame + ; sym_code : sym_code + ; sym_mem : SM.t + ; sym_budget : int (* to model stack overflow *) + ; varmap : Varmap.t + ; sym_globals : expr Globals.t + ; encoder : E.t + } type step_res = | End of Encoding.Expression.t @@ -148,9 +156,9 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : | SReturning vs -> SReturning vs | SBreaking (n, vs) -> SBreaking (n, vs) | SLabel (n, es0, (vs, es)) -> - SLabel (n, es0, (vs, List.map clone_admin_instr es)) + SLabel (n, es0, (vs, List.map clone_admin_instr es)) | SFrame (n, frame, (vs, es)) -> - SFrame (n, clone_frame frame, (vs, List.map clone_admin_instr es)) + SFrame (n, clone_frame frame, (vs, List.map clone_admin_instr es)) | Interrupt i -> Interrupt i in { it; at = e.at } @@ -164,22 +172,21 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : let varmap = Varmap.copy c.varmap in let sym_globals = Globals.copy c.sym_globals in let encoder = E.clone c.encoder in - ( { c with sym_mem = sm }, - { sym_frame; sym_code; sym_mem; sym_budget; varmap; sym_globals; encoder } + ( { c with sym_mem = sm } + , { sym_frame; sym_code; sym_mem; sym_budget; varmap; sym_globals; encoder } ) let sym_config (inst : module_inst) (vs : expr stack) - (es : sym_admin_instr stack) (sym_m : Concolic.Heap.t) - (globs : expr Globals.t) : sym_config = - { - sym_frame = sym_frame inst []; - sym_code = (vs, es); - sym_mem = SM.from_heap sym_m; - (* models default recursion limit in a system *) - sym_budget = 100000; - varmap = Varmap.create (); - sym_globals = globs; - encoder = E.create (); + (es : sym_admin_instr stack) (sym_m : Concolic.Heap.t) + (globs : expr Globals.t) : sym_config = + { sym_frame = sym_frame inst [] + ; sym_code = (vs, es) + ; sym_mem = SM.from_heap sym_m + ; (* models default recursion limit in a system *) + sym_budget = 100000 + ; varmap = Varmap.create () + ; sym_globals = globs + ; encoder = E.create () } let to_concolic (c : sym_config) : Concolic.Eval.config = @@ -201,7 +208,7 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : List.map (fun r_ex -> let ex = !r_ex in - ref (expr_to_value ex, ex)) + ref (expr_to_value ex, ex) ) sym_locals in { inst = sym_inst; locals } @@ -217,7 +224,7 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : let es = List.map sym_instr_to_conc es in (vs, es) and sym_instr_to_conc (instr : Strategies.sym_admin_instr) : - Concolic.Eval.sym_admin_instr = + Concolic.Eval.sym_admin_instr = let open Interpreter.Source in let { at; it } = instr in let it = @@ -227,11 +234,11 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : | Strategies.STrapping t -> Concolic.Eval.Trapping t | Strategies.SReturning vs -> Concolic.Eval.Returning (vs_to_conc vs) | Strategies.SBreaking (n, vs) -> - Concolic.Eval.Breaking (n, vs_to_conc vs) + Concolic.Eval.Breaking (n, vs_to_conc vs) | Strategies.SLabel (l, insts, code) -> - Concolic.Eval.Label (l, insts, code_to_conc code) + Concolic.Eval.Label (l, insts, code_to_conc code) | Strategies.SFrame (f, frame, code) -> - Concolic.Eval.Frame (f, frame_to_conc frame, code_to_conc code) + Concolic.Eval.Frame (f, frame_to_conc frame, code_to_conc code) | Strategies.Interrupt i -> failwith "TODO: uniform interrupts" in { at; it } @@ -249,42 +256,42 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : let _, es = code in match es with | e :: _ -> ( - match e.it with - | Frame (_, _, code') -> - let s = stack_from_code code' in - Stack.push r s; - s - | _ -> - let s = Stack.create () in - Stack.push r s; - s) - | _ -> - let s = Stack.create () in + match e.it with + | Frame (_, _, code') -> + let s = stack_from_code code' in Stack.push r s; s + | _ -> + let s = Stack.create () in + Stack.push r s; + s ) + | _ -> + let s = Stack.create () in + Stack.push r s; + s in let call_stack = stack_from_code code in { frame; glob; code; mem; store; heap; pc; bp; tree; budget; call_stack } let concolic_invoke (c : sym_config) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = Concolic.Eval.head := Concolic.Execution_tree.Leaf; debug "-- Switching to concolic mode..."; debug - ("-- path_condition = " - ^ Encoding.Expression.pp_to_string (E.get_assertions c.encoder)); + ( "-- path_condition = " + ^ Encoding.Expression.pp_to_string (E.get_assertions c.encoder) ); let conc_c = to_concolic c in let test_suite = Filename.concat !Interpreter.Flags.output "test_suite" in Concolic.Eval.BFS.s_invoke conc_c test_suite let p_invoke (c : sym_config) : - (Encoding.Expression.t, string * Interpreter.Source.region) result = + (Encoding.Expression.t, string * Interpreter.Source.region) result = let conc_c = to_concolic c and test_suite = Filename.concat !Interpreter.Flags.output "test_suite" in Concolic.Eval.BFS.p_invoke conc_c test_suite let p_finished (c : sym_config) (pc' : Encoding.Expression.t) : - sym_config option = + sym_config option = let npc' = Encoding.Boolean.mk_not pc' in E.add c.encoder npc'; if E.check c.encoder None then Some c else None @@ -309,843 +316,708 @@ module SymbolicInterpreter (SM : Memory.SymbolicMemory) (E : Encoder) : match E.check encoder size_cond with | false -> None | true -> - let _, c = clone c in - (match size_cond with - | Some size_cond -> E.add c.encoder size_cond - | None -> ()); - assert (E.check c.encoder None); - let binds = - E.value_binds c.encoder ~symbols:(Varmap.binds c.varmap) - in - let logic_env = Concolic.Store.create binds in - - let open Interpreter.Source in - let c_size = Concolic.Store.eval logic_env s_size in - let size = - match c_size with - | I32 size -> size - | _ -> - failwith - (Printf.sprintf "%d" e.at.left.line - ^ ":Alloc with non i32 size: " - ^ string_of_type (Encoding.Num.type_of c_size)) - in - let c_base = Concolic.Store.eval logic_env s_base in - let base = - match c_base with - | I32 base -> base - | _ -> - failwith - (Printf.sprintf "%d" e.at.left.line - ^ ":Alloc with non i32 base: " - ^ string_of_type (Encoding.Num.type_of c_base)) - in + let _, c = clone c in + ( match size_cond with + | Some size_cond -> E.add c.encoder size_cond + | None -> () ); + assert (E.check c.encoder None); + let binds = E.value_binds c.encoder ~symbols:(Varmap.binds c.varmap) in + let logic_env = Concolic.Store.create binds in - let base_cond = Relop (I32 I32.Eq, s_base, Val (Num (I32 base))) in - E.add c.encoder base_cond; - SM.alloc sym_mem base size; + let open Interpreter.Source in + let c_size = Concolic.Store.eval logic_env s_size in + let size = + match c_size with + | I32 size -> size + | _ -> + failwith + ( Printf.sprintf "%d" e.at.left.line + ^ ":Alloc with non i32 size: " + ^ string_of_type (Encoding.Num.type_of c_size) ) + in + let c_base = Concolic.Store.eval logic_env s_base in + let base = + match c_base with + | I32 base -> base + | _ -> + failwith + ( Printf.sprintf "%d" e.at.left.line + ^ ":Alloc with non i32 base: " + ^ string_of_type (Encoding.Num.type_of c_base) ) + in - let sym_ptr = SymPtr (base, Val (Num (I32 0l))) in - Some { c with sym_code = (sym_ptr :: List.tl vs, List.tl es) } + let base_cond = Relop (I32 I32.Eq, s_base, Val (Num (I32 base))) in + E.add c.encoder base_cond; + SM.alloc sym_mem base size; + + let sym_ptr = SymPtr (base, Val (Num (I32 0l))) in + Some { c with sym_code = (sym_ptr :: List.tl vs, List.tl es) } in let fixed_attempts = List.filter_map helper (List.map Option.some - (List.map Int32.of_int !Interpreter.Flags.fixed_numbers)) + (List.map Int32.of_int !Interpreter.Flags.fixed_numbers) ) in if List.length fixed_attempts > 0 then fixed_attempts else [ Option.get (helper None) ] let rec step (c : sym_config) : - (step_res, string * Interpreter.Source.region) result = - let { - sym_frame = frame; - sym_code = vs, es; - sym_mem = mem; - varmap; - encoder; - _; - } = + (step_res, string * Interpreter.Source.region) result = + let { sym_frame = frame + ; sym_code = vs, es + ; sym_mem = mem + ; varmap + ; encoder + ; _ + } = c in let open Interpreter in let open Source in match es with | [] -> - assert (E.check encoder None); - let string_binds = E.string_binds encoder in - let witness = Concolic.Store.strings_to_json string_binds in - Common.write_test_case witness; - Result.ok (End (E.get_assertions c.encoder)) + assert (E.check encoder None); + let string_binds = E.string_binds encoder in + let witness = Concolic.Store.strings_to_json string_binds in + Common.write_test_case witness; + Result.ok (End (E.get_assertions c.encoder)) | e :: t -> ( - match (e.it, vs) with - | SPlain e', vs -> ( - match (e', vs) with - | Nop, vs -> - Result.ok - (Continuation [ { c with sym_code = (vs, List.tl es) } ]) - | Drop, v :: vs' -> - Result.ok - (Continuation [ { c with sym_code = (vs', List.tl es) } ]) - | Select, ex :: v2 :: v1 :: vs' -> ( - match simplify ex with - | Val (Num (I32 0l)) -> - (* if it is 0 *) - Result.ok - (Continuation - [ { c with sym_code = (v2 :: vs', List.tl es) } ]) - | Val (Num (I32 _)) -> - (* if it is not 0 *) - Result.ok - (Continuation - [ { c with sym_code = (v1 :: vs', List.tl es) } ]) - | ex -> - let co = Option.get (to_relop ex) in - let negated_co = negate_relop co in - let es' = List.tl es in - - let sat_then, sat_else = E.fork encoder co in - - let l = - match (sat_then, sat_else) with - | true, true -> - let c, c_clone = clone c in - E.add c.encoder co; - E.add c_clone.encoder negated_co; - [ - { c with sym_code = (v1 :: vs', es') }; - { c_clone with sym_code = (v2 :: vs', es') }; - ] - | true, false -> - E.add encoder co; - [ { c with sym_code = (v1 :: vs', es') } ] - | false, true -> - E.add encoder negated_co; - [ { c with sym_code = (v2 :: vs', es') } ] - | false, false -> failwith "Unreachable Select" - in - - Result.ok (Continuation l)) - | Block (ts, es'), vs -> - let es0 = - SLabel (List.length ts, [], ([], List.map plain es')) @@ e.at - in - Result.ok - (Continuation - [ { c with sym_code = (vs, es0 :: List.tl es) } ]) - | Loop (ts, es'), vs -> - let es0 = - SLabel (0, [ e' @@ e.at ], ([], List.map plain es')) @@ e.at - in - Result.ok - (Continuation - [ { c with sym_code = (vs, es0 :: List.tl es) } ]) - | If (ts, es1, es2), ex :: vs' -> ( - let es' = List.tl es in - match simplify ex with - | Val (Num (I32 0l)) -> - (* if it is 0 *) - Result.ok - (Continuation - [ - { - c with - sym_code = - (vs', [ SPlain (Block (ts, es2)) @@ e.at ] @ es'); - }; - ]) - | Val (Num (I32 _)) -> - (* if it is not 0 *) - Result.ok - (Continuation - [ - { - c with - sym_code = - (vs', [ SPlain (Block (ts, es1)) @@ e.at ] @ es'); - }; - ]) - | ex -> - let co = Option.get (to_relop ex) in - let negated_co = negate_relop co in - - let sat_then, sat_else = E.fork encoder co in - - let l = - match (sat_then, sat_else) with - | true, true -> - let c, c_clone = clone c in - E.add c.encoder co; - E.add c_clone.encoder negated_co; - [ - { - c with - sym_code = - (vs', [ SPlain (Block (ts, es1)) @@ e.at ] @ es'); - }; - { - c_clone with - sym_code = - (vs', [ SPlain (Block (ts, es2)) @@ e.at ] @ es'); - }; - ] - | true, false -> - E.add encoder co; - [ - { - c with - sym_code = - (vs', [ SPlain (Block (ts, es1)) @@ e.at ] @ es'); - }; - ] - | false, true -> - E.add encoder negated_co; - [ - { - c with - sym_code = - (vs', [ SPlain (Block (ts, es2)) @@ e.at ] @ es'); - }; - ] - | false, false -> failwith "Unreachable If" - in - - Result.ok (Continuation l)) - | Br x, vs -> - Result.ok - (Continuation - [ - { - c with - sym_code = (vs, [ SBreaking (x.it, vs) @@ e.at ]); - }; - ]) - | BrIf x, ex :: vs' -> ( - match simplify ex with - | Val (Num (I32 0l)) -> - (* if it is 0 *) - let es' = List.tl es in - Result.ok - (Continuation [ { c with sym_code = (vs', es') } ]) - | Val (Num (I32 _)) -> - (* if it is not 0 *) - Result.ok - (Continuation - [ - { - c with - sym_code = (vs', [ SPlain (Br x) @@ e.at ]); - }; - ]) - | ex -> - let co = Option.get (to_relop ex) in - let negated_co = negate_relop co in - let es' = List.tl es in - - let sat_then, sat_else = E.fork encoder co in - - let l = - match (sat_then, sat_else) with - | true, true -> - let c, c_clone = clone c in - E.add c.encoder co; - E.add c_clone.encoder negated_co; - [ - { - c with - sym_code = (vs', [ SPlain (Br x) @@ e.at ]); - }; - { c_clone with sym_code = (vs', es') }; - ] - | true, false -> - E.add encoder co; - [ - { - c with - sym_code = (vs', [ SPlain (Br x) @@ e.at ]); - }; - ] - | false, true -> - E.add encoder negated_co; - [ { c with sym_code = (vs', es') } ] - | false, false -> failwith "Unreachable BrIf" - in - - Result.ok (Continuation l)) - | Return, vs -> - let es' = [ SReturning vs @@ e.at ] @ List.tl es in - Result.ok (Continuation [ { c with sym_code = ([], es') } ]) - | Call x, vs -> - Result.ok - (Continuation - [ - { - c with - sym_code = - (vs, [ SInvoke (func frame.sym_inst x) @@ e.at ] @ t); - }; - ]) - | CallIndirect x, Val (Num (I32 i)) :: vs -> - let func = func_elem frame.sym_inst (0l @@ e.at) i e.at in - let es' = - if type_ frame.sym_inst x <> Func.type_of func then - [ STrapping "indirect call type mismatch" @@ e.at ] - else [ SInvoke func @@ e.at ] - in - Result.ok - (Continuation [ { c with sym_code = (vs, es' @ List.tl es) } ]) - | LocalGet x, vs -> - let vs' = !(local frame x) :: vs in - let es' = List.tl es in - Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) - | LocalSet x, v :: vs' -> - local frame x := v; - let es' = List.tl es in - Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) - | LocalTee x, v :: vs' -> - local frame x := v; - let es' = List.tl es in - Result.ok - (Continuation [ { c with sym_code = (v :: vs', es') } ]) - | GlobalGet x, vs -> - let v' = Globals.find c.sym_globals x.it in - let es' = List.tl es in - Result.ok - (Continuation [ { c with sym_code = (v' :: vs, es') } ]) - | GlobalSet x, v :: vs' -> ( - let es' = List.tl es in - try - Globals.add c.sym_globals x.it v; - Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) - with - | Global.NotMutable -> - Crash.error e.at "write to immutable global" - | Global.Type -> - Crash.error e.at "type mismatch at global write") - | Load { offset; ty; sz; _ }, sym_ptr :: vs' -> ( - let sym_ptr = simplify sym_ptr in - let ptr = - match concretize_ptr sym_ptr with - | Some ptr -> ptr - | None -> - assert (E.check encoder None); - let binds = - E.value_binds encoder ~symbols:(Varmap.binds varmap) - in - let logic_env = Concolic.Store.create binds in - - let ptr = Concolic.Store.eval logic_env sym_ptr in - let ty = Encoding.Num.type_of ptr in - if ty != `I32Type then - failwith - (Printf.sprintf "%d" e.at.left.line - ^ ":Load with non i32 ptr: " - ^ Encoding.Types.string_of_type ty); - - let ptr_cond = - Relop (I32 Encoding.Types.I32.Eq, sym_ptr, Val (Num ptr)) - in - E.add encoder ptr_cond; - - (* TODO: generate a configuration equal to the original with the condition denied in the path_cond ? *) - ptr - in - let ptr64 = - I64_convert.extend_i32_u - (Values.I32Value.of_value (Evaluations.to_value ptr)) - in - let base_ptr = concretize_base_ptr sym_ptr in - match - Option.bind base_ptr (fun bp -> - SM.check_access mem bp ptr offset) - with - | Some b -> - let bug_type = - match b with - | Common.Bug.Overflow -> "Out of Bounds access" - | Common.Bug.UAF -> "Use After Free" - | Common.Bug.InvalidFree -> - failwith "unreachable, check_access can't return this" - in - Result.error (bug_type, e.at) - | None -> - let v = - match sz with - | None -> - SM.load_value mem ptr64 offset - (Common.Evaluations.to_num_type ty) - | Some (sz, _) -> - SM.load_packed sz mem ptr64 offset - (Common.Evaluations.to_num_type ty) - in - let es' = List.tl es in - Result.ok - (Continuation [ { c with sym_code = (v :: vs', es') } ])) - | Store { offset; sz; _ }, ex :: sym_ptr :: vs' -> ( - let sym_ptr = simplify sym_ptr in - let ptr = - match concretize_ptr sym_ptr with - | Some ptr -> ptr - | None -> - assert (E.check encoder None); - let binds = - E.value_binds encoder ~symbols:(Varmap.binds varmap) - in - let logic_env = Concolic.Store.create binds in - - let ptr = Concolic.Store.eval logic_env sym_ptr in - let ty = Encoding.Num.type_of ptr in - if ty != `I32Type then - failwith - (Printf.sprintf "%d" e.at.left.line - ^ ":Store with non i32 ptr: " - ^ Encoding.Types.string_of_type ty); - - let ptr_cond = - Relop (I32 Encoding.Types.I32.Eq, sym_ptr, Val (Num ptr)) - in - E.add encoder ptr_cond; - - (* TODO: generate a configuration equal to the original with the condition denied in the path_cond ? *) - ptr - in - let ptr64 = - I64_convert.extend_i32_u - (Values.I32Value.of_value (Evaluations.to_value ptr)) - in - let base_ptr = concretize_base_ptr sym_ptr in - match - Option.bind base_ptr (fun bp -> - SM.check_access mem bp ptr offset) - with - | Some b -> - let bug_type = - match b with - | Common.Bug.Overflow -> "Out of Bounds access" - | Common.Bug.UAF -> "Use After Free" - | Common.Bug.InvalidFree -> - failwith "unreachable, check_access can't return this" - in - Result.error (bug_type, e.at) - | None -> - (match sz with - | None -> SM.store_value mem ptr64 offset ex - | Some sz -> SM.store_packed sz mem ptr64 offset ex); - let es' = List.tl es in - Result.ok - (Continuation [ { c with sym_code = (vs', es') } ])) - | Const v, vs -> - let es' = List.tl es in - Result.ok - (Continuation - [ - { - c with - sym_code = - (Val (Num (Evaluations.of_value v.it)) :: vs, es'); - }; - ]) - | Test testop, v :: vs' -> ( - let es' = List.tl es in - try - let v' = eval_testop v testop in - Result.ok - (Continuation - [ { c with sym_code = (simplify v' :: vs', es') } ]) - with exn -> - Result.ok - (Continuation - [ - { - c with - sym_code = - ( vs', - (STrapping (numeric_error e.at exn) @@ e.at) - :: es' ); - }; - ])) - | Compare relop, v2 :: v1 :: vs' -> ( - let es' = List.tl es in - try - let v = eval_relop v1 v2 relop in - Result.ok - (Continuation - [ { c with sym_code = (simplify v :: vs', es') } ]) - with exn -> - Result.ok - (Continuation - [ - { - c with - sym_code = - ( vs', - (STrapping (numeric_error e.at exn) @@ e.at) - :: es' ); - }; - ])) - | Unary unop, v :: vs' -> ( - let es' = List.tl es in - try - let v = eval_unop v unop in - Result.ok - (Continuation - [ { c with sym_code = (simplify v :: vs', es') } ]) - with exn -> - Result.ok - (Continuation - [ - { - c with - sym_code = - ( vs', - (STrapping (numeric_error e.at exn) @@ e.at) - :: es' ); - }; - ])) - | Binary binop, v2 :: v1 :: vs' -> ( - let es' = List.tl es in - try - let v = eval_binop v1 v2 binop in - Result.ok - (Continuation - [ { c with sym_code = (simplify v :: vs', es') } ]) - with exn -> - Result.ok - (Continuation - [ - { - c with - sym_code = - ( vs', - (STrapping (numeric_error e.at exn) @@ e.at) - :: es' ); - }; - ])) - | Convert cvtop, v :: vs' -> ( - let es' = List.tl es in - try - let v' = eval_cvtop cvtop v in - Result.ok - (Continuation - [ { c with sym_code = (simplify v' :: vs', es') } ]) - with exn -> - Result.ok - (Continuation - [ - { - c with - sym_code = - ( vs', - (STrapping (numeric_error e.at exn) @@ e.at) - :: es' ); - }; - ])) - | Dup, v :: vs' -> - let vs'' = v :: v :: vs' in - let es' = List.tl es in - Result.ok (Continuation [ { c with sym_code = (vs'', es') } ]) - | GetSymInt32 x, vs' -> - let es' = List.tl es in - Result.ok - (Continuation - [ - { - c with - sym_code = (mk_symbol_s `I32Type x :: vs', es'); - }; - ]) - | GetSymInt64 x, vs' -> - let es' = List.tl es in - Result.ok - (Continuation - [ - { - c with - sym_code = (mk_symbol_s `I64Type x :: vs', es'); - }; - ]) - | GetSymFloat32 x, vs' -> - let es' = List.tl es in - Result.ok - (Continuation - [ - { - c with - sym_code = (mk_symbol_s `F32Type x :: vs', es'); - }; - ]) - | GetSymFloat64 x, vs' -> - let es' = List.tl es in - Result.ok - (Continuation - [ - { - c with - sym_code = (mk_symbol_s `F64Type x :: vs', es'); - }; - ]) - | SymAssert, Val (Num (I32 0l)) :: vs' -> - debug (string_of_pos e.at.left ^ ":Assert FAILED! Stopping..."); - assert (E.check encoder None); - let string_binds = E.string_binds encoder in - let witness = Concolic.Store.strings_to_json string_binds in - Common.write_test_case ~witness:true witness; - Result.error ("Assertion Failure", e.at) - | SymAssert, Val (Num (I32 i)) :: vs' -> - (* passed *) - debug (string_of_pos e.at.left ^ ":Assert PASSED!"); - Result.ok - (Continuation [ { c with sym_code = (vs', List.tl es) } ]) - | SymAssert, v :: vs' -> - let v = simplify v in - debug ("Asserting: " ^ to_string (simplify v)); - let constr = negate_relop (Option.get (to_relop v)) in - let sat = E.check encoder (Some constr) in - if sat then ( - E.add encoder constr; - assert (E.check encoder None); - let string_binds = E.string_binds encoder in - let witness = Concolic.Store.strings_to_json string_binds in - debug (string_of_pos e.at.left ^ ":Assert FAILED! Stopping..."); - Common.write_test_case ~witness:true witness; - Result.error ("Assertion Failure", e.at)) - else ( - debug (string_of_pos e.at.left ^ ":Assert PASSED!"); - Result.ok - (Continuation [ { c with sym_code = (vs', List.tl es) } ])) - | SymAssume, ex :: vs' -> ( - match simplify ex with - | Val (Num (I32 0l)) -> - (* if it is 0 *) - Result.ok (Continuation []) - | SymPtr (_, Val (Num (I32 0l))) | Val (Num (I32 _)) -> - (* if it is not 0 *) - Result.ok - (Continuation [ { c with sym_code = (vs, List.tl es) } ]) - | ex -> - let co = Option.get (to_relop ex) in - E.add encoder co; - if E.check encoder None then - let c_true = { c with sym_code = (vs', List.tl es) } in - Result.ok (Continuation [ c_true ]) - else Result.ok (Continuation [])) - | Symbolic (ty, b), Val (Num (I32 i)) :: vs' -> - let base = I64_convert.extend_i32_u i in - let symbol = if i = 0l then "x" else SM.load_string mem base in - let x = Varmap.next varmap symbol in - let ty' = Evaluations.to_num_type ty in - let v = mk_symbol_s ty' x in - let es' = List.tl es in - Varmap.add varmap x ty'; - Result.ok - (Continuation [ { c with sym_code = (v :: vs', es') } ]) - | Boolop boolop, v1 :: v2 :: vs' -> ( - (* results in i32 *) - let v2' = mk_relop v2 `I32Type in - let v1' = mk_relop v1 `I32Type in - let v3 = eval_binop v1' v2' boolop in - let es' = List.tl es in - try - Result.ok - (Continuation - [ { c with sym_code = (simplify v3 :: vs', es') } ]) - with exn -> - Result.ok - (Continuation - [ - { - c with - sym_code = - ( vs', - (STrapping (numeric_error e.at exn) @@ e.at) - :: es' ); - }; - ])) - | Alloc, Val (Num (I32 sz)) :: Val (Num (I32 base)) :: vs' -> - SM.alloc mem base sz; - let sym_ptr = SymPtr (base, Val (Num (I32 0l))) in - Result.ok - (Continuation - [ { c with sym_code = (sym_ptr :: vs', List.tl es) } ]) - | Alloc, _ :: _ :: vs' -> - Result.ok (Continuation (concretize_alloc c)) - | Free, ptr :: vs' -> ( - match simplify ptr with - | SymPtr (base, Val (Num (I32 0l))) -> - let es' = - if not (SM.check_bound mem base) then ( - assert (E.check encoder None); - let string_binds = E.string_binds encoder in - let witness = - Concolic.Store.strings_to_json string_binds - in - [ - Interrupt (Bug (Common.Bug.InvalidFree, witness)) - @@ e.at; - ] - @ List.tl es) - else ( - SM.free mem base; - List.tl es) - in - Result.ok - (Continuation [ { c with sym_code = (vs', es') } ]) - | value -> - failwith ("Free with invalid argument" ^ pp_to_string value) - ) - | PrintStack, vs -> - let vs' = List.map (fun v -> pp_to_string v) vs in - debug - ("Stack @ " - ^ Source.string_of_pos e.at.left - ^ ":" ^ "\n" ^ String.concat "\n" vs'); - let es' = List.tl es in - Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) - | PrintMemory, vs -> - print_endline ("Memory State:\n" ^ SM.to_string mem); - let es' = List.tl es in - Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) - | PrintPC, vs -> - print_endline - (Printf.sprintf "%d" e.at.left.line - ^ " pc: " - ^ Encoding.Expression.pp_to_string (E.get_assertions encoder) - ); - let es' = List.tl es in - Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) - | PrintValue, v :: vs' -> - let es' = List.tl es in - print_endline - (Printf.sprintf "%d" e.at.left.line - ^ ":val: " ^ pp_to_string v); - Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) - | _ -> - print_endline - (string_of_region e.at ^ ":Not implemented " ^ instr_str e'); - let reason = - "{" ^ "\"type\" : \"" ^ "Not implemented" ^ "\", " - ^ "\"line\" : \"" - ^ (string_of_pos e.at.left - ^ - if e.at.right = e.at.left then "" - else "-" ^ string_of_pos e.at.right) - ^ "\"" ^ "}" - in - Result.error (reason, e.at)) - | SLabel (n, es0, (vs', [])), vs -> + match (e.it, vs) with + | SPlain e', vs -> ( + match (e', vs) with + | Nop, vs -> + Result.ok (Continuation [ { c with sym_code = (vs, List.tl es) } ]) + | Drop, v :: vs' -> + Result.ok (Continuation [ { c with sym_code = (vs', List.tl es) } ]) + | Select, ex :: v2 :: v1 :: vs' -> ( + match simplify ex with + | Val (Num (I32 0l)) -> + (* if it is 0 *) Result.ok - (Continuation [ { c with sym_code = (vs' @ vs, List.tl es) } ]) - | SLabel (n, es0, (vs', { it = Interrupt i; at } :: es')), vs -> - let es' = - (Interrupt i @@ at) :: [ SLabel (n, es0, (vs', es')) @@ e.at ] + (Continuation [ { c with sym_code = (v2 :: vs', List.tl es) } ]) + | Val (Num (I32 _)) -> + (* if it is not 0 *) + Result.ok + (Continuation [ { c with sym_code = (v1 :: vs', List.tl es) } ]) + | ex -> + let co = Option.get (to_relop ex) in + let negated_co = negate_relop co in + let es' = List.tl es in + + let sat_then, sat_else = E.fork encoder co in + + let l = + match (sat_then, sat_else) with + | true, true -> + let c, c_clone = clone c in + E.add c.encoder co; + E.add c_clone.encoder negated_co; + [ { c with sym_code = (v1 :: vs', es') } + ; { c_clone with sym_code = (v2 :: vs', es') } + ] + | true, false -> + E.add encoder co; + [ { c with sym_code = (v1 :: vs', es') } ] + | false, true -> + E.add encoder negated_co; + [ { c with sym_code = (v2 :: vs', es') } ] + | false, false -> failwith "Unreachable Select" in + + Result.ok (Continuation l) ) + | Block (ts, es'), vs -> + let es0 = + SLabel (List.length ts, [], ([], List.map plain es')) @@ e.at + in + Result.ok + (Continuation [ { c with sym_code = (vs, es0 :: List.tl es) } ]) + | Loop (ts, es'), vs -> + let es0 = + SLabel (0, [ e' @@ e.at ], ([], List.map plain es')) @@ e.at + in + Result.ok + (Continuation [ { c with sym_code = (vs, es0 :: List.tl es) } ]) + | If (ts, es1, es2), ex :: vs' -> ( + let es' = List.tl es in + match simplify ex with + | Val (Num (I32 0l)) -> + (* if it is 0 *) Result.ok - (Continuation [ { c with sym_code = (vs, es' @ List.tl es) } ]) - | SLabel (n, es0, (vs', { it = STrapping msg; at } :: es')), vs -> - (* TODO *) - Trap.error e.at "trap" - | SLabel (n, es0, (vs', { it = SReturning vs0; at } :: es')), vs -> - let vs'' = take n vs0 e.at @ vs in + (Continuation + [ { c with + sym_code = (vs', [ SPlain (Block (ts, es2)) @@ e.at ] @ es') + } + ] ) + | Val (Num (I32 _)) -> + (* if it is not 0 *) Result.ok - (Continuation [ { c with sym_code = (vs'', List.tl es) } ]) - | SLabel (n, es0, (vs', { it = SBreaking (0l, vs0); at } :: es')), vs -> - let vs'' = take n vs0 e.at @ vs in - let es' = List.map plain es0 in + (Continuation + [ { c with + sym_code = (vs', [ SPlain (Block (ts, es1)) @@ e.at ] @ es') + } + ] ) + | ex -> + let co = Option.get (to_relop ex) in + let negated_co = negate_relop co in + + let sat_then, sat_else = E.fork encoder co in + + let l = + match (sat_then, sat_else) with + | true, true -> + let c, c_clone = clone c in + E.add c.encoder co; + E.add c_clone.encoder negated_co; + [ { c with + sym_code = (vs', [ SPlain (Block (ts, es1)) @@ e.at ] @ es') + } + ; { c_clone with + sym_code = (vs', [ SPlain (Block (ts, es2)) @@ e.at ] @ es') + } + ] + | true, false -> + E.add encoder co; + [ { c with + sym_code = (vs', [ SPlain (Block (ts, es1)) @@ e.at ] @ es') + } + ] + | false, true -> + E.add encoder negated_co; + [ { c with + sym_code = (vs', [ SPlain (Block (ts, es2)) @@ e.at ] @ es') + } + ] + | false, false -> failwith "Unreachable If" + in + + Result.ok (Continuation l) ) + | Br x, vs -> + Result.ok + (Continuation + [ { c with sym_code = (vs, [ SBreaking (x.it, vs) @@ e.at ]) } ] + ) + | BrIf x, ex :: vs' -> ( + match simplify ex with + | Val (Num (I32 0l)) -> + (* if it is 0 *) + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) + | Val (Num (I32 _)) -> + (* if it is not 0 *) Result.ok - (Continuation [ { c with sym_code = (vs'', es' @ List.tl es) } ]) - | SLabel (n, es0, (vs', { it = SBreaking (k, vs0); at } :: es')), vs -> - let es0' = SBreaking (Int32.sub k 1l, vs0) @@ at in + (Continuation + [ { c with sym_code = (vs', [ SPlain (Br x) @@ e.at ]) } ] ) + | ex -> + let co = Option.get (to_relop ex) in + let negated_co = negate_relop co in + let es' = List.tl es in + + let sat_then, sat_else = E.fork encoder co in + + let l = + match (sat_then, sat_else) with + | true, true -> + let c, c_clone = clone c in + E.add c.encoder co; + E.add c_clone.encoder negated_co; + [ { c with sym_code = (vs', [ SPlain (Br x) @@ e.at ]) } + ; { c_clone with sym_code = (vs', es') } + ] + | true, false -> + E.add encoder co; + [ { c with sym_code = (vs', [ SPlain (Br x) @@ e.at ]) } ] + | false, true -> + E.add encoder negated_co; + [ { c with sym_code = (vs', es') } ] + | false, false -> failwith "Unreachable BrIf" + in + + Result.ok (Continuation l) ) + | Return, vs -> + let es' = [ SReturning vs @@ e.at ] @ List.tl es in + Result.ok (Continuation [ { c with sym_code = ([], es') } ]) + | Call x, vs -> + Result.ok + (Continuation + [ { c with + sym_code = + (vs, [ SInvoke (func frame.sym_inst x) @@ e.at ] @ t) + } + ] ) + | CallIndirect x, Val (Num (I32 i)) :: vs -> + let func = func_elem frame.sym_inst (0l @@ e.at) i e.at in + let es' = + if type_ frame.sym_inst x <> Func.type_of func then + [ STrapping "indirect call type mismatch" @@ e.at ] + else [ SInvoke func @@ e.at ] + in + Result.ok + (Continuation [ { c with sym_code = (vs, es' @ List.tl es) } ]) + | LocalGet x, vs -> + let vs' = !(local frame x) :: vs in + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) + | LocalSet x, v :: vs' -> + local frame x := v; + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) + | LocalTee x, v :: vs' -> + local frame x := v; + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (v :: vs', es') } ]) + | GlobalGet x, vs -> + let v' = Globals.find c.sym_globals x.it in + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (v' :: vs, es') } ]) + | GlobalSet x, v :: vs' -> ( + let es' = List.tl es in + try + Globals.add c.sym_globals x.it v; + Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) + with + | Global.NotMutable -> Crash.error e.at "write to immutable global" + | Global.Type -> Crash.error e.at "type mismatch at global write" ) + | Load { offset; ty; sz; _ }, sym_ptr :: vs' -> ( + let sym_ptr = simplify sym_ptr in + let ptr = + match concretize_ptr sym_ptr with + | Some ptr -> ptr + | None -> + assert (E.check encoder None); + let binds = + E.value_binds encoder ~symbols:(Varmap.binds varmap) + in + let logic_env = Concolic.Store.create binds in + + let ptr = Concolic.Store.eval logic_env sym_ptr in + let ty = Encoding.Num.type_of ptr in + if ty != `I32Type then + failwith + ( Printf.sprintf "%d" e.at.left.line + ^ ":Load with non i32 ptr: " + ^ Encoding.Types.string_of_type ty ); + + let ptr_cond = + Relop (I32 Encoding.Types.I32.Eq, sym_ptr, Val (Num ptr)) + in + E.add encoder ptr_cond; + + (* TODO: generate a configuration equal to the original with the condition denied in the path_cond ? *) + ptr + in + let ptr64 = + I64_convert.extend_i32_u + (Values.I32Value.of_value (Evaluations.to_value ptr)) + in + let base_ptr = concretize_base_ptr sym_ptr in + match + Option.bind base_ptr (fun bp -> SM.check_access mem bp ptr offset) + with + | Some b -> + let bug_type = + match b with + | Common.Bug.Overflow -> "Out of Bounds access" + | Common.Bug.UAF -> "Use After Free" + | Common.Bug.InvalidFree -> + failwith "unreachable, check_access can't return this" + in + Result.error (bug_type, e.at) + | None -> + let v = + match sz with + | None -> + SM.load_value mem ptr64 offset + (Common.Evaluations.to_num_type ty) + | Some (sz, _) -> + SM.load_packed sz mem ptr64 offset + (Common.Evaluations.to_num_type ty) + in + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (v :: vs', es') } ]) ) + | Store { offset; sz; _ }, ex :: sym_ptr :: vs' -> ( + let sym_ptr = simplify sym_ptr in + let ptr = + match concretize_ptr sym_ptr with + | Some ptr -> ptr + | None -> + assert (E.check encoder None); + let binds = + E.value_binds encoder ~symbols:(Varmap.binds varmap) + in + let logic_env = Concolic.Store.create binds in + + let ptr = Concolic.Store.eval logic_env sym_ptr in + let ty = Encoding.Num.type_of ptr in + if ty != `I32Type then + failwith + ( Printf.sprintf "%d" e.at.left.line + ^ ":Store with non i32 ptr: " + ^ Encoding.Types.string_of_type ty ); + + let ptr_cond = + Relop (I32 Encoding.Types.I32.Eq, sym_ptr, Val (Num ptr)) + in + E.add encoder ptr_cond; + + (* TODO: generate a configuration equal to the original with the condition denied in the path_cond ? *) + ptr + in + let ptr64 = + I64_convert.extend_i32_u + (Values.I32Value.of_value (Evaluations.to_value ptr)) + in + let base_ptr = concretize_base_ptr sym_ptr in + match + Option.bind base_ptr (fun bp -> SM.check_access mem bp ptr offset) + with + | Some b -> + let bug_type = + match b with + | Common.Bug.Overflow -> "Out of Bounds access" + | Common.Bug.UAF -> "Use After Free" + | Common.Bug.InvalidFree -> + failwith "unreachable, check_access can't return this" + in + Result.error (bug_type, e.at) + | None -> + ( match sz with + | None -> SM.store_value mem ptr64 offset ex + | Some sz -> SM.store_packed sz mem ptr64 offset ex ); + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) ) + | Const v, vs -> + let es' = List.tl es in + Result.ok + (Continuation + [ { c with + sym_code = (Val (Num (Evaluations.of_value v.it)) :: vs, es') + } + ] ) + | Test testop, v :: vs' -> ( + let es' = List.tl es in + try + let v' = eval_testop v testop in Result.ok - (Continuation [ { c with sym_code = (vs, es0' :: List.tl es) } ]) - | SLabel (n, es0, code'), vs -> - Result.map - (fun step_r -> - match step_r with - | End pc -> End pc - | Continuation cs -> - Continuation - (List.map - (fun (c' : sym_config) -> - let es0' = SLabel (n, es0, c'.sym_code) @@ e.at in - { c' with sym_code = (vs, es0' :: List.tl es) }) - cs)) - (step { c with sym_code = code' }) - | SFrame (n, frame', (vs', [])), vs -> + (Continuation [ { c with sym_code = (simplify v' :: vs', es') } ]) + with exn -> Result.ok - (Continuation [ { c with sym_code = (vs' @ vs, List.tl es) } ]) - | SFrame (n, frame', (vs', { it = Interrupt i; at } :: es')), vs -> - let es' = - (Interrupt i @@ at) :: [ SFrame (n, frame', (vs', es')) @@ e.at ] - in + (Continuation + [ { c with + sym_code = + (vs', (STrapping (numeric_error e.at exn) @@ e.at) :: es') + } + ] ) ) + | Compare relop, v2 :: v1 :: vs' -> ( + let es' = List.tl es in + try + let v = eval_relop v1 v2 relop in + Result.ok + (Continuation [ { c with sym_code = (simplify v :: vs', es') } ]) + with exn -> + Result.ok + (Continuation + [ { c with + sym_code = + (vs', (STrapping (numeric_error e.at exn) @@ e.at) :: es') + } + ] ) ) + | Unary unop, v :: vs' -> ( + let es' = List.tl es in + try + let v = eval_unop v unop in + Result.ok + (Continuation [ { c with sym_code = (simplify v :: vs', es') } ]) + with exn -> Result.ok - (Continuation [ { c with sym_code = (vs, es' @ List.tl es) } ]) - | SFrame (n, frame', (vs', { it = STrapping msg; at } :: es')), vs -> - (* TODO *) - Trap.error e.at "trap" - | SFrame (n, frame', (vs', { it = SReturning vs0; at } :: es')), vs -> - let vs'' = take n vs0 e.at @ vs in + (Continuation + [ { c with + sym_code = + (vs', (STrapping (numeric_error e.at exn) @@ e.at) :: es') + } + ] ) ) + | Binary binop, v2 :: v1 :: vs' -> ( + let es' = List.tl es in + try + let v = eval_binop v1 v2 binop in Result.ok - (Continuation [ { c with sym_code = (vs'', List.tl es) } ]) - | SFrame (n, frame', code'), vs -> - Result.map - (fun step_r -> - match step_r with - | End pc -> End pc - | Continuation cs -> - Continuation - (List.map - (fun (c' : sym_config) -> - let es0 = - SFrame (n, c'.sym_frame, c'.sym_code) @@ e.at - in - { - c' with - sym_code = (vs, es0 :: List.tl es); - sym_frame = clone_frame frame; - }) - cs)) - (step - { - sym_frame = frame'; - sym_code = code'; - sym_mem = c.sym_mem; - sym_budget = c.sym_budget - 1; - varmap = c.varmap; - sym_globals = c.sym_globals; - encoder = c.encoder; - }) - | STrapping msg, vs -> assert false - | Interrupt i, vs -> assert false - | SReturning vs', vs -> Crash.error e.at "undefined frame" - | SBreaking (k, vs'), vs -> Crash.error e.at "undefined label" - | SInvoke func, vs when c.sym_budget = 0 -> - (* stop execution if call stack is too deep *) + (Continuation [ { c with sym_code = (simplify v :: vs', es') } ]) + with exn -> + Result.ok + (Continuation + [ { c with + sym_code = + (vs', (STrapping (numeric_error e.at exn) @@ e.at) :: es') + } + ] ) ) + | Convert cvtop, v :: vs' -> ( + let es' = List.tl es in + try + let v' = eval_cvtop cvtop v in + Result.ok + (Continuation [ { c with sym_code = (simplify v' :: vs', es') } ]) + with exn -> + Result.ok + (Continuation + [ { c with + sym_code = + (vs', (STrapping (numeric_error e.at exn) @@ e.at) :: es') + } + ] ) ) + | Dup, v :: vs' -> + let vs'' = v :: v :: vs' in + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs'', es') } ]) + | GetSymInt32 x, vs' -> + let es' = List.tl es in + Result.ok + (Continuation + [ { c with sym_code = (mk_symbol_s `I32Type x :: vs', es') } ] ) + | GetSymInt64 x, vs' -> + let es' = List.tl es in + Result.ok + (Continuation + [ { c with sym_code = (mk_symbol_s `I64Type x :: vs', es') } ] ) + | GetSymFloat32 x, vs' -> + let es' = List.tl es in + Result.ok + (Continuation + [ { c with sym_code = (mk_symbol_s `F32Type x :: vs', es') } ] ) + | GetSymFloat64 x, vs' -> + let es' = List.tl es in + Result.ok + (Continuation + [ { c with sym_code = (mk_symbol_s `F64Type x :: vs', es') } ] ) + | SymAssert, Val (Num (I32 0l)) :: vs' -> + debug (string_of_pos e.at.left ^ ":Assert FAILED! Stopping..."); + assert (E.check encoder None); + let string_binds = E.string_binds encoder in + let witness = Concolic.Store.strings_to_json string_binds in + Common.write_test_case ~witness:true witness; + Result.error ("Assertion Failure", e.at) + | SymAssert, Val (Num (I32 i)) :: vs' -> + (* passed *) + debug (string_of_pos e.at.left ^ ":Assert PASSED!"); + Result.ok (Continuation [ { c with sym_code = (vs', List.tl es) } ]) + | SymAssert, v :: vs' -> + let v = simplify v in + debug ("Asserting: " ^ to_string (simplify v)); + let constr = negate_relop (Option.get (to_relop v)) in + let sat = E.check encoder (Some constr) in + if sat then ( + E.add encoder constr; + assert (E.check encoder None); + let string_binds = E.string_binds encoder in + let witness = Concolic.Store.strings_to_json string_binds in + debug (string_of_pos e.at.left ^ ":Assert FAILED! Stopping..."); + Common.write_test_case ~witness:true witness; + Result.error ("Assertion Failure", e.at) ) + else ( + debug (string_of_pos e.at.left ^ ":Assert PASSED!"); + Result.ok (Continuation [ { c with sym_code = (vs', List.tl es) } ]) + ) + | SymAssume, ex :: vs' -> ( + match simplify ex with + | Val (Num (I32 0l)) -> + (* if it is 0 *) Result.ok (Continuation []) - | SInvoke func, vs -> ( - let (FuncType (ins, out)) = Func.type_of func in - let n = List.length ins in - let args, vs' = (take n vs e.at, drop n vs e.at) in - match func with - | Func.AstFunc (t, inst', f) -> - let locals' = - List.map - (fun v -> Val (Num v)) - (List.map - (fun t -> - Encoding.Num.default_value (Evaluations.to_num_type t)) - f.it.locals) - in - let locals'' = List.rev args @ locals' in - let code' = ([], [ SPlain (Block (out, f.it.body)) @@ f.at ]) in - let frame' = - { sym_inst = !inst'; sym_locals = List.map ref locals'' } - in - let es0 = SFrame (List.length out, frame', code') @@ e.at in - Result.ok - (Continuation - [ { c with sym_code = (vs', es0 :: List.tl es) } ]) - | Func.HostFunc (t, f) -> failwith "HostFunc error")) + | SymPtr (_, Val (Num (I32 0l))) | Val (Num (I32 _)) -> + (* if it is not 0 *) + Result.ok (Continuation [ { c with sym_code = (vs, List.tl es) } ]) + | ex -> + let co = Option.get (to_relop ex) in + E.add encoder co; + if E.check encoder None then + let c_true = { c with sym_code = (vs', List.tl es) } in + Result.ok (Continuation [ c_true ]) + else Result.ok (Continuation []) ) + | Symbolic (ty, b), Val (Num (I32 i)) :: vs' -> + let base = I64_convert.extend_i32_u i in + let symbol = if i = 0l then "x" else SM.load_string mem base in + let x = Varmap.next varmap symbol in + let ty' = Evaluations.to_num_type ty in + let v = mk_symbol_s ty' x in + let es' = List.tl es in + Varmap.add varmap x ty'; + Result.ok (Continuation [ { c with sym_code = (v :: vs', es') } ]) + | Boolop boolop, v1 :: v2 :: vs' -> ( + (* results in i32 *) + let v2' = mk_relop v2 `I32Type in + let v1' = mk_relop v1 `I32Type in + let v3 = eval_binop v1' v2' boolop in + let es' = List.tl es in + try + Result.ok + (Continuation [ { c with sym_code = (simplify v3 :: vs', es') } ]) + with exn -> + Result.ok + (Continuation + [ { c with + sym_code = + (vs', (STrapping (numeric_error e.at exn) @@ e.at) :: es') + } + ] ) ) + | Alloc, Val (Num (I32 sz)) :: Val (Num (I32 base)) :: vs' -> + SM.alloc mem base sz; + let sym_ptr = SymPtr (base, Val (Num (I32 0l))) in + Result.ok + (Continuation [ { c with sym_code = (sym_ptr :: vs', List.tl es) } ]) + | Alloc, _ :: _ :: vs' -> Result.ok (Continuation (concretize_alloc c)) + | Free, ptr :: vs' -> ( + match simplify ptr with + | SymPtr (base, Val (Num (I32 0l))) -> + let es' = + if not (SM.check_bound mem base) then ( + assert (E.check encoder None); + let string_binds = E.string_binds encoder in + let witness = Concolic.Store.strings_to_json string_binds in + [ Interrupt (Bug (Common.Bug.InvalidFree, witness)) @@ e.at ] + @ List.tl es ) + else ( + SM.free mem base; + List.tl es ) + in + Result.ok (Continuation [ { c with sym_code = (vs', es') } ]) + | value -> failwith ("Free with invalid argument" ^ pp_to_string value) + ) + | PrintStack, vs -> + let vs' = List.map (fun v -> pp_to_string v) vs in + debug + ( "Stack @ " + ^ Source.string_of_pos e.at.left + ^ ":" ^ "\n" ^ String.concat "\n" vs' ); + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) + | PrintMemory, vs -> + print_endline ("Memory State:\n" ^ SM.to_string mem); + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) + | PrintPC, vs -> + print_endline + ( Printf.sprintf "%d" e.at.left.line + ^ " pc: " + ^ Encoding.Expression.pp_to_string (E.get_assertions encoder) ); + let es' = List.tl es in + Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) + | PrintValue, v :: vs' -> + let es' = List.tl es in + print_endline + (Printf.sprintf "%d" e.at.left.line ^ ":val: " ^ pp_to_string v); + Result.ok (Continuation [ { c with sym_code = (vs, es') } ]) + | _ -> + print_endline + (string_of_region e.at ^ ":Not implemented " ^ instr_str e'); + let reason = + "{" ^ "\"type\" : \"" ^ "Not implemented" ^ "\", " ^ "\"line\" : \"" + ^ ( string_of_pos e.at.left + ^ + if e.at.right = e.at.left then "" + else "-" ^ string_of_pos e.at.right ) + ^ "\"" ^ "}" + in + Result.error (reason, e.at) ) + | SLabel (n, es0, (vs', [])), vs -> + Result.ok (Continuation [ { c with sym_code = (vs' @ vs, List.tl es) } ]) + | SLabel (n, es0, (vs', { it = Interrupt i; at } :: es')), vs -> + let es' = + (Interrupt i @@ at) :: [ SLabel (n, es0, (vs', es')) @@ e.at ] + in + Result.ok (Continuation [ { c with sym_code = (vs, es' @ List.tl es) } ]) + | SLabel (n, es0, (vs', { it = STrapping msg; at } :: es')), vs -> + (* TODO *) + Trap.error e.at "trap" + | SLabel (n, es0, (vs', { it = SReturning vs0; at } :: es')), vs -> + let vs'' = take n vs0 e.at @ vs in + Result.ok (Continuation [ { c with sym_code = (vs'', List.tl es) } ]) + | SLabel (n, es0, (vs', { it = SBreaking (0l, vs0); at } :: es')), vs -> + let vs'' = take n vs0 e.at @ vs in + let es' = List.map plain es0 in + Result.ok + (Continuation [ { c with sym_code = (vs'', es' @ List.tl es) } ]) + | SLabel (n, es0, (vs', { it = SBreaking (k, vs0); at } :: es')), vs -> + let es0' = SBreaking (Int32.sub k 1l, vs0) @@ at in + Result.ok + (Continuation [ { c with sym_code = (vs, es0' :: List.tl es) } ]) + | SLabel (n, es0, code'), vs -> + Result.map + (fun step_r -> + match step_r with + | End pc -> End pc + | Continuation cs -> + Continuation + (List.map + (fun (c' : sym_config) -> + let es0' = SLabel (n, es0, c'.sym_code) @@ e.at in + { c' with sym_code = (vs, es0' :: List.tl es) } ) + cs ) ) + (step { c with sym_code = code' }) + | SFrame (n, frame', (vs', [])), vs -> + Result.ok (Continuation [ { c with sym_code = (vs' @ vs, List.tl es) } ]) + | SFrame (n, frame', (vs', { it = Interrupt i; at } :: es')), vs -> + let es' = + (Interrupt i @@ at) :: [ SFrame (n, frame', (vs', es')) @@ e.at ] + in + Result.ok (Continuation [ { c with sym_code = (vs, es' @ List.tl es) } ]) + | SFrame (n, frame', (vs', { it = STrapping msg; at } :: es')), vs -> + (* TODO *) + Trap.error e.at "trap" + | SFrame (n, frame', (vs', { it = SReturning vs0; at } :: es')), vs -> + let vs'' = take n vs0 e.at @ vs in + Result.ok (Continuation [ { c with sym_code = (vs'', List.tl es) } ]) + | SFrame (n, frame', code'), vs -> + Result.map + (fun step_r -> + match step_r with + | End pc -> End pc + | Continuation cs -> + Continuation + (List.map + (fun (c' : sym_config) -> + let es0 = SFrame (n, c'.sym_frame, c'.sym_code) @@ e.at in + { c' with + sym_code = (vs, es0 :: List.tl es) + ; sym_frame = clone_frame frame + } ) + cs ) ) + (step + { sym_frame = frame' + ; sym_code = code' + ; sym_mem = c.sym_mem + ; sym_budget = c.sym_budget - 1 + ; varmap = c.varmap + ; sym_globals = c.sym_globals + ; encoder = c.encoder + } ) + | STrapping msg, vs -> assert false + | Interrupt i, vs -> assert false + | SReturning vs', vs -> Crash.error e.at "undefined frame" + | SBreaking (k, vs'), vs -> Crash.error e.at "undefined label" + | SInvoke func, vs when c.sym_budget = 0 -> + (* stop execution if call stack is too deep *) + Result.ok (Continuation []) + | SInvoke func, vs -> ( + let (FuncType (ins, out)) = Func.type_of func in + let n = List.length ins in + let args, vs' = (take n vs e.at, drop n vs e.at) in + match func with + | Func.AstFunc (t, inst', f) -> + let locals' = + List.map + (fun v -> Val (Num v)) + (List.map + (fun t -> + Encoding.Num.default_value (Evaluations.to_num_type t) ) + f.it.locals ) + in + let locals'' = List.rev args @ locals' in + let code' = ([], [ SPlain (Block (out, f.it.body)) @@ f.at ]) in + let frame' = + { sym_inst = !inst'; sym_locals = List.map ref locals'' } + in + let es0 = SFrame (List.length out, frame', code') @@ e.at in + Result.ok + (Continuation [ { c with sym_code = (vs', es0 :: List.tl es) } ]) + | Func.HostFunc (t, f) -> failwith "HostFunc error" ) ) end module EncodingSelector (SM : Memory.SymbolicMemory) = struct @@ -1174,18 +1046,18 @@ let parse_memory_and_encoding () = let func_to_globs (func : func_inst) : expr Globals.t = match Interpreter.Func.get_inst func with | Some inst -> - Globals.of_seq - (Seq.mapi - (fun i a -> - let v = Interpreter.Global.load a in - (Int32.of_int i, Val (Num (Evaluations.of_value v)))) - (List.to_seq !inst.globals)) + Globals.of_seq + (Seq.mapi + (fun i a -> + let v = Interpreter.Global.load a in + (Int32.of_int i, Val (Num (Evaluations.of_value v))) ) + (List.to_seq !inst.globals) ) | None -> Globals.create () let set_timeout (time_limit : int) : unit = if time_limit > 0 then ( Sys.(set_signal sigalrm (Signal_handle exiter)); - ignore (Unix.alarm time_limit)) + ignore (Unix.alarm time_limit) ) let invoke (func : func_inst) (vs : expr list) (mem0 : Concolic.Heap.t) = set_timeout !Interpreter.Flags.timeout; diff --git a/src/static/evaluations.ml b/src/static/evaluations.ml index 638e6b03..900ffe7e 100644 --- a/src/static/evaluations.ml +++ b/src/static/evaluations.ml @@ -10,13 +10,13 @@ open Interpreter.Ast let eval_unop (e : expr) (op : unop) : expr = match e with | Val (Num c) -> - Val (Num (of_value (Interpreter.Eval_numeric.eval_unop op (to_value c)))) + Val (Num (of_value (Interpreter.Eval_numeric.eval_unop op (to_value c)))) | _ -> ( - let open Interpreter in - match op with - | Values.F32 x -> f32_unop x e - | Values.F64 x -> f64_unop x e - | Values.I32 _ | Values.I64 _ -> raise (UnsupportedOp "eval_unop: ints")) + let open Interpreter in + match op with + | Values.F32 x -> f32_unop x e + | Values.F64 x -> f64_unop x e + | Values.I32 _ | Values.I64 _ -> raise (UnsupportedOp "eval_unop: ints") ) (* Evaluate a binary operation *) let eval_binop (s1 : expr) (s2 : expr) (op : binop) : expr = @@ -24,16 +24,15 @@ let eval_binop (s1 : expr) (s2 : expr) (op : binop) : expr = let open Interpreter in match (s1, s2) with | Val (Num c1), Val (Num c2) -> - Val - (Num - (of_value (Eval_numeric.eval_binop op (to_value c1) (to_value c2)))) + Val + (Num (of_value (Eval_numeric.eval_binop op (to_value c1) (to_value c2)))) | _ -> ( - (* dispatch *) - match op with - | Values.I32 x -> i32_binop x s1 s2 - | Values.I64 x -> i64_binop x s1 s2 - | Values.F32 x -> f32_binop x s1 s2 - | Values.F64 x -> f64_binop x s1 s2) + (* dispatch *) + match op with + | Values.I32 x -> i32_binop x s1 s2 + | Values.I64 x -> i64_binop x s1 s2 + | Values.F32 x -> f32_binop x s1 s2 + | Values.F64 x -> f64_binop x s1 s2 ) in s @@ -41,41 +40,41 @@ let eval_binop (s1 : expr) (s2 : expr) (op : binop) : expr = let eval_testop (e : expr) (op : testop) : expr = match e with | Val (Num c) -> - Val - (Num - (Num.num_of_bool - (Interpreter.Eval_numeric.eval_testop op (to_value c)))) + Val + (Num + (Num.num_of_bool + (Interpreter.Eval_numeric.eval_testop op (to_value c)) ) ) | SymPtr (b, Val (Num (I32 o))) -> - let c : Num.t = I32 (Int32.add b o) in - Val - (Num - (Num.num_of_bool - (Interpreter.Eval_numeric.eval_testop op (to_value c)))) + let c : Num.t = I32 (Int32.add b o) in + Val + (Num + (Num.num_of_bool + (Interpreter.Eval_numeric.eval_testop op (to_value c)) ) ) | _ -> ( - let open Interpreter in - match op with - | Values.I32 I32Op.Eqz -> Relop (I32 Eq, e, Val (Num (I32 0l))) - | Values.I64 I64Op.Eqz -> Relop (I64 Eq, e, Val (Num (I64 0L))) - | Values.F32 _ | Values.F64 _ -> failwith "eval_testop: floats") + let open Interpreter in + match op with + | Values.I32 I32Op.Eqz -> Relop (I32 Eq, e, Val (Num (I32 0l))) + | Values.I64 I64Op.Eqz -> Relop (I64 Eq, e, Val (Num (I64 0L))) + | Values.F32 _ | Values.F64 _ -> failwith "eval_testop: floats" ) (* Evaluate a relative operation *) let eval_relop (s1 : expr) (s2 : expr) (op : relop) : expr = let s : expr = match (s1, s2) with | Val (Num c1), Val (Num c2) -> - Val - (Num - (Num.num_of_bool - (Interpreter.Eval_numeric.eval_relop op (to_value c1) - (to_value c2)))) + Val + (Num + (Num.num_of_bool + (Interpreter.Eval_numeric.eval_relop op (to_value c1) + (to_value c2) ) ) ) | _ -> ( - let (* dispatch *) - open Interpreter in - match op with - | Values.I32 x -> i32_relop x s1 s2 - | Values.I64 x -> i64_relop x s1 s2 - | Values.F32 x -> f32_relop x s1 s2 - | Values.F64 x -> f64_relop x s1 s2) + let (* dispatch *) + open Interpreter in + match op with + | Values.I32 x -> i32_relop x s1 s2 + | Values.I64 x -> i64_relop x s1 s2 + | Values.F32 x -> f32_relop x s1 s2 + | Values.F64 x -> f64_relop x s1 s2 ) in s @@ -83,15 +82,14 @@ let eval_cvtop (op : cvtop) (s : expr) : expr = let s = match s with | Val (Num c) -> - Val - (Num (of_value (Interpreter.Eval_numeric.eval_cvtop op (to_value c)))) + Val (Num (of_value (Interpreter.Eval_numeric.eval_cvtop op (to_value c)))) | _ -> ( - let (* dispatch cvtop func *) - open Interpreter in - match op with - | Values.I32 x -> i32_cvtop x s - | Values.I64 x -> i64_cvtop x s - | Values.F32 x -> f32_cvtop x s - | Values.F64 x -> f64_cvtop x s) + let (* dispatch cvtop func *) + open Interpreter in + match op with + | Values.I32 x -> i32_cvtop x s + | Values.I64 x -> i64_cvtop x s + | Values.F32 x -> f32_cvtop x s + | Values.F64 x -> f64_cvtop x s ) in s diff --git a/src/static/memory.ml b/src/static/memory.ml index 19400225..06944134 100644 --- a/src/static/memory.ml +++ b/src/static/memory.ml @@ -7,7 +7,9 @@ open Types open Interpreter.Memory type size = int32 + type address = int64 + type offset = int32 module type MemoryBackend = sig @@ -16,15 +18,23 @@ module type MemoryBackend = sig exception Bounds val store_byte : t -> address -> Expression.t -> unit + val load_byte : t -> address -> Expression.t + val from_heap : Concolic.Heap.t -> t + val clone : t -> t * t + val to_string : t -> string + val to_heap : t -> (Expression.t -> Num.t) -> Concolic.Heap.t end module LazyMemory : MemoryBackend = struct - type t = { map : (address, Expression.t) Hashtbl.t; parent : t Option.t } + type t = + { map : (address, Expression.t) Hashtbl.t + ; parent : t Option.t + } exception Bounds @@ -41,31 +51,28 @@ module LazyMemory : MemoryBackend = struct match Hashtbl.find_opt lmem.map a with | Some b -> b | None -> ( - match Option.bind lmem.parent load_byte_rec with - | Some b -> - Hashtbl.add lmem.map a b; - b - | None -> Extract (Val (Num (I64 0L)), 1, 0)) + match Option.bind lmem.parent load_byte_rec with + | Some b -> + Hashtbl.add lmem.map a b; + b + | None -> Extract (Val (Num (I64 0L)), 1, 0) ) let from_heap (heap : Concolic.Heap.t) : t = let concolic_seq = Concolic.Heap.to_seq heap in let concolic_to_symbolic (k, (_, s)) = (k, s) in - { - map = Hashtbl.of_seq (Seq.map concolic_to_symbolic concolic_seq); - parent = None; + { map = Hashtbl.of_seq (Seq.map concolic_to_symbolic concolic_seq) + ; parent = None } let clone (lmem : t) : t * t = let child1 = - { - map = Hashtbl.create Interpreter.Flags.hashtbl_default_size; - parent = Some lmem; + { map = Hashtbl.create Interpreter.Flags.hashtbl_default_size + ; parent = Some lmem } in let child2 = - { - map = Hashtbl.create Interpreter.Flags.hashtbl_default_size; - parent = Some lmem; + { map = Hashtbl.create Interpreter.Flags.hashtbl_default_size + ; parent = Some lmem } in (child1, child2) @@ -80,11 +87,11 @@ module LazyMemory : MemoryBackend = struct List.fold_right (fun (a, se) acc -> "(" ^ Int64.to_string a ^ "->" ^ "(" ^ Expression.to_string se ^ ")" - ^ ")\n" ^ acc) + ^ ")\n" ^ acc ) lst "" let to_heap (map : t) (expr_to_value : Expression.t -> Num.t) : - Concolic.Heap.t = + Concolic.Heap.t = failwith "TODO: LazyMemory.to_heap is not implemented" end @@ -115,11 +122,11 @@ module MapMemory : MemoryBackend = struct List.fold_right (fun (a, se) acc -> "(" ^ Int64.to_string a ^ "->" ^ "(" ^ Expression.to_string se ^ ")" - ^ ")\n" ^ acc) + ^ ")\n" ^ acc ) lst "" let to_heap (map : t) (expr_to_value : Expression.t -> Num.t) : - Concolic.Heap.t = + Concolic.Heap.t = let sz = Hashtbl.length map in let mem = Concolic.Heap.alloc sz in let address_symb_seq = Hashtbl.to_seq map in @@ -131,10 +138,9 @@ module MapMemory : MemoryBackend = struct match c with | I64 cb -> Int64.to_int cb | _ -> - failwith - ("Memory should be composed of bytes: " ^ Num.to_string c) + failwith ("Memory should be composed of bytes: " ^ Num.to_string c) in - (a, (cb, b))) + (a, (cb, b)) ) address_symb_seq in Concolic.Heap.add_seq mem address_conc_seq; @@ -168,11 +174,11 @@ module TreeMemory : MemoryBackend = struct List.fold_right (fun (a, se) acc -> "(" ^ Int64.to_string a ^ "->" ^ "(" ^ Expression.to_string se ^ ")" - ^ ")\n" ^ acc) + ^ ")\n" ^ acc ) lst "" let to_heap (map : t) (expr_to_value : Expression.t -> Num.t) : - Concolic.Heap.t = + Concolic.Heap.t = failwith "TODO" exception Bounds @@ -180,20 +186,29 @@ end module type SymbolicMemory = sig type b - type t = { backend : b; chunk_table : (int32, int32) Hashtbl.t } + + type t = + { backend : b + ; chunk_table : (int32, int32) Hashtbl.t + } exception Bounds val from_heap : Concolic.Heap.t -> t + val clone : t -> t * t + val load_value : t -> address -> offset -> num_type -> Expression.t val load_packed : pack_size -> t -> address -> offset -> num_type -> Expression.t val load_string : t -> address -> string + val store_value : t -> address -> offset -> Expression.t -> unit + val store_packed : pack_size -> t -> address -> offset -> Expression.t -> unit + val to_string : t -> string val to_heap : @@ -201,14 +216,21 @@ module type SymbolicMemory = sig (*TODO : change int32 to address (int64)*) val alloc : t -> int32 -> size -> unit + val free : t -> int32 -> unit + val check_access : t -> int32 -> Num.t -> offset -> bug option + val check_bound : t -> int32 -> bool end module SMem (MB : MemoryBackend) : SymbolicMemory = struct type b = MB.t - type t = { backend : b; chunk_table : Chunktable.t } + + type t = + { backend : b + ; chunk_table : Chunktable.t + } exception Bounds = MB.Bounds @@ -222,16 +244,16 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct match sz with Pack8 -> 1 | Pack16 -> 2 | Pack32 -> 4 let storen (mem : MB.t) (a : address) (o : offset) (n : int) - (value : Expression.t) : unit = + (value : Expression.t) : unit = let rec loop mem a i n x = if n > i then ( MB.store_byte mem a (Expression.Extract (x, i + 1, i)); - loop mem (Int64.add a 1L) (i + 1) n x) + loop mem (Int64.add a 1L) (i + 1) n x ) in loop mem (effective_address a o) 0 n value let loadn (mem : MB.t) (a : address) (o : offset) (n : int) : - Expression.t list = + Expression.t list = let rec loop a n acc = if n = 0 then acc else @@ -250,17 +272,17 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct let backend1, backend2 = MB.clone m.backend in let chunk_table1 = m.chunk_table in let chunk_table2 = Chunktable.copy chunk_table1 in - ( { backend = backend1; chunk_table = chunk_table1 }, - { backend = backend2; chunk_table = chunk_table2 } ) + ( { backend = backend1; chunk_table = chunk_table1 } + , { backend = backend2; chunk_table = chunk_table2 } ) let load_value (mem : t) (a : address) (o : offset) (ty : num_type) : - Expression.t = + Expression.t = let exprs = loadn mem.backend a o (Types.size_of_num_type ty) in let expr = List.( fold_left (fun acc e -> Expression.Concat (e, acc)) - (hd exprs) (tl exprs)) + (hd exprs) (tl exprs) ) in (* simplify concats *) let expr = Expression.simplify expr in @@ -269,25 +291,25 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct let expr = match ty with | `I32Type -> ( - match expr with - | Val (Num (I64 v)) -> Val (Num (I32 (Int64.to_int32 v))) - | _ -> expr) + match expr with + | Val (Num (I64 v)) -> Val (Num (I32 (Int64.to_int32 v))) + | _ -> expr ) | `I64Type -> expr | `F32Type -> ( - match expr with - | Val (Num (I64 v)) -> Val (Num (F32 (Int64.to_int32 v))) - | Cvtop (I32 I32.ReinterpretFloat, v) -> v - | _ -> Cvtop (F32 F32.ReinterpretInt, expr)) + match expr with + | Val (Num (I64 v)) -> Val (Num (F32 (Int64.to_int32 v))) + | Cvtop (I32 I32.ReinterpretFloat, v) -> v + | _ -> Cvtop (F32 F32.ReinterpretInt, expr) ) | `F64Type -> ( - match expr with - | Val (Num (I64 v)) -> Val (Num (F64 v)) - | Cvtop (I64 I64.ReinterpretFloat, v) -> v - | _ -> Cvtop (F64 F64.ReinterpretInt, expr)) + match expr with + | Val (Num (I64 v)) -> Val (Num (F64 v)) + | Cvtop (I64 I64.ReinterpretFloat, v) -> v + | _ -> Cvtop (F64 F64.ReinterpretInt, expr) ) in expr let load_packed (sz : pack_size) (mem : t) (a : address) (o : offset) - (ty : num_type) : Expression.t = + (ty : num_type) : Expression.t = let exprs = loadn mem.backend a o (length_pack_size sz) in (* pad with 0s *) let expr = @@ -305,9 +327,9 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct let expr = match ty with | `I32Type -> ( - match expr with - | Val (Num (I64 v)) -> Val (Num (I32 (Int64.to_int32 v))) - | _ -> expr) + match expr with + | Val (Num (I64 v)) -> Val (Num (I32 (Int64.to_int32 v))) + | _ -> expr ) | `I64Type -> expr | _ -> failwith "load_packed only exists for i32 and i64" in @@ -320,39 +342,39 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct match sb with | Extract (Val (Num (I64 b)), 1, 0) -> Int64.to_int b | _ -> - failwith - ("Symmem.load_string failed to load a char" - ^ "\nThe value loaded was: " ^ Expression.to_string sb) + failwith + ( "Symmem.load_string failed to load a char" + ^ "\nThe value loaded was: " ^ Expression.to_string sb ) in if b = 0 then acc else loop (Int64.add a 1L) (acc ^ Char.(escaped (chr b))) in loop a "" let store_value (mem : t) (a : address) (o : offset) (value : Expression.t) : - unit = + unit = let ty = Expression.type_of value in let sz = Types.size ty in let value = match ty with | `I32Type -> ( - match value with - | Val (Num (I32 i)) -> Val (Num (I64 (Int64.of_int32 i))) - | _ -> value) + match value with + | Val (Num (I32 i)) -> Val (Num (I64 (Int64.of_int32 i))) + | _ -> value ) | `I64Type -> value | `F32Type -> ( - match value with - | Val (Num (F32 f)) -> Val (Num (I64 (Int64.of_int32 f))) - | _ -> Cvtop (I32 I32.ReinterpretFloat, value)) + match value with + | Val (Num (F32 f)) -> Val (Num (I64 (Int64.of_int32 f))) + | _ -> Cvtop (I32 I32.ReinterpretFloat, value) ) | `F64Type -> ( - match value with - | Val (Num (F64 f)) -> Val (Num (I64 f)) - | _ -> Cvtop (I64 I64.ReinterpretFloat, value)) + match value with + | Val (Num (F64 f)) -> Val (Num (I64 f)) + | _ -> Cvtop (I64 I64.ReinterpretFloat, value) ) | _ -> assert false in storen mem.backend a o sz value let store_packed (sz : pack_size) (mem : t) (a : address) (o : offset) - (value : Expression.t) : unit = + (value : Expression.t) : unit = let value : Expression.t = match value with | Val (Num (I32 x)) -> Val (Num (I64 (Int64.of_int32 x))) @@ -364,7 +386,7 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct let to_string (m : t) : string = MB.to_string m.backend let to_heap (m : t) (expr_to_value : Expression.t -> Num.t) : - Concolic.Heap.t * (int32, int32) Hashtbl.t = + Concolic.Heap.t * (int32, int32) Hashtbl.t = (MB.to_heap m.backend expr_to_value, m.chunk_table) (*TODO : change int32 to address (int64)*) @@ -380,5 +402,7 @@ module SMem (MB : MemoryBackend) : SymbolicMemory = struct end module LazySMem : SymbolicMemory = SMem (LazyMemory) + module MapSMem : SymbolicMemory = SMem (MapMemory) + module TreeSMem : SymbolicMemory = SMem (TreeMemory) diff --git a/src/static/memory.mli b/src/static/memory.mli index 6bb95636..18f75fb0 100644 --- a/src/static/memory.mli +++ b/src/static/memory.mli @@ -5,7 +5,9 @@ open Types open Interpreter.Memory type size = int32 + type address = int64 + type offset = int32 module type MemoryBackend = sig @@ -14,33 +16,49 @@ module type MemoryBackend = sig exception Bounds val store_byte : t -> address -> Expression.t -> unit + val load_byte : t -> address -> Expression.t + val from_heap : Concolic.Heap.t -> t + val clone : t -> t * t + val to_string : t -> string + val to_heap : t -> (Expression.t -> Num.t) -> Concolic.Heap.t end module LazyMemory : MemoryBackend + module MapMemory : MemoryBackend + module TreeMemory : MemoryBackend module type SymbolicMemory = sig type b - type t = { backend : b; chunk_table : Chunktable.t } + + type t = + { backend : b + ; chunk_table : Chunktable.t + } exception Bounds val from_heap : Concolic.Heap.t -> t + val clone : t -> t * t + val load_value : t -> address -> offset -> num_type -> Expression.t val load_packed : pack_size -> t -> address -> offset -> num_type -> Expression.t val load_string : t -> address -> string + val store_value : t -> address -> offset -> Expression.t -> unit + val store_packed : pack_size -> t -> address -> offset -> Expression.t -> unit + val to_string : t -> string val to_heap : @@ -48,11 +66,16 @@ module type SymbolicMemory = sig (*TODO : change int32 to address (int64)*) val alloc : t -> int32 -> size -> unit + val free : t -> int32 -> unit + val check_access : t -> int32 -> Num.t -> offset -> bug option + val check_bound : t -> int32 -> bool end module LazySMem : SymbolicMemory + module MapSMem : SymbolicMemory + module TreeSMem : SymbolicMemory diff --git a/src/static/strategies.ml b/src/static/strategies.ml index 5a0939b2..6868adcd 100644 --- a/src/static/strategies.ml +++ b/src/static/strategies.ml @@ -1,17 +1,22 @@ open Common open Encoding -type interruption = IntLimit | AssFail of string | Bug of Bug.bug * string +type interruption = + | IntLimit + | AssFail of string + | Bug of Bug.bug * string (* Symbolic Frame *) -type sym_frame = { - sym_inst : Interpreter.Instance.module_inst; - sym_locals : Expression.t ref list; (* Locals can be symbolic *) -} +type sym_frame = + { sym_inst : Interpreter.Instance.module_inst + ; sym_locals : Expression.t ref list (* Locals can be symbolic *) + } (* Symbolic code *) type sym_code = Expression.t list * sym_admin_instr list + and sym_admin_instr = sym_admin_instr' Interpreter.Source.phrase + and instr = Interpreter.Ast.instr' Interpreter.Source.phrase and sym_admin_instr' = @@ -22,10 +27,8 @@ and sym_admin_instr' = | SBreaking of int32 * Expression.t list | SLabel of int * instr list * sym_code | SFrame of int * sym_frame * sym_code - (** - * Wasp's administrative instructions to halt - * small-step semantic intepretation - *) + (** * Wasp's administrative instructions to halt * small-step semantic + intepretation *) | Interrupt of interruption module type Interpreter = sig @@ -38,12 +41,12 @@ module type Interpreter = sig val clone : sym_config -> sym_config * sym_config val sym_config : - Interpreter.Instance.module_inst -> - Expression.t list -> - sym_admin_instr list -> - Concolic.Heap.t -> - Expression.t Globals.t -> - sym_config + Interpreter.Instance.module_inst + -> Expression.t list + -> sym_admin_instr list + -> Concolic.Heap.t + -> Expression.t Globals.t + -> sym_config val step : sym_config -> (step_res, string * Interpreter.Source.region) result @@ -51,15 +54,15 @@ module type Interpreter = sig sym_config -> (string * Interpreter.Source.region) option val p_invoke : - sym_config -> - (Encoding.Expression.t, string * Interpreter.Source.region) result + sym_config + -> (Encoding.Expression.t, string * Interpreter.Source.region) result val p_finished : sym_config -> Encoding.Expression.t -> sym_config option end module TreeStrategy (L : WorkList) (I : Interpreter) = struct let eval (c : I.sym_config) (pcs : Expression.t list ref) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = let w = L.create () in L.push c w; @@ -68,9 +71,9 @@ module TreeStrategy (L : WorkList) (I : Interpreter) = struct let c = L.pop w in match I.step c with | Result.Ok step_res -> ( - match step_res with - | I.Continuation cs' -> L.add_seq w (List.to_seq cs') - | I.End e -> pcs := e :: !pcs) + match step_res with + | I.Continuation cs' -> L.add_seq w (List.to_seq cs') + | I.End e -> pcs := e :: !pcs ) | Result.Error step_err -> err := Some step_err done; @@ -85,7 +88,7 @@ module BFS_L (I : Interpreter) = struct let max_configs = 32 let eval (c : I.sym_config) (pcs : Expression.t list ref) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = let w = Queue.create () in Queue.push c w; @@ -95,12 +98,12 @@ module BFS_L (I : Interpreter) = struct let c = Queue.pop w in match I.step c with | Result.Ok step_res -> ( - match step_res with - | I.Continuation cs' -> - if l + List.length cs' <= max_configs then - Queue.add_seq w (List.to_seq cs') - else Queue.push c w - | I.End e -> pcs := e :: !pcs) + match step_res with + | I.Continuation cs' -> + if l + List.length cs' <= max_configs then + Queue.add_seq w (List.to_seq cs') + else Queue.push c w + | I.End e -> pcs := e :: !pcs ) | Result.Error step_err -> err := Some step_err done; @@ -111,7 +114,7 @@ module Half_BFS (I : Interpreter) = struct let max_configs = 512 let eval (c : I.sym_config) (pcs : Expression.t list ref) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = let w = Queue.create () in Queue.push c w; @@ -120,21 +123,21 @@ module Half_BFS (I : Interpreter) = struct let c = Queue.pop w in match I.step c with | Result.Ok step_res -> ( - match step_res with - | I.Continuation cs' -> Queue.add_seq w (List.to_seq cs') - | I.End e -> pcs := e :: !pcs) + match step_res with + | I.Continuation cs' -> Queue.add_seq w (List.to_seq cs') + | I.End e -> pcs := e :: !pcs ) | Result.Error step_err -> - err := Some step_err; - let l = Queue.length w in - if l >= max_configs - 2 then ( - let filtered = - Queue.of_seq - (Seq.filter_map - (fun c -> if Random.bool () then Some c else None) - (Queue.to_seq w)) - in - Queue.clear w; - Queue.transfer filtered w) + err := Some step_err; + let l = Queue.length w in + if l >= max_configs - 2 then ( + let filtered = + Queue.of_seq + (Seq.filter_map + (fun c -> if Random.bool () then Some c else None) + (Queue.to_seq w) ) + in + Queue.clear w; + Queue.transfer filtered w ) done; !err @@ -142,7 +145,7 @@ end module ProgressBFS (I : Interpreter) = struct let eval (c : I.sym_config) (pcs : Expression.t list ref) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = let max_configs = ref 2 in let hot = Queue.create () in Queue.push c hot; @@ -158,12 +161,12 @@ module ProgressBFS (I : Interpreter) = struct let c = Queue.pop hot in match I.step c with | Result.Ok step_res -> ( - match step_res with - | I.Continuation cs' -> - if l + List.length cs' <= !max_configs then - Queue.add_seq hot (List.to_seq cs') - else Queue.add_seq cold (List.to_seq cs') - | I.End e -> pcs := e :: !pcs) + match step_res with + | I.Continuation cs' -> + if l + List.length cs' <= !max_configs then + Queue.add_seq hot (List.to_seq cs') + else Queue.add_seq cold (List.to_seq cs') + | I.End e -> pcs := e :: !pcs ) | Result.Error step_err -> err := Some step_err done; Queue.transfer cold hot; @@ -179,7 +182,7 @@ module Hybrid (I : Interpreter) = struct let max_configs = 128 let eval (c : I.sym_config) (pcs : Expression.t list ref) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = let w = Queue.create () in Queue.push c w; @@ -195,9 +198,9 @@ module Hybrid (I : Interpreter) = struct else match I.step c with | Result.Ok step_res -> ( - match step_res with - | I.Continuation cs' -> Queue.add_seq w (List.to_seq cs') - | I.End e -> pcs := e :: !pcs) + match step_res with + | I.Continuation cs' -> Queue.add_seq w (List.to_seq cs') + | I.End e -> pcs := e :: !pcs ) | Result.Error step_err -> err := Some step_err done; @@ -208,7 +211,7 @@ module HybridP (I : Interpreter) = struct let max_configs = 128 let eval (c : I.sym_config) (pcs : Expression.t list ref) : - (string * Interpreter.Source.region) option = + (string * Interpreter.Source.region) option = let w = Queue.create () in Queue.push c w; @@ -221,14 +224,14 @@ module HybridP (I : Interpreter) = struct match I.p_invoke c with | Error step_err -> err := Some step_err | Ok pc' -> - pcs := pc' :: !pcs; - Queue.add_seq w (Option.to_seq (I.p_finished c pc'))) + pcs := pc' :: !pcs; + Queue.add_seq w (Option.to_seq (I.p_finished c pc')) ) else match I.step c with | Result.Ok step_res -> ( - match step_res with - | I.Continuation cs' -> Queue.add_seq w (List.to_seq cs') - | I.End e -> pcs := e :: !pcs) + match step_res with + | I.Continuation cs' -> Queue.add_seq w (List.to_seq cs') + | I.End e -> pcs := e :: !pcs ) | Result.Error step_err -> err := Some step_err done; @@ -236,11 +239,13 @@ module HybridP (I : Interpreter) = struct end let loop_start = ref 0.0 + let pcs = ref [] + let logs = ref [] let write_report (error : (string * Interpreter.Source.region) option) - (loop_time : float) (paths : int) (step_count : int) : unit = + (loop_time : float) (paths : int) (step_count : int) : unit = if !Interpreter.Flags.log then print_logs !logs; let spec, reason = match error with @@ -284,9 +289,9 @@ module Helper (I : Interpreter) = struct module HybridP_I = HybridP (I) let helper (inst : Interpreter.Instance.module_inst) (vs : Expression.t list) - (es : sym_admin_instr list) (sym_m : Concolic.Heap.t) - (globs : Expression.t Globals.t) : - bool * (string * Interpreter.Source.region) option * float * int = + (es : sym_admin_instr list) (sym_m : Concolic.Heap.t) + (globs : Expression.t Globals.t) : + bool * (string * Interpreter.Source.region) option * float * int = let c = I.sym_config inst vs es sym_m globs in let eval = @@ -301,9 +306,9 @@ module Helper (I : Interpreter) = struct | _ -> failwith "unreachable" in - (if !Interpreter.Flags.log then - let get_finished () : int = List.length !pcs in - logger logs get_finished exiter loop_start); + ( if !Interpreter.Flags.log then + let get_finished () : int = List.length !pcs in + logger logs get_finished exiter loop_start ); loop_start := Sys.time (); let step_err = eval c pcs in let spec, reason = diff --git a/src/static/varmap.ml b/src/static/varmap.ml index 93995905..310fe40d 100644 --- a/src/static/varmap.ml +++ b/src/static/varmap.ml @@ -4,19 +4,18 @@ open Types type typemap = (string, expr_type) Hashtbl.t -type varmap = { - sym : string Counter.t; - ord : string Stack.t; - typemap : typemap; -} +type varmap = + { sym : string Counter.t + ; ord : string Stack.t + ; typemap : typemap + } type t = varmap let create () : t = - { - sym = Counter.create (); - ord = Stack.create (); - typemap = Hashtbl.create Interpreter.Flags.hashtbl_default_size; + { sym = Counter.create () + ; ord = Stack.create () + ; typemap = Hashtbl.create Interpreter.Flags.hashtbl_default_size } let to_store (varmap : t) (binds : (Symbol.t * Value.t) list) : Concolic.Store.t From 39914d31783939440035e991a4d9afd52c4c9b37 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Sat, 24 Aug 2024 11:01:42 +0200 Subject: [PATCH 7/8] Bring back concolic options --- .gitignore | 2 +- bin/dune | 2 +- bin/main.ml | 32 ++++++++++++++++++++---- bin/options.ml | 48 +++++++++++++++++++++++++++++++++++- src/concolic/eval.ml | 10 +++++++- src/concolic/store.ml | 9 ++++--- src/run.ml | 6 ++--- src/run.mli | 2 +- src/std.ml | 6 +++++ tests/failing/dune | 4 +++ tests/failing/test_failing.t | 2 ++ tests/passing/dune | 4 +++ tests/passing/test_passing.t | 2 ++ 13 files changed, 112 insertions(+), 17 deletions(-) create mode 100644 src/std.ml create mode 100644 tests/failing/dune create mode 100644 tests/failing/test_failing.t create mode 100644 tests/passing/dune create mode 100644 tests/passing/test_passing.t diff --git a/.gitignore b/.gitignore index 2dc2e8bd..f84172c6 100644 --- a/.gitignore +++ b/.gitignore @@ -27,5 +27,5 @@ result .DS_Store nix/profiles/ -**/wasp-out/ +wasp-out/* bin/libc.wasm diff --git a/bin/dune b/bin/dune index 72ea30f4..d2ca4a87 100644 --- a/bin/dune +++ b/bin/dune @@ -3,4 +3,4 @@ (name main) (public_name wasp) (modules main options) - (libraries cmdliner interpreter wasp)) + (libraries prelude interpreter wasp)) diff --git a/bin/main.ml b/bin/main.ml index d45112bf..c976acc0 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,8 +1,30 @@ -let main filename = Format.printf "%a@." Fpath.pp filename +open Prelude +module Flags = Interpreter.Flags + +let run_concolic filename unchecked trace timeout workspace no_simplify policy + queries log = + let open Wasp.Std.Let_syntax.Result in + Flags.unchecked := unchecked; + Flags.trace := trace; + Flags.timeout := timeout; + Flags.output := workspace; + Flags.simplify := no_simplify; + (* Flags.policy := *) + Flags.queries := queries; + Flags.log := log; + let+ data = Bos.OS.File.read filename in + if not (Wasp.Run.run_string_concolic data policy) then 1 else 0 let cli = - let open Cmdliner in - let info = Cmd.info "wasp" ~version:"%%VERSION%%" in - Cmd.v info Term.(const main $ Options.file0) + let info = Cmdliner.Cmd.info "wasp" ~version:"%%VERSION%%" in + Cmdliner.Cmd.group info [ Options.cmd_concolic run_concolic ] -let () = exit (Cmdliner.Cmd.eval cli) +let () = + match Cmdliner.Cmd.eval_value' cli with + | `Ok result -> ( + match result with + | Ok n -> exit n + | Error (`Msg msg) -> + Fmt.epr "unexpected error: %s@." msg; + exit 2 ) + | `Exit n -> exit n diff --git a/bin/options.ml b/bin/options.ml index 338805d6..8b55ce67 100644 --- a/bin/options.ml +++ b/bin/options.ml @@ -3,5 +3,51 @@ open Cmdliner let path = ((fun s -> `Ok (Fpath.v s)), Fpath.pp) let file0 = - let doc = "input file to analyse" in + let doc = "$(docv) to analyse" in Arg.(required & pos 0 (some path) None & info [] ~doc ~docv:"FILE") + +let unchecked = + let doc = "Unchecked, do not perform validation" in + Arg.(value & flag & info [ "u"; "unchecked" ] ~doc) + +let trace = + let doc = "Trace execution" in + Arg.(value & flag & info [ "t"; "trace" ] ~doc) + +let timeout = + let doc = "Time limit" in + Arg.(value & opt int ~-1 & info [ "timeout" ] ~doc) + +let workspace = + let doc = "Directory to output report and testsuite (default=wasp-out)" in + Arg.(value & opt string "wasp-out" & info [ "workspace" ] ~doc) + +let no_simplify = + let doc = "Don't perform algebraic simplifications of symbolic expressions" in + Arg.(value & flag & info [ "no-simplify" ] ~doc) + +let policy_conv = + Arg.enum + [ ("random", Concolic.Eval.Random) + ; ("depth", Concolic.Eval.Depth) + ; ("breadth", Concolic.Eval.Breadth) + ] + +let policy = + let doc = "Search policy random|depth|breadth (default=random)" in + Arg.(value & opt policy_conv Concolic.Eval.Random & info [ "policy" ] ~doc) + +let queries = + let doc = "Output solver queries in .smt2 format" in + Arg.(value & flag & info [ "queries" ] ~doc) + +let log = + let doc = "Logs paths and memory" in + Arg.(value & flag & info [ "log" ] ~doc) + +let cmd_concolic run = + let info = Cmd.info "concolic" in + Cmd.v info + Term.( + const run $ file0 $ unchecked $ trace $ timeout $ workspace $ no_simplify + $ policy $ queries $ log ) diff --git a/src/concolic/eval.ml b/src/concolic/eval.ml index 1be7723b..81ff35b6 100644 --- a/src/concolic/eval.ml +++ b/src/concolic/eval.ml @@ -233,7 +233,15 @@ let mk_relop ?(reduce : bool = true) (e : Expr.t) (ty : Ty.t) = | Ty_fp 64 -> Expr.relop (Ty_fp 64) Ne e (Expr.value zero) | _ -> assert false ) -let add_constraint ?neg:_ _ _ = assert false +let add_constraint ?(neg : bool = false) e pc = + let cond = + let c = to_relop (Expr.simplify e) in + if neg then Option.map (fun e -> Expr.Bool.not e) c else c + in + match (cond, Expr.view pc) with + | None, _ -> pc + | Some cond, Val True -> cond + | Some cond, _ -> Expr.binop Ty_bool And cond pc let branch_on_cond bval c pc tree = let tree', to_branch = diff --git a/src/concolic/store.ml b/src/concolic/store.ml index a421cc35..ae21ed8a 100644 --- a/src/concolic/store.ml +++ b/src/concolic/store.ml @@ -186,10 +186,11 @@ let rec eval (env : t) (e : Expr.t) : Value.t = in Hashtbl.replace env.map x v; Num v ) - | Extract (e, _, _) -> - let _v = int64_of_value (eval env e) in - (* Num (I64 (Expr.nland64 (Int64.shift_right v (l * 8)) (h - l))) *) - assert false + | Extract (e', h, l) when h - l = 1 -> + let v = int64_of_value (eval env e') in + Num (I64 Int64.(logand (shift_right v (8 * l)) 0xffL)) + | Extract (_, _, _) -> + assert false | Concat (e1, e2) -> ( let v1 = int64_of_value (eval env e1) in let v2 = int64_of_value (eval env e2) in diff --git a/src/run.ml b/src/run.ml index 78034521..827abeed 100644 --- a/src/run.ml +++ b/src/run.ml @@ -524,7 +524,7 @@ and run_quote_script script invoke = bind scripts None (List.rev !quote); quote := !quote @ save_quote -let invoke_concolic f vs inst = +let invoke_concolic _policy f vs inst = Concolic.Eval.main f (List.map (fun v -> @@ -545,8 +545,8 @@ let run_file _file = (* input_file file run_script *) assert false -let run_string_concolic string = - input_string string ~callback:(fun s -> run_script s invoke_concolic) +let run_string_concolic string policy = + input_string string ~callback:(fun s -> run_script s (invoke_concolic policy)) (* let run_string_se string = *) (* input_string string ~callback:(fun s -> run_script s invoke_se) *) diff --git a/src/run.mli b/src/run.mli index b8ca5bf7..a71bc74c 100644 --- a/src/run.mli +++ b/src/run.mli @@ -8,7 +8,7 @@ exception IO of Source.region * string val trace : string -> unit -val run_string_concolic : string -> bool +val run_string_concolic : string -> Concolic.Eval.policy -> bool val run_file : string -> bool diff --git a/src/std.ml b/src/std.ml new file mode 100644 index 00000000..d92fe542 --- /dev/null +++ b/src/std.ml @@ -0,0 +1,6 @@ +module Let_syntax = struct + module Result = struct + let ( let* ) = Result.bind + let ( let+ ) v f = Result.map f v + end +end diff --git a/tests/failing/dune b/tests/failing/dune new file mode 100644 index 00000000..546a0fb5 --- /dev/null +++ b/tests/failing/dune @@ -0,0 +1,4 @@ +(cram + (deps + %{bin:wasp} + test1.wast)) diff --git a/tests/failing/test_failing.t b/tests/failing/test_failing.t new file mode 100644 index 00000000..b87d19d7 --- /dev/null +++ b/tests/failing/test_failing.t @@ -0,0 +1,2 @@ +Run tests with assertion failures in concolic: + $ wasp concolic test1.wast diff --git a/tests/passing/dune b/tests/passing/dune new file mode 100644 index 00000000..546a0fb5 --- /dev/null +++ b/tests/passing/dune @@ -0,0 +1,4 @@ +(cram + (deps + %{bin:wasp} + test1.wast)) diff --git a/tests/passing/test_passing.t b/tests/passing/test_passing.t new file mode 100644 index 00000000..67c47aa5 --- /dev/null +++ b/tests/passing/test_passing.t @@ -0,0 +1,2 @@ +Run tests without issues in concolic: + $ wasp concolic test1.wast From 1d602f38b0b22b13ee7e78d404a08be0526ef3e6 Mon Sep 17 00:00:00 2001 From: Filipe Marques Date: Sat, 24 Aug 2024 11:04:36 +0200 Subject: [PATCH 8/8] Add z3 dependency --- dune-project | 3 ++- wasp.opam | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/dune-project b/dune-project index fa43fda0..56f439f5 100644 --- a/dune-project +++ b/dune-project @@ -26,4 +26,5 @@ (ocamlformat :with-dev-setup) pyml re2 - (smtml (>= "0.2.4")))) + (smtml (>= "0.2.4")) + z3)) diff --git a/wasp.opam b/wasp.opam index a0a3ff82..9724c705 100644 --- a/wasp.opam +++ b/wasp.opam @@ -18,6 +18,7 @@ depends: [ "pyml" "re2" "smtml" {>= "0.2.4"} + "z3" "odoc" {with-doc} ] build: [