pax_global_header00006660000000000000000000000064147436723200014522gustar00rootroot0000000000000052 comment=9621d6d3d443131adeba126c0fba400ea3a21939 multicoretests-0.7/000077500000000000000000000000001474367232000144565ustar00rootroot00000000000000multicoretests-0.7/.gitattributes000066400000000000000000000000211474367232000173420ustar00rootroot00000000000000*.sh text eol=lf multicoretests-0.7/.github/000077500000000000000000000000001474367232000160165ustar00rootroot00000000000000multicoretests-0.7/.github/runner.sh000077500000000000000000000117361474367232000176760ustar00rootroot00000000000000#!/bin/sh set -e OCAMLDIR=ocaml DUNEDIR=dune MULTICORETESTSDIR=multicoretests fatal() { printf %s "$1" exit 1 } compiler_sha() { # Expect $COMPILER_REPO and $COMPILER_REF to be set # Note: only GitHub-hosted compiler forks are supported for now git ls-remote "https://github.com/$COMPILER_REPO.git" "$COMPILER_REF" \ | cut -f 1 } setup() { if [ -n "$GITHUB_ENV" ] && [ -n "$GITHUB_PATH" ] ; then sha="$(compiler_sha)" || fatal "Cannot find compiler's SHA" arch="$(uname -m)" opts="$(printf %s "$OCAML_OPTIONS" | tr " " -)" opts="${opts:+-}$opts" echo "cache_key=ocaml-$sha-$OCAML_PLATFORM-$arch$opts" >> "$GITHUB_ENV" case "$OCAML_PLATFORM" in mingw|msvc|cygwin) PREFIX='D:\ocaml' bin='D:\ocaml\bin' ;; *) PREFIX="$HOME/local" bin="$HOME/local/bin" ;; esac printf "PREFIX=%s\n" "$PREFIX" >> "$GITHUB_ENV" printf "%s\n" "$bin" >> "$GITHUB_PATH" if [ -z "$JOBS" ] ; then if command -v nproc > /dev/null; then echo "JOBS=$(nproc)" >> "$GITHUB_ENV" elif command -v sysctl > /dev/null; then echo "JOBS=$(sysctl -n hw.ncpu)" >> "$GITHUB_ENV" fi fi echo Environment set up: cat "$GITHUB_ENV" echo PATH addition: cat "$GITHUB_PATH" fi case "$OCAML_PLATFORM,$OCAML_OPTIONS" in linux,*32bit*) sudo dpkg --add-architecture i386 sudo apt-get update sudo apt-get install pkg-config:i386 libzstd1:i386 libzstd-dev:i386 \ libgcc-s1:i386 gcc-multilib g++-multilib ;; linux,*musl*) sudo apt-get update sudo apt-get install musl-tools ;; esac } build_ocaml() { echo "${LOGBEGINGRP}Building OCaml" # We let standard OCaml CI test for warnings opts="--disable-warn-error \ --disable-stdlib-manpages \ --disable-ocamltest \ --disable-ocamldoc" case "$OCAML_OPTIONS" in *fp*) opts="$opts --enable-frame-pointers" ;; esac case "$OCAML_OPTIONS" in *bytecode-only*) opts="$opts --disable-native-compiler" ;; esac case "$OCAML_PLATFORM" in msvc|mingw|cygwin) opts="$opts --prefix=/cygdrive/d/ocaml" ;; *) opts="$opts --prefix=$PREFIX" ;; esac cd "$OCAMLDIR" case "$OCAML_PLATFORM,$OCAML_OPTIONS" in msvc,*32bit*) eval $(tools/msvs-promote-path) printf 'Running: %s\n' "./configure --host=i686-pc-windows $opts" if ! ./configure --host=i686-pc-windows $opts ; then cat config.log exit 1 fi ;; msvc,*) eval $(tools/msvs-promote-path) printf 'Running: %s\n' "./configure --host=x86_64-pc-windows $opts" if ! ./configure --host=x86_64-pc-windows $opts ; then cat config.log exit 1 fi ;; mingw,*) printf 'Running: %s\n' "./configure --host=x86_64-w64-mingw32 $opts" if ! ./configure --host=x86_64-w64-mingw32 $opts ; then cat config.log exit 1 fi ;; cygwin,*) case $COMPILER_REF in */5.1*) git -C flexdll fetch origin 0.43 git -C flexdll checkout FETCH_HEAD ;; esac printf 'Running: %s\n' "./configure $opts" if ! ./configure $opts ; then cat config.log exit 1 fi ;; linux,*32bit*) printf 'Running: %s\n' \ "./configure --host=i386-linux \"CC=gcc -m32\" $opts" if ! ./configure --host=i386-linux "CC=gcc -m32" $opts ; then cat config.log exit 1 fi ;; linux,*musl*) printf 'Running: %s\n' \ "./configure \"CC=musl-gcc\" \"CFLAGS=-Os\" \"ASPP=musl-gcc -c\" $opts" if ! ./configure "CC=musl-gcc" "CFLAGS=-Os" "ASPP=musl-gcc -c" $opts ; then cat config.log exit 1 fi ;; *) # linux, macos, default options printf 'Running: %s\n' "./configure $opts" if ! ./configure $opts ; then cat config.log exit 1 fi ;; esac make -j"$JOBS" make install echo "$LOGENDGRP" } build_dune() { echo "${LOGBEGINGRP}Building dune" case "$OCAML_PLATFORM" in msvc) eval $("$OCAMLDIR"/tools/msvs-promote-path) ;; esac cd "$DUNEDIR" make release make install PREFIX="$PREFIX" echo "$LOGENDGRP" } show_config() { set -x ocamlc -config dune --version } build_testsuite() { case "$OCAML_PLATFORM" in msvc) eval $("$OCAMLDIR"/tools/msvs-promote-path) ;; esac cd "$MULTICORETESTSDIR" dune build dune build test/ } case "$1" in setup) setup ;; ocaml) build_ocaml ;; dune) build_dune ;; show_config) show_config ;; build) build_testsuite ;; testsuite) cd "$MULTICORETESTSDIR" dune build @ci -j1 --no-buffer --display=quiet --cache=disabled --error-reporting=twice ;; internaltests) cd "$MULTICORETESTSDIR" dune build @internaltests -j1 --no-buffer --display=quiet --cache=disabled --error-reporting=twice ;; *) fatal "Unknown command '$1'" ;; esac multicoretests-0.7/.github/workflows/000077500000000000000000000000001474367232000200535ustar00rootroot00000000000000multicoretests-0.7/.github/workflows/common.yml000066400000000000000000000116101474367232000220650ustar00rootroot00000000000000name: Common CI workflow concurrency: group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} cancel-in-progress: true on: workflow_call: inputs: runs_on: description: 'Type of machine + OS on which to run the tests' type: string default: 'ubuntu-latest' options: description: >- Configuration options for the compiler. Space-separated list of '32bit', 'bytecode-only', 'fp', 'musl'. type: string default: '' platform: description: 'Platform. One of: linux, macos, msvc, mingw, cygwin.' type: string default: 'linux' timeout: description: 'Timeout' type: number default: 180 dune_profile: description: 'Dune profile to use' type: string default: 'dev' runparam: description: 'OCAMLRUNPARAM to use' type: string default: '' dune_alias: description: 'dune alias that should be built in the main step' type: string default: 'testsuite' compiler_repository: description: 'Repository from which to fetch the compiler' type: string default: 'ocaml/ocaml' compiler_ref: description: 'Git reference to use' type: string required: true permissions: {} jobs: test: env: QCHECK_MSG_INTERVAL: '60' OCAML_OPTIONS: ${{ inputs.options }} OCAML_PLATFORM: ${{ inputs.platform }} DUNE_PROFILE: ${{ inputs.dune_profile }} OCAMLRUNPARAM: ${{ inputs.runparam }} DUNE_CI_ALIAS: ${{ inputs.dune_alias }} COMPILER_REPO: ${{ inputs.compiler_repository }} COMPILER_REF: ${{ inputs.compiler_ref }} LOGBEGINGRP: "::group::" LOGENDGRP: "::endgroup::" # For the record, PR 12345 of the compiler can be tested simply by setting # COMPILER_REF: 'refs/pull/12345/head' runs-on: ${{ inputs.runs_on }} timeout-minutes: ${{ inputs.timeout }} steps: - name: Configure EOLs on Cygwin run: | # Ensure that .expected files are not modified by check out # as, in Cygwin, the .expected should use LF line endings, # rather than Windows’ CRLF git config --global core.autocrlf input if: inputs.platform == 'cygwin' - name: Checkout code uses: actions/checkout@v4 with: path: multicoretests - name: Fetch QCheck uses: actions/checkout@v4 with: repository: c-cube/qcheck ref: v0.23 path: multicoretests/qcheck - name: Pre-Setup run: | bash multicoretests/.github/runner.sh setup - name: Set up MSVC uses: ilammy/msvc-dev-cmd@v1 if: inputs.platform == 'msvc' - name: Restore cache uses: actions/cache/restore@v4 id: cache with: path: | ${{ env.PREFIX }} C:\cygwin-packages key: ${{ env.cache_key }} - name: Install Cygwin (Windows only) uses: cygwin/cygwin-install-action@v4 with: packages: make,bash${{ inputs.platform == 'mingw' && ',mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++' || '' }}${{ inputs.platform == 'cygwin' && ',gcc-core' }} install-dir: 'D:\cygwin' if: runner.os == 'Windows' - name: Fetch OCaml uses: actions/checkout@v4 with: repository: ${{ env.COMPILER_REPO }} ref: ${{ env.COMPILER_REF }} path: ocaml submodules: true if: steps.cache.outputs.cache-hit != 'true' || inputs.platform == 'msvc' # We need to fetch OCaml in all cases for MSVC for msvs-promote-path - name: Fetch dune uses: actions/checkout@v4 with: repository: ocaml/dune ref: 3.16.0 path: dune if: steps.cache.outputs.cache-hit != 'true' - name: Build and install OCaml and dune run: | bash multicoretests/.github/runner.sh ocaml bash multicoretests/.github/runner.sh dune if: steps.cache.outputs.cache-hit != 'true' - name: Save cache uses: actions/cache/save@v4 with: path: | ${{ env.PREFIX }} C:\cygwin-packages key: ${{ env.cache_key }} if: steps.cache.outputs.cache-hit != 'true' - name: Show the configuration run: | bash multicoretests/.github/runner.sh show_config - name: Build the test suite run: | bash multicoretests/.github/runner.sh build - name: Run the internal package tests run: | bash multicoretests/.github/runner.sh internaltests - name: Run the multicore test suite run: | bash multicoretests/.github/runner.sh testsuite multicoretests-0.7/.github/workflows/cygwin-52x.yml000066400000000000000000000004471474367232000225170ustar00rootroot00000000000000name: Cygwin 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: cygwin compiler_ref: refs/tags/5.2.1 timeout: 240 multicoretests-0.7/.github/workflows/cygwin-530-trunk.yml000066400000000000000000000005311474367232000235430ustar00rootroot00000000000000name: Cygwin 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: cygwin compiler_ref: refs/heads/5.3 timeout: 240 multicoretests-0.7/.github/workflows/cygwin-540-trunk.yml000066400000000000000000000005351474367232000235500ustar00rootroot00000000000000name: Cygwin trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: cygwin compiler_ref: refs/heads/trunk timeout: 240 multicoretests-0.7/.github/workflows/gh-pages.yml000066400000000000000000000017321474367232000222740ustar00rootroot00000000000000name: github pages on: push: branches: - main # Set a branch name to trigger deployment jobs: deploy: runs-on: ubuntu-latest steps: - name: Checkout code uses: actions/checkout@v4 - name: Cache opam id: cache-opam uses: actions/cache@v3 with: path: ~/.opam key: opam-ubuntu-latest-5.0.0 - uses: avsm/setup-ocaml@v3 with: ocaml-compiler: 'ocaml-base-compiler.5.0.0' default: https://github.com/ocaml/opam-repository.git - name: Pin packages run: opam pin -n . - name: Install dependencies run: opam install -d . --deps-only - name: Build run: opam exec -- dune build @doc - name: Deploy uses: peaceiris/actions-gh-pages@v3 with: github_token: ${{ secrets.GITHUB_TOKEN }} publish_dir: ./_build/default/_doc/_html/ destination_dir: dev enable_jekyll: true multicoretests-0.7/.github/workflows/linux-52x-32bit.yml000066400000000000000000000004061474367232000232720ustar00rootroot00000000000000name: 32bit 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/tags/5.2.1 options: 32bit timeout: 240 multicoretests-0.7/.github/workflows/linux-52x-bytecode.yml000066400000000000000000000004211474367232000241420ustar00rootroot00000000000000name: Bytecode 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/tags/5.2.1 options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/linux-52x-debug.yml000066400000000000000000000004701474367232000234360ustar00rootroot00000000000000name: Linux 5.2 debug on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/tags/5.2.1 dune_profile: 'debug-runtime' runparam: 's=4096,V=1' timeout: 240 multicoretests-0.7/.github/workflows/linux-52x-fp.yml000066400000000000000000000004001474367232000227460ustar00rootroot00000000000000name: FP 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/tags/5.2.1 options: fp timeout: 240 multicoretests-0.7/.github/workflows/linux-52x-musl.yml000066400000000000000000000004041474367232000233250ustar00rootroot00000000000000name: musl 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/tags/5.2.1 options: musl timeout: 240 multicoretests-0.7/.github/workflows/linux-52x.yml000066400000000000000000000003361474367232000223530ustar00rootroot00000000000000name: Linux 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/tags/5.2.1 multicoretests-0.7/.github/workflows/linux-530-trunk-32bit.yml000066400000000000000000000004701474367232000243250ustar00rootroot00000000000000name: 32bit 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/5.3 options: 32bit timeout: 240 multicoretests-0.7/.github/workflows/linux-530-trunk-bytecode.yml000066400000000000000000000005031474367232000251750ustar00rootroot00000000000000name: Bytecode 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/5.3 options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/linux-530-trunk-debug.yml000066400000000000000000000005521474367232000244710ustar00rootroot00000000000000name: Linux 5.3 debug on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/5.3 dune_profile: 'debug-runtime' runparam: 's=4096,V=1' timeout: 240 multicoretests-0.7/.github/workflows/linux-530-trunk-fp.yml000066400000000000000000000004621474367232000240100ustar00rootroot00000000000000name: FP 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/5.3 options: fp timeout: 240 multicoretests-0.7/.github/workflows/linux-530-trunk-musl.yml000066400000000000000000000004661474367232000243670ustar00rootroot00000000000000name: musl 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/5.3 options: musl timeout: 240 multicoretests-0.7/.github/workflows/linux-530-trunk.yml000066400000000000000000000004201474367232000233770ustar00rootroot00000000000000name: Linux 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/5.3 multicoretests-0.7/.github/workflows/linux-540-trunk-32bit.yml000066400000000000000000000004741474367232000243320ustar00rootroot00000000000000name: 32bit trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/trunk options: 32bit timeout: 240 multicoretests-0.7/.github/workflows/linux-540-trunk-bytecode.yml000066400000000000000000000005071474367232000252020ustar00rootroot00000000000000name: Bytecode trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/trunk options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/linux-540-trunk-debug.yml000066400000000000000000000005561474367232000244760ustar00rootroot00000000000000name: Linux trunk debug on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/trunk dune_profile: 'debug-runtime' runparam: 's=4096,V=1' timeout: 240 multicoretests-0.7/.github/workflows/linux-540-trunk-fp.yml000066400000000000000000000004661474367232000240150ustar00rootroot00000000000000name: FP trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/trunk options: fp timeout: 240 multicoretests-0.7/.github/workflows/linux-540-trunk-musl.yml000066400000000000000000000004721474367232000243650ustar00rootroot00000000000000name: musl trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/trunk options: musl timeout: 240 multicoretests-0.7/.github/workflows/linux-540-trunk.yml000066400000000000000000000004241474367232000234040ustar00rootroot00000000000000name: Linux trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: compiler_ref: refs/heads/trunk multicoretests-0.7/.github/workflows/macosx-arm64-52x.yml000066400000000000000000000004241474367232000234330ustar00rootroot00000000000000name: macOS-ARM64 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: 'macos-14' platform: macos compiler_ref: refs/tags/5.2.1 multicoretests-0.7/.github/workflows/macosx-arm64-530-trunk.yml000066400000000000000000000005061474367232000244660ustar00rootroot00000000000000name: macOS-ARM64 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: 'macos-14' platform: macos compiler_ref: refs/heads/5.3 multicoretests-0.7/.github/workflows/macosx-arm64-540-trunk.yml000066400000000000000000000005121474367232000244640ustar00rootroot00000000000000name: macOS-ARM64 trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: 'macos-14' platform: macos compiler_ref: refs/heads/trunk multicoretests-0.7/.github/workflows/macosx-intel-52x.yml000066400000000000000000000004241474367232000236150ustar00rootroot00000000000000name: macOS-intel 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: 'macos-13' platform: macos compiler_ref: refs/tags/5.2.1 multicoretests-0.7/.github/workflows/macosx-intel-530-trunk.yml000066400000000000000000000005061474367232000246500ustar00rootroot00000000000000name: macOS-intel 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: 'macos-13' platform: macos compiler_ref: refs/heads/5.3 multicoretests-0.7/.github/workflows/macosx-intel-540-trunk.yml000066400000000000000000000005121474367232000246460ustar00rootroot00000000000000name: macOS-intel trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: 'macos-13' platform: macos compiler_ref: refs/heads/trunk multicoretests-0.7/.github/workflows/mingw-52x-bytecode.yml000066400000000000000000000005131474367232000241260ustar00rootroot00000000000000name: MinGW bytecode 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: mingw compiler_ref: refs/tags/5.2.1 options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/mingw-52x.yml000066400000000000000000000004451474367232000223360ustar00rootroot00000000000000name: MinGW 5.2 on: schedule: # Every Monday morning, at 1:11 UTC - cron: '11 1 * * 1' workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: mingw compiler_ref: refs/tags/5.2.1 timeout: 240 multicoretests-0.7/.github/workflows/mingw-530-trunk-bytecode.yml000066400000000000000000000005751474367232000251700ustar00rootroot00000000000000name: MinGW bytecode 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: mingw compiler_ref: refs/heads/5.3 options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/mingw-530-trunk.yml000066400000000000000000000005271474367232000233710ustar00rootroot00000000000000name: MinGW 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: mingw compiler_ref: refs/heads/5.3 timeout: 240 multicoretests-0.7/.github/workflows/mingw-540-trunk-bytecode.yml000066400000000000000000000006011474367232000251570ustar00rootroot00000000000000name: MinGW bytecode trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: mingw compiler_ref: refs/heads/trunk options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/mingw-540-trunk.yml000066400000000000000000000005331474367232000233670ustar00rootroot00000000000000name: MinGW trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: mingw compiler_ref: refs/heads/trunk timeout: 240 multicoretests-0.7/.github/workflows/msvc-530-trunk-bytecode.yml000066400000000000000000000005731474367232000250150ustar00rootroot00000000000000name: MSVC bytecode 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: msvc compiler_ref: refs/heads/5.3 options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/msvc-530-trunk.yml000066400000000000000000000005021474367232000232110ustar00rootroot00000000000000name: MSVC 5.3 on: schedule: # Every Monday morning, at 2:22 UTC - cron: '22 2 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: msvc compiler_ref: refs/heads/5.3 multicoretests-0.7/.github/workflows/msvc-540-trunk-bytecode.yml000066400000000000000000000005771474367232000250220ustar00rootroot00000000000000name: MSVC bytecode trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: msvc compiler_ref: refs/heads/trunk options: bytecode-only timeout: 240 multicoretests-0.7/.github/workflows/msvc-540-trunk.yml000066400000000000000000000005061474367232000232160ustar00rootroot00000000000000name: MSVC trunk on: schedule: # Every Monday morning, at 3:33 UTC - cron: '33 3 * * 1' pull_request: push: branches: - main workflow_dispatch: jobs: build: uses: ./.github/workflows/common.yml with: runs_on: windows-latest platform: msvc compiler_ref: refs/heads/trunk multicoretests-0.7/.github/workflows/opam.yml000066400000000000000000000022061474367232000215320ustar00rootroot00000000000000name: OPAM installation concurrency: group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} cancel-in-progress: true on: pull_request: push: branches: - main workflow_dispatch: jobs: build-and-test: env: QCHECK_MSG_INTERVAL: '60' strategy: matrix: ocaml-compiler: - 4.12.x - 4.13.x - 4.14.x - 5.0.0 - 5.1.0 - 5.2.0 - 5.3.0 - ocaml-variants.5.4.0+trunk runs-on: ubuntu-latest steps: - name: Checkout code uses: actions/checkout@v4 - name: Install OCaml compiler uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - name: Test installation of the OPAM packages run: | opam install --with-test ./qcheck-multicoretests-util.opam ./qcheck-lin.opam ./qcheck-stm.opam - name: Show configuration run: | opam exec -- ocamlc -config opam config list opam exec -- dune printenv opam list --columns=name,installed-version,repository,synopsis-or-target multicoretests-0.7/.gitignore000066400000000000000000000000121474367232000164370ustar00rootroot00000000000000_build *~ multicoretests-0.7/AUTHORS000066400000000000000000000002161474367232000155250ustar00rootroot00000000000000The following people have contributed to multicoretests: Jan Midtgaard Olivier Nicole Nicolas Osborne Naomi Spargo Samuel Hym Charlène Gros multicoretests-0.7/CHANGES.md000066400000000000000000000056231474367232000160560ustar00rootroot00000000000000# Changes ## 0.7 - #509: Change/Fix to use a symmetric barrier to synchronize domains - #511: Introduce extended specs to allow wrapping command sequences - #517: Add `Lin` combinators `seq_small`, `array_small`, and `list_small` ## 0.6 - No changes to the opam-released library packages. Two significant additions to the test suite in the `multicoretests` opam package: - #463: Dynarray tests - #469: Add gc tests ## 0.5 - #492: Also use the new, upstreamed `Gen.exponential` combinator in STM - #491: Require `qcheck.0.23`, simplify show functions by utilizing it, and update expect outputs accordingly - #486: Add `Util.Pp.pp_fun_` printer for generated `QCheck.fun_` functions ## 0.4 - #415: Remove `--verbose` in internal `mutable_set_v5` expect test to avoid a test failure on a slow machine - #443: Add `Lin_domain.stress_test` as a lighter stress test, not requiring an interleaving search. - #462: Add `STM_domain.stress_test_par`, similar to `Lin_domain.stress_test` for STM models. - #472: Switch `arb_cmds` to use an exponential distribution with a mean of 10, avoiding lists of up to 10000 cmds in `STM_sequential` (reported by @nikolaushuber). ## 0.3 - #400: Catch and delay exceptions in `STM`'s `next_state` for a nicer UX - #387: Reduce needless allocations in `Lin`'s sequential consistency search, as part of an `Out_channel` test cleanup - #379: Extend the set of `Util.Pp` pretty-printers and teach them to add break hints similar to `ppx_deriving.show`; teach `to_show` to generate truncated strings when `$MCTUTILS_TRUNCATE` environment variable is set - #368: Switch `STM_domain.agree_prop_par_asym` from using `Semaphore.Binary` to using an `int Atomic.t` which improves the error rate across platforms and backends ## 0.2 - #342: Add two submodules of combinators in `Util`: - `Pp` to pretty-print values back to valid OCaml syntax - `Equal` to test equality of values - #337: Add 3 `Bytes.t` combinators to `Lin`: `bytes`, `bytes_small`, `bytes_small_printable` - #329,340,352: Support `qcheck-lin` and `qcheck-stm` on OCaml 4.12.x, 4.13.x and 4.14.x without the `Domain` and `Effect` modes - #316: Fix `rep_count` in `STM_thread` so that negative and positive tests repeat equally many times - #318: avoid repetitive interleaving searches in `STM_domain` and `STM_thread` - #312: Escape and quote `bytes` printed with `STM`'s `bytes` combinator - #295: ensure `cleanup` is run in the presence of exceptions in - `STM_sequential.agree_prop` and `STM_domain.agree_prop_par` - `Lin_thread.lin_prop` and `Lin_effect.lin_prop` ## 0.1.1 - #263: Cleanup resources after each domain-based `Lin` test - #281: Escape and quote strings printed with `STM`'s `string` combinator ## 0.1 The initial opam release of `qcheck-lin`, `qcheck-stm`, and `qcheck-multicoretests-util`. The `multicoretests` package is not released on opam, as it is of limited use to OCaml developers. multicoretests-0.7/LICENSE000066400000000000000000000025141474367232000154650ustar00rootroot00000000000000BSD 2-Clause License Copyright (c) 2021-2022, Jan Midtgaard, Olivier Nicole, Nicolas Osborne All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. multicoretests-0.7/Makefile000066400000000000000000000001001474367232000161050ustar00rootroot00000000000000all: dune build clean: dune clean rm -f *~ src/*~ issues/*~ multicoretests-0.7/README.md000066400000000000000000001155131474367232000157430ustar00rootroot00000000000000Multicore tests =============== [![OPAM installation](https://github.com/ocaml-multicore/multicoretests/actions/workflows/opam.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/opam.yml) [![Linux 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x.yml) [![macOS-Intel 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-52x.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-52x.yml) [![macOS-ARM64 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-52x.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-52x.yml) [![Linux 5.2.1-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-bytecode.yml) [![Linux 5.2.1-debug](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-debug.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-debug.yml) [![Linux 5.2.1-musl](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-musl.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-musl.yml) [![Linux 32-bit 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-32bit.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-32bit.yml) [![Linux FP 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-fp.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-fp.yml) [![MinGW 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-52x.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-52x.yml) [![MinGW 5.2.1-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-52x-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-52x-bytecode.yml) [![Cygwin 5.2.1](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-52x.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-52x.yml) [![Linux 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk.yml) [![macOS-Intel 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-530-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-530-trunk.yml) [![macOS-ARM64 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-530-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-530-trunk.yml) [![Linux 5.3.0+trunk-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-bytecode.yml) [![Linux 5.3.0+trunk-debug](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-debug.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-debug.yml) [![Linux 5.3.0+trunk-musl](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-musl.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-musl.yml) [![Linux 32-bit 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-32bit.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-32bit.yml) [![Linux FP 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-fp.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-fp.yml) [![MinGW 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-530-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-530-trunk.yml) [![MinGW 5.3.0+trunk-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-530-trunk-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-530-trunk-bytecode.yml) [![Cygwin 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-530-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-530-trunk.yml) [![MSVC 5.3.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-530-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-530-trunk.yml) [![MSVC 5.3.0+trunk-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-530-trunk-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-530-trunk-bytecode.yml) [![Linux 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk.yml) [![macOS-Intel 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-540-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-540-trunk.yml) [![macOS-ARM64 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-540-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-540-trunk.yml) [![Linux 5.4.0+trunk-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-bytecode.yml) [![Linux 5.4.0+trunk-debug](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-debug.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-debug.yml) [![Linux 5.4.0+trunk-musl](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-musl.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-musl.yml) [![Linux 32-bit 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-32bit.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-32bit.yml) [![Linux FP 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-fp.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-fp.yml) [![MinGW 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-540-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-540-trunk.yml) [![MinGW 5.4.0+trunk-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-540-trunk-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-540-trunk-bytecode.yml) [![Cygwin 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-540-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-540-trunk.yml) [![MSVC 5.4.0+trunk](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-540-trunk.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-540-trunk.yml) [![MSVC 5.4.0+trunk-bytecode](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-540-trunk-bytecode.yml/badge.svg)](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-540-trunk-bytecode.yml) Property-based tests of (parts of) the OCaml multicore compiler and run time. This project contains - a randomized test suite of OCaml 5.x, packaged up in `multicoretests.opam` - two reusable testing libraries: - `Lin` packaged up in `qcheck-lin.opam` and - `STM` packaged up in `qcheck-stm.opam` All of the above build on [QCheck](https://github.com/c-cube/qcheck), a black-box, property-based testing library in the style of QuickCheck. The two libraries are [already quite helpful](https://tarides.com/blog/2022-12-22-ocaml-5-multicore-testing-tools) Installation instructions, and running the tests ================================================ The multicore test suite requires OCaml 5.x: ``` opam update opam switch create 5.0.0 ``` Installing the libraries ------------------------ The two testing libraries are available as packages `qcheck-lin` and `qcheck-stm` from the opam repository. The full versions require OCaml 5.x and reduced, non-`Domain` versions are available for OCaml 4.12.x to 4.14.x. They can be installed in the usual way: ``` opam install qcheck-lin opam install qcheck-stm ``` Bleeding edge users can `pin` and install the latest `main` as follows: ``` opam pin -y https://github.com/ocaml-multicore/multicoretests.git#main ``` To use the `Lin` library in parallel mode on a Dune project, add the following dependency to your dune rule: ``` (libraries qcheck-lin.domain) ``` Using the `STM` library in sequential mode requires the dependency `(libraries qcheck-stm.sequential)` and the parallel mode similarly requires the dependency `(libraries qcheck-stm.domain)`. Running the test suite ---------------------- We have not released the test suite on the [opam repository](https://github.com/ocaml/opam-repository) at this point. The test suite can be built and run from a clone of this repository with the following commands: ``` opam install . --deps-only --with-test dune build dune runtest -j1 --no-buffer --display=quiet ``` Individual tests can be run by invoking `dune exec`. For example: ``` $ dune exec src/atomic/stm_tests.exe -- -v random seed: 51501376 generated error fail pass / total time test name [âś“] 1000 0 0 1000 / 1000 0.2s sequential atomic test [âś“] 1000 0 0 1000 / 1000 180.8s parallel atomic test ================================================================================ success (ran 2 tests) ``` See [src/README.md](src/README.md) for an overview of the current PBTs of OCaml 5.x. It is also possible to run the test suite in the CI, by altering [.github/workflows/common.yml](.github/workflows/common.yml) to target a particular compiler PR: ``` COMPILER_REF: 'refs/pull/12345/head' ``` or a particular branch of a particular fork: ``` COMPILER_REPO: 'login/ocaml' COMPILER_REF: 'refs/heads/test-me' ``` Since [ocaml/ocaml#13458](https://github.com/ocaml/ocaml/pull/13458) the test suite can be triggered on an ocaml/ocaml PR (or on a fork of it) by adding the `run-multicoretests` label. A Linearization Tester ====================== The `Lin` module lets a user test an API for *sequential consistency*, i.e., it performs a sequence of random commands in parallel, records the results, and checks whether the observed results can be linearized and reconciled with some sequential execution. The library offers an embedded, combinator DSL to describe signatures succinctly. As an example, the required specification to test (a small part of) the `Hashtbl` module is as follows: ``` ocaml module HashtblSig = struct type t = (char, int) Hashtbl.t let init () = Hashtbl.create ~random:false 42 let cleanup _ = () open Lin let a,b = char_printable,nat_small let api = [ val_ "Hashtbl.add" Hashtbl.add (t @-> a @-> b @-> returning unit); val_ "Hashtbl.remove" Hashtbl.remove (t @-> a @-> returning unit); val_ "Hashtbl.find" Hashtbl.find (t @-> a @-> returning_or_exc b); val_ "Hashtbl.mem" Hashtbl.mem (t @-> a @-> returning bool); val_ "Hashtbl.length" Hashtbl.length (t @-> returning int); ] end module HT = Lin_domain.Make(HashtblSig) ;; QCheck_base_runner.run_tests_main [ HT.lin_test `Domain ~count:1000 ~name:"Lin Hashtbl test"; ] ``` The first line indicates the type of the system under test along with bindings `init` and `cleanup` for setting it up and tearing it down. The `api` then contains a list of type signature descriptions using combinators `unit`, `bool`, `int`, `returning`, `returning_or_exc`, ... in the style of [Ctypes](https://github.com/ocamllabs/ocaml-ctypes). The functor `Lin_domain.Make` expects a description of the tested commands and outputs a module with a QCheck test `lin_test` that performs the linearization test. The QCheck linearization test iterates a number of test instances. Each instance consists of a "sequential prefix" of calls to the above commands, followed by a `spawn` of two parallel `Domain`s that each call a sequence of operations. `Lin` chooses the individual operations and arguments arbitrarily and records their results. The framework then performs a search for a sequential interleaving of the same calls, and succeeds if it finds one. Since `Hashtbl`s are not safe for parallelism, if you run `dune exec doc/example/lin_tests.exe` the output can produce the following output, where each tested command is annotated with its result: ``` Messages for test Lin Hashtbl test: Results incompatible with sequential execution | | .------------------------------------. | | Hashtbl.add t 'a' 0 : () Hashtbl.add t 'a' 0 : () Hashtbl.length t : 1 Hashtbl.length t : 1 ``` In this case, the test tells us that there is no sequential interleaving of these calls which would return `1` from both calls to `Hashtbl.length`. For example, in the following sequential interleaving the last call should return `2`: ``` ocaml Hashtbl.add t 'a' 0;; let res1 = Hashtbl.length t;; Hashtbl.add t 'a' 0;; let res2 = Hashtbl.length t;; ``` See [src/atomic/lin_tests.ml](src/atomic/lin_tests.ml) for another example of testing the `Atomic` module. A Parallel State-Machine Testing Library ======================================== `STM` contains a revision of [qcstm](https://github.com/jmid/qcstm) extended to run parallel state-machine tests akin to [Erlang QuickCheck, Haskell Hedgehog, ScalaCheck, ...](https://github.com/jmid/pbt-frameworks). To do so, the `STM` library also performs a sequence of random operations in parallel and records the results. In contrast to `Lin`, `STM` then checks whether the observed results are linearizable by reconciling them with a sequential execution of a `model` description. The `model` expresses the intended meaning of each tested command. As such, it requires more of the user compared to `Lin`. The corresponding code to describe a `Hashtbl` test using `STM` is given below: ``` ocaml open QCheck open STM (** parallel STM tests of Hashtbl *) module HashtblModel = struct type sut = (char, int) Hashtbl.t type state = (char * int) list type cmd = | Add of char * int | Remove of char | Find of char | Mem of char | Length [@@deriving show { with_path = false }] let init_sut () = Hashtbl.create ~random:false 42 let cleanup (_:sut) = () let arb_cmd (s:state) = let char = if s=[] then Gen.printable else Gen.(oneof [oneofl (List.map fst s); printable]) in let int = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.map2 (fun k v -> Add (k,v)) char int; Gen.map (fun k -> Remove k) char; Gen.map (fun k -> Find k) char; Gen.map (fun k -> Mem k) char; Gen.return Length; ]) let next_state (c:cmd) (s:state) = match c with | Add (k,v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ | Mem _ | Length -> s let run (c:cmd) (h:sut) = match c with | Add (k,v) -> Res (unit, Hashtbl.add h k v) | Remove k -> Res (unit, Hashtbl.remove h k) | Find k -> Res (result int exn, protect (Hashtbl.find h) k) | Mem k -> Res (bool, Hashtbl.mem h k) | Length -> Res (int, Hashtbl.length h) let init_state = [] let precond (_:cmd) (_:state) = true let postcond (c:cmd) (s:state) (res:res) = match c,res with | Add (_,_), Res ((Unit,_),_) | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int,Exn),_),r) -> r = (try Ok (List.assoc k s) with Not_found -> Error Not_found) | Mem k, Res ((Bool,_),r) -> r = List.mem_assoc k s | Length, Res ((Int,_),r) -> r = List.length s | _ -> false end module HT_seq = STM_sequential.Make(HashtblModel) module HT_dom = STM_domain.Make(HashtblModel) ;; QCheck_base_runner.run_tests_main (let count = 200 in [HT_seq.agree_test ~count ~name:"Hashtbl test sequential"; HT_dom.agree_test_par ~count ~name:"Hashtbl test parallel"; ]) ``` Again this requires a type `sut` for the system under test, and bindings `init_sut` and `cleanup` for setting it up and tearing it down. The type `cmd` describes the tested commands. The type `state = (char * int) list` describes with a pure association list the internal state of a `Hashtbl`. The `init_state` represents the empty `Hashtbl` mode and the state transition function `next_state` describes how it changes across each `cmd`. For example, `Add (k,v)` appends the key-value pair onto the association list. `arb_cmd` is a generator of `cmd`s, taking `state` as a parameter. This allows for `state`-dependent `cmd` generation, which we use to increase the chance of producing a `Remove 'c'`, `Find 'c'`, ... following an `Add 'c'`. Internally `arb_cmd` uses QCheck combinators `Gen.return`, `Gen.map`, and `Gen.map2` to generate one of 5 different commands. `run` executes the tested `cmd` over the `sut` and wraps the result up in a result type `res` offered by `STM`. Combinators `unit`, `bool`, `int`, ... allow to annotate the result with the expected type. `postcond` expresses a post-condition by matching the received `res`, for a `cmd` with the corresponding answer from the `model`. For example, this compares the Boolean result `r` from `Hashtbl.mem` with the result from `List.mem_assoc`. Similarly `precond` expresses a pre-condition. The module is phrased as functors: - the functor `STM_sequential.Make` produces a module with a function `agree_test` to test whether the model agrees with the `sut` across a sequential run of an arbitrary command sequence and - the functor `STM_domain.Make` produces a module with a function `agree_test_par` which tests in parallel by `spawn`ing two domains with `Domain` similarly to `Lin` and searches for a sequential interleaving over the model. When running the above with the command `dune exec doc/example/stm_tests.exe` one may obtain the following output: ``` Messages for test Hashtbl test parallel: Results incompatible with linearized model | | .------------------------------------. | | (Add ('e', 5268)) : () (Add ('!', 4)) : () Length : 1 Length : 1 ``` This illustrates how two hashtable `Add` commands may interfere when executed in parallel, leaving only `1` entry in the resulting `Hashtbl` - which is not reconcilable with the declarative model description. The above examples are available from the [doc/example](doc/example) directory. The [doc](doc) directory also contains our 2022 OCaml Workshop paper presenting the project in a bit more detail. Repeatability Efforts ===================== Both `Lin` and `STM` perform randomized property-based testing with QCheck. When rerunning a test to shrink/reduce the test input, QCheck thus starts from the same `Random` seed to limit non-determinism. This is however not suffient for multicore programs where CPU scheduling and garbage collection may hinder reproducibility. `Lin` and `STM` primarily uses test repetition to increase reproducibility and it is sufficient that only a single repetition triggers an issue. Currently repeating a non-deterministic QCheck property can be done in two different ways: - a `repeat`-combinator lets you test a property, e.g., 50 times rather than just 1. (Pro: a failure is found faster, Con: wasted, repetitive testing when there are no failures) - [a `QCheck` PR](https://github.com/c-cube/qcheck/pull/212) extends `Test.make` with a `~retries` parameter causing it to only perform repetition during shrinking. (Pro: each test is cheaper so we can run more, Con: more tests are required to trigger a race) Issues ====== Replacing blocking functions by non-blocking ones caused deadlocks (new, fixed, runtime) ---------------------------------------------------------------------------------------- [A recently merged PR](https://github.com/ocaml/ocaml/pull/13227) replacing blocking functions by unblocking ones caused [a regression in the form of deadlocks in the parallel `Sys` STM test](https://github.com/ocaml/ocaml/issuess/13713). Unboxed `Dynarray` STM tests segfaults (new, fixed, runtime) ------------------------------------------------------------ Early `STM` tests of [the unboxed `Dynarray` PR](https://github.com/ocaml/ocaml/pull/12885) triggered [segfaults caused by mixing flat float arrays with boxed arrays](https://github.com/ocaml/ocaml/pull/12885#discussion_r1568976695). Race condition in backup thread logic (new, fixed, runtime) ----------------------------------------------------------- An assertion error revealed [a race condition between two atomic updates underlying the coordination between a spawned domain and its backup thread](https://github.com/ocaml/ocaml/issues/13677). Marking color problem when adopting orphaned Ephemerons (new, runtime) ---------------------------------------------------------------------- An assertion error during the upstreaming of [a mark-delay improvement](https://github.com/ocaml/ocaml/pull/13580), [revealed a problem](https://github.com/ocaml/ocaml/pull/13580#issuecomment-2478454501) [with the marking color of orphaned Ephemerons]( https://github.com/ocaml-flambda/flambda-backend/pull/3332). Parallel usage of `flush` may trigger `Sys_error` exception (new, runtime) -------------------------------------------------------------------------- The `Out_channel` tests found that [`flush` may raise a `Sys_error` exception when used in parallel with a `close`](https://github.com/ocaml/ocaml/issues/13586). Registered bytecode fragments leading to bytecode crashes (new, fixed, runtime) ------------------------------------------------------------------------------- Both the `Gc` and `Domain.DLS` tests triggered crashes due to bytecode fragments in callbacks [not being properly unregistered](https://github.com/ocaml/ocaml/pull/13549), [fixed in a separate PR](https://github.com/ocaml/ocaml/pull/13553). Out of date `Gc.control` documentation (new, fixed, stdlib) ----------------------------------------------------------- Tests of the `Gc` module revealed that `Gc.control` records contain [constant zero fields ignored by `Gc.set`](https://github.com/ocaml/ocaml/pull/13440) Out of date `Gc.quick_stat` documentation (new, fixed, stdlib) --------------------------------------------------------------- Tests of the `Gc` module revealed that `Gc.quick_stat` did not return [a record with 4 zero fields as documented](https://github.com/ocaml/ocaml/pull/13424) Shared heap assertion failure (known, runtime) ---------------------------------------------- New GC tests offered a simple reproducer for consistently triggering [a shared heap assertion error](https://github.com/ocaml/ocaml/issues/13090) Unsafe GC interaction in `Gc.counters` binding (known, fixed, runtime) ---------------------------------------------------------------------- New GC tests spotted an issue with unsafe root registration in `Gc.counters` in 5.2.0, [already fixed upstream](https://github.com/ocaml/ocaml/pull/13370) Assertion error `s->running` in backup thread termination (new, fixed, runtime) ------------------------------------------------------------------------------- Tests of `In_channel` would trigger an occasional race in a debug assertion, due to a [TOCTOU](https://en.wikipedia.org/wiki/Time-of-check_to_time-of-use) race for [incoming interrupts during backup thread termination](https://github.com/ocaml/ocaml/issues/13386) Parallel `Dynlink` tests under Windows could deadlock or crash (known, fixed, flexdll) -------------------------------------------------------------------------------------- Tests of `Dynlink` on Windows revealed that [the underlying FlexDLL was unsafe for parallel usage](https://github.com/ocaml/ocaml/issues/13046) `Sys.rename` regression under MinGW/MSVC (new, fixed, runtime) -------------------------------------------------------------- Earlier fixes to bring Windows behaviour closer to other platforms introduced [an unfortunate cornercase regression](https://github.com/ocaml/ocaml/pull/13166) if attempting to `Sys.rename` a parent directory to an empty child directory Regression causing a Cygwin configure to fail (new, fixed, configure) --------------------------------------------------------------------- A configure PR accidentally [introduced a regression causing a flexlink test to fail for a Cygwin build](https://github.com/ocaml/ocaml/pull/13009) Crash and hangs on MinGW (new, fixed, runtime) ---------------------------------------------- [We observed crashes and hangs of the `threadomain` test under MinGW](https://github.com/ocaml/ocaml/issues/12230), which turned out to be due to unsafe systhread yielding. Regression on output to closed `Out_channel`s (new, fixed, runtime) ------------------------------------------------------------------- While revising out `Out_channel` tests we discovered [a regression when outputting to a closed `Out_channel`](https://github.com/ocaml/ocaml/issues/12898) Failure to build `dune` with trunk (new, fixed, dune) ----------------------------------------------------- A change to the OCaml compiler's internals revealed that `dune` was [not using `CAML_INTERNALS` according to the OCaml manual](https://github.com/ocaml/dune/pull/9733) Hard abort regression on 'failure to create domains' (new, fixed, runtime) -------------------------------------------------------------------------- The tests found a regression where a failure to create a domain [would trigger an abort rather than an exception](https://github.com/ocaml/ocaml/pull/12855) Assertion failures in `runtime/domain.c` on trunk (new, fixed, runtime) ----------------------------------------------------------------------- A PR merged to `trunk` [reintroduced off-by-one assertion errors in `caml_reset_young_limit`]( https://github.com/ocaml/ocaml/pull/12824) Assertion failure triggered in runtime/memprof.c (new, fixed, runtime) ---------------------------------------------------------------------- The `thread_joingraph` test triggered [an assertion boundary case in `caml_memprof_renew_minor_sample` from `memprof.c`](https://github.com/ocaml/ocaml/pull/12817) Assertion boundary case in `caml_reset_young_limit` (new, fixed, runtime) ------------------------------------------------------------------------- The `thread_joingraph` test triggered [an assertion boundary case in `caml_reset_young_limit` which was too strict](https://github.com/ocaml/ocaml/pull/12742) Assertion race condition in `install_backup_thread` (new, fixed, runtime) ------------------------------------------------------------------------- A repro test case [submitted upstream from `multicoretests` to the ocaml compiler test suite](https://github.com/ocaml/ocaml/pull/11749) and two separate `multicoretests` all [triggered an race condition in `install_backup_thread`](https://github.com/ocaml/ocaml/pull/12707) Float register preservation on ppc64 (new, fixed, codegen) ---------------------------------------------------------- The sequential `Float.Array` `STM` test revealed that a float register was not properly preserved on ppc64, sometimes resulting in [random `float` values appearing](https://github.com/ocaml/ocaml/pull/12546) Signal-based overflow on ppc64 crash (new, fixed, codegen) ---------------------------------------------------------- The sequential `STM` tests of `Array`, `Bytes`, and `Float.Array` would [trigger segfaults on ppc64](https://github.com/ocaml/ocaml/issues/12482) Frame pointer `Effect` crashes (new, fixed, codegen) ---------------------------------------------------- Negative `Lin` `Effect` tests exercising exceptions for unhandled `Effect`s triggered a [crash on a frame pointer switch](https://github.com/ocaml/ocaml/pull/12535) s390x `Effect` crashes (new, fixed, codegen) -------------------------------------------- Negative `Lin` `Effect` tests exercising exceptions for unhandled `Effect`s also triggered [a crash on the newly restored s390x backend](https://github.com/ocaml/ocaml/issues/12486) `Sys.rename` behaves differently on corner cases under MingW (new, fixed, stdlib) --------------------------------------------------------------------------------- Sequential `STM` tests targeting `Sys.rename` found [two corner cases where MingW behaves differently](https://github.com/ocaml/ocaml/issues/12073) `flexdll` contains a race condition in its handling of errors (new, fixed, flexdll) ----------------------------------------------------------------------------------- Parallel `Lin` tests of the `Dynlink` module found [a race condition](https://github.com/ocaml/flexdll/pull/112) in accesses to the global variables storing the last error. `Buffer.add_string` contained a race condition (new, fixed, stdlib) ------------------------------------------------------------------- Parallel `STM` tests of the `Buffer` module found a segfault, leading to the discovery of an [assertion failure](https://github.com/ocaml/ocaml/issues/12103) revealing a race condition in the `add_string` function Parallel `Weak` `Hashset` usage may crash the runtime (new, fixed, runtime) --------------------------------------------------------------------------- Parallel `STM` tests found a combination of `Weak` `Hashset` functions that [may cause the run-time to `abort` or segfault](https://github.com/ocaml/ocaml/issues/11934) `Sys.readdir` on MingW disagrees with Linux behavior (new, fixed, stdlib) ------------------------------------------------------------------------- Sequential `STM` tests of `Sys` showed how `Sys.readdir` of a non-existing directory on MingW Windows [returns an empty `array`, thus disagreeing with the Linux and macOS behavior](https://github.com/ocaml/ocaml/issues/11829) `seek` on a closed `in_channel` may read uninitialized memory (new, fixed, runtime) ----------------------------------------------------------------------------------- A failure of `Lin` `In_channel` tests revealed that `seek` on a closed `in_channel` [may read uninitialized memory](https://github.com/ocaml/ocaml/issues/11878) Parallel usage of `Weak` could produce weird values (new, fixed, runtime) ------------------------------------------------------------------------- Racing `Weak.set` and `Weak.get` [can in some cases produce strange values](https://github.com/ocaml/ocaml/pull/11749) Bytecode interpreter can segfault on unhandled `Effect` (new, fixed, runtime) ----------------------------------------------------------------------------- In seldom cases the tests would [trigger a segfault in the bytecode interpreter when treating an unhandled `Effect`](https://github.com/ocaml/ocaml/issues/11669) `Ephemeron` can fail assert and abort (new, fixed, runtime) ----------------------------------------------------------- In some cases (even sequential) [the `Ephemeron` tests can trigger an assertion failure and abort](https://github.com/ocaml/ocaml/issues/11503). Parallel usage of `Bytes.escaped` is unsafe (new, fixed, stdlib) ---------------------------------------------------------------- The `Bytes` tests triggered a segfault which turned out to be caused by [an unsafe `Bytes.escaped` definition](https://github.com/ocaml/ocaml/issues/11508). Infinite loop in `caml_scan_stack` on ARM64 (known, fixed, runtime) ------------------------------------------------------------------- The tests triggered [an apparent infinite loop on ARM64 while amd64 would complete the tests as expected](https://github.com/ocaml/ocaml/issues/11425). Unsafe `Buffer` module (new, fixed, stdlib) ------------------------------------------- The tests found that the `Buffer` module implementation is [unsafe under parallel usage](https://github.com/ocaml/ocaml/issues/11279) - initially described in [multicoretests#63](https://github.com/ocaml-multicore/multicoretests/pull/63). MacOS segfault (new, fixed, runtime) ------------------------------------ The tests found an issue causing [a segfault on MacOS](https://github.com/ocaml/ocaml/issues/11226). `In_channel` and `Out_channel` unsafety (new, fixed, runtime) ------------------------------------------------------------- The tests found a problem with `In_channel` and `Out_channel` which could trigger segfaults under parallel usage. For details see [issue ocaml-multicore/multicoretests#13](https://github.com/ocaml-multicore/multicoretests/pull/13) and [this ocaml/ocaml#10960 comment](https://github.com/ocaml/ocaml/issues/10960#issuecomment-1087660763). Cornercase issue in `Domainslib` (new, fixed, domainslib) --------------------------------------------------------- The tests found an issue in `Domainslib.parallel_for_reduce` which [would yield the wrong result for empty arrays](https://github.com/ocaml-multicore/domainslib/pull/67). As of [domainslib#100](https://github.com/ocaml-multicore/domainslib/pull/100) the `Domainslib` tests have been moved to the `Domainslib` repo. Specification of `Lockfree.Ws_deque` (new, fixed, lockfree) ----------------------------------------------------------- The initial tests of `ws_deque` just applied the parallelism property `agree_prop_par`. However that is not sufficient, as only the original domain (thread) is allowed to call `push`, `pop`, ..., while a `spawn`ed domain should call only `steal`. A custom, revised property test runs a `cmd` prefix, then `spawn`s a "stealer domain" with `steal`, ... calls, while the original domain performs calls across a broder random selection (`push`, `pop`, ...). As of [lockfree#43](https://github.com/ocaml-multicore/lockfree/pull/43) this test has now been moved to the `lockfree` repo. Here is an example output illustrating how `size` may return `-1` when used in a "stealer domain". The first line in the `Failure` section lists the original domain's commands and the second lists the stealer domains commands (`Steal`,...). The second `Messages` section lists a rough dump of the corresponding return values: `RSteal (Some 73)` is the result of `Steal`, ... Here it is clear that the spawned domain successfully steals 73, and then observes both a `-1` and `0` result from `size` depending on timing. `Size` should therefore not be considered threadsafe (none of the [two](https://www.dre.vanderbilt.edu/~schmidt/PDF/work-stealing-dequeue.pdf) [papers](https://hal.inria.fr/hal-00802885/document) make any such promises though): ``` ocaml $ dune exec src/ws_deque_test.exe random seed: 55610855 generated error fail pass / total time test name [âś—] 318 0 1 317 / 10000 2.4s parallel ws_deque test (w/repeat) --- Failure -------------------------------------------------------------------- Test parallel ws_deque test (w/repeat) failed (8 shrink steps): Seq.prefix: Parallel procs.: [] [(Push 73); Pop; Is_empty; Size] [Steal; Size; Size] +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test parallel ws_deque test (w/repeat): Result observations not explainable by linearized model: Seq.prefix: Parallel procs.: [] [RPush; (RPop None); (RIs_empty true); (RSize 0)] [(RSteal (Some 73)); (RSize -1); (RSize 0)] ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) ``` Segfault in Domainslib (known, fixed, domainslib) ------------------------------------------------- Testing `Domainslib.Task`s with one dependency and with 2 work pools found a [segfault in domainslib](https://github.com/ocaml-multicore/domainslib/issues/58). As of [domainslib#100](https://github.com/ocaml-multicore/domainslib/pull/100) the `domainslib/task_one_dep.ml` test in question has been moved to the `Domainslib` repo. Dead-lock in Domainslib (known, fixed, domainslib) -------------------------------------------------- A reported deadlock in domainslib motivated the development of these tests: - https://github.com/ocaml-multicore/domainslib/issues/47 - https://github.com/ocaml-multicore/ocaml-multicore/issues/670 The tests `domainslib/task_one_dep.ml` and `domainslib/task_more_deps.ml` were run with a timeout to prevent deadlocking indefinitely. `domainslib/task_one_dep.ml` could trigger one such deadlock. As of [domainslib#100](https://github.com/ocaml-multicore/domainslib/pull/100) these tests have been moved to the `Domainslib` repo. The test exhibits no non-determistic behaviour when repeating the same tested property from within the QCheck test. However it fails (due to timeout) on the following test input: ```ocaml $ dune exec -- src/task_one_dep.exe -v random seed: 147821373 generated error fail pass / total time test name [âś—] 25 0 1 24 / 100 36.2s Task.async/await --- Failure -------------------------------------------------------------------- Test Task.async/await failed (2 shrink steps): { num_domains = 3; length = 6; dependencies = [|None; (Some 0); None; (Some 1); None; None|] } ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) ``` This corresponds to the following program with 3+1 domains and 6 promises. It loops infinitely with both bytecode/native: ```ocaml ... open Domainslib (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let work () = for _ = 1 to 200 do assert (7 = tak 18 12 6); done let pool = Task.setup_pool ~num_additional_domains:3 () let p0 = Task.async pool work let p1 = Task.async pool (fun () -> work (); Task.await pool p0) let p2 = Task.async pool work let p3 = Task.async pool (fun () -> work (); Task.await pool p1) let p4 = Task.async pool work let p5 = Task.async pool work let () = List.iter (fun p -> Task.await pool p) [p0;p1;p2;p3;p4;p5] let () = Task.teardown_pool pool ``` --- This project has been created and is maintained by Tarides. multicoretests-0.7/doc/000077500000000000000000000000001474367232000152235ustar00rootroot00000000000000multicoretests-0.7/doc/README.md000066400000000000000000000010061474367232000164770ustar00rootroot00000000000000This directory contains: - [example](example) - the `Lin` and `STM` examples from [../README.md](../README.md) with small tests of the `Hashtbl` module. - [paper.md](paper.md) - a paper presenting the project (in Markdown format) - [paper.pdf](paper.pdf) - the same paper presenting the project (in pdf format) - [paper-latex](paper-latex) - is the LaTeX source code for above - [paper-examples](paper-examples) - the `Lin` and `STM` examples from the paper with (slightly larger) tests of the `Hashtbl` module. multicoretests-0.7/doc/example/000077500000000000000000000000001474367232000166565ustar00rootroot00000000000000multicoretests-0.7/doc/example/dune000066400000000000000000000005201474367232000175310ustar00rootroot00000000000000;; A linearization test of the stdlib Hashtbl library (executable (name lin_tests) (modules lin_tests) (libraries qcheck-lin.domain)) ;; A model-based test of the stdlib Hashtbl library (executable (name stm_tests) (modules stm_tests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show))) multicoretests-0.7/doc/example/dune-project000066400000000000000000000000201474367232000211700ustar00rootroot00000000000000(lang dune 2.9) multicoretests-0.7/doc/example/dune-workspace000066400000000000000000000000001474367232000215160ustar00rootroot00000000000000multicoretests-0.7/doc/example/lin_tests.ml000066400000000000000000000016411474367232000212160ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Hashtbl] *) (* ********************************************************************** *) module HashtblSig = struct type t = (char, int) Hashtbl.t let init () = Hashtbl.create ~random:false 42 let cleanup _ = () open Lin let a,b = char_printable,nat_small let api = [ val_ "Hashtbl.add" Hashtbl.add (t @-> a @-> b @-> returning unit); val_ "Hashtbl.remove" Hashtbl.remove (t @-> a @-> returning unit); val_ "Hashtbl.find" Hashtbl.find (t @-> a @-> returning_or_exc b); val_ "Hashtbl.mem" Hashtbl.mem (t @-> a @-> returning bool); val_ "Hashtbl.length" Hashtbl.length (t @-> returning int); ] end module HT = Lin_domain.Make(HashtblSig) ;; QCheck_base_runner.run_tests_main [ HT.lin_test ~count:1000 ~name:"Lin Hashtbl test"; ] multicoretests-0.7/doc/example/stm_tests.ml000066400000000000000000000037601474367232000212430ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Hashtbl *) module HashtblModel = struct type sut = (char, int) Hashtbl.t type state = (char * int) list type cmd = | Add of char * int | Remove of char | Find of char | Mem of char | Length [@@deriving show { with_path = false }] let init_sut () = Hashtbl.create ~random:false 42 let cleanup (_:sut) = () let arb_cmd (s:state) = let char = if s=[] then Gen.printable else Gen.(oneof [oneofl (List.map fst s); printable]) in let int = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.map2 (fun k v -> Add (k,v)) char int; Gen.map (fun k -> Remove k) char; Gen.map (fun k -> Find k) char; Gen.map (fun k -> Mem k) char; Gen.return Length; ]) let next_state (c:cmd) (s:state) = match c with | Add (k,v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ | Mem _ | Length -> s let run (c:cmd) (h:sut) = match c with | Add (k,v) -> Res (unit, Hashtbl.add h k v) | Remove k -> Res (unit, Hashtbl.remove h k) | Find k -> Res (result int exn, protect (Hashtbl.find h) k) | Mem k -> Res (bool, Hashtbl.mem h k) | Length -> Res (int, Hashtbl.length h) let init_state = [] let precond (_:cmd) (_:state) = true let postcond (c:cmd) (s:state) (res:res) = match c,res with | Add (_,_), Res ((Unit,_),_) | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int,Exn),_),r) -> r = (try Ok (List.assoc k s) with Not_found -> Error Not_found) | Mem k, Res ((Bool,_),r) -> r = List.mem_assoc k s | Length, Res ((Int,_),r) -> r = List.length s | _ -> false end module HT_seq = STM_sequential.Make(HashtblModel) module HT_dom = STM_domain.Make(HashtblModel) ;; QCheck_base_runner.run_tests_main (let count = 200 in [HT_seq.agree_test ~count ~name:"Hashtbl test sequential"; HT_dom.agree_test_par ~count ~name:"Hashtbl test parallel"; ]) multicoretests-0.7/doc/lin/000077500000000000000000000000001474367232000160055ustar00rootroot00000000000000multicoretests-0.7/doc/lin/dune000066400000000000000000000003731474367232000166660ustar00rootroot00000000000000(documentation (package qcheck-lin) (mld_files index)) (executable (name mutable_set) (modules mutable_set) (libraries qcheck-lin.domain)) (executable (name mutable_set_lock) (modules mutable_set_lock) (libraries qcheck-lin.domain)) multicoretests-0.7/doc/lin/index.mld000066400000000000000000000275541474367232000176270ustar00rootroot00000000000000{0 qcheck-lin} {1 Content} - {!module-Lin} is a base module for specifying sequential consistency tests. - {!module-Lin_domain} exposes a functor that allows to test a library under parallel usage (with domains). - {!module-Lin_thread} exposes a functor that allows to test a library under concurrent usage (with threads). - {!module-Lin_effect} exposes a functor that allows to test a library under concurrent usage (with effects). {1 Overview: what is [qcheck-lin]?} [qcheck-lin] is a testing library based on [QCheck] for sequential consistency. A parallel or concurrent program is said to be sequentially consistent if "the result of any execution is the same as if the operations of all the processors were executed in some sequential order, and the operations of each individual processor appear in this sequence in the order specified by its program."{{!section-ref}{^ 1}} According to a library description, [qcheck-lin] generates random programs using the functionalities of this library and runs them, records the results and checks whether the observed results are linearizable by reconciling them with a sequential execution. [qcheck-lin] offers an embedded domain specific language to easily describe signatures succinctly. It provides three types of tests: - a parallel one, generating and running parallel programs with two domains and testing for sequential consistency, - another concurrent one, generating and running parallel programs with two threads and testing for sequential consistency, - a concurrent one using effects, generating and running parallel programs with two fibers and testing for sequential consistency. {1 Example: how to test a library?} Suppose we want to implement a small mutable set library, our main focus being to have a constant time [cardinal] operation. We will be using {!Stdlib.Set} for the content, keeping track of the cardinality when adding and removing elements. Of course, we will be using [qcheck-lin] for testing! Our library reads like that: {[ module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val remove : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int } let empty () = { content = S.empty; cardinal = 0 } let mem a t = S.mem a t.content let add a t = if not (mem a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1 end let remove a t = if mem a t then ( t.content <- S.remove a t.content; t.cardinal <- t.cardinal - 1) let cardinal t = t.cardinal end end ]} {2 Writing a specification} In order to test it for sequential consistency, [qcheck-lin] needs a lightweight specification of our library's interface. This specification takes the form of a module matching the {{!Lin.Spec}[Spec]} signature. Then [qcheck-lin] does all the heavy lifting for us! This specification exposes one type and three values: - type [t] which is the main type of our library, here the mutable set. - [init] that tells [qcheck-lin] how to create an initial value of type [t]. - [cleanup] that tells [qcheck-lin] how to clean up after the tests (which is necessary when [t] uses resources that must be released, such as opened files, network connections, etc.). - [api] which is a list of the library's functions we want to include in the tests. These functions are encoded using a custom embedded domain specific language. {[ open Lin module LibInt = Lib.Make (Int) module Spec : Spec = struct type t = LibInt.t let init = LibInt.empty let cleanup _ = () let api = let int = nat_small in [ val_ "mem" LibInt.mem (int @-> t @-> returning bool); val_ "add" LibInt.add (int @-> t @-> returning unit); val_ "remove" LibInt.remove (int @-> t @-> returning unit); val_ "cardinal" LibInt.cardinal (t @-> returning int); ] end ]} Let's have a closer look at the [api] value. This is where [qcheck-lin] gets the information about the functions we want to include in our tests. [api] is a list of values. These values should be constructed using either the {{!Lin.val_}[val_]} function or the {{!Lin.val_freq}[val_freq]} one. In the example, we use [val_], but let's first describe [val_freq]. [val_freq] takes four arguments: - an [int] that is a weight used by [QCheck] for generation. It allows to skew the distribution of the function in the generated programs. - its name as a [string] so that it can be printed in the output. - the function itself, so that it can be called in the tests. - an encoding of its type which is used to generate arguments to the function. [val_] is a specialization of [val_freq], giving the same weight to all the elements. Note that the domain specific language brings some static guarantees about the type encoding. If we make a mistake, we will know at compile time. {2 Running the tests} Now we are set to run our first [qcheck-lin] tests! We will be testing our library for parallel usage. The functor {!module-Lin_domain.Make} takes the [Spec] as argument and exposes two functions: - {{!Lin_domain.Make.lin_test}[lin_test]} to build a positive [QCheck] test, - {{!Lin_domain.Make.neg_lin_test}[neg_lin_test]} to build a negative [QCheck] test. Here, we expect the test to succeed, so we will use the first one. {[ module LibDomain = Lin_domain.Make (Spec) let _ = QCheck_base_runner.run_tests ~verbose:true [ LibDomain.lin_test ~count:1000 ~name:"Lin parallel tests" ] ]} And the test fails... {[ $ dune exec ./mutable_set.exe random seed: 429006728 generated error fail pass / total time test name [âś—] 1 0 1 0 / 1000 1.9s Lin parallel tests --- Failure -------------------------------------------------------------------- Test Lin parallel tests failed (41 shrink steps): | | .---------------------. | | add 0 t add 0 t cardinal t +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test Lin parallel tests: Results incompatible with sequential execution | | .------------------------------------. | | add 0 t : () add 0 t : () cardinal t : 2 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) ]} In the case of a failing test, [qcheck-lin] prints the counterexample it has found, after some shrinking steps, as is customary in property-based testing {i Ă  la} QuickCheck. The counterexample is a program with a sequential prefix and two parallel suffixes. The counterexample is given twice: the first time with just the function calls; and the second time, each call is paired with its result. Here, the counterexample is composed of an empty sequential prefix and two spawned processes. The first one adds 0 to the set, while the second one also adds 0 to the set and then asks for the cardinality of the said set. In terms of sequential interleaving, there are only three possibilities. If we prefix the function call by [Left] and [Right] depending on the process in which they are, those sequential interleavings are: 1. [Left.add 0 t; Right.add 0 t; Right.cardinal t] 2. [Right.add 0 t; Left.add 0 t; Right.cardinal t] 3. [Right.add 0 t; Right.cardinal t; Left.add 0 t] None of them can explain the value 2 returned by [cardinal t]. What happened is that both calls to [add] have checked whether [0] was already an element of the set at the same time (or at least before the other one had a chance to add it). It was not. So, according to our implementation, both calls added the element and incremented the [cardinal] field. One way to make our library safe for parallel usage is to protect the set with a mutex. {[ module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val remove : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int; mutex : Mutex.t } let empty () = { content = S.empty; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = S.mem a t.content let mem a t = Mutex.lock t.mutex; let b = S.mem a t.content in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then being t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1 end; Mutex.unlock t.mutex let remove a t = Mutex.lock t.mutex; if mem_non_lock a t then begin t.content <- S.remove a t.content; t.cardinal <- t.cardinal - 1 end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let c = t.cardinal in Mutex.unlock t.mutex; c end end ]} Once this is done, we can use exactly the same specification and tests. The successful output looks like the following: {[ $ dune exec ./mutable_set_lock.exe random seed: 162610433 generated error fail pass / total time test name [âś“] 1000 0 0 1000 / 1000 48.0s Lin parallel tests ================================================================================ success (ran 1 tests) ]} {1 [Lin] in a bit more detail} Underneath the hood [Lin] uses QCheck and OCaml's pseudo-random number generator from the [Random] module to generate arbitrary [cmd] sequences and arbitrary input argument data to each call. To recreate a problematic test run, one therefore needs to generate the same pseudo-random test case input, by passing the same randomness seed. By running the [Lin] tests using [QCheck_base_runner.run_tests_main] from QCheck, it is possible to pass a seed as a command line argument as follows: {[ $ dune exec ./mutable_set.exe -- -s 429006728 ]} Despite generating and thus running the same test case input, one may still experience different behaviours on subsequent reruns of the resulting test, because of CPU scheduling and other factors. This may materialize as different counterexamples being printed or as one run failing the test whereas another run passes it. {!Lin_domain} uses the {!Util.repeat} combinator to repeat each test case 50 times to address the issue and help increase reproducibility. {1 Current limitations} [Lin] comes with a number of limitations which we plan to address in future releases. Currently {{!Lin.Spec.api}[Spec.api]} descriptions: - support only one {{!Lin.Spec.t}[Spec.t]} - namely the one resulting from {{!Lin.Spec.init}[Spec.init]}, - do not support composing {{!Lin.Spec.t}[Spec.t]} with other type combinators such as {!Lin.list} and {!Lin.option} - this restriction is expressed with the {!Lin.noncombinable} type parameter in {!Lin.t}, - do not support using the result of {!Lin.int_bound} as both an argument type and as a result type - you can use {!Lin.int} for the latter, - do not support specifying function values using arrow syntax [t1 @-> t2], - do not support specifying tuple values using product syntax [t1 * t2]. The later two can however be addressed by writing a custom argument generator using {!Lin.gen}. {1:ref References} 1. Lamport, {i How to Make a Multiprocessor Computer That Correctly Executes Multiprocess Program}, 1979, DOI: 10.1109/TC.1979.1675439 multicoretests-0.7/doc/lin/mutable_set.ml000066400000000000000000000027211474367232000206450ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val remove : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int } let empty () = { content = S.empty; cardinal = 0 } let mem a t = S.mem a t.content let add a t = if not (mem a t) then ( t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1) let remove a t = if mem a t then ( t.content <- S.remove a t.content; t.cardinal <- t.cardinal - 1) let cardinal t = t.cardinal end end open Lin module LibInt = Lib.Make (Int) module Spec : Spec = struct type t = LibInt.t let init = LibInt.empty let cleanup _ = () let api = let int = nat_small in [ val_ "mem" LibInt.mem (int @-> t @-> returning bool); val_ "add" LibInt.add (int @-> t @-> returning unit); val_ "remove" LibInt.remove (int @-> t @-> returning unit); val_ "cardinal" LibInt.cardinal (t @-> returning int); ] end module LibDomain = Lin_domain.Make (Spec) let _ = QCheck_base_runner.run_tests ~verbose:true [ LibDomain.lin_test ~count:1000 ~name:"Lin parallel tests" ] multicoretests-0.7/doc/lin/mutable_set_lock.ml000066400000000000000000000035361474367232000216620ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val remove : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int; mutex : Mutex.t } let empty () = { content = S.empty; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = S.mem a t.content let mem a t = Mutex.lock t.mutex; let b = S.mem a t.content in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1 end; Mutex.unlock t.mutex let remove a t = Mutex.lock t.mutex; if mem_non_lock a t then begin t.content <- S.remove a t.content; t.cardinal <- t.cardinal - 1 end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let c = t.cardinal in Mutex.unlock t.mutex; c end end open Lin module LibInt = Lib.Make (Int) module Spec : Spec = struct type t = LibInt.t let init = LibInt.empty let cleanup _ = () let api = let int = nat_small in [ val_ "mem" LibInt.mem (int @-> t @-> returning bool); val_ "add" LibInt.add (int @-> t @-> returning unit); val_ "remove" LibInt.remove (int @-> t @-> returning unit); val_ "cardinal" LibInt.cardinal (t @-> returning int); ] end module LibDomain = Lin_domain.Make (Spec) let _ = QCheck_base_runner.run_tests ~verbose:true [ LibDomain.lin_test ~count:1000 ~name:"Lin parallel tests" ] multicoretests-0.7/doc/paper-examples/000077500000000000000000000000001474367232000201465ustar00rootroot00000000000000multicoretests-0.7/doc/paper-examples/dune000066400000000000000000000005201474367232000210210ustar00rootroot00000000000000;; A linearization test of the stdlib Hashtbl library (executable (name lin_tests) (modules lin_tests) (libraries qcheck-lin.domain)) ;; A model-based test of the stdlib Hashtbl library (executable (name stm_tests) (modules stm_tests) (libraries qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show))) multicoretests-0.7/doc/paper-examples/dune-project000066400000000000000000000000201474367232000224600ustar00rootroot00000000000000(lang dune 2.9) multicoretests-0.7/doc/paper-examples/dune-workspace000066400000000000000000000000001474367232000230060ustar00rootroot00000000000000multicoretests-0.7/doc/paper-examples/lin_tests.ml000066400000000000000000000021241474367232000225030ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Hashtbl] *) (* ********************************************************************** *) module HashtblSig = struct type t = (char, int) Hashtbl.t let init () = Hashtbl.create ~random:false 42 let cleanup _ = () open Lin let a,b = char_printable,nat_small let api = [ val_ "Hashtbl.clear" Hashtbl.clear (t @-> returning unit); val_ "Hashtbl.add" Hashtbl.add (t @-> a @-> b @-> returning unit); val_ "Hashtbl.remove" Hashtbl.remove (t @-> a @-> returning unit); val_ "Hashtbl.find" Hashtbl.find (t @-> a @-> returning_or_exc b); val_ "Hashtbl.replace" Hashtbl.replace (t @-> a @-> b @-> returning unit); val_ "Hashtbl.mem" Hashtbl.mem (t @-> a @-> returning bool); val_ "Hashtbl.length" Hashtbl.length (t @-> returning int); ] end module HT = Lin_domain.Make(HashtblSig) ;; QCheck_base_runner.run_tests_main [ HT.lin_test ~count:1000 ~name:"Lin Hashtbl test"; ] multicoretests-0.7/doc/paper-examples/stm_tests.ml000066400000000000000000000047141474367232000225330ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Hashtbl *) module HashtblModel = struct type sut = (char, int) Hashtbl.t type state = (char * int) list type cmd = | Clear | Add of char * int | Remove of char | Find of char | Replace of char * int | Mem of char | Length [@@deriving show { with_path = false }] let init_sut () = Hashtbl.create ~random:false 42 let cleanup (_:sut) = () let arb_cmd (s:state) = let char = if s=[] then Gen.printable else Gen.(oneof [oneofl (List.map fst s); printable]) in let int = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Clear; Gen.map2 (fun k v -> Add (k,v)) char int; Gen.map (fun k -> Remove k) char; Gen.map (fun k -> Find k) char; Gen.map2 (fun k v -> Replace (k,v)) char int; Gen.map (fun k -> Mem k) char; Gen.return Length; ]) let next_state (c:cmd) (s:state) = match c with | Clear -> [] | Add (k,v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ -> s | Replace (k,v) -> (k,v)::(List.remove_assoc k s) | Mem _ | Length -> s let run (c:cmd) (h:sut) = match c with | Clear -> Res (unit, Hashtbl.clear h) | Add (k,v) -> Res (unit, Hashtbl.add h k v) | Remove k -> Res (unit, Hashtbl.remove h k) | Find k -> Res (result int exn, protect (Hashtbl.find h) k) | Replace (k,v) -> Res (unit, Hashtbl.replace h k v) | Mem k -> Res (bool, Hashtbl.mem h k) | Length -> Res (int, Hashtbl.length h) let init_state = [] let precond (_:cmd) (_:state) = true let postcond (c:cmd) (s:state) (res:res) = match c,res with | Clear, Res ((Unit,_),_) | Add (_,_), Res ((Unit,_),_) | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int,Exn),_),r) -> r = (try Ok (List.assoc k s) with Not_found -> Error Not_found) | Replace (_,_), Res ((Unit,_),_) -> true | Mem k, Res ((Bool,_),r) -> r = List.mem_assoc k s | Length, Res ((Int,_),r) -> r = List.length s | _ -> false end module HT_seq = STM_sequential.Make(HashtblModel) module HT_dom = STM_domain.Make(HashtblModel) ;; QCheck_base_runner.run_tests_main (let count = 200 in [HT_seq.agree_test ~count ~name:"Hashtbl test sequential"; HT_dom.agree_test_par ~count ~name:"Hashtbl test parallel"; ]) multicoretests-0.7/doc/paper-latex/000077500000000000000000000000001474367232000174455ustar00rootroot00000000000000multicoretests-0.7/doc/paper-latex/.latexmkrc000066400000000000000000000001721474367232000214400ustar00rootroot00000000000000# Use lualatex, generate PDF #$pdf_mode = 4; # Use xelatex, generate PDF $pdf_mode = 5; $postscript_mode = $dvi_mode = 0; multicoretests-0.7/doc/paper-latex/README.md000066400000000000000000000001541474367232000207240ustar00rootroot00000000000000To compile (requires fonts Libertinus and Fira Mono installed as OpenType fonts): ``` latexmk paper.tex ``` multicoretests-0.7/doc/paper-latex/biblio.bib000066400000000000000000000142321474367232000213650ustar00rootroot00000000000000 @online{AddFailingOut2022, title = {Add (Failing) \{\vphantom\}{{In}},{{Out}}\vphantom\{\}\_channel Linearization Tests}, OPTdate = {2022-03-10}, url = {https://github.com/jmid/multicoretests/pull/13}, OPTorganization = {{Multicoretests Github repository}} } @online{Articheck, title = {Articheck}, url = {https://github.com/braibant/articheck} } @inproceedings{artsTestingTelecomsSoftware2006, title = {Testing Telecoms Software with Quviq {{QuickCheck}}}, booktitle = {Proceedings of the 2006 {{ACM SIGPLAN Workshop}} on {{Erlang}} ({{Erlang}} 2006)}, author = {Arts, Thomas and Hughes, John and Johansson, Joakim and Wiger, Ulf T.}, date = {2006}, pages = {2--10}, } @online{AuditStdlibMutable2022, title = {Audit Stdlib for Mutable State (Comment)}, OPTdate = {2022-04-04}, url = {https://github.com/ocaml/ocaml/issues/10960#issuecomment-1087660763}, OPTorganization = {{OCaml Github repository}} } @inproceedings{braibantWelltypedSmartFuzzing2014, title = {Well-Typed Generic Smart Fuzzing for APIs}, author = {Braibant, Thomas and Protzenko, Jonathan and Scherer, Gabriel}, date = {2014}, url = {https://hal.inria.fr/hal-01094006}, eventtitle = {{{ML Familiy Workshop}} ({{ML}} 2014)} } @inproceedings{claessenFindingRaceConditions2009, title = {Finding {{Race Conditions}} in {{Erlang}} with {{QuickCheck}} and {{PULSE}}}, booktitle = {Proceeding of the 14th {{ACM SIGPLAN}} International Conference on {{Functional}} Programming ({{ICFP}} 2009)}, author = {Claessen, Koen and PaĹ‚ka, MichaĹ‚ and Smallbone, Nicholas and Hughes, John and Svensson, Hans and Arts, Thomas and Wiger, Ulf}, date = {2009}, pages = {12}, } @inproceedings{claessenQuickCheckLightweightTool2000, title = {{{QuickCheck}}: A Lightweight Tool for Random Testing of {{Haskell}} Programs}, shorttitle = {{{QuickCheck}}}, booktitle = {Proceedings of the {{Fifth ACM SIGPLAN International Conference}} on {{Functional Programming}} ({{ICFP}} 2000)}, author = {Claessen, Koen and Hughes, John}, date = {2000}, pages = {268--279}, } @inproceedings{claessenTestingMonadicCode2002, title = {Testing Monadic Code with {{QuickCheck}}}, booktitle = {Proceedings of the 2002 {{ACM SIGPLAN Workshop}} on {{Haskell}} ({{Haskell}} 2002)}, author = {Claessen, Koen and Hughes, John}, date = {2002}, pages = {65--77}, } @online{Crowbar, title = {Crowbar}, url = {https://github.com/stedolan/crowbar} } @online{Ctypes, title = {Ctypes}, url = {https://github.com/ocamllabs/ocaml-ctypes} } @article{YALLOP201882, title = {A modular foreign function interface}, author = {Jeremy Yallop and David Sheets and Anil Madhavapeddy}, journal = {Science of Computer Programming}, volume = {164}, pages = {82-97}, year = {2018}, url = {https://www.sciencedirect.com/science/article/pii/S0167642317300709}, } @inproceedings{dolanTestingCrowbar2017, title = {Testing with {{Crowbar}}}, author = {Dolan, Stephen and Preston, Mindy}, date = {2017}, eventtitle = {{OCaml Users and Developers Workshop}}, } @online{Hedgehog, title = {Hedgehog}, url = {https://github.com/hedgehogqa/haskell-hedgehog} } @inproceedings{koopmanTestingReactiveSystems2003, title = {Testing Reactive Systems with {{GAST}}}, booktitle = {Revised {{Selected Papers}} from the {{Fourth Symposium}} on {{Trends}} in {{Functional Programming}} ({{TFP}} 2003)}, author = {Koopman, Pieter W. M. and Plasmeijer, Rinus}, date = {2003}, series = {Trends in {{Functional Programming}}}, volume = {4}, pages = {111--129}, } @online{ParallelAccessBuffer2022, title = {Parallel Access to {{Buffer}} Can Trigger Segfaults}, OPTdate = {2022-05-26}, url = {https://github.com/ocaml/ocaml/issues/11279}, OPTorganization = {{OCaml Github repository}} } @inproceedings{pottierStrongAutomatedTesting2021, title = {Strong {{Automated Testing}} of {{OCaml Libraries}}}, author = {Pottier, François}, date = {2021-02}, eventtitle = {JournĂ©es {{Francophones}} Des {{Langages Applicatifs}} ({{JFLA}} 2021)}, langid = {english}, } @online{PropCheck, title = {{{propCheck}}}, url = {https://github.com/1Jajen1/propCheck} } @online{Proper, title = {Proper}, url = {https://github.com/proper-testing/proper} } @InProceedings{PropErTypes@Erlang-11, author = "Manolis Papadakis and Konstantinos Sagonas", title = "A {PropEr} Integration of Types and Function Specifications with Property-Based Testing", pages = "39--50", booktitle = "Proceedings of the 2011 ACM SIGPLAN Erlang Workshop", year = "2011", } @online{QCheck, title = {{{QCheck}}}, url = {https://github.com/c-cube/qcheck} } @online{Qcstm, title = {qcstm}, url = {https://github.com/jmid/qcstm} } @InProceedings{Midtgaard:OCaml20, author = "Jan Midtgaard", title = "A Simple State-Machine Framework for Property-Based Testing in {OCaml}", year = 2020, booktitle = {{OCaml Users and Developers Workshop}}, } @online{QuviqQuickCheck, title = {Quviq {{QuickCheck}}}, url = {http://quviq.com/documentation/eqc/index.html} } @online{ScalaCheck, title = {{{ScalaCheck}}}, url = {https://github.com/typelevel/scalacheck} } @online{SegfaultMacOSXTrunk2022, title = {Segfault on {{MacOSX}} with Trunk}, OPTdate = {2022-04-29}, url = {https://github.com/ocaml/ocaml/issues/11226}, OPTorganization = {{OCaml Github repository}} } @online{STMCleanup2022, title = {{{STM}} Clean-Up}, OPTdate = {2022-05-10}, url = {https://github.com/jmid/multicoretests/pull/63}, OPTorganization = {{Multicoretests Github repository}} } @inproceedings{osborne:hal-03328646, TITLE = {{Leveraging Formal Specifications to Generate Fuzzing Suites}}, AUTHOR = {Osborne, Nicolas and Pascutto, Cl{\'e}ment}, URL = {https://hal.inria.fr/hal-03328646}, BOOKTITLE = {{OCaml Users and Developers Workshop}}, YEAR = {2021}, PDF = {https://hal.inria.fr/hal-03328646/file/OCaml_2021.pdf}, HAL_ID = {hal-03328646}, HAL_VERSION = {v1}, } @inproceedings{padhiyarParafuzzCoverageguidedProperty2021, title = {Parafuzz: {{Coverage-guided Property Fuzzing}} for {{Multicore OCaml}} Programs}, author = {Padhiyar, Sumit and Kamath, Adharsh and Sivaramakrishnan, KC}, date = {2021}, eventtitle = {{OCaml Users and Developers Workshop}}, } multicoretests-0.7/doc/paper-latex/macros.tex000066400000000000000000000001251474367232000214510ustar00rootroot00000000000000 \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} multicoretests-0.7/doc/paper-latex/paper.tex000066400000000000000000000404161474367232000213030ustar00rootroot00000000000000\documentclass[twocolumn,10pt]{article} \title{Multicoretests -- Parallel Testing Libraries for OCaml~5.0} \author{Jan~Midtgaard \and Olivier~Nicole \and Nicolas~Osborne} \date{Tarides} % Yes, I'm abusing this field \input{preamble} \input{macros} \begin{document} \maketitle \section{Introduction} Parallel and concurrent code is notoriously hard to test because of the involved non-determinism, yet it is facing OCaml programmers with the coming OCaml~5.0 multicore release. We present two related testing libraries to improve upon the situation: \begin{itemize} \tightlist \item \texttt{Lin} -- a library to test for sequential consistency \item \texttt{STM} -- a state-machine testing library \end{itemize} Both libraries build on QCheck~\cite{QCheck}, a black-box, property-based testing library in the style of QuickCheck~\cite{claessenQuickCheckLightweightTool2000}. The two libraries represent different trade-offs between required user effort and provided guarantees and thereby supplement each other. In this document we will use OCaml's \texttt{Hashtbl} module as a running example. \section{The \texttt{Lin} library} The \texttt{Lin} library performs a sequence of random operations in parallel, records the results, and checks whether the observed results are linearizable by reconciling them with a sequential execution. % The library offers an embedded, combinator DSL to describe signatures succinctly. As an example, the required specification to test (parts of) the \texttt{Hashtbl} module is given in \cref{code:lin}. \begin{figure*}[htb!] \begin{lstlisting} module HashtblSig = struct type t = (char, int) Hashtbl.t let init () = Hashtbl.create ~random:false 42 let cleanup _ = () open Lin let a,b = char_printable,nat_small let api = [ val_ "Hashtbl.clear" Hashtbl.clear (t @-> returning unit); val_ "Hashtbl.add" Hashtbl.add (t @-> a @-> b @-> returning unit); val_ "Hashtbl.remove" Hashtbl.remove (t @-> a @-> returning unit); val_ "Hashtbl.find" Hashtbl.find (t @-> a @-> returning_or_exc b); val_ "Hashtbl.replace" Hashtbl.replace (t @-> a @-> b @-> returning unit); val_ "Hashtbl.mem" Hashtbl.mem (t @-> a @-> returning bool); val_ "Hashtbl.length" Hashtbl.length (t @-> returning int); ] end \end{lstlisting}% \vspace{-5mm} \caption{Specification of selected \texttt{Hashtbl} functions for testing using \texttt{Lin}.}\label{code:lin} \vspace{-.7em}% \end{figure*} The first line indicates the type of the system under test (SUT). In the above case we intend to test \texttt{Hashtbl}s with \texttt{char} keys and \texttt{int} values. The bindings \texttt{init} and \texttt{cleanup} allow for setting up and tearing down the SUT. The \texttt{api} then contains a list of type signature descriptions using combinators in the style of Ctypes~\cite{YALLOP201882}. Different combinators \texttt{unit}, \texttt{bool}, \texttt{int}, \texttt{list}, \texttt{option}, \texttt{returning}, \lstinline|returning_or_exc|, \dots\@ allow for a concise type signature description. From the signature description the \texttt{Lin} library will iterate a number of test instances. Each test instance consists of a ``sequential prefix'' of calls to the specified operations, followed by a \texttt{spawn} of two parallel \texttt{Domain}s that each call a sequence of operations. For each test instance \texttt{Lin} chooses the individual operations arbitrarily and records the result received from each operation. The framework will then perform a search for a sequential interleaving of the same calls, and succeed if it finds one. Since \texttt{Hashtbl}s are not safe for parallelism, the output produces the following: \begingroup\lstset{language={},basicstyle=\ttfamily\small} \begin{lstlisting} Results incompatible with sequential execution | Hashtbl.add t '@' 4 : () | .-------------------------. | | Hashtbl.add t '.' 3 : () Hashtbl.clear t : () Hashtbl.length t : 2 \end{lstlisting} \endgroup This describes that in one parallel execution, \texttt{Lin} received the response \texttt{2} from \texttt{Hashtbl.length}, despite having just executed \texttt{Hashtbl.clear}. It this case, it is not possible to interleave \texttt{Hashtbl.add t '.' 3} with these two calls to explain this observed behaviour. Underneath the hood, \texttt{Lin} does its best to schedule the two parallel \texttt{Domain}s on top of each other. It also repeats each test instance, to increase the chance of triggering an error, and it fails if just one of the repetitions fail to find a sequential interleaving. Finally, upon finding an error it reduces the involved operation sequences to a local minimum, which is what is printed above. \texttt{Lin} is phrased as an OCaml functor, \lstinline|Lin_domain.Make|. The module resulting from \lstinline|Lin_domain.Make(HashtblSig)| contains a binding \lstinline|lin_test| that can perform the above linearization test over \texttt{Domain}s, the basic unit of parallelism coming in OCaml 5.0. An alternative \texttt{Lin} mode works over \texttt{Thread} for testing concurrent but non-overlapping executions. This mode thus mimicks the above functionality by replacing \texttt{Domain.spawn} and \texttt{Domain.join} with \texttt{Thread.create} and \texttt{Thread.join}, respectively. \section{The \texttt{STM} library} Like \texttt{Lin} the \texttt{STM} library also performs a sequence of random operations in parallel and records the results. In contrast to \texttt{Lin}, \texttt{STM} then checks whether the observed results are linearizable by reconciling them with a sequential execution of a \texttt{model} description. The \texttt{model} expresses the intended meaning of each tested operation. As such, the required \texttt{STM} user input is longer compared to that of \texttt{Lin}. The corresponding code to describe a \texttt{Hashtbl} test using \texttt{STM} is given in \cref{code:stm}. \begin{figure*}[t] %\vspace{-10mm} \hspace*{-5mm} \hfil \small \begin{minipage}[t]{.46\textwidth} \begin{lstlisting} module HashtblModel = struct type sut = (char, int) Hashtbl.t type state = (char * int) list type cmd = | Clear | Add of char * int | Remove of char | Find of char | Replace of char * int | Mem of char | Length [@@deriving show { with_path = false }] let init_sut () = Hashtbl.create ~random:false 42 let cleanup (_:sut) = () let arb_cmd (s:state) = let char = if s = [] then Gen.printable else Gen.(oneof [oneofl (List.map fst s); printable]) in let int = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Clear; Gen.map2 (fun k v -> Add (k,v)) char int; Gen.map (fun k -> Remove k) char; Gen.map (fun k -> Find k) char; Gen.map2 (fun k v -> Replace (k,v)) char int; Gen.map (fun k -> Mem k) char; Gen.return Length; ]) \end{lstlisting} \end{minipage} \hfil \begin{minipage}[t]{.49\textwidth} \begin{lstlisting} let next_state (c:cmd) (s:state) = match c with | Clear -> [] | Add (k,v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ -> s | Replace (k,v) -> (k,v)::(List.remove_assoc k s) | Mem _ | Length -> s let run (c:cmd) (h:sut) = match c with | Clear -> Res (unit, Hashtbl.clear h) | Add (k,v) -> Res (unit, Hashtbl.add h k v) | Remove k -> Res (unit, Hashtbl.remove h k) | Find k -> Res (result int exn, protect (Hashtbl.find h) k) | Replace (k,v) -> Res (unit, Hashtbl.replace h k v) | Mem k -> Res (bool, Hashtbl.mem h k) | Length -> Res (int, Hashtbl.length h) let init_state = [] let precond (_:cmd) (_:state) = true let postcond (c:cmd) (s:state) (res:res) = match c,res with | Clear, Res ((Unit,_),_) | Add (_,_), Res ((Unit,_),_) | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int,Exn),_),r) -> r = (try Ok (List.assoc k s) with Not_found -> Error Not_found) | Replace (_,_), Res ((Unit,_),_) -> true | Mem k, Res ((Bool,_),r) -> r = List.mem_assoc k s | Length, Res ((Int,_),r) -> r = List.length s | _ -> false end \end{lstlisting} \end{minipage} \hfil% \vspace{-3mm} \caption{Description of a \texttt{Hashtbl} test using \texttt{STM}.}% \label{code:stm} \vspace{-1.25em}% \end{figure*} Again this requires a description of the system under test, \texttt{sut}. In addition \texttt{STM} requires a type \texttt{cmd} for describing the tested operations. The hooks \lstinline|init_sut| and \texttt{cleanup} match \texttt{init} and \texttt{cleanup} from \texttt{Lin}, respectively. A distinguishing feature is \texttt{type state = (char * int) list} describing with a pure association list the internal state of a hashtable. \lstinline|next_state| is a simple state transition function describing how the \texttt{state} changes across each \texttt{cmd}. For example, \texttt{Add (k,v)} appends the key-value pair onto the association list. \lstinline|arb_cmd| is a generator of \texttt{cmd}s, taking \texttt{state} as a parameter. This allows for \texttt{state}-dependent \texttt{cmd} generation, which we use to increase the chance of producing a \texttt{Remove 'c'}, \texttt{Find 'c'}, \dots\@ following an \texttt{Add 'c'}. Internally \lstinline|arb_cmd| uses combinators \texttt{Gen.return}, \texttt{Gen.map}, and \texttt{Gen.map2} from QCheck to generate one of 7 different operations. For example, \texttt{Gen.map (fun k -> Mem k) char} creates a \texttt{Mem} command with the result obtained from the \texttt{char} generator. \lstinline|arb_cmd| further uses a derived printer \lstinline|show_cmd| to be able to print counterexamples. \texttt{run} executes the tested \texttt{cmd} over the SUT and wraps the result up in a result type \texttt{res} offered by \texttt{STM}. Combinators \texttt{unit}, \texttt{bool}, \texttt{int}, \dots~allow to annotate the result with the expected type. \texttt{postcond} then expresses a post-condition by matching the received \texttt{res}, for a given \texttt{cmd} with the corresponding answer from the \texttt{model} description. For example, this compares the Boolean result \texttt{r} from \texttt{Hashtbl.mem} with the result from \lstinline|List.mem_assoc|. Similarly \texttt{precond} expresses a \texttt{cmd} pre-condition. \texttt{STM} is also phrased as an OCaml functor. The module resulting from \texttt{STM\_domain.Make(HashtblModel)} thus includes a binding \lstinline|agree_test| for running sequential tests comparing the SUT behaviour to the given model. Another binding \lstinline|agree_test_par| instead runs parallel tests that make a similar comparison over a sequential prefix and two parallel \texttt{Domain}s, this time also searching for a sequential interleaving of \texttt{cmd}s. For example, one execution of \lstinline|agree_test_par| produced the following output. Note how no interleaving of \texttt{Remove} from the first parallel \texttt{cmd} sequence can make the association list model return \lstinline|-1| from \texttt{Length}: \begingroup\lstset{language={}} \begin{lstlisting} Results incompatible with linearized model | (Add ('1', 5)) : () | .-----------------------. | | (Remove '1') : () Clear : () Length : -1 \end{lstlisting} \endgroup \vspace{-1.6em} \section{Status} Both libraries are open source and available for download on GitHub from \url{https://github.com/jmid/multicoretests}. As the APIs are still unstable and under development, we have not made a public release yet. Interested users can nevertheless easily install the libraries with \texttt{opam}. During development we have used examples such as \texttt{Hashtbl} to confirm that the approach indeed works as intended. The behaviour is continuously confirmed by running GitHub Actions of the latest trunk compiler. As further testament to the usability of the approach, we have used the libraries to test parts of OCaml's \texttt{Stdlib}, as well as the \texttt{Domainslib} and \texttt{lockfree} libraries. In doing so, we have been able to find and report a number of issues which have either already been fixed or have fixes underway: \begin{itemize} \tightlist \item \lstinline|In_channel| and \lstinline|Out_channel| unsafety~\cite{AddFailingOut2022,AuditStdlibMutable2022} \item MacOSX crash~\cite{SegfaultMacOSXTrunk2022} \item \texttt{Buffer} unsafety~\cite{STMCleanup2022,ParallelAccessBuffer2022} \end{itemize} \vspace{-.8em} \section{Related Work} QuickCheck~\cite{claessenQuickCheckLightweightTool2000} originally introduced property-based testing within functional programming with combinator-based generators, properties, and test-case reduction. It has since been ported to over 30 other programming languages, including Quviq QuickCheck~\cite{QuviqQuickCheck}---a commercial port to Erlang. Model-based testing was initially suggested as a method for testing monadic code with Haskell's QuickCheck~\cite{claessenTestingMonadicCode2002}. An explicit framework was later proposed in the GAST property-based testing library for Clean~\cite{koopmanTestingReactiveSystems2003}. The commercial Quviq QuickCheck~\cite{QuviqQuickCheck} was later extended with a state-machine model framework for testing stateful systems~\cite{artsTestingTelecomsSoftware2006}. This approach was extended further to test parallel code for data races~\cite{claessenFindingRaceConditions2009}. This general approach for parallel testing has since been adopted in other ports, such as Erlang's open source Proper~\cite{PropErTypes@Erlang-11}, Haskell Hedgehog~\cite{Hedgehog}, ScalaCheck~\cite{ScalaCheck}, and Kotlin's propCheck~\cite{PropCheck}. \texttt{STM} continues this adoption tradition. qcstm~\cite{Midtgaard:OCaml20} is a previous OCaml adoption, also building on QCheck. It was missing the ability to perform parallel testing though. \texttt{STM} seeks to remedy this limitation. Crowbar~\cite{dolanTestingCrowbar2017} is another QuickCheck-style testing framework with combinator-based generators. In contrast to QuickCheck, it utilizes AFL-based coverage guidance to effectively guide the generated input towards unvisited parts of the SUT. Crowbar does not come with a state-machine framework. Monolith~\cite{pottierStrongAutomatedTesting2021} is a model-based testing framework also building on AFL-based coverage guidance. In contrast to \texttt{STM}, Monolith's models are oracle implementations with operations matching the type signatures of the tested operations. Neither Crowbar nor Monolith come with skeletons to perform parallel or concurrent testing. Furthermore the AFL-based coverage-guidance underlying both Crowbar and Monolith works best for deterministic, sequential code. ParaFuzz~\cite{padhiyarParafuzzCoverageguidedProperty2021} is another approach to fuzz test multicore OCaml programs. It simulates parallelism in OCaml through concurrency, enabling scheduling order to be controlled by AFL, which helps to trigger and find scheduling-dependent bugs. A caveat is that ParaFuzz assumes data race freedom. Ortac can extract Monolith-based tests from a formal specification written in Gospel, a specification language for OCaml~\cite{osborne:hal-03328646}. Gospel specifications include models, pre-conditions, and post-conditions close to those of \texttt{STM}. The extracted tests however inherit Monolith's and AFL's focus on sequential code. ArtiCheck~\cite{braibantWelltypedSmartFuzzing2014} tests random combinations of OCaml calls from type signature descriptions, similarly to \texttt{Lin}. Whereas \texttt{Lin} and \texttt{STM} target impure interfaces, ArtiCheck targets persistent (pure) interfaces. ArtiCheck furthermore targets sequential rather than parallel or concurrent tests. \section{Conclusion} We have presented two libraries, \texttt{Lin} and \texttt{STM} for testing parallel and concurrent code for OCaml 5.0. Despite still being under development, we believe both libraries could be helpful to developers of OCaml~5.0 programs. \printbibliography \end{document} multicoretests-0.7/doc/paper-latex/preamble.tex000066400000000000000000000027631474367232000217660ustar00rootroot00000000000000\usepackage{fontspec} \setmainfont{Libertinus Serif} \setmonofont[Scale=0.8]{Fira Mono} %\setmonofont[Scale=0.8]{FiraMono-Regular.otf} \frenchspacing \usepackage{xcolor} \colorlet{darkred}{red!70!black} \colorlet{darkgray}{gray!70!black} \usepackage[final]{listings} \lstset{ basicstyle=\ttfamily, keywordstyle=\color{darkred}, commentstyle=\color{darkgray}, columns=fullflexible, captionpos=b, % sets the caption-position to bottom escapeinside={\%*}{*)}, % if you want to add LaTeX within your code % frame=single, % adds a frame around the code keepspaces=true, % keeps spaces in text, useful for keeping indentation of code (possibly needs columns=flexible) language=[Objective]Caml, % the language of the code % numbers=left, % where to put the line-numbers; possible values are (none, left, right) % numbersep=5pt, % how far the line-numbers are from the code numberstyle=\scriptsize\color{darkgray}, % the style that is used for the line-numbers mathescape=true, % rulecolor=\color{black}, % if not set, the frame-color may be changed on line-breaks within not-black text (e.g. comments (green here)) } \usepackage[ backend=biber, maxbibnames=3, style=numeric]{biblatex} \bibliography{biblio.bib} \usepackage{graphicx} \usepackage{hyperref} \hypersetup{hidelinks = true} \usepackage{cleveref} \usepackage[top=2cm,left=2cm,right=2cm,bottom=20mm]{geometry} multicoretests-0.7/doc/paper.md000066400000000000000000000426341474367232000166650ustar00rootroot00000000000000Multicoretests - Parallel Testing Libraries for OCaml 5.0 ========================================================= **Jan Midtgaard, Olivier Nicole, and Nicolas Osborne**, *Tarides* Introduction ------------ Parallel and concurrent code is notoriously hard to test because of the involved non-determinism, yet it is facing OCaml programmers with the coming OCaml 5.0 multicore release. We present two related testing libraries to improve upon the situation: - `Lin` - a library to test for sequential consistency - `STM` - a state-machine testing library Both libraries build on [QCheck][qcheck], a black-box, property-based testing library in the style of [QuickCheck](#QuickCheck). The two libraries represent different trade-offs between required user effort and provided guarantees and thereby supplement each other. In this document we will use OCaml's `Hashtbl` module as a running example. The `Lin` library ----------------- The `Lin` library performs a sequence of random operations in parallel, records the results, and checks whether the observed results are linearizable by reconciling them with a sequential execution. The library offers an embedded, combinator DSL to describe signatures succinctly. As an example, the required specification to test (parts of) the `Hashtbl` module is as follows: ```ocaml module HashtblSig = struct type t = (char, int) Hashtbl.t let init () = Hashtbl.create ~random:false 42 let cleanup _ = () open Lin let a,b = char_printable,nat_small let api = [ val_ "Hashtbl.clear" Hashtbl.clear (t @-> returning unit); val_ "Hashtbl.add" Hashtbl.add (t @-> a @-> b @-> returning unit); val_ "Hashtbl.remove" Hashtbl.remove (t @-> a @-> returning unit); val_ "Hashtbl.find" Hashtbl.find (t @-> a @-> returning_or_exc b); val_ "Hashtbl.replace" Hashtbl.replace (t @-> a @-> b @-> returning unit); val_ "Hashtbl.mem" Hashtbl.mem (t @-> a @-> returning bool); val_ "Hashtbl.length" Hashtbl.length (t @-> returning int); ] end ``` The first line indicates the type of the system under test (SUT). In the above case we intend to test `Hashtbl`s with `char` keys and `int` values. The bindings `init` and `cleanup` allow for setting up and tearing down the SUT. The `api` then contains a list of type signature descriptions using combinators in the style of [Ctypes][ctypes]. Different combinators `unit`, `bool`, `int`, `list`, `option`, `returning`, `returning_or_exc`, ... allow for a concise type signature description. From the above description the `Lin` library will iterate a number of test instances. Each test instance consists of a "sequential prefix" of calls to the above operations, followed by a `spawn` of two parallel `Domain`s that each call a sequence of operations. For each test instance `Lin` chooses the individual operations arbitrarily and records the result received from each operation. The framework will then perform a search for a sequential interleaving of the same calls, and succeed if it finds one. Since `Hashtbl`s are not safe for parallelism, the output produces the following: ``` Results incompatible with sequential execution | Hashtbl.add t '@' 4 : () | .------------------------------------. | | Hashtbl.add t '.' 3 : () Hashtbl.clear t : () Hashtbl.length t : 2 ``` This describes that in one parallel execution, `Lin` received the response `2` from `Hashtbl.length`, despite having just executed `Hashtbl.clear`. It this case, it is not possible to interleave `Hashtbl.add t '.' 3` with these two calls to explain this observed behaviour. Underneath the hood, `Lin` does its best to schedule the two parallel `Domain`s on top of each other. It also repeats each test instance, to increase the chance of triggering an error, and it fails if just one of the repetitions fail to find a sequential interleaving. Finally, upon finding an error it reduces the involved operation sequences to a local minimum, which is what is printed above. `Lin` is phrased as an OCaml functor, `Lin_domain.Make`. The module resulting from `Lin_domain.Make(HashtblSig)` contains a binding `lin_test` that can perform the above linearization test over `Domain`s, the basic unit of parallelism coming in OCaml 5.0. An alternative `Lin` mode works over `Thread` for testing concurrent but non-overlapping executions. This mode thus mimicks the above functionality by replacing `Domain.spawn` and `Domain.join` with `Thread.create` and `Thread.join`, respectively. The `STM` library ----------------- Like `Lin` the `STM` library also performs a sequence of random operations in parallel and records the results. In contrast to `Lin`, `STM` then checks whether the observed results are linearizable by reconciling them with a sequential execution of a `model` description. The `model` expresses the intended meaning of each tested operation. As such, the required `STM` user input is longer compared to that of `Lin`. The corresponding code to describe a `Hashtbl` test using `STM` is given below: ```ocaml module HashtblModel = struct type sut = (char, int) Hashtbl.t type state = (char * int) list type cmd = | Clear | Add of char * int | Remove of char | Find of char | Replace of char * int | Mem of char | Length [@@deriving show { with_path = false }] let init_sut () = Hashtbl.create ~random:false 42 let cleanup (_:sut) = () let arb_cmd (s:state) = let char = if s = [] then Gen.printable else Gen.(oneof [oneofl (List.map fst s); printable]) in let int = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Clear; Gen.map2 (fun k v -> Add (k,v)) char int; Gen.map (fun k -> Remove k) char; Gen.map (fun k -> Find k) char; Gen.map2 (fun k v -> Replace (k,v)) char int; Gen.map (fun k -> Mem k) char; Gen.return Length; ]) let next_state (c:cmd) (s:state) = match c with | Clear -> [] | Add (k,v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ -> s | Replace (k,v) -> (k,v)::(List.remove_assoc k s) | Mem _ | Length -> s let run (c:cmd) (h:sut) = match c with | Clear -> Res (unit, Hashtbl.clear h) | Add (k,v) -> Res (unit, Hashtbl.add h k v) | Remove k -> Res (unit, Hashtbl.remove h k) | Find k -> Res (result int exn, protect (Hashtbl.find h) k) | Replace (k,v) -> Res (unit, Hashtbl.replace h k v) | Mem k -> Res (bool, Hashtbl.mem h k) | Length -> Res (int, Hashtbl.length h) let init_state = [] let precond (_:cmd) (_:state) = true let postcond (c:cmd) (s:state) (res:res) = match c,res with | Clear, Res ((Unit,_),_) | Add (_,_), Res ((Unit,_),_) | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int,Exn),_),r) -> r = (try Ok (List.assoc k s) with Not_found -> Error Not_found) | Replace (_,_), Res ((Unit,_),_) -> true | Mem k, Res ((Bool,_),r) -> r = List.mem_assoc k s | Length, Res ((Int,_),r) -> r = List.length s | _ -> false ``` Again this requires a description of the system under test, `sut`. In addition `STM` requires a type `cmd` for describing the tested operations. The hooks `init_sut` and `cleanup` match `init` and `cleanup` from `Lin`, respectively. A distinguishing feature is `type state = (char * int) list` describing with a pure association list the internal state of a `Hashtbl`. `next_state` is a simple state transition function describing how the `state` changes across each `cmd`. For example, `Add (k,v)` appends the key-value pair onto the association list. `arb_cmd` is a generator of `cmd`s, taking `state` as a parameter. This allows for `state`-dependent `cmd` generation, which we use to increase the chance of producing a `Remove 'c'`, `Find 'c'`, ... following an `Add 'c'`. Internally `arb_cmd` uses combinators `Gen.return`, `Gen.map`, and `Gen.map2` from QCheck to generate one of 7 different operations. For example, `Gen.map (fun k -> Mem k) char` creates a `Mem` command with the result obtained from the `char` generator. `arb_cmd` further uses a derived printer `show_cmd` to be able to print a counterexample. `run` executes the tested `cmd` over the SUT and wraps the result up in a result type `res` offered by `STM`. Combinators `unit`, `bool`, `int`, ... allow to annotate the result with the expected type. `postcond` then expresses a post-condition by matching the received `res`, for a given `cmd` with the corresponding answer from the `model` description. For example, this compares the Boolean result `r` from `Hashtbl.mem` with the result from `List.mem_assoc`. Similarly `precond` expresses a `cmd` pre-condition. `STM` is also phrased as an OCaml functor. The module resulting from `STM_domain.Make(HashtblModel)` thus includes a binding `agree_test` for running sequential tests comparing the SUT behaviour to the given model. Another binding `agree_test_par` instead runs parallel tests that make a similar comparison over a sequential prefix and two parallel `Domain`s, this time also searching for a sequential interleaving of `cmd`s. For example, one execution of `agree_test_par` produced the following output. Note how no interleaving of `Remove` from the first parallel `cmd` sequence can make the association list model return `-1` from `Length`: ``` Results incompatible with linearized model | (Add ('1', 5)) : () | .-----------------------. | | (Remove '1') : () Clear : () Length : -1 ``` Status ------ Both libraries are open source and available for download on GitHub from https://github.com/jmid/multicoretests As the APIs are still unstable and under development, we have not made a public release yet. Interested users can nevertheless easily install the libraries with `opam`. During development we have used examples such as `Hashtbl` to confirm that the approach indeed works as intended. The behaviour is continuously confirmed by running GitHub Actions of the latest trunk compiler. As further testament to the usability of the approach, we have used the libraries to test parts of OCaml's `Stdlib`, as well as the `Domainslib` and `lockfree` libraries. In doing so, we have been able to find and report a number of issues which have either already been fixed or have fixes underway: - `In_channel` and `Out_channel` unsafety https://github.com/jmid/multicoretests/pull/13 https://github.com/ocaml/ocaml/issues/10960#issuecomment-1087660763 - MacOSX crash - https://github.com/ocaml/ocaml/issues/11226 - `Buffer` unsafety - https://github.com/jmid/multicoretests/pull/63 https://github.com/ocaml/ocaml/issues/11279 Related work ------------ - [QuickCheck](#QuickCheck) originally introduced property-based testing within functional programming with combinator-based generators, properties, and test-case reduction. It has since been ported to over 30 other programming languages, including [Quviq QuickCheck][Quviq QuickCheck] - a commercial port to Erlang. - Model-based testing was initially suggested as a method for [testing monadic code with Haskell's QuickCheck](#Haskell-model). An explicit framework was later proposed in [the GAST property-based testing library for Clean](#Gast-Clean). The commercial [Quviq QuickCheck][Quviq QuickCheck] was later extended with a [state-machine model framework for testing stateful systems](#Erlang-eqc_commands). This approach was extended further to [test parallel code for data races](#Erlang-eqc_par_statem). This general approach for parallel testing has since been adopted in other ports, such as Erlang's open source [Proper][Proper], Haskell [Hedgehog][hedgehog], [ScalaCheck][scalacheck], and Kotlin's [propCheck][propcheck]. `STM` continues this adoption tradition. [qcstm][qcstm] is a previous OCaml adoption, also building on QCheck. It was missing the ability to perform parallel testing though. `STM` seeks to remedy this limitation. - [Crowbar][crowbar] is another QuickCheck-style testing framework with combinator-based generators. In contrast to QuickCheck, it utilizes AFL-based coverage guidance to effectively guide the generated input towards unvisited parts of the SUT. Crowbar does not come with a state-machine framework. [Monolith](#Monolith) is a model-based testing framework also building on AFL-based coverage guidance. In contrast to `STM`, Monolith's models are oracle implementations with operations matching the type signatures of the tested operations. Neither Crowbar nor Monolith come with skeletons to perform parallel or concurrent testing. Furthermore the AFL-based coverage-guidance underlying both Crowbar and Monolith works best for deterministic, sequential code. - [ParaFuzz][parafuzz] is another approach to fuzz test multicore OCaml programs. It simulates parallelism in OCaml through concurrency, enabling scheduling order to be controlled by AFL, which helps to trigger and find scheduling-dependent bugs. A caveat is that ParaFuzz assumes data race freedom. - [Ortac][ortac] can extract Monolith-based tests from a formal specification written in Gospel, a specification language for OCaml. Gospel specifications include models, pre-conditions, and post-conditions close to those of `STM`. The extracted tests however inherit Monolith's and AFL's focus on sequential code. - [ArtiCheck][articheck] tests random combinations of OCaml calls from type signature descriptions, similarly to `Lin`. Whereas `Lin` and `STM` target impure interfaces, ArtiCheck targets both persistent (pure) interfaces. ArtiCheck furthermore targets sequential rather than parallel or concurrent tests. Conclusion ---------- We have presented two libraries, `Lin` and `STM` for testing parallel and concurrent code for OCaml 5.0. Despite still being under development, we believe both libraries could be helpful to developers of OCaml 5.0 programs. References ---------- [qcheck]: https://github.com/c-cube/qcheck ##### QuickCheck Koen Claessen and John Hughes, QuickCheck: A Lightweight Tool for Random Testing of Haskell Programs, ICFP 2000 https://www.cs.tufts.edu/~nr/cs257/archive/john-hughes/quick.pdf ##### ctypes Jeremy Yallop, David Sheets, and Anil Madhavapeddy, A modular foreign function interface, Science of Computer Programming, vol.164, 2018 https://anil.recoil.org/papers/2018-socp-modular-ffi.pdf https://github.com/ocamllabs/ocaml-ctypes [Quviq QuickCheck]: http://quviq.com/documentation/eqc/index.html ##### Haskell-model Koen Claessen and John Hughes, Testing Monadic Code with QuickCheck, Haskell 2002 https://www.cs.tufts.edu/~nr/cs257/archive/koen-claessen/quickmonad.ps ##### Gast-Clean Pieter Koopman and Rinus Plasmeijer, Testing reactive systems with GAST, TFP 2003, https://www.mbsd.cs.ru.nl/publications/papers/2004/koop2004-TestReactiveGAST.pdf http://www.cs.ru.nl/~pieter/gentest/gentest.html ##### Erlang-eqc_commands Thomas Arts, John Hughes, Joakim Johansson, and Ulf Wiger, Testing Telecoms Software with Quviq QuickCheck, Erlang 2006, http://www.quviq.com/wp-content/uploads/2014/08/erlang001-arts.pdf ##### Erlang-eqc_par_statem Koen Claessen et al., Finding Race Conditions in Erlang with QuickCheck and PULSE, ICFP 2009 https://smallbone.se/papers/finding-race-conditions.pdf ##### Proper Manolis Papadakis and Konstantinos Sagonas, A PropEr Integration of Types and Function Specifications with Property-Based Testing, Erlang 2011 https://proper-testing.github.io/papers/proper_types.pdf https://github.com/proper-testing/proper [hedgehog]: https://github.com/hedgehogqa/haskell-hedgehog [scalacheck]: https://github.com/typelevel/scalacheck [propcheck]: https://github.com/1Jajen1/propCheck ##### qcstm Jan Midtgaard, A Simple State-Machine Framework for Property-Based Testing in OCaml, OCaml Users and Developers Workshop 2020 https://janmidtgaard.dk/papers/Midtgaard%3AOCaml20.pdf https://github.com/jmid/qcstm ##### crowbar Stephen Dolan and Mindy Preston, Testing with Crowbar, OCaml Users and Developers Workshop 2017 https://67.207.157.55/meetings/ocaml/2017/extended-abstract__2017__stephen-dolan_mindy-preston__testing-with-crowbar.pdf https://github.com/stedolan/crowbar ##### Mmonolith François Pottier, Strong Automated Testing of OCaml Libraries, JPFL 2021, http://cambium.inria.fr/~fpottier/publis/pottier-monolith-2021.pdf https://gitlab.inria.fr/fpottier/monolith ##### parafuzz Sumit Padhiyar, Adharsh Kamath, and KC Sivaramakrishnan, Parafuzz: Coverage-guided Property Fuzzing for Multicore OCaml Programs, OCaml Users and Developers Workshop 2021 https://github.com/ocaml-multicore/parafuzz ##### ortac Nicolas Osborne and ClĂ©ment Pascutto, Leveraging Formal Specifications to Generate Fuzzing Suites, OCaml Users and Developers Workshop 2021 https://hal.inria.fr/hal-03328646/file/OCaml_2021.pdf https://github.com/ocaml-gospel/ortac ##### articheck Thomas Braibant, Jonathan Protzenko, and Gabriel Scherer, Well-Typed Generic Smart Fuzzing for APIs, ML Familiy Workshop 2014 https://hal.inria.fr/hal-01094006/document https://github.com/braibant/articheck multicoretests-0.7/doc/paper.pdf000066400000000000000000001551771474367232000170450ustar00rootroot00000000000000%PDF-1.5 %äđíř 16 0 obj <> stream xÚµ\Io,1nľçWř´˘} Čm€w rhŰí9ĺ0˙˙-$E-U]í™ŕ˝F»«´R—Ź”Ţţń¦Ţdţ§Ţ‚Î˙ĺŰ×˙ć_˙™?úýŹ·żüyű÷˙Po*­ś}űóófĽP>˝Ý´Îř·?ß˙ý.Ą~H鼔ö;»ü}Ď›˙–ůc>b.b=Ľ*ß¶ýíěÇMŰô.ý·Ď9™Ë•ËčR­}—&ë§6_J©RĘ}xý>¶V;ýÉź­Jý OMoŻ~ß±&öj Ç‘i cx`ßĺŤĘ5eîG©Ź˙ůó_Ť>J$çtˇŹMB†Lž(bŇHžOhçŰ(«Łp0ö%ę?B’«Í+™„ e [[e\ćĺ› Ť\˙Ś Đ¨Ť‘‚§Ć¶E5'Lé®ŘććUyШ”n­Ţ˘Ú»{L20ʱ4É1xbĎĹx#ÜvęLČÓÖĐÄUpČ,üŚ,6ń# ™ĆxjŘ­Z߆¸ÓE "=d› …—٧u:ëN©VÂ^Đ˝­6„„Śüą}/oiVÚTmś Ś@čkÜžŘÎ ‰»łĽ–ź«`%-ŢEÜÍčł“V(”¦ţáëš·˘7¤Ş Nx§şMź}Ö‰ŻUyM@ĄĂt˝Őô×–öy~®íYFBxF¦.®U9ĘĄş$ «:{AÇš«x.ş‰ô¶÷H"ýţą3!” ż#7Ż›ukţř˘żGnš‹îs’(PŘ%¶Iüžć“Ŕą´”ŐbČVdČŞ=s‘0-mş^+ĎHsy[VMo`mďPËa¸˝Z9ŁA$¦IŹ}ayóŐ×fłžJ%áëđó#km„°NÝű¨â#a}˝j”1¤aĘ&ş—†ÚZ(k…6v’NÖ "ś¤©ÖáhiG·bw|˝Y|ő=ą w2dń صf*µhíRGkÜę?[ă¨E´™*ÚF‘ża‰ý“JAئJuu¨ßuŽb«k˘Ą!.krĹźićS¦jôÁ&ÝÚĘ۶†I‘71ۨZ“FÓ…IŽüg­Ü† ßŹ˘‘S$fň¸ňĂ€AęľśÓ«Ć„úťŰśµĐNÇćWmXy?W–q˛×ől„ţćn ëľµ™.6˝E´?ş5Sj¤}źÄ #Í ě‘j˝;tTű…őV¨uâą ßń]ČRĎ.5­/ülr•ě%˛÷©öéťxôYČ1/c¬>!cm=łu›oEÝ0§˘U\­Ů¬ŕľČˇU§r!ëL÷&¤T|¦Ë,t ícŁHŤɤ·«_í<‰śĐ­ĺ>Bpźa›ěG†™'5âÖOwY&eęIľă”;|°5ăiď:›Htť™ÔP |7¶• ·/a=2˙«„öÔ9±8-ĽkuP‹A=Ă…şuĽě2Í™,VŃť0Ž›ÉFč˘QÜ)¶ŃŚ ě* g·Đ<(ËTÜT»K3t2ËďŢ ‘đd«Ĺ±;‡Â#14 ‹µí€ŇÝ ú>ĚÚ承»Î‡‹{F6Đßܬu¸CśĐ0©ŇšB…Đ6Ď~-»îS7›áÔ)|Og FOÝ]÷źö:¸)Ó4ŤŘŻś[­¤şb•Ôřŕ©AŮ–Zr+–#w†Ŕ¶ćP9u3…!onü]řS7ŘbŤ5Çă°´.~š-@ôž‹@aŞĐ!? ·e–ˇ ‘Á6ć˝űi«• ž™ÖNHÚď .t€š6"­?T5Î,ŤhżNµSC}ľ±đ¸ă«6ßÖŽ±Ü»aâˇX˛ß śج°uä`‚ ;0ˇ>•i”‘´Á[ ůý#ďYyZ9ÔUĆŠ mWV/#ŢtE‡†HŘ"ŠcĆđ ÷x`†=/ŠjB…ě’WóŹqjŁfÜZŇgcó`őĄ?«c…óq®ýÜr1Ą'S”‹Sś‡::gúÚ™ć€|Ź<˝wőJ΢ćë­ Űę˘#Ú•0˝5ŢË #l#›A¤•÷lL ŚXK#"CóśK’§EĐŇ#z™ň›9:fÁ·_Ăn¬Ošâ™p…Ć«h8ÜoyUfΫh9¶Ďń2Çű®b/Úý§măťpŇ˙rŰlĘv›ŻJ˛Öí¨ôÖnu¶Uď•řĹ0ocŕ}­ťPi±öżş„iŞPe–ÎÚąI"HfŞ~btggÖa]·Ń]č¦jęjcý`ĎĂRú}ŇdśsŕZĹě°>q|ő{7ĆlĐkczůłą«ÜvJ#áA„°Řŕz·Ü^¸8v-şô\ł<"ĄŇĽX;®f˛Ýčň†Ář­üŕâ·÷n5ôĆŔo&?¸Če?K V”öx`Ađj5ŐżÎ]ĄĽh†/‚i:×~î}Ą"e$łTČp¤î¸á‰h˘–Nčä7–N%Í˝»(Ú“™8pL¸ľ'/Č o®DĄŃxbjU„eăMAžu+äe«öŇTEpEůyŐŐ!Ş´ţŇvG!4.€ž!ë`•%“Ů­V„kç‘+{Z1Z‘˘ž+đŮFwc¬Ćü‹Ôą<%ˇ­¤á©dRI(ÝĄŤüŢ´Y &Ś-âGMĆó&oÚf´˘î§‚ľB-çí:ť¬ÄÚ¤;›}|ĄÉ:s´Ô?á÷mŃQřd^jÚ‚ö°n–­ťdjz0Ť&=ďĆľĐMţŔúÖ˛ ĘßIať%®Śń€$˘)ű"Ú…>Ćl¤…,Q.WU幪ĘU™SUeÓMÝ„Ł:u$GÝ+r´uů‚=—!*„xI׆§‚yix›wţ[ĘƤą 6ʨ^Ýŕŕݧ4–倰xoĹVV‹ úĂŔxJŕŢŮč‘ŐöܨgÁăhv#¤ý†ř'Z¦R'Aů®áĆ™4Ë—0řO7ćŔVYŕ§ąfÉUiľgĘ[ą¦%p_°Gʉ6·Ą†(™Á,9†ˇáÝ €Šj\Ňj# ,ůo?ń9JŔ¤—ť §m“}™lpSŇČYŁ˝ňČvĽdZIę嚤]zŠdo†ĺ•6ôÍ ¶ĘwćdcOz­Y˛CÖŽFűU®á8|:pÚű•[˝Ľ@hű˝$Rh732’˦-W@ŢĐg<Ô t˛+˛™^{:os({ľÍ7¶ś*†‹ň6Đł^(j€Á:'™/W|p»@<ĂŃ ć!` ö–yl8J­ĐJÄvÎĐäaćG –î5ú!łł×@ł=ą¨1aN4›jĎŤb¨¤}óÖOŘ"Ë˝ ”’ĹŇôâb¬zĘ`ŮqnşŞ)ĹáŤö¤őϢƞK8 ć}•ňa§…}ÜřŔđô4<-ÖĐ Ź PŕÁ!Ř;P”í1ţRů· ¬˘Ö38çĚ”´&WĹAŻĆĹGĄg§/öµh?Đ÷Ě‚P‹ń»‰5f_4^1'N™u3’<;€Łh/qMq„‰J¤#k4â€ăÄ‘UzryćúßźS‚†,Ń!evÔ) |wť@«XŮGgŰ…aße§­×IµËu5z „'¤®áçÉ (UT“=€.*Aś< ĚhŽu`Ç#Ů“zIŤ|~śk"v6Ž˘żNě':ŃëR¤’›ČSBâŕ©}–ŰČËÉ0}Ľ±â’N[t¦Ąä%=ĺĨ¬›š=Ó™1ś|-±í].ÓçmGĆ·ˇä¬ś± Çc–,’)˨©Ň­×'— YňŰ& ),ő4ď6Ú! O~f©%ÇpîöÄ.‡đo˛HĹćLŃ)/Ş×'ľ9ˇT¶•“y)[v—Ća…dg·_Ăőč"ö´Ő⪆~z·Ix‚yHÁďŔ9*3g˙cŢźii‹ ż Ý}÷şmZ+ü„ ;ѡűnQÉ›EoXÄÓ÷4DÁŰ ÓÎ6<¬Đ ¨lfůKĆĚ{ŞÚľy$˘˝%*÷N KE¶˙ř)SăY%üĎ„ďRŹd.€;ÇLÜ mčř#É/Š7(Ž´rłwj6ť˘j2uϤ,vŮN-]OxŞČĎ0Ş'ů>6ăaÚľŚ‡áQ.p8ON U™´µž$řYßŇĆ€UŤ§č,ĎY®ýíą…MŁťÓÚĄëďđíÖçÂn—Oéët=EĄź†9`¨i%<% }ŹçŽhyŰŰéN:ä°—N–ź!¸łPM2Ý|ŰbÓqr»ú~ěö€%Ádę[ź%_"Bą‰lě€s]…e‰î:Pő[b‹fDZ¶RxAH˙U´ýÚÝ6ĺËsµC˛<ďXÎ,ůÝńHËŘ*ÔfręfB‡—\u•Č@9¦ě„QjJJާî Y•Muťähę8>3j{Ń‘,v‹V˙z5¬ĺĚôŻóýls–źŻA!&;…1ŰÓ&›‘Z+žX%Ů6™-i«NłV7” Ahî•O”©3 C¦ÔŐŮçł­čç٬ĚřýÁY< é%R ł?Ď׆îX<ąäŮ›IĘ­'e·g‘fÁmµŮŘjVŰÍ(čXîä;”Lý/ĽăĹ.fą`ĆÎ'Ř«X§qzvE =^Xc^Šž U­°fˇęÁÝ,v ťQć@v¶7ý¦Lă6ď KďµÉJź˝?ľ†'Nżr.Ë?#«±)O÷aÇaůó¦ew‡gĘuĘĄcgw{ôŰ2ĐđtOi·Ś4#PnÓqś`°Ýz´śŔ+ôɲ©ŕdşGneč/žĐ_nZOčű§I©éü€~¨ô=ЧkżŽtKQëË`ˇçÉÚ§ ąŮŘeŢÁł[‘x»‡ů¸O˝Áľ‡żp%`ôšę\¸J"âҢű+Ś…Ii“Ůrő–Ío ČżÔ•¨`R3 •®çťm.±KęÂ?xŰť;» Üs­FwR8XhvčĎ9łěŁđ줻ʏ!Áöđ€UËO<»ű2Oî>Řĺ8ŞCPălu(urJ_j3Ř8 &ŐE˙c‚‘ŰWw¨UżĽ ÁęÝ]ťžü.«źóĄ»äÚpŻĆĎi`’”ä ţî<[!#Ő€«_Őŕcź^mY6É/Žq´»^ő‚:?XĄŐ«u–yíý*‰Í•‘<ż—ť˝¤”îđdňÉyDo(v1_ÎăÝ•n·‰Ţnç[ŚQî[6ľ’úĄo5čĺ˘='R&Ľ‡Á,gjĚoîaÖµçŮ!˛gjXú.D§+Ľ`đ´H=ŰOôÜq’říČ|oĹLľwOGp5‘ŕ(®·Ę?ÍŁÓĹŻPă¶ťdň\ő«§~?8€ĺΦ_ź&łĚˇŢŔčÜíf{éZ(şO·h„ ~Ö´Ż^Äĺý¨+yčŞYęëéÜMŢ®‘ĺ=żGÓ/P9ö÷iŘÄ ŞRôęÝ&e‰Z.•ô٬•Ú÷‹şÎkĹĆĐc-”ŇĘ—RÍ‚,.ô;»uÇkŇör7yQH ĺK§›]đÂ)Í%Ő»ŃîŐłr?Xk”ĂnÉš!ó|§&łĎśŽîĚ€(ÄČf—ăUŇ´4|ď”0N_Ľe#»›żľe#đ%}0ŇŮÔ¨$ eÔÁ÷ă›CJoşŠŤĐks*:Ć˝–µYŽĆ…ßiöď]ţÄ?0ťÝ2%Ë€>+•Üćv&¬ý·ű?)ćv endstream endobj 27 0 obj <> stream xÚĹ\Én$=rľű)ô˘ą@č{ßĆřo†jUiNsż˙ÁA2H—ĚĘ’äĐ-TUfr F|±2_ţń˘^$ţS/^ăůňńwüőüűŰú)|~öżţŇľţďß^ţńňoĽüë/˘—ęĺŹĎ—WÂH˙"˘Ăß·˙~“Ň~J ?~züĽăź˙ő?üçËż˙ńň×6Ʀ7„rw¦ß±±ÁŽ?ń;`§Ö–NMşö˙âŻWźVźlg—đޤŃŇŔiŔ4XZEţ˝®âú0 Ľ5/ŻZ‹hc%Ť€Ký,Ťć~ ^±Sü&ßˬm%!®DŢëÝD8Ľ™g ׫gäVr˘Ŕł+7VD •K2Wěiş[µ&ŔÜ­!:ľîľ˘NŹGkË;lˬňs.ď µNdĘw ŤéË‘ŰŐǨ˘Ľ ŮmZR(C¤Iĺ‰^dŠE~ęLá•ýĆŽY'‚űކ ]@ď¦Ň1ÉčĆ•jÝ7ÚĎŻŻÂăcľ ŠŞÂ–†Jŕx7ú^ąďó ZxýMyű0IÂWŻTś‘Ŕ!ňw†™ůlźOę/ó{•EŚůŮŐŢżA…hR÷[Dş0´ÁZg›NŚZ%đw™ʩćV[ČÎťŇ^Ă“ŰţâÎh{ŽĆć­©|çx§qµwCË6g[ÉHňeNʢ0éIĎ4É~;ĄW%şBą€Xőô7Čd ¦?YŔJ)›DM^°Ćrë „Ž®µ®Ä*ęq%–5Ç„ě‚ôĎ"˛‘¬ű6‘›^#Ű,÷ä ?ŞpMőo»hÍńä™˙RZ-@ţż6±ŻóěĐËOóíc‚«® ňóŮděÜ˙Á ?Ç«ĹďÔ 0~ŐOńëÚMëâ;<űχç„U?ŔĎź]®żČË­‡?źŹ9Żqtš×3„ôAçżOČjĽ€ĺűďOaěľ‹Ëűąď/“ŠîďąĐQ ŁuµĹüpŁß|đI˝«—(˘Ó.őŚđ %-­@rU®ôdĐZ°ůŢňXh&eOéŁ~/,Ŕ{VZ pzîÚdfBŠPž ‡‹úFß5ŰĆ,8.ä]dč—%ăä6ö•ŰÖßg9±§”B{{A ©1_ü ­meŠ,©vžxµ-#Ű2¤f]łËÚĺ~B{‚î˛;»ĺŕě,•ŃšöĹ Ăž•źÇüłŮUô,ŚMü˘#2c ‘ht2ŤłĚZWÔ…6Ż'Ž«ĄÖž6Tł ‘ůĺ‰WŚ3oµ‹piA©¶´)D(Yű]Ăgáťvçă Č“¦ş/»MĽ0¸źżëČ›-AI1*tŽb\‘9Ęô™ ˘bŐw˘6‚BWęC×oąG:–†–<Ô‚d$î%°t|ăÜ&´Ą®=Gm,nhâi3nmr•Mt“ÚLH˘ČHÇ&üŢŐ–o±/&#;uéU !vNyĆ)Ľî,#»±Ć=ň‰až‘čEX0B›*0ÄĂËRš¨ßIݲiď÷ÔŞí€(¬+č0¦ŕ{ű™!Kމ}•Öz"»cŃÚ±ó “zK[„<–§š/ę‘iÖŤ‰HAÝeâ`&9*a†&G¶óFĹ 2ĺ¶]'źed•ö€ëˇp­Ó VDÜŐAt?Ů’äuyiÝCá~ "Ř8Ă+“¬+YDetşm¦h‚°¦ë+Ý=zBÄŚv7 G…†făä-`/lˇşÚ„U•Ó¡j<5ĂBľb?ňŻĚď4¤Ż¨@[›®Đ•3Ň,ťĘŽ, ·‡Ň-.ź©Š¦NX°ą‚ź{~ĐÁmF&Ś[XIt3ÉüĘ Ń3’–쎼rOŚF&OŃhé„¶f š…ľ¶7®D!^!«ÓŃu]‹÷9L"dsđs9ÎŹ=źwáV§ÔŕůăYc%~µ|ŕk(€üžtź°ŢS§2XeŤ†Z63Ź.q™†MĄý‚@‚lU˘ˇnŮäń”}ëĚťĽ‚ŕđŔ(˙łq‡` źEB#b7„rÜşNZ‘¦g[żĂÎV)”vIĎĚę3ćă&2Áz8a§ö3-9AUŇLšrˇ*¤|Ą2[‰ü«±›eö3zGMň•E™ŚĂTÓ$T¶j*…°WÁŐc Ž\ ŻŃńsĆ4jš}ěĄňěH9ËŔ2^ĐF;ŐĆľfšcŚ«Uíq6ę Ă Ż&±Ľ»GúÖŮUBˇ‹Ňp=bEĐ[%G†űé4 ň- šąŚ§O­Xšđű»P\÷˛~ű[,ŔúÔÎpGÇ2ă&6OX˛Ý{ź{‡˙_Ę#€hćQĆľQCp†ěĚ/ض0™‚p8RÍ…ľ°o·¶ö*Ą;DCpTĘ_±ex§5)Tz tŇV]’|A5ëťjŰÁĄŮčWšŕb•_§ęZŮŘ Ż¤r_…ÖP¨ĺŁé0® ’Gg‚­¶0ÓGŘťuűgížY˛u@2öbÓ˛rň/ž2fQąÇ`®p wĺCŤ7ç˝ĹäĆ(źîáÖö$Żx‚;T•"D|=ă[G’Şáßxa QŤŕiT'Ŕ©qP’üfÚ ×ivˇ‰.+Ż6¸MHÁ?éDşŇ™'…â w$Y\M3ęÁ9zr˘ÚĹ™“¨|Ě!ŃÁ89Űžd±čűë¸Zxëŕh-˘K7íg >E@Rщ•J„`§`#N’7m6ş \M&/}ăš,í±o6”َŽsę¸ŰôX9™ %9¬_'„ hĆ0S˘ÁdY®?FF@Ý|ű"űŢ/a60›#·ënŢźeĄtG˝M8zâŁ7°Ľć/Öę¸}ť2¦ůř¸L«€ëš˘ř¬‰:vfv…ǢĎčA ÇĺčÔ)HSu,ÄV¦ę(ćÝĎ*˝&ýňŮ˝Ş—9fQÓŔÄW,•‚´Nř¨'ŻĎgÂ2S|Erž ćIÔ{YĽŠ} ‰¦yż9şŘtëÖçC»Ů°Hv5·`Oß‘‡0Wí΄»LŘŮ­IŽ; &‡Ö¸¤}®ĹłJďú;–ç« )Á˛xC6w7›~jxdjJ;Ć{^ógşlIKşŽś!]Ôŕ.TPov_Öqř¤!çŔ𢴩—cŐ[íŻg=L]Ż–Ý«ÓÂĹ%ĶÉöMŘî÷˛q¸G(ÄŽ@PĹľúŮ@żĺ*YŤž”V¬Ö@šĐdĽ’O?`SłVBŤ,ĺ–u -¤ µ|Yë°ŇÓŘ]D_ŁZŞŰ-7ßĄÔ ĚZ®L P“¨[c`ŁŞ]zsš¦\cr˙Íń˘Ye5Íĺá“9pů‘Śş®\`»=±x™ÔJަńMžj t·|IRËľËpĎ[Ý÷&ĽŤŮšËŞDń{«¸ĐčÜ*VFHf°3ŮŘAťöCBü(»SElŢ}ÖéŢź Ł=pó^“ç„ {—|bU˛í‚©1Ü×Ňz1( E†j¶ł…ť\‹,Uă÷$7ä6QH.ň†9ZĆhÁääj´ýjŤĐ82öĄŹ8żĄ›Zh«U\I‡~Öąć(ě#!SÂUâÔ6Ą „ŰsŐTvhí@N°tŮP¨•$şi€päZĐ,±m™¶aIWKą°ÂQg>-@«Q˙Ôí#ÝcB™kĎŚ÷s-C> ż*]Áçş›kéD`©SÁ.€wEsůÉ*%#&úĘe3Kę-şďk(\Ô“W’knc“—”[[ö˝*7żUÖžî2»}ăÁęsŮ,u:vtq˘?ŞKd>x¦† ¦tŐ˝‡łĘTă)ř•â°šV+#pÇŞ\ąćXáĂvJ®Íwńb^ůtľF…ƬaE·’µ,¸CĎËD?Ú¬á¨ę‚0‡F4űë.”/ťŘ‹!>Ž^0p:wt‡\śşMÚŇ…ęoe…ˇ˙żţ”Ľ6+#9ݸ”éäßęä¦re“˘ąŠďÍ|łzĽ¶Gç;˘ŚAŢ‹˙ʆƔ`}IéWýą¤Żý_#M“.U©*(‘ÝB53¤Ŕ¤,'煉ŕµ2ź=ńX!a÷ÓqĂ0:ÉŚ.E+íi‹ĂÉł©­Ęŕ_îŘÁăm†qk:x }ĎęknKíCmË­HUOkqçłš=Ý ě3&m˛ř,˘¬ëĆâ`ŕP'2}LBńQ8đ<ţçčŹvP!d*Uţě¸DËŢąŤd¬D»´bű1UÜ“Ŕđv<Ô{ÔžłŃžŘ&đŞZ;:o˘áëq)[Éc´ŔîSćĎY’Źzg ˙ľ3b Ľ2‹AG;•ÜeNhv•z…ŽţdţôvXË•şËš%nťä¶eäçzz(c6,ĺXěxUi˝QĹĺÉŃvĘiŘÔ<ß+*Ł<ŮG­/NhϰđRK7 t)­×LŻt·ŹŁ· €Eßx̶XŇ˝ĆÇĐł˝##ź2µ0šGŹťUüĽŞ Ń“S—ÂýÔ×ŮÔ­SVwzš5ŻćĄŔUĚ€Öx,x_ü`ńCŽ ¸Í6 ¦2\kdsgF€*w(iJcĆßĺÂĘßt,>†ZĘüYĹůŕČű¶ńŔ‚*8-ĹH›/`öîJ fF˛š˛Âá}°Öé†RyËOÉŘᨢ}c‘FŰą:ŰiÁ˝„CR-ÚÂq;oM§‘âObÚŠhĺĄ)‡tN}PmŽîË·ůM+;č˛qč`0P7ŽŽ‚J]ĘTwAČÝI¢mŠFšÚQlÎÝáŇ{Sč2¦dÇĐZęITÓ©É"Ś÷ç–§ĂĎjžçá÷†n¦'Ç|OđüÔĚĐ™ö),0ÎŚ{±V÷·Ç4•·Ň|ś;ęZ ôÜ·ŇZá“{?¶’·óV&Eż ó×Čn[9áÍÜČÜźd>Ät]ßfzĆ|cëĘ|Ľu‰ĺ‘Éti®ëMbíT…/nEŠúyŞ9–ů`7ŚIo‚ąĺÓ$B§S…ŻŠ'k\@x*Eˇ×AnĂŤFa#3Ľ±č”Ł3‘‘˛vă”2ÍyĂ\†Ą¦†x:…\Ą¶óhéě¬;ov•qjhÖá>Ô Ńä2Čú6ćę5Ěbç!`Đ&ü˛ap#ó\9´;ćőě0ŻŠ8^G+r-%bÚ«ś.Ie˛GĆVH9´­é˝Cm­§bą)×|öҦ`iчŕo‚i8˝âĹe–śĽ­ś*‘B©Ą2L¦Ĺ{ŤŁË /ek5!jł¦w~ܧl»Üľw«ű¸Ž>ťQ…–ŔΦ9ăŰ#«¬\§kxĽOqť.Öh?LâÖ-cśtwČ„qŇîü@™iŽi·Áúk˝Z§vŞmĂY‰[oťÍ1ëY¤~$ű›eämU1&«ď”EčOnĘ˝縬t޲9üzšżËŞ«łŮQ˘&Š4\kQ)]Íëg×Ya.ČúâýˇZó`ć–掾»Żµys˝_{eËĄń’0:ń;3Źq÷ň;Í+qŘžě^ˇ¸Ăm\@:„ôęPuőlű.Ůů×ů?›  endstream endobj 45 0 obj <> stream xÚĹ\ÉŽ#ą˝ű+ô˘ą/@ˇě|Ło†ę’4'Ć˙0—2Čd.JuĎ`¦ĐZ¸E0–KęňűE\xüO\śŚ˙óË×ă»_âßoË™Ëc˙őK}ůżß.ż_ţöíňר‹cÂ)qůöĽ\…gÁ„‹`ÖřË·űż?8×OÎŤ˙ÚřŻ‹˙>âźűüĎ·^ţţíňkÝd˛śLŘ~5y‹łU\ÉÄăkWŐş¬*ÉN:ďôy5!ÄYâIö{•k`Š Ř?í›ö4¨Éď—ÔĽ° gĘËUr&-î’vř˙䫼ę—1ĺń€Ť׸v|Ĺoĺđ âüV§Íy9˙Žźn1_đ/3@ &…źý:p_ůŘY.ް˘~óµÍ,Ëßq—w×2~ćŢ'ľ['őL 1S„éqÓęr5Š UĄ¨Ş‘4¨ľ•QGVłšń`–«)PŐ3Ś“qM?.ťtßb—˛,9Ěe s&‡Čv†Ĺed+ keüpÉGY€4ôűç,đńśŽĐé-ăB-Ż×7Žť»bĎ”×ăú/Đí@°Ăüô…Čçč#×î1+飬¨ÍçU|śĽOł ;•CGE0Ô/$CóL9“Ä÷đ&h©Ná$A8f*“Ý˦R@× ŕč9|^Pą…ĺ·%ĐoĘ,»  ĚóNVŕăkŘFÜ2ŹóÄ},xÎx˛“2¤]őx»śOtŇŇŇÚŐ {–˝ŢĘ=-—*0­ü{Z>,ŇpĺŇ—ŽRËŃvťŕMŚ^śtóíťż2ÁDsĐÇ(á.¨i¶Z÷^ŇűÁÇO¤-tC| ›ľ%n2«űUZť FŞYĚG..ŐfkÝš/r’)Ž'Ůqa t —S_|='°«AUbĽbŇ©SĐT6#Şŕ'dÄxf„7Ěฮ‚Ö/rGFj¦x<ąäUÚ[šć›î)ÝV"„dtHN cČ…Źě¤ę ‹C •ÜeqÜRţţv»ťĺożHäŻpňtl]IŁ «î=K‘ť…µ/Ȩâ†Ehü1°ßí$‡EÖ8ägv÷ÓDŚĻ×Ý~gąÖ­±«ŐóěÁĄ–á[ăîZ®düڇ?JH»Ýβ»_dUH[^é‡ ¨ňŚ[ż†˘Wiš Úß«:0.1Ľ^@Âł•7)“Ţ÷•·×€śÔ1´ŕŞ[˘ŠŰ4±ł4Räiđ†Ţ×O[• ,Hµ¨?Ö-˛¸ËG+ę´ë—2§Ňş:"7ÝłµËđ»ĺf¨FÖŔgĄ4c} Ţd\pcoÆ vk×®¬řxŰěźc†‡’€!9vľľč÷8Šö7‹&ÍtU€ő$̢Ŕąş[Ť4ŹŐ;ž[ěstăEýď§7sź[WľĂżĎőŢÖn1`Q˛\uGâŘ‚‹bŕ–3yí"_öC…čś—ĘTş˘€—|Avś[IÚ>@GO»¤ňśPÖ1žj%CQí”o2ĚŽ+˝ă–µ¸7\j¶é<µëK&­?äH9d8*Ěí¸.ęq?Ňëüp’§ju:b„ü äG}ő:ü§öŁi7Ű'ş ŕýő]j×űť§ş~ÚúÓZÖr™Ç¬pgmѢtŚ7reş«_a–0sʶü˘éäyWŢć|čę—/ńŰĘš™źčô–Ô­źěm ěŞr›8ŕ´üi”Q¨xÁâ,OqNÓşúÜűŕd…NÚA÷¨©]"W›/fŢäu,ÔÔ΂ˇa•µViÔüŞŚŤšľ@t–šyi Í”Ť-·o`=ńóâ~„iĂÉiŁ®{ŁPÖřűNĄ¬ń·[%ó—JČ:ŹPnet{yy˙ćm´¤AWR; ÁĄỦ°XÍ€ĂiĆćL‹a`FËqíwPy_¨ŰBĺ>D'#"8@c:7źéO-\eŃŞ\@ŞŻ&tşşß.¸ănâÉ»ÜaX,~Ú©{°sÂz…řZ…e;Ök“G]m<źŕÍ&lζsřń=Îß—Ü̱Ę͵Ć0±,›µÖmÚäuĆ:8ˬZ,Ź×ňýŘ•8;®˘­2­¶­K&b]é iőëŚů >Íď×QśÄ8ĐŞ“ß»&€fVôÁš "ăš<Ř_ń¸é+P/Ç;K¸‰~˙ s2Př†9éëeŰqĐë¦D." †Ą_Oú‹ÖŔŔ9üč4}_ŇŰ‹źNđg0¤3Ţ`a÷s6c¬Ăl0ż¬hń¶HËoFd2îq¤ŐůŚĎc¬·pś­IŁăâ –µÇ${M—xV›Şf©OGULLŠÓŠZŞwPľö źęÓĂ(uö`‘:±4hÝŇN°`Ôbi-ćĐFliAĂX›Ő-{•ZďgÂÂé 2ďZx/­ .FąMd×cwKĎ©L|ię\CΗDľěŠF*3ĺY›ŘúShÁ|DIUqâJĘ&c4Ů5_µ#‰Šőkśđöjâl}ąFŤcUl%ł5‰*Üö,áţb’zT1˝ĘčwŤw»ó“FQmuĆNńŔ@[vdwB×­č t`ŘŔDźmNą? Zźš”ęÜó'x» żÉVE}:\Hő0|© ¦&î ¦=Ě75PIt&ݍŠčń °§ö,wlĽĄš|W5ąţ ŚUŤŤ‰Â|€–aDĘ'Y˛î Źpu囩1ľ±Ůü¤Ä‘ŞR•çÄöL«Yŕaś ˘…»¦ĂŮ5čäŘUËUxΤ°Łökj•’7QDÇ ¸¸Ô}&µ~QűňZ{|ĘéëÔ.a<«ĺ˛ĚĄŰ漙…>vóÔwĄňźO>•˙2–*!ş„g3[d­,3š/XBÖďQÉVő xČŤ.ĺ ş§Ş$°-éMW«U5·Ô–Ë‚o›Ąĺ(äĺĚ[úŁŐ UŘe×N’GݨコkÜé°)NŹ9jäPÇLq7ißWşśXľU,¬b»ˇ4Ź"V¦¤2›5ˇ —yD6‚śľë0WůT 1둊´rĹ“Sa™iMď<ɸÉň˘?,pŔ¸_%NŹ#éÚęęőúíI–ńŕĆIhaßń*ó§¤0ÝŢ”F—mÔ 4Ŕ„=Îç ¶T Y‘O‘UyÄőč.)¬¨ežžĽ˙ Ö×Ŕ(_:3śDĨť“Ç ß2ŤŠgů˝ŽĐ$’ôÁÉĉWqGźšŻŞáĽv ŃŃ4şĹ×d°¬› ›ŞjeжÜjĎD˛Ű&Ú'Y[˛—2›ŤcĘ«qb–Ý;î˝}»–¨/ĘuqőéÚĺ0y ă¶dR±AnˇđWŮîu9ŞŚÁOYÉá¬j?ˇ;wĂTQL9YźÁß×§T!îU «° Żfş§ŢęËŇ{¨ČDâS+gÄlRPy۶•©rŕĚ8‘¸Â>wĚ8w0·,j'°@jÖ˛ę[䌦ŃÁŤ~:5K$©Ńć˘y­J)¦R‚´ÇP¦˛ńlŮC8…Z­‰!~ŕ7{şź’?é.ş†Ţ|r[÷ăAŁř UÝ·úŞňNÖ“6YО“EĘ5Ş ú[§!§.5Á~÷¶Ţ‡AuŰČ{{R>Učß±d[îŔF”ćyę٤ú ŞüN­Z¸¦ dhV»&Łć zĚŽćŻnźŮ”@ZÓo%ůy6ęăK§†&€DŚ]ťAî‘ţ§‘0­¤ÁG‹¬B»Ď{ĂZ¶Fě5sz›˛¨łß‰ö–[ $őđT }oÍÔ0ŹŢŢ)‚ié›č‘ŚŘ°·ÁDŮf=¦ÉőŠń¨_Čn'SÖů´'±<<ĐP»kťJEnő /ÇÝŠĄ÷¤cÖĐ^Ś4ÂҶü.µ«ał['Ë Ą0Gâ«ó§ł‹Şw‘·ݦT°cǬŐ}Ô‘ŚôĐś÷)nőGM˛sßé˛ ‰ç3k[ZŢ}ť•8âó0Ĺ®?†>;y$1'ĆÍf( f·6pßT‹[> stream xÚÍ\ËŽě˙•ëKyöń®•ç˙óűż3mý–¶äÁŇęíô˘#˛&~DUűŹüŔ”«”˙ “ axŕtţ3t“†ó8 ç°ˇ/Ď\ëďşX;”9ů+ÎŇšBŤ†2tŹČŞ+ÍÜĽ…-ĄË̵1›.Żg·Üáł’Ţ/SűÍÓÚ–Aęvąá°iĐ­­Éł6y"đýÝ€G‘·E¬™—QŻ/4r,-,m#/ZÝęď:š-XČzKÎÉY_éŻěô5ÓHq\ß™˘2„ Şt­ĂÇ{˝¦ă#RrQőN™iáş:ěMNDgş*ÓŐşüËwAn‚&®lc¶ç:,-ŹŞOąď^Ů'5móĽ 4^™±7}E…3G&wĄ•iZ‡`_uĺľÄ˛u˛vSbţť¨·‘ąq¨L#µG‡¬_ZZqšŽt;ň8˘eĺŐéĆTófŐce.˛‰ĺł¦SOlI7młţEóuĽVř×’]ę“Î.­g•J$ö­)]+  ţő÷Űߢĺ{t›6šĹŘĐB›´‚`mŰóF|‚d)÷yĎ3řŘňŻß’ö<ČW^KžŞąÝĄb%zčM逭ůęA—ÝPůT!ĐN\ó|ă.©KiYŹ1OčIćâD'P T´Ú$pă[ J$y?ň¦ű¤ßŽLU.4Ľq(%őhW'ěLnóľ­Z¬Ý˘OÜ$y“˙ňV¸ËŠ^>n°ŤśţܱɀňĽ÷:n10—ÔĺxúÄÇPäLń…–MŢ>IJ˙rJ–[)ş(§Yqć{×˙‹¶ůĄx¦âQ î÷ÔŠhU•Ëbh«=ÍÚJ*u-DĹŢú+`ĐůµŰmžÜjP› 1÷3j‹ŕÇ|^v¬ß<$);ćˇěč•ěŚDžGeɱi> ă J)AÇw 3ŞkżHÉíe\ŢDý^3µTĺH_¶B%M iűŚú¸ď¦zš‘E¬é$Y\šćXśWŞëőtľĄ)äÎĹ“:S‹ś,úžt=Ţ÷7őaă/Z7T ő‘ MĐĄÔ–¬ďV’Äíľę6Š–…@­şe®MeĐ/×g‰w*Wjúkí2VC60°ńDSąşěvYDśl¸Â٬{wÖˇé‹ř©ęľHÂRWyŘ’ĎٲN ÓŞž8tžŔ¶·ď¶đ»•U$_€[L›7^‚eîVÝŻlCbŹÉDŇu!‰H âĎ$üŐŁę"Ëíś §=“A ÚóJp Â[Ů—őLQ†uË ‹ “VTyfµ25Ü„ţ´¸X@±OŁÂ4EH—u[ŘŠËóv Ú©7ďÂO¨·ĽŚÍ€ź·uŻßŞjk c4;ÜŁ¨ĆZ»ş§ń¨ťjí„Î3N4ę}GGńŤZiç¨Mµ’> ĎÍ#0šŹ´ŞţÎíu,×üDąµ}Ľ ÜDˇŰĺEś*ú·‘ňÎčDŁEşÇżë×ěn.{ćdKö5ő &n™™¤TşÓęu"rG˝ć}(""üökîŘĄ˛ˇ| ďÜ2 ¶2Ł/PâSě_U×TďI«É¦Ábzé^ŮëňÜ 4űŘŹ!Žě30ręŮ6Čţa’Z˙Z}.KĆ0şVé2±.ĚT’âúnl·YÚ2NâIÝşîz_˛˙ĘÎÔÝV ö•pH}€tŕĄj8©űĺŽ4,î†Ŕ»đ®ĺWü%Ü’ŰčšdŁöĽEŹT«žŐĺ@˝é7@V:€VO—Qš 6ĺĂ[ćd}jß{ű§á|Ţ98Ť¶Íö&EŢÄçVđ”[´iźřLłl÷}:Á}¬ćË_| BVUËú‚É.’{†Š‚„!†"đőˇ“´4=Ůc5 VXZlŻŰą•Ä ęÇ ”jlCG – 0íÎXÚUŚśöh䬨ůŢ4¤›¶ X{”ÍKň=xOęJŠ;Ź^¤4‰p<zĽ !ťŰů;HŁ…yę/ŕ@1­łăaŁ:ú˝ŔÔ>ć3x'6z'.łMđ¸ńçă…Ň/áśŘä/*VHmŠŁsBm8"hîknád3)Ď˨PËž[łË„ťJë±/îŔÎMľ+ÔK‹#߬¶6ŹŁwMAÜáVüżĐž…B±Ĺ ĄźŁďÝÖnQÁŕ%Ýé}"Ž Ź¨:SY_˘gdČn»śŔěíoFÂ_8 ’Ä=đłŚÁ[ FBŃ~DířŐ~OGÖmâ׌ś%.ňécHďľë@šŹcĹ ×ńŹŔIŤě68ÁőH8Ń;f5d/Đ$¦]š!ƦX‡Ĺü±¤Őŕ ö{„ń¶úcU€¶ÚŻđŽ0C¶Ă˘6łýÎ÷'Gu&y áˇ"(Ý䡝•l«lľĄlÇÓ˛=ą'ݦ2ΑtgR4ń— h–;UfIcőt™ fęÁ@ ÖĆ»:qB…N¨A=ű"çĹa°{zŠŽĐ iŻwOH{éä!ĺ˘ZP\<ŠH?‡Bő!<Ô@Źţż…BŰrPä‰đÁ“pa›Ťď ZXB>‚ě÷Š©aᤩauÇ–%ü?iwP†ń”ÝAđ¤©qąßłn ÉŮ—‰f"÷ě4ň8_»yŇyä‰XqćZ¤‘‹Łă5ĄńŃ­č‘çgᢶ·_J,Űš}Ůsý`}Ę´ŔÁŽ“$Č›M(węY÷*ő-¸Scű¸Ç*“MODL ĐX¦"÷†˘''2ëLéÉ( Ăľďçő8TňжK~3vĐv—ÓQţ‘¤ 9Ć1Ƹ<·ŕâęnłQ˙D\=řMÁn«´±6@ycm8Ł;_Ý ¤S;ŐÚ‰@úŽĆĄŁmĄÇi@’áĘ)¦ÍsľďŢĺó,¨V‹ÂY•Đáł”÷0 cŢ;ź=\7ŁěŮxUu8°›VsĹEaě“đ7ҢđFÖ•p-‹ ä ţr łm¨*"¨DJC©VíkLÇ4Çe?8j9d¦‘ł"ůtá’ LÇ6˝'“ÖËŕ·éĺÚĹŽíwt}OoĂ*sMw‹ÝQĂ϶f[ )?¶µLÚLig# ”ĆłSí!¦ćí–o%on ČSkŞÉkőx4ěśKe‹N µo!waŹÜĘ9ŻŤMA¤¸6ˇl>ĺm®[Kõ80R—ľšćBäIÓu kă>Ó‹ěň¤Őµäś“&X⢦’SjćWJłýdď_)m*L‘,N ]K˛ßCʼnŽ=±=T}HŰCuŚĎoĎ;ÍoDŘS›´‹GÉ-9pnˇýőÄľ9ľbĽŤa c•Vą-ńv źŤsŇddW†óv˘.ĆŤ…9LÂX ¸tiďOÇ‘pDÖŻŐ˝µ©…é râGě±ű…–śó~‘Řś->‡B_çfňËÄa­Ň;2Źq¸.ăkvDaěsŕń†Íôş…µYŚ+Ý›ĹäÚ"…EsÓŤę%SžŤo-,AĄ3Ę?rčĚÉú!aË.ň,Bç‹ÝFBđÝ Ň/«ń—vÖuŮC˛ěíçňqěȦKš«]¸«HgEąkEÄŚG•Fś®«ŁlRm“¦)Ť°«2§9ÓJ‚ôbA8Huh»a”ÍB \ţěL¸—“ĹAŘçQöé+Ěű^/çîö9÷•´i-ÄϨxÇ+Ĺ'Ă‘«ô’¨Ń/‰š 5ź+e É ˛wÜ;H5ź˙eÁŢ›*»Źů?•®wôg©†(RÚţ ]ﳍ zžú «îĽs4ěpö˛Svˇ3‚Y;—}¸Ŕ4#–[/ëËľŔëş"®Ö/§H<ąN>‰Ú‹4Ň,žYó»ncąQ§5°€<:Ĺr6.\ĺđp?śÍő%*çŮÂřîC–łŠQŇ葸ť¦Ä˘‚ň=AöOÉľ©\ç»q%˝Ł ÜłÉĂ8í M„Éü1ŃjĚŠ-nÔa˛şv_‚[4ÇĆ4lÓD¦ž‰v=ŔŇżY@)ŰÔjy6Ŕ7ű#ZŠ%I÷»ő›őz–owZľGBÍ ţ†ÉWę•—Ö”x–±ĄÜ]ĽÓc-¬ÁEaď÷h#—žÍ= áĘ)Ąí‹"”nĹG7Š(P¬ČT„š(’1çWf°G«}w\3w5üćŔNy»cĎ´Q~ŇFšÍËĚÓd:A«XOĆÍ!BÝśQĚqBî‹Ţ˛%ý'Ţ] ĺI;$~?i§Ł›ŁńŔwç¤Ţ}”´Ł~wŢ0ĐŃżl˘yČŢĐßZMŐ(4#tX˛cüŐó!á);áOůV Árź `ç[ů§3 Â&Jł"ž^ĽµÖJÄĘW©Öٶ`ŻÂÖ·Aj‰´WŃ\z„™žXQţŚďŁ´•¨ů‹˛ź•ÍH±x•ëťWďĚ“}śCńň…“'llóô» mÇ6ž6˛—É2¬EaľÖ«7ß_żE t«!>NËŐ %hAmÉŔĽşÓ|ť/´Ž3_‡óŞy¤4„˛ň\ČYľś4]ÎRÍ’4×ZÁa˝ŐçJnaΉB"ß ‰Ő¦z ޡhyűę"ĆŘ-Ůy9«L4Ô€]ÉDÓ•ćwµń*>ČDSĹ=d&ZRăĐ |¸~uĎO1fźË«‰; ú"Ę5öÄýâ®)Ye«ńÍŠćEÜĺ¶čw!ŹtžĎ&Jp‚±ŚÚ‚µ‡ŻvëěOŞç<ÓÍ'7/ŕOŞgÎă Ļ޸śuŐÓFŘŰĎťż 6›oó¬O?č-ŞÝń_^8~I)şĎýKÚ®¨Ňöä‰RĆýÉfŮ×.=f”°…~„Q‚©ŕ6mÚČ(üMźúľL yeÉĆ-[SÉO´o©Ťâ+ =DSóßyRiö(Z!ó×ô¦5ý‹ ŽěťĘśˇó_ł U˙zHńYµůw|3ő!6Ą´A©·c¶ŕŇ«Ěi3n¦ů Ą/kć)Ůn°ůĽ´[8*Ç2éG8ĐřMÇ0ŻgYŽĄ—ciV[tOó˝»ĺXš• öʱµřKCAP1gŞÖŕq+÷f!F» ¸ž!°çŃhS÷˛ľ“čÝË1Ć%73ĽŔt#Ą‡Ž+‡ďۧŔý3őĹÚŻUD‰źÎQ(Ľ+Ýč&®+F.~R±JŔÔšI<ŮlΩŞu‡]Z±˛ulĎŃ•Wb‰[H»ď‡ýp ía"ËŘ|đřҧs/˛­Éf€ÝAĄ9ϵ#!KKĺK1ÉW2ĽHéÜ(_°Š«ą”ŮŽśÄgpYQű0-jé3´ęUŕşŃ˘ĽÚ<ň°‡âĎ0Q›?~C•jô›ó34ľöE$bßá;HÄžÇßc0ŁťJyßt)Ŕx™'łö7qĄçÓ©%če -ŮtĂš{üĆ ąŕ‡ d sH(]ů{…ŔőQü~PýzcKžH›”c9\޶{­ďßąĐz@r™Ľe- wLAşű%5o“¸¬*Źş âÂöů< | ¶ SęQ„[ż‡FŹ,ŘjőîLŢŁ*©ä1/‰ię‡ ‹6%>%ÓěµËţÍÓŐ&g$¨÷ôF±ü&•źÇáč˛×/˝Đ;—TAłáĹ0µăJ čPHSşr‹)©€7uź-ş /4Lu˘Y›űŁalăłuď}BÎjţ†śeÇewĺ˙µgŞ=ckđłłkýÍá¶Ď}Čč#Ť…wcߥ/Ú.‹¨ŢBâ0[ĽŚ·őţ'ů)NŁFń=O¦Łg‰®A|7ŽcďĘd¤-Guv¸üYśÎvr±Ä}Ę–s3Á¤nŕŢ˙Ź˙żçs endstream endobj 125 0 obj <> stream xÚ]’[k0ÇßýyÜĹ$Őt"´^°sŰ»ŐchŁD}č·źžăş±@ żÎ5?ΓܚůŻ®­ Xclí oGW;ŔŃXOHV›jXżŐąěňü‹ç ˝h5:7 Ž1Žŕ<-ĆÂuŇ»¶›˝piČŇ— endstream endobj 126 0 obj <> stream xÚ]’M‹0†ďţŠ»,EăW[ˇkWö‹¦eŮŁ&c7Pczčż_“q{h@Ă3ľ3óš‰_T‡JÉ‘ř_¦ç FŇJ% ýd8.Ry4$Bňq!÷ć]­=żxŻőGÝń÷ěűřS>żÉĚ(Ő400˛]3čdÓ_Ĺú|*iJ´tşi áÂŐ݆şJµ=É2Ź˙8÷Fs#«˝čx˛±O#ćšęBV点›´ľBj$—ç®E—Ľ0蚩ռ,WN˛r^ąJ<|§¦5-˙­Ť•‡ń,‚8Ęí‘vŽ˘­ŁdăhZJ·H¨LQH/H¤©Dzu”H%VŮěśŮĹUüďńţO4t2şq[DŃ]„” É›ˇ2FeŠĘ•IŠÍÂĄ–·‡d‡|ź1źŚ™ŹÚÝ7D{ŢRÁý˛č^Ű,÷üś®© endstream endobj 127 0 obj <> stream xÚ]’ak0†żű+ň±cŤZË@„ÍVÖ­ťíH“Ój˘~čżźÉŮ Đđśďĺ^ď–ő®Vr$áŃjŢŔHZ©„…AO–ąB'U@c"$ňoŢ3„ĺ™Ö ËÓűét|®¤e­ôú şéĆěúr®hF´(>ß xáz×܇úZµšäy@H8§Éa´w˛zú O.öiX©:˛ş”ŤŹ4“17čAŤ$ ŠÂGŃ×Ă8X¦:ňh^É«y(ńďűł®-˙fÖ«ÓYEq\xÚ %žhĺ)ŮyŠ#¤˝§9čhó†„Ę *SŠ„–ZŮŁňźŃ/‹J¬ąE{OŹŹK,?Čmi„AT&X,Ee’`p‹(úÁ`†?ŃĹq=rłý-ź¬ť;í/€źˇk·Tđ{GŚ6.Ë?? 0Ąź endstream endobj 128 0 obj <> stream xÚ]RŰŠ0|÷+ň¸ËR4ŢZmˇ{am?@㱨1Äôˇżšcei ÂLfΙcçeQ ®‰ý­V&­‚q¸)¤ uIË™^ů˛ľ––ťÔňłîŘŰ÷ăľ:żyJsq+PĽŰ”şľr¶9ź4$-th9Ý%wÁeQÝG })ş¤©Eý3uµş“—m;4đ:s_Şť*Š y9ç•aŞ›”WčAhâXYfĘQĚȆFY3Pµ¸€•:ÓĘHzVfhźÎt5ű­•Q'“ÚqÜ83h‹(AT ĘíŃČ /D„>}^lP!ÂvđDnÉ>R­— ÔČh€uău]L€Í|ŠdńbHĚęŁŇGeĘél bČť!”x%K, â=ý­Ř[ †óžýq®Lä#łĂŠô˙ ç—çh#vSjzO3lfRćGĺÖy”ś]f˙hŁżŢ endstream endobj 130 0 obj <> stream xÚĹ{xTŐÖöİqQŚšă\ő*(*R¤*ČĄH'´P’RI2ée&Ó×ôĚdŇH2é@H€‚˘AĄŠbWÜĂ=Ü˙ţűL L”{ĺůžď~’™ŮkŻý®ö®u6˘>}DOÍť·böô#Ţ Ý´564".fYĐÖĐMŁ–Ç…ůo>2Çů¤sě,r>ĺárźóiOçc}†ôlŘçÉžá­OöąţĎ dHäAľ·=üdżďe?N~oŕłÂ+Ť‡‰î÷đxlаáâU˙ałi‘ćEĆĆ&ľńŐ—ząę˙‘Řîü¦Ă}¶ÝłÝůŁNĺ-„ľU®gżP é~eÝßý+Ţ4~-űŤźJÍ„^ErsŇżž;ŐHđĆBr“ýëĹ·ó~˙|ĆcĎçž{¨IŚëŤ|2 äç‚Mźe1dÁ澌4ŘíOW×Ú&·dč€0l4?ů…Ŕ„ÜďA_˙Ü“Z)-*šĚŇą ŐdĘŐ™PDűń‘gRř|ľ??xK0¤y¶耟ŻŇ)H™”›řÇi‚}´Ńó×oĹa'ÁHŔ-˛mj(Ô(0PĽne T/·ČáHöá˝xđHtc2-l4ćGÍö¤e4Fśą;ĐhS٤|$’tL‹ĹD¶Ú,ł˘°źôşÇˇëž‡v‹1˘,f'ÂN,+Ăť€;cĘ""0&#ÜżIkťmµŤ—iĐeOšâ<#.Ŕ|…=Ş˘·żŽüß_Rż•ş â&Ż‘%"ŚF)}/3Ä´G[[T7?źCÚď¤é€?Ä\Üp˘ký+}^ŔQ|äשy®ÓvD:R…ŁüMSăüA|Γ6S/1Ň ŃŐçšÔ¨FXşbëřŤ Ď0J­ h-,1" !CĘ]'E)g©Aˇ@‰Yűtuş¸Ë´íÚöĎÍX¬0Ă,C’ ?¶ĂNK­÷ţϧť}ă2ťţwâ¨3DŚ’ÂÄbAhĺ6,ĚŇ5ŕ>ÔXVĚ,ݍűˇ;¶âŔů±+/‚iÓ weřóÉľ¸;ôŐt’jlŐ BÎŰY]%(Liz©’f&m f–™ÍÜqď©“&üô9Ôą{~̰Ťßó*w‚÷ÄŮ“qQŹĽŰ>¤ł?Yő÷ÝÂ,±›˘q>ŕŞ%Żż ¦-¤@ż sŘ«‡đŁdä ăńqQ!«PVšľ ¤ąiöx J00ŕBÔ¦ăĽÎLôŰ×crăbhő„űéłĆŇf<X)/‹)‡¸’‚•LÝçŃnLµĹ—!Ô˘± Źź˛WÜ2}şÍůł]ŮÇĚťF1ňÍ„_†¤ăłhźSßĎ7‹'±CÓ‚íبĎŤžlA"GĄBĄ„·¦ňŔO~‰ )ć¨J¦ťűđKס_ŹE«uMşVlÄmµ›E×%lüšśB’‹y…Ý`Îpé–QKO·Óˇď[â˝é™+ÜUz†.ăČŐł!aZyJ¤$ĺI0! ă7^ =Äxżř©7ŕws/ó}üp“,QEt ©WU+÷"T˘Cßlî\ţI"7îęR…ŹrÂ& Ö‡ ”ap ¨ÁX‡p;ü÷¸ĄĎ;µTĎŇ fÉă zD\SRŁ+@řKFŕjfĽűüWŻAx —:ľXŞŻ0ďkťxűWÇ˘Ź·ÚUÖL<ľŔŮ›°`FŘü[¶ŢpŽiţ(¤^Ľ´î˙$B4f†§ ›§YŠ%ΆŮńŢÎ~\ťę¬Ó9H^ăWü_9‡ YrÂí„wńP(ňĚ*qš(EČ‚ĹQcć?Ç?Îě–n”e)á§Ęc»Ţ>ÇÎT}…]lŮţţ¦© ·Gчçp"ŕÄÖ©”YĄł*sŮćĽô:ÝxÝăôuĎÓ”ţ×´Śü‰˙ž¶d‘¸i—s@Ľ·ç‡ßÁü=źÖ‰ăPn0Úŕgj'f$ßđĺ,ŇůŢOÜI‡SŽŮȢš#9ĚżFěˇA*ßž«×uę±™…\­[ČBŤI{™/8O‘YTF;_üÍ˝ \±ˇgm…®FWÉÖ¶këÝÖÖó›ÁKÎt=č čđľ~‘†}z•sŇeÎ61@Űe„·ńĂpřňâđIÓX6łřć~ŁđĐT 8=r!?a¦UŕQđs–‰ŃG¨»˝ýiu'ŢĆ C’[ahÔÔŐcVh. Ó‹úâ…pą6·sB9 KÎöň–ýxđýËüB–Y A KÜ^ŇfçĺzŹúŻ<é ©ř;ĽŇzň (­r!ŰĚ|mNŘh†Ä8šŽDú ŔŇ3u-Đ~ôđŽý ŕÁŘ9ąb"ŘU6C¶”űĺ{Ąť°Ę´ľ‰áeś¶Řć- ŽĎ0KO˙ŤŽna;^×8śź8<®_tŢÍ“.» Fg,ÁÚÚ\ćŚ4 ?ŕg ?š-XĎ?°šZđ׌"¬fxfx¬ĐÜ t XŹ»4ż¸đxšQ“㬒3ç]ČŹ˘Łřĺěl¸\Č´ ÂFZßp2ľ,ž.o2Ć{˙v‘ë˘ú/ń!ąĎ%¸Ç^tá,’łP2ěšl˝ÍÜYesĘ5 +ˇz­Ž•rîŰ$u¦6†ˇ•…$ —Ü‹žőş#şvhV6öâyˇ¸ć¶ç˝—ŐRsş>M ń3BżÎ$LÍjŤ&_!ą†XĂz0+ŠŃlm…v:wčş2ŕşf * ^®N{YH÷Jč'Ëđg@ş’ÔJíÖn@¶ŕŇ{¤V×®kÁÜ×+8o1¤ë×—Ň:šYG?Şó¨żć|ú˘§óω;Ťĺ#>ŠąÍ\ú?.c°öÇ«ĺ'C†U™…Ůl90/+°í4“[ĆäĆh·j0×é6čŘnL‡¦C§j»  Q$tË\#xü8|…ľÖÍ,fPBŇ~Lú0lžÄś?[›­Ď6z—Ş)ů ,˛mŞedĽč ôŹwŃúxćčô[¦č˙ “ťřóÓi—ÂŮ6jWipúöčŕ?đß °Ořò -[«qŁ.č.Ëţ„ëÝ^u ×=wĂŐ—PaŢ÷ËZزzG{ď¶Ě‹ď(”Ü$śŹEń]·AëËĘ·ö^´lŃ1†Ë´Ü«mąŰvü-7k<(3;•8‹ÄÂfGÜ ńÓ˘!V»mvţöf Ůů殌Ü,ТT»<vYóÎT —``đÄÁ««˛škaOýáýHźŻ],§W5ТÁŠůôŐ['Ą‹C»3Ł(čX~ )ŠÎŤŇ3ŞÖ©ŤEş]1:С­q;F„!ŇVÇZšC2ŹdbŃYµ@ź§#Hëľ&cSĎY´[´[Wę6ąťĄNíPůŻg´’źI$±±i!jf»™Ŕ|ťv­v1§^o·˛rŘ€­wĹ|.6:ë¶đpÓP$Űńk!OŮÚm'ĚűAjĘЧkXžÚ´řiß‘@L,Ä@ç¸?¨µž©ĬłV·î^ÔjÔŇ9„0RgKvJśĄôAžP‚ńެŐŐ;ÓéXnÁŤĦWUÚ7Ýj+Đ•ě4îĐĎ1¨ŤŠĎ!Ü9™¨šrOo+Ĺ?Ş!|ČM#QIŐ* ‚Ő&upóy'뺇éÉ-ą§TfŤü ŕÜC‹Ň·.UŢ޲RW­+Ă2lŇVşm9Ϥ¬2˝ \Y =p3źäćL3‚Ť#ŰŇĆ9+„7˝~uňfŤ÷ĎűśĂ÷q ÎN+ë8ÎLŔ 9k>1e[D=đלs˙DŹV»Ő•!ćh†ŢD‚ă’łä·uÚ­ka:•2vąŐ’dÄŻËĽCwće šdgÄ×Bľą€d§äČňY B«]h†śéŻO[µ¬ľIÜŇĄ°—pZ^ Â1ŕő»´ÎyŐ•—籺~áĆ}búţÎßÇ*9Ëds&ĺű˛\ę…üýÔér¦Č¦.ţŔ2é|+ ©ţęĹĎaYÁ:>~4ň+زŐôţAĘč&őÄ/öv~M‡JÎŕđňa‘itĐN‡2Ţű׋4î*÷]âěăÎĽÚ3§đT,ň“ ZąáE„­ Ď0ŔËt˝ř?%žZ|§Wcýš1ĆčJŹSI‰ĽL]Ëtx;Y—yđťŔßůBżµXŔJݧ›pĄ[}ăľ»ĺŘ^żóA‡ösüď3Ź>Ŕ #aá–ekCü@.Wd*3ˇ1žŘ ěyąąkË10ďÂú„Ć8h‹jŹú@ ű»*߆$;‰‹ –2˘íŹŰüŠ`]Éę’% ”Ł\ íuűŠ«­đyîű»[Ž÷ ž)­ŇHh«ýíĆ<ěkn7-wţńQ<‡|¦ŐĂ3#ŘľBÉJ$¸Ó^ËöśtSÎNńą€…)ą±đ;?ťě\»ŰźőFyX P)­Ş,XŹ[Ń»÷¦›ČîÜ/÷ăo€íIÍÁđmY`x a-úËeĺ"BXYű×lâvnkëUľ¸Ý=ĺ>i]}ÉąÖáÝń•]ŕZśOÝ ^’Ą/dÝÚs8n.> 8ô˛ďˇp$öŁHřęz˙)Z´;îćűiF©FŞăTc´} ¤wqG졌ěή-ĂuuGYӆק´M®‚E%Ď70ń펷ßAř«ÍlMŽÎjŐ^ŐéđŇkjśgłXkżí"wŠţâ*«ŢŹŰX×]"ж肩Ťą:+ëÔëĺ­Ęm  NŁ×2hN…ŞyOĺ?&˛Î˘~*3Š)ČŔňšFZP­—®Ěđ›Ę®µ ź-:ßZńÂ>$őh Â… B± Â)n#§]°ŁWdLąŕ{¬w8_ăqů"ý}ź'}ĂU’óLçz’ţZíV’K tËGn“›Ý¬$űŃGa®îŹűX‹Og3çO xľŔxÄâÎub1ޱ÷ŇqV^ ĆW™-“Ň'…˙;˙šŕx·…ď„5mšŹńx˛Jnô­ńбľ˙:ČÓąÜůOńGJŚ’ř0NÇÜE‰„ďAbŹsNöě ]Ż fĄ*D·ą{?ť°_§2+iűl «oZ‰9Ů"·!3‚ĹjÎŕ´Â¶üĆw{D„kCʱ¸^·ŃMe/ęt)ä­§čt:my'=Dç~»Ńá<&ćÇÜśMT:ÂrľJ’Önqă©›™B[ÜďwÔ%aÖh(ťGŚé)Ę…Qmđbľ•(™¨çś IzívS­ţ¶¨ÍLT †`„.ÂMT‹Ú˘-ôşřf1%›3˛rĐlłNż Ö"É„`Dc†9 čýüEbN2Ií.˛My@×9ëHNí¶ŇÎť#‰ĆhÜŔҢ›Îż5«›Ô)~ŕu‚9úůÖտȿxCüŻt­˘3ůWčög1kÓ6iŽÂ†6@«ÎjµDgîÝÚ–Şśă¤7ąöďµĎuˇ"f3đň3B¦P«Ô¨2*-ŔßG'‘&UöŰ=Şnb"—nÖ…»Ů{—şPŮĽčP~ÉJ7g˘Pˇ’)2Q>îJčş-éëUwh@˝®”•Ü]Ú&·@Ů`H0•9€>Fs–Ůlpˇ¨6gkRf’ĆŚenä…ŃlÄšŰLBëJW§ü I6˙Ăŕß ™ŽNýôâA:ź”>Ę}HżtńŃ'Y˛ŐäWkNÂČŽŽë¸s‘ĚHÁ˝č·=ę|©$xO>d¦(u˛|ÖkRłËh»O°6č®ř(j—}”Ź&áF)nb±Čý)}ěg¸Ű{ĄîĂŰ „Ďä}*oś«ô¦˘÷çŇpî"ń>b–řB°o>|‘ś-ĎFńNĆ/gĺŃA6†Ęť·C„' ™ür— j6÷}&@wcą¸ű=¦J˘pÚStp†%'°,ÇäLČLáIŮň;o»ä –6oÜëěSă]÷ůüstâ'\3mĄ©ŚŚ=F0M!ĎT@´$46a5Ć5 Sľ–âÖŹ ˇ‹ź$6‡eGµ#°>« ¸¸0Ť]eÍ0C¦"Yš&L´´ŤŘĘŇŰó¬6}műt„É8É—ĆŘÓK…ضbĚaMÖ˘1‚Ö 5 MkŐ®ě¶%ąĆŕrµJ­…‰Â5Ź™˝çN~;ú´0®ĚÚ〢|â5LęPKśOíˇz#ĚźtŃĐK\-Ë7˙W”VZw"Ĺöiř"3WßuG"„ˇ¤$ľśif Xl´ĺdĽJ¬P¨ôhe/ľE8 ž061ŇŹ•Aƨ”ôŤÔ5h2őÉ ¸ýj» _a ¦ Ô&ŞS«5ešT,;Í6k–lvv”&T*‡ú逫HÇ3Ń^cĎNĆĐAIa‘̦H÷9=k<ę/y:‡~%VY3Ť2„nđ‹óCŽ ?BÚOZî}ŹŐ¬w0+ƨ\Y1B1îČlŃą´i„đ<ćéqČeçźG˝ŽŕÂöĎŔkś´MľťţXŰ Lă%ŐĹ€ůž>$ĆMfj:lÚ˛%™µ„>¸ě¤žÉmĘ+†Ş¶]†"áIyZQ,ä&ä|Řd´ęur0Äd…0t˛Ô&ťYś¤d[mŢQW)Čc:ß$+Ä}ĚyW“{‘„ \Łq‘ţŤ¬[ť‡â‚ŔĎ/z1NcŘ"˙ŕ±±T„ĐőEűšn/H÷Ń€F:€Awú^ň¤ŃZq!%§­e‚7¶Hą2•2áS~ąxSPD2ŁzÁč_Öń5é­xhˇ†ŘŃârą á_ňO!L`7 ů‘€Ër}j‚ŔĐĂőÇx°¶i?¨m SşŽíŢP(q>ŮHÓ׺<é W6*&W‘X1×(xPaOŻdôUÄhá!ćýŁ[Ëj„‡ ůéą!•ťęz>UVŚE€Ű$ů˝-Ú„đ ŽžŽüŔ˛ I"*Ó10Ť R§5 ź•ţb–r’U>Ş;#¤Z–E›poŻŇkF…Ŕĺ˝Fň˛zşäh„>UEŁÎúT1G¨>µńłičšóŰ:ą‹éZ-ĆŃk6 űË>řŰéňşN;;Ö1ŢÂ}2†_Äďg«ó59U¸Ă‹ĐÎ2˙ÎdhŚł§"kÉf<4VŔř•ťxС/ßÉúüΧҏm›pÎâ„ü(áA†oRt(KĹéY›‹#ŚĂÉ‹đ%@ꞰQŔ5űEĆ$ű ‹"+Ň€űhŚĎ–Čuč8áł(áŃČHź;TXťRQŐłtLsîżDÜŞ‰QCŠVŞU é'$w3k‹íP–şCŢđ~ډ߶Ąnʍ‹­(—Č‚µY&Ó™#eTŔk)3ńăű»Łć‹.ş©‹ű”NˇŤb,¶ÚY|7Ôw”0aEXśfŹ[Ľ> Ă™#Ź$8YŞZ©%3ŚIÂtR0LMwonb†Qša™)Ăź±¸N°Sµ7¶ ’JÂě!kpQÚÂ9 VÉĄ :G¸ďî)Íc‘®ZŇă5®˛ÚŔöÝá櫌2—CđçŘáćY0ž>ü#;Ţ—?ŽďâŞč<—ű2¶íĆă–FĄ!!2#@6[…>Y/PB›BČßüJ¶e†zˇňΖŤ®Ł6ôCpU Ť¦\óg´ŁË˘Y€îŔ˛íX X&ŮÁ‚«‰ÁČŚaŠ}ĚÇěqţłGł~ś(hFčiVŚĚńSń®FČŔ4ŁÜR[z~śđ›$^x:Q—Z(äĹý†ú*hkŘqérđ_ś«:¨ĚÎÄ5§˛$ň*Nb-řěr:©†Ú׸ÔE'ŇŃÜ—đ&e¨–ą™@0}-3A©»ŃŔˤP›«µ©!;Ó*ł'ÇĂÉÎ@{‚.]¨i Â@­DW„UXĄ-r[jÜjŚr˙}•¨Lj#šŘ™Po4Â_‘ĘęÚ¬¦«ŤdŚ>7ébÝřĎŰŞY:ÄF„…F'@\rTz‚0Pű™pżßŁyń %7f ˙¶‹«˙¶űĐĘ…nłěú»8ÁBC†kćęô'Ü©˙¶Ía•YŤo°žaĄ+ú ńŢßtŃeÂßGžäöŃ©ôźbmĄ¦NiŤIÓmÉh7K2;*qI·oNNS.w#Ş .µŞzÍ«VÝĂI„űôV\75ÖU dG Îŕ0I™J–iotů­ÖhËÝzµQfrIO0sµvŘ{ %§QSç’3SH Ę•’SŰ ·ä,ż-gÁ+)§Ç Ďţ$¬\jµB©±‚´9¨z%Â\꿸}JĄ\ŽvđZq®kżŢEýşE~‹aĹ5+ä «GÚíšFWó×°IU‹ÜĆ|M.%+˙›´¶=é°ĺ^ҡ07Öu ü«tČ}¸—Ą-ž^c¤µÎk=š/QĂ%Ďfę/Ća'yB‡"Ç}ĄŽhŮSô.üu)}€%0ź¨M~ě—°ßb ,ő_ÂŻ!˙,SËűͰµĎ`(#JçX,_ů’eü×ůP Ťu8I+ňĽdĆ%î+VÝ/+Ş[+w {uÎp1ŇÉÄˉbJ̇řm*3Ö1ý߸¤Őž \WB˝XS©­@?ű_Ażů:ą{ííB3oĺ *"cÔÚ”P.«TT OXŰ šˇ­uű1ü¸ońúßCX‡+Ă7ŹłJdí¤×K®ÓíIÜćĽßÁÎW{‰ĆuqgéYgqQś1…Ą6ä“&j•irMŹŇ& ~6aŇ Ő]ťČËöô’­Pv3Ć•ęî!ę]‰˙}t–ł°Pe3.&GEffĂ$-QĄNĎ‚-EV×pěó,»Ž~—>‹°kĚ ĽÝĄ9F=JXć‰)”Đkß/8Ć”˙‘‡Ëˇ3™‹kšşA¶ţĄgłú¸ŔŤ0u«ÖŢĎÜLéČO®+ěĄömť_ZĂh˝­š,¦ř!‹ÔžV€P†ĄĺXÜN,LÜé/Śé6n .G‘ˇĚbYŮ‹÷—Öh$ÎkX®ě,Kú€>ý1·y/,6®1¬E°ém:sń* šŃ˘íňíŞzÁśżlÇO®išĂÄo_T‡ť€ÍuĄav83çe0+ŠtÂłËlCťľ^WĂ>fňÍ])<`źë+Ü)š^vn |Z(XÓ_‰ŔŽŞ1Žq+ÍŘŁ`˛7+Ě Z…‚©Z-í¤ß7Ňg­Wş(ĄŻň#čţďôanűôM–Lb]KnQÚ .EĂ{!ŕPďHÚ±.ó1ÉQ­R˛đĆ+Ľ¬ŠS‡hn'ľ ĺvh+ÜŮđ/ÁĆLcI5Ľűɲµ¬ç8<…Ôú&k¶¨ďTÝ]ăî۵enK×R ‡`,ĺʬ5ĚÂľ~'őme¦şpąJQĽ6ÖĄvd/µą+oÔ«˛Ő1ˇđć"—Şt™Ůŕ5…O9çlŻń¶ÓQô ú:?˝ź»Jýř âü9;ě•pžú´ü˛źö˘]ąůmćž]~6‰d›„ő2wµZ]­H†řD"O–©3‹` $‰»”…oďŚg…2ĎŠw[ۤ̑U,Jř|bŤĎ['Ť„ôÍé‘)aź*s=łV2„ž.%Ó%EÉ۲ߔUwśĄ°×Ń‘,ů·‡.CôoŃ3"ďz§'W˙sľX*j@»^"[V•]c7@чU•:?2‡ďű<˙ěkCA–ŽjTĘł”y,[FŃjbwä췴ܡOgŻŐ§Fčńq+µŔ?ŽäŁo~ĄcŹý yĺ†,4şš 9K ©‰`ůnľp$Í”*Ô‚)üÚťg«;÷vŹzčŕcž4a„¸m©¬´a´$5!3ŚQ6ËŐrL‡ňڎşĹÖ*ˇm+ @ˇL›©âC¤ÓĐ^Ňú1üoĚ‹8>‘ö‘BđbV|“MW˙źç+<8ĎŠ_çĚ4µ 3I, ‹ĐŁgóXJąźzu6‰-‰Ö)¸ZµĽÖRŮ>ŹýÎĹžďQ™Řů’Ě)îZŐYLÉ›/·¨Să´i >}^XR{c¤ç>¶äFź?.ůWź?-áĎßXďAÇ4zRńŤ…=7˝Ă*¤÷zÓ;Ęi˘ Ţ{»¬•ě‹;GËś&q–0ëVEŰ  O2c)`q]ëţ@›ĆÂZÝEK|qࢊŔ&ć\cńî‹8ç]—qçn-d ¸NđX#íßčůŰ˙ä ”íý?8¸šMđ8F<ŹŃ$1ľŐ±ę]aşÔŃďľ»Şă-á*ĹŞUڬ{ŃŃ®ëítüu:î//ąÓmřßß/řďď{ĄuĎň¶V&ÖzŮE}»¸OťËnMôľľ‘&zéZĚČý°ÂZ"ĐÁâTk<Ř$¶„íB”—'Ě»š×ŐL./Ť ]ÜwieëS˘-—¤Ăě€Í3‘÷‚5wň˝{Č—á6äcUŐ…jtôş7˝ÎÖÝę{gنže;YĎĺ`Ëvkw»W˘Oçtwłť Ų`m pg:€đ‚«0u:™Uk.„âó-Ůy }[LöV°Ć[ă+„'˙zÔëô:đ qa—O•ˇSʰŰěÂ.pű°ńÖĐEˇW «ÂÓ#´¬«ăWwŹDżq\8‰°YÁ¶ş8ĄJ ¸ĹEÂÔĺŘË{G MĚňÄŤľŕżF¶_L!÷Ś•aU‹µŘŇ«#™o”ö`5IfĹă*áľ…«;XîÖÔą®F4öşňzk奓vF»\ćYۧďk]tE—Fg8˙.¦+p˙»Dą{L˛$š(T2 ŁĽúX”á$áZ„ Ä÷Őí–RČ*+ÎÍfVąIö°$Ů3Š 17OŔ2_VźńyáÖ Áë×%Çlđ€Ě8ţ/fĚ\ÚÝAÝÝëqß-?ňúť—tŢuĽćέç)ŢKĚ?ŇÎß§ ¦tR­T ˝Ń`Đîʖb‡.ĺśÜÓzâöm‹˙tícŔ Ă Q–”‘śkC" )žŘrm9Ů9PWl˛ zN ý}álŘ™” żâOőďľIŰČĽMSâV#ĽŽ«rÇÖݏ‘rŹ·QĽřIčpľďMűt×qť˛l‚Ą×,»@fĘÔg¨!yqÄ–»Ö#‰n«˛Ą%?Ď65Ý!<µˇ†~˝.¶Ue«\7Â÷iÜnpp§öéŢÓ1Ű{˝"Ż•IJ%4h'ő©T c.sSéŹô1ţ#6bÂáŇÉßX>˛ŮŢÎ_Ľ?†Źăe҉¤s7çl®°d)}Ë»[¸Re(0‚ŢĆĽ2‹Uěsü~8KŇ«Ň Ňr„‹Ó{G3žü|e-?@¸E´T.xŽżŰm7íąő˝Á şf] VaMŻ<ĹMő5Č\Ď?¤ÍÎńżvQS›§sýJěz†:GńŹ ÄDň ^×ÓÝ^(2Ú¸1P|7Ç2—}ńĚFz«P/aó®›Ű´ď„„k]ä8¤o˝%Ä‹/ęý\‡uÂÝ1Öa)ůcwKńő,Âţa˙é“—đż4r>1đąA"‘hŞđß./y§ŰťÓr¶Ůé#¶ÚśJ[_^–}ď—€˝ÔopĎěěgŘż®×€ş»,p~-ţż-_ą_ endstream endobj 132 0 obj <> stream xÚkHŻ˙`˙˙˙+ ţŔŚ Ă0s¶PË< , ĐĹ={ Ě endstream endobj 134 0 obj <> stream xÚŤX tŐ¶­Nsᡅ”­Ď˙#F"ňD™AaÎ@ćĚsŇdčîěîN:óHH@扠PPQÁAx‚¨|TTô«·±půnuŃőłVWwĄnť:gź}Î>·4Rż~’FŁqźµdůs+žřׂ@ożČčŔ°¨%~‘\âčâ«®™ë¸Óq\‡;†KŽ»5w‡»Öń?ýFąj;\űÝůӻʙ;ŮźţÁî’$é‡[ÄQ3iŘ×âÇ­Ç\=Ôóq®÷Iý5š;†ß?z]Â_=j–o¸·ß<_ż°čŔč„GÇ><îńđ„Č@˙€h÷ îăÇ=<ţAqěľ4ŔĎý7î‹"Ăü|˘ÝgĹD„GFŤýÝ%§}÷ëˇ?7I–n•ôŇmŇí’‡4Zú·ô4Aš$Í–—ćHsĄ'¤'ĄyŇ|i´PzVZ$-‘–JĎKË$/­¤Qď. wż–KG4žš\,Ú[µý¤~,şż¶˙®—¨rࢭ|˝38Ű5iČÝşuş ·śúčĐ‹Ăü‡ťułËžľču\ęŐŁGݶ×ń­žOW ˘Ö^ŔúţăÎ÷÷ťâj>SV‰3Ĺyń"ŘŐI?×;L`¸˛]ß:/s“ă•J ÷á.ZîsFŹŐ‹±ÎDYY±gŃ.ËK7şq8gWNŻë˝v;j˛ěä•’=‡;Ă~Űëˇ4+7”ä¬řtň ›¶r¶/YSóS ÔSűrE ¨63V’Î :Ň:Üz˙ĎăĎË'÷9üôމŻmA}1vňP`* S~NŠ µM-űA­čŚŔC„y)k=—Ňă3|ń{âÖ`ń+`ą]öĂ%ű)5?ÝšJx2%ѤLîýříÖV:÷Ńëoŕßr˙®ń ů¤2ó'âáOz§ŁµĂíĺĎřď&r’/óTÇ[úh Ăs„Uaó•d÷aőöŞÜ|qçĹĽ–ECPôÓB"@A©1TRFir©8 EL ë?‰xÄÝŔĄŕ§żütľ0˙i[őű¨#tżĄô>އ÷$,] NŘ›QM8r¸¬¤f‡ßŐ«áußiyťĂ ‡RĎ”y`űţsä«cź÷TęőcEĽ‡ˇíÖ2[Ů"°LdgŤ´`š"@xHą—lÉöPaŻ‹˙ͰÚďIî°ěA;ŽŢäX3^ |Â>+Cy JEF{şęVęnţć!>섆ă´â𦣼[Ľ”„˛Ô:2T'U…¨h$Ä!†°îëŤ[ńżß`Ěű\ÚĄĆx#Uđá¬Ţô¶ąÔ€ëľ\*?Ćâ‹Ř3™kL+@đ¶®ĚĄĄ—ŮÖX PęĹ ‹đ€đĂĐĆwwń VMg|.gZ>–7ę[Z·[ËA˘jVÜ7řúÖcařLB1Ş,ĹÄ«ř‹zk1ĘłŠIš95|Ţ4{zĐXډőçCןţŽC;Ś÷{cřmĘ4P8‚2ÂS©ěřŽÍ-těřĽh#— »§;5Mü6­c€A˙>ŢűögZǦ?2;xŠHňÝxŠŹ!čŵç.9±č~tçj+`†ŤŻ'w+wĹ ˇ<¨Üe…đd×(“xĽŔ\‰•zŞIó5×iůĆôp¶—Ut‚ĘŔň`ł!ŹPÇ€‘fřb´ 5›˘˛sMąÎµ(OC0áŞ0śśćJ3ÂhB!šYĹr\˛¶Łßť¬Âd-ÝdËv®őFJ¶“îxÖ濾XŢĽ‡ďîtŽń%ÜU^ăçĐcäšŐŁA^*9[X]Ţ›Čîaô®yă®ezpť2 Wqń„ňĎĚŘlB ŃfĘ,°±|°mČMD¸đ3–!<%ÉŰůěl~ď'żĹÚ"¨űţ5ÚŚÎĹ>H.Uű _É^ÂcY$ÉÓ?S¦˛m«zü^•ŁÍşŁäÍĆf擲9f7ypO&Ży§­{/.“îiC§!ÖńK»[×|ĹŹrŹĂíĘ`ýŇ‚¬ÍcA0rW‘Ł\żđÝp:Őŕ‰Ĺ„Y~>3@OaŃÁ¸ äcbr|ŃŚü•VOŞDa^µč =u¨NţJP ?>>~‡đoČű'6Đúň©˝xp°nʍ–shśZ5Ź:ňئ˝˝Ćý¤{E0ŕŤ=š†>S`=łE{ë¤óWîĐÇU°“.3ze.O_Fí٬útYŢĐ~°V”lB¨@1ţW7ţ Ĺoť ňÁ7Aqăo(:bK E_;€ŇěęÇTďŇ÷gľdÜKţF†¬ś„XAUÇÚÂŘ+¬Ń ?mřy(÷ů ďŕ÷ĘçřŃ4ýVÔTî ®ĺź1Kž5ϲÂb´m"Aô3¬(¸4^Ô÷vTT”v|”Ďp”˛˛Îâ’vP1E/ ś,··—çc=¦Xś^›úXnĘ5 –żšŚ4R)?˛Ť3XěŰLéĎżań‡šD¤$*Ĺz˝Xäc€2$Ç >Xbą^/Ѣ^ňLůęZ&iGUJAmyšĺ,›°‰jJ5¦Ń,%–EĎeŃď2A‚YjkU®p4ą6‘Ô0“Z‹çxÂłob»l;Ş6Fź}µŽÉçŠCË€ /-?Ŕnsků~ěE~—d_Ţ$ÚX‰ß¶¸Ă hëČŤČßT*˛”…ś¤(/rÚTać÷‰ŞóĽc2h6F,Çł„ŤĹI-*°uu(#”d«*SÓXÚęÂö(2=ËähŹĐ9ÁJx˘Ń˙ĽŕŞov×µ7‘ĄU/GGĆÄ%€V"ą̈́β†ă[čP%Ó:ŁcëcűřŇ–Š"Äą˝Ď]ř4>@.Hç Šb•5Öl)¬íE÷LŚUŁő™6U(5’퉛Ižś®¸8rő¸šÂŕ—oŠ"yIzS“‹ŇöłşđÖݢ`´B<.‚?˘ęřÄSŁ@~ ‹§óŽÚ:ÔI$?Ó¶I8^–i¸/ŐŰD¶0A ›ŮÚefâ9Ő(ĘŔ|ŇÝkŘÇîŇ´ňţZÇčóú¸ÍlÝĘÄ  yX|R¨¶0Şí9*Ź6”ůÚ‚ÉQ·KAŐVµ^öęU4˘y ¨‘ ĺ¶ăSřĐ;8ŘŇp„ti†Ţ´ťüË®_iĺř|î"oççů—BČK`Ś!ôVwSłöZłčć;±mcM 3őň®Âę¸YT×B‚âÁRĘŠ“@Ó±:ĆŰŹVŻŽY9âÂĐOĆý &zkI[#™W±&Áj˙ĆĘîŠ7óÉĽ“-ËKß‚ŇM3ä+;řŔ.!eřcŞ´Źĺmú˛o_-ߪGçFřŕĐ,^ę-¦™ŻęËÎG";®ÜKy–O“٤ŹD†n„Vîţ ]9*ýć˙Uäš‹“ÄÍéµŰ×WúSi¸Čl˛č±}¦ö:Mď3e!mcČ5YĹěfcÉ–¨ŠÄm¤źÁ˛óÍąB‡°ď@]=É]3ëęZëŞ,Ô`e…‹EUşk2Ăě‹<Ő7Ďe‹‡)βšŠsh‹™•çTÇG…Pthld\"Ą¦Ç¤Äš„Łçol‰{¤żˇžN±™›ßäD†]äc_8ë˙tü î\c6&·ŢŕƱżó˘Îü‹4"]úĺ—˙¤KÍürKŘA[śŰW×Ęl÷u Ó›EďzĆú:ű•s‚ óśś ĽĆąL'çĚŞë™Á™´éO®źqşţÁoą.ţÍyŁ……ć'˘^ XĹzwvVmS ěˇxR Rk)3$Ś9×9´ěWł8©|łÍMŞ ˇŹ?˘I\H>î®Ęčň(O_ŇĹşýŐÍŽűň!ZnsŚÔżŤ=3úTE^%6/“±ëđľhŞ źľ!T'DńÔĂă”(DŃaůCx‡ó*ľ_ČoQ&Šë÷aŠPĄ»DV‡‹ŇÝÇŮě÷´4Äą](â>×P´üĹĘ›Ł(*7"Ń’E†?Uîéż71_­Ü­ŕţ -ĹuĺETRPW!u¨ >íjóݲ»„lÄ4ř«»Ľui+ńěM ńĹqđ%¬Žűö™lLřX<Ţ×đ.?őż-ÎíSî2ĺŚ|™ŻtÜ®? ¶UׅŤ Ëuo3ɧ„0L1x‰­Ş|9 NBÔ5‹p÷‰UĘ‹ ł[ÂzŐÁmďÖÖ˝]Ë¢ăÍBýS‘šŹ7IWlčĺW›‚šÝÎ ˛?$ŇtŇáÍQÉ`č°v©ő_s,"0±Ż EBY®™í4 Í+JRwtĘv¶!x}v (AU8+čŔĐjéqŢľÖś1Ű]o"rŹ0`ß'…‰Zł=IÝ&(b:ť[ű$'őŤKOů drŽ ŰĘëJ/”PÎNöĽÍP« YJňŃů?8¶6ąń…|)ż]ěŹćđĎő•];6ďŮ‘—«ٵ};R_s$ÖâÉkľ›úfu›1Oťw¶¤‹Y=a±Ź˘ śDcąŘRě,(ëPwv ňŐ9ݨše^oĚ·^÷#ŐM­Ů®j]IRő â÷(—Y‚ ›ľ1,”‰¬‚,±˝‹Č,Š/CQBÔ7-ŢRĹ4sÝ'›Î’N}O9ÔńO×űŐ—Ź©Ż?uK+uĚ)+-ű´ňhĺö‚ţʦm†ŇĆüâ:Đî:¨iw\“gµY­6őăęĘ]ňóŠ\‡X\uŽýí¤/ endstream endobj 136 0 obj <> stream xÚk`°gŕPi°Ďť§iî endstream endobj 138 0 obj <> stream xÚ]X XMéú_Ëní˝$[µ­p°÷Î5„!ŠŃU…n*ÓUwŇ6 •CÎ1óšf\ŠAĺRb¤\Š!jw%D„ĆĚ31ď—o;ó˙VΙ˙ňő Ős‹!ě¦ßI‹aňó‹áśŠç­l´Ă36mý_üŮq†ĹńŢqń©+’W¬rp4n˘Ă·äÄäÉĹÇéăbVÄčc ËWĄ%'&­ĐŰĹŽŇł÷DzËd{}PRĽŢĎđQrJJŚŢð2•ÍN6¤ęcRăôAń)ń †ÔäŘ}ŕ¸Ůăd©zY¬ţ?b˙ŕŘĎŚ¸žś9׋łŕÔ\Î’łâ¬9 ×—“8®ןŔýŤČ âs:NĎ á†røáÜn$gÇŤâFsc8{n7žsŕ&p“8Gn27…sâfr®ÜlnçĆąsś'çĹyss9Ηóăćqóąś?ŔrA\0· áBą0n÷>ÎEp‘\­ŕxYżyÜĽěîs®’ÂOă3ů2ţEŰSz÷XÖŁ¶*ć(ľUüdöžŮ1ł:!P(~Q:*”+UV*U™¨ÝÄtń€řGĎá=˝{®íą»g‡ů0óTó˝4˝Öö:Đ«ą×+ K‹ˇŰ{s˝˝{—¨űŞĂú}<úüŁĎ-ËŢ–ł,YvXŮY}ee˛´>§1Óxh šýš[}­úNď{¤o…4^ZF_]Ŕ5áńs¤ě‚őÓK/ćWśŞŞŞŇśËzú¦Xôf™:HČTzs^˘7 –xCIG˝­•ĘUuŰ N@ř]ÚĄÉqÁk—ŻŮ¶n—öKřró–Ďżů:ç‹\¨€Ë ffĚů§č¤Z˝s}öÎěm»´š·Yó'Ié»>Ţ·o×îÜ}«weh3VŻÎЩɇÍ˙ÁÍâţŕ²¸;ÝWz’ĄŘŤŮC@@šÍvu?¨sÓŃĺ¦Ő˘s‘¬WH.=©uV@g7XAťéřďíDď6HˇiŽ>wa%uŮK.ß7B.ştÜ]fSi8Rž,ĽS ż~ŞŔÝ˙ŐĂ–‰¦ú7I 6 Şłę1ŻłŚÖD÷Đű±ćE7˘x¸ P<*ś)=•{Äć+‹gMőIđÖ-†u^W@Đ<»m©Ýä€ŕ1ş@đßwF Ś.řŢ7´…źžö‚ß]/;o5/šr®×Ŕń‡éw©ŤVzg#‰g}Ó¦ ů¸Vš!ď)7ĐşЇxş¦‘¦Ąŕ‡'¨s:?aËô¬©ĹůFŐmh`‘÷q—»dâésŁňŰśCŰľ±áRíˇtĐ-€đÜÓbH¨p1ôFĘqHg'jQëz‡ l ‰Żqć«d§Ţ6˘Ż‘żű )đ ’Ć ,íš/QK»,”~ŕ„ŞÍ·?Ż:y¤ěSĆNf3©ď"qźŹ€Ű›°ÇcŔł"Nu{IÇi×™úH3? /‡ßŕő™ËOŕ'(ÚD§&E$ÎýŚĹNÁE8…GśÉ2GŠ,J8s¶¨¤Ľ,ůxxDrb”–ľ5‹(JbcĹgĘ’KŘXBËć—.ş@ľ–ä‰]¨Ł?›±1F Ëw¦í[-ľO݆ű8OČ9şe?Ł„ňw”ŕŐ„ćMükŇ_AÖ“y’©˙Ň_IÍÍŢݨɡ žř5)P"ťŇb|M—Ń×4µÜŹXâ:x$¨Ś+jđß×ŃŻĹúpÎmÁţš5XÂŇf"ŚY:ÁE< ´ßjý†ą}ŽĐ14P§©¤ł6Óľq)yżkńĽ*đpÜW,’,çLĄstš5´˙©ŃČkďÁ‰Ę˝gĹ/•šĘĎŹmg‡Đ·č0: émm‘ň`ď?s׉4[µÖ>ßÄů™őĎŃćPm§NÎ.·&˘h ë}ä2‹ t“.Q·§@WtąÓ@Wľu—ĐM8Đ$ižˇ’(P0)dNÁ-MÖhýS®â÷˝ć7R‚ˇŚĆ{N;é’-jHí®š3đDÄ´ĎIÚ[K]Ţşă<%Zc˙38ZG{aťä‘<]KöJůŕBę ťć·C´Aî”饥JÜ‚=•mu Ń©łZȵfľ¦SodťDŃ>t5]Ťý¨%ÎĐý µEĄ§ÄČËBBj„Á…ŮÉܡc0áç&4Ó]„sź”%çŻA§ň&0 RŢČ?čŔÓϤ_Hx’NľD§héH¦ăD%Ĺ™W±T7ΆŃ4f§ťFĘŰ”?˘rÝŔh·75âjV'¬Yţ'‘·žíM¦oÝÉ0€ZÇHhnh¤ŰŢŐí« ¸‘­Đ˛Y)ݏ.Ż-Żč`sŻâyŮ™¶šńÍřE3_ţ ëŘěş,é9Ôć_/±Ť®Vm™/Ä­ŚĘzźíÔÂ÷†cŇO żč®@ůŞŇ8ńB•\rm”Ž˘zjN×ŃőżQsśÚíí{ŤX–!ď=»CAŢłéčrw¤e4Ë™*xł•j¨'gxÜĆ8sŁĚ™Zwk:KÇzm=KÎâXĄzmswE×ńn-sĂh“¤ÔĎŁŤ…°í JÄřˇjqÝĘ:”s«ŰUĚt­„0"Äě6Ȇü v´R#!“»ŤD^ßă“)Ő 7ĄP3’B{CÜ[÷ű°M–GźˇŐ§'D´4­ęÉ*’Zlµs©©˝ÚHn;‹çmߦů†člPÝĺ>ťţ¬Ô„µÜA› "Âl"Ű_.? šcđzZ~z‘M3ąŢĚź}ŠwźĘŃń\¤ɬq¦Î“™Aăhň#jËhÜůŽŔxíę>ŠŠT{ŽľčsöŠ(žI}´ęuM2Ry'ŢëTĘn$Çn¤ŽďXÇ‚µ¬ôU”ÚŠß’_„ž˝ďuu €#D‡?ÁC»ÁĎýśůňś·5đ/áöď¤ü]Âľk©‹–ş±śĹsĎ”čOĎý 4«…óškŕ•8ŢĆ> ÁN;·ý˘|]™4‘ĺV©ić[c S˛Y÷ą#´ß‰Ăp꯻ ŐPťy>ZĽpYđŻđ, ´?8̆ˇŔ JŽEóäŁKŔ ];,(|ż\ Y T>Hyčß?`^”}üćë.;ä.q°í–i7Ŕ,\ `zÓ!Ç˙­.!oęŔ"~ů,&™’•CBC'L ­üMK’M *Ş{hŹCP÷ôÔkŐTŐŘUŔrË÷ž}©JÂ/©kWş6Ń/•ľ}rOA».KôË9čú¶€şşˇüvn _A6)*č\‰lj1mbÍ^ &TŁ]_˙×°Ö* äVկ޵´ź6×Í]!đŞöžűşÄ;g .şč™*:ÉqĺFÝđy­3ÂŐüçsŢ/I/ß(ć~',۶f7”Š4ŐWňXZTk,-EQw›T¦„‡BäŽĘN–1"ăp†ő/í¸˝SSŚľ$’y˘LФ;­·-¬…*ŢzI8q6ă;–QšQ…Ž8-yŞ×ÍĐÔ¸PFţ¦áŇ"Î7ś1GUXZ^Z âýÓt0Ő‡y9v;{t#ßÉôűk’÷U´EÝÍşNÝY(ű¸|™xę’°čÔ‚\OFh/:‘N{Ę"Tw óĘOб—„ŘĺQ™ eťë’ţ_gc'no×3ű®“č!Uâ©Čýó„äB{2©5¬'×2vşň’¨I˙ÚŁ +C ŃtżtJÓ ŁEM1ÝĄJŤZ;Ä©Q 8uƦoÎą®őüÝÇxčľ‚ĄÝ Wnޱy7ěŃqڿ誟Č2dťÚÁäŚÓŢ„ÚçOq—…đ”ŘŹa:x^ü'ŞYKÇZÇ{Pá˙9DzHůŠW.Ýî tŞĂ…ő¬Q`î/ďź:o´nµňB+“ÓCâ„3UŰę¨ŔďBuIałö[8ąˇhµx¨FXüMäŽB“Ś8ĄůáeÜt=¬Âşö¶ďŁŔ»¸¬#ţˇćU9HîJ~D¬bIC­`Š+čÁł â»QórV|ZF2,ž ˙^ű˛®2-, tU±R8‹š Żë\•úŞśŽťW^Ýwľf«ŐüeŻ ţx_ľöîÜ·kçżçn*´‚ć[đ+|·¬ÜŻŕ*Tn.Ë™lşwątçäâ3c#fMŽ«lŇ5ž¨x(“YZ‡¬©fáöI;Ë›®µ’Ózx›ŢÎ踯PpŞę kâk —űęLVíÄZősdő0­/ř¤Ć±úYG×a_4·Ć ¨žŃλr¤ÄÓ’“óŇŽ—äçéŠŇň´škuô3‰nô ¦ÁtŠŃÖQ;–ué]Ž˙¸Šj/@2@Čgy2Ŕ‡2Ŕł;2Ŕe/4¬”ŔŽŚ=üéřÄśą&Ç>í€nÝĚËŔŐr(ľn×´bóˇćYwް’€ż˛#倮ˇÇťô*€~ĄŚjHWŹil˙W»2$ú™N1+j‚źi«ŕô΂]âĘkBj–aC ˇ‰{/Č”¤ÔfeXW¶â€;8 UÓFI±´’ ©1WĹ펅…°d©a±¨9żńú\FjyěĹfŤU–Ţs Ä_,÷Ň™ÔwşGŽě9úçH+¤Âޡůˇ˙ńNV7|Âöó‹M;Ń( J/žąâÝŃ”ÓŃć?ťâî)1Á˘¦|CËśîc_Ď7wb>Kň*¦µs¦ťBŮiŠc­˙Č{(°nzúLäXŹîaö´Ü›ę¨mä\‡Č›¨Gýą-d:’Ž dĽńť[:5éř„ÁůB`J<W,‹cfŐľđKáxě™ Ć68¸Vf&N •©I›á)=(é& ¨ąŽş0™śNý…śţGÓ{K;“tHVÜĆ­›?¦_dŠŰęŞá“U";ú0&l_Ç„mW“ľÁ_H*[”ď b®§T§Ó ˘Ĺn.‰JđqZ\ťĚ%e2—ŔM˘ou˝iŤ ÚŃŁ…µşáL=‡ĹNfÖű­č€ąĎl§˛<pSĎš4AÓZ„buu[¨`TjĘw˘§°bëĘ-©Ýçaâ`ä_=F3ř±jÉ,.Ă„ň¸›K4cgç2`ýgĎăĂ l —ě†sđíáÂv0ByúÉĺâ‰j!ň¨ßÁ)@{Áô@ă— żÍ »Ň B-™.Ëi #jy oW݇¤%WĂęäuq ÎI=R­ĂZśĄÚQK}ľ |ĆÝ˝Ľ‘]hť0ţ†7;îUŔĄś’<T›,ç‹ěŐŐíšrViň$'“F9Ş"ŕĄö:Ü,,˝(j2żrkbTçÄl\nęŻJŤ Ścöśg8l”łn“ ëďČ M )aë'±iËéhSµ'!MyĎY0Âěh©Ëŕ÷k ˛Ö¦“ä166f{;p2Ů{ĂřŃ”‡"´›z“Ťđ.•ůËdµímp8¦ăpšţčB,FWüt4°Ć?”Ş1t$ +ýś.¤G9†đ“î…×Ér)f 9eŠĄcHěD@S^˧/Ť¤\¦¸ÓK@ý®«ŹJĺ/#V-üK˘W`L“„§É¨5)fă~ ĺ¦ŕClX«Îd Ş#’‘HuÖ¸ůN@+c¬®V‰šÁĐälŞ5Ďriđ•燉t ž*ÖĄç%lđ5/Ňi€°†ŞMf Ö©Ţ˙o¶Ö°ůű0FŘöxé1÷ěúěc%ëŰŮÔ 6´ńzőžfćîáolyÜuKO»ÎIłţm{KůWľj ¸ĂcŁ ^Şf¨^µŃO^Oc„őNE w?™¶6eɶI˛6´Ő×˙Ł÷@ôR1 ~-ZĂj!Ó „ őĹ%h ˘QEű@âńŻŚň.0HČFőĐ"¶3v¶Ďl>ÔĚź&;uČpv\Ťv_ć/~·L8xîpÉi¸Ĺ#ń1”Őľ"Î?*|đţŇ„Ĺ0–ţ2’­–żČ[’#s7MţĐ~Őš<ď Ňšl’—ŤŁ˛K˛•49[őIÉËA»śă9"MÉé©5W¬µčąŐÂ,zŐ›×[X´÷j·čýćĺůŚ endstream endobj 139 0 obj <> stream xÚë©ţ˙w˙ďű¬ń˙˙˙oAÜ ~ endstream endobj 141 0 obj <> stream xÚ­zxUĹÖö atˇ%Űs튊(vPĽ¨€@, ˇ·@ BúIo§·uzINzď=B•ޤ˘R°rńÚ®ßUgăÎ÷đÍś€bąúű}?<ĎÉ){ϬYk˝ďz×Ě , ¸{ň+Ż˝4gŢ#ŻĹDD¦(bŇRçD¦ÄD=öŞbĹš•üŠiâťâ]8ônńn™xO€8|xo xëŕ‚ˇF ě:řÎŹK‡î$ń?>Mî’ÉČŤüŐ8ěNz{ű„sčţŤrč˛knąsÄCËŇtż?ÝäU‰‘Ż®ŠLPÄ(˛žy|ô“!‰IY)1«ŁĂw6óäč1ʱ—g‡ĎŤŽţóĂCSc#W*†ONSD'¦¤>~ŐOţчŚţëŻeěßŮu˛dA˛a˛`™ »Y&—Ý"»]vźě~Ůٲ‘˛eÉFÉ–=&{\ö„ěIŮhŮŮS˛§eceĎČĆÉž•M’M‘…Č^”˝${YöŠlŞěUŮ4Ůk˛×e3d3eˇ˛Y˛Ů˛9˛ą˛y˛ů˛˛…˛Ĺ˛%˛0xćĂ’@Yź˘lâ ön¬;ŕ†€ůeŢx|pâŕďIö5a×Îżö¸†l¸îčőEC+n¸ď†ýA_ÜřŹ›˘†M ľQ„ť7Çɧ˙íˇ[:o9pëšŰn¸Íu{ôí§ďčąsý]x÷ř{îż§uř'÷î˝oĚý÷Ý˙ĂŞF>°n¤úÁŰü÷CF%>|Ă#iŹÖ=fš[Ĺ/·°×[·ŠßĘéDÉM$ţŇĽŚ} n2đÍpş}ŕ#ö»Ć>Iţ/ é÷ßwËE#ĽJúŮß É}ńĄŚ€ŹŢ ¤2”W?ß3mw(T•‘9§sNh×®ÍŘť€}ŽŤîMPňQĂéž÷ jíú“ž†Ür2rRč¸řĄ0BĚł9O‚>Ö‡±€ \ JAdąřJF-fC-ň´Ó«ĎŢ éŮd×řŇ\ËÁc‹ÁŐ€áúĄš0Č›4~Ő$HŹX>ń™çˇ$›üë˝˝g›7ŔöÓmgĘÎŁÍÖŠm€Ű´Űr·˛±˙)ÝJŮŕÂćŔäZRPˇ‡RC‰ł†Í+“Ú¦që€BUăg¸ °WQ»!2q  “¦î 8Iëéš*/ÁĘ6,t) ‰ Ó’1PcS»]?DŐ*no řç1j9HÓUň x¸yçič;¸‰Czŕżâľ|! T‰™0nÎé1”¦>ĐńŕôzńCyëĽJ(Í)ŚĹą€RŔré…řé9nˇ& a>ćîŔC€těIÖłjęk\ĺţ©ÍÍÁ´ŕa;ÝRţťXOĐj˛ĚČţ›AŁ×čŐzX‘š8.PiS;ÔĐR¸ÎQŕE‡sŐ&­)BúčÓs–aµ‰ ¦»¶XÚpnĆzÜjŢ:ô~»ÝZit@¬•¬°©Ę |~Ü'–¶ĐQ§čÔSÔ(ž“ĎNŚ\€Q€9Ąl–2,ńąŠÁîBşą‹Đ X۸á}„&Ü€ŻŽ }eĆ9NďŠVńąŐ‹Ł1›0¤[¤[ ŇhŚgą|Ď;Ńď2†á—ôzüđ`ňŇ0„(ś§I„ę#ëlčÝ»>ě:î鬴GľĄłŐS‡p«^ĆE€/Α®™Ś° ç¶ăw€ëÜ;\µÜŠ‚FŞč¤»›č°w¨âxŕÉRąI…j›ľ°ý°éÔi ·Đ[ít463äÜ3ĄŤÁć}Xşďś^˙łşpGM{#¤M]ţú˛p=癨5ĐłtŹ|ńę8u Âł~·ľ˝‡^sˇwĆŕ}€+4ó´©ô˝©‰Ć®ŻĎ°]|$ňÔZŃhE«Ő ôę"V$kĄJ"––ËĎŃËç˛ó „!©“&‹ŮŔ´u¬YpĐh4ëÁ”I,&ŇiŮaéb!ę1wđY­ÄZAĐa´éTiĎ)ŃőŔb1V óňP­ÎIé­ţ2őz˘j…ô/XęđŤmţ-l@Ł(yĄ×ĎwV·Ă ASSB;ÝŢN±=ˇ)Ţ墧?ťrBHŁëĹ#rg›Ő{aîVŕdĆ/&%Ł’ěg¦Ç?Źđ"]Śü0!ťÜ4§°d7° r§¬ś)ŤDŤ9¬´[HSBĺ†Lb5‘ –K7vŁĎô2é<öMŮG`őY‹°đť%}ŻT3˙!m{ݶmŢŔ@[„>Ŕ=1{ů¸1nZ…Q¸Ę˛ĚÂî7šĐnČ h°Ť&Ňj*ňW˝YgÖ¨~$Úh•! ěŇt=š¸ł‚vŞÖŠw|ú‘¸´)žWÉ/ŕ?7žůŚ˝S‰0nBČš1,نâ˘oćlMŽFčĄáôŃs'XtoĂŢçÜcˇÉN,۬[ś;`ž-aťt»ĺ)”^”FFJ‹@źbJņ‘ŰŢ“®ŁSĐźQ íâ)żłăNĐCç…5ĺrcÖ€cş-=Ř…]¦ŻýŽąéVcĚ਱Ö`Ëň'¤@:D‹0g˙Úe,üf˝Ťű ŢDZL>gŻ<ÜŻg䩌1ů}°Ć€óť˛Sţ•h"®Žvű&?ď–®AiŁJcĽ.VIˤż-’î@x3ťXÍcɢ AŃŘÔC»şßΨ͠łz“ěÁâ¦O:…íâÖ‹·ËŃjfišíŮFťYÁśb@2`.-ŰYÄĚF4¸ük6ů4ČŚbf=Üo şÄĽ‚HÄth2Ť (ř-~/őZ8G Ů'L¬`Tm«{łz$8HlČâPćeéoڱŔŽ€6´Yě°…Ú â•¦H‹ @“™CŇ”Âl°č™ÇŞ8lÄŢëh°W‚­ŇŐ\Ř F;óÔöt$~o@›BX±É‹eăł‘ziqÔ{ĐżAr˝+Ý/CŁ0Ř×Úż`Ő0č~Ć[~ÇG§”T˘'äÍX8` ţž-ÂçĘßšsJů—Í9®´­upsxHL,$§”YF˝?$Ć_„ä]ĺ/BŇb*Ň $Á¬c!Ń1ý—áŻ.—ůćg8؆ËfŕF`©VgËwóܵs€ÍÔJ‚ţKŐIMťôHWŔąOÄäć@1çâHąô,Jł¤[–KI`H3Ąólî˙FD'°X<×qr¨=F·µj(gG™łŃ‹ÝʆuÔ“•$ÓÍW‚-Jźě‡„ˇ–Ń‚±XÇWdŕińŇcdU\hÎć‘8ťŢ„ô:ŔJKĄ˝Úi ¦×Óż±©ďÁŽgĚ›ť×Y{]Ça&o`‚č`Ó%ŮÝJŮĄ€JŮşK˛˙foů瀊‹ć@ńń°ŕńĂ˫Ҷú˙Őţw6¬ŔK˛;™ű/}˘”őĐ›\—޸ŚŕJQ'řčr}bÎeS„Ě_”é®zü„SIÉ®ęÝUŰ@ç,°©L8céKśN!IĹüb1ó§ń碂8K˙˘•”Ű–Ľô‹›‚K/~-ř.Ţ˙±Üśźdňk6ÔŃ/ Ş6Zš,ŤŘÄ”ŰT ýuÜ`ŐY ŮJR­:Ç•ËⲸażClőľâ&+Ô[‰ťhqµ’ŁB F"íęwťĘh``DłÝěQ˘“H#,„ˇÄ4P<îL¤ĆäŃa Î¬3i@đI÷öçmR~bĽßHÝOÚ…ŮÄäe Ö`—ąń˛Ô°ü¤]ô3-Z–ş-›h°8ŤK%aÜ—ýĄÄŞuśtŘ ˇÇYoĂ~ úŽy¨9;ý"4],c wČťÍőÝ6h°:mL|1G°…q+0#~‚;Ż€·Á1w“7Ó!Ż)“űo$†L“R‡ Auyz«Hb(‘nEЧ‰—N·Ée†cŐ*K2 G÷G]RfÂ*#¤0vô©Ízt.Węµ–Z¬ĹŽź˘ółĆbęzŤµ b@ů8Y˛ĽE˙M\íŽć_'ş•ľ4ĆQk˙ëÄ•[¨.E𡧑NĐŞvńËö€ŹĎ‹Ó? §^,gŤů;!(ÝÇëqŚv5DKŻÜ7śe#<ŚĎžFĘdnť­ŃŮĚDI úřc–ÉĄŇfąŁŢĘlcjáÉűľćzIzĄG¤G#Ą… O2¦`*cÖG˙ő˝ź]˙2{O  ×Yµr·Óť )íÁ4ö$]üˇđíß–;š|eGvăŽ,|0×”mČ€tI63üqfڵŞl ’Ť!,[9ŕ®_ËfK/üć_ć¬hî¬<Od›Yëi2©Ô–Ű™q!ř˝ľôC°z-^® ÷Ćś”běË|]˝Šw‹-Ń`ń3¤łŔ[MŚç»L¤Ř\Ąĺ‹dĄŚé† ¤ČÝÝ}Z˙Żľ•ü·V®Öh5Z5´e’˛’ŇŇb(ńŰX`?ĹuŹň~cn¬ßĽ ňŠHrR”*áďřú™{t OZ„=Ý;ŞÚXş?ÚLŻĄ7ł2˙/ÁşçÜSô¦\7céň¤Sµ(šhY;Ýx%TKÎ â°‹2ů¸' źăB<—uةҰ ‰,FKlau×ŃTVöËÁvąžŠ3Ő‘Ü‘Ľü˙±Gő›YíĎ-řmhŻHů˵ź€íjÄYYíŻĽBšëi"yËr˝ :Ţ’¦Š°¶{бĚZč[-YŽŮíŮëáy¦eúŠżŘVőŘ|}›Ş)˝„„¨ ˇŽ™¬öWu¦_’Uóâ{@)k>ŘĽů8sÎÔ"lUŻ‘/t;kÇpďKłÓďSY‰*Ŕ1'ĂŽE°eŁ˘+g˛ŽĆ\`ĚśçÇ1š­3BnĽ‘_0Ĺj˛+÷`]î,ńű3•ßţdϧ/÷MmŘ’)ëđ( “q° Šöo[ű&KĎM˙@_¨óUh1Üěh°í€ ěËJaĐdVź|Á4P\'ĄYo“ ]ÉîIµp4qABÚpë}FBÓáşĘíG‘ô SĄO€Gű ţZ=ő±ôý§ËČÇçfxÚd–$—M/ş±ČB—r·i˝µ—M«Ď׬f~}‡5EçščM§é^•ś.ÂŁTh§/ĂÚČ+^ÉZÔńcł±Ú/óđ*s¦ůSi€‡ śNíF›żi5ůÔ?kűŮŇF’& ^)Ý.ýa)FW)š ˝Aׂ­€­Îvg+쥻(őőţŢT+Í,gŻLe ü…WÇ4«±XëźĘŻđ^•>eФđKÉ?Ä˝Ç5Űż ýĹ…ŢńăÝŇH:RřĆ‹ëĺűú[5ۢ/DpŁÍî-şţHJJš\…`aÜd1‚5ͦ˛GĂ:‰k–Óŕń_kcײHî`ýyE[mýv'8ťX¦sB,óJ2&ce%7U§Ăl§¶:óŇV4SúšD˝L´űIm%†víA&>–łB˝¨0‰śN´‡I ýŰz ;¬?ąČ…±Lß®ľjHáĂÍšZ•s15‰ź4YzÍu1›nżHäfÓě1A©±QÓ8 ľ’V§Ú¦E ď€LhłN§Öj@/Í$Iń+ÂçUéMŕLđ _ËdH7Öýp{%á=•ŢYV’ÍĘ8o-<îÂBĐgč«Äív9­ ňF»>“B‰+Ď®F JmT Öř 6N!Ű-ŐXŤ˝ćž+ŐĎ`¶3 ±Â–Ü–ŮĂč ţF«Ĺ‚V°zśžÂ" OÓ—H[gCă+‹…ŐŽ6°ű5Ď*s¬?%c,«®¤dĎÎo¬·ń™n‘VSźŇ)„h5zkXY/f7¸˝HtE/şŘÚśŽ2 ´˛Ź6Ţk]ŚăĚČśŔ°~t™y1! –‘‘ţŚ4’ IŇă}ibV ¸R$ďOA˘ 'b2S7“T;éĄMFđ©÷éł§„“âăâKň$[ľm%Âp”FŁ4pŽoü9„í¸kçľO±lţ ˘U3°0Ó•Ě|{{ëwŢŁwĺ#$Ee樸®S[95yśŤLMŽŇD8™ŠÉĆ ,’bĺ‹GOü{ß>Qőâ.ŔďĎұ˙ŕÝfµ¶‚ŤŚŞ{S¦CĐ8U‡¸‰.k)őbFđ×'hÁáíß— ď•ňö˛EŁËhSłµźOR…䳢`L%h´p×2Ćóˇ[ÇU—Ň”­OýKIŢëőó>cżaŹŻŁÎżůz3~ řVŢO"ĽŚ _‹Ž“…Đ©Ńrî‚aŇ-/ ¬F]Oé[¬A6íܰ3B3Ö(đÖnLRíĄRKŔŮ3tÖŃ@©’ÇCŰ6ŁWĺff­ _;źďŢfÚó* ·BU‰űXyuě““ĽÔ4ęů9“¶F=09¬äiăÍ)ă{´u•XŘcŘ-ÉVâ´äpX}ţóŇWt>sňěW4‰Cíż“ߣ2'3-Ŕh@EöŇ„ů€äÚd˘K5dţĄ~/®$1ĆlCDIݰ|%Í u‘ţ<»‹©(žgs‹Ç|†8˛ 7őîű„ąöiŐ>ú#síYżk©xŤGßű‚ :č˝;›×!t"ăňBĄä´ř ĂIěf:I±%„ —)"MDI|¦węY„#¸żcď Đęłg)ÔK–ášZ<čŔ*ÖµI(©ŰÄô$5Pe[đń+á$ o—gH×(gŞ&Aţ¨LiěęŮ ĚÎČĎĺ[ź—Î j_fEß®Wgňsš´ÚT&kÖb_eËzhě©>ŃCgCé©ŇJέŚ\@âÁ»ŐÍ0č¨B Óš&+Łá$ďě wWwa{QÔX[Ρ őŽt°§ą“ÚyŢşjŃ ŘŢţ"źsFîŠĹ‘<1ëixŐH2ÍZ ë“ĚFcŁS41jdůńw¶,ššNďh¦Řě:˛n×’wéýďÎ?$H2:Ö(~T–ŽĄµĺ®äÚ4ž‘1+źbNŚóşp'°Ëpóľ:V‡\t“tťy•PR\WČ´¦‡±/k,ďĘŃWĚ÷ąĘsJÉ©ŠŽ´ú¸Ňp˙pá/đcŽđŠ q ô+S’–đéT¨¨Ď…ů ĎÎĺ2č9ÎEÎ]xľż<´¤m^)<_;ĹŠ›+‹k=ePŞŞŐ6"·ěc<´Ź]5ĺřzţÔ™|3R}ś_xĽhça„őX˝u…jߪtń¶}WP"Ž>-DŃŹË»ésäÍ3‡övrň)ÖáŔůô¸ü—KěFÜŕî‚Nú qł†ĆĹĹŤKëPCy\áÂĘeĐR·†1_;v´´î-k˛• é™ěO&jËU•¸3ż'ŻrZtű&ú‰p|ŰF˛ĄŻˇĽ’­čłz4äµs n­ŔŔĆ4W÷ÎŚČé°2†dç¦ç¤#gUëW1űüĎc$mćqąxĎŔ/śO„i´‡—­ŮŇ Ż.âχ^{¨?”…Dă‰#Ą aî¨ßř×OŃń«ăŇ řf‚ÁÉu‰ŰVâéeú2ĺrÖ_şôöO)Lo¦Łčă'żú ÷¤ˇ¤Óč»ňŮ’•ü:¦>o7ë7Ç’S”ějc_U˘SËŹŘ Ě©Ú5°D ˙Í-ţ¬ě¦ŁÉ‡ôúžöUzý·(Í š5 ¬”­’FU„&Ő€ĺůĹ{qgSűje&ŹÖÁ–’™”… G““źlŮ­u¶B–óĘMôe⬱·pzy3žźˇżsgĚš¶RK9?9_–ČO<§Í}×p«‡3”Ţßďä˙|ĺeüśţ̨6ćé!hůďąíßôaúČia†ř˝IÎQ.DýçËÓźd`¶źÚ×ĺ^ĎĎ¶Šµ3‡é´lćßLŚc.›uÎU1Č)T^íĐçŘ\ožŮy™ŁôśŁ t‰ «żÇQ›ýHµý.R…—±$]Łęol 8u–&ź ¤céD9~ÖCG~ϵMiNq"řRlQ“ndl˙<Žç r(Ó'RŢ%Ům|Cô)Syăřv†k"!?”,Zź ö<ʶˇş©şĽ±†‘ŃţpŢ‚Äé!ÓHX?gfúIŹţÍ! ń-G'?D}‹ďĄ2)ŹLĘ;LV2m$ךěp·C}Ť”ä4e7!ĽŤ{zű¶ĂŽĂ oáqŔs‰‡DXQ™I9@ÇJ·ČqqĆË‘ˇ±2>’sZ’/˝ Ó ¤®´©Ľá-ôľ‹!čĄ˙¸ŢuⵝÁśÂÄQô¬s2'dÎĹ´§ĆEńçÜc\¤Ńˇ'é°oąş©‹Ă¶LiP\›÷ź×yôĎ×IoO~ôÉ1ĺÖđÇ6´oTć@BQ´ĆUE Ü‹ŇcŇP”&NŞyös„-¸ĄöŔG`3“ iya:ýúż^:ö L|J/HĐ‘ăÎ ;i2í–»;`öôx:8âJÔ^ŢGřçşRqśWWäg.Ďü4M6@„Q EZÖ{{ ‰!BőćŹw]¨ń?B˘w2ívi|ś8°Ľ «rë™÷„ť‹pÖëᏳĚ^Ąj…¶zăÁsďŇ)*y ’Żpď|pSŇĆ'öC|ĄŞś‹ëŽĘÎő¬UÇ2Ť-l©e‰¬p5˘»K;ô˝Žđ4ÎźŽ3Ş— ‡í«Ý±Ľź»2sO€<‡±Ś5yÍńšTTFmŚ:j`V¸ü2˘'řŰÓBť!N–Ď˙úě’R'x˙3«ËU-śŕŻm?ŔÚ;ŁOëdĚľtA–*‡kpŐ€·U˛ îĄĄle¤Čá©Wşá!$Ţ Ä^áiňcHĂ1´­ËTQ´’ié3ű8ů=Mź9%t‰6úÝođf WEB‚4L–‚ż¸! ĽÜÇĄÖ*W¬§'îVßZÎŔşâxľ—7;fi(“®6µSĂbRßÜVéEp1MČ› µ.M› áŇx˘M6¦ńĹÍnUt śÂ­Ţţ7°~[ąŠ¨ă4üĺşJcý‘ÎăIɶ3⫣ľ 9.tŃ='ä14Źä](čŠâMĺěĐčů¬¶*ÝşB346ÔT <„”í‡u’‘¸Ă˝Ĺü›âŇŠJhéčŢ\RBSUóĆýŤ‡ˇ¤Ł¨“?mÖ_±ŠG6;źď?ę¬*›„ş…3ť+ýĺQ"˛ĺgŻËS˛j+üd×Ĺ{/ŰU^ wcyqitíÝůEÇ{ŕ´âé%Ďy§‚k‰KĺA(Ââ˘Ę:hęlÝP\ÉL¨né8đ‡&čą i&,K~!räfädäĺÖJÔŰňŹäďu·şM[9ćlcŽV<ˇĘŢ!ŽzÄib¨\‘ś«ËáÉžgó2yżÄď`J"—MË—Öc.d…wc™w#Çe·ş‰ëF7z¬ iĄr’ˇ 3äMËřÉ nŁËä63a]ÝUÇä”±v©5ŤZ—ۦjä I[Ý&*ťKkc¸Žś‘ Oäš~!:;ž`dpŠ˘wşćĘ*o)3{­_üă­ĹÁźľ\8J[Ĺr÷Zosq9”VWřŞś`+&óÍ (9«Ôó FšEÔ‹2ć†ć€YOşUE‰ÉOJrŤŮ |¸F !†$Ç Ŕ{¦;|Šî‚f°µ-Ëž×FŻ©s`‰µÜĆrňhGŤ¶üŢüşŐe°˝Ş¦ˇô<ą$u—ľKÜĹ{ć¬:mS𸋠-˘Z<"Ď^ťV0 ¤W‘$-ôţŐµ\-¸3śéŕȱç©Áap™o¤©rÖ{/7Ć%żjŚxc\rxşĽ… P ŁÚßŰ4Ž p¤»’Ű8m»jéü®°Ž9üáÇŮĘ…!ĚéŮ]ŻŐ2žšŚ‹Łb—ÂŇiyăô VÓIj ®&b+'âŁHŇĄÁD–;GýdHw$I·$&BNŽÚĎ÷p4…/h˝jo6Ďo˝őLÄĆCŘëZşß‚Ťm˘K{ioôét$ 6š6:{˘z&ˇ,éş4)Ť—›«âăĺ ĆŁ)ŤWS80^ęŔx GúpmCç>ŘôA7]ş™2ţŢĘ[ř…27O¸/•ś¶ś–Bä˙—íaŤţŁňsú˙KůÉ_D¤X˙ŢFÉ{ĹŠ ¤±Ü]„P‚ĺz[ŘÓÝÉLîVcqWÓÝKjgrÇ)3r .yEd¤ô2ßÜČ2k4ż‰Ů9$©Ň5†™ů“@Ř’óh¶4nől~Ę–ą[ßÁ–«NŮj¤ ątË–ŃÖ$N*łÚ 6«ÝfłB_óĆĘ/Đ1µŚÉţÖA_ĺÇ`uüÄôŹŽÁî:ű˝!2UYŞěXł8*z%t*HˇŻČWTŐ%UFťq_ö7KŕÍ5'łO!|‰ßöŰ ĺäĺ¨ YKy3§t|Śľ˙×OřŁö7‰w y—L&ĎśŻ.đ‰“|ĺĹ Źřš˝×HęÂk ŠÄÉ?}R{ČÝ×FE âz]Ďu'®ď:ôÄĐÄ=ň˙&–Y7 endstream endobj 143 0 obj <> stream xÚkH«U°ţďŔţ÷˙w0Ś\ ŔŔŔ$ů ˙ endstream endobj 11 0 obj <> stream xÚÍ[[s·~ďŻŘ™>T;íâ~éd<#ËQ˘ÖiË©“˛| Čµ´ EĘĽ8öżď÷Ľ¬%QŽR޶gh`‹sÎý…(¤*$şPĘŇZٱ…1®ľ°62NÇB‰Â4˛BŕëB ‰Vsľ,8Yi@±€elˇ0ÝX´oť+4P9ă -ÖĆBc~đ č?ŘX•ǸÚ4hĐřH€6 8ë ÔŢ…Âu˛0ŞP1ŠÂŕSVđS…ĺ`Z :†ÂJ ]– Ą,,AcžĹ§tbČ(# Ŕ_ ˘ÁăćǬĎUĸĂÄ÷S@8P Ţ€ňŕPy>tşp"@Hw2™ âĽŔ§Â^âSk\_=şüöĽŔ!|†ŚkőĆŁ#ů8!±*p&bßx2žp˝ŁÄ :d ‘ĹKőlˇˇ%dF”tŔ„*|4%°Ĺ˘Aë!eáŠFZ IJ' 80AČ÷śŤW”ŚÇ 6V€(@ >…Î9Á´xo Ę,€5A ¶ŕK 'HĆäæťŐßN_Mëg®|ň¤~Ů =eĺ jd…5Á˛EÎ›ŞŚRý'Oţ´|~žˇ" Ś‹™Şl¬hP›Ę8÷đÉüđľ°Áçeé °Ľ-ô®"ŹUÔ•trO«‹[n_ÁöéÖŇźVv ?Y©¨ö´şÁźq\Ł˘ŞĘB‘Ť•TE]ÁŐ®đťL' 6đ€ö˛>ŁČŘ;÷b6ž5‹^ýâŮIýŞyż¨OŻÍqnžććô2L®đÓËSţ.‹ëů_ëú˘]\.Ď«áôŞţĎU;ŞŻ–ăE;śÎšE3_Ě7Ë„űŻtdxý“µźd$»ŁÝ“Ď·lŤ¦‚ÓEř󼋉ĐQ “!TNű=ˇnĐYa µ°FgE¨ĽŢ3¶Ń–™Ńaqń¶ŇđrĄ•@””0 „±=ˇk¶ĽşJÁ2Ó5FŞJ#@ŠQ!<î ß›->é+ÁgŤO905îßÖˇiç*F X @2@U)jiřĎ=a“˘#=S&7¦bîCîz„7ÓĆxĂŢWÖ}ŰđŰŢoŃ/·ţ?ŠĘz`8x-u^ JioüR[|ĘđP.Č-š«Č¸ †^î_@tůŽY5›°1ŮYDâLNÄí ˇľÍQ8CfŤ+Ž* —{[ Ů.*‡¸'ŚŚYOĹr@iSY»7„v‹P‰Š)ź„VHŞ‘U-j,|_ř¶)‘’žpĹVĄ‘žî]'# pŔŚ.k|+ůí]čč'üŁdE÷Ď0ĂóÄŽhöJe'%’®bĺRGéˇeŹe{˝/|ŽzB;耵‡aîŤŕĘR×˝{łżóCáI ?*tÁPYY–VŐţla؉602TdđýhY#ŃCz‹`··rďĹán ÜXdV.lŘÇbŘjý˙'hÍHĂÝYT8NEnFÂvü# ô˛]4—Ó‹·6˙µŹׯ:[!ŐCÜ‚°fĂ,”ŃĚ?3q+Îq»ÄÔlN€V„32âőăKR#rć–$í¸=«Ś„˘É1Wî_Ń?aRůmĄ‘Ěhˇá†wąŽđµBȰĚŢ‘4ů·Áš‰¬ŻgÓëăËfřk§°G%^é<«°0F-<(‹¨OÍgˇhĂ%Ô|Š"m5XĽG4xDš†‡ĂĺySż~L‚§CÖdáh‚Ö ×ćá3Ä˝’jŢ.ßµo1ŁépIO>X´ÓIÝĽÖídÔĽŻ.Wă­ô 4'rWŐG0[ůAŁPM~^âÖ‚„"UÜc7H;OŠx\ÔŹ(HB7ďšq=Ćá ŤGŠŘŠÇڇ>†˙»ßR®łłéŇ~´1Ú¦·—öł’¶áš •ÖÜu5U:bÝ(ÔçČÂ;—Q¬ë|Ţ-ĺYčšqđŃ}nę6Ľ˘2¨Ö «QÁ˝]Äo±÷Śç·ß~«ćö™ ›Q;‰ĐŐ›z0©ă¦ľnŰúLHČĚ“^q;‚j“vŐ7 Ő6е|Ń$ë´37|7p °sănĂ›3ťÍfď¦W{ p{C°řV¦űż}”O(—Á${@îXŃł—Ţ(>¸žrťŘÓžG΂JÉN„ŽĆľB]Řł—‰HbtěřÖŽN4=Łe_ˇäíY™:řĆă«řűťfI¶©ŹOźń™˘~:7iô»Óž<=ţęy{Ţ ś,çgͬ}sř˛ąXŽ3N:ű0_4W§“7Ódyí|1űpp4šž7eýËŃvrqp:‚™µ Ółĺőő¸áÖZ!UyÂpÖ^Ă(ŇMUęŘł×૨_§Ë¬[âÇ3ęŁů°B4Ě7R˙Ug}Şţ aASŻżkÚ‹ËüÍŃ»‹×í6‡Â:zJ+=”Ľbv¨,ŻŐÂËDđ©>…†·ĂŁÉŸ)D}2\Ě Âý0n@Ë‹Ád:oľ¨‡„˙Ł,Ţţ{˛Z-ëS\äw'í¸ŃXíĘ/ŻÍ‚÷h7!,ô¨LwüúÚőśs}…–±oeĎq‹Ă' čC­",“jîyeş¨yUť»’%{RsxwŢ9đ®gáňU}{–Ď1čžá¦¦ŕ÷´IŃŹP.­¦JGgŻ_ţrr‹ gÍU{>ŹA—r`íę’ý_t …ęNeňň–2Ą[+™MâneR(­Ř©QţŤú3»*e>V)w>!şăź˙řă‹Żŕ ľźN¦Źhţ9ߡČWü AEm;‚rv%¨`:râ79hGNŽb‚j0MĺÝd»CNţ–řO‰sĚřĺ'!ĚG"ÚĹ´®hÂǢYgä©HKťB*‚چµ1śšt|ŰůYř|ľî+—QçSŕDĄZ¤~:f04ȧhޢolʱ+ †Áwŕ—n§–Ęb,O0¦Mň ‚;-đ".!ÇĚŔ?D`ÁĘ?^‰Ů9đlŮű•OŢ„ź)Ç?Č + )´¦Ďy˙ÁrW±“§9ČÉMúű”| ÷lyŢëľ’^ ‘QI®Ť! ŚÂ"ÉŽľ}ţÍŮO·,&Ëű49'éçcÔ˙ČÜNߣŐmß“ţţ*ÜČĄZkµřC±ě~>v”;—'ĺ6ú>żó ´ăp-„Ăďęo&Ăé‚©;ď2űF2MUMÎÉ_Mš´řşáÝľó _űPjÜmjܨŮáVJE¸M…OîÓ‚ËçbÖű ˙Cß,Ţ endstream endobj 144 0 obj <]/Size 145/W[1 2 2]/Filter/FlateDecode/Length 312>> stream xÚ%ŇGR‚1€á|VöŢÁ^°÷ŢETě`ŻŘ;Wđî< kWęĆ;xüßÉć™7“2™L”R‘H”2«s8=Â\Ă3Ü ( ”˘˘ bDYôD,@Ä  ĚÉbí×ŰRŕ, i VČ‚lČ\Č|(€B±ýé“‹ŕŕЎJˇ ʡ*ˇ Şˇl`‡Z¨zh€Fh‚fhVh´K߯ľP¸Ŕ ‹0 łŕ„1č„yXA€iX….IXxa†`şˇV`úa ĆÁ#Đ˝°Ř€MŘ‚mŘ?śÂ.ěĂ!‹Óa|—ÉŔýnŕ±ë׸ ůuÝHčSוĽ‰®;yóŰ>Bzř(ßşî%l,‘Ż R˙vŮ6Ő endstream endobj startxref 55408 %%EOF multicoretests-0.7/doc/stm/000077500000000000000000000000001474367232000160265ustar00rootroot00000000000000multicoretests-0.7/doc/stm/dune000066400000000000000000000015731474367232000167120ustar00rootroot00000000000000(documentation (package qcheck-stm) (mld_files index)) (executable (name mutable_set_v0) (modules mutable_set_v0) (libraries qcheck-stm.sequential) (preprocess (pps ppx_deriving.show))) (executable (name mutable_set_v1) (modules mutable_set_v1) (libraries qcheck-stm.sequential) (preprocess (pps ppx_deriving.show))) (executable (name mutable_set_v2) (modules mutable_set_v2) (libraries qcheck-stm.domain) (preprocess (pps ppx_deriving.show))) (executable (name mutable_set_v3) (modules mutable_set_v3) (libraries qcheck-stm.domain) (preprocess (pps ppx_deriving.show))) (executable (name mutable_set_v4) (modules mutable_set_v4) (libraries qcheck-stm.sequential) (preprocess (pps ppx_deriving.show))) (executable (name mutable_set_v5) (modules mutable_set_v5) (libraries qcheck-stm.sequential) (preprocess (pps ppx_deriving.show))) multicoretests-0.7/doc/stm/index.mld000066400000000000000000000532151474367232000176410ustar00rootroot00000000000000{0 qcheck-stm} {1 Content} - {!module-STM} is a base module for specifying model-based state-machine tests. - {!module-STM_sequential} exposes a functor that allows to test a library sequentially. - {!module-STM_domain} exposes a functor that allows to test a library in parallel (with domains). - {!module-STM_thread} exposes a functor that allows to test a library in concurrency (with threads). {1 Overview: what is [qcheck-stm]?} [qcheck-stm] is a model-based testing framework that builds upon {!QCheck}. According to a library description, it generates random programs using the functionalities of this library and runs them, records the results at each step of the run, and compares these results with the behaviour of a given pure (functional) model. [qcheck-stm] provides three types of tests: - a sequential one, testing that a sequential run of a generated program is correct with respect to the behaviour of the given model, - a parallel one, generating and running a parallel program with two domains and testing that the results of the parallel run can be reconciled with a sequential execution over the functional model, - a concurrent one, generating and running concurrent programs with two threads and testing that the results of the concurrent execution run can be reconciled with a sequential execution over the model. Be aware that this mode is currently experimental as it does not trigger as many bugs as the [domain] mode. This is due to a difference in their execution models: domains can run in parallel (with all the races that it can induce) while threads are interleaved so that races require specific scheduling to be revealed. {1 Example: how to test a library?} Suppose we want to implement a small mutable set library, our main focus being to have a constant time [cardinal] operation. We will be using {!Stdlib.Set} for the content, keeping track of the cardinality when adding and removing elements. Of course, we will be using [qcheck-stm] for testing! We will build the library incrementally, beginning with a small subset of a traditional signature for sets: {[ module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int end ]} This is obviously a subset of {{!Stdlib.Set.S}[Set.S]}. The first version of the implementation looks like that: {[ module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int } let empty () = { content = S.empty; cardinal = 0 } let mem a t = S.mem a t.content let add a t = t.content <- S.add a t.content let cardinal t = t.cardinal end end ]} {2 Writing a specification} In order to use [qcheck.stm] to test our implementation, the first thing we need to do is to provide a description of this library. We call this description a specification and it takes the form of a module of type {{!module-STM.Spec}Spec}. In this module, the user describes three things: {ol {- the library to be tested,} {- the functional model against which to test it,} {- and how to generate commands from this library.} } Here is the specification of our little mutable set library: {[ open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | _ -> false let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; ]) end ]} Let's go over the content of that specification. The first thing we do is to instantiate the functor. We can't test the library if we don't. In the same way, if you want to test a library with an abstract type parameter (like ['a t]), you will have to instantiate the ['a]. {3 The library description} [sut] is the main type of the system under test. Here the mutable set. [qcheck-stm] also needs to know how to create an initial value and how to clean up after the tests (which is necessary when the [sut] uses resources that must be released, such as opened files, network connections, etc.). The type [cmd] describes the functions of the library we want to test. The arguments of the constructors correspond to the arguments of the corresponding functions except for the [sut]. Note that we use a ppx_deriver to generate a [show] function. We will need it in [arb_cmd]. But you can also implement it yourself if you prefer. Finally, the [run] function calls the library's function with the given arguments and [sut] and wraps the result with information about its type in a {{!STM.res}res} type. {3 The model definition} [state] is the type of the model. The model should be pure and simple enough to be obviously correct. Here we use a simple {{!Stdlib.List.t}[list]} from the standard library. [qcheck-stm] also needs to know what is the model's initial value. This is provided by [init_state] and should be the model of the result of [init_sut ()]. The function [next_state] updates the [state] according to a [cmd]. Here, only the [Add] [cmd] changes the [state]. The result of running a [cmd] will be checked in [postcond]. The [precond] function checks whether the [cmd] can be run. Here, it is always the case. But this is useful when some library functions have preconditions. The [postcond] function is the last concerning the model against which the library will be tested. It takes a [cmd], the [state] {i before} running the [cmd] and the [res] returned by the [run] function. In this function, we express the relation between the result of the library's functions and the functional model. The fact that it takes the [state] before the call of the function will come in handy when we will add a {{!section-remove}[remove]} function to our set library. {3 The [cmd]s generation} The last thing to do is to tell [qcheck-stm] how to generate the [cmd]s. This is what is done by the [arb_cmd] function, using [QCheck]'s combinators. We will make two remarks on this function. The first one is that {!QCheck.make} takes an optional printer. It is important to provide it so that the test's output is printed. Here we use the function [show_cmd] that has been built by ppx_deriver from [cmd]'s definition. The second remark is that [arb_cmd] takes a [state] as argument. This allows to make the generation of [cmd]s depend on the [state] of the model. We don't use it here, but again, it will be demonstrated when we will add a {{!section-remove}[remove]} function to our set library. {2 Running our first tests} Now, we are set to run our first [qcheck-stm] tests! We will begin with some sequential testing. {!module-STM_sequential} provides a functor that exposes mainly two functions: - {{!STM_sequential.Make.agree_test}[agree_test]} to build a positive [QCheck] test, - {{!STM_sequential.Make.neg_agree_test}[neg_agree_test]} to build a negative [QCheck] test. Here, we expect the test to succeed, so we will use the first one. {[ module Lib_sequential = STM_sequential.Make (Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [ Lib_sequential.agree_test ~count:100 ~name:"STM sequential tests" ] ]} And the test fails... {[ $ dune exec ./mutable_set_v0.exe random seed: 499586059 generated error fail pass / total time test name [âś—] 2 0 1 1 / 100 0.0s STM sequential tests --- Failure -------------------------------------------------------------------- Test STM sequential tests failed (3 shrink steps): (Add 4231961964031379412) Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM sequential tests: Results incompatible with model (Add 4231961964031379412) : () Cardinal : 0 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) ]} In the case of a failing test, [qcheck-stm] gives the user the counter example it has found, after some shrinking steps, as it is customary in property-based testing {i Ă  la} QuickCheck. The counter example is a program. It is given twice: the first time just as a sequence of calls; the second time, each call is paired with the result of the computation. Looking at the output, we see that [Add 3591134320860609976] returns a [unit], which is to be expected. But the call to [Cardinal] returns [0] despite the fact that it has been run after the [Add]. We conclude that there is something wrong with our implementation of [add]. Indeed, we've forgotten to increment the [cardinal] field. This is easily fixed just by updating the [cardinal] field when adding an element. {[ module Lib = struct (* same as before *) let add a t = if not (mem a t) then begin t.content <- a :: t.content; t.cardinal <- t.cardinal + 1 end (* same as before *) end ]} When rerunning the sequential test, the output looks like that: {[ $ dune exec ./mutable_set_v1.exe random seed: 296715191 generated error fail pass / total time test name [âś“] 100 0 0 100 / 100 1.2s STM sequential tests ================================================================================ success (ran 1 tests) ]} We can see that the tests are successful. That means that the behaviours of all the 100 generated programs were consistent with the functional model we've given. {2 Parallel testing} We've now tested that, when run sequentially, our library behaves accordingly to the functional model we've given. The power of [qcheck-stm] comes from the fact that we can also test the behaviour of our library when run in a parallel or concurrent context. Let's say we want to test our library when it is used with OCaml domains. We just have to instantiate our specification with another functor. On the model of {!module-STM_sequential}, {!module-STM_domain} proposes a functor that exposes mainly two functions: - {{!STM_domain.Make.agree_test_par}[agree_test_par]} to build a positive [QCheck] linearization test of parallel programs run with [domains], - {{!STM_domain.Make.neg_agree_test_par}[neg_agree_test_par]} to build a negative [QCheck] linearization test of parallel programs run with [domains]. Here again, we expect the test to succeed, so we'll use the first one. {[ (* same as before *) module Lib_domain = STM_domain.Make (Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [ Lib_domain.agree_test_par ~count:100 ~name:"STM parallel tests" ] ]} And we are set to run the tests: {[ $ dune exec ./mutable_set_v2.exe random seed: 111516437 generated error fail pass / total time test name [âś—] 3 0 1 2 / 100 0.8s STM parallel tests --- Failure -------------------------------------------------------------------- Test STM parallel tests failed (13 shrink steps): | | .--------------------------. | | (Add 1435831017908725795) (Add 31161757608660161) Cardinal Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM parallel tests: Results incompatible with linearized model | | .------------------------------------. | | (Add 1435831017908725795) : () (Add 31161757608660161) : () Cardinal : 1 Cardinal : 1 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) ]} Here, the test fails again. This means, that even if the library is correct with respect to the given functional model when used sequentially, the library is not safe to be used in parallel. We can see that the output is a bit different than the one with the failing sequential test. This is because the generated programs are a bit different too. For testing with using {!Stdlib.Domain}, [qcheck-stm] generates a triplet of lists of calls: one sequential prefix to bring the system under test in a random state and two parallel suffixes. We can see in the minimal counter example proposed by [qcheck-stm] that there are some parallel writes and reads occurring. This is a classical mistake when writing parallel code known as a data race. Let's fix that by putting a lock on every operation. This will end up being quite slow. In a real-life program, you'll probably want to be a bit smarter than that. {[ module Lib : sig type 'a t val empty : unit -> 'a t val mem : 'a -> 'a t -> bool val add : 'a -> 'a t -> unit val cardinal : 'a t -> int end = struct type 'a t = { mutable content : 'a list; mutable cardinal : int; mutex : Mutex.t} let empty () = { content = []; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = List.mem a t.content let mem a t = Mutex.lock t.mutex; let b = mem_non_lock a t in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then begin t.content <- a :: t.content; t.cardinal <- t.cardinal + 1; end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let l = t.cardinal in Mutex.unlock t.mutex; l end ]} We had to make a lot of edits in the implementation. But, as far as we don't change the signature of the function we want to test, the specification is exactly the same. So we can directly run the test. {[ $ dune exec ./mutable_set_v3.exe random seed: 99077635 generated error fail pass / total time test name [âś“] 100 0 0 100 / 100 94.7s STM parallel tests ================================================================================ success (ran 1 tests) ]} This time, the test succeeds! {2:remove Add a [remove] function} Our library is now safe to be used in parallel and you are set to use [qcheck-stm]. In this last section, we will be adding a [remove] function to our little mutable set library. That will allow us to demonstrate two more things that can improve how you make use of [qcheck-stm]: - how to use [postcond], and more precisely how to make use of the fact that the [state] parameter refers to the state {i before} the execution of the [cmd], - how to use the [state] parameter in [arb_cmd] to skew the distribution of [cmd]s in a way that better fits our needs. First, for the sake of the example, we will give the [remove] function a slightly different signature than the [add] function. The [remove] function will return an optional element of the set, either the one that has been removed, or none if it was not an element of the set. Now, let's begin by updating the [postcond] function in the specification. As noted above, the [state] parameter of the [postcond] function is the [model]'s state {i before} the execution of the [cmd] (that is before the computation of [next_state cmd state]). This is useful because we can now check that the result of the [remove] function is correct according to the model's [state]. {[ let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | Remove i, Res ((Option Int, _), Some x) -> List.mem i state && i = x | Remove i, Res ((Option Int, _), None) -> not (List.mem i state) | _ -> false ]} Here, we can pattern match on the result of the [Remove i] [cmd] and express the fact that if this result is [Some x] then [i] was indeed in the set and [i] and [x] are structurally equal. On the other hand, if the result is [None], then [i] was not in the set. Now, let's say we have updated [arb_cmd] just by adding a generator for the [Remove] [cmd] similar to the other ones: {[ let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; Gen.map (fun i -> Remove i) Gen.int; ]) ]} Then, if we make the same mistake as above for the [add] function, namely: {[ let remove a t = Mutex.lock t.mutex; let r = if mem_non_lock a t then begin t.content <- S.remove a t.content; (* t.cardinal <- t.cardinal - 1; *) Some a end else None in Mutex.unlock t.mutex; r ]} most of the time, [qcheck-stm] won't be able to spot the bug: {[ $ dune exec ./mutable_set_v4.exe random seed: 423411827 generated error fail pass / total time test name [âś“] 100 0 0 100 / 100 0.8s STM sequential tests ================================================================================ success (ran 1 tests) ]} The reason why is that there is very little chance to generate an argument for [Remove] corresponding to an element already added to the set in the same program. So the conditional branch where the mistake has been made is never explored. But be sure that it will be in real life! In order to overcome this problem, it is possible to skew the distribution of generated [cmd]s by looking at the [state] parameter. If the model of the set is empty, then we just generate a random element. But if there are already some elements in the set, then we can choose between picking one of them or generating a random new one. Now that we are aware of the problem, we also update the generators for [Mem] and [Add] which suffer from the same weakness. {[ let arb_cmd state = let gen = match state with | [] -> Gen.int | xs -> Gen.(oneof [oneofl xs; int]) in QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) gen; Gen.map (fun i -> Add i) gen; Gen.map (fun i -> Remove i) gen; ]) ]} This will be enough to trigger a failure in the test which can help us correct our implementation. {[ $ dune exec ./mutable_set_v5.exe random seed: 185490690 generated error fail pass / total time test name [âś—] 1 0 1 0 / 100 0.0s STM sequential tests --- Failure -------------------------------------------------------------------- Test STM sequential tests failed (9 shrink steps): (Add -410825599021310838) (Remove -410825599021310838) Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM sequential tests: Results incompatible with model (Add -410825599021310838) : () (Remove -410825599021310838) : Some (-410825599021310838) Cardinal : 1 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) ]} We see in the output that there is indeed a [Remove] of a previously added element. So this execution path is now explored. As there is only one [Add], one [Remove] of the added element and then [Cardinal] returns [1], we can easily conclude there is something wrong in the implementation of the removal of an element when the element is indeed in the set. {1 [STM] in a bit more detail} [STM] uses QCheck and OCaml's pseudo-random number generator from the [Random] module to generate arbitrary [cmd] sequences and arbitrary input argument data to each call. To recreate a problematic test run, one therefore needs to generate the same pseudo-random test case input, by passing the same randomness seed. By running the [STM] tests using [QCheck_base_runner.run_tests_main] from QCheck, it is possible to pass a seed as a command line argument as follows: {[ $ dune exec ./mutable_set_v5.exe -- -s 185490690 ]} For {!STM_sequential} this is enough to ensure that we deterministically generate the same sequence of calls. With {!STM_domain} and {!STM_thread} one may however still experience different behaviours on subsequent reruns of the resulting test, because of CPU scheduling and other factors. This may materialize as different counterexamples being printed or as one run failing the test whereas another run passes it. {!STM_domain} uses the {!Util.repeat} combinator to repeat each test case 25 times to address the issue and help increase reproducibility. {1 Current limitations} [STM] comes with a couple of limitations: - Currently {!STM} is missing {!STM.ty_show} product combinators to express tuple result types. The underlying {!STM.ty} type is extensible though, and hence allows users to implement their own tuple combinators. - In some circumstances OCaml's type checker fails to infer the intended type of {!STM.Spec.postcond}. Annotating the function header [let postcond c (s : state) res = ...] and avoiding the polymorphic equality function [(=) : 'a -> 'a -> bool] in [postcond]'s body should address the issue. multicoretests-0.7/doc/stm/mutable_set_v0.ml000066400000000000000000000036411474367232000212750ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int } let empty () = { content = S.empty; cardinal = 0 } let mem a t = S.mem a t.content let add a t = t.content <- S.add a t.content let cardinal t = t.cardinal end end open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | _ -> false let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; ]) end module Lib_sequential = STM_sequential.Make(Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [Lib_sequential.agree_test ~count:100 ~name:"STM sequential tests"] multicoretests-0.7/doc/stm/mutable_set_v1.ml000066400000000000000000000040001474367232000212640ustar00rootroot00000000000000open QCheck open STM module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int } let empty () = { content = S.empty; cardinal = 0 } let mem a t = S.mem a t.content let add a t = if not (mem a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1 end let cardinal t = t.cardinal end end module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | _ -> false let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; ]) end module Lib_sequential = STM_sequential.Make(Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [Lib_sequential.agree_test ~count:100 ~name:"STM sequential tests"] multicoretests-0.7/doc/stm/mutable_set_v2.ml000066400000000000000000000037651474367232000213060ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int } let empty () = { content = S.empty; cardinal = 0 } let mem a t = S.mem a t.content let add a t = if not (mem a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1 end let cardinal t = t.cardinal end end open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | _ -> false let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; ]) end module Lib_domain = STM_domain.Make(Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [Lib_domain.agree_test_par ~count:100 ~name:"STM parallel tests"] multicoretests-0.7/doc/stm/mutable_set_v3.ml000066400000000000000000000044731474367232000213040ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int; mutex : Mutex.t} let empty () = { content = S.empty; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = S.mem a t.content let mem a t = Mutex.lock t.mutex; let b = mem_non_lock a t in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1; end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let c = t.cardinal in Mutex.unlock t.mutex; c end end open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | _ -> false let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; ]) end module Lib_domain = STM_domain.Make(Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [Lib_domain.agree_test_par ~count:100 ~name:"STM parallel tests"] multicoretests-0.7/doc/stm/mutable_set_v4.ml000066400000000000000000000060501474367232000212760ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int val remove : elt -> t -> elt option end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int; mutex : Mutex.t} let empty () = { content = S.empty; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = S.mem a t.content let mem a t = Mutex.lock t.mutex; let b = mem_non_lock a t in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1; end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let c = t.cardinal in Mutex.unlock t.mutex; c let remove a t = Mutex.lock t.mutex; let r = if mem_non_lock a t then begin t.content <- S.remove a t.content; (* t.cardinal <- t.cardinal - 1; *) Some a end else None in Mutex.unlock t.mutex; r end end open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal | Remove of int [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) | Remove i -> Res (option int, S.remove i sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state | Remove i -> if List.mem i state then List.filter (fun x -> x <> i) state else state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | Remove i, Res ((Option Int, _), Some x) -> List.mem i state && i = x | Remove i, Res ((Option Int, _), None) -> not (List.mem i state) | _ -> false let arb_cmd _state = QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) Gen.int; Gen.map (fun i -> Add i) Gen.int; Gen.map (fun i -> Remove i) Gen.int; ]) end module Lib_sequential = STM_sequential.Make(Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [Lib_sequential.agree_test ~count:100 ~name:"STM sequential tests"] multicoretests-0.7/doc/stm/mutable_set_v5.ml000066400000000000000000000062101474367232000212750ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int val remove : elt -> t -> elt option end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int; mutex : Mutex.t} let empty () = { content = S.empty; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = S.mem a t.content let mem a t = Mutex.lock t.mutex; let b = mem_non_lock a t in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1; end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let c = t.cardinal in Mutex.unlock t.mutex; c let remove a t = Mutex.lock t.mutex; let r = if mem_non_lock a t then begin t.content <- S.remove a t.content; (* t.cardinal <- t.cardinal - 1; *) Some a end else None in Mutex.unlock t.mutex; r end end open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = | Mem of int | Add of int | Cardinal | Remove of int [@@deriving show { with_path = false }] let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) | Remove i -> Res (option int, S.remove i sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state | Remove i -> if List.mem i state then List.filter (fun x -> x <> i) state else state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | Remove i, Res ((Option Int, _), Some x) -> List.mem i state && i = x | Remove i, Res ((Option Int, _), None) -> not (List.mem i state) | _ -> false let arb_cmd state = let gen = match state with | [] -> Gen.int | xs -> Gen.(oneof [oneofl xs; int]) in QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) gen; Gen.map (fun i -> Add i) gen; Gen.map (fun i -> Remove i) gen; ]) end module Lib_sequential = STM_sequential.Make(Lib_spec) let _ = QCheck_base_runner.run_tests ~verbose:true [Lib_sequential.agree_test ~count:100 ~name:"STM sequential tests"] multicoretests-0.7/doc/util/000077500000000000000000000000001474367232000162005ustar00rootroot00000000000000multicoretests-0.7/doc/util/dune000066400000000000000000000001131474367232000170510ustar00rootroot00000000000000(documentation (package qcheck-multicoretests-util) (mld_files index)) multicoretests-0.7/doc/util/index.mld000066400000000000000000000012461474367232000200100ustar00rootroot00000000000000{0 qcheck-multicoretests-util} The package offers a {!Util} module with a number of reusable functions handy for multicore testing. {1 An example} For example, the function {!Util.repeat} is handy to repeatedly test a non-deterministic property that may behave differently on repeated reruns. Consider a regular [QCheck] test such as the following: {[ open QCheck let test = Test.make ~name:"example test" small_int some_int_property ]} The following adaption of [test] will now fail if just one of the 50 repetitions fail to satisfy the tested property: {[ let test = Test.make ~name:"example test with repetition" small_int (Util.repeat 50 some_int_property) ]} multicoretests-0.7/dune000066400000000000000000000037271474367232000153450ustar00rootroot00000000000000(env (debug-runtime (link_flags :standard -runtime-variant=d) (env-vars (MCTUTILS_TRUNCATE 50))) (_ (env-vars (MCTUTILS_TRUNCATE 50))) ) (vendored_dirs qcheck) ;; make `dune build` target a recursive default target (alias (name default) (package multicoretests) (deps (alias src/default))) ; The main test alias (alias (name testsuite) (package multicoretests) (deps (alias_rec src/runtest))) ; The internal tests alias (alias (name internaltests) (package multicoretests) (deps (alias_rec test/runtest))) ; The aliases to control what is run in CI ; It can either be the full test suite, or focus on a single test (alias (name ci) (package multicoretests) (deps (alias_rec %{env:DUNE_CI_ALIAS=testsuite}))) ; (alias_rec focusedtest))) ; @focusedtest ; repeat a single test a couple of times ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; A rule to repeat the test executable given as dependency a couple of ; times and report at the end whether this worked ; To change the test to repeat, change the source of the `copy`: (rule (copy src/io/lin_tests_domain.exe focusedtest.exe)) (rule (alias focusedtest) (package multicoretests) (deps focusedtest.exe) (enabled_if (<> %{os_type} Win32)) (action (no-infer (progn (write-file hoped "") (write-file failed-runs "") (bash "for i in `seq 20`; do echo Starting $i-th run; if ! ./focusedtest.exe -v ; then echo $i >> failed-runs; fi; done") ; edit the previous line to focus on a particular seed (diff failed-runs hoped))))) (rule (alias focusedtest) (package multicoretests) (deps focusedtest.exe) (enabled_if (= %{os_type} Win32)) (action (no-infer (progn (write-file hoped "") (write-file failed-runs "") (run cmd /q /c "for %G in (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20) do (echo Starting %G-th run && focusedtest.exe -v || echo %G >> failed-runs)") ; edit the previous line to focus on a particular seed (diff failed-runs hoped))))) multicoretests-0.7/dune-project000066400000000000000000000043641474367232000170070ustar00rootroot00000000000000(lang dune 3.0) (name multicoretests) (generate_opam_files true) (source (github ocaml-multicore/multicoretests)) (authors "Jan Midtgaard" "Olivier Nicole" "Nicolas Osborne" "Samuel Hym") (maintainers "Jan Midtgaard ") (license BSD-2-clause) (version "0.7") (package (name multicoretests) (synopsis "Experimental multicore test suite of OCaml 5.0") (authors "Multiple contributors") (description "This package contains a collection of randomized QCheck tests to exercise the multicore run-time of OCaml 5.0.") (tags ("test" "test suite" "property" "qcheck" "quickcheck" "multicore" "non-determinism")) (depends base-domains (qcheck-core (>= "0.23")) (qcheck-lin (= :version)) (qcheck-stm (= :version)))) (package (name qcheck-stm) (synopsis "State-machine testing library for sequential and parallel model-based tests") (description "A state-machine testing library based on QCheck that can generate both sequential and parallel tests against a declarative model.") (tags ("test" "property" "qcheck" "quickcheck" "state-machine testing" "model-based testing" "parallel testing")) (depopts base-domains) (depends (ocaml (>= 4.12)) (qcheck-core (>= "0.23")) (qcheck-multicoretests-util (= :version)))) (package (name qcheck-lin) (synopsis "A multicore testing library for OCaml") (description "A testing library based on QCheck to test interface behaviour under parallel usage. Lin will generate and run random parallel tests and check the observed behaviour for sequential consistency, that is, whether they can be linearized and explained by some sequential interleaving.") (tags ("test" "property" "qcheck" "quickcheck" "parallelism" "sequential consistency")) (depopts base-domains) (depends (ocaml (>= 4.12)) (qcheck-core (>= "0.23")) (qcheck-multicoretests-util (= :version)))) (package (name qcheck-multicoretests-util) (synopsis "Various utility functions for property-based testing of multicore programs") (description "A small library of utility functions for QCheck-based testing of multicore programs.") (tags ("test" "property" "qcheck" "quickcheck" "multicore" "non-determinism")) (depends (ocaml (>= 4.12)) (qcheck-core (>= "0.23")))) multicoretests-0.7/dune-workspace000066400000000000000000000000001474367232000173160ustar00rootroot00000000000000multicoretests-0.7/lib/000077500000000000000000000000001474367232000152245ustar00rootroot00000000000000multicoretests-0.7/lib/STM.ml000066400000000000000000000272721474367232000162330ustar00rootroot00000000000000(** Base module for specifying STM tests *) open QCheck type 'a ty = .. type _ ty += | Unit : unit ty | Bool : bool ty | Char : char ty | Int : int ty | Int32 : int32 ty | Int64 : int64 ty | Float : float ty | String : string ty | Bytes : bytes ty | Exn : exn ty | Option : 'a ty -> 'a option ty | Result : 'a ty * 'b ty -> ('a, 'b) result ty | List : 'a ty -> 'a list ty | Array : 'a ty -> 'a array ty | Seq : 'a ty -> 'a Seq.t ty type 'a ty_show = 'a ty * ('a -> string) let unit = (Unit, QCheck.Print.unit) let bool = (Bool, QCheck.Print.bool) let char = (Char, QCheck.Print.char) let int = (Int, QCheck.Print.int) let int32 = (Int32, Int32.to_string) let int64 = (Int64, Int64.to_string) let float = (Float, QCheck.Print.float) let string = (String, QCheck.Print.string) let bytes = (Bytes, QCheck.Print.bytes) let option spec = let (ty,show) = spec in (Option ty, QCheck.Print.option show) let exn = (Exn, Printexc.to_string) let show_result show_ok show_err = function | Ok x -> Printf.sprintf "Ok (%s)" (show_ok x) | Error y -> Printf.sprintf "Error (%s)" (show_err y) let result spec_ok spec_err = let (ty_ok, show_ok) = spec_ok in let (ty_err, show_err) = spec_err in (Result (ty_ok, ty_err), show_result show_ok show_err) let list spec = let (ty,show) = spec in (List ty, QCheck.Print.list show) let array spec = let (ty,show) = spec in (Array ty, QCheck.Print.array show) let seq spec = let (ty,show) = spec in (Seq ty, fun s -> QCheck.Print.list show (List.of_seq s)) type res = Res : 'a ty_show * 'a -> res let show_res (Res ((_,show), v)) = show v (** The specification of a state machine. *) module type Spec = sig type cmd (** The type of commands *) type state (** The type of the model's state *) type sut (** The type of the system under test *) val arb_cmd : state -> cmd arbitrary (** A command generator. Accepts a state parameter to enable state-dependent [cmd] generation. *) val init_state : state (** The model's initial state. *) val show_cmd : cmd -> string (** [show_cmd c] returns a string representing the command [c]. *) val next_state : cmd -> state -> state (** Move the internal state machine to the next state. *) val init_sut : unit -> sut (** Initialize the system under test. *) val cleanup : sut -> unit (** Utility function to clean up the [sut] after each test instance, e.g., for closing sockets, files, or resetting global parameters*) val precond : cmd -> state -> bool (** [precond c s] expresses preconditions for command [c]. This is useful, e.g., to prevent the shrinker from breaking invariants when minimizing counterexamples. *) val run : cmd -> sut -> res (** [run c i] should interpret the command [c] over the system under test (typically side-effecting). *) val postcond : cmd -> state -> res -> bool (** [postcond c s res] checks whether [res] arising from interpreting the command [c] over the system under test with [run] agrees with the model's result. Note: [s] is in this case the model's state prior to command execution. *) end module type SpecExt = sig include Spec val wrap_cmd_seq : (unit -> 'a) -> 'a end module SpecDefaults = struct let cleanup = ignore let precond _ _ = true let wrap_cmd_seq th = th () end module Internal = struct module Make(Spec : Spec) = struct let rec gen_cmds arb s fuel = Gen.(if fuel = 0 then return [] else (arb s).gen >>= fun c -> let s' = try Spec.next_state c s with _ -> s in (gen_cmds arb s' (fuel-1)) >>= fun cs -> return (c::cs)) (** A fueled command list generator. Accepts a state parameter to enable state-dependent [cmd] generation. *) let rec cmds_ok s cs = match cs with | [] -> true | c::cs -> Spec.precond c s && let s' = try Spec.next_state c s with _ -> s in cmds_ok s' cs (* This is an adaption of [QCheck.Shrink.list_spine] with more base cases added *) let rec shrink_list_spine l yield = let rec split l len acc = match len,l with | _,[] | 0,_ -> List.rev acc, l | _,x::xs -> split xs (len-1) (x::acc) in match l with | [] -> () | [_] -> yield [] | [x;y] -> yield []; yield [x]; yield [y] | [x;y;z] -> yield [x]; yield [x;y]; yield [x;z]; yield [y;z] | [x;y;z;w] -> yield [x;y;z]; yield [x;y;w]; yield [x;z;w]; yield [y;z;w] | _::_ -> let len = List.length l in let xs,ys = split l ((1 + len) / 2) [] in yield xs; shrink_list_spine xs (fun xs' -> yield (xs'@ys)) (* This is an adaption of [QCheck.Shrink.list] *) let shrink_list ?shrink l yield = shrink_list_spine l yield; match shrink with | None -> () (* no elem. shrinker provided *) | Some shrink -> Shrink.list_elems shrink l yield let gen_cmds_size gen s size_gen = Gen.sized_size size_gen (gen_cmds gen s) let cmd_list_size_dist mean = let skew = 0.75 in (* to avoid too many empty cmd lists *) Gen.map (fun p -> int_of_float (p +. skew)) (Gen.exponential mean) let arb_cmds s = let mean = 10. in (* generate on average ~10 cmds, ignoring skew *) let cmds_gen = gen_cmds_size Spec.arb_cmd s (cmd_list_size_dist mean) in let shrinker = shrink_list ?shrink:(Spec.arb_cmd s).shrink in (* pass opt. elem. shrinker *) let ac = QCheck.make ~shrink:(Shrink.filter (cmds_ok Spec.init_state) shrinker) cmds_gen in (match (Spec.arb_cmd s).print with | None -> ac | Some p -> set_print (Util.print_vertical p) ac) let consistency_test ~count ~name = Test.make ~name ~count (arb_cmds Spec.init_state) (cmds_ok Spec.init_state) let rec interp_agree s sut cs = match cs with | [] -> true | c::cs -> let res = Spec.run c sut in let b = Spec.postcond c s res in let s' = Spec.next_state c s in b && interp_agree s' sut cs let rec check_disagree s sut cs = match cs with | [] -> None | c::cs -> let res = Spec.run c sut in let b = Spec.postcond c s res in if b then let s' = Spec.next_state c s in match check_disagree s' sut cs with | None -> None | Some rest -> Some ((c,res)::rest) else Some [c,res] (* checks that all interleavings of a cmd triple satisfies all preconditions *) let rec all_interleavings_ok pref cs1 cs2 s = match pref with | c::pref' -> Spec.precond c s && let s' = try Spec.next_state c s with _ -> s in all_interleavings_ok pref' cs1 cs2 s' | [] -> match cs1,cs2 with | [],[] -> true | [],c2::cs2' -> Spec.precond c2 s && let s' = try Spec.next_state c2 s with _ -> s in all_interleavings_ok pref cs1 cs2' s' | c1::cs1',[] -> Spec.precond c1 s && let s' = try Spec.next_state c1 s with _ -> s in all_interleavings_ok pref cs1' cs2 s' | c1::cs1',c2::cs2' -> (Spec.precond c1 s && let s' = try Spec.next_state c1 s with _ -> s in all_interleavings_ok pref cs1' cs2 s') && (Spec.precond c2 s && let s' = try Spec.next_state c2 s with _ -> s in all_interleavings_ok pref cs1 cs2' s') let rec check_obs pref cs1 cs2 s = match pref with | (c,res)::pref' -> let b = Spec.postcond c s res in b && check_obs pref' cs1 cs2 (Spec.next_state c s) | [] -> match cs1,cs2 with | [],[] -> true | [],(c2,res2)::cs2' -> let b = Spec.postcond c2 s res2 in b && check_obs pref cs1 cs2' (Spec.next_state c2 s) | (c1,res1)::cs1',[] -> let b = Spec.postcond c1 s res1 in b && check_obs pref cs1' cs2 (Spec.next_state c1 s) | (c1,res1)::cs1',(c2,res2)::cs2' -> (let b1 = Spec.postcond c1 s res1 in b1 && check_obs pref cs1' cs2 (Spec.next_state c1 s)) || (let b2 = Spec.postcond c2 s res2 in b2 && check_obs pref cs1 cs2' (Spec.next_state c2 s)) (* Shrinks a single cmd, starting in the given state *) let shrink_cmd arb cmd state = Option.value (arb state).shrink ~default:Shrink.nil @@ cmd (* Shrinks cmd list elements, starting in the given state *) let rec shrink_cmd_list_elems arb cs state = match cs with | [] -> Iter.empty | c::cs -> if Spec.precond c state then Iter.( map (fun c -> c::cs) (shrink_cmd arb c state) <+> map (fun cs -> c::cs) (shrink_cmd_list_elems arb cs Spec.(next_state c state)) ) else Iter.empty (* Shrinks cmd elements in triples *) let shrink_triple_elems arb0 arb1 arb2 (seq,p1,p2) = let shrink_prefix_elems cs state = Iter.map (fun cs -> (cs,p1,p2)) (shrink_cmd_list_elems arb0 cs state) in let rec shrink_par_suffix_elems cs state = match cs with | [] -> (* try only one option: p1s or p2s first - both valid interleavings *) Iter.(map (fun p1 -> (seq,p1,p2)) (shrink_cmd_list_elems arb1 p1 state) <+> map (fun p2 -> (seq,p1,p2)) (shrink_cmd_list_elems arb2 p2 state)) | c::cs -> (* walk seq prefix (again) to advance state *) if Spec.precond c state then shrink_par_suffix_elems cs Spec.(next_state c state) else Iter.empty in match Spec.(arb_cmd init_state).shrink with | None -> Iter.empty (* stop early if no cmd shrinker is available *) | Some _ -> Iter.(shrink_prefix_elems seq Spec.init_state <+> shrink_par_suffix_elems seq Spec.init_state) (* General shrinker of cmd triples *) let shrink_triple arb0 arb1 arb2 = let open Iter in Shrink.filter (fun (seq,p1,p2) -> all_interleavings_ok seq p1 p2 Spec.init_state) (fun ((seq,p1,p2) as triple) -> (* Shrinking heuristic: First reduce the cmd list sizes as much as possible, since the interleaving is most costly over long cmd lists. *) (map (fun seq' -> (seq',p1,p2)) (shrink_list_spine seq)) <+> (fun yield -> (match p1 with [] -> Iter.empty | c1::c1s -> Iter.return (seq@[c1],c1s,p2)) yield) <+> (fun yield -> (match p2 with [] -> Iter.empty | c2::c2s -> Iter.return (seq@[c2],p1,c2s)) yield) <+> (map (fun p1' -> (seq,p1',p2)) (shrink_list_spine p1)) <+> (map (fun p2' -> (seq,p1,p2')) (shrink_list_spine p2)) <+> (* Secondly reduce the cmd data of individual list elements *) (shrink_triple_elems arb0 arb1 arb2 triple)) let arb_triple seq_len par_len arb0 arb1 arb2 = let seq_pref_gen = gen_cmds_size arb0 Spec.init_state (Gen.int_bound seq_len) in let shrink_triple = shrink_triple arb0 arb1 arb2 in let gen_triple = Gen.(seq_pref_gen >>= fun seq_pref -> int_range 2 (2*par_len) >>= fun dbl_plen -> let spawn_state = List.fold_left (fun st c -> try Spec.next_state c st with _ -> st) Spec.init_state seq_pref in let par_len1 = dbl_plen/2 in let par_gen1 = gen_cmds_size arb1 spawn_state (return par_len1) in let par_gen2 = gen_cmds_size arb2 spawn_state (return (dbl_plen - par_len1)) in triple (return seq_pref) par_gen1 par_gen2) in make ~print:(Util.print_triple_vertical Spec.show_cmd) ~shrink:shrink_triple gen_triple let arb_cmds_triple seq_len par_len = arb_triple seq_len par_len Spec.arb_cmd Spec.arb_cmd Spec.arb_cmd end end include Util multicoretests-0.7/lib/STM.mli000066400000000000000000000237111474367232000163760ustar00rootroot00000000000000(** Module with combinators and definitions to specify an STM test *) (** Extensible type to represent result values *) type 'a ty = .. (** A range of constructors to represent built-in types *) type _ ty += | Unit : unit ty | Bool : bool ty | Char : char ty | Int : int ty | Int32 : int32 ty | Int64 : int64 ty | Float : float ty | String : string ty | Bytes : bytes ty | Exn : exn ty | Option : 'a ty -> 'a option ty | Result : 'a ty * 'b ty -> ('a, 'b) result ty | List : 'a ty -> 'a list ty | Array : 'a ty -> 'a array ty | Seq : 'a ty -> 'a Seq.t ty type 'a ty_show = 'a ty * ('a -> string) (** Combinator type to represent an OCaml type along with an associated [to_string] function *) val unit : unit ty_show (** Combinator to represent the {{!Stdlib.Unit.t}[unit]} type *) val bool : bool ty_show (** Combinator to represent the {{!Stdlib.Bool.t}[bool]} type *) val char : char ty_show (** Combinator to represent the {{!Stdlib.Char.t}[char]} type *) val int : int ty_show (** Combinator to represent the {{!Stdlib.Int.t}[int]} type *) val int32 : int32 ty_show (** Combinator to represent the {{!Stdlib.Int32.t}[int32]} type *) val int64 : int64 ty_show (** Combinator to represent the {{!Stdlib.Int64.t}[int64]} type *) val float : float ty_show (** Combinator to represent the {{!Stdlib.Float.t}[float]} type *) val string : string ty_show (** Combinator to represent the {{!Stdlib.String.t}[string]} type *) val bytes : bytes ty_show (** Combinator to represent the {{!Stdlib.Bytes.t}[bytes]} type *) val option : 'a ty_show -> 'a option ty_show (** [option t] builds a [t] {{!Stdlib.Option.t}[option]} type representation *) val exn : exn ty_show (** Combinator to represent the [exception] type *) val result : 'a ty_show -> 'b ty_show -> ('a,'b) Result.t ty_show (** [result a b] builds an [(a,b)] {{!Stdlib.Result.t}[result]} type representation *) val list : 'a ty_show -> 'a list ty_show (** [list t] builds a [t] {{!Stdlib.List.t}[list]} type representation *) val array : 'a ty_show -> 'a array ty_show (** [array t] builds a [t] {{!Stdlib.Array.t}[array]} type representation *) val seq : 'a ty_show -> 'a Seq.t ty_show (** [seq t] builds a [t] {{!Stdlib.Seq.t}[Seq.t]} type representation *) type res = Res : 'a ty_show * 'a -> res val show_res : res -> string (** The specification of a state machine. See also {!SpecExt} and {!SpecDefaults}. *) module type Spec = sig type cmd (** The type of commands *) type state (** The type of the model's state *) type sut (** The type of the system under test *) val arb_cmd : state -> cmd QCheck.arbitrary (** A command generator. Accepts a state parameter to enable state-dependent {!cmd} generation. *) val init_state : state (** The model's initial state. *) val show_cmd : cmd -> string (** [show_cmd c] returns a string representing the command [c]. *) val next_state : cmd -> state -> state (** [next_state c s] expresses how interpreting the command [c] moves the model's internal state machine from the state [s] to the next state. Ideally a [next_state] function is pure, as it is run more than once. *) val init_sut : unit -> sut (** Initialize the system under test. *) val cleanup : sut -> unit (** Utility function to clean up the {!sut} after each test instance, e.g., for closing sockets, files, or resetting global parameters*) val precond : cmd -> state -> bool (** [precond c s] expresses preconditions for command [c] in terms of the model state [s]. A [precond] function should be pure. [precond] is useful, e.g., to prevent the shrinker from breaking invariants when minimizing counterexamples. *) val run : cmd -> sut -> res (** [run c i] should interpret the command [c] over the system under test (typically side-effecting). *) val postcond : cmd -> state -> res -> bool (** [postcond c s res] checks whether [res] arising from interpreting the command [c] over the system under test with {!run} agrees with the model's result. A [postcond] function should be a pure. {b Note:} the state parameter [s] is the model's {!state} before executing the command [c] (the "old/pre" state). This is helpful to model, e.g., a [remove] [cmd] that returns the removed element. *) end module type SpecExt = sig (** Extended specification of a state machine. This signature may be extended in the future with new specifications that can be given defaults via {!SpecDefaults}. *) include Spec val wrap_cmd_seq : (unit -> 'a) -> 'a (** [wrap_cmd_seq] is used to wrap the execution of the generated command sequences. [wrap_cmd_seq] is useful, e.g., to handle effects performed by blocking primitives. [wrap_cmd_seq thunk] must call [thunk ()] and return or raise whatever [thunk ()] returned or raised. *) end module SpecDefaults : sig (** Default implementations for state machine specifications that can be given useful defaults. The intention is that extended spec modules would [include] the defaults: {[ module MySpec = struct include SpecDefaults (* ... *) end ]} This way the spec module can usually just continue working after new specifications have been added to {!SpecExt} with defaults in {!SpecDefaults}. *) val cleanup : 'sut -> unit (** [cleanup sut] just returns [()]. *) val precond : 'cmd -> 'state -> bool (** [precond cmd state] just returns [true]. *) val wrap_cmd_seq : (unit -> 'a) -> 'a (** [wrap_cmd_seq thunk] is equivalent to [thunk ()]. *) end module Internal : sig open QCheck (** Internal helper module to build STM tests. *) (** Derives a test framework from a state machine specification. *) module Make (Spec : Spec) : sig (** {3 The resulting test framework derived from a state machine specification} *) val cmds_ok : Spec.state -> Spec.cmd list -> bool (** A precondition checker (stops early, thanks to short-circuit Boolean evaluation). Accepts the initial state and the command sequence as parameters. [cmds_ok] catches and ignores exceptions arising from {!next_state}. *) val arb_cmds : Spec.state -> Spec.cmd list arbitrary (** A generator of command sequences. Accepts the initial state as parameter. *) val consistency_test : count:int -> name:string -> QCheck.Test.t (** A consistency test that generates a number of [cmd] sequences and checks that all contained [cmd]s satisfy the precondition [precond]. Accepts two labeled parameters: [count] is the test count and [name] is the printed test name. *) val interp_agree : Spec.state -> Spec.sut -> Spec.cmd list -> bool (** Checks agreement between the model and the system under test (stops early, thanks to short-circuit Boolean evaluation). *) val check_disagree : Spec.state -> Spec.sut -> Spec.cmd list -> (Spec.cmd * res) list option (** [check_disagree state sut pg] checks that none of the commands present in [pg] violated the declared postconditions when [pg] is run in [state]. Return [None] if none of the commands violate its postcondition, and [Some] list corresponding to the prefix of [pg] ending with the [cmd] violating its postcondition. *) val check_obs : (Spec.cmd * res) list -> (Spec.cmd * res) list -> (Spec.cmd * res) list -> Spec.state -> bool (** [check_obs pref cs1 cs2 s] tests whether the observations from the sequential prefix [pref] and the parallel traces [cs1] [cs2] agree with the model started in state [s]. *) val gen_cmds_size : (Spec.state -> Spec.cmd arbitrary) -> Spec.state -> int Gen.t -> Spec.cmd list Gen.t (** [gen_cmds_size arb state gen_int] generates a program of size generated by [gen_int] using [arb] to generate [cmd]s according to the current state. [state] is the starting state. [gen_cmds_size] catches and ignores generation-time exceptions arising from {!next_state}. *) val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) arbitrary (** [arb_cmds_triple seq_len par_len] generates a [cmd] triple with at most [seq_len] sequential commands and at most [par_len] parallel commands each. [arb_cmds_triple] catches and ignores generation-time exceptions arising from {!next_state}. *) val all_interleavings_ok : Spec.cmd list -> Spec.cmd list -> Spec.cmd list -> Spec.state -> bool (** [all_interleavings_ok seq spawn0 spawn1 state] checks that preconditions of all the {!cmd}s of [seq], [spawn0], and [spawn1] are satisfied in all the possible interleavings and starting with [state]. [all_interleavings_ok] catches and ignores exceptions arising from {!next_state}. *) val shrink_triple : (Spec.state -> Spec.cmd arbitrary) -> (Spec.state -> Spec.cmd arbitrary) -> (Spec.state -> Spec.cmd arbitrary) -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) Shrink.t (** [shrink_triple arb0 arb1 arb2] is a {!QCheck.Shrink.t} for programs (triple of list of [cmd]s) that is specialized for each part of the program. *) val arb_triple : int -> int -> (Spec.state -> Spec.cmd arbitrary) -> (Spec.state -> Spec.cmd arbitrary) -> (Spec.state -> Spec.cmd arbitrary) -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) arbitrary (** [arb_triple seq_len par_len arb0 arb1 arb2] generates a [cmd] triple with at most [seq_len] sequential commands and at most [par_len] parallel commands each. The three [cmd] components are generated with [arb0], [arb1], and [arb2], respectively. Each of these take the model state as a parameter. [arb_triple] catches and ignores generation-time exceptions arising from {!next_state}. *) end [@@alert internal "This module is exposed for internal uses only, its API may change at any time"] end val protect : ('a -> 'b) -> 'a -> ('b, exn) result (** [protect f] turns an [exception]-throwing function into a {{!Stdlib.Result.t}[result]}-returning function. *) multicoretests-0.7/lib/STM_domain.ml000066400000000000000000000132301474367232000175470ustar00rootroot00000000000000open STM module MakeExt (Spec: SpecExt) = struct open Util open QCheck open Internal.Make(Spec) [@alert "-internal"] let check_obs = check_obs let all_interleavings_ok (seq_pref,cmds1,cmds2) = all_interleavings_ok seq_pref cmds1 cmds2 Spec.init_state let arb_cmds_triple = arb_cmds_triple let arb_triple = arb_triple let arb_triple_asym seq_len par_len arb0 arb1 arb2 = let arb_triple = arb_triple seq_len par_len arb0 arb1 arb2 in set_print (print_triple_vertical ~center_prefix:false Spec.show_cmd) arb_triple (* operate over arrays to avoid needless allocation underway *) let interp_sut_res sut cs = let cs_arr = Array.of_list cs in let res_arr = Array.map (fun c -> Domain.cpu_relax(); Spec.run c sut) cs_arr in List.combine cs (Array.to_list res_arr) let run_par seq_pref cmds1 cmds2 = let sut = Spec.init_sut () in let pref_obs = Spec.wrap_cmd_seq @@ fun () -> interp_sut_res sut seq_pref in let barrier = Atomic.make 2 in let main cmds () = Spec.wrap_cmd_seq @@ fun () -> Atomic.decr barrier; while Atomic.get barrier <> 0 do Domain.cpu_relax() done; try Ok (interp_sut_res sut cmds) with exn -> Error exn in let dom1 = Domain.spawn (main cmds1) in let dom2 = Domain.spawn (main cmds2) in let obs1 = Domain.join dom1 in let obs2 = Domain.join dom2 in let () = Spec.cleanup sut in let obs1 = match obs1 with Ok v -> v | Error exn -> raise exn in let obs2 = match obs2 with Ok v -> v | Error exn -> raise exn in pref_obs, obs1, obs2 let agree_prop_par (seq_pref,cmds1,cmds2) = let pref_obs, obs1, obs2 = run_par seq_pref cmds1 cmds2 in check_obs pref_obs obs1 obs2 Spec.init_state || Test.fail_reportf " Results incompatible with linearized model\n\n%s" @@ print_triple_vertical ~fig_indent:5 ~res_width:35 (fun (c,r) -> Printf.sprintf "%s : %s" (Spec.show_cmd c) (show_res r)) (pref_obs,obs1,obs2) let stress_prop_par (seq_pref,cmds1,cmds2) = let _ = run_par seq_pref cmds1 cmds2 in true let agree_prop_par_asym (seq_pref, cmds1, cmds2) = let sut = Spec.init_sut () in let pref_obs = Spec.wrap_cmd_seq @@ fun () -> interp_sut_res sut seq_pref in let wait = Atomic.make 2 in let child_dom = Domain.spawn (fun () -> Spec.wrap_cmd_seq @@ fun () -> Atomic.decr wait; while Atomic.get wait <> 0 do Domain.cpu_relax() done; try Ok (interp_sut_res sut cmds2) with exn -> Error exn) in let parent_obs = Spec.wrap_cmd_seq @@ fun () -> Atomic.decr wait; while Atomic.get wait <> 0 do Domain.cpu_relax() done; try Ok (interp_sut_res sut cmds1) with exn -> Error exn in let child_obs = Domain.join child_dom in let () = Spec.cleanup sut in let parent_obs = match parent_obs with Ok v -> v | Error exn -> raise exn in let child_obs = match child_obs with Ok v -> v | Error exn -> raise exn in check_obs pref_obs parent_obs child_obs Spec.init_state || Test.fail_reportf " Results incompatible with linearized model:\n\n%s" @@ print_triple_vertical ~fig_indent:5 ~res_width:35 ~center_prefix:false (fun (c,r) -> Printf.sprintf "%s : %s" (Spec.show_cmd c) (show_res r)) (pref_obs,parent_obs,child_obs) let agree_test_par ~count ~name = let rep_count = 25 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make ~retries:10 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun triple -> assume (all_interleavings_ok triple); repeat rep_count agree_prop_par triple) (* 25 times each, then 25 * 10 times when shrinking *) let stress_test_par ~count ~name = let rep_count = 25 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make ~retries:10 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun triple -> assume (all_interleavings_ok triple); repeat rep_count stress_prop_par triple) (* 25 times each, then 25 * 10 times when shrinking *) let neg_agree_test_par ~count ~name = let rep_count = 25 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make_neg ~retries:10 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun triple -> assume (all_interleavings_ok triple); repeat rep_count agree_prop_par triple) (* 25 times each, then 25 * 10 times when shrinking *) let agree_test_par_asym ~count ~name = let rep_count = 25 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make ~retries:10 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun triple -> assume (all_interleavings_ok triple); repeat rep_count agree_prop_par_asym triple) (* 25 times each, then 25 * 10 times when shrinking *) let neg_agree_test_par_asym ~count ~name = let rep_count = 25 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make_neg ~retries:10 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun triple -> assume (all_interleavings_ok triple); repeat rep_count agree_prop_par_asym triple) (* 25 times each, then 25 * 10 times when shrinking *) end module Make (Spec: Spec) = MakeExt (struct include SpecDefaults include Spec end) multicoretests-0.7/lib/STM_domain.mli000066400000000000000000000140711474367232000177240ustar00rootroot00000000000000(** Module for building parallel STM tests over {!Stdlib.Domain}s *) module Make : functor (Spec : STM.Spec) -> sig val check_obs : (Spec.cmd * STM.res) list -> (Spec.cmd * STM.res) list -> (Spec.cmd * STM.res) list -> Spec.state -> bool (** [check_obs pref cs1 cs2 s] tests whether the observations from the sequential prefix [pref] and the parallel traces [cs1] [cs2] agree with the model started in state [s]. *) val all_interleavings_ok : (Spec.cmd list * Spec.cmd list * Spec.cmd list) -> bool (** [all_interleavings_ok (seq,spawn0,spawn1)] checks that preconditions of all the {!cmd}s of [seq], [spawn0], and [spawn1] are satisfied in all the possible interleavings and starting with {!Spec.init_state}. [all_interleavings_ok] catches and ignores exceptions arising from {!next_state}. *) val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary (** [arb_cmds_triple seq_len par_len] generates a [cmd] triple with at most [seq_len] sequential commands and at most [par_len] parallel commands each. All [cmds] are generated with {!Spec.arb_cmd}. [arb_cmds_triple] catches and ignores generation-time exceptions arising from {!Spec.next_state}. *) val arb_triple : int -> int -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary (** [arb_triple seq_len par_len arb0 arb1 arb2] generates a [cmd] triple with at most [seq_len] sequential commands and at most [par_len] parallel commands each. The three {!Spec.cmd} components are generated with [arb0], [arb1], and [arb2], respectively. Each of these take the model state as a parameter. [arb_triple] catches and ignores generation-time exceptions arising from {!Spec.next_state}. *) val arb_triple_asym : int -> int -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.state -> Spec.cmd QCheck.arbitrary) -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary (** [arb_triple_asym seq_len par_len arb0 arb1 arb2] creates a triple [cmd] generator like {!arb_triple}. It differs in that the resulting printer is asymmetric, printing [arb1]'s result below [arb0]'s result and printing [arb2]'s result to the right of [arb1]'s result. [arb_triple_asym] catches and ignores generation-time exceptions arising from {!Spec.next_state}. *) val interp_sut_res : Spec.sut -> Spec.cmd list -> (Spec.cmd * STM.res) list (** [interp_sut_res sut cs] interprets the commands [cs] over the system {!Spec.sut} and returns the list of corresponding {!Spec.cmd} and result pairs. *) val stress_prop_par : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool (** Parallel stress testing property based on {!Stdlib.Domain}. [stress_prop_par (seq_pref, tl1, tl2)] first interprets [seq_pref] and then spawns two parallel, symmetric domains interpreting [tl1] and [tl2] simultaneously. In contrast to {!agree_prop_par}, [stress_prop_par] does not perform an interleaving search. @return [true] if no unexpected exceptions or crashes are encountered. *) val agree_prop_par : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool (** Parallel agreement property based on {!Stdlib.Domain}. [agree_prop_par (seq_pref, tl1, tl2)] first interprets [seq_pref] and then spawns two parallel, symmetric domains interpreting [tl1] and [tl2] simultaneously. @return [true] if there exists a sequential interleaving of the results which agrees with a model interpretation. *) val agree_prop_par_asym : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool (** Asymmetric parallel agreement property based on {!Stdlib.Domain}. [agree_prop_par_asym (seq_pref, tl1, tl2)] first interprets [seq_pref], and then interprets [tl1] while a spawned domain interprets [tl2] in parallel with the parent domain. @return [true] if there exists a sequential interleaving of the results which agrees with a model interpretation. *) val agree_test_par : count:int -> name:string -> QCheck.Test.t (** Parallel agreement test based on {!Stdlib.Domain} which combines [repeat] and [~retries]. Accepts two labeled parameters: [count] is the number of test iterations and [name] is the printed test name. *) val neg_agree_test_par : count:int -> name:string -> QCheck.Test.t (** A negative parallel agreement test (for convenience). Accepts two labeled parameters: [count] is the number of test iterations and [name] is the printed test name. *) val agree_test_par_asym : count:int -> name:string -> QCheck.Test.t (** Asymmetric parallel agreement test based on {!Stdlib.Domain} and {!agree_prop_par_asym} which combines [repeat] and [~retries]. Accepts two labeled parameters: [count] is the number of test iterations and [name] is the printed test name. *) val neg_agree_test_par_asym : count:int -> name:string -> QCheck.Test.t (** A negative asymmetric parallel agreement test (for convenience). Accepts two labeled parameters: [count] is the number of test iterations and [name] is the printed test name. *) val stress_test_par : count:int -> name:string -> QCheck.Test.t (** Parallel stress test based on {!Stdlib.Domain} which combines [repeat] and [~retries]. Accepts two labeled parameters: [count] is the number of test iterations and [name] is the printed test name. The test fails if an unexpected exception is raised underway. It is intended as a stress test to run operations at a high frequency and detect unexpected exceptions or crashes. It does not perform an interleaving search like {!agree_test_par} and {!neg_agree_test_par}. *) end module MakeExt : functor (Spec : STM.SpecExt) -> module type of Make (Spec) multicoretests-0.7/lib/STM_sequential.ml000066400000000000000000000022321474367232000204520ustar00rootroot00000000000000open STM module MakeExt (Spec: SpecExt) = struct open QCheck open Internal.Make(Spec) [@alert "-internal"] (* re-export some functions *) let cmds_ok = cmds_ok let arb_cmds = arb_cmds let print_seq_trace trace = List.fold_left (fun acc (c,r) -> Printf.sprintf "%s\n %s : %s" acc (Spec.show_cmd c) (show_res r)) "" trace let agree_prop cs = assume (cmds_ok Spec.init_state cs); let sut = Spec.init_sut () in (* reset system's state *) let res = try Ok (Spec.wrap_cmd_seq @@ fun () -> check_disagree Spec.init_state sut cs) with exn -> Error exn in let () = Spec.cleanup sut in let res = match res with Ok res -> res | Error exn -> raise exn in match res with | None -> true | Some trace -> Test.fail_reportf " Results incompatible with model\n%s" @@ print_seq_trace trace let agree_test ~count ~name = Test.make ~name ~count (arb_cmds Spec.init_state) agree_prop let neg_agree_test ~count ~name = Test.make_neg ~name ~count (arb_cmds Spec.init_state) agree_prop end module Make (Spec : Spec) = MakeExt (struct include SpecDefaults include Spec end) multicoretests-0.7/lib/STM_sequential.mli000066400000000000000000000027021474367232000206250ustar00rootroot00000000000000(** Module for building sequential STM tests *) module Make : functor (Spec : STM.Spec) -> sig val cmds_ok : Spec.state -> Spec.cmd list -> bool (** A precondition checker (stops early, thanks to short-circuit Boolean evaluation). Accepts the initial state and the command sequence as parameters. [cmds_ok] catches and ignores exceptions arising from {!next_state}. *) val arb_cmds : Spec.state -> Spec.cmd list QCheck.arbitrary (** A generator of {!Spec.cmd} sequences. Accepts the initial state as a parameter. [arb_cmds] catches and ignores generation-time exceptions arising from {!Spec.next_state}. *) val agree_prop : Spec.cmd list -> bool (** The agreement property: the command sequence [cs] yields the same observations when interpreted from the model's initial state and the [sut]'s initial state. Cleans up after itself by calling {!Spec.cleanup}. *) val agree_test : count:int -> name:string -> QCheck.Test.t (** An actual agreement test (for convenience). Accepts two labeled parameters: [count] is the test count and [name] is the printed test name. *) val neg_agree_test : count:int -> name:string -> QCheck.Test.t (** A negative agreement test (for convenience). Accepts two labeled parameters: [count] is the test count and [name] is the printed test name. *) end module MakeExt : functor (Spec : STM.SpecExt) -> module type of Make (Spec) multicoretests-0.7/lib/STM_thread.ml000066400000000000000000000055101474367232000175510ustar00rootroot00000000000000open STM module MakeExt (Spec: SpecExt) = struct open Util open QCheck open Internal.Make(Spec) [@alert "-internal"] exception ThreadNotFinished let arb_cmds_triple = arb_cmds_triple (* [interp_sut_res] specialized for [Threads] *) let rec interp_sut_res sut cs = match cs with | [] -> [] | c::cs -> Thread.yield (); let res = Spec.run c sut in (c,res)::interp_sut_res sut cs (* Concurrent agreement property based on [Threads] *) let agree_prop_conc (seq_pref,cmds1,cmds2) = let sut = Spec.init_sut () in let obs1,obs2 = ref (Error ThreadNotFinished), ref (Error ThreadNotFinished) in let pref_obs = Spec.wrap_cmd_seq @@ fun () -> interp_sut_res sut seq_pref in let wait = ref true in let th1 = Thread.create (fun () -> Spec.wrap_cmd_seq @@ fun () -> while !wait do Thread.yield () done; obs1 := try Ok (interp_sut_res sut cmds1) with exn -> Error exn) () in let th2 = Thread.create (fun () -> Spec.wrap_cmd_seq @@ fun () -> wait := false; obs2 := try Ok (interp_sut_res sut cmds2) with exn -> Error exn) () in let () = Thread.join th1 in let () = Thread.join th2 in let () = Spec.cleanup sut in let obs1 = match !obs1 with Ok v -> v | Error exn -> raise exn in let obs2 = match !obs2 with Ok v -> v | Error exn -> raise exn in check_obs pref_obs obs1 obs2 Spec.init_state || Test.fail_reportf " Results incompatible with linearized model\n\n%s" @@ print_triple_vertical ~fig_indent:5 ~res_width:35 (fun (c,r) -> Printf.sprintf "%s : %s" (Spec.show_cmd c) (show_res r)) (pref_obs,obs1,obs2) let agree_test_conc ~count ~name = (* a bigger [rep_count] for [Threads] as it is more difficult to trigger a problem *) let rep_count = 100 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make ~retries:15 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun ((seq_pref,cmds1,cmds2) as triple) -> assume (all_interleavings_ok seq_pref cmds1 cmds2 Spec.init_state); repeat rep_count agree_prop_conc triple) (* 100 times each, then 100 * 15 times when shrinking *) let neg_agree_test_conc ~count ~name = let rep_count = 100 in let seq_len,par_len = 20,12 in let max_gen = 3*count in (* precond filtering may require extra generation: max. 3*count though *) Test.make_neg ~retries:15 ~max_gen ~count ~name (arb_cmds_triple seq_len par_len) (fun ((seq_pref,cmds1,cmds2) as triple) -> assume (all_interleavings_ok seq_pref cmds1 cmds2 Spec.init_state); repeat rep_count agree_prop_conc triple) (* 100 times each, then 100 * 15 times when shrinking *) end module Make (Spec: Spec) = MakeExt (struct include SpecDefaults include Spec end) multicoretests-0.7/lib/STM_thread.mli000066400000000000000000000032641474367232000177260ustar00rootroot00000000000000(** Module for building concurrent STM tests over {!Thread}s *) module Make : functor (Spec : STM.Spec) -> sig exception ThreadNotFinished val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary (** [arb_cmds_triple seq_len conc_len] generates a [cmd] triple with at most [seq_len] sequential commands and at most [conc_len] concurrent commands each. All [cmds] are generated with {!Spec.arb_cmd}. [arb_cmds_triple] catches and ignores generation-time exceptions arising from {!Spec.next_state}. *) val interp_sut_res : Spec.sut -> Spec.cmd list -> (Spec.cmd * STM.res) list (** [interp_sut_res sut cs] interprets the commands [cs] over the system [sut] and returns the list of corresponding {!Spec.cmd} and result pairs. *) val agree_prop_conc : Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool (** Concurrent agreement property based on {!Thread} *) val agree_test_conc : count:int -> name:string -> QCheck.Test.t (** Concurrent agreement test based on {!Thread} which combines [repeat] and [~retries] *) val neg_agree_test_conc : count:int -> name:string -> QCheck.Test.t (** A negative agreement test (for convenience). Accepts two labeled parameters: [count] is the test count and [name] is the printed test name. *) end [@@alert experimental "This module is experimental: It may fail to trigger concurrency issues that are present."] module MakeExt : functor (Spec : STM.SpecExt) -> module type of Make (Spec) [@@alert "-experimental"] [@@alert experimental "This module is experimental: It may fail to trigger concurrency issues that are present."] multicoretests-0.7/lib/dune000066400000000000000000000025771474367232000161150ustar00rootroot00000000000000(library (name STM) (public_name qcheck-stm.stm) (modules STM) (libraries qcheck-core qcheck-multicoretests-util)) (library (name STM_sequential) (public_name qcheck-stm.sequential) (modules STM_sequential) (libraries qcheck-core qcheck-stm.stm)) (library (name STM_domain) (public_name qcheck-stm.domain) (modules STM_domain) (enabled_if (>= %{ocaml_version} 5)) (libraries qcheck-core qcheck-stm.stm)) (library (name STM_thread) (public_name qcheck-stm.thread) (modules STM_thread) (libraries threads qcheck-core qcheck-stm.stm)) (library (name lin) (public_name qcheck-lin.lin) (modules lin) (libraries qcheck-core qcheck-core.runner qcheck-multicoretests-util)) (library (name lin_domain) (public_name qcheck-lin.domain) (modules lin_domain) (enabled_if (>= %{ocaml_version} 5)) (libraries qcheck-core qcheck-core.runner qcheck-multicoretests-util qcheck-lin.lin)) (library (name lin_effect) (public_name qcheck-lin.effect) (modules lin_effect) (enabled_if (>= %{ocaml_version} 5)) (libraries qcheck-core qcheck-core.runner qcheck-multicoretests-util qcheck-lin.lin)) (library (name lin_thread) (public_name qcheck-lin.thread) (modules lin_thread) (libraries threads qcheck-core qcheck-core.runner qcheck-multicoretests-util qcheck-lin.lin)) (library (name util) (public_name qcheck-multicoretests-util) (modules util) (libraries qcheck-core.runner unix)) multicoretests-0.7/lib/lin.ml000066400000000000000000000470351474367232000163510ustar00rootroot00000000000000module Internal = struct open QCheck include Util module type CmdSpec = sig type t (** The type of the system under test *) type cmd (** The type of commands *) val show_cmd : cmd -> string (** [show_cmd c] returns a string representing the command [c]. *) val gen_cmd : cmd Gen.t (** A command generator. *) val shrink_cmd : cmd Shrink.t (** A command shrinker. To a first approximation you can use [Shrink.nil]. *) type res (** The command result type *) val show_res : res -> string (** [show_res r] returns a string representing the result [r]. *) val equal_res : res -> res -> bool val init : unit -> t (** Initialize the system under test. *) val cleanup : t -> unit (** Utility function to clean up [t] after each test instance, e.g., for closing sockets, files, or resetting global parameters *) val run : cmd -> t -> res (** [run c t] should interpret the command [c] over the system under test [t] (typically side-effecting). *) end (** A functor to create test setups, for all backends (Domain, Thread and Effect). We use it below, but it can also be used independently *) module Make(Spec : CmdSpec) = struct (* plain interpreter of a cmd list *) let interp_plain sut cs = List.map (fun c -> (c, Spec.run c sut)) cs (* plain interpreter ignoring the output and allocating less *) let interp_plain_ignore sut cs = List.iter (fun c -> ignore (Spec.run c sut)) cs let rec gen_cmds fuel = Gen.(if fuel = 0 then return [] else Spec.gen_cmd >>= fun c -> gen_cmds (fuel-1) >>= fun cs -> return (c::cs)) (** A fueled command list generator. *) let gen_cmds_size size_gen = Gen.sized_size size_gen gen_cmds let shrink_triple (seq,p1,p2) = let open Iter in (* Shrinking heuristic: First reduce the cmd list sizes as much as possible, since the interleaving is most costly over long cmd lists. *) (map (fun seq' -> (seq',p1,p2)) (Shrink.list_spine seq)) <+> (match p1 with [] -> Iter.empty | c1::c1s -> Iter.return (seq@[c1],c1s,p2)) <+> (match p2 with [] -> Iter.empty | c2::c2s -> Iter.return (seq@[c2],p1,c2s)) <+> (map (fun p1' -> (seq,p1',p2)) (Shrink.list_spine p1)) <+> (map (fun p2' -> (seq,p1,p2')) (Shrink.list_spine p2)) <+> (* Secondly reduce the cmd data of individual list elements *) (map (fun seq' -> (seq',p1,p2)) (Shrink.list_elems Spec.shrink_cmd seq)) <+> (map (fun p1' -> (seq,p1',p2)) (Shrink.list_elems Spec.shrink_cmd p1)) <+> (map (fun p2' -> (seq,p1,p2')) (Shrink.list_elems Spec.shrink_cmd p2)) let arb_cmds_triple seq_len par_len = let gen_triple = Gen.(int_range 2 (2*par_len) >>= fun dbl_plen -> let seq_pref_gen = gen_cmds_size (int_bound seq_len) in let par_len1 = dbl_plen/2 in let par_gen1 = gen_cmds_size (return par_len1) in let par_gen2 = gen_cmds_size (return (dbl_plen - par_len1)) in triple seq_pref_gen par_gen1 par_gen2) in make ~print:(print_triple_vertical Spec.show_cmd) ~shrink:shrink_triple gen_triple let rec check_seq_cons pref cs1 cs2 seq_sut seq_trace = match pref with | (c,res)::pref' -> if Spec.equal_res res (Spec.run c seq_sut) then check_seq_cons pref' cs1 cs2 seq_sut (c::seq_trace) else (Spec.cleanup seq_sut; false) (* Invariant: call Spec.cleanup immediately after mismatch *) | [] -> match cs1,cs2 with | [],[] -> Spec.cleanup seq_sut; true | [],(c2,res2)::cs2' -> if Spec.equal_res res2 (Spec.run c2 seq_sut) then check_seq_cons pref cs1 cs2' seq_sut (c2::seq_trace) else (Spec.cleanup seq_sut; false) | (c1,res1)::cs1',[] -> if Spec.equal_res res1 (Spec.run c1 seq_sut) then check_seq_cons pref cs1' cs2 seq_sut (c1::seq_trace) else (Spec.cleanup seq_sut; false) | (c1,res1)::cs1',(c2,res2)::cs2' -> (if Spec.equal_res res1 (Spec.run c1 seq_sut) then check_seq_cons pref cs1' cs2 seq_sut (c1::seq_trace) else (Spec.cleanup seq_sut; false)) || (* rerun to get seq_sut to same cmd branching point *) (let seq_sut' = Spec.init () in interp_plain_ignore seq_sut' (List.rev seq_trace); if Spec.equal_res res2 (Spec.run c2 seq_sut') then check_seq_cons pref cs1 cs2' seq_sut' (c2::seq_trace) else (Spec.cleanup seq_sut'; false)) (* Linearization test *) let lin_test ~rep_count ~retries ~count ~name ~lin_prop = let arb_cmd_triple = arb_cmds_triple 20 12 in Test.make ~count ~retries ~name arb_cmd_triple (repeat rep_count lin_prop) (* Negative linearization test *) let neg_lin_test ~rep_count ~retries ~count ~name ~lin_prop = let arb_cmd_triple = arb_cmds_triple 20 12 in Test.make_neg ~count ~retries ~name arb_cmd_triple (repeat rep_count lin_prop) end end (* Type-representing values *) type constructible = | type deconstructible = | type combinable type noncombinable type (_,_,_,_) ty = | Gen : 'a QCheck.arbitrary * ('a -> string) -> ('a, constructible, 's, combinable) ty | Deconstr : ('a -> string) * ('a -> 'a -> bool) -> ('a, deconstructible, 's, combinable) ty | GenDeconstr : 'a QCheck.arbitrary * ('a -> string) * ('a -> 'a -> bool) -> ('a, 'c, 's, combinable) ty | State : ('s, constructible, 's, noncombinable) ty let gen gen print = Gen (gen,print) let deconstructible print eq = Deconstr (print,eq) let gen_deconstructible gen print eq = GenDeconstr (gen,print,eq) let qcheck_nat64_small = QCheck.(map Int64.of_int small_nat) let bytes_small_printable = QCheck.bytes_small_of QCheck.Gen.printable let unit = GenDeconstr (QCheck.unit, QCheck.Print.unit, (=)) let bool = GenDeconstr (QCheck.bool, QCheck.Print.bool, (=)) let char = GenDeconstr (QCheck.char, QCheck.Print.char, (=)) let char_printable = GenDeconstr (QCheck.printable_char, QCheck.Print.char, (=)) let nat_small = GenDeconstr (QCheck.small_nat, QCheck.Print.int, (=)) let int = GenDeconstr (QCheck.int, QCheck.Print.int, (=)) let int_small = GenDeconstr (QCheck.small_int, QCheck.Print.int, (=)) let int_pos = GenDeconstr (QCheck.pos_int, QCheck.Print.int, (=)) let int_bound b = GenDeconstr (QCheck.int_bound b, QCheck.Print.int, (=)) let int32 = GenDeconstr (QCheck.int32, Int32.to_string, Int32.equal) let int64 = GenDeconstr (QCheck.int64, Int64.to_string, Int64.equal) let nat64_small = GenDeconstr (qcheck_nat64_small, Int64.to_string, Int64.equal) let float = GenDeconstr (QCheck.float, QCheck.Print.float, Float.equal) let string = GenDeconstr (QCheck.string, QCheck.Print.string, String.equal) let string_small = GenDeconstr (QCheck.small_string, QCheck.Print.string, String.equal) let string_small_printable = GenDeconstr (QCheck.small_printable_string, QCheck.Print.string, String.equal) let bytes = GenDeconstr (QCheck.bytes, QCheck.Print.bytes, Bytes.equal) let bytes_small = GenDeconstr (QCheck.bytes_small, QCheck.Print.bytes, Bytes.equal) let bytes_small_printable = GenDeconstr (bytes_small_printable, QCheck.Print.bytes, Bytes.equal) let option : type a c s. ?ratio:float -> (a, c, s, combinable) ty -> (a option, c, s, combinable) ty = fun ?ratio ty -> match ty with | Gen (arb, print) -> Gen (QCheck.option ?ratio arb, QCheck.Print.option print) | GenDeconstr (arb, print, eq) -> GenDeconstr (QCheck.option ?ratio arb, QCheck.Print.option print, Option.equal eq) | Deconstr (print, eq) -> Deconstr (QCheck.Print.option print, Option.equal eq) let opt = option let list : type a c s. (a, c, s, combinable) ty -> (a list, c, s, combinable) ty = fun ty -> match ty with | Gen (arb, print) -> Gen (QCheck.list arb, QCheck.Print.list print) | GenDeconstr (arb, print, eq) -> GenDeconstr (QCheck.list arb, QCheck.Print.list print, List.equal eq) | Deconstr (print, eq) -> Deconstr (QCheck.Print.list print, List.equal eq) let list_small : type a c s. (a, c, s, combinable) ty -> (a list, c, s, combinable) ty = fun ty -> match ty with | Gen (arb, print) -> Gen (QCheck.small_list arb, QCheck.Print.list print) | GenDeconstr (arb, print, eq) -> GenDeconstr (QCheck.small_list arb, QCheck.Print.list print, List.equal eq) | Deconstr (print, eq) -> Deconstr (QCheck.Print.list print, List.equal eq) let array : type a c s. (a, c, s, combinable) ty -> (a array, c, s, combinable) ty = fun ty -> match ty with | Gen (arb, print) -> Gen (QCheck.array arb, QCheck.Print.array print) | GenDeconstr (arb, print, eq) -> GenDeconstr (QCheck.array arb, QCheck.Print.array print, Array.for_all2 eq) | Deconstr (print, eq) -> Deconstr (QCheck.Print.array print, Array.for_all2 eq) let array_small : type a c s. (a, c, s, combinable) ty -> (a array, c, s, combinable) ty = fun ty -> match ty with | Gen (arb, print) -> Gen (QCheck.array_of_size QCheck.Gen.small_nat arb, QCheck.Print.array print) | GenDeconstr (arb, print, eq) -> GenDeconstr (QCheck.array_of_size QCheck.Gen.small_nat arb, QCheck.Print.array print, Array.for_all2 eq) | Deconstr (print, eq) -> Deconstr (QCheck.Print.array print, Array.for_all2 eq) let seq_iteri f s = let (_:int) = Seq.fold_left (fun i x -> f i x; i + 1) 0 s in () let print_seq pp s = let b = Buffer.create 25 in Buffer.add_char b '<'; seq_iteri (fun i x -> if i > 0 then Buffer.add_string b "; "; Buffer.add_string b (pp x)) s; Buffer.add_char b '>'; Buffer.contents b let arb_seq size_gen a = let open QCheck in let print = match a.print with None -> None | Some ap -> Some (print_seq ap) in let shrink s = Iter.map List.to_seq (Shrink.list ?shrink:a.shrink (List.of_seq s)) in let gen = Gen.map List.to_seq (Gen.list_size size_gen a.gen) in QCheck.make ?print ~shrink gen let rec seq_equal eq s1 s2 = let open Seq in match s1 (), s2 () with | Nil, Nil -> true | Cons (a, an), Cons (b, bn) when eq a b -> seq_equal eq an bn | _ -> false let seq : type a c s. (a, c, s, combinable) ty -> (a Seq.t, c, s, combinable) ty = fun ty -> match ty with | Gen (arb, print) -> Gen (arb_seq QCheck.Gen.nat arb, print_seq print) | GenDeconstr (arb, print, eq) -> GenDeconstr (arb_seq QCheck.Gen.nat arb, print_seq print, seq_equal eq) | Deconstr (print, eq) -> Deconstr (print_seq print, seq_equal eq) let seq_small : type a c s. (a, c, s, combinable) ty -> (a Seq.t, c, s, combinable) ty = fun ty -> match ty with | Gen (arb, print) -> Gen (arb_seq QCheck.Gen.small_nat arb, print_seq print) | GenDeconstr (arb, print, eq) -> GenDeconstr (arb_seq QCheck.Gen.small_nat arb, print_seq print, seq_equal eq) | Deconstr (print, eq) -> Deconstr (print_seq print, seq_equal eq) let state = State let t = state let print_result print_ok print_err = function | Ok x -> Printf.sprintf "Ok (%s)" (print_ok x) | Error y -> Printf.sprintf "Error (%s)" (print_err y) let or_exn ty = match ty with | GenDeconstr (_, print, eq) -> Deconstr (print_result print Printexc.to_string, Result.equal ~ok:eq ~error:(=)) | Deconstr (print, eq) -> Deconstr (print_result print Printexc.to_string, Result.equal ~ok:eq ~error:(=)) let print : type a c s comb. (a, c, s, comb) ty -> a -> string = fun ty value -> match ty with | Gen (_,print) -> print value | Deconstr (print,_) -> print value | GenDeconstr (_,print,_) -> print value | State -> "t" let equal : type a s c. (a, deconstructible, s, c) ty -> a -> a -> bool = fun ty -> match ty with | Deconstr (_,equal) -> equal | GenDeconstr (_,_,equal) -> equal module Fun = struct (* Function type, number of arguments (unary encoding), state type *) type (_,_,_) fn = | Ret : ('a, deconstructible, 's, combinable) ty -> ('a, 'a, 's) fn | Ret_or_exc : ('a, deconstructible, 's, combinable) ty -> ('a, ('a,exn) result, 's) fn | Ret_ignore : ('a, _, 's, _) ty -> ('a, unit, 's) fn | Ret_ignore_or_exc : ('a, _, 's, _) ty -> ('a, (unit,exn) result, 's) fn | Fn : ('a, constructible, 's, _) ty * ('b, 'r, 's) fn -> ('a -> 'b, 'r, 's) fn end let returning a = Fun.Ret a let returning_or_exc a = Fun.Ret_or_exc a let returning_ a = Fun.Ret_ignore a let returning_or_exc_ a = Fun.Ret_ignore_or_exc a let (@->) a b = Fun.Fn (a,b) type _ elem = | Elem : { name : string ; fntyp : ('ftyp, 'r, 's) Fun.fn ; value : 'ftyp } -> 's elem type 's api = (int * 's elem) list let val_ name value fntyp = (1, Elem { name ; fntyp ; value }) let val_freq freq name value fntyp = (freq, Elem { name ; fntyp ; value }) module type Spec = sig type t val init : unit -> t val cleanup : t -> unit val api : (int * t elem) list end module MakeCmd (ApiSpec : Spec) : Internal.CmdSpec = struct type t = ApiSpec.t let init = ApiSpec.init let cleanup = ApiSpec.cleanup (* Typed argument list and return type descriptor *) module Args = struct type (_,_) args = | Ret : ('a, deconstructible, t, _) ty -> ('a,'a) args | Ret_or_exc : ('a, deconstructible, t, _) ty -> ('a, ('a,exn) result) args | Ret_ignore : ('a, _, t, _) ty -> ('a, unit) args | Ret_ignore_or_exc : ('a, _, t, _) ty -> ('a, (unit,exn) result) args | Fn : 'a * ('b,'r) args -> ('a -> 'b, 'r) args | FnState : ('b,'r) args -> (t -> 'b, 'r) args end (* Operation name, typed argument list, return type descriptor, printer, shrinker, function *) type cmd = Cmd : { name : string ; args : ('ftyp, 'r) Args.args ; rty : ('r, deconstructible, t, _) ty ; print : (('ftyp, 'r) Args.args -> string) ; shrink : (('ftyp, 'r) Args.args QCheck.Shrink.t) ; f : 'ftyp } -> cmd type res = Res : ('a, deconstructible, t, _) ty * 'a -> res (* Function to generate typed list of arguments from a function description. The printer can be generated independently. *) let rec gen_args_of_desc : type a r. (a, r, t) Fun.fn -> ((a, r) Args.args) QCheck.Gen.t = fun fdesc -> let open QCheck.Gen in match fdesc with | Fun.Ret ty -> return @@ Args.Ret ty | Fun.Ret_or_exc ty -> return @@ Args.Ret_or_exc ty | Fun.Ret_ignore_or_exc ty -> return @@ Args.Ret_ignore_or_exc ty | Fun.Ret_ignore ty -> return @@ Args.Ret_ignore ty | Fun.(Fn (State, fdesc_rem)) -> let* args_rem = gen_args_of_desc fdesc_rem in return @@ Args.FnState args_rem | Fun.(Fn ((Gen (arg_arb,_) | GenDeconstr (arg_arb, _, _)), fdesc_rem)) -> let* arg = arg_arb.gen in let* args_rem = gen_args_of_desc fdesc_rem in return @@ Args.Fn (arg, args_rem) let rec ret_type : type a r. (a,r,t) Fun.fn -> (r, deconstructible, t, _) ty = fun fdesc -> match fdesc with | Fun.Ret ty -> ty | Fun.Ret_or_exc ty -> or_exn ty | Fun.Ret_ignore _ -> unit | Fun.Ret_ignore_or_exc _ -> or_exn unit | Fun.Fn (_, fdesc_rem) -> ret_type fdesc_rem let rec show_args : type a r. (a,r,t) Fun.fn -> (a,r) Args.args -> string list = fun fdesc args -> match fdesc,args with | _, Args.(Ret _ | Ret_or_exc _ | Ret_ignore _ | Ret_ignore_or_exc _) -> [] | Fun.(Fn (State, fdesc_rem)), Args.(FnState args_rem) -> "t"::show_args fdesc_rem args_rem | Fun.(Fn ((GenDeconstr _ | Gen _ as ty), fdesc_rem)), Args.(Fn (value, args_rem)) -> (print ty value)::show_args fdesc_rem args_rem | Fun.(Fn (State, _)), Args.(Fn _) | Fun.(Fn ((Gen _ | GenDeconstr _), _)), Args.(FnState _) -> assert false | Fun.(Ret _ | Ret_or_exc _ | Ret_ignore _ | Ret_ignore_or_exc _), Args.(Fn _ | FnState _) -> assert false let gen_printer : type a r. string -> (a,r,t) Fun.fn -> (a,r) Args.args -> string = fun name fdesc args -> name ^ " " ^ (String.concat " " (show_args fdesc args)) (* Extracts a QCheck shrinker for argument lists *) let rec gen_shrinker_of_desc : type a r. (a, r, t) Fun.fn -> ((a, r) Args.args) QCheck.Shrink.t = fun fdesc -> let open QCheck in match fdesc with | Fun.Ret _ty -> Shrink.nil | Fun.Ret_or_exc _ty -> Shrink.nil | Fun.Ret_ignore_or_exc _ty -> Shrink.nil | Fun.Ret_ignore _ty -> Shrink.nil | Fun.(Fn (State, fdesc_rem)) -> (function (Args.FnState args) -> Iter.map (fun args -> Args.FnState args) (gen_shrinker_of_desc fdesc_rem args) | _ -> failwith "FnState: should not happen") | Fun.(Fn ((Gen (arg_arb,_) | GenDeconstr (arg_arb, _, _)), fdesc_rem)) -> (match arg_arb.shrink with | None -> (function (Args.Fn (a,args)) -> Iter.map (fun args -> Args.Fn (a,args)) (gen_shrinker_of_desc fdesc_rem args) | _ -> failwith "Fn/None: should not happen") | Some shrk -> Iter.(function (Args.Fn (a,args)) -> (map (fun a -> Args.Fn (a,args)) (shrk a)) <+> (map (fun args -> Args.Fn (a,args)) (gen_shrinker_of_desc fdesc_rem args)) | _ -> failwith "Fn/Some: should not happen")) let api = List.map (fun (wgt, Elem { name ; fntyp = fdesc ; value = f }) -> let rty = ret_type fdesc in let open QCheck.Gen in (wgt, gen_args_of_desc fdesc >>= fun args -> let print = gen_printer name fdesc in let shrink = gen_shrinker_of_desc fdesc in return (Cmd { name ; args ; rty ; print ; shrink ; f }))) ApiSpec.api let gen_cmd : cmd QCheck.Gen.t = QCheck.Gen.frequency api let show_cmd (Cmd { args ; print ; _ }) = print args let shrink_cmd (Cmd cmd) = QCheck.Iter.map (fun args -> Cmd { cmd with args }) (cmd.shrink cmd.args) (* Unsafe if called on two [res] whose internal values are of different types. *) let equal_res (Res (deconstr, v1)) (Res (_, v2)) = match deconstr with | Deconstr (_, eq) -> eq v1 (Obj.magic v2) | GenDeconstr (_, _, eq) -> eq v1 (Obj.magic v2) let show_res (Res (deconstr, value)) = match deconstr with | Deconstr (print, _) -> print value | GenDeconstr (_, print, _) -> print value let rec apply_f : type a r. a -> (a, r) Args.args -> t -> r = fun f args state -> match args with | Ret _ -> f | Ret_or_exc _ -> (* A constant value in the API cannot raise an exception *) raise (Invalid_argument "apply_f") | Ret_ignore _ -> () | Ret_ignore_or_exc _ -> (* A constant value in the API cannot raise an exception *) raise (Invalid_argument "apply_f") | FnState (Ret _) -> f state | FnState (Ret_or_exc _) -> begin try Ok (f state) with e -> Error e end | FnState (Ret_ignore _) -> ignore (f state) | FnState (Ret_ignore_or_exc _) -> begin try Ok (ignore @@ f state) with e -> Error e end | FnState (Fn _ as rem) -> apply_f (f state) rem state | FnState (FnState _ as rem) -> apply_f (f state) rem state | Fn (arg, Ret _) -> f arg | Fn (arg, Ret_or_exc _) -> begin try Ok (f arg) with e -> Error e end | Fn (arg, Ret_ignore _) -> ignore @@ f arg | Fn (arg, Ret_ignore_or_exc _) -> begin try Ok (ignore @@ f arg) with e -> Error e end | Fn (arg, (Fn _ as rem)) -> apply_f (f arg) rem state | Fn (arg, (FnState _ as rem)) -> apply_f (f arg) rem state let run cmd state = let Cmd { args ; rty ; f ; _ } = cmd in Res (rty, apply_f f args state) end multicoretests-0.7/lib/lin.mli000066400000000000000000000346571474367232000165300ustar00rootroot00000000000000(** This module allows the user to describe the type signature of a tested module interface using a DSL of type combinators. *) (** Internal module to build test representations. This module is exposed for internal uses only, its API may change at any time. *) module Internal : sig module type CmdSpec = sig type t (** The type of the system under test *) type cmd (** The type of commands *) val show_cmd : cmd -> string (** [show_cmd c] returns a string representing the command [c]. *) val gen_cmd : cmd QCheck.Gen.t (** A command generator. *) val shrink_cmd : cmd QCheck.Shrink.t (** A command shrinker. To a first approximation you can use {!QCheck.Shrink.nil}. *) type res (** The command result type *) val show_res : res -> string (** [show_res r] returns a string representing the result [r]. *) val equal_res : res -> res -> bool (** equality function over {!res} *) val init : unit -> t (** Initialize the system under test. *) val cleanup : t -> unit (** Utility function to clean up [t] after each test instance, e.g., for closing sockets, files, or resetting global parameters *) val run : cmd -> t -> res (** [run c t] should interpret the command [c] over the system under test [t] (typically side-effecting). *) end module Make(Spec : CmdSpec) : sig val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary val check_seq_cons : (Spec.cmd * Spec.res) list -> (Spec.cmd * Spec.res) list -> (Spec.cmd * Spec.res) list -> Spec.t -> Spec.cmd list -> bool val interp_plain : Spec.t -> Spec.cmd list -> (Spec.cmd * Spec.res) list val lin_test : rep_count:int -> retries:int -> count:int -> name:string -> lin_prop:(Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool) -> QCheck.Test.t val neg_lin_test : rep_count:int -> retries:int -> count:int -> name:string -> lin_prop:(Spec.cmd list * Spec.cmd list * Spec.cmd list -> bool) -> QCheck.Test.t end end [@@alert internal "This module is exposed for internal uses only, its API may change at any time"] (** {1 Type-representing values} *) type constructible = | (** Type definition to denote whether a described type can be generated *) type deconstructible = | (** Type definition to denote whether a described type can be deconstructed, i.e., tested for equality. *) type combinable (** Type definition to denote that a described type can be composed with other combinators such as {!list}. *) type noncombinable (** Type definition to denote that a described type cannot be composed with other combinators such as {!list}. *) type (_, _, _, _) ty (** Type definition for type-describing combinators. [(typ,con,styp,comb) ty] represents a type [typ] and with an underlying state of type [styp]. The [con] type parameter indicates whether the combinator type is {!constructible} or {!type-deconstructible}. The [comb] type parameter indicates whether the combinator type is {!combinable} or {!noncombinable}. *) val gen : 'a QCheck.arbitrary -> ('a -> string) -> ('a, constructible, 's, combinable) ty (** [gen arb to_str] builds a {!constructible} and {!combinable} type combinator from a QCheck generator [arb] and a to-string function [to_str]. *) val deconstructible : ('a -> string) -> ('a -> 'a -> bool) -> ('a, deconstructible, 's, combinable) ty (** [deconstructible to_str eq] builds a {!type-deconstructible} and {!combinable} type combinator from a to-string function [to_str] and an equality predicate [eq]. *) val gen_deconstructible : 'a QCheck.arbitrary -> ('a -> string) -> ('a -> 'a -> bool) -> ('a, 'c, 's, combinable) ty (** [gen_deconstructible arb to_str eq] builds a {!combinable} type combinator from a QCheck generator [arb], a to-string function [to_str] and an equality predicate [eq]. *) (** {2 Type combinators} *) val unit : (unit, 'a, 'b, combinable) ty (** The [unit] combinator represents the {{!Stdlib.Unit.t}[unit]} type *) val bool : (bool, 'a, 'b, combinable) ty (** The [bool] combinator represents the {{!Stdlib.Bool.t}[bool]} type *) val char : (char, 'a, 'b, combinable) ty (** The [char] combinator represents the {{!Stdlib.Char.t}[char]} type. It uses a uniform generator based on {!QCheck.char}. *) val char_printable : (char, 'a, 'b, combinable) ty (** The [char_printable] combinator represents the {{!Stdlib.Char.t}[char]} type. The generated characters have character codes 32-126 or 10 (newline) and are based on {!QCheck.printable_char}. *) val nat_small : (int, 'a, 'b, combinable) ty (** The [nat_small] combinator represents the {{!Stdlib.Int.t}[int]} type. The generated integers are non-negative, less than 100, and are based on {!QCheck.small_nat}. *) val int : (int, 'a, 'b, combinable) ty (** The [int] combinator represents the {{!Stdlib.Int.t}[int]} type. It uses a uniform generator based on {!QCheck.int}. *) val int_small : (int, 'a, 'b, combinable) ty (** The [int_small] combinator represents the {{!Stdlib.Int.t}[int]} type. The generated integers are non-negative and are based on {!QCheck.small_int}. *) val int_pos : (int, 'a, 'b, combinable) ty (** The [int_pos] combinator represents the {{!Stdlib.Int.t}[int]} type. The generated integers are non-negative and uniformly distributed. It is based on {!QCheck.pos_int}. *) val int_bound : int -> (int, 'a, 'b, combinable) ty (** The [int_bound b] combinator represents the {{!Stdlib.Int.t}[int]} type. The generated integers range from [0] to [b], inclusive. It uses a uniform generator based on {!QCheck.int_bound}. Note: the result of [int_bound my_bound] cannot be used both as an argument type and as a result type in type signature descriptions. *) val int32 : (Int32.t, 'a, 'b, combinable) ty (** The [int32] combinator represents the {{!Stdlib.Int32.t}[int32]} type. It uses a uniform generator based on {!QCheck.int32}. *) val int64 : (Int64.t, 'a, 'b, combinable) ty (** The [int64] combinator represents the {{!Stdlib.Int64.t}[int64]} type. It uses a uniform generator based on {!QCheck.int64}. *) val nat64_small : (Int64.t, 'a, 'b, combinable) ty (** The [nat64_small] combinator represents the {{!Stdlib.Int64.t}[int64]} type. The generated integers are non-negative and are based on {!QCheck.small_nat}. *) val float : (float, 'a, 'b, combinable) ty (** The [float] combinator represents the {{!Stdlib.Float.t}[float]} type. The generated floating point numbers do not include nan and infinities. It is based on {!QCheck.float}. *) val string : (String.t, 'a, 'b, combinable) ty (** The [string] combinator represents the {{!Stdlib.String.t}[string]} type. The generated strings have a size generated from {!QCheck.Gen.nat} and characters resulting from {!QCheck.Gen.char}. It is based on {!QCheck.string}. *) val string_small : (String.t, 'a, 'b, combinable) ty (** The [string_small] combinator represents the {{!Stdlib.String.t}[string]} type. The generated strings have a size generated from {!QCheck.Gen.small_nat} and characters resulting from {!QCheck.Gen.char}. It is based on {!QCheck.small_string}. *) val string_small_printable : (String.t, 'a, 'b, combinable) ty (** The [string_small_printable] combinator represents the {{!Stdlib.String.t}[string]} type. The generated strings have a size generated from {!QCheck.Gen.small_nat} and characters resulting from {!QCheck.Gen.printable}. It is based on {!QCheck.small_printable_string}. *) val bytes : (Bytes.t, 'a, 'b, combinable) ty (** The [bytes] combinator represents the {{!Stdlib.Bytes.t}[bytes]} type. The generated byte strings have a size generated from {!QCheck.Gen.nat} and characters resulting from {!QCheck.Gen.char}. It is based on {!QCheck.bytes}. *) val bytes_small : (Bytes.t, 'a, 'b, combinable) ty (** The [bytes_small] combinator represents the {{!Stdlib.Bytes.t}[bytes]} type. The generated byte strings have a size generated from {!QCheck.Gen.small_nat} and characters resulting from {!QCheck.Gen.char}. It is based on {!QCheck.bytes_small}. *) val bytes_small_printable : (Bytes.t, 'a, 'b, combinable) ty (** The [bytes_small_printable] combinator represents the {{!Stdlib.Bytes.t}[string]} type. The generated byte strings have a size generated from {!QCheck.Gen.small_nat} and characters resulting from {!QCheck.Gen.printable}. It is based on {!QCheck.bytes_small_of}. *) val option : ?ratio:float -> ('a, 'c, 's, combinable) ty -> ('a option, 'c, 's, combinable) ty (** The [option] combinator represents the {{!Stdlib.Option.t}[option]} type. The generated values from [option t] are either [Some v] or [None] with [v] being generated by the [t] combinator. An optional [ratio] allows to change the default [0.85] [Some]s. It is based on {!QCheck.option}. *) val opt : ?ratio:float -> ('a, 'b, 'c, combinable) ty -> ('a option, 'b, 'c, combinable) ty (** The [opt] combinator is an alias for {!option}. *) val list : ('a, 'c, 's, combinable) ty -> ('a list, 'c, 's, combinable) ty (** The [list] combinator represents the {{!Stdlib.List.t}[list]} type. The generated lists from [list t] have a length resulting from {!QCheck.Gen.nat} and have their elements generated by the [t] combinator. It is based on {!QCheck.list}. *) val list_small : ('a, 'c, 's, combinable) ty -> ('a list, 'c, 's, combinable) ty (** The [list_small] combinator represents the {{!Stdlib.List.t}[list]} type. The generated lists from [list_small t] have a length resulting from {!QCheck.Gen.small_nat} and have their elements generated by the [t] combinator. It is based on {!QCheck.small_list}. *) val array : ('a, 'c, 's, combinable) ty -> ('a array, 'c, 's, combinable) ty (** The [array] combinator represents the {{!Stdlib.Array.t}[array]} type. The generated arrays from [array t] have a length resulting from {!QCheck.Gen.nat} and have their elements generated by the [t] combinator. It is based on {!QCheck.array}. *) val array_small : ('a, 'c, 's, combinable) ty -> ('a array, 'c, 's, combinable) ty (** The [array_small] combinator represents the {{!Stdlib.Array.t}[array]} type. The generated arrays from [array_small t] have a length resulting from {!QCheck.Gen.small_nat} and have their elements generated by the [t] combinator. It is based on {!QCheck.array_of_size}. *) val seq : ('a, 'c, 's, combinable) ty -> ('a Seq.t, 'c, 's, combinable) ty (** The [seq] combinator represents the {!Stdlib.Seq.t} type. The generated sequences from [seq t] have a length resulting from {!QCheck.Gen.nat} and have their elements generated by the [t] combinator. *) val seq_small : ('a, 'c, 's, combinable) ty -> ('a Seq.t, 'c, 's, combinable) ty (** The [seq_small] combinator represents the {!Stdlib.Seq.t} type. The generated sequences from [seq_small t] have a length resulting from {!QCheck.Gen.small_nat} and have their elements generated by the [t] combinator. *) val t : ('a, constructible, 'a, noncombinable) ty (** The [t] combinator represents the type {!Spec.t} of the system under test. *) val state : ('a, constructible, 'a, noncombinable) ty (** The [state] combinator represents the type {!Spec.t} of the system under test. It is an alias for the [t] combinator. *) val or_exn : ('a, deconstructible, 'b, combinable) ty -> (('a, exn) result, deconstructible, 'c, combinable) ty (** The [or_exn] combinator transforms a result type representing [t] into a [(t, exn)] {{!Stdlib.Result.t}[result]} type. *) val print_result : ('a -> string) -> ('b -> string) -> ('a, 'b) result -> string (** [print_result pa pb] creates a to-string function for a [(a,b)] {{!Stdlib.Result.t}[result]} type given two to-string functions for [a]s and [b]s, respectively. *) val print : ('a, 'c, 's, 'comb) ty -> 'a -> string (** Given a description of type ['a], print a value of type ['a]. *) val equal : ('a, deconstructible, 's, 'comb) ty -> 'a -> 'a -> bool (** Given a description of type ['a], compare two values of type ['a]. *) (** {1 Values representing API functions} *) module Fun : sig (** [(ftyp,rtyp,styp) Fun.fn] represents a function type of type [ftyp], with return type [rtyp], and with the underlying state type [styp]. *) type (_, _, _) fn end val returning : ('a, deconstructible, 'b, combinable) ty -> ('a, 'a, 'b) Fun.fn (** [returning t] represents a pure return type. *) val returning_or_exc : ('a, deconstructible, 'b, combinable) ty -> ('a, ('a, exn) result, 'b) Fun.fn (** [returning_or_exc t] represents a return type of a function that may raise an exception. *) val returning_ : ('a, 'b, 'c, 'd) ty -> ('a, unit, 'c) Fun.fn (** [returning_ t] represents a return type that should be ignored. *) val returning_or_exc_ : ('a, 'b, 'c, 'd) ty -> ('a, (unit, exn) result, 'c) Fun.fn (** [returning_or_exc_ t] represents a return type that should be ignored of a function that may raise an exception. *) val ( @-> ) : ('a, constructible, 'b, 'c) ty -> ('d, 'e, 'b) Fun.fn -> ('a -> 'd, 'e, 'b) Fun.fn (** [at @-> rt] represents a function type expecting an argument [at] and returning [rt]. *) (** {1 API description} *) (** Type and constructor to capture a single function signature *) type !_ elem type 's api = (int * 's elem) list (** The type of module signatures *) val val_ : string -> 'f -> ('f, 'r, 's) Fun.fn -> int * 's elem (** [val_ str f sig] describes a function signature from a string [str], a function value [f], and a signature description [sig]. *) val val_freq : int -> string -> 'f -> ('f, 'r, 's) Fun.fn -> int * 's elem (** [val_freq w str f sig] describes a function signature like {!val_} [str f sig] but with relative weight [w] rather than 1. A function of weight 2 will have twice the probability of being invoked compared to a function of weight 1. *) (** The required description of a module signature *) module type Spec = sig type t (** The type of the system under test *) val init : unit -> t (** The function to initialize the system under test *) val cleanup : t -> unit (** The function to cleanup the system under test *) val api : (int * t elem) list (** A description of the function signatures *) end (** {1 Generating a linearization testing module from an API} *) module MakeCmd (Spec : Spec) : Internal.CmdSpec [@alert "-internal"] (** Functor to map a combinator-based module signature description into a raw {!Lin} description. This functor is exposed for internal uses only, its API may change at any time. *) multicoretests-0.7/lib/lin_domain.ml000066400000000000000000000041601474367232000176700ustar00rootroot00000000000000open Lin module Make_internal (Spec : Internal.CmdSpec [@alert "-internal"]) = struct module M = Internal.Make(Spec) [@alert "-internal"] include M (* operate over arrays to avoid needless allocation underway *) let interp sut cs = let cs_arr = Array.of_list cs in let res_arr = Array.map (fun c -> Domain.cpu_relax(); Spec.run c sut) cs_arr in List.combine cs (Array.to_list res_arr) let run_parallel (seq_pref,cmds1,cmds2) = let sut = Spec.init () in let pref_obs = interp sut seq_pref in let barrier = Atomic.make 2 in let main cmds () = Atomic.decr barrier; while Atomic.get barrier <> 0 do Domain.cpu_relax () done; try Ok (interp sut cmds) with exn -> Error exn in let dom1 = Domain.spawn (main cmds1) in let dom2 = Domain.spawn (main cmds2) in let obs1 = Domain.join dom1 in let obs2 = Domain.join dom2 in Spec.cleanup sut ; let obs1 = match obs1 with Ok v -> v | Error exn -> raise exn in let obs2 = match obs2 with Ok v -> v | Error exn -> raise exn in (pref_obs,obs1,obs2) (* Linearization property based on [Domain] and an Atomic flag *) let lin_prop (seq_pref,cmds1,cmds2) = let pref_obs,obs1,obs2 = run_parallel (seq_pref,cmds1,cmds2) in let seq_sut = Spec.init () in check_seq_cons pref_obs obs1 obs2 seq_sut [] || QCheck.Test.fail_reportf " Results incompatible with sequential execution\n\n%s" @@ Util.print_triple_vertical ~fig_indent:5 ~res_width:35 (fun (c,r) -> Printf.sprintf "%s : %s" (Spec.show_cmd c) (Spec.show_res r)) (pref_obs,obs1,obs2) (* "Don't crash under parallel usage" property *) let stress_prop (seq_pref,cmds1,cmds2) = let _ = run_parallel (seq_pref,cmds1,cmds2) in true let lin_test ~count ~name = M.lin_test ~rep_count:50 ~count ~retries:3 ~name ~lin_prop:lin_prop let neg_lin_test ~count ~name = neg_lin_test ~rep_count:50 ~count ~retries:3 ~name ~lin_prop:lin_prop let stress_test ~count ~name = M.lin_test ~rep_count:25 ~count ~retries:5 ~name ~lin_prop:stress_prop end module Make (Spec : Spec) = Make_internal(MakeCmd(Spec)) multicoretests-0.7/lib/lin_domain.mli000066400000000000000000000035351474367232000200460ustar00rootroot00000000000000open Lin (** functor to build an internal module representing parallel tests *) module Make_internal (Spec : Internal.CmdSpec [@alert "-internal"]) : sig val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary val lin_prop : (Spec.cmd list * Spec.cmd list * Spec.cmd list) -> bool val stress_prop : (Spec.cmd list * Spec.cmd list * Spec.cmd list) -> bool val lin_test : count:int -> name:string -> QCheck.Test.t val neg_lin_test : count:int -> name:string -> QCheck.Test.t val stress_test : count:int -> name:string -> QCheck.Test.t end [@@alert internal "This module is exposed for internal uses only, its API may change at any time"] (** functor to build a module for parallel testing *) module Make (Spec : Spec) : sig val lin_test : count:int -> name:string -> QCheck.Test.t (** [lin_test ~count:c ~name:n] builds a parallel test with the name [n] that iterates [c] times. The test fails if one of the generated programs is not sequentially consistent. In that case it fails, and prints a reduced counter example. *) val neg_lin_test : count:int -> name:string -> QCheck.Test.t (** [neg_lin_test ~count:c ~name:n] builds a negative parallel test with the name [n] that iterates [c] times. The test fails if no counter example is found, and succeeds if a counter example is indeed found, and prints it afterwards. *) val stress_test : count:int -> name:string -> QCheck.Test.t (** [stress_test ~count:c ~name:n] builds a parallel test with the name [n] that iterates [c] times. The test fails if an unexpected exception is raised underway. It is intended as a stress test to run operations at a high frequency and detect unexpected exceptions or crashes. It does not perform an interleaving search like {!lin_test} and {!neg_lin_test}. *) end multicoretests-0.7/lib/lin_effect.ml000066400000000000000000000104051474367232000176540ustar00rootroot00000000000000open Lin (** Definitions for Effect interpretation *) (* Scheduler adapted from https://kcsrk.info/slides/retro_effects_simcorp.pdf *) open Effect open Effect.Deep type _ t += Fork : (unit -> unit) -> unit t | Yield : unit t let enqueue k q = Queue.push k q let dequeue q = if Queue.is_empty q then () (*Finished*) else continue (Queue.pop q) () let start_sched main = (* scheduler's queue of continuations *) let q = Queue.create () in let rec spawn = fun (type res) (f : unit -> res) -> match_with f () { retc = (fun _v -> dequeue q); (* value case *) exnc = (fun e -> (Stdlib.print_string (Printexc.to_string e); raise e)); effc = (fun (type a) (e : a t) -> match e with | Yield -> Some (fun (k : (a, _) continuation) -> enqueue k q; dequeue q) | Fork f -> Some (fun (k : (a, _) continuation) -> enqueue k q; spawn f) | _ -> None ) } in spawn main (* short hands *) let fork f = perform (Fork f) let yield () = perform Yield module Make_internal (Spec : Internal.CmdSpec [@alert "-internal"]) = struct (** A refined [CmdSpec] specification with generator-controlled [Yield] effects *) module EffSpec = struct open QCheck type t = Spec.t let init = Spec.init let cleanup = Spec.cleanup type cmd = SchedYield | UserCmd of Spec.cmd let show_cmd c = match c with | SchedYield -> "" | UserCmd c -> Spec.show_cmd c let gen_cmd = (Gen.frequency [(3,Gen.return SchedYield); (5,Gen.map (fun c -> UserCmd c) Spec.gen_cmd)]) let shrink_cmd c = match c with | SchedYield -> Iter.empty | UserCmd c -> Iter.map (fun c' -> UserCmd c') (Spec.shrink_cmd c) type res = SchedYieldRes | UserRes of Spec.res let show_res r = match r with | SchedYieldRes -> "" | UserRes r -> Spec.show_res r let equal_res r r' = match r,r' with | SchedYieldRes, SchedYieldRes -> true | UserRes r, UserRes r' -> Spec.equal_res r r' | _, _ -> false let run c sut = match c with | SchedYield -> (yield (); SchedYieldRes) | UserCmd uc -> let res = Spec.run uc sut in UserRes res end module EffTest = Internal.Make(EffSpec) [@alert "-internal"] let arb_cmds_triple = EffTest.arb_cmds_triple let filter_res rs = List.filter (fun (c,_) -> c <> EffSpec.SchedYield) rs let rec interp sut cs = match cs with | [] -> [] | c::cs -> let res = EffSpec.run c sut in (c,res)::interp sut cs (* Concurrent agreement property based on effect-handler scheduler *) let lin_prop (seq_pref,cmds1,cmds2) = let sut = Spec.init () in (* exclude [Yield]s from sequential prefix *) let pref_obs = EffTest.interp_plain sut (List.filter (fun c -> c <> EffSpec.SchedYield) seq_pref) in let obs1,obs2 = ref (Ok []), ref (Ok []) in let main () = fork (fun () -> let tmp1 = try Ok (interp sut cmds1) with exn -> Error exn in obs1 := tmp1); fork (fun () -> let tmp2 = try Ok (interp sut cmds2) with exn -> Error exn in obs2 := tmp2); in let () = start_sched main in let () = Spec.cleanup sut in let obs1 = match !obs1 with Ok v -> ref v | Error exn -> raise exn in let obs2 = match !obs2 with Ok v -> ref v | Error exn -> raise exn in let seq_sut = Spec.init () in (* exclude [Yield]s from sequential executions when searching for an interleaving *) EffTest.check_seq_cons (filter_res pref_obs) (filter_res !obs1) (filter_res !obs2) seq_sut [] || QCheck.Test.fail_reportf " Results incompatible with linearized model\n\n%s" @@ Util.print_triple_vertical ~fig_indent:5 ~res_width:35 (fun (c,r) -> Printf.sprintf "%s : %s" (EffSpec.show_cmd c) (EffSpec.show_res r)) (pref_obs,!obs1,!obs2) let lin_test ~count ~name = let arb_cmd_triple = EffTest.arb_cmds_triple 20 12 in let rep_count = 1 in QCheck.Test.make ~count ~retries:10 ~name arb_cmd_triple (Util.repeat rep_count lin_prop) let neg_lin_test ~count ~name = let arb_cmd_triple = EffTest.arb_cmds_triple 20 12 in let rep_count = 1 in QCheck.Test.make_neg ~count ~retries:10 ~name arb_cmd_triple (Util.repeat rep_count lin_prop) end module Make (Spec : Spec) = Make_internal(MakeCmd(Spec)) multicoretests-0.7/lib/lin_effect.mli000066400000000000000000000034171474367232000200320ustar00rootroot00000000000000open Lin (** functor to build an internal module representing {!Stdlib.Effect}-based tests *) module Make_internal (Spec : Internal.CmdSpec [@alert "-internal"]) : sig module EffSpec : sig type cmd end val arb_cmds_triple : int -> int -> (EffSpec.cmd list * EffSpec.cmd list * EffSpec.cmd list) QCheck.arbitrary val lin_prop : (EffSpec.cmd list * EffSpec.cmd list * EffSpec.cmd list) -> bool val lin_test : count:int -> name:string -> QCheck.Test.t val neg_lin_test : count:int -> name:string -> QCheck.Test.t end [@@alert internal "This module is exposed for internal uses only, its API may change at any time"] val fork : (unit -> unit) -> unit (** Helper function to fork a process in the underlying {!Stdlib.Effect}-based scheduler *) val yield : unit -> unit (** Helper function to yield control in the underlying {!Stdlib.Effect}-based scheduler *) (** functor to build a module for [Effect]-based testing *) module Make (Spec : Spec) : sig val lin_test : count:int -> name:string -> QCheck.Test.t (** [lin_test ~count:c ~name:n] builds an {!Stdlib.Effect}-based test with the name [n] that iterates [c] times. The test fails if one of the generated programs is not sequentially consistent. In that case it fails, and prints a reduced counter example. *) val neg_lin_test : count:int -> name:string -> QCheck.Test.t (** [neg_lin_test ~count:c ~name:n] builds a negative {!Stdlib.Effect}-based test with the name [n] that iterates [c] times. The test fails if no counter example is found, and succeeds if a counter example is indeed found, and prints it afterwards. *) end [@@alert experimental "This module is experimental: The interface is not considered stable, and it may fail to trigger concurrency issues that are present."] multicoretests-0.7/lib/lin_thread.ml000066400000000000000000000037371474367232000177010ustar00rootroot00000000000000open Lin module Make_internal (Spec : Internal.CmdSpec [@alert "-internal"]) = struct module M = Internal.Make(Spec) [@alert "-internal"] include M (* Note: On purpose we use - a non-tail-recursive function and - an (explicit) allocation in the loop body since both trigger statistically significant more thread issues/interleaving *) let rec interp_thread sut cs = match cs with | [] -> [] | c::cs -> Thread.yield (); let res = Spec.run c sut in (c,res)::interp_thread sut cs let arb_cmds_triple = arb_cmds_triple (* Linearization property based on [Thread] *) let lin_prop (seq_pref, cmds1, cmds2) = let sut = Spec.init () in let obs1, obs2 = ref (Ok []), ref (Ok []) in let pref_obs = interp_plain sut seq_pref in let wait = ref true in let th1 = Thread.create (fun () -> while !wait do Thread.yield () done; obs1 := try Ok (interp_thread sut cmds1) with exn -> Error exn) () in let th2 = Thread.create (fun () -> wait := false; obs2 := try Ok (interp_thread sut cmds2) with exn -> Error exn) () in Thread.join th1; Thread.join th2; Spec.cleanup sut; let obs1 = match !obs1 with Ok v -> ref v | Error exn -> raise exn in let obs2 = match !obs2 with Ok v -> ref v | Error exn -> raise exn in let seq_sut = Spec.init () in (* we reuse [check_seq_cons] to linearize and interpret sequentially *) check_seq_cons pref_obs !obs1 !obs2 seq_sut [] || QCheck.Test.fail_reportf " Results incompatible with sequential execution\n\n%s" @@ Util.print_triple_vertical ~fig_indent:5 ~res_width:35 (fun (c,r) -> Printf.sprintf "%s : %s" (Spec.show_cmd c) (Spec.show_res r)) (pref_obs,!obs1,!obs2) let lin_test ~count ~name = lin_test ~rep_count:100 ~count ~retries:5 ~name ~lin_prop:lin_prop let neg_lin_test ~count ~name = neg_lin_test ~rep_count:100 ~count ~retries:5 ~name ~lin_prop:lin_prop end module Make (Spec : Spec) = Make_internal(MakeCmd(Spec)) multicoretests-0.7/lib/lin_thread.mli000066400000000000000000000026121474367232000200410ustar00rootroot00000000000000open Lin (** functor to build an internal module representing concurrent tests *) module Make_internal (Spec : Internal.CmdSpec [@alert "-internal"]) : sig val arb_cmds_triple : int -> int -> (Spec.cmd list * Spec.cmd list * Spec.cmd list) QCheck.arbitrary val lin_prop : (Spec.cmd list * Spec.cmd list * Spec.cmd list) -> bool val lin_test : count:int -> name:string -> QCheck.Test.t val neg_lin_test : count:int -> name:string -> QCheck.Test.t end [@@alert internal "This module is exposed for internal uses only, its API may change at any time"] (** functor to build a module for concurrent testing *) module Make (Spec : Spec) : sig val lin_test : count:int -> name:string -> QCheck.Test.t (** [lin_test ~count:c ~name:n] builds a concurrent test with the name [n] that iterates [c] times. The test fails if one of the generated programs is not sequentially consistent. In that case it fails, and prints a reduced counter example. *) val neg_lin_test : count:int -> name:string -> QCheck.Test.t (** [neg_lin_test ~count:c ~name:n] builds a negative concurrent test with the name [n] that iterates [c] times. The test fails if no counter example is found, and succeeds if a counter example is indeed found, and prints it afterwards. *) end [@@alert experimental "This module is experimental: It may fail to trigger concurrency issues that are present."] multicoretests-0.7/lib/util.ml000066400000000000000000000257031474367232000165420ustar00rootroot00000000000000let rec repeat n prop = fun input -> if n<0 then failwith "repeat: negative repetition count"; if n=0 then true else prop input && repeat (n-1) prop input exception Timeout let prop_timeout sec p x = Sys.(signal sigalrm (Signal_handle (fun _ -> raise Timeout))) |> ignore; ignore (Unix.alarm sec); let res = p x in ignore (Unix.alarm 0); (*cancel alarm*) res let fork_prop_with_timeout sec p x = let a = Unix.fork () in match a with | 0 -> let _ = Unix.alarm sec in if p x then (ignore (Unix.alarm 0); exit 0) (*cancel alarm*) else (ignore (Unix.alarm 0); exit 2) (*cancel alarm*) | _ -> let _childid, retcode = Unix.wait () in (match retcode with | WEXITED code -> (0=code) | WSIGNALED s when s = Sys.sigalrm -> raise Timeout | WSIGNALED _ | WSTOPPED _ -> false) let print_vertical ?(fig_indent=3) show cmds = let cmds = List.map show cmds in let buf = Buffer.create 64 in let indent () = Printf.bprintf buf "%s" (String.make fig_indent ' ') in let print_seq_col c = Printf.bprintf buf "%s\n" c in let () = List.iter (fun c -> indent (); print_seq_col c) cmds in Buffer.contents buf let print_triple_vertical ?(fig_indent=10) ?(res_width=20) ?(center_prefix=true) show (seq,cmds1,cmds2) = let seq,cmds1,cmds2 = List.(map show seq, map show cmds1, map show cmds2) in let max_width ss = List.fold_left max 0 (List.map String.length ss) in let width = List.fold_left max 0 [max_width seq; max_width cmds1; max_width cmds2] in let res_width = max width res_width in let cmd_indent = String.make ((width-1)/2) ' ' in let seq_indent = String.make ((res_width + 3)/2) ' ' in let bar_cmd = Printf.sprintf "%-*s" res_width (cmd_indent ^ "|") in let center c = let clen = String.length c in if clen > width (* it's a '|'-string *) then c else Printf.sprintf "%s%s" (String.make ((width - clen)/2) ' ') c in let buf = Buffer.create 64 in let indent () = Printf.bprintf buf "%s" (String.make fig_indent ' ') in let print_seq_col c = Printf.bprintf buf "%s%-*s\n" seq_indent res_width c in let print_par_col c1 c2 = Printf.bprintf buf "%-*s %-*s\n" res_width c1 res_width c2 in let print_hoz_line () = Printf.bprintf buf "%-*s\n" res_width (cmd_indent ^ "." ^ (String.make (res_width + 1) '-') ^ ".") in let rec print_par_cols cs cs' = match cs,cs' with | [], [] -> () | c::cs,[] -> indent (); print_par_col (center c) ""; print_par_cols cs [] | [], c::cs -> indent (); print_par_col "" (center c); print_par_cols [] cs | l::ls,r::rs -> indent (); print_par_col (center l) (center r); print_par_cols ls rs in (* actual printing *) if center_prefix then List.iter (fun c -> indent (); print_seq_col (center c)) ([bar_cmd] @ seq @ [bar_cmd]) else List.iter (fun c -> indent (); print_par_col (center c) "") (bar_cmd::seq@[bar_cmd]); indent (); print_hoz_line (); print_par_cols (bar_cmd::cmds1) (bar_cmd::cmds2); Buffer.contents buf let protect (f : 'a -> 'b) (a : 'a) : ('b, exn) result = try Result.Ok (f a) with e -> Result.Error e module Pp = struct open Format type 'a t = bool -> Format.formatter -> 'a -> unit type pp_thunk = Format.formatter -> unit let truncate_message = "... (truncated)" let truncate_length = let truncate_env = "MCTUTILS_TRUNCATE" in let ( let* ) = Option.bind in let* l = Sys.getenv_opt truncate_env in let* l = int_of_string_opt l in (* it does not make sense to truncate at less than the length of [truncate_message] *) if l > 0 then Some (max l (String.length truncate_message - 1)) else None let to_show f x = match truncate_length with | None -> let buf = Buffer.create 512 in let fmt = formatter_of_buffer buf in pp_set_margin fmt max_int; fprintf fmt "@[%a@]@?" (f false) x; let s = Buffer.contents buf in Buffer.reset buf; s | Some trlen -> (* if we overflow, we'll have the [truncate_message] at the end of the buffer, filling it until [trlen + 1]: we'll use the fact that the buffer contains more than [trlen] to indicate that it has already overflown *) let buf = Buffer.create (trlen + 1) in let msglen = String.length truncate_message in let out str ofs len = let blen = Buffer.length buf in (* if we didn't overflow yet... *) if blen <= trlen then if blen + len > trlen then ( let fits = trlen - blen - msglen + 1 in if fits > 0 then Buffer.add_substring buf str ofs fits else Buffer.truncate buf (trlen + 1 - msglen); Buffer.add_string buf truncate_message) else Buffer.add_substring buf str ofs len in let ppf = make_formatter out ignore in pp_set_margin ppf max_int; fprintf ppf "@[%a@]@?" (f false) x; let s = Buffer.contents buf in Buffer.reset buf; s let of_show f par fmt x = fprintf fmt (if par then "@[(%s)@]" else "@[%s@]") (f x) let cst0 name fmt = pp_print_string fmt name let cst1 (pp : 'a t) name par fmt x = let o, c = if par then ("(", ")") else ("", "") in fprintf fmt "%s@[<2>%s@ %a@]%s" o name (pp true) x c let cst2 (pp1 : 'a t) (pp2 : 'b t) name par fmt x y = let o, c = if par then ("(", ")") else ("", "") in fprintf fmt "%s@[<2>%s (@,%a,@ %a)@]%s" o name (pp1 false) x (pp2 false) y c let cst3 (pp1 : 'a t) (pp2 : 'b t) (pp3 : 'c t) name par fmt x y z = let o, c = if par then ("(", ")") else ("", "") in fprintf fmt "%s@[<2>%s (@,%a,@ %a,@ %a)@]%s" o name (pp1 false) x (pp2 false) y (pp3 false) z c let pp_exn = of_show Printexc.to_string let pp_unit _ fmt () = pp_print_string fmt "()" let pp_bool _ fmt b = fprintf fmt "%B" b let pp_int par fmt i = fprintf fmt (if par && i < 0 then "(%d)" else "%d") i let pp_int32 par fmt i = fprintf fmt (if par && i < 0l then "(%ldl)" else "%ldl") i let pp_int64 par fmt i = fprintf fmt (if par && i < 0L then "(%LdL)" else "%LdL") i let pp_float par fmt f = fprintf fmt (if par && f < 0.0 then "(%F)" else "%F") f let pp_char _ fmt c = fprintf fmt "%C" c let pp_string _ fmt s = fprintf fmt "%S" s let pp_bytes _ fmt s = fprintf fmt "%S" (Bytes.to_string s) let pp_option (pp_s : 'a t) par fmt o = match o with | None -> cst0 "None" fmt | Some s -> cst1 pp_s "Some" par fmt s let pp_result (pp_o : 'o t) (pp_e : 'e t) par fmt r = let open Result in match r with | Ok o -> cst1 pp_o "Ok" par fmt o | Error e -> cst1 pp_e "Error" par fmt e type pp_tuple_item = pp_thunk let pp_tuple_item pp x fmt = pp false fmt x let pp_tuple _ fmt items = fprintf fmt "(@["; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") (fun fmt ppf -> ppf fmt) fmt items; fprintf fmt "@])" let pp_tuple2 pp1 pp2 p fmt (x1, x2) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2 ] let pp_tuple3 pp1 pp2 pp3 p fmt (x1, x2, x3) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3 ] let pp_tuple4 pp1 pp2 pp3 pp4 p fmt (x1, x2, x3, x4) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; ] let pp_tuple5 pp1 pp2 pp3 pp4 pp5 p fmt (x1, x2, x3, x4, x5) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; pp_tuple_item pp5 x5; ] let pp_tuple6 pp1 pp2 pp3 pp4 pp5 pp6 p fmt (x1, x2, x3, x4, x5, x6) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; pp_tuple_item pp5 x5; pp_tuple_item pp6 x6; ] let pp_tuple7 pp1 pp2 pp3 pp4 pp5 pp6 pp7 p fmt (x1, x2, x3, x4, x5, x6, x7) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; pp_tuple_item pp5 x5; pp_tuple_item pp6 x6; pp_tuple_item pp7 x7; ] let pp_tuple8 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 p fmt (x1, x2, x3, x4, x5, x6, x7, x8) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; pp_tuple_item pp5 x5; pp_tuple_item pp6 x6; pp_tuple_item pp7 x7; pp_tuple_item pp8 x8; ] let pp_tuple9 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 p fmt (x1, x2, x3, x4, x5, x6, x7, x8, x9) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; pp_tuple_item pp5 x5; pp_tuple_item pp6 x6; pp_tuple_item pp7 x7; pp_tuple_item pp8 x8; pp_tuple_item pp9 x9; ] let pp_tuple10 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 pp10 p fmt (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) = pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3; pp_tuple_item pp4 x4; pp_tuple_item pp5 x5; pp_tuple_item pp6 x6; pp_tuple_item pp7 x7; pp_tuple_item pp8 x8; pp_tuple_item pp9 x9; pp_tuple_item pp10 x10; ] let pp_pair = pp_tuple2 let pp_list (pp_e : 'a t) _ fmt l = fprintf fmt "@[<2>["; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (pp_e false) fmt l; fprintf fmt "@,]@]" let pp_seq (pp_e : 'a t) _ fmt s = fprintf fmt "@[<2><"; pp_print_seq ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (pp_e false) fmt s; fprintf fmt "@,>@]" let pp_array (pp_e : 'a t) _ fmt a = fprintf fmt "@[<2>[|"; pp_print_seq ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (pp_e false) fmt (Array.to_seq a); fprintf fmt "@,|]@]" type pp_field = pp_thunk let pp_field name (pp_c : 'a t) c fmt = fprintf fmt "@[%s =@ %a@]" name (pp_c false) c let pp_record _ fmt fields = fprintf fmt "@[<2>{ "; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") (fun fmt ppf -> ppf fmt) fmt fields; fprintf fmt "@ }@]" let pp_fun_ par fmt f = fprintf fmt (if par then "(%s)" else "%s") (QCheck.Fn.print f) end module Equal = struct type 'a t = 'a -> 'a -> bool let equal_exn = ( = ) let equal_unit = Unit.equal let equal_bool = Bool.equal let equal_int = Int.equal let equal_int64 = Int64.equal let equal_float = Float.equal let equal_char = Char.equal let equal_string = String.equal let equal_option = Option.equal let equal_result eq_o eq_e x y = Result.equal ~ok:eq_o ~error:eq_e x y let equal_list = List.equal let rec equal_seq eq s1 s2 = (* To support OCaml 4.13 as Seq.equal was added in 4.14 *) let open Seq in match s1 (), s2 () with | Nil, Nil -> true | Cons (a, an), Cons (b, bn) when eq a b -> equal_seq eq an bn | _ -> false let equal_array eq x y = equal_seq eq (Array.to_seq x) (Array.to_seq y) end multicoretests-0.7/lib/util.mli000066400000000000000000000211531474367232000167060ustar00rootroot00000000000000(** The Util module contains a number of reusable functions handy for multicore testing. *) val repeat : int -> ('a -> bool) -> 'a -> bool (** [repeat num prop] iterates a property [prop] [num] times. The function stops early and returns false if just one of the iterations returns false. This is handy if the property outcome is non-determistic, for example, if it depends on scheduling. *) exception Timeout (** exception raised by [prop_timeout] and [fork_prop_with_timeout]. *) val prop_timeout : int -> ('a -> 'b) -> 'a -> 'b (** [prop_timeout s prop] returns a property working as [prop] that times out and raises [Timeout] after [s] seconds. *) val fork_prop_with_timeout : int -> ('a -> bool) -> 'a -> bool (** [fork_prop_with_timeout s prop] tests a property in a separate process and times out and raises [Timeout] after [s] seconds, like [prop_timeout s prop]. This is handy if the tested code can segfault or loop infinitely. *) val print_vertical : ?fig_indent:int -> ('a -> string) -> 'a list -> string (** [print_vertical pr cmds] returns a string representing a sequential trace. Optional [fig_indent] indicates how many spaces it should be indented (default: 3 spaces). *) val print_triple_vertical : ?fig_indent:int -> ?res_width:int -> ?center_prefix:bool -> ('a -> string) -> 'a list * 'a list * 'a list -> string (** [print_triple_vertical pr (xs,ys,zs)] returns a string representing a parallel trace, with [xs] printed first, and then [ys] and [zs] printed in parallel. Optional [fig_indent] indicates how many spaces it should be indented (default: 10 spaces). Optional [res_width] specifies the reserved width for printing each list entry (default: 20 chars). Optional [center_prefix] centers the sequential prefix if [true] (the default) and otherwise left-adjust it. *) val protect : ('a -> 'b) -> 'a -> ('b, exn) result (** [protect f] turns an [exception] throwing function into a [result] returning function. *) module Pp : sig (** Pretty-printing combinators that generate valid OCaml syntax for common types along with combinators for user-defined types *) type 'a t = bool -> Format.formatter -> 'a -> unit (** The type of pretty-printers to valid OCaml syntax. The [bool] argument asks the printer to wrap its output inside parentheses if it produces a non-atomic expression. *) val to_show : 'a t -> 'a -> string (** [to_show pp] converts a pretty-printer to a simple ['a -> string] function that generate everything on one line. If the environment variable [MCTUTILS_TRUNCATE] is set to a length, it will truncate the resulting string if it exceeds that length. *) val of_show : ('a -> string) -> 'a t (** [of_show show] uses a simple ['a -> string] function as a pretty-printer. Unfortunately, it will wrap the resulting string with parentheses in more cases than strictly necessary. *) val cst0 : string -> Format.formatter -> unit (** [cst0 name fmt] pretty-prints a constructor [name] with no argument. *) val cst1 : 'a t -> string -> bool -> Format.formatter -> 'a -> unit (** [cst1 pp name par v fmt] pretty-prints a constructor [name] with one parameter, using [pp] to pretty-print its argument [v], wrapping itself into parentheses when [par]. *) val cst2 : 'a t -> 'b t -> string -> bool -> Format.formatter -> 'a -> 'b -> unit (** [cst2 pp1 pp2 name par v1 v2 fmt] pretty-prints a constructor [name] with two parameters, using [pp]i to pretty-print its argument [v]i, wrapping itself into parentheses when [par]. *) val cst3 : 'a t -> 'b t -> 'c t -> string -> bool -> Format.formatter -> 'a -> 'b -> 'c -> unit (** [cst3 pp1 pp2 pp3 name par v1 v2 v3 fmt] pretty-prints a constructor [name] with three parameters, using [pp]i to pretty-print its argument [v]i, wrapping itself into parentheses when [par]. *) val pp_exn : exn t (** Pretty-printer for exceptions reusing the standard {!Printexc.to_string}. The exception message will be wrapped conservatively (ie too often) in parentheses. *) val pp_unit : unit t (** Pretty-printer for type [unit] *) val pp_bool : bool t (** Pretty-printer for type [bool] *) val pp_int : int t (** Pretty-printer for type [int] *) val pp_int32 : int32 t (** Pretty-printer for type [int32] *) val pp_int64 : int64 t (** Pretty-printer for type [int64] *) val pp_float : float t (** Pretty-printer for type [float] *) val pp_char : char t (** Pretty-printer for type [char] *) val pp_string : string t (** Pretty-printer for type [string] *) val pp_bytes : bytes t (** Pretty-printer for type [bytes] *) val pp_option : 'a t -> 'a option t (** [pp_option pp] pretty-prints a value of type ['a option] using [pp] to pretty-print values of type ['a]. *) val pp_result : 'o t -> 'e t -> ('o, 'e) result t (** [pp_result pp_ok pp_error] pretty-prints a value of type [('o, 'e) result] using [pp_ok] to pretty-print values of type ['o] and [pp_error] for values of type ['e]. *) type pp_tuple_item (** The abstract type for the pretty-printer of a tuple item *) val pp_tuple_item : 'a t -> 'a -> pp_tuple_item (** [pp_tuple_item pp v] builds a pretty-printer for a tuple item using [pp] to pretty-print its value [v]. *) val pp_tuple : pp_tuple_item list t (** [pp_tuple] pretty-prints a tuple taken as a list of [pp_tuple_item]s. *) val pp_pair : 'a t -> 'b t -> ('a * 'b) t (** [pp_pair pp_a pp_b] pretty-prints a value of type ['a * 'b] using [pp_a] to pretty-print values of type ['a] and [pp_b] for values of type ['b]. *) val pp_tuple2 : 'a t -> 'b t -> ('a * 'b) t (** [pp_tuple2] pretty-prints pairs, synonym for [pp_pair]. *) val pp_tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t (** [pp_tuple3] pretty-prints triples. *) val pp_tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t (** [pp_tuple4] pretty-prints tuples of 4 elements. *) val pp_tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t (** [pp_tuple5] pretty-prints tuples of 5 elements. *) val pp_tuple6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('a * 'b * 'c * 'd * 'e * 'f) t (** [pp_tuple6] pretty-prints tuples of 6 elements. *) val pp_tuple7 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g) t (** [pp_tuple7] pretty-prints tuples of 7 elements. *) val pp_tuple8 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t (** [pp_tuple8] pretty-prints tuples of 8 elements. *) val pp_tuple9 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t (** [pp_tuple9] pretty-prints tuples of 9 elements. *) val pp_tuple10 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t -> 'j t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j) t (** [pp_tuple10] pretty-prints tuples of 10 elements. *) val pp_list : 'a t -> 'a list t (** [pp_list pp] pretty-prints a list using [pp] to pretty-print its elements. *) val pp_seq : 'a t -> 'a Seq.t t (** [pp_seq pp] pretty-prints a sequence using [pp] to pretty-print its elements. *) val pp_array : 'a t -> 'a array t (** [pp_array pp] pretty-prints an array using [pp] to pretty-print its elements. *) type pp_field (** The abstract type for the pretty-printer of a record field *) val pp_field : string -> 'a t -> 'a -> pp_field (** [pp_field name pp v] builds a pretty-printer for a record field of given [name] using [pp] to pretty-print its content value [v]. *) val pp_record : pp_field list t (** [pp_record flds] pretty-prints a record using the list of pretty-printers of its fields. *) val pp_fun_ : _ QCheck.fun_ t (** Pretty-printer for QCheck's function type [fun_] *) end module Equal : sig (** Equality combinators for common types *) type 'a t = 'a -> 'a -> bool (** The usual type for equality functions *) val equal_exn : exn t (** equality function for comparing exceptions *) val equal_unit : unit t val equal_bool : bool t val equal_int : int t val equal_int64 : int64 t val equal_float : float t val equal_char : char t val equal_string : string t val equal_option : 'a t -> 'a option t val equal_result : 'o t -> 'e t -> ('o, 'e) result t val equal_list : 'a t -> 'a list t val equal_seq : 'a t -> 'a Seq.t t val equal_array : 'a t -> 'a array t end multicoretests-0.7/multicoretests.opam000066400000000000000000000020461474367232000204240ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.7" synopsis: "Experimental multicore test suite of OCaml 5.0" description: """ This package contains a collection of randomized QCheck tests to exercise the multicore run-time of OCaml 5.0.""" maintainer: ["Jan Midtgaard "] authors: ["Multiple contributors"] license: "BSD-2-clause" tags: [ "test" "test suite" "property" "qcheck" "quickcheck" "multicore" "non-determinism" ] homepage: "https://github.com/ocaml-multicore/multicoretests" bug-reports: "https://github.com/ocaml-multicore/multicoretests/issues" depends: [ "dune" {>= "3.0"} "base-domains" "qcheck-core" {>= "0.23"} "qcheck-lin" {= version} "qcheck-stm" {= version} "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/ocaml-multicore/multicoretests.git" x-maintenance-intent: ["(latest)"] multicoretests-0.7/multicoretests.opam.template000066400000000000000000000000431474367232000222310ustar00rootroot00000000000000x-maintenance-intent: ["(latest)"] multicoretests-0.7/qcheck-lin.opam000066400000000000000000000023741474367232000173600ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.7" synopsis: "A multicore testing library for OCaml" description: """ A testing library based on QCheck to test interface behaviour under parallel usage. Lin will generate and run random parallel tests and check the observed behaviour for sequential consistency, that is, whether they can be linearized and explained by some sequential interleaving.""" maintainer: ["Jan Midtgaard "] authors: ["Jan Midtgaard" "Olivier Nicole" "Nicolas Osborne" "Samuel Hym"] license: "BSD-2-clause" tags: [ "test" "property" "qcheck" "quickcheck" "parallelism" "sequential consistency" ] homepage: "https://github.com/ocaml-multicore/multicoretests" bug-reports: "https://github.com/ocaml-multicore/multicoretests/issues" depends: [ "dune" {>= "3.0"} "ocaml" {>= "4.12"} "qcheck-core" {>= "0.23"} "qcheck-multicoretests-util" {= version} "odoc" {with-doc} ] depopts: ["base-domains"] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocaml-multicore/multicoretests.git" x-maintenance-intent: ["(latest)"] multicoretests-0.7/qcheck-lin.opam.template000066400000000000000000000000431474367232000211610ustar00rootroot00000000000000x-maintenance-intent: ["(latest)"] multicoretests-0.7/qcheck-multicoretests-util.opam000066400000000000000000000020041474367232000226250ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.7" synopsis: "Various utility functions for property-based testing of multicore programs" description: """ A small library of utility functions for QCheck-based testing of multicore programs.""" maintainer: ["Jan Midtgaard "] authors: ["Jan Midtgaard" "Olivier Nicole" "Nicolas Osborne" "Samuel Hym"] license: "BSD-2-clause" tags: ["test" "property" "qcheck" "quickcheck" "multicore" "non-determinism"] homepage: "https://github.com/ocaml-multicore/multicoretests" bug-reports: "https://github.com/ocaml-multicore/multicoretests/issues" depends: [ "dune" {>= "3.0"} "ocaml" {>= "4.12"} "qcheck-core" {>= "0.23"} "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/ocaml-multicore/multicoretests.git" x-maintenance-intent: ["(latest)"] multicoretests-0.7/qcheck-multicoretests-util.opam.template000066400000000000000000000000431474367232000244400ustar00rootroot00000000000000x-maintenance-intent: ["(latest)"] multicoretests-0.7/qcheck-stm.opam000066400000000000000000000022521474367232000173740ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.7" synopsis: "State-machine testing library for sequential and parallel model-based tests" description: """ A state-machine testing library based on QCheck that can generate both sequential and parallel tests against a declarative model.""" maintainer: ["Jan Midtgaard "] authors: ["Jan Midtgaard" "Olivier Nicole" "Nicolas Osborne" "Samuel Hym"] license: "BSD-2-clause" tags: [ "test" "property" "qcheck" "quickcheck" "state-machine testing" "model-based testing" "parallel testing" ] homepage: "https://github.com/ocaml-multicore/multicoretests" bug-reports: "https://github.com/ocaml-multicore/multicoretests/issues" depends: [ "dune" {>= "3.0"} "ocaml" {>= "4.12"} "qcheck-core" {>= "0.23"} "qcheck-multicoretests-util" {= version} "odoc" {with-doc} ] depopts: ["base-domains"] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/ocaml-multicore/multicoretests.git" x-maintenance-intent: ["(latest)"] multicoretests-0.7/qcheck-stm.opam.template000066400000000000000000000000431474367232000212020ustar00rootroot00000000000000x-maintenance-intent: ["(latest)"] multicoretests-0.7/src/000077500000000000000000000000001474367232000152455ustar00rootroot00000000000000multicoretests-0.7/src/README.md000066400000000000000000000134001474367232000165220ustar00rootroot00000000000000Current PBTs of OCaml 5 ======================= Tests utilizing the parallel STM.ml capability: - [array/stm_tests.ml](array/stm_tests.ml) contains sequential and parallel tests of the `Array` module - [atomic/stm_tests.ml](atomic/stm_tests.ml) contains sequential and parallel tests of the `Atomic` module - [bigarray/stm_tests.ml](bigarray/stm_tests.ml) contains sequential and parallel tests of the `Bigarray` module - [buffer/stm_tests.ml](buffer/stm_tests.ml) contains sequential and parallel tests of the `Buffer` module - [bytes/stm_tests.ml](bytes/stm_tests.ml) contains sequential and parallel tests of the `Bytes` module - [domain/stm_tests_dls.ml](domain/stm_tests_dls.ml) contains sequential and parallel tests of the `Domain.DLS` module - [dynarray/stm_tests.ml](dynarray/stm_tests.ml) contains sequential and parallel tests of the `Dynarray` module - [ephemeron/stm_tests.ml](ephemeron/stm_tests.ml) contains sequential and parallel tests of the `Ephemeron` module - [floatarray/stm_tests.ml](floatarray/stm_tests.ml) contains sequential and parallel tests of the `Float.Array` module - [gc](gc) contains sequential and parallel tests of the `Gc` module - [gc/stm_tests_seq.ml](gc/stm_tests_seq.ml), [gc/stm_tests_seq_child.ml](gc/stm_tests_seq_child.ml), and [gc/stm_tests_par.ml](gc/stm_tests_par.ml) contains a version with explicit calls to `Gc` functions, and - [gc/stm_tests_impl_seq.ml](gc/stm_tests_impl_seq.ml), [gc/stm_tests_impl_seq_child.ml](gc/stm_tests_impl_seq_child.ml), and [gc/stm_tests_impl_par.ml](gc/stm_tests_impl_par.ml) contains a version with implicit calls to the `Gc` - [hashtbl/stm_tests.ml](hashtbl/stm_tests.ml) contains sequential and parallel tests of the `Hashtbl` module - [lazy/stm_tests.ml](lazy/stm_tests.ml) contains sequential and parallel tests of the `Lazy` module - [semaphore/stm_tests.ml](semaphore/stm_tests.ml) contains sequential and parallel tests of the `Semaphore.Counting` module - [sys/stm_tests.ml](sys/stm_tests.ml) contains sequential and parallel tests of the `Sys` module - [weak/stm_tests.ml](weak/stm_tests.ml) and [weak/stm_tests_hashset.ml](weak/stm_tests_hashset.ml) contains sequential and parallel tests of the `Weak` module Tests utilizing `Lin`: - [array/lin_internal_tests.ml](array/lin_internal_tests.ml) and [array/lin_tests.ml](array/lin_tests.ml) contain experimental `Lin.Internal` and `Lin`-tests of `Array` - [atomic/lin_internal_tests.ml](atomic/lin_internal_tests.ml) and [atomic/lin_tests.ml](atomic/lin_tests.ml) contain experimental `Lin.Internal` and `Lin`-tests of `Atomic` - [bigarray/lin_tests.ml](bigarray/lin_tests.ml) contains experimental `Lin`-tests of `Bigarray` - [bytes/lin_tests.ml](bytes/lin_tests.ml) contains experimental `Lin`-tests of `Bytes` - [domain/lin_tests_dls.ml](domain/lin_tests_dls.ml) contains experimental `Lin`-tests of `Domain.DLS` - [dynarray/lin_tests.ml](dynarray/lin_tests.ml) contains experimental `Lin`-tests of `Dynarray` - [dynlink/lin_tests.ml](dynlink/lin_tests.ml) contains experimental `Lin`-tests of `Dynlink` - [ephemeron/lin_tests.ml](ephemeron/lin_tests.ml) contains experimental `Lin`-stress tests of `Ephemeron` - [floatarray/lin_tests.ml](floatarray/lin_tests.ml) contains experimental `Lin`-tests of `Float.Array` - [hashtbl/lin_internal_tests.ml](hashtbl/lin_internal_tests.ml) and [hashtbl/lin_tests.ml](hashtbl/lin_tests.ml) contain experimental `Lin.Internal` and `Lin`-tests of `Hashtbl` - [io/lin_internal_tests.ml](hashtbl/lin_internal_tests.ml), [io/lin_tests_domain.ml](io/lin_tests_domain.ml), and [io/lin_tests_thread.ml](io/lin_tests_thread.ml) contain experimental `Lin.Internal` and `Lin`-tests of `In_channel` and `Out_channel` - [lazy/lin_internal_tests.ml](lazy/lin_internal_tests.ml) and [lazy/lin_tests.ml](lazy/lin_tests.ml) contain experimental `Lin.Internal` and `Lin`-tests of `Lazy` - [queue/lin_internal_tests.ml](queue/lin_internal_tests.ml) and [queue/lin_tests.ml](queue/lin_tests.ml) contain experimental `Lin.Internal` and `Lin`-tests of `Queue` - [stack/lin_internal_tests.ml](stack/lin_internal_tests.ml) and [stack/lin_tests.ml](stack/lin_tests.ml) contain experimental `Lin.Internal` and `Lin`-tests of `Stack` - [weak/lin_tests.ml](weak/lin_tests.ml) and [weak/lin_tests_hashset.ml](weak/lin_tests_hashset.ml) contains experimental `Lin`-stress tests of the `Weak` module Tests of the underlying spawn/async functionality of `Domain` and `Thread` (not using `STM.ml` or `Lin.ml` which rely on them): - [domain/domain_joingraph.ml](domain/domain_joingraph.ml) is a test of `Domain`'s `spawn`/`join` based on a random dependency graph - [domain/domain_spawntree.ml](domain/domain_spawntree.ml) is a test of `Domain`'s `spawn`/`join` based on a random `spawn` tree - [thread/thread_joingraph.ml](thread/thread_joingraph.ml) is a test of `Thread`'s `create`/`join` based on a random dependency graph - [thread/thread_createtree.ml](thread/thread_createtree.ml) is a test of `Thread`'s `create`/`join` based on a random `create` tree Development tests ----------------- During development we use examples with known problems to help ensure that concurrency issues are indeed found as expected (aka. sanity check). For `Lin.Internal` and `Lin` - [neg_tests/lin_internal_tests_common.ml](neg_tests/lin_internal_tests_common.ml) and - [neg_tests/lin_tests_common.ml](neg_tests/lin_tests_common.ml) contain "sanity check tests" for an unprotected global `ref` and a buggy concurrent list over unboxed `int` and boxed `int64` types. For `STM` - [neg_tests/stm_tests_spec_ref.ml](neg_tests/stm_tests_spec_ref.ml) and - [neg_tests/stm_tests_conclist.ml](neg_tests/stm_tests_conclist.ml) contain similar tests. multicoretests-0.7/src/array/000077500000000000000000000000001474367232000163635ustar00rootroot00000000000000multicoretests-0.7/src/array/dune000066400000000000000000000010261474367232000172400ustar00rootroot00000000000000;; Test of the array library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/array/lin_internal_tests.ml000066400000000000000000000100461474367232000226160ustar00rootroot00000000000000open QCheck (* ********************************************************************** *) (* Tests of thread-unsafe [Array] *) (* ********************************************************************** *) module AConf = struct type t = char array type cmd = | Length | Get of int | Set of int * char | Sub of int * int | Copy | Fill of int * int * char | To_list | Mem of char | Sort | To_seq let pp_cmd par fmt x = let open Util.Pp in match x with | Length -> cst0 "Length" fmt | Get x -> cst1 pp_int "Get" par fmt x | Set (x, y) -> cst2 pp_int pp_char "Set" par fmt x y | Sub (x, y) -> cst2 pp_int pp_int "Sub" par fmt x y | Copy -> cst0 "Copy" fmt | Fill (x, y, z) -> cst3 pp_int pp_int pp_char "Fill" par fmt x y z | To_list -> cst0 "To_list" fmt | Mem x -> cst1 pp_char "Mem" par fmt x | Sort -> cst0 "Sort" fmt | To_seq -> cst0 "To_seq" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int = small_nat and char = printable in oneof [ pure Length; map (fun x -> Get x) int; map2 (fun x y -> Set (x, y)) int char; map2 (fun x y -> Sub (x, y)) int int; pure Copy; map3 (fun x y z -> Fill (x, y, z)) int int char; pure To_list; map (fun x -> Mem x) char; pure Sort; pure To_seq; ] let shrink_cmd c = Iter.empty type res = | RLength of int | RGet of (char, exn) result | RSet of (unit, exn) result | RSub of (char array, exn) result | RCopy of char array | RFill of (unit, exn) result | RTo_list of char list | RMem of bool | RSort of unit | RTo_seq of char Seq.t let pp_res par fmt x = let open Util.Pp in match x with | RLength x -> cst1 pp_int "RLength" par fmt x | RGet x -> cst1 (pp_result pp_char pp_exn) "RGet" par fmt x | RSet x -> cst1 (pp_result pp_unit pp_exn) "RSet" par fmt x | RSub x -> cst1 (pp_result (pp_array pp_char) pp_exn) "RSub" par fmt x | RCopy x -> cst1 (pp_array pp_char) "RCopy" par fmt x | RFill x -> cst1 (pp_result pp_unit pp_exn) "RFill" par fmt x | RTo_list x -> cst1 (pp_list pp_char) "RTo_list" par fmt x | RMem x -> cst1 pp_bool "RMem" par fmt x | RSort x -> cst1 pp_unit "RSort" par fmt x | RTo_seq x -> cst1 (pp_seq pp_char) "RTo_seq" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RLength x, RLength y -> equal_int x y | RGet x, RGet y -> equal_result equal_char equal_exn x y | RSet x, RSet y -> equal_result equal_unit equal_exn x y | RSub x, RSub y -> equal_result (equal_array equal_char) equal_exn x y | RCopy x, RCopy y -> equal_array equal_char x y | RFill x, RFill y -> equal_result equal_unit equal_exn x y | RTo_list x, RTo_list y -> equal_list equal_char x y | RMem x, RMem y -> equal_bool x y | RSort x, RSort y -> equal_unit x y | RTo_seq x, RTo_seq y -> equal_seq equal_char x y | _, _ -> false let array_size = 16 let init () = Array.make array_size 'a' let run c a = match c with | Length -> RLength (Array.length a) | Get i -> RGet (Util.protect (Array.get a) i) | Set (i,c) -> RSet (Util.protect (Array.set a i) c) | Sub (i,l) -> RSub (Util.protect (Array.sub a i) l) | Copy -> RCopy (Array.copy a) | Fill (i,l,c) -> RFill (Util.protect (Array.fill a i l) c) | To_list -> RTo_list (Array.to_list a) | Mem c -> RMem (Array.mem c a) | Sort -> RSort (Array.sort Char.compare a) | To_seq -> RTo_seq (List.to_seq (List.of_seq (Array.to_seq a))) (* workaround: Array.to_seq is lazy and will otherwise see and report later Array.set state changes... *) let cleanup _ = () end module AT_domain = Lin_domain.Make_internal(AConf) [@alert "-internal"] ;; QCheck_base_runner.run_tests_main [ AT_domain.neg_lin_test ~count:1000 ~name:"Lin.Internal Array test with Domain"; ] multicoretests-0.7/src/array/lin_tests.ml000066400000000000000000000031721474367232000207240ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Array] *) (* ********************************************************************** *) module AConf = struct type t = char array let array_size = 16 let init () = Array.make array_size 'a' let cleanup _ = () open Lin let int,char = nat_small,char_printable let array_to_seq a = List.to_seq (List.of_seq (Array.to_seq a)) (* workaround: Array.to_seq is lazy and will otherwise see and report later Array.set state changes... *) let api = [ val_ "Array.length" Array.length (t @-> returning int); val_ "Array.get" Array.get (t @-> int @-> returning_or_exc char); val_ "Array.set" Array.set (t @-> int @-> char @-> returning_or_exc unit); val_ "Array.sub" Array.sub (t @-> int @-> int @-> returning_or_exc (array char)); val_ "Array.copy" Array.copy (t @-> returning (array char)); val_ "Array.fill" Array.fill (t @-> int @-> int @-> char @-> returning_or_exc unit); val_ "Array.to_list" Array.to_list (t @-> returning (list char)); val_ "Array.mem" Array.mem (char @-> t @-> returning bool); val_ "Array.sort" (Array.sort Char.compare) (t @-> returning unit); val_ "Array.to_seq" array_to_seq (t @-> returning (seq char)); ] end module AT_domain = Lin_domain.Make(AConf) ;; QCheck_base_runner.run_tests_main [ AT_domain.neg_lin_test ~count:1000 ~name:"Lin Array test with Domain"; AT_domain.stress_test ~count:1000 ~name:"Lin Array stress test with Domain"; ] multicoretests-0.7/src/array/stm_tests.ml000066400000000000000000000143661474367232000207540ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Array *) module AConf = struct type cmd = | Length | Get of int | Set of int * char | Sub of int * int | Copy | Fill of int * int * char | To_list | For_all of (char -> bool) fun_ | Exists of (char -> bool) fun_ | Mem of char | Find_opt of (char -> bool) fun_ (*| Find_index of char_bool_fun since 5.1*) | Sort | Stable_sort | Fast_sort | To_seq let pp_cmd par fmt x = let open Util.Pp in match x with | Length -> cst0 "Length" fmt | Get x -> cst1 pp_int "Get" par fmt x | Set (x, y) -> cst2 pp_int pp_char "Set" par fmt x y | Sub (x, y) -> cst2 pp_int pp_int "Sub" par fmt x y | Copy -> cst0 "Copy" fmt | Fill (x, y, z) -> cst3 pp_int pp_int pp_char "Fill" par fmt x y z | To_list -> cst0 "To_list" fmt | For_all f -> cst1 pp_fun_ "For_all" par fmt f | Exists f -> cst1 pp_fun_ "Exists" par fmt f | Mem x -> cst1 pp_char "Mem" par fmt x | Find_opt f -> cst1 pp_fun_ "Find_opt" par fmt f (*| Find_index f -> cst1 pp_char_bool_fun "Find_index" par fmt f*) | Sort -> cst0 "Sort" fmt | Stable_sort -> cst0 "Stable_sort" fmt | Fast_sort -> cst0 "Fast_sort" fmt | To_seq -> cst0 "To_seq" fmt let show_cmd = Util.Pp.to_show pp_cmd type state = char list type sut = char Array.t let arb_cmd s = let int_gen = Gen.(oneof [small_nat; int_bound (List.length s - 1)]) in let char_gen = Gen.printable in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(oneof [ return Length; map (fun i -> Get i) int_gen; map2 (fun i c -> Set (i,c)) int_gen char_gen; map2 (fun i len -> Sub (i,len)) int_gen int_gen; (* hack: reusing int_gen for length *) return Copy; map3 (fun i len c -> Fill (i,len,c)) int_gen int_gen char_gen; (* hack: reusing int_gen for length *) return To_list; map (fun f -> For_all f) (fun1 Observable.char QCheck.bool).gen; map (fun f -> Exists f) (fun1 Observable.char QCheck.bool).gen; map (fun c -> Mem c) char_gen; map (fun f -> Find_opt f) (fun1 Observable.char QCheck.bool).gen; (*map (fun f -> Find_index f) (fun1 Observable.char QCheck.bool).gen;*) return Sort; return Stable_sort; return Fast_sort; return To_seq; ]) let array_size = 16 let init_state = List.init array_size (fun _ -> 'a') let next_state c s = match c with | Length -> s | Get _ -> s | Set (i,c) -> List.mapi (fun j c' -> if i=j then c else c') s | Sub (_,_) -> s | Copy -> s | Fill (i,l,c) -> if i >= 0 && l >= 0 && i+l-1 < List.length s then List.mapi (fun j c' -> if i <= j && j <= i+l-1 then c else c') s else s | To_list -> s | For_all _ -> s | Exists _ -> s | Mem _ -> s | Find_opt _ -> s (*| Find_index _ -> s*) | Sort -> List.sort Char.compare s | Stable_sort -> List.stable_sort Char.compare s | Fast_sort -> List.fast_sort Char.compare s | To_seq -> s let init_sut () = Array.make array_size 'a' let cleanup _ = () let precond c _s = match c with | _ -> true let run c a = match c with | Length -> Res (int, Array.length a) | Get i -> Res (result char exn, protect (Array.get a) i) | Set (i,c) -> Res (result unit exn, protect (Array.set a i) c) | Sub (i,l) -> Res (result (array char) exn, protect (Array.sub a i) l) | Copy -> Res (array char, Array.copy a) | Fill (i,l,c) -> Res (result unit exn, protect (Array.fill a i l) c) | To_list -> Res (list char, Array.to_list a) | For_all (Fun (_,f)) -> Res (bool, Array.for_all f a) | Exists (Fun (_,f)) -> Res (bool, Array.exists f a) | Mem c -> Res (bool, Array.mem c a) | Find_opt (Fun (_,f)) -> Res (option char, Array.find_opt f a) (*| Find_index (Fun (_,f)) -> Res (option int, Array.find_index f a)*) | Sort -> Res (unit, Array.sort Char.compare a) | Stable_sort -> Res (unit, Array.stable_sort Char.compare a) | Fast_sort -> Res (unit, Array.fast_sort Char.compare a) | To_seq -> Res (seq char, List.to_seq (List.of_seq (Array.to_seq a))) (* workaround: Array.to_seq is lazy and will otherwise see and report later Array.set state changes... *) let postcond c (s:char list) res = match c, res with | Length, Res ((Int,_),i) -> i = List.length s | Get i, Res ((Result (Char,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok (List.nth s i) | Set (i,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok () | Sub (i,l), Res ((Result (Array Char,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "Array.sub") else r = Ok (Array.of_list (List.filteri (fun j _ -> i <= j && j <= i+l-1) s)) | Copy, Res ((Array Char,_),r) -> Array.to_list r = s | Fill (i,l,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "Array.fill") else r = Ok () | To_list, Res ((List Char,_),cs) -> cs = s | For_all (Fun (_,f)), Res ((Bool,_),r) -> r = List.for_all f s | Exists (Fun (_,f)), Res ((Bool,_),r) -> r = List.exists f s | Mem c, Res ((Bool,_),r) -> r = List.mem c s | Find_opt (Fun (_,f)), Res ((Option Char,_),r) -> r = List.find_opt f s (*| Find_index (Fun (_,f)), Res ((Option Int,_),r) -> r = List.find_index f s*) | Sort, Res ((Unit,_),r) -> r = () | Stable_sort, Res ((Unit,_),r) -> r = () | Fast_sort, Res ((Unit,_),r) -> r = () | To_seq, Res ((Seq Char,_),r) -> Seq.equal (=) r (List.to_seq s) | _, _ -> false end module ArraySTM_seq = STM_sequential.Make(AConf) module ArraySTM_dom = STM_domain.Make(AConf) ;; QCheck_base_runner.run_tests_main (let count = 1000 in [ArraySTM_seq.agree_test ~count ~name:"STM Array test sequential"; ArraySTM_dom.neg_agree_test_par ~count ~name:"STM Array test parallel" (* this test is expected to fail *) ]) multicoretests-0.7/src/atomic/000077500000000000000000000000001474367232000165215ustar00rootroot00000000000000multicoretests-0.7/src/atomic/dune000066400000000000000000000012211474367232000173730ustar00rootroot00000000000000;; Tests of the stdlib Atomic library ;; STM_sequential and STM_domain test of Atomic (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) ;; Linearization tests of Atomic, utilizing ppx_deriving_qcheck (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/atomic/lin_internal_tests.ml000066400000000000000000000135341474367232000227610ustar00rootroot00000000000000open QCheck (* ********************************************************************** *) (* Tests of the Atomic module *) (* ********************************************************************** *) module AConf = struct type t = int Atomic.t type cmd = | Get | Set of int | Exchange of int | Compare_and_set of int * int | Fetch_and_add of int | Incr | Decr let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Exchange x -> cst1 pp_int "Exchange" par fmt x | Compare_and_set (x, y) -> cst2 pp_int pp_int "Compare_and_set" par fmt x y | Fetch_and_add x -> cst1 pp_int "Fetch_and_add" par fmt x | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int = nat in oneof [ pure Get; map (fun x -> Set x) int; map (fun x -> Exchange x) int; map2 (fun x y -> Compare_and_set (x, y)) int int; map (fun x -> Fetch_and_add x) int; pure Incr; pure Decr; ] let shrink_cmd = Shrink.nil type res = | RGet of int | RSet | RExchange of int | RFetch_and_add of int | RCompare_and_set of bool | RIncr | RDecr let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RExchange x -> cst1 pp_int "RExchange" par fmt x | RFetch_and_add x -> cst1 pp_int "RFetch_and_add" par fmt x | RCompare_and_set x -> cst1 pp_bool "RCompare_and_set" par fmt x | RIncr -> cst0 "RIncr" fmt | RDecr -> cst0 "RDecr" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int x y | RSet, RSet -> true | RExchange x, RExchange y -> equal_int x y | RFetch_and_add x, RFetch_and_add y -> equal_int x y | RCompare_and_set x, RCompare_and_set y -> equal_bool x y | RIncr, RIncr -> true | RDecr, RDecr -> true | _, _ -> false let init () = Atomic.make 0 let run c r = match c with | Get -> RGet (Atomic.get r) | Set i -> (Atomic.set r i; RSet) | Exchange i -> RExchange (Atomic.exchange r i) | Fetch_and_add i -> RFetch_and_add (Atomic.fetch_and_add r i) | Compare_and_set (seen,v) -> RCompare_and_set (Atomic.compare_and_set r seen v) | Incr -> (Atomic.incr r; RIncr) | Decr -> (Atomic.decr r; RDecr) let cleanup _ = () end module AT_domain = Lin_domain.Make_internal(AConf) [@alert "-internal"] (** A variant of the above with 3 Atomics *) module A3Conf = struct type t = int Atomic.t array type cmd = | Get of var | Set of var * int | Exchange of var * int | Compare_and_set of var * int * int | Fetch_and_add of var * int | Incr of var | Decr of var and var = int let pp_cmd par fmt x = let open Util.Pp in match x with | Get x -> cst1 pp_int "Get" par fmt x | Set (x, y) -> cst2 pp_int pp_int "Set" par fmt x y | Exchange (x, y) -> cst2 pp_int pp_int "Exchange" par fmt x y | Compare_and_set (x, y, z) -> cst3 pp_int pp_int pp_int "Compare_and_set" par fmt x y z | Fetch_and_add (x, y) -> cst2 pp_int pp_int "Fetch_and_add" par fmt x y | Incr x -> cst1 pp_int "Incr" par fmt x | Decr x -> cst1 pp_int "Decr" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let var = int_bound 2 and int = nat in oneof [ map (fun x -> Get x) var; map2 (fun x y -> Set (x, y)) var int; map2 (fun x y -> Exchange (x, y)) var int; map3 (fun x y z -> Compare_and_set (x, y, z)) var int int; map2 (fun x y -> Fetch_and_add (x, y)) var int; map (fun x -> Incr x) var; map (fun x -> Decr x) var; ] let shrink_cmd = Shrink.nil type res = | RGet of int | RSet | RExchange of int | RFetch_and_add of int | RCompare_and_set of bool | RIncr | RDecr let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RExchange x -> cst1 pp_int "RExchange" par fmt x | RFetch_and_add x -> cst1 pp_int "RFetch_and_add" par fmt x | RCompare_and_set x -> cst1 pp_bool "RCompare_and_set" par fmt x | RIncr -> cst0 "RIncr" fmt | RDecr -> cst0 "RDecr" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int x y | RSet, RSet -> true | RExchange x, RExchange y -> equal_int x y | RFetch_and_add x, RFetch_and_add y -> equal_int x y | RCompare_and_set x, RCompare_and_set y -> equal_bool x y | RIncr, RIncr -> true | RDecr, RDecr -> true | _, _ -> false let init () = [| Atomic.make 0; Atomic.make 0; Atomic.make 0 |] let run c env = match c with | Get v -> RGet (Atomic.get env.(v)) | Set (v,i) -> (Atomic.set env.(v) i; RSet) | Exchange (v,i) -> RExchange (Atomic.exchange env.(v) i) | Fetch_and_add (v,i) -> RFetch_and_add (Atomic.fetch_and_add env.(v) i) | Compare_and_set (v,seen,nval) -> RCompare_and_set (Atomic.compare_and_set env.(v) seen nval) | Incr v -> (Atomic.incr env.(v); RIncr) | Decr v -> (Atomic.decr env.(v); RDecr) let cleanup _ = () end module A3T_domain = Lin_domain.Make_internal(A3Conf) [@alert "-internal"] ;; QCheck_base_runner.run_tests_main [ AT_domain.lin_test ~count:1000 ~name:"Lin.Internal Atomic test with Domain"; A3T_domain.lin_test ~count:1000 ~name:"Lin.Internal Atomic3 test with Domain"; ] multicoretests-0.7/src/atomic/lin_tests.ml000066400000000000000000000017201474367232000210570ustar00rootroot00000000000000module Atomic_spec : Lin.Spec = struct open Lin (* FIXME add Gen.nat *) type t = int Atomic.t let init () = Atomic.make 0 let cleanup _ = () let api = [ val_ "Atomic.get" Atomic.get (t @-> returning int); val_ "Atomic.set" Atomic.set (t @-> int @-> returning unit); val_ "Atomic.exchange" Atomic.exchange (t @-> int @-> returning int); val_ "Atomic.fetch_and_add" Atomic.fetch_and_add (t @-> int @-> returning int); val_ "Atomic.compare_and_set" Atomic.compare_and_set (t @-> int @-> int @-> returning bool); val_ "Atomic.incr" Atomic.incr (t @-> returning unit); val_ "Atomic.decr" Atomic.decr (t @-> returning unit) ] end module Lin_atomic_domain = Lin_domain.Make (Atomic_spec) let () = QCheck_base_runner.run_tests_main [ Lin_atomic_domain.lin_test ~count:1000 ~name:"Lin Atomic test with Domain"; ] multicoretests-0.7/src/atomic/stm_tests.ml000066400000000000000000000054371474367232000211110ustar00rootroot00000000000000open QCheck open STM (** This is a parallel test of the Atomic module *) module CConf = struct type cmd = | Get | Set of int | Exchange of int | Compare_and_set of int * int | Fetch_and_add of int | Incr | Decr let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Exchange x -> cst1 pp_int "Exchange" par fmt x | Compare_and_set (x, y) -> cst2 pp_int pp_int "Compare_and_set" par fmt x y | Fetch_and_add x -> cst1 pp_int "Fetch_and_add" par fmt x | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt let show_cmd = Util.Pp.to_show pp_cmd type state = int type sut = int Atomic.t let arb_cmd s = let int_gen = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Get; Gen.map (fun i -> Set i) int_gen; Gen.map (fun i -> Exchange i) int_gen; Gen.map (fun i -> Fetch_and_add i) int_gen; Gen.map2 (fun seen v -> Compare_and_set (seen,v)) (Gen.oneof [Gen.return s; int_gen]) int_gen; Gen.return Incr; Gen.return Decr; ]) let init_state = 0 let init_sut () = Atomic.make 0 let cleanup _ = () let next_state c s = match c with | Get -> s | Set i -> i (*if i<>1213 then i else s*) (* an artificial fault *) | Exchange i -> i | Fetch_and_add i -> s+i | Compare_and_set (seen,v) -> if s=seen then v else s | Incr -> s+1 | Decr -> s-1 let precond _ _ = true let run c r = match c with | Get -> Res (int, Atomic.get r) | Set i -> Res (unit, Atomic.set r i) | Exchange i -> Res (int, Atomic.exchange r i) | Fetch_and_add i -> Res (int, Atomic.fetch_and_add r i) | Compare_and_set (seen,v) -> Res (bool, Atomic.compare_and_set r seen v) | Incr -> Res (unit, Atomic.incr r) | Decr -> Res (unit, Atomic.decr r) let postcond c (s : state) res = match c,res with | Get, Res ((Int,_),v) -> v = s (*&& v<>42*) (*an injected bug*) | Set _, Res ((Unit,_),_) -> true | Exchange _, Res ((Int,_),v) -> v = s | Fetch_and_add _, Res ((Int,_),v) -> v = s | Compare_and_set (seen,_), Res ((Bool,_),b) -> b = (s=seen) | Incr, Res ((Unit,_),_) -> true | Decr, Res ((Unit,_),_) -> true | _,_ -> false end module AT_seq = STM_sequential.Make(CConf) module AT_dom = STM_domain.Make(CConf) ;; QCheck_base_runner.run_tests_main (let count = 250 in [AT_seq.agree_test ~count ~name:"STM Atomic test sequential"; AT_dom.agree_test_par ~count ~name:"STM Atomic test parallel";]) multicoretests-0.7/src/bigarray/000077500000000000000000000000001474367232000170455ustar00rootroot00000000000000multicoretests-0.7/src/bigarray/dune000066400000000000000000000005431474367232000177250ustar00rootroot00000000000000;; Test of the Bigarray module of the standard library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/bigarray/lin_tests.ml000066400000000000000000000021071474367232000214030ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Bigarray.Array1] of ints *) (* ********************************************************************** *) module BA1Conf = struct open Bigarray type t = (int, int_elt, c_layout) Array1.t let array_size = 16 let init () = let arr = Array1.create int C_layout array_size in Array1.fill arr 0 ; arr let cleanup _ = () open Lin let int = int_small let api = [ val_ "Bigarray.Array1.size_in_bytes" Array1.size_in_bytes (t @-> returning int); val_ "Bigarray.Array1.get" Array1.get (t @-> int @-> returning_or_exc int); val_ "Bigarray.Array1.set" Array1.set (t @-> int @-> int @-> returning_or_exc unit); val_ "Bigarray.Array1.fill" Array1.fill (t @-> int @-> returning unit); ] end module BA1T = Lin_domain.Make(BA1Conf) let _ = QCheck_base_runner.run_tests_main [ BA1T.stress_test ~count:1000 ~name:"Lin Bigarray.Array1 stress test with Domain"; ] multicoretests-0.7/src/bigarray/stm_tests.ml000066400000000000000000000064451474367232000214350ustar00rootroot00000000000000open QCheck open STM open Bigarray (** parallel STM tests of Big Array *) module BAConf = struct type cmd = | Size_in_bytes | Get of int | Set of int * int (* STM don't support bigarray type for the moment*) (* | Sub of int * int *) | Fill of int let pp_cmd par fmt x = let open Util.Pp in match x with | Size_in_bytes -> cst0 "Size_in_bytes" fmt | Get x -> cst1 pp_int "Get" par fmt x | Set (x, y) -> cst2 pp_int pp_int "Set" par fmt x y | Fill x -> cst1 pp_int "Fill" par fmt x let show_cmd = Util.Pp.to_show pp_cmd type state = int list type sut = (int, int_elt, c_layout) Array1.t let arb_cmd s = let int_gen = Gen.(oneof [small_nat; int_bound (List.length s - 1)]) in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(oneof [ return Size_in_bytes; map (fun i -> Get i) int_gen; map2 (fun i n -> Set (i,n)) int_gen int_gen; (* STM don't support bigarray type for the moment*) (* map2 (fun i len -> Sub (i,len)) int_gen int_gen; *) map (fun n -> Fill n) int_gen; ]) let barray_size = 16 let init_state = List.init barray_size (fun _ -> 0) let next_state n s = match n with | Size_in_bytes -> s | Get _ -> s | Set (i,n) -> List.mapi (fun j n' -> if i=j then n else n') s (* STM don't support bigarray type for the moment*) (* | Sub (_,_) -> s *) | Fill n -> List.map (fun _ -> n) s let init_sut () = let ba = Array1.create int C_layout barray_size in Array1.fill ba 0 ; ba let cleanup _ = () let precond _n _s = true let run n ba = match n with | Size_in_bytes -> Res (STM.int, Array1.size_in_bytes ba) | Get i -> Res (result STM.int exn, protect (Array1.get ba) i) | Set (i,n) -> Res (result unit exn, protect (Array1.set ba i) n) (* STM don't support bigarray type for the moment*) (* | Sub (i,l) -> Res (result (array char) exn, protect (Array.sub a i) l) *) | Fill n -> Res (result unit exn, protect (Array1.fill ba) n) let word_size_in_bytes = Sys.word_size / 8 let postcond n (s:int list) res = match n, res with | Size_in_bytes, Res ((Int,_),r) -> r = word_size_in_bytes * (List.length s) | Get i, Res ((Result (Int,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok (List.nth s i) | Set (i,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok () (* STM don't support bigarray type for the moment*) (* | Sub (i,l), Res ((Result (Array Char,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "Array.sub") else r = Ok (Array.of_list (List.filteri (fun j _ -> i <= j && j <= i+l-1) s)) *) | Fill (_), Res ((Result (Unit,Exn),_), r) -> r = Ok () | _, _ -> false end module BigArraySTM_seq = STM_sequential.Make(BAConf) module BigArraySTM_dom = STM_domain.Make(BAConf) ;; QCheck_base_runner.run_tests_main [ BigArraySTM_seq.agree_test ~count:1000 ~name:"STM BigArray test sequential"; BigArraySTM_dom.neg_agree_test_par ~count:5000 ~name:"STM BigArray test parallel" ] multicoretests-0.7/src/buffer/000077500000000000000000000000001474367232000165165ustar00rootroot00000000000000multicoretests-0.7/src/buffer/dune000066400000000000000000000002771474367232000174020ustar00rootroot00000000000000;; Test of the buffer library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/buffer/stm_tests.ml000066400000000000000000000136001474367232000210750ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Buffer *) (* port from the QCSTM example *) module BConf = struct type cmd = | Contents | To_bytes | Sub of (int * int) (* Blit *) | Nth of int | Length | Clear | Reset | Add_char of char (* Add_utf8_uchar | Add_utf_16le_uchar | Add_utf_16be_uchar *) | Add_string of string | Add_bytes of bytes | Truncate of int let pp_cmd par fmt x = let open Util.Pp in match x with | Contents -> cst0 "Contents" fmt | To_bytes -> cst0 "To_bytes" fmt | Sub x -> cst1 (pp_pair pp_int pp_int) "Sub" par fmt x | Nth x -> cst1 pp_int "Nth" par fmt x | Length -> cst0 "Length" fmt | Clear -> cst0 "Clear" fmt | Reset -> cst0 "Reset" fmt | Add_char x -> cst1 pp_char "Add_char" par fmt x | Add_string x -> cst1 pp_string "Add_string" par fmt x | Add_bytes x -> cst1 pp_bytes "Add_bytes" par fmt x | Truncate x -> cst1 pp_int "Truncate" par fmt x let show_cmd = Util.Pp.to_show pp_cmd type state = char list (* in reverse *) type sut = Buffer.t let _shrink_cmd c = match c with | Add_string s -> Iter.map (fun s -> Add_string s) (Shrink.string s) | _ -> Iter.empty let arb_cmd s = let int_gen,string_gen = Gen.(small_nat,small_string) in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(oneof [return Contents; return To_bytes; map2 (fun off len -> Sub (off, len)) int_gen int_gen; map (fun i -> Nth i) int_gen; return Length; return Clear; return Reset; map (fun c -> Add_char c) char; map (fun s -> Add_string s) string_gen; map (fun b -> Add_bytes (String.to_bytes b)) string_gen; map (fun i -> Truncate i) (let len = List.length s in if len = 0 then return 0 else int_bound (len - 1)); ]) let init_state = [] let rev_explode s = let chars = ref [] in String.iter (fun c -> chars := c::!chars) s; !chars let explode s = List.rev (rev_explode s) let to_string s = List.rev s |> List.map (fun c -> Printf.sprintf "%c" c) |> String.concat "" let next_state c s = match c with | Contents -> s | To_bytes -> s | Sub _ -> s (* sub returns a copy *) | Nth _ -> s | Length -> s | Clear -> [] | Reset -> [] | Add_char ch -> ch::s | Add_string str -> (rev_explode str)@s (*s@(explode str)*) | Add_bytes bytes -> (rev_explode (String.of_bytes bytes))@s | Truncate i -> let rec trunc buf n = match buf,n with | [],0 -> [] | [],_ -> [] | _::_,0 -> [] | c::cs,_ -> c::trunc cs (n-1) in List.rev (trunc (List.rev s) i) let init_sut () = Buffer.create 16 let cleanup b = Buffer.reset b let precond c s = match c with | Truncate i -> i >= 0 && i <= List.length s | _ -> true let run c b = match c with | Contents -> Res (result string exn, protect Buffer.contents b) (* protect from Invalid_argument("String.sub / Bytes.sub") *) | To_bytes -> Res (result bytes exn, protect Buffer.to_bytes b) (* protect from Invalid_argument("String.sub / Bytes.sub") *) | Sub (off, len) -> Res (result string exn, protect (Buffer.sub b off) len) | Nth i -> Res (result char exn, protect (Buffer.nth b) i) | Length -> Res (int, Buffer.length b) | Clear -> Res (result unit exn, protect Buffer.clear b) (* protect from Invalid_argument("String.sub / Bytes.sub") *) | Reset -> Res (result unit exn, protect Buffer.reset b) (* protect from Invalid_argument("String.sub / Bytes.sub") *) | Add_char ch -> Res (result unit exn, protect (Buffer.add_char b) ch) (* protect from assertion failure *) | Add_string str -> Res (result unit exn, protect (Buffer.add_string b) str) (* protect from assertion failure *) | Add_bytes bytes -> Res (result unit exn, protect (Buffer.add_bytes b) bytes) (* protect from assertion failure *) | Truncate i -> Res (result unit exn, protect (Buffer.truncate b) i) let postcond c s res = match c, res with | Contents, Res ((Result (String,Exn),_),Ok str) -> explode str = List.rev s (*| Contents, Res ((String,_),str) -> explode str = List.rev s*) | To_bytes, Res ((Result (Bytes,Exn),_), r) -> r = Ok (Bytes.of_string (to_string s)) | Sub (off, len), Res ((Result (String,Exn),_), str) -> if off > List.length s || off + len > List.length s then str = Error (Invalid_argument "Buffer.sub") else str = Ok (String.sub (to_string s) off len) | Nth i, Res ((Result (Char,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "Buffer.nth") else r = Ok (List.nth (List.rev s) i) | Length, Res ((Int,_),i) -> i = List.length s | Clear, Res ((Result (Unit,Exn),_),r) -> r = Ok () | Reset, Res ((Result (Unit,Exn),_),r) -> r = Ok () | Add_char _, Res ((Result (Unit,Exn),_),r) -> r = Ok () | Add_string _, Res ((Result (Unit,Exn),_),r) -> r = Ok () | Add_bytes _, Res ((Result (Unit,Exn),_),r) -> r = Ok () | Truncate i, Res ((Result (Unit,Exn),_),r) -> if i < 0 || i > List.length s then r = Error (Invalid_argument "Buffer.truncate") else r = Ok () | _, _ -> false end module BufferSTM_seq = STM_sequential.Make(BConf) module BufferSTM_dom = STM_domain.Make(BConf) ;; QCheck_base_runner.run_tests_main (let count = 1000 in [BufferSTM_seq.agree_test ~count ~name:"STM Buffer test sequential"; BufferSTM_dom.neg_agree_test_par ~count ~name:"STM Buffer test parallel"; BufferSTM_dom.stress_test_par ~count ~name:"STM Buffer stress test parallel"]) multicoretests-0.7/src/bytes/000077500000000000000000000000001474367232000163735ustar00rootroot00000000000000multicoretests-0.7/src/bytes/dune000066400000000000000000000005431474367232000172530ustar00rootroot00000000000000;; Tests of the stdlib Bytes library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) multicoretests-0.7/src/bytes/lin_tests.ml000066400000000000000000000070171474367232000207360ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Bytes] *) (* ********************************************************************** *) module BConf = struct type t = Bytes.t let init () = Stdlib.Bytes.make 42 '0' let cleanup _ = () open Lin let int,string = nat_small, string_small_printable let api = [ val_ "Bytes.length" Bytes.length (t @-> returning int); val_ "Bytes.get" Bytes.get (t @-> int @-> returning_or_exc char); val_ "Bytes.set" Bytes.set (t @-> int @-> char @-> returning_or_exc unit); val_ "Bytes.copy" Bytes.copy (t @-> returning bytes); val_ "Bytes.to_string" Bytes.to_string (t @-> returning string); val_ "Bytes.sub" Bytes.sub (t @-> int @-> int @-> returning_or_exc bytes); val_ "Bytes.sub_string" Bytes.sub_string (t @-> int @-> int @-> returning_or_exc string); val_ "Bytes.fill" Bytes.fill (t @-> int @-> int @-> char @-> returning_or_exc unit); val_ "Bytes.blit_string" Bytes.blit_string (string @-> int @-> t @-> int @-> int @-> returning_or_exc unit); val_ "Bytes.index" Bytes.index (t @-> char @-> returning_or_exc int); val_ "Bytes.index_opt" Bytes.index_opt (t @-> char @-> returning (option int)); val_ "Bytes.rindex" Bytes.rindex (t @-> char @-> returning_or_exc int); val_ "Bytes.rindex_opt" Bytes.rindex_opt (t @-> char @-> returning (option int)); val_ "Bytes.index_from" Bytes.index_from (t @-> int @-> char @-> returning_or_exc int); val_ "Bytes.index_from_opt" Bytes.index_from_opt (t @-> int @-> char @-> returning_or_exc (option int)); val_ "Bytes.rindex_from" Bytes.rindex_from (t @-> int @-> char @-> returning_or_exc int); val_ "Bytes.rindex_from_opt" Bytes.rindex_from_opt (t @-> int @-> char @-> returning_or_exc (option int)); val_ "Bytes.contains" Bytes.contains (t @-> char @-> returning_or_exc bool); val_ "Bytes.contains_from" Bytes.contains_from (t @-> int @-> char @-> returning_or_exc bool); val_ "Bytes.rcontains_from" Bytes.rcontains_from (t @-> int @-> char @-> returning_or_exc bool); (* UTF codecs and validations *) val_ "Bytes.is_valid_utf_8" Bytes.is_valid_utf_8 (t @-> returning bool); val_ "Bytes.is_valid_utf_16be" Bytes.is_valid_utf_16be (t @-> returning bool); val_ "Bytes.is_valid_utf_16le" Bytes.is_valid_utf_16le (t @-> returning bool); (* Binary encoding/decoding of integers *) val_ "Bytes.get_uint8" Bytes.get_uint8 (t @-> int @-> returning_or_exc int); val_ "Bytes.get_int8" Bytes.get_int8 (t @-> int @-> returning_or_exc int); val_ "Bytes.set_uint8" Bytes.set_uint8 (t @-> int @-> int @-> returning_or_exc unit); val_ "Bytes.set_int8" Bytes.set_int8 (t @-> int @-> int @-> returning_or_exc unit); ] end module BT_domain = Lin_domain.Make(BConf) module BT_thread = Lin_thread.Make(BConf) [@alert "-experimental"] ;; QCheck_base_runner.run_tests_main [ BT_domain.neg_lin_test ~count:5000 ~name:"Lin Bytes test with Domain"; BT_thread.lin_test ~count:250 ~name:"Lin Bytes test with Thread"; BT_domain.stress_test ~count:1000 ~name:"Lin Bytes stress test with Domain"; ] multicoretests-0.7/src/bytes/stm_tests.ml000066400000000000000000000073241474367232000207600ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Bytes *) module ByConf = struct type cmd = | Length | Get of int | Set of int * char | Sub of int * int | Copy | Fill of int * int * char | To_seq let pp_cmd par fmt x = let open Util.Pp in match x with | Length -> cst0 "Length" fmt | Get x -> cst1 pp_int "Get" par fmt x | Set (x, y) -> cst2 pp_int pp_char "Set" par fmt x y | Sub (x, y) -> cst2 pp_int pp_int "Sub" par fmt x y | Copy -> cst0 "Copy" fmt | Fill (x, y, z) -> cst3 pp_int pp_int pp_char "Fill" par fmt x y z | To_seq -> cst0 "To_seq" fmt let show_cmd = Util.Pp.to_show pp_cmd type state = char list type sut = Bytes.t let arb_cmd s = let int_gen = Gen.(oneof [small_nat; int_bound (List.length s - 1)]) in let char_gen = Gen.printable in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(oneof [ return Length; map (fun i -> Get i) int_gen; map2 (fun i c -> Set (i,c)) int_gen char_gen; map2 (fun i len -> Sub (i,len)) int_gen int_gen; (* hack: reusing int_gen for length *) return Copy; map3 (fun i len c -> Fill (i,len,c)) int_gen int_gen char_gen; (* hack: reusing int_gen for length*) return To_seq; ]) let byte_size = 16 let init_state = List.init byte_size (fun _ -> 'a') let next_state c s = match c with | Length -> s | Get _ -> s | Set (i,c) -> List.mapi (fun j c' -> if i = j then c else c') s | Sub (_,_) -> s | Copy -> s | Fill (i,l,c) -> if i >= 0 && l >= 0 && i+l-1 < (List.length s) then List.mapi (fun j c' -> if i <= j && j <= i+l-1 then c else c') s else s | To_seq -> s let init_sut () = Bytes.make byte_size 'a' let cleanup _ = () let precond c _s = match c with | _ -> true let run c b = match c with | Length -> Res (int, Bytes.length b) | Get i -> Res (result char exn, protect (Bytes.get b) i) | Set (i,c) -> Res (result unit exn, protect (Bytes.set b i) c) | Sub (i,l) -> Res (result (bytes) exn, protect (Bytes.sub b i) l) | Copy -> Res (bytes, Bytes.copy b) | Fill (i,l,c) -> Res (result unit exn, protect (Bytes.fill b i l) c) | To_seq -> Res (seq char, List.to_seq (List.of_seq (Bytes.to_seq b))) let postcond c (s: char list) res = match c, res with | Length, Res ((Int,_),i) -> i = List.length s | Get i, Res ((Result (Char,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok (List.nth s i) | Set (i,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok () | Sub (i,l), Res ((Result (Bytes,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "String.sub / Bytes.sub") else r = Ok (Bytes.of_seq (List.to_seq (List.filteri (fun j _ -> i <= j && j <= i+l-1) s))) | Copy, Res ((Bytes,_),r) -> r = Bytes.of_seq (List.to_seq s) | Fill (i,l,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "String.fill / Bytes.fill" ) else r = Ok () | To_seq, Res ((Seq Char,_),r) -> Seq.equal (=) r (List.to_seq s) | _, _ -> false end module BytesSTM_seq = STM_sequential.Make(ByConf) module BytesSTM_dom = STM_domain.Make(ByConf) ;; QCheck_base_runner.run_tests_main (let count = 1000 in [BytesSTM_seq.agree_test ~count ~name:"STM Bytes test sequential"; BytesSTM_dom.neg_agree_test_par ~count ~name:"STM Bytes test parallel" ]) multicoretests-0.7/src/domain/000077500000000000000000000000001474367232000165145ustar00rootroot00000000000000multicoretests-0.7/src/domain/domain_joingraph.ml000066400000000000000000000140521474367232000223600ustar00rootroot00000000000000(** Generate direct tests of the Domain module's spawn/join primitives. Like [src/domainslib/tast_one_dep.ml]([src/domainslib/tast_one_dep.ml) it does so by generating a random, acyclic dependency graph of [spawn]ed [Domain.t]s each waiting to [join] with its dependency. *) open QCheck (* Generates a sparse DAG of join dependencies *) (* Each domain is represented by an array index w/at most 1 dep. each *) (* This example DAG A/0 <--- B/1 ^. \ `- C/2 <--- D/3 is represented as: [| None; Some 0; Some 0; Some 2 |] Since each domain can only be joined once, A/0 is joined by B/1 (not C/2) *) let gen_deps n st = let a = Array.make n None in for i=1 to n-1 do if Gen.bool st then a.(i) <- Some (Gen.int_bound (i-1) st) done; a (* FIXME: - Make sparsety a random param - not just a bool in gen_deps - negative tests: catch and check expected exception - one domain could join several other domains - all domains are spawned by main - but joined randomly ideally: spawned by random domain and joined by random domain only one domain can spawn (but repeatedly) - this gives rise to a spawn tree only one domain can join on a domain (after creation) - this gives rise to a join tree - or a join forest (if there are un-joined domains *) type test_input = { num_domains : int; dependencies : int option array } let pp_test_input par fmt { num_domains; dependencies } = let open Util.Pp in pp_record par fmt [ pp_field "num_domains" pp_int num_domains; pp_field "dependencies" (pp_array (pp_option pp_int)) dependencies; ] let show_test_input = Util.Pp.to_show pp_test_input (* an older, more ambitious shrinker *) (* let rec shrink_deps i ((len,deps) as pair) = if len = 0 || i>=len then Iter.empty else let front = Array.sub deps 0 i in let back = Array.sub deps (i+1) (len - (i+1)) in let adjust_indices a = (* adjust dependencies for removed entry *) Array.map (function | None -> None | Some j -> if i=j then None else (*old dependency was just removed in shrink candidate *) if j let len = List.length deps in let arr = Array.of_list deps in let deps = Array.mapi (fun i j_opt -> match i,j_opt with | 0, _ | _,None -> None | _,Some 0 -> Some 0 | _, Some j -> if j<0 || j>=len || j>=i (* ensure reduced dep is valid *) then Some ((j + i) mod i) else Some j) arr in { num_domains=len; dependencies=deps }) is let arb_deps domain_bound = let gen_deps = Gen.(int_bound (domain_bound-1) >>= fun num_domains -> let num_domains = succ num_domains in gen_deps num_domains >>= fun dependencies -> return { num_domains; dependencies }) in make ~print:show_test_input ~shrink:shrink_deps gen_deps (*let dom_id id i = Printf.sprintf "(domain %i, index %i)" id i*) let is_first_with_dep i dep deps = [] = List.filteri (fun j opt -> j < i && opt = Some dep) (Array.to_list deps) let build_dep_graph test_input f = let rec build i domain_acc = if i=test_input.num_domains then List.rev domain_acc else let p = (match test_input.dependencies.(i) with | None -> Domain.spawn f | Some dep -> Domain.spawn (fun () -> f(); if is_first_with_dep i dep test_input.dependencies then let p' = List.nth domain_acc (i-1-dep) in (*let src_id = (dom_id (Domain.self () :> int) i) in let tgt_id = (dom_id (Domain.get_id p' :> int) dep) in*) Domain.join p'; (*Printf.printf "graph -- %s joining %s success\n%!" src_id tgt_id*) )) in build (i+1) (p::domain_acc) in build 0 [] (** In this first test each spawned domain calls [work] - and then optionally join. *) (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let work () = for _ = 1 to 100 do assert (7 = tak 18 12 6); done let test_tak_work ~domain_bound = Test.make ~name:"Domain.spawn/join - tak work" ~count:100 (arb_deps domain_bound) ((*Util.fork_prop_with_timeout 30*) (fun test_input -> (*Printf.printf "%s\n%!" (show_test_input test_input);*) let ps = build_dep_graph test_input work in List.iteri (fun i p -> if not (Array.mem (Some i) test_input.dependencies) then Domain.join p) ps; true)) (** In this test each spawned domain calls [Atomic.incr] - and then optionally join. *) let test_atomic_work ~domain_bound = Test.make ~name:"Domain.spawn/join - atomic" ~count:500 (arb_deps domain_bound) (fun test_input -> let a = Atomic.make 0 in let ps = build_dep_graph test_input (fun () -> Atomic.incr a) in List.iteri (fun i p -> if not (Array.mem (Some i) test_input.dependencies) then (*let tgt_id = dom_id (Domain.get_id p :> int) i in*) Domain.join p; (*Printf.printf "main domain %i -- joining %s success\n%!" (Domain.self () :> int) tgt_id*) ) ps; Atomic.get a = test_input.num_domains) let bound_tak = if Sys.word_size == 64 then 100 else 8 let bound_atomic = if Sys.word_size == 64 then 250 else 8 ;; QCheck_base_runner.run_tests_main [test_tak_work ~domain_bound:bound_tak; test_atomic_work ~domain_bound:bound_atomic ] multicoretests-0.7/src/domain/domain_spawntree.ml000066400000000000000000000053071474367232000224120ustar00rootroot00000000000000(** This tests the Domain module's spawn/join primitives. *) (* Idea: generate a series of spawn trees: Spawn / | | \ / | | \ / | | \ Incr Spawn Incr Spawn / | \ | / | \ | / | \ | Incr Incr Incr Decr Each tree is interpreted over Domain: - [Spawn] call [Domain.spawn] for each child - [Incr] and [Decr] call [Atomic.incr] and [Atomic.decr], respectively *) open QCheck type cmd = | Incr | Decr (*| Join*) | Spawn of cmd list let rec pp_cmd par fmt x = let open Util.Pp in match x with | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt | Spawn x -> cst1 (pp_list pp_cmd) "Spawn" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen max_height max_degree = let height_gen = Gen.int_bound max_height in let degree_gen = Gen.int_bound max_degree in Gen.sized_size height_gen @@ Gen.fix (fun rgen n -> match n with | 0 -> Gen.oneofl [Incr;Decr] | _ -> Gen.oneof [ Gen.oneofl [Incr;Decr]; Gen.map (fun ls -> Spawn ls) (Gen.list_size degree_gen (rgen (n-1))) ]) let rec shrink_cmd = function | Incr | Decr -> Iter.empty | Spawn cs -> let open Iter in (return Incr) <+> (map (fun cs' -> Spawn cs') (Shrink.list_elems shrink_cmd cs)) <+> (map (fun cs' -> Spawn cs') (Shrink.list_spine cs)) let rec interp s = function | Incr -> succ s | Decr -> pred s | Spawn cs -> List.fold_left (fun s' c -> interp s' c) s cs let rec dom_interp a = function | Incr -> Atomic.incr a | Decr -> Atomic.decr a | Spawn cs -> let ds = List.map (fun c -> Domain.spawn (fun () -> dom_interp a c)) cs in List.iter Domain.join ds let t ~max_height ~max_degree = Test.make ~name:"domain_spawntree - with Atomic" ~count:100 ~retries:10 (*~print:show_cmd (gen max_height max_degree)*) (make ~print:show_cmd ~shrink:shrink_cmd (gen max_height max_degree)) ((*Util.fork_prop_with_timeout 30*) (* forking a fresh process starts afresh, it seems *) (fun c -> (*Printf.printf "spawns: %i\n%!" (count_spawns c);*) (*Printf.printf "%s\n%!" (show_cmd c);*) try let a = Atomic.make 0 in let () = dom_interp a c in Atomic.get a = interp 0 c with | Failure s -> if s = "failed to allocate domain" then true else (Printf.printf "Failure \"%s\"\n%!" s; false) )) let test = if Sys.word_size == 64 then t ~max_height:5 ~max_degree:10 else t ~max_height:3 ~max_degree:3 ;; QCheck_base_runner.run_tests_main [test] multicoretests-0.7/src/domain/dune000066400000000000000000000014001474367232000173650ustar00rootroot00000000000000;; Tests of the stdlib Domain library ;; Tests of Domain's spawn functionality (non-STM) (test (name domain_joingraph) (modules domain_joingraph) (package multicoretests) (libraries util qcheck-core qcheck-core.runner) (action (run %{test} --verbose)) ) (test (name domain_spawntree) (modules domain_spawntree) (package multicoretests) (libraries util qcheck-core qcheck-core.runner) (action (run %{test} --verbose)) ) (test (name lin_tests_dls) (modules lin_tests_dls) (package multicoretests) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name stm_tests_dls) (modules stm_tests_dls) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/domain/lin_tests_dls.ml000066400000000000000000000021771474367232000217230ustar00rootroot00000000000000open Domain open Lin module DLSConf = struct type t = int DLS.key let init () = DLS.new_key (fun () -> 0) (* without split from parent *) let cleanup _ = () let int = int_small let api = [ val_ "DLS.get" DLS.get (t @-> returning int) ; val_ "DLS.set" DLS.set (t @-> int @-> returning unit) ; ] end module DLSN = Lin_domain.Make (DLSConf) module DLST = Lin_domain.Make (struct include DLSConf let init () = (* get and set will see the parent's key *) DLS.new_key ~split_from_parent:(fun i -> i) (fun () -> 0) end) ;; (* let _ = Domain.join (Domain.spawn (fun () -> QCheck_base_runner.run_tests ~verbose:true [DLSN.neg_lin_test ~count:100 ~name:"Lin Domain.DLS negative test with Domain"])) let _ = Domain.join (Domain.spawn (fun () -> QCheck_base_runner.run_tests ~verbose:true [DLST.lin_test ~count:75 ~name:"Lin Domain.DLS test with Domain"])) *) QCheck_base_runner.run_tests_main [ DLSN.neg_lin_test ~count:100 ~name:"Lin Domain.DLS negative test with Domain"; DLST.lin_test ~count:75 ~name:"Lin Domain.DLS test with Domain"; ] multicoretests-0.7/src/domain/stm_tests_dls.ml000066400000000000000000000057271474367232000217500ustar00rootroot00000000000000open Domain open QCheck open STM (** parallel STM tests of Domain.DLS *) module DLSConf = struct let length = 4 type index = int type cmd = | Get of index | Set of index * int let pp_cmd par fmt x = let open Util.Pp in match x with | Get i -> cst1 pp_int "Get" par fmt i | Set (i,x) -> cst2 pp_int pp_int "Set" par fmt i x let show_cmd = Util.Pp.to_show pp_cmd type state = int list type sut = int Domain.DLS.key list let arb_cmd _s = let index = Gen.int_bound (length-1) in let int_gen = Gen.small_nat in QCheck.make ~print:show_cmd Gen.(oneof [ map (fun i -> Get i) index; map2 (fun i x -> Set (i,x)) index int_gen; ]) let init_state = List.init length (fun i -> i) let next_state n s = match n with | Get _ -> s | Set (i,n) -> List.mapi (fun j x -> if i=j then n else x) s let init_sut () = List.init length (fun i -> DLS.new_key ~split_from_parent:(fun x -> x) (fun () -> i)) let cleanup _ = () let precond n _s = match n with | _ -> true let run n t = match n with | Get i -> Res (STM.int, Domain.DLS.get (List.nth t i)) | Set (i,x) -> Res (unit, Domain.DLS.set (List.nth t i) x) let postcond n (s:int list) res = match n, res with | Get i, Res ((Int,_), r) -> (List.nth s i) = r | Set _, Res ((Unit,_), ()) -> true | _, _ -> false end module DLS_STM_seq = STM_sequential.Make(DLSConf) module DLS_STM_dom = STM_domain.Make(DLSConf) (* Run seq. property in a child domain to have a clean DLS for each iteration *) let agree_prop cs = Domain.spawn (fun () -> DLS_STM_seq.agree_prop cs) |> Domain.join (* Run domain property in a child domain to have a clean DLS for each iteration *) let agree_prop_par t = Domain.spawn (fun () -> DLS_STM_dom.agree_prop_par t) |> Domain.join (* Run stress property in a child domain to have a clean DLS for each iteration *) let stress_prop_par t = Domain.spawn (fun () -> DLS_STM_dom.stress_prop_par t) |> Domain.join let agree_test ~count ~name = Test.make ~name ~count (DLS_STM_seq.arb_cmds DLSConf.init_state) agree_prop let neg_agree_test_par ~count ~name = let seq_len,par_len = 20,12 in Test.make_neg ~retries:10 ~count ~name (DLS_STM_dom.arb_cmds_triple seq_len par_len) (fun triple -> assume (DLS_STM_dom.all_interleavings_ok triple); agree_prop_par triple) (* just repeat 1 * 10 times when shrinking *) let stress_test_par ~count ~name = let seq_len,par_len = 20,12 in Test.make ~retries:10 ~count ~name (DLS_STM_dom.arb_cmds_triple seq_len par_len) (fun triple -> assume (DLS_STM_dom.all_interleavings_ok triple); stress_prop_par triple) (* just repeat 1 * 10 times when shrinking *) ;; ;; QCheck_base_runner.run_tests_main [ agree_test ~count:1000 ~name:"STM Domain.DLS test sequential"; neg_agree_test_par ~count:1000 ~name:"STM Domain.DLS test parallel"; stress_test_par ~count:1000 ~name:"STM Domain.DLS stress test parallel"; ] multicoretests-0.7/src/dynarray/000077500000000000000000000000001474367232000170765ustar00rootroot00000000000000multicoretests-0.7/src/dynarray/dune000066400000000000000000000021531474367232000177550ustar00rootroot00000000000000(* -*- tuareg -*- *) (* We generate an appropriate dune stanza to avoid Dynarray tests build failures on 5.0 and 5.1 with the opam-less CI GitHub action setup *) (* Use ocaml_version instead of ocaml_release (from 4.14) to support 4.12 opam install *) let ocaml_version_pair = let (major,minor) = match String.split_on_char '.' Sys.ocaml_version with | major::minor::_ -> (major,minor) | _ -> failwith "Unable to extract OCaml version" in try (int_of_string major, int_of_string minor) with Failure _ -> failwith "Failed to parse OCaml version" let dune = if ocaml_version_pair >= (5,2) then Printf.sprintf {| (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %%{test} --verbose)) ) (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %%{test} --verbose)) ) |} else Printf.sprintf {| (rule (alias runtest) (package multicoretests) (action (echo "Dynarray tests disabled as Dynarray is not available\n"))) |} let () = Jbuild_plugin.V1.send dune multicoretests-0.7/src/dynarray/lin_tests.ml000066400000000000000000000035571474367232000214460ustar00rootroot00000000000000module Dynarray_api = struct type t = int Dynarray.t let init () = Dynarray.make 1024 0xcafe let cleanup _ = () open Lin type elem = int [@@warning "-34"] let elem = nat_small let int = nat_small let get_check a i = let v = Dynarray.get a i in if not (Obj.is_int (Obj.repr v)) then (Printf.eprintf "dummy found!\n%!"; exit 1) else v let api = (*let int_not_too_big = int_bound 2048 in*) [ val_ "get_check" get_check (t @-> int @-> returning_or_exc elem); val_ "set" Dynarray.set (t @-> int @-> elem @-> returning_or_exc unit); val_ "length" Dynarray.length (t @-> returning int); val_freq 3 "add_last" Dynarray.add_last (t @-> elem @-> returning_or_exc unit); val_ "append_seq" Dynarray.append_seq (t @-> seq_small elem @-> returning_or_exc unit); val_ "get_last" Dynarray.get_last (t @-> returning_or_exc elem); val_ "pop_last" Dynarray.pop_last (t @-> returning_or_exc elem); val_freq 2 "remove_last" Dynarray.remove_last (t @-> returning_or_exc unit); val_ "clear" Dynarray.clear (t @-> returning_or_exc unit); val_ "truncate" Dynarray.truncate (t @-> int @-> returning_or_exc unit); val_ "ensure_capacity" Dynarray.ensure_capacity (t @-> int @-> returning_or_exc unit); val_ "fit_capacity" Dynarray.fit_capacity (t @-> returning_or_exc unit); (*val_ "blit" Dynarray.blit (t @-> int_not_too_big @-> t @-> int_not_too_big @-> int_not_too_big @-> returning_or_exc unit);*) val_freq 2 "set_capacity" Dynarray.set_capacity (t @-> int @-> returning_or_exc unit); val_ "reset" Dynarray.reset (t @-> returning_or_exc unit); ] end module DAT = Lin_domain.Make (Dynarray_api) let () = QCheck_base_runner.run_tests_main [ DAT.neg_lin_test ~count:1000 ~name:"Lin Dynarray test with Domain"; DAT.stress_test ~count:1000 ~name:"Lin Dynarray stress test with Domain"; ] multicoretests-0.7/src/dynarray/stm_tests.ml000066400000000000000000000720211474367232000214570ustar00rootroot00000000000000open QCheck open STM module type Elem = sig type t val arb : t QCheck.arbitrary val pp : Format.formatter -> t -> unit val show : t -> string val equal : t -> t -> bool val init_state : t list list val mapping_fun : t -> t val mapping_fun_with_index : int -> t -> t val folding_fun : t -> t -> t val pred : t -> bool val filter_mapping_fun : t -> t option end module Dynarray_spec (Elem : Elem) = struct type elem = Elem.t type _ ty += Elem : elem ty let elem : elem ty_show = Elem, Elem.show (* We are plucking from a pool of Dynarrays. New arrays can be added to the pool, sometimes arrays can be removed. *) type sut = elem Dynarray.t list ref let init_sut () = ref (List.map Dynarray.of_list Elem.init_state) let cleanup _ = () let add_array arr sut = sut := arr :: !sut type idx = I of int [@@unboxed] let equal_idx (I i1) (I i2) = Int.equal i1 i2 type cmd = | Create | Make of int * elem | Get of idx * int | Set of idx * int * elem | Length of idx | Is_empty of idx | Get_last of idx | Find_last of idx | Copy of idx | Add_last of idx * elem | Append_array of idx * elem array | Append_list of idx * elem list | Append of idx * idx | Append_seq of idx * elem array | Append_iter of idx * elem array | Pop_last_opt of idx | Remove_last of idx | Truncate of idx * int | Clear of idx | Iter of idx (* Allocate a short-lived cell for each element *) | Iteri of idx (* Allocate a short-lived cell for each element *) | Map of idx (* Negate all elements *) | Mapi of idx (* Add indices and elements *) | Fold_left of elem * idx (* Sum over elements *) | Fold_right of idx * elem (* Sum over elements *) | Exists of idx (* Predicate: (=) 0. *) | For_all of idx (* Predicate: (=) 0. *) | Filter of idx (* Predicate: (=) 0. *) | Filter_map of idx (* f: fun x -> if x < 0 then Some (-.x) else None *) | Of_array of elem array | To_array of idx | Of_list of elem list | To_list of idx | Of_seq of elem array | To_seq of idx (* The produced sequence is turned into a list immediately, see [run]. *) | To_seq_reentrant of idx | To_seq_rev of idx | To_seq_rev_reentrant of idx | Capacity of idx | Ensure_capacity of idx * int | Ensure_extra_capacity of idx * int | Fit_capacity of idx | Set_capacity of idx * int | Reset of idx let show_cmd : cmd -> string = let open Format in function | Create -> "create" | Make (l, x) -> asprintf "make (%d, %a)" l Elem.pp x | Get (I arr_idx, elem_idx) -> sprintf "get (a%d, %d)" arr_idx elem_idx | Set (I arr_idx, elem_idx, x) -> asprintf "set (a%d, %d, %a)" arr_idx elem_idx Elem.pp x | Is_empty (I arr_idx) -> sprintf "is_empty a%d" arr_idx | Length (I arr_idx) -> sprintf "length a%d" arr_idx | Get_last (I arr_idx) -> sprintf "get_last a%d" arr_idx | Find_last (I idx) -> sprintf "find_last a%d" idx | Copy (I idx) -> sprintf "copy a%d" idx | Add_last (I idx, x) -> asprintf "add_last (a%d, %a)" idx Elem.pp x | Append_array (I idx, arr) -> asprintf "append_array (a%d, @[[| %a |]@])" idx (pp_print_array ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) arr | Append_list (I idx, l) -> asprintf "append_list (a%d, @[[ %a ]@])" idx (pp_print_list ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) l | Append (I arr_i1, I arr_i2) -> sprintf "append (a%d, a%d)" arr_i1 arr_i2 | Append_seq (I idx, arr) -> asprintf "append_seq (a%d, @[[ %a ]@])" idx (pp_print_array ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) arr | Append_iter (I idx, arr) -> asprintf "append_iter (a%d, @[[| %a |]@])" idx (pp_print_array ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) arr | Pop_last_opt (I idx) -> sprintf "pop_last_opt a%d" idx | Remove_last (I arr_idx) -> sprintf "remove_last a%d" arr_idx | Truncate (I arr_idx, len) -> sprintf "truncate (a%d, %d)" arr_idx len | Clear (I arr_i) -> sprintf "clear a%d" arr_i | Iter (I i) -> sprintf "iter a%d" i | Iteri (I i) -> sprintf "iteri a%d" i | Map (I i) -> sprintf "map a%d" i | Mapi (I i) -> sprintf "mapi a%d" i | Fold_left (init, I i) -> asprintf "fold_left (%a, a%d)" Elem.pp init i | Fold_right (I i, init) -> asprintf "fold_right (a%d, %a)" i Elem.pp init | Exists (I i) -> sprintf "exists a%d" i | For_all (I i) -> sprintf "for_all a%d" i | Filter (I i) -> sprintf "filter a%d" i | Filter_map (I i) -> sprintf "filter_map a%d" i | Of_array arr -> asprintf "of_array @[[| %a |]@]" (pp_print_array ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) arr | To_array (I i) -> sprintf "to_array a%d" i | Of_list l -> asprintf "of_list @[[ %a ]@]" (pp_print_list ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) l | To_list (I i) -> sprintf "to_list a%d" i | Of_seq arr -> asprintf "of_seq @[[| %a |]@]" (pp_print_array ~pp_sep:(fun f () -> fprintf f ";@ ") Elem.pp) arr | To_seq (I i) -> sprintf "to_seq a%d" i | To_seq_reentrant (I i) -> sprintf "to_seq_reentrant a%d" i | To_seq_rev (I i) -> sprintf "to_seq_rev a%d" i | To_seq_rev_reentrant (I i) -> sprintf "to_seq_rev_reentrant a%d" i | Capacity (I i) -> sprintf "capacity a%d" i | Ensure_capacity (I arr_idx, n) -> sprintf "ensure_capacity (a%d, %d)" arr_idx n | Ensure_extra_capacity (I arr_idx, n) -> sprintf "ensure_extra_capacity (a%d, %d)" arr_idx n | Fit_capacity (I arr_idx) -> sprintf "fit_capacity a%d" arr_idx | Set_capacity (I arr_idx, n) -> sprintf "set_capacity (a%d, %d)" arr_idx n | Reset (I arr_idx) -> sprintf "reset a%d" arr_idx type state = elem list list let shrink_cmd c = match c with | Append_array (i,a) -> Iter.map (fun a -> Append_array (i,a)) (Shrink.array a) | Append_list (i,l) -> Iter.map (fun l -> Append_list (i,l)) (Shrink.list l) | Append_seq (i,a) -> Iter.map (fun a -> Append_seq (i,a)) (Shrink.array a) | Append_iter (i,a) -> Iter.map (fun a -> Append_iter (i,a)) (Shrink.array a) | Of_array a -> Iter.map (fun a -> Of_array a) (Shrink.array a) | Of_list l -> Iter.map (fun l -> Of_list l) (Shrink.list l) | Of_seq a -> Iter.map (fun a -> Of_seq a) (Shrink.array a) | _ -> Iter.empty let arb_cmd state : cmd QCheck.arbitrary = let open Gen in let arr_idx state = map (fun i -> I i) (int_bound (List.length state - 1)) in let elem = Elem.arb.gen in let array elm_gen = Gen.array_size small_nat elm_gen in let list elm_gen = Gen.list_size small_nat elm_gen in QCheck.make ~print:show_cmd ~shrink:shrink_cmd (frequency [ 5, return Create; 5, map2 (fun l x -> Make (l, x)) small_nat elem; 50, map2 (fun arr_idx elem_idx -> Get (arr_idx, elem_idx)) (arr_idx state) small_nat; 50, map3 (fun arr_idx elem_idx x -> Set (arr_idx, elem_idx, x)) (arr_idx state) small_nat elem; 50, map (fun i -> Is_empty i) (arr_idx state); 50, map (fun i -> Length i) (arr_idx state); 50, map (fun i -> Get_last i) (arr_idx state); 50, map (fun i -> Find_last i) (arr_idx state); 5, map (fun i -> Copy i) (arr_idx state); 50, map2 (fun arr_i x -> Add_last (arr_i, x)) (arr_idx state) elem; 33, map2 (fun arr_i arr -> Append_array (arr_i, arr)) (arr_idx state) (array elem); 33, map2 (fun arr_i l -> Append_list (arr_i, l)) (arr_idx state) (list elem); 33, map2 (fun arr_i1 arr_i2 -> Append (arr_i1, arr_i2)) (arr_idx state) (arr_idx state); 33, map2 (fun arr_i arr -> Append_seq (arr_i, arr)) (arr_idx state) (array elem); 33, map2 (fun arr_i arr -> Append_iter (arr_i, arr)) (arr_idx state) (array elem); 50, map (fun arr_i -> Pop_last_opt arr_i) (arr_idx state); 50, map (fun arr_i -> Remove_last arr_i) (arr_idx state); 50, map2 (fun arr_i len -> Truncate (arr_i, len)) (arr_idx state) nat; 50, map (fun arr_i -> Clear arr_i) (arr_idx state); 5, map (fun i -> Iter i) (arr_idx state); 5, map (fun i -> Iteri i) (arr_idx state); 5, map (fun i -> Map i) (arr_idx state); 5, map (fun i -> Mapi i) (arr_idx state); 5, map2 (fun init i -> Fold_left (init, i)) elem (arr_idx state); 5, map2 (fun i init -> Fold_right (i, init)) (arr_idx state) elem; 50, map (fun i -> Exists i) (arr_idx state); 50, map (fun i -> For_all i) (arr_idx state); 5, map (fun i -> Filter i) (arr_idx state); 5, map (fun i -> Filter_map i) (arr_idx state); 5, map (fun arr -> Of_array arr) (array elem); 10, map (fun i -> To_array i) (arr_idx state); 5, map (fun l -> Of_list l) (list elem); 10, map (fun i -> To_list i) (arr_idx state); 5, map (fun arr -> Of_seq arr) (array elem); 50, map (fun i -> To_seq i) (arr_idx state); 50, map (fun i -> To_seq_reentrant i) (arr_idx state); 50, map (fun i -> To_seq_rev i) (arr_idx state); 50, map (fun i -> To_seq_rev_reentrant i) (arr_idx state); 50, map (fun i -> Capacity i) (arr_idx state); 50, map2 (fun i cap -> Ensure_capacity (i, cap)) (arr_idx state) nat; 50, map2 (fun i extra_cap -> Ensure_extra_capacity (i, extra_cap)) (arr_idx state) small_nat; 50, map (fun i -> Fit_capacity i) (arr_idx state); 50, map2 (fun arr_i cap -> Set_capacity (arr_i, cap)) (arr_idx state) nat; 33, map (fun arr_i -> Reset arr_i) (arr_idx state); ]) let run cmd sut = let nth sut (I idx) = List.nth !sut idx in match cmd with | Create -> Res (unit, add_array (Dynarray.create ()) sut) | Make (l, x) -> Res (unit, add_array (Dynarray.make l x) sut) | Get (arr_i, elem_i) -> Res (result elem exn, protect (fun () -> Dynarray.get (nth sut arr_i) elem_i) ()) | Set (arr_i, elem_i, x) -> Res (result unit exn, protect (fun () -> Dynarray.set (nth sut arr_i) elem_i x) ()) | Length arr_i -> Res (result int exn, protect (fun () -> Dynarray.length (nth sut arr_i)) ()) | Is_empty arr_i -> Res (result bool exn, protect (fun () -> Dynarray.is_empty (nth sut arr_i)) ()) | Get_last arr_i -> Res (result elem exn, protect (fun () -> Dynarray.get_last (nth sut arr_i)) ()) | Find_last arr_i -> Res (result (option elem) exn, protect (fun () -> Dynarray.find_last (nth sut arr_i)) ()) | Copy arr_i -> Res (result unit exn, protect (fun () -> add_array (Dynarray.copy (nth sut arr_i)) sut) ()) | Add_last (arr_i, x) -> Res (result unit exn, protect (fun () -> Dynarray.add_last (nth sut arr_i) x) ()) | Append_array (arr_i, arr) -> Res (result unit exn, protect (fun () -> Dynarray.append_array (nth sut arr_i) arr) ()) | Append_list (arr_i, l) -> Res (result unit exn, protect (fun () -> Dynarray.append_list (nth sut arr_i) l) ()) | Append (arr_i1, arr_i2) -> Res (result unit exn, protect (fun () -> Dynarray.append (nth sut arr_i1) (nth sut arr_i2)) ()) | Append_seq (arr_i, arr) -> Res (result unit exn, protect (fun () -> Dynarray.append_seq (nth sut arr_i) (Array.to_seq arr)) ()) | Append_iter (arr_i, arr) -> Res (result unit exn, protect (fun () -> Dynarray.append_iter (nth sut arr_i) Array.iter arr) ()) | Pop_last_opt arr_i -> Res (result (option elem) exn, protect (fun () -> Dynarray.pop_last_opt (nth sut arr_i)) ()) | Remove_last arr_i -> Res (result unit exn, protect (fun () -> Dynarray.remove_last (nth sut arr_i)) ()) | Truncate (arr_i, len) -> Res (result unit exn, protect (fun () -> Dynarray.truncate (nth sut arr_i) len) ()) | Clear arr_i -> Res (result unit exn, protect (fun () -> Dynarray.clear (nth sut arr_i)) ()) | Iter i -> Res (result unit exn, protect (fun () -> Dynarray.iter (fun x -> ignore @@ Sys.opaque_identity (ref x)) (nth sut i)) ()) | Iteri i -> Res (result unit exn, protect (fun () -> Dynarray.iteri (fun i x -> ignore @@ Sys.opaque_identity (i, x)) (nth sut i)) ()) | Map i -> Res (result unit exn, protect (fun () -> add_array (Dynarray.map Elem.mapping_fun (nth sut i)) sut) ()) | Mapi i -> Res (result unit exn, protect (fun () -> add_array (Dynarray.mapi Elem.mapping_fun_with_index (nth sut i)) sut) ()) | Fold_left (init, i) -> Res (result elem exn, protect (fun () -> Dynarray.fold_left Elem.folding_fun init (nth sut i)) ()) | Fold_right (i, init) -> Res (result elem exn, protect (fun () -> Dynarray.fold_right Elem.folding_fun (nth sut i) init) ()) | Exists i -> Res (result bool exn, protect (fun () -> Dynarray.exists Elem.pred (nth sut i)) ()) | For_all i -> Res (result bool exn, protect (fun () -> Dynarray.for_all Elem.pred (nth sut i)) ()) | Filter i -> Res (result unit exn, protect (fun () -> add_array (Dynarray.filter Elem.pred (nth sut i)) sut) ()) | Filter_map i -> Res (result unit exn, protect (fun () -> add_array (Dynarray.filter_map Elem.filter_mapping_fun (nth sut i)) sut) ()) | Of_array arr -> Res (unit, add_array (Dynarray.of_array arr) sut) | To_array i -> Res (result (array elem) exn, protect (fun () -> Dynarray.to_array (nth sut i)) ()) | Of_list l -> Res (unit, add_array (Dynarray.of_list l) sut) | To_list i -> Res (result (list elem) exn, protect (fun () -> Dynarray.to_list (nth sut i)) ()) | Of_seq arr -> Res (unit, add_array (Dynarray.of_seq (Array.to_seq arr)) sut) | To_seq i -> (* Evaluate the sequence immediately and store it as a list, otherwise sequence is lazily produced and later mutating operations can cause exceptions that are hard to model, even in a sequential setting. *) Res (result (list elem) exn, protect (fun () -> Dynarray.to_seq (nth sut i) |> List.of_seq) ()) | To_seq_reentrant i -> Res (result (list elem) exn, protect (fun () -> Dynarray.to_seq_reentrant (nth sut i) |> List.of_seq) ()) | To_seq_rev i -> Res (result (list elem) exn, protect (fun () -> Dynarray.to_seq_rev (nth sut i) |> List.of_seq) ()) | To_seq_rev_reentrant i -> Res (result (list elem) exn, protect (fun () -> Dynarray.to_seq_rev_reentrant (nth sut i) |> List.of_seq) ()) | Capacity i -> Res (result int exn, protect (fun () -> Dynarray.capacity (nth sut i)) ()) | Ensure_capacity (arr_i, cap) -> Res (result unit exn, protect (fun () -> Dynarray.ensure_capacity (nth sut arr_i) cap) ()) | Ensure_extra_capacity (arr_i, extra_cap) -> Res (result unit exn, protect (fun () -> Dynarray.ensure_extra_capacity (nth sut arr_i) extra_cap) ()) | Fit_capacity arr_i -> Res (result unit exn, protect (fun () -> Dynarray.fit_capacity (nth sut arr_i)) ()) | Set_capacity (arr_i, cap) -> Res (result unit exn, protect (fun () -> Dynarray.set_capacity (nth sut arr_i) cap) ()) | Reset arr_i -> Res (result unit exn, protect (fun () -> Dynarray.reset (nth sut arr_i)) ()) let init_state = Elem.init_state module List = struct include List let[@tail_mod_cons] rec take n = function | [] -> [] | _ :: _ when n <= 0 -> [] | x :: xs -> x :: take (n - 1) xs end let get_model (I arr_i) state = List.nth state arr_i let update_model (I arr_i) f state = List.mapi (fun i arr -> if i = arr_i then f arr else arr) state let next_state cmd state = match cmd with | Create -> [] :: state | Make (l, x) -> List.init l (Fun.const x) :: state | Get _ -> state | Set (arr_i, elem_i, x) -> update_model arr_i (fun arr -> List.mapi (fun i y -> if i = elem_i then x else y) arr) state | Length _ | Is_empty _ | Get_last _ | Find_last _ | To_array _ | To_list _ | To_seq _ -> state | Copy arr_i -> get_model arr_i state :: state | Add_last (arr_i, x) -> update_model arr_i (fun arr -> arr @ [ x ]) state | Append_array (arr_i, arr') -> update_model arr_i (fun arr -> arr @ Array.to_list arr') state | Append_list (arr_i, l) -> update_model arr_i (fun arr -> arr @ l) state | Append (arr_i1, arr_i2) -> (* "Warning: append a a is a programming error because it iterates on a and adds elements to it at the same time [...] It fails with Invalid_argument." *) update_model arr_i1 (fun arr -> arr @ get_model arr_i2 state) state (* In practice: Invalid_argument "Dynarray.append: a length change from 3 to 6 occurred during iteration" and the state change happens *) | Append_seq (arr_i, arr') -> update_model arr_i (fun arr -> arr @ Array.to_list arr') state | Append_iter (arr_i, arr') -> update_model arr_i (fun arr -> arr @ Array.to_list arr') state | Pop_last_opt arr_i -> update_model arr_i (fun arr -> List.take (List.length arr - 1) arr) state | Remove_last arr_i -> update_model arr_i (fun arr -> List.take (List.length arr - 1) arr) state | Truncate (arr_i, len) -> update_model arr_i (List.take len) state | Clear arr_i -> update_model arr_i (Fun.const []) state | Iter _ | Iteri _ -> state | Map i -> List.map Elem.mapping_fun (get_model i state) :: state | Mapi i -> List.mapi Elem.mapping_fun_with_index (get_model i state) :: state | Fold_left _ | Fold_right _ | Exists _ | For_all _ -> state | Filter i -> List.filter Elem.pred (get_model i state) :: state | Filter_map i -> List.filter_map Elem.filter_mapping_fun (get_model i state) :: state | Of_array arr -> Array.to_list arr :: state | Of_list l -> l :: state | Of_seq arr -> Array.to_list arr :: state | To_seq_reentrant _ | To_seq_rev _ | To_seq_rev_reentrant _ | Capacity _ -> state | Ensure_capacity _ | Ensure_extra_capacity _ | Fit_capacity _ -> state | Set_capacity (arr_i, cap) -> update_model arr_i (fun arr -> List.take cap arr) state | Reset arr_i -> update_model arr_i (Fun.const []) state let valid_arr_idx (I idx) state = idx < List.length state let precond cmd state = match cmd with | Create | Make (_,_) -> true | Get (idx,_) | Set (idx,_,_) | Length idx | Is_empty idx | Get_last idx | Find_last idx | Copy idx | Add_last (idx,_) | Append_array (idx, _) | Append_list (idx, _) -> valid_arr_idx idx state | Append (idx, idx2) -> valid_arr_idx idx state && valid_arr_idx idx2 state | Append_seq (idx, _) | Append_iter (idx, _) | Pop_last_opt idx | Remove_last idx | Truncate (idx, _) | Clear idx | Iter idx | Iteri idx | Map idx | Mapi idx | Fold_left (_,idx) | Fold_right (idx,_) | Exists idx | For_all idx | Filter idx | Filter_map idx -> valid_arr_idx idx state | Of_array _ -> true | To_array idx -> valid_arr_idx idx state | Of_list _ -> true | To_list idx -> valid_arr_idx idx state | Of_seq _ -> true | To_seq idx | To_seq_reentrant idx | To_seq_rev idx | To_seq_rev_reentrant idx | Capacity idx | Ensure_capacity (idx, _) | Ensure_extra_capacity (idx, _) | Fit_capacity idx | Set_capacity (idx, _) | Reset idx -> valid_arr_idx idx state let postcond : cmd -> state -> res -> bool = fun cmd state res -> match cmd, res with | Create, _ | Make _, _ -> true | Copy i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Add_last (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Append_array (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Append_list (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Append (i,j), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && valid_arr_idx j state && (match res with | Ok () -> true | Error (Invalid_argument _) -> equal_idx i j | Error _ -> false) | Append_seq (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Append_iter (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Remove_last i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Truncate (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Clear i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Iter i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Iteri i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Map i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Mapi i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Filter i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Filter_map i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Of_array _, _ | Of_list _, _ | Of_seq _, _ -> true | Ensure_capacity (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Ensure_extra_capacity (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Fit_capacity i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Set_capacity (i,_), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Reset i, Res ((Result (Unit, Exn), _), res) -> valid_arr_idx i state && res = Ok () | Get (arr_i, elem_i), Res ((Result (Elem, Exn), _), res) -> (match valid_arr_idx arr_i state, res with | true, Ok r -> let arr = get_model arr_i state in elem_i < List.length arr && let mres = List.nth arr elem_i in Elem.equal r mres | true, Error (Invalid_argument _) -> elem_i < 0 || elem_i >= List.length (get_model arr_i state) | false, Error (Failure msg) -> msg = "nth" | _,_ -> false) | Set (arr_i, elem_i, _), Res ((Result (Unit, Exn), _), res) -> valid_arr_idx arr_i state && ( let arr = get_model arr_i state in (match res with | Ok () -> 0 <= elem_i && elem_i < List.length arr | Error (Invalid_argument _) -> elem_i < 0 || elem_i >= List.length arr | Error _ -> false) ) | Length arr_i, Res ((Result (Int, Exn), _), res) -> valid_arr_idx arr_i state && (match res with | Ok l -> l = List.length (get_model arr_i state) | Error _ -> false) | Is_empty idx, Res ((Result (Bool, Exn), _), res) -> valid_arr_idx idx state && (match res with | Ok res -> Bool.equal res (List.is_empty (get_model idx state)) | Error _ -> false) | Get_last idx, Res ((Result (Elem, Exn), _), res) -> valid_arr_idx idx state && (let arr = get_model idx state in match List.length arr, res with | 0, Error (Invalid_argument _) -> true | length, Ok res -> length > 0 && Elem.equal res (List.nth arr (length - 1)) | _, Error _ -> false (* Unexpected exception type *)) | (Pop_last_opt idx | Find_last idx), Res ((Result (Option Elem, Exn), _), res) -> valid_arr_idx idx state && (let arr = get_model idx state in match List.length arr, res with | 0, Ok None -> true | length, Ok (Some res) when length > 0 -> Elem.equal res (List.nth arr (length - 1)) | 0, Ok (Some _) (* unexpected [Some _] *) | _, Ok None (* unexpected [None] *) | _, Error _ -> false | _, _ -> assert false (* length < 0: impossible *)) | Fold_left (init, i), Res ((Result (Elem, Exn),_), res) -> valid_arr_idx i state && (match res with | Ok res -> Elem.equal res (List.fold_left Elem.folding_fun init (get_model i state)) | Error _ -> false) | Fold_right (i, init), Res ((Result (Elem, Exn),_), res) -> valid_arr_idx i state && (match res with | Ok res -> Elem.equal res (List.fold_right Elem.folding_fun (get_model i state) init) | Error _ -> false) | Exists i, Res ((Result (Bool, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok res -> Bool.equal res (List.exists Elem.pred (get_model i state)) | Error _ -> false) | For_all i, Res ((Result (Bool, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok res -> Bool.equal res (List.for_all Elem.pred (get_model i state)) | Error _ -> false) | To_array i, Res ((Result (Array Elem, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok arr -> let arr' = get_model i state in (try Array.for_all2 Elem.equal arr (Array.of_list arr') with Invalid_argument _ -> false) | Error _ -> false) | To_list i, Res ((Result (List Elem, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok l -> let arr = get_model i state in (try List.for_all2 Elem.equal arr l with Invalid_argument _ -> false) | Error _ -> false) | To_seq i, Res ((Result (List Elem, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok seq -> let arr = get_model i state in (try List.for_all2 Elem.equal seq arr with Invalid_argument _ -> false) | Error _ -> false) | To_seq_reentrant i, Res ((Result (List Elem, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok seq -> let arr = get_model i state in (try List.for_all2 Elem.equal seq arr with Invalid_argument _ -> false) | Error _ -> false) | To_seq_rev i, Res ((Result (List Elem, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok seq -> let arr = get_model i state in (try List.for_all2 Elem.equal seq (List.rev arr) with Invalid_argument _ -> false) | Error _ -> false) | To_seq_rev_reentrant i, Res ((Result (List Elem, Exn), _), res) -> valid_arr_idx i state && (match res with | Ok seq -> let arr = get_model i state in (try List.for_all2 Elem.equal seq (List.rev arr) with Invalid_argument _ -> false) | Error _ -> false) | Capacity i, Res ((Result (Int, Exn), _), res) -> (* The model here does not contain an actual notion of capacity, so only check that the result is greater than the actual length. *) valid_arr_idx i state && (match res with | Ok cap -> cap >= List.length (get_model i state) | Error _ -> false) | _ -> assert false end module Int : Elem = struct type t = int let arb = QCheck.small_int let pp = Format.pp_print_int let equal = Int.equal let show = snd STM.int let init_state = [ [ 1; 2; 3 ]; List.init 12 Fun.id ] let mapping_fun = (~-) let mapping_fun_with_index i x = i + x let folding_fun = (+) let pred x = Int.equal 0 x let filter_mapping_fun x = if Int.compare x 0 < 0 then Some (-x) else None end module Float : Elem = struct type t = float let arb = QCheck.float let pp = Format.pp_print_float let equal = Float.equal let show = snd STM.float let init_state = [ [ 1.; 2.; 3. ]; List.init 12 Float.of_int ] let mapping_fun = (~-.) let mapping_fun_with_index i x = Float.of_int i +. x let folding_fun = (+.) let pred x = Float.equal 0. x let filter_mapping_fun x = if Float.compare x 0. < 0 then Some (-.x) else None end module Test_sequential = struct module Int = STM_sequential.Make (Dynarray_spec (Int)) module Float = STM_sequential.Make (Dynarray_spec (Float)) end module Test_domain = struct module Int = STM_domain.Make (Dynarray_spec (Int)) module Float = STM_domain.Make (Dynarray_spec (Float)) end let () = QCheck_base_runner.run_tests_main [ Test_sequential.Int.agree_test ~count:1_000 ~name:"STM Dynarray test sequential agreement (int)"; Test_domain.Int.neg_agree_test_par ~count:1_000 ~name:"STM Dynarray test parallel (int)"; Test_domain.Int.stress_test_par ~count:1_000 ~name:"STM Dynarray stress test (int)"; Test_sequential.Float.agree_test ~count:1_000 ~name:"STM Dynarray test sequential agreement (float)"; Test_domain.Float.neg_agree_test_par ~count:1_000 ~name:"STM Dynarray test parallel (float)"; Test_domain.Float.stress_test_par ~count:1_000 ~name:"STM Dynarray stress test (float)"; ] multicoretests-0.7/src/dynlink/000077500000000000000000000000001474367232000167155ustar00rootroot00000000000000multicoretests-0.7/src/dynlink/dune000066400000000000000000000004451474367232000175760ustar00rootroot00000000000000;; Test of the Dynlink module of the standard library (library (name libA) (modules libA) ) (library (name libB) (modules libB) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain dynlink libA libB) (action (run %{test} --verbose)) ) multicoretests-0.7/src/dynlink/libA.ml000066400000000000000000000000171474367232000201140ustar00rootroot00000000000000let value = 12 multicoretests-0.7/src/dynlink/libB.ml000066400000000000000000000000171474367232000201150ustar00rootroot00000000000000let value = 34 multicoretests-0.7/src/dynlink/lin_tests.ml000066400000000000000000000025221474367232000212540ustar00rootroot00000000000000(* ************************************ *) (* Tests of Dynlink *) (* ************************************ *) open Lin (* Two libraries that should exist, one that should not *) let library_name = QCheck.Gen.oneofl ["libA.cma"; "libB.cma"; "libC.cma"] let arb_library = QCheck.make library_name let print_library l = QCheck.Print.string (Dynlink.adapt_filename l) (** A {!Lin} {i type} for files that can be dynamically linked *) let library = gen_deconstructible arb_library print_library (=) let loadfile f = Dynlink.loadfile (Dynlink.adapt_filename f) module DynConf = struct type t = unit let init () = () let cleanup _ = () let api = [ val_ "Dynlink.loadfile" loadfile (library @-> returning_or_exc unit); val_ "Dynlink.main_program_units" Dynlink.main_program_units (unit @-> returning (list string)); val_ "Dynlink.all_units" Dynlink.all_units (unit @-> returning (list string)); ] end module DynT = Lin_domain.Make(DynConf) let _ = if Sys.win32 || Sys.cygwin then Printf.printf "Lin Dynlink tests disabled under Windows\n\n%!" else QCheck_base_runner.run_tests_main [ DynT.neg_lin_test ~count:100 ~name:"negative Lin Dynlink test with Domain"; DynT.stress_test ~count:1000 ~name:"Lin Dynlink stress test with Domain"; ] multicoretests-0.7/src/ephemeron/000077500000000000000000000000001474367232000172275ustar00rootroot00000000000000multicoretests-0.7/src/ephemeron/dune000066400000000000000000000010111474367232000200760ustar00rootroot00000000000000;; Linearization tests of the stdlib Ephemeron module (test (name stm_tests_seq) (modules stm_tests_spec stm_tests_seq) (package multicoretests) (libraries qcheck-stm.sequential) (action (run %{test} --verbose)) ) (test (name stm_tests_par) (modules stm_tests_spec stm_tests_par) (package multicoretests) (libraries qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/ephemeron/lin_tests.ml000066400000000000000000000030031474367232000215610ustar00rootroot00000000000000(* ************************************************************ *) (* Lin tests of [Ephemeron] *) (* ************************************************************ *) module EConf = struct module E = Ephemeron.K1.Make(struct type t = Int.t let equal = Int.equal let hash = Fun.id end) type t = string E.t let init () = E.create 42 let cleanup _ = () open Lin let int,string = nat_small, string_small_printable let api = [ val_ "Ephemeron.clear" E.clear (t @-> returning unit); val_ "Ephemeron.add" E.add (t @-> int @-> string @-> returning unit); val_ "Ephemeron.remove" E.remove (t @-> int @-> returning unit); val_ "Ephemeron.find" E.find (t @-> int @-> returning_or_exc string); val_ "Ephemeron.find_opt" E.find_opt (t @-> int @-> returning (option string)); val_ "Ephemeron.find_all" E.find_all (t @-> int @-> returning (list string)); val_ "Ephemeron.replace" E.replace (t @-> int @-> string @-> returning unit); val_ "Ephemeron.mem" E.mem (t @-> int @-> returning bool); val_ "Ephemeron.length" E.length (t @-> returning int); val_ "Ephemeron.clean" E.clean (t @-> returning unit); ] end module ET_domain = Lin_domain.Make(EConf) ;; QCheck_base_runner.run_tests_main [ ET_domain.stress_test ~count:1000 ~name:"Lin Ephemeron stress test with Domain"; ] multicoretests-0.7/src/ephemeron/stm_tests_par.ml000066400000000000000000000003351474367232000224510ustar00rootroot00000000000000(** parallel STM tests of Ephemeron *) module ETest_dom = STM_domain.Make(Stm_tests_spec) let _ = QCheck_base_runner.run_tests_main [ ETest_dom.neg_agree_test_par ~count:1000 ~name:"STM Ephemeron test parallel" ] multicoretests-0.7/src/ephemeron/stm_tests_seq.ml000066400000000000000000000003351474367232000224570ustar00rootroot00000000000000(** sequential STM tests of Ephemeron *) module ETest_seq = STM_sequential.Make(Stm_tests_spec) let _ = QCheck_base_runner.run_tests_main [ ETest_seq.agree_test ~count:1000 ~name:"STM Ephemeron test sequential" ] multicoretests-0.7/src/ephemeron/stm_tests_spec.ml000066400000000000000000000114431474367232000226230ustar00rootroot00000000000000open QCheck open STM (** STM test specification of Ephemeron *) (* module Ephemeron.S = sig type key type 'a t val create : int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_opt : 'a t -> key -> 'a option val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats : 'a t -> Hashtbl.statistics val to_seq : 'a t -> (key * 'a) Seq.t val to_seq_keys : 'a t -> key Seq.t val to_seq_values : 'a t -> 'a Seq.t val add_seq : 'a t -> (key * 'a) Seq.t -> unit val replace_seq : 'a t -> (key * 'a) Seq.t -> unit val of_seq : (key * 'a) Seq.t -> 'a t val clean : 'a t -> unit remove all dead bindings. Done automatically during automatic resizing. val stats_alive : 'a t -> Hashtbl.statistics same as Hashtbl.SeededS.stats but only count the alive bindings *) module E = Ephemeron.K1.Make(struct [@@@warning "-unused-value-declaration"] (* support Int64.hash added in 5.1, without triggering an 'unused hash' error *) external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc] let hash x = seeded_hash_param 10 100 0 x include Stdlib.Int64 end) type key = int64 type data = int64 type sut = data E.t type state = (key * data) list type cmd = | Clear | Add of key * data | Remove of key | Find of key | Find_opt of key | Find_all of key | Replace of key * data | Mem of key | Length | Clean let pp_cmd par fmt x = let open Util.Pp in let pp_key = pp_int64 in let pp_data = pp_int64 in match x with | Clear -> cst0 "Clear" fmt | Add (x, y) -> cst2 pp_key pp_data "Add" par fmt x y | Remove x -> cst1 pp_key "Remove" par fmt x | Find x -> cst1 pp_key "Find" par fmt x | Find_opt x -> cst1 pp_key "Find_opt" par fmt x | Find_all x -> cst1 pp_key "Find_all" par fmt x | Replace (x, y) -> cst2 pp_key pp_data "Replace" par fmt x y | Mem x -> cst1 pp_key "Mem" par fmt x | Length -> cst0 "Length" fmt | Clean -> cst0 "Clean" fmt let show_cmd = Util.Pp.to_show pp_cmd let init_sut () = Gc.minor (); E.create 42 let cleanup _ = () let arb_cmd s = let key = if s = [] then Gen.(map Int64.of_int small_int) else Gen.(oneof [oneofl (List.map fst s); map Int64.of_int small_int]) in let data = Gen.(map Int64.of_int small_int) in QCheck.make ~print:show_cmd Gen.(frequency [ 1,return Clear; 2,map2 (fun k v -> Add (k, v)) key data; 2,map (fun k -> Remove k) key; 3,map (fun k -> Find k) key; 3,map (fun k -> Find_opt k) key; 3,map (fun k -> Find_all k) key; 2,map2 (fun k v -> Replace (k, v)) key data; 3,map (fun k -> Mem k) key; 2,return Length; 1,return Clean; ]) let next_state c s = match c with | Clear -> [] | Add (k, v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ | Find_opt _ | Find_all _ -> s | Replace (k,v) -> (k,v)::(List.remove_assoc k s) | Mem _ | Length | Clean -> s let run c e = let data = int64 in match c with | Clear -> Res (unit, E.clear e) | Add (k, v) -> Res (unit, E.add e k v) | Remove k -> Res (unit, E.remove e k) | Find k -> Res (result data exn, protect (E.find e) k) | Find_opt k -> Res (option data, E.find_opt e k) | Find_all k -> Res (list data, E.find_all e k) | Replace (k,v) -> Res (unit, E.replace e k v) | Mem k -> Res (bool, E.mem e k) | Length -> Res (int, E.length e) | Clean -> Res (unit, E.clean e) let init_state = [] let precond _ _ = true let postcond c (s : state) res = match c,res with | Clear, Res ((Unit,_),_) -> true | Add (_,_), Res ((Unit,_),_) -> true | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int64,Exn),_),r) -> r = Error Not_found || r = protect (List.assoc k) s | Find_opt k, Res ((Option Int64,_),r) -> r = None || r = List.assoc_opt k s | Find_all k, Res ((List Int64,_),r) -> let filter = fun (k',v') -> if k' = k then Some v' else None in let vs_state = List.filter_map filter s in (* some entries may have been GC'ed - test only for inclusion *) List.for_all (fun v -> List.mem v vs_state) (List.sort Int64.compare r) | Replace (_,_), Res ((Unit,_),_) -> true | Mem k, Res ((Bool,_),r) -> r = false || r = List.mem_assoc k s (*effectively: no postcond*) | Length, Res ((Int,_),r) -> r <= List.length s | Clean, Res ((Unit,_),_) -> true | _ -> false multicoretests-0.7/src/floatarray/000077500000000000000000000000001474367232000174115ustar00rootroot00000000000000multicoretests-0.7/src/floatarray/dune000066400000000000000000000005161474367232000202710ustar00rootroot00000000000000;; Test of the floatarray library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/floatarray/lin_tests.ml000066400000000000000000000041711474367232000217520ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Float.Array] *) (* ********************************************************************** *) module FAConf = struct type t = Float.Array.t let array_size = 16 let init () = Float.Array.make array_size 0.0 let cleanup _ = () open Lin let int = int_small (* fully evaluate the iterator, otherwise we get too many counterexamples from this aspect *) let strict_to_seq a = List.to_seq (List.of_seq (Float.Array.to_seq a)) let api = [ val_ "Float.Array.length" Float.Array.length (t@-> returning int); val_ "Float.Array.get" Float.Array.get (t@-> int @-> returning_or_exc float); val_ "Float.Array.set" Float.Array.set (t@-> int @-> float @-> returning_or_exc unit); val_ "Float.Array.fill" Float.Array.fill (t@-> int @-> int @-> float @-> returning_or_exc unit); val_ "Float.Array.to_list" Float.Array.to_list (t@-> returning (list float)); val_ "Float.Array.mem" Float.Array.mem (float @-> t @-> returning bool); val_ "Float.Array.mem_ieee" Float.Array.mem_ieee (float @-> t @-> returning bool); val_ "Float.Array.sort" (Float.Array.sort compare) (t@-> returning unit); val_ "Float.Array.stable_sort" (Float.Array.stable_sort compare) (t@-> returning unit); val_ "Float.Array.fast_sort" (Float.Array.fast_sort compare) (t@-> returning unit); val_ "Float.Array.to_seq" strict_to_seq (t@-> returning (seq float)); val_ "Float.Array.to_array" (Float.Array.map_to_array (fun x -> x)) (t@-> returning (array float)); ] end module FAT = Lin_domain.Make(FAConf) let _ = QCheck_base_runner.run_tests_main [ FAT.neg_lin_test ~count:1000 ~name:"Lin Float.Array test with Domain"; FAT.stress_test ~count:1000 ~name:"Lin Float.Array stress test with Domain"; ] multicoretests-0.7/src/floatarray/stm_tests.ml000066400000000000000000000114651474367232000217770ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Float.Array *) module FAConf = struct type cmd = | Length | Get of int | Set of int * float (* STM don't support floatarray type for the moment*) (* | Sub of int * int | Copy *) | Fill of int * int * float | To_list | Mem of float | Sort | To_seq let pp_cmd par fmt x = let open Util.Pp in match x with | Length -> cst0 "Length" fmt | Get x -> cst1 pp_int "Get" par fmt x | Set (x, y) -> cst2 pp_int pp_float "Set" par fmt x y | Fill (x, y, z) -> cst3 pp_int pp_int pp_float "Fill" par fmt x y z | To_list -> cst0 "To_list" fmt | Mem x -> cst1 pp_float "Mem" par fmt x | Sort -> cst0 "Sort" fmt | To_seq -> cst0 "To_seq" fmt let show_cmd = Util.Pp.to_show pp_cmd type state = float list type sut = Float.Array.t let arb_cmd s = let int_gen = Gen.(frequency [ (1,small_nat); (7,int_bound (List.length s - 1)); ]) in let float_gen = Gen.float in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(oneof [ return Length; map (fun i -> Get i) int_gen; map2 (fun i f -> Set (i,f)) int_gen float_gen; (* STM don't support floatarray type for the moment*) (* map2 (fun i len -> Sub (i,len)) int_gen int_gen; (* hack: reusing int_gen for length *) return Copy; *) map3 (fun i len c -> Fill (i,len,c)) int_gen int_gen float_gen; (* hack: reusing int_gen for length *) return To_list; map (fun f -> Mem f) float_gen; return Sort; return To_seq; ]) let floatarray_size = 16 let init_state = List.init floatarray_size (fun _ -> 1.0) let next_state f s = match f with | Length -> s | Get _ -> s | Set (i,f) -> List.mapi (fun j f' -> if i=j then f else f') s (* STM don't support floatarray type for the moment*) (* | Sub (_,_) -> s | Copy -> s *) | Fill (i,l,f) -> if i >= 0 && l >= 0 && i+l-1 < List.length s then List.mapi (fun j f' -> if i <= j && j <= i+l-1 then f else f') s else s | To_list -> s | Mem _ -> s | Sort -> List.sort Float.compare s | To_seq -> s let init_sut () = Float.Array.make floatarray_size 1.0 let cleanup _ = () let precond f _s = match f with | _ -> true let run f fa = match f with | Length -> Res (int, Float.Array.length fa) | Get i -> Res (result float exn, protect (Float.Array.get fa) i) | Set (i,f) -> Res (result unit exn, protect (Float.Array.set fa i) f) (* STM don't support floatarray type for the moment*) (* | Sub (i,l) -> Res (result (floatarray) exn, protect (Float.Array.sub fa i) l) *) (* | Copy -> Res (floatarray, Float.Array.copy fa) *) | Fill (i,l,f) -> Res (result unit exn, protect (Float.Array.fill fa i l) f) | To_list -> Res (list float, Float.Array.to_list fa) | Mem f -> Res (bool, Float.Array.mem f fa) | Sort -> Res (unit, Float.Array.sort Float.compare fa) | To_seq -> Res (seq float, List.to_seq (List.of_seq (Float.Array.to_seq fa))) let postcond f (s:float list) res = match f, res with | Length, Res ((Int,_),i) -> i = List.length s | Get i, Res ((Result (Float,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok (List.nth s i) | Set (i,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "index out of bounds") else r = Ok () (* STM don't support floatarray type for the moment*) (* | Sub (i,l), Res ((Result (Float.Array Float,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "Float.Array.sub") else r = Ok (Float.Array.of_list (List.filteri (fun j _ -> i <= j && j <= i+l-1) s)) *) (* | Copy, Res ((Float.Array Float,_),r) -> Float.Array.to_list r = s *) | Fill (i,l,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "Float.Array.fill") else r = Ok () | To_list, Res ((List Float,_),fs) -> List.equal Float.equal fs s | Mem f, Res ((Bool,_),r) -> r = List.mem f s | Sort, Res ((Unit,_),r) -> r = () | To_seq, Res ((Seq Float,_),r) -> Seq.equal (=) r (List.to_seq s) | _, _ -> false end module FloatArraySTM_seq = STM_sequential.Make(FAConf) module FloatArraySTM_dom = STM_domain.Make(FAConf) ;; QCheck_base_runner.run_tests_main (let count = 1000 in [FloatArraySTM_seq.agree_test ~count ~name:"STM Float Array test sequential"; FloatArraySTM_dom.neg_agree_test_par ~count ~name:"STM Float Array test parallel" ]) multicoretests-0.7/src/gc/000077500000000000000000000000001474367232000156365ustar00rootroot00000000000000multicoretests-0.7/src/gc/dune000066400000000000000000000035101474367232000165130ustar00rootroot00000000000000;; Tests of the stdlib Gc module (library (name pagesize) (modules pagesize) (foreign_stubs (language c) (names pagesizestub) (flags (:standard))) ) (test (name stm_tests_seq) (modules stm_tests_spec stm_tests_seq) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.sequential) (action (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=1" (run %{test} --verbose))) ) (test (name stm_tests_seq_child) (modules stm_tests_spec stm_tests_seq_child) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.sequential) (action (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=1" (run %{test} --verbose))) ) (test (name stm_tests_par) (modules stm_tests_spec stm_tests_par) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.domain) (action (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=1" (run %{test} --verbose))) ) (test (name stm_tests_par_stress) (modules stm_tests_spec stm_tests_par_stress) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.domain) (action (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=1" (run %{test} --verbose))) ) (test (name stm_tests_impl_seq) (modules stm_tests_spec stm_tests_impl_seq) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.sequential) (action (run %{test} --verbose)) ) (test (name stm_tests_impl_seq_child) (modules stm_tests_spec stm_tests_impl_seq_child) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.sequential) (action (run %{test} --verbose)) ) (test (name stm_tests_impl_par) (modules stm_tests_spec stm_tests_impl_par) (package multicoretests) (flags (:standard -w -37)) (libraries pagesize qcheck-stm.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/gc/pagesize.ml000066400000000000000000000000511474367232000177730ustar00rootroot00000000000000external get : unit -> int = "page_size" multicoretests-0.7/src/gc/pagesizestub.c000066400000000000000000000007171474367232000205140ustar00rootroot00000000000000#ifdef _WIN32 #define WIN32_LEAN_AND_MEAN #include #include #else #include #endif #include "caml/mlvalues.h" #include "caml/memory.h" CAMLprim value page_size(value ignored) { CAMLparam1(ignored); CAMLlocal1(result); long ps; #ifdef _WIN32 SYSTEM_INFO si; GetSystemInfo(&si); ps = si.dwPageSize; #else ps = sysconf(_SC_PAGESIZE); // page size in bytes #endif result = Val_int(ps); CAMLreturn(result); } multicoretests-0.7/src/gc/stm_tests_impl_par.ml000066400000000000000000000006011474367232000220750ustar00rootroot00000000000000(* parallel tests of the GC, without explicit Gc invocations *) module ImplGCConf = struct include Stm_tests_spec let arb_cmd = arb_alloc_cmd end module GC_STM_dom = STM_domain.Make(ImplGCConf) let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ GC_STM_dom.agree_test_par ~count:1000 ~name:"STM implicit Gc test parallel"; ] multicoretests-0.7/src/gc/stm_tests_impl_seq.ml000066400000000000000000000012551474367232000221110ustar00rootroot00000000000000open QCheck (* sequential tests of the GC, without explicit Gc invocations *) module ImplGCConf = struct include Stm_tests_spec let arb_cmd = arb_alloc_cmd end module GC_STM_seq = STM_sequential.Make(ImplGCConf) let agree_prop cs = match Util.protect GC_STM_seq.agree_prop cs with | Ok r -> r | Error Stack_overflow -> true (* Stack_overflow is accepted behaviour *) | Error e -> raise e let agree_test ~count ~name = Test.make ~name ~count (GC_STM_seq.arb_cmds ImplGCConf.init_state) agree_prop let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ agree_test ~count:1000 ~name:"STM implicit Gc test sequential"; ] multicoretests-0.7/src/gc/stm_tests_impl_seq_child.ml000066400000000000000000000015051474367232000232520ustar00rootroot00000000000000open QCheck (* sequential tests of the GC, without explicit Gc invocations *) module ImplGCConf = struct include Stm_tests_spec let arb_cmd = arb_alloc_cmd end module GC_STM_seq = STM_sequential.Make(ImplGCConf) (* Run seq. property in a child domain to stresstest parent-child GC *) let agree_child_prop cs = match Domain.spawn (fun () -> Util.protect GC_STM_seq.agree_prop cs) |> Domain.join with | Ok r -> r | Error Stack_overflow -> true (* Stack_overflow is accepted behaviour *) | Error e -> raise e let agree_child_test ~count ~name = Test.make ~name ~count (GC_STM_seq.arb_cmds ImplGCConf.init_state) agree_child_prop let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ agree_child_test ~count:1000 ~name:"STM implicit Gc test sequential in child domain"; ] multicoretests-0.7/src/gc/stm_tests_par.ml000066400000000000000000000004451474367232000210620ustar00rootroot00000000000000(* parallel tests of the GC with explicit Gc invocations *) module GC_STM_dom = STM_domain.Make(Stm_tests_spec) let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ GC_STM_dom.neg_agree_test_par ~count:1000 ~name:"STM Gc test parallel"; ] multicoretests-0.7/src/gc/stm_tests_par_stress.ml000066400000000000000000000004631474367232000224650ustar00rootroot00000000000000(* parallel stress tests of the GC with explicit Gc invocations *) module GC_STM_dom = STM_domain.Make(Stm_tests_spec) let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ GC_STM_dom.stress_test_par ~count:1000 ~name:"STM Gc stress test parallel"; ] multicoretests-0.7/src/gc/stm_tests_seq.ml000066400000000000000000000011211474367232000210600ustar00rootroot00000000000000open QCheck (* sequential tests of the GC with explicit Gc invocations *) module GC_STM_seq = STM_sequential.Make(Stm_tests_spec) let agree_prop cs = match Util.protect GC_STM_seq.agree_prop cs with | Ok r -> r | Error Stack_overflow -> true (* Stack_overflow is accepted behaviour *) | Error e -> raise e let agree_test ~count ~name = Test.make ~name ~count (GC_STM_seq.arb_cmds Stm_tests_spec.init_state) agree_prop let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ agree_test ~count:1000 ~name:"STM Gc test sequential"; ] multicoretests-0.7/src/gc/stm_tests_seq_child.ml000066400000000000000000000013661474367232000222360ustar00rootroot00000000000000open QCheck (* sequential tests of the GC with explicit Gc invocations *) module GC_STM_seq = STM_sequential.Make(Stm_tests_spec) (* Run seq. property in a child domain to stresstest parent-child GC *) let agree_child_prop cs = match Domain.spawn (fun () -> Util.protect GC_STM_seq.agree_prop cs) |> Domain.join with | Ok r -> r | Error Stack_overflow -> true (* Stack_overflow is accepted behaviour *) | Error e -> raise e let agree_child_test ~count ~name = Test.make ~name ~count (GC_STM_seq.arb_cmds Stm_tests_spec.init_state) agree_child_prop let _ = Printf.printf "Page size: %i\n" (Pagesize.get ()); QCheck_base_runner.run_tests_main [ agree_child_test ~count:1000 ~name:"STM Gc test sequential in child domain"; ] multicoretests-0.7/src/gc/stm_tests_spec.ml000066400000000000000000000462451474367232000212420ustar00rootroot00000000000000open QCheck open STM (* ideas for extensions: - Weak - Ephemerons - finalizers *) type setcmd = | Minor_heap_size of int | Major_heap_increment of int (* 1: "This field is currently not available in OCaml 5: the field value is always [0]." *) | Space_overhead of int (* | Verbose *) | Max_overhead of int (* 4: "This field is currently not available in OCaml 5: the field value is always [0]." *) | Stack_limit of int (* | Allocation_policy *) (* 6: "This field is currently not available in OCaml 5: the field value is always [0]." *) (* | Window_size of int *) (* 7: "This field is currently not available in OCaml 5: the field value is always [0]." *) | Custom_major_ratio of int | Custom_minor_ratio of int | Custom_minor_max_size of int type cmd = | Stat | Quick_stat | Counters | Minor_words | Get | Set of setcmd | Minor | Major_slice of int | Major | Full_major | Compact | Allocated_bytes | Get_minor_free (* cmds to allocate memory *) | Cons64 of int | PreAllocStr of int * string | AllocStr of int * int | CatStr of int * int * int | PreAllocList of int * char list | AllocList of int * int | RevList of int | PreAllocBigarray of int * (int, Bigarray.int_elt, Bigarray.c_layout) Bigarray.Array1.t | AllocBigarray of int * int let pp_cmd par fmt x = let open Util.Pp in match x with | Stat -> cst0 "Stat" fmt | Quick_stat -> cst0 "Quick_stat" fmt | Counters -> cst0 "Counters" fmt | Minor_words -> cst0 "Minor_words" fmt | Get -> cst0 "Get" fmt | Set subcmd -> (match subcmd with | Minor_heap_size i -> cst1 pp_int "Set minor_heap_size" par fmt i | Major_heap_increment i -> cst1 pp_int "Set major_heap_increment" par fmt i | Space_overhead i -> cst1 pp_int "Set space_overhead" par fmt i | Max_overhead i -> cst1 pp_int "Set max_overhead" par fmt i | Stack_limit i -> cst1 pp_int "Set stack_limit" par fmt i | Custom_major_ratio i -> cst1 pp_int "Set custom_major_ratio" par fmt i | Custom_minor_ratio i -> cst1 pp_int "Set custom_minor_ratio" par fmt i | Custom_minor_max_size i -> cst1 pp_int "Set custom_minor_max_size" par fmt i ) | Minor -> cst0 "Minor" fmt | Major_slice n -> cst1 pp_int "Major_slice" par fmt n | Major -> cst0 "Major" fmt | Full_major -> cst0 "Full_major" fmt | Compact -> cst0 "Compact" fmt | Allocated_bytes -> cst0 "Allocated_bytes" fmt | Get_minor_free -> cst0 "Get_minor_free" fmt | Cons64 i -> cst1 pp_int "Cons64" par fmt i | PreAllocStr (i,s) -> cst2 pp_int pp_string "PreAllocStr" par fmt i s | AllocStr (i,l) -> cst2 pp_int pp_int "AllocStr" par fmt i l | CatStr (s1,s2,t) -> cst3 pp_int pp_int pp_int "CatStr" par fmt s1 s2 t | PreAllocList (i,l) -> cst2 pp_int (pp_list pp_char) "PreAllocList" par fmt i l | AllocList (i,l) -> cst2 pp_int pp_int "AllocList" par fmt i l | RevList i -> cst1 pp_int "RevList" par fmt i | PreAllocBigarray (i,_l) -> cst2 pp_int pp_string "AllocBigarray" par fmt i "[|...|]" | AllocBigarray (i,l) -> cst2 pp_int pp_int "AllocBigarray" par fmt i l let show_cmd = Util.Pp.to_show pp_cmd let default_control = Gc.{ minor_heap_size = 262_144; (* Default: 256k. *) major_heap_increment = 0; (* Default: https://github.com/ocaml/ocaml/pull/13440 *) space_overhead = 120; (* Default: 120. *) verbose = 0; (* Default: 0. *) max_overhead = 0; (* Default: https://github.com/ocaml/ocaml/pull/13440 *) stack_limit = 134_217_728; (* Default: 128M. https://github.com/ocaml/ocaml/pull/13440 *) allocation_policy = 0; (* "This option is ignored in OCaml 5.x." *) window_size = 0; (* Default: https://github.com/ocaml/ocaml/pull/13440 *) custom_major_ratio = 44; (* Default: 44. *) custom_minor_ratio = 100; (* Default: 100. *) custom_minor_max_size = 70_000; (* Default: 70000 bytes. *) } type state = Gc.control let page_size = let bytes_per_word = Sys.word_size / 8 in (* bytes per word *) Pagesize.get () / bytes_per_word (* page size in words *) let round_heap_size i = if i mod page_size > 0 then page_size * (1 + (i / page_size)) else i (* Non-pretty OCAMLRUNPARAM parsing code *) let parse_params params = (* "l=2M,b,m=55,M=50,n=50,s=4k,o=75" *) let parse_pair s = (match String.split_on_char '=' s with | [lhs;rhs] -> Some (lhs, rhs) | _ -> None) in let convert_rhs rhs = if rhs="" then None else let len = String.length rhs in (match rhs.[len - 1] with | 'k' -> Some ((1 lsl 10) * int_of_string (String.sub rhs 0 (len - 1))) | 'M' -> Some ((1 lsl 20) * int_of_string (String.sub rhs 0 (len - 1))) | 'G' -> Some ((1 lsl 30) * int_of_string (String.sub rhs 0 (len - 1))) | c -> if '0' <= c && c <= '9' then Some (int_of_string rhs) else None) in let param_list = String.split_on_char ',' params in let pairs = List.fold_right (fun s acc -> match parse_pair s with None -> acc | Some pair -> pair::acc) param_list [] in let num_pairs = List.fold_right (fun (lhs,rhs) acc -> match convert_rhs rhs with None -> acc | Some num -> (lhs,num)::acc) pairs [] in num_pairs let rec interpret_params paramlist s = match paramlist with | [] -> s | pair::ps -> let s' = match pair with (* FIXME: The multiplier is k, M, or G, for multiplication by 2^10, 2^20, and 2^30 respectively.*) | ("l",sl) -> { s with Gc.stack_limit = sl } | ("m",cmr) -> { s with Gc.custom_minor_ratio = cmr } | ("M",cmr) -> { s with Gc.custom_major_ratio = cmr } | ("n",cms) -> { s with Gc.custom_minor_max_size = cms } | ("o",so) -> { s with Gc.space_overhead = so } | ("s",hs) -> { s with Gc.minor_heap_size = round_heap_size hs } | ("v",vs) -> { s with Gc.verbose = vs } | _ -> s in interpret_params ps s' let init_state = let control = if Sys.runtime_variant () = "d" then { default_control with Gc.verbose = 63 } (* -runtime-variant=d causes verbose=63 *) else default_control in let params = try Sys.getenv "OCAMLRUNPARAM" with Not_found -> try Sys.getenv "CAMLRUNPARAM" with Not_found -> "" in interpret_params (parse_params params) control let array_length = 8 let alloc_cmds, gc_cmds = let minor_heap_size_gen = Gen.oneofl [512;1024;2048;4096;8192;16384;32768] in let _major_heap_increment = Gen.oneof [Gen.int_bound 100; (* percentage increment *) Gen.int_range 101 1000; (* percentage increment *) Gen.int_range 1000 10000; (* word increment *) ] in let space_overhead = Gen.int_range 20 200 in (* percentage increment *) let _max_overhead = Gen.oneof [Gen.return 0; (* "If max_overhead is set to 0, heap compaction is triggered at the end of each major GC cycle" *) Gen.int_range 1 1000; Gen.return 1_000_000; ] in (* "If max_overhead >= 1000000 , compaction is never triggered." *) let stack_limit = Gen.int_range 3284 1_000_000 in let custom_major_ratio = Gen.int_range 1 100 in let custom_minor_ratio = Gen.int_range 1 100 in let custom_minor_max_size = Gen.int_range 10 1_000_000 in let int_gen = Gen.small_nat in let str_len_gen = Gen.(map (fun shift -> 1 lsl (shift-1)) (int_bound 14)) in (*[-1;13] ~ [0;1;...4096;8196] *) let str_gen = Gen.map (fun l -> String.make l 'x') str_len_gen in let list_gen = Gen.map (fun l -> List.init l (fun _ -> 'l')) Gen.nat in let bigarray_gen = Gen.map (fun l -> Bigarray.(Array1.create int C_layout l)) Gen.nat in let index_gen = Gen.int_bound (array_length-1) in let alloc_cmds = Gen.([ (* purely observational cmds *) 1, return Stat; 1, return Quick_stat; 1, return Minor_words; 5, return Get; 1, return Allocated_bytes; 1, return Get_minor_free; (* allocating cmds to activate the Gc *) 5, map (fun i -> Cons64 i) int_gen; 5, map2 (fun index str -> PreAllocStr (index,str)) index_gen str_gen; 5, map2 (fun index len -> AllocStr (index,len)) index_gen str_len_gen; 5, map3 (fun src1 src2 tgt -> CatStr (src1,src2,tgt)) index_gen index_gen index_gen; 5, map2 (fun index list -> PreAllocList (index,list)) index_gen list_gen; 5, map2 (fun index len -> AllocList (index,len)) index_gen Gen.nat; 5, map (fun index -> RevList index) index_gen; 5, map2 (fun index ba -> PreAllocBigarray (index,ba)) index_gen bigarray_gen; 5, map2 (fun index len -> AllocBigarray (index,len)) index_gen Gen.nat; ]) in let gc_cmds = let gc_cmds = Gen.([ 1, map (fun i -> Set (Minor_heap_size i)) minor_heap_size_gen; (*1, map (fun i -> Set (Major_heap_increment i)) major_heap_increment;*) 1, map (fun i -> Set (Space_overhead i)) space_overhead; (*1, map (fun i -> Set (Max_overhead i)) max_overhead;*) 1, map (fun i -> Set (Stack_limit i)) stack_limit; 1, map (fun i -> Set (Custom_major_ratio i)) custom_major_ratio; 1, map (fun i -> Set (Custom_minor_ratio i)) custom_minor_ratio; 1, map (fun i -> Set (Custom_minor_max_size i)) custom_minor_max_size; 1, return Minor; 1, map (fun i -> Major_slice i) Gen.nat; (* "n is the size of the slice: the GC will do enough work to free (on average) n words of memory." *) 1, return (Major_slice 0); (* cornercase: "If n = 0, the GC will try to do enough work to ensure that the next automatic slice has no work to do" *) 1, return Major; 1, return Full_major; (* 1, return Compact; *) (* Temporarily omit Gc.compact to silence the remaining issues: #470 and #480 *) ]) @ alloc_cmds in if Sys.(ocaml_release.major,ocaml_release.minor) > (5,3) then (1, Gen.return Counters)::gc_cmds (* known problem with Counters on <= 5.2: https://github.com/ocaml/ocaml/pull/13370 *) else gc_cmds in alloc_cmds, gc_cmds let arb_cmd _s = QCheck.make ~print:show_cmd (Gen.frequency gc_cmds) let arb_alloc_cmd _s = QCheck.make ~print:show_cmd (Gen.frequency alloc_cmds) let next_state n s = match n with | Stat -> s | Quick_stat -> s | Counters -> s | Minor_words -> s | Get -> s | Set subcmd -> (match subcmd with | Minor_heap_size mhs -> { s with Gc.minor_heap_size = round_heap_size mhs } | Major_heap_increment _mhi -> s (* "This field is currently not available in OCaml 5: the field value is always [0]." *) | Space_overhead so -> { s with Gc.space_overhead = so } | Max_overhead _mo -> s (* "This field is currently not available in OCaml 5: the field value is always [0]." *) | Stack_limit sl -> { s with Gc.stack_limit = sl } | Custom_major_ratio cmr -> { s with Gc.custom_major_ratio = cmr } | Custom_minor_ratio cmr -> { s with Gc.custom_minor_ratio = cmr } | Custom_minor_max_size ms -> { s with Gc.custom_minor_max_size = ms } ) | Minor -> s | Major_slice _ -> s | Major -> s | Full_major -> s | Compact -> s | Allocated_bytes -> s | Get_minor_free -> s | Cons64 _ -> s | PreAllocStr _ -> s | AllocStr _ -> s | CatStr _ -> s | PreAllocList _ -> s | AllocList _ -> s | RevList _ -> s | PreAllocBigarray _ -> s | AllocBigarray _ -> s type sut = { mutable int64s : int64 list; mutable strings : string array; mutable lists : char list array; mutable bigarrays : (int, Bigarray.int_elt, Bigarray.c_layout) Bigarray.Array1.t array; } let init_sut () = { int64s = []; strings = Array.make array_length ""; lists = Array.make array_length []; bigarrays = Array.make array_length Bigarray.(Array1.create int C_layout 0); } let cleanup sut = begin sut.int64s <- []; sut.strings <- [| |]; sut.lists <- [| |]; sut.bigarrays <- [| |]; Gc.set init_state; Gc.full_major () end let precond _n _s = true type _ ty += Tup3 : 'a ty * 'b ty * 'c ty -> ('a * 'b * 'c) ty | GcStat: Gc.stat ty | GcControl: Gc.control ty let tup3 spec_a spec_b spec_c = let (ty_a,show_a) = spec_a in let (ty_b,show_b) = spec_b in let (ty_c,show_c) = spec_c in (Tup3 (ty_a,ty_b,ty_c), QCheck.Print.tup3 show_a show_b show_c) let pp_gcstat par fmt s = let open Util.Pp in pp_record par fmt [ pp_field "minor_words" pp_float s.Gc.minor_words; pp_field "promoted_words" pp_float s.Gc.promoted_words; pp_field "major_words" pp_float s.Gc.major_words; pp_field "minor_collections" pp_int s.Gc.minor_collections; pp_field "major_collections" pp_int s.Gc.major_collections; pp_field "heap_words" pp_int s.Gc.heap_words; pp_field "heap_chunks" pp_int s.Gc.heap_chunks; pp_field "live_words" pp_int s.Gc.live_words; pp_field "live_blocks" pp_int s.Gc.live_blocks; pp_field "free_words" pp_int s.Gc.free_words; pp_field "free_blocks" pp_int s.Gc.free_blocks; pp_field "largest_free" pp_int s.Gc.largest_free; pp_field "fragments" pp_int s.Gc.fragments; pp_field "compactions" pp_int s.Gc.compactions; pp_field "top_heap_words" pp_int s.Gc.top_heap_words; pp_field "stack_size" pp_int s.Gc.stack_size; pp_field "forced_major_collections" pp_int s.Gc.forced_major_collections; ] let show_gcstat = Util.Pp.to_show pp_gcstat let gcstat = (GcStat, show_gcstat) let pp_gccontrol par fmt c = let open Util.Pp in pp_record par fmt [ pp_field "minor_heap_size" pp_int c.Gc.minor_heap_size; pp_field "major_heap_increment" pp_int c.Gc.major_heap_increment; pp_field "space_overhead" pp_int c.Gc.space_overhead; pp_field "verbose" pp_int c.Gc.verbose; pp_field "max_overhead" pp_int c.Gc.max_overhead; pp_field "stack_limit" pp_int c.Gc.stack_limit; pp_field "allocation_policy" pp_int c.Gc.allocation_policy; pp_field "window_size" pp_int c.Gc.window_size; pp_field "custom_major_ratio" pp_int c.Gc.custom_major_ratio; pp_field "custom_minor_ratio" pp_int c.Gc.custom_minor_ratio; pp_field "custom_minor_max_size" pp_int c.Gc.custom_minor_max_size; ] let show_gccontrol = Util.Pp.to_show pp_gccontrol let gccontrol = (GcControl, show_gccontrol) let run c sut = match c with | Stat -> Res (gcstat, Gc.stat ()) | Quick_stat -> Res (gcstat, Gc.quick_stat ()) | Counters -> Res (tup3 float float float, Gc.counters ()) | Minor_words -> Res (float, Gc.minor_words ()) | Get -> Res (gccontrol, Gc.get ()) | Set subcmd -> (match subcmd with | Minor_heap_size i -> Res (unit, let prev = Gc.get () in Gc.set { prev with minor_heap_size = i; }) | Major_heap_increment i -> Res (unit, let prev = Gc.get () in Gc.set { prev with major_heap_increment = i; }) | Space_overhead i -> Res (unit, let prev = Gc.get () in Gc.set { prev with space_overhead = i; }) | Max_overhead i -> Res (unit, let prev = Gc.get () in Gc.set { prev with max_overhead = i; }) | Stack_limit i -> Res (unit, let prev = Gc.get () in Gc.set { prev with stack_limit = i; }) | Custom_major_ratio i -> Res (unit, let prev = Gc.get () in Gc.set { prev with custom_major_ratio = i; }) | Custom_minor_ratio i -> Res (unit, let prev = Gc.get () in Gc.set { prev with custom_minor_ratio = i; }) | Custom_minor_max_size i -> Res (unit, let prev = Gc.get () in Gc.set { prev with custom_minor_max_size = i; }) ) | Minor -> Res (unit, Gc.minor ()) | Major_slice n -> Res (int, Gc.major_slice n) | Major -> Res (unit, Gc.major ()) | Full_major -> Res (unit, Gc.full_major ()) | Compact -> Res (unit, Gc.compact ()) | Allocated_bytes -> Res (float, Gc.allocated_bytes ()) | Get_minor_free -> Res (int, Gc.get_minor_free ()) | Cons64 i -> Res (unit, sut.int64s <- ((Int64.of_int i)::sut.int64s)) (*alloc int64 and cons cell at test runtime*) | PreAllocStr (i,s) -> Res (unit, sut.strings.(i) <- s) (*alloc string in parent domain in test-input*) | AllocStr (i,len) -> Res (unit, sut.strings.(i) <- String.make len 'c') (*alloc string at test runtime*) | CatStr (src1,src2,tgt) -> Res (unit, sut.strings.(tgt) <- String.cat sut.strings.(src1) sut.strings.(src2)) | PreAllocList (i,l) -> Res (unit, sut.lists.(i) <- l) (*alloc list in parent domain in test-input*) | AllocList (i,len) -> Res (unit, sut.lists.(i) <- List.init len (fun _ -> 'a')) (*alloc list at test runtime*) | RevList i -> Res (unit, sut.lists.(i) <- List.rev sut.lists.(i)) (*alloc list at test runtime*) | PreAllocBigarray (i,ba) -> Res (unit, sut.bigarrays.(i) <- ba) (*alloc bigarray in parent domain in test-input*) | AllocBigarray (i,len) -> Res (unit, let ba = Bigarray.(Array1.create int C_layout len) in Bigarray.Array1.fill ba 0xbeef; sut.bigarrays.(i) <- ba) (*alloc bigarray at test runtime*) let check_gc_stats r = r.Gc.minor_words >= 0. && r.Gc.promoted_words >= 0. && r.Gc.major_words >= 0. && r.Gc.minor_collections >= 0 && r.Gc.major_collections >= 0 && r.Gc.heap_words >= 0 && r.Gc.heap_chunks = 0 && (* Note: currently always 0 in OCaml5 *) r.Gc.live_words >= 0 && (* https://github.com/ocaml/ocaml/pull/13424 *) r.Gc.live_blocks >= 0 && (* https://github.com/ocaml/ocaml/pull/13424 *) r.Gc.free_words >= 0 && (* https://github.com/ocaml/ocaml/pull/13424 *) r.Gc.free_blocks = 0 && (* Note: currently always 0 in OCaml5 *) r.Gc.largest_free = 0 && (* Note: currently always 0 in OCaml5 *) r.Gc.fragments >= 0 && (* https://github.com/ocaml/ocaml/pull/13424 *) r.Gc.compactions >= 0 && r.Gc.top_heap_words >= 0 && r.Gc.stack_size = 0 && (* Note: currently always 0 in OCaml5 *) r.Gc.forced_major_collections >= 0 let postcond n (s: state) res = match n, res with | Stat, Res ((GcStat,_),r) -> check_gc_stats r | Quick_stat, Res ((GcStat,_),r) -> check_gc_stats r | Counters, Res ((Tup3 (Float,Float,Float),_),r) -> let (minor_words, promoted_words, major_words) = r in minor_words >= 0. && promoted_words >= 0. && major_words >= 0. | Minor_words, Res ((Float,_),r) -> r >= 0. | Get, Res ((GcControl,_),r) -> (* model-agreement modulo stack_limit which may have been expanded *) r = { s with stack_limit = r.Gc.stack_limit } && r.Gc.stack_limit >= s.Gc.stack_limit | Set _, Res ((Unit,_), ()) -> true | Minor, Res ((Unit,_), ()) -> true | Major_slice _, Res ((Int,_),r) -> r = 0 | Major, Res ((Unit,_), ()) -> true | Full_major, Res ((Unit,_), ()) -> true | Compact, Res ((Unit,_), ()) -> true | Allocated_bytes, Res ((Float,_),r) -> r >= 0. | Get_minor_free, Res ((Int,_),r) -> r >= 0 | Cons64 _, Res ((Unit,_), ()) -> true | PreAllocStr _, Res ((Unit,_), ()) -> true | AllocStr _, Res ((Unit,_), ()) -> true | CatStr _, Res ((Unit,_), ()) -> true | PreAllocList _, Res ((Unit,_), ()) -> true | AllocList _, Res ((Unit,_), ()) -> true | RevList _, Res ((Unit,_), ()) -> true | PreAllocBigarray _, Res ((Unit,_), ()) -> true | AllocBigarray _, Res ((Unit,_), ()) -> true | _, _ -> false multicoretests-0.7/src/hashtbl/000077500000000000000000000000001474367232000166725ustar00rootroot00000000000000multicoretests-0.7/src/hashtbl/dune000066400000000000000000000010561474367232000175520ustar00rootroot00000000000000;; Linearization tests of the stdlib Hashtbl library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/hashtbl/lin_internal_tests.ml000066400000000000000000000101301474367232000231170ustar00rootroot00000000000000open QCheck (* ********************************************************************** *) (* Tests of thread-unsafe [Hashtbl] *) (* ********************************************************************** *) module HConf = struct type t = (char, int) Hashtbl.t type cmd = | Clear | Add of char * int | Remove of char | Find of char | Find_opt of char | Find_all of char | Replace of char * int | Mem of char | Length let pp_cmd par fmt x = let open Util.Pp in match x with | Clear -> cst0 "Clear" fmt | Add (x, y) -> cst2 pp_char pp_int "Add" par fmt x y | Remove x -> cst1 pp_char "Remove" par fmt x | Find x -> cst1 pp_char "Find" par fmt x | Find_opt x -> cst1 pp_char "Find_opt" par fmt x | Find_all x -> cst1 pp_char "Find_all" par fmt x | Replace (x, y) -> cst2 pp_char pp_int "Replace" par fmt x y | Mem x -> cst1 pp_char "Mem" par fmt x | Length -> cst0 "Length" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int = nat and char = printable in oneof [ pure Clear; map2 (fun x y -> Add (x, y)) char int; map (fun x -> Remove x) char; map (fun x -> Find x) char; map (fun x -> Find_opt x) char; map (fun x -> Find_all x) char; map2 (fun x y -> Replace (x, y)) char int; map (fun x -> Mem x) char; pure Length; ] let shrink_cmd c = match c with | Clear -> Iter.empty | Add (c,i) -> Iter.((map (fun c -> Add (c,i)) (Shrink.char c)) <+> (map (fun i -> Add (c,i)) (Shrink.int i))) | Remove c -> Iter.map (fun c -> Remove c) (Shrink.char c) | Find c -> Iter.map (fun c -> Find c) (Shrink.char c) | Find_opt c -> Iter.map (fun c -> Find_opt c) (Shrink.char c) | Find_all c -> Iter.map (fun c -> Find_all c) (Shrink.char c) | Replace (c,i) -> Iter.((map (fun c -> Replace (c,i)) (Shrink.char c)) <+> (map (fun i -> Replace (c,i)) (Shrink.int i))) | Mem c -> Iter.map (fun c -> Mem c) (Shrink.char c) | Length -> Iter.empty type res = | RClear | RAdd | RRemove | RFind of (int, exn) result | RFind_opt of int option | RFind_all of int list | RReplace | RMem of bool | RLength of int let pp_res par fmt x = let open Util.Pp in match x with | RClear -> cst0 "RClear" fmt | RAdd -> cst0 "RAdd" fmt | RRemove -> cst0 "RRemove" fmt | RFind x -> cst1 (pp_result pp_int pp_exn) "RFind" par fmt x | RFind_opt x -> cst1 (pp_option pp_int) "RFind_opt" par fmt x | RFind_all x -> cst1 (pp_list pp_int) "RFind_all" par fmt x | RReplace -> cst0 "RReplace" fmt | RMem x -> cst1 pp_bool "RMem" par fmt x | RLength x -> cst1 pp_int "RLength" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RClear, RClear -> true | RAdd, RAdd -> true | RRemove, RRemove -> true | RFind x, RFind y -> equal_result equal_int equal_exn x y | RFind_opt x, RFind_opt y -> equal_option equal_int x y | RFind_all x, RFind_all y -> equal_list equal_int x y | RReplace, RReplace -> true | RMem x, RMem y -> equal_bool x y | RLength x, RLength y -> equal_int x y | _, _ -> false let init () = Hashtbl.create ~random:false 42 let run c h = match c with | Clear -> Hashtbl.clear h; RClear | Add (k,v) -> Hashtbl.add h k v; RAdd | Remove k -> Hashtbl.remove h k; RRemove | Find k -> RFind (Util.protect (Hashtbl.find h) k) | Find_opt k -> RFind_opt (Hashtbl.find_opt h k) | Find_all k -> RFind_all (Hashtbl.find_all h k) | Replace (k,v) -> Hashtbl.replace h k v; RReplace | Mem k -> RMem (Hashtbl.mem h k) | Length -> RLength (Hashtbl.length h) let cleanup _ = () end module HT_domain = Lin_domain.Make_internal(HConf) [@alert "-internal"] ;; QCheck_base_runner.run_tests_main [ HT_domain.neg_lin_test ~count:1000 ~name:"Lin.Internal Hashtbl test with Domain"; ] multicoretests-0.7/src/hashtbl/lin_tests.ml000066400000000000000000000026241474367232000212340ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of thread-unsafe [Hashtbl] *) (* ********************************************************************** *) module HConf (*: Lin.ApiSpec*) = struct type t = (char, int) Hashtbl.t let init () = Hashtbl.create ~random:false 42 let cleanup _ = () open Lin let int,char = nat_small,char_printable let api = [ val_ "Hashtbl.clear" Hashtbl.clear (t @-> returning unit); val_ "Hashtbl.add" Hashtbl.add (t @-> char @-> int @-> returning unit); val_ "Hashtbl.remove" Hashtbl.remove (t @-> char @-> returning unit); val_ "Hashtbl.find" Hashtbl.find (t @-> char @-> returning_or_exc int); val_ "Hashtbl.find_opt" Hashtbl.find_opt (t @-> char @-> returning (option int)); val_ "Hashtbl.find_all" Hashtbl.find_all (t @-> char @-> returning (list int)); val_ "Hashtbl.replace" Hashtbl.replace (t @-> char @-> int @-> returning unit); val_ "Hashtbl.mem" Hashtbl.mem (t @-> char @-> returning bool); val_ "Hashtbl.length" Hashtbl.length (t @-> returning int); ] end module HT_domain = Lin_domain.Make(HConf) ;; QCheck_base_runner.run_tests_main [ HT_domain.neg_lin_test ~count:1000 ~name:"Lin Hashtbl test with Domain"; HT_domain.stress_test ~count:1000 ~name:"Lin Hashtbl stress test with Domain"; ] multicoretests-0.7/src/hashtbl/stm_tests.ml000066400000000000000000000106741474367232000212610ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Hashtbl *) (* module Hashtbl : sig type (!'a, !'b) t val create : ?random:bool -> int -> ('a, 'b) t val clear : ('a, 'b) t -> unit val reset : ('a, 'b) t -> unit val copy : ('a, 'b) t -> ('a, 'b) t val add : ('a, 'b) t -> 'a -> 'b -> unit val find : ('a, 'b) t -> 'a -> 'b val find_opt : ('a, 'b) t -> 'a -> 'b option val find_all : ('a, 'b) t -> 'a -> 'b list val mem : ('a, 'b) t -> 'a -> bool val remove : ('a, 'b) t -> 'a -> unit val replace : ('a, 'b) t -> 'a -> 'b -> unit val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit val filter_map_inplace : ('a -> 'b -> 'b option) -> ('a, 'b) t -> unit val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c val length : ('a, 'b) t -> int val randomize : unit -> unit val is_randomized : unit -> bool val rebuild : ?random:bool -> ('a, 'b) t -> ('a, 'b) t ... end *) module HConf = struct type sut = (char, int) Hashtbl.t type state = (char * int) list type cmd = | Clear | Add of char * int | Remove of char | Find of char | Find_opt of char | Find_all of char | Replace of char * int | Mem of char | Length let pp_cmd par fmt x = let open Util.Pp in match x with | Clear -> cst0 "Clear" fmt | Add (x, y) -> cst2 pp_char pp_int "Add" par fmt x y | Remove x -> cst1 pp_char "Remove" par fmt x | Find x -> cst1 pp_char "Find" par fmt x | Find_opt x -> cst1 pp_char "Find_opt" par fmt x | Find_all x -> cst1 pp_char "Find_all" par fmt x | Replace (x, y) -> cst2 pp_char pp_int "Replace" par fmt x y | Mem x -> cst1 pp_char "Mem" par fmt x | Length -> cst0 "Length" fmt let show_cmd = Util.Pp.to_show pp_cmd let init_sut () = Hashtbl.create ~random:false 42 let cleanup _ = () let arb_cmd s = let char = if s=[] then Gen.printable else Gen.(oneof [oneofl (List.map fst s); printable]) in let int = Gen.nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Clear; Gen.map2 (fun k v -> Add (k,v)) char int; Gen.map (fun k -> Remove k) char; Gen.map (fun k -> Find k) char; Gen.map (fun k -> Find_opt k) char; Gen.map (fun k -> Find_all k) char; Gen.map2 (fun k v -> Replace (k,v)) char int; Gen.map (fun k -> Mem k) char; Gen.return Length; ]) let next_state c s = match c with | Clear -> [] | Add (k,v) -> (k,v)::s | Remove k -> List.remove_assoc k s | Find _ | Find_opt _ | Find_all _ -> s | Replace (k,v) -> (k,v)::(List.remove_assoc k s) | Mem _ | Length -> s let run c h = match c with | Clear -> Res (unit, Hashtbl.clear h) | Add (k,v) -> Res (unit, Hashtbl.add h k v) | Remove k -> Res (unit, Hashtbl.remove h k) | Find k -> Res (result int exn, protect (Hashtbl.find h) k) | Find_opt k -> Res (option int, Hashtbl.find_opt h k) | Find_all k -> Res (list int, Hashtbl.find_all h k) | Replace (k,v) -> Res (unit, Hashtbl.replace h k v) | Mem k -> Res (bool, Hashtbl.mem h k) | Length -> Res (int, Hashtbl.length h) let init_state = [] let precond _ _ = true let postcond c (s : state) res = match c,res with | Clear, Res ((Unit,_),_) | Add (_,_), Res ((Unit,_),_) | Replace (_,_), Res ((Unit,_),_) -> true | Remove _, Res ((Unit,_),_) -> true | Find k, Res ((Result (Int,Exn),_),r) -> r = (try Ok (List.assoc k s) with Not_found -> Error Not_found) | Find_opt k, Res ((Option Int,_),r) -> r = List.assoc_opt k s | Find_all k, Res ((List Int,_),r) -> let rec find_all h = match h with | [] -> [] | (k',v')::h' -> if k = k' (*&& k<>'a'*) (* an arbitrary, injected bug *) then v'::find_all h' else find_all h' in r = find_all s | Mem k, Res ((Bool,_),r) -> r = List.mem_assoc k s | Length, Res ((Int,_),r) -> r = List.length s | _ -> false end module HTest_seq = STM_sequential.Make(HConf) module HTest_dom = STM_domain.Make(HConf) ;; QCheck_base_runner.run_tests_main (let count = 200 in [HTest_seq.agree_test ~count ~name:"STM Hashtbl test sequential"; HTest_dom.neg_agree_test_par ~count ~name:"STM Hashtbl test parallel"; ]) multicoretests-0.7/src/io/000077500000000000000000000000001474367232000156545ustar00rootroot00000000000000multicoretests-0.7/src/io/dune000066400000000000000000000016731474367232000165410ustar00rootroot00000000000000;; Linearizability tests of the I/O operations (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) ;(flags (:standard -w -27)) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (library (name lin_tests_spec_io) (modules lin_tests_spec_io) (package multicoretests) (libraries qcheck-lin.lin) ) (test (name lin_tests_domain) (modules lin_tests_domain) (package multicoretests) ;(flags (:standard -w -27)) (libraries qcheck-lin.domain lin_tests_spec_io) (action (run %{test} --verbose)) ) (test (name lin_tests_thread) (modules lin_tests_thread) (package multicoretests) ;(flags (:standard -w -27)) (libraries qcheck-lin.thread lin_tests_spec_io) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/io/lin_internal_tests.ml000066400000000000000000000106521474367232000221120ustar00rootroot00000000000000(* First generate a big temporary file with random contents. *) let temp_readonly = Filename.temp_file "fuzz_stdlib" "" let temp_readonly_size = 1_000_000 let () = Random.self_init (); let out = Out_channel.open_bin temp_readonly in for _ = 1 to temp_readonly_size do Out_channel.output_byte out @@ Random.bits () lsr 22 done; Out_channel.close out module In_channel_ops = struct type t = In_channel.t (* Filename and corresponding channel *) type cmd = Close | Read of int | BlindRead of int let show_cmd = let open Printf in function | Close -> "Close" | Read l -> sprintf "Read %d" l | BlindRead l -> sprintf "BlindRead %d" l let gen_cmd = let open QCheck.Gen in frequency [1, return Close; 6, map (fun l -> Read l) small_nat; 6, map (fun l -> BlindRead l) small_nat; ] let shrink_cmd _ = QCheck.Iter.empty type res = | UnitRes of (unit, exn) result | ReadRes of (string option, exn) result let show_res = let open Printf in function | UnitRes (Ok ()) -> "()" | UnitRes (Error e) -> sprintf "UnitRes exception %s" (Printexc.to_string e) | ReadRes (Ok (Some s)) -> sprintf "\"%s\"" s | ReadRes (Ok None) -> "None" | ReadRes (Error e) -> sprintf "ReadRes exception %s" (Printexc.to_string e) let equal_res = (=) let init () = In_channel.open_bin temp_readonly let cleanup chan = In_channel.close chan let run cmd chan = match cmd with | Read l -> begin try ReadRes (Ok (In_channel.really_input_string chan l)) with e -> ReadRes (Error e) end | BlindRead l -> begin try ignore (In_channel.really_input_string chan l); UnitRes (Ok ()) with e -> UnitRes (Error e) end | Close -> begin try In_channel.close chan; UnitRes (Ok ()) with e -> UnitRes (Error e) end end module Out_channel_ops = struct type t = Out_channel.t let path = ref "" type cmd = | Seek of int64 | Close | Flush | Output_string of string | Set_binary_mode of bool | Set_buffered of bool | Is_buffered let show_cmd = let open Printf in function | Seek i -> sprintf "Seek %Li" i | Close -> "Close" | Flush -> "Flush" | Output_string s -> sprintf "Output_string %s" s | Set_binary_mode b -> sprintf "Set_binary_mode %s" QCheck.Print.(bool b) | Set_buffered b -> sprintf "Set_buffered %s" QCheck.Print.(bool b) | Is_buffered -> "Is_buffered" let gen_cmd = let open QCheck.Gen in frequency [10, map (fun i -> Seek (Int64.of_int i)) small_nat; 10, return Close; 10, return Flush; 10, map (fun s -> Output_string s) string_small; 10, map (fun b -> Set_binary_mode b) bool; 10, map (fun b -> Set_buffered b) bool; 10, return Is_buffered; ] let shrink_cmd _ = QCheck.Iter.empty type inner_res = Unit | Bool of bool type res = (inner_res, exn) result let show_res = let open Printf in function | Ok r -> (match r with | Unit -> sprintf "()" | Bool b -> QCheck.Print.(bool b) ) | Error e -> sprintf "exception %s" (Printexc.to_string e) let equal_res = (=) let init () = let p,ch = Filename.open_temp_file "lin-internal-" "" in path := p; ch let cleanup chan = Out_channel.close chan; Sys.remove !path let run cmd chan = match cmd with | Seek i -> (try Out_channel.seek chan i; Ok Unit with e -> Error e) | Close -> (try Out_channel.close chan; Ok Unit with e -> Error e) | Flush -> (try Out_channel.flush chan; Ok Unit with e -> Error e) | Output_string s -> (try Out_channel.output_string chan s; Ok Unit with e -> Error e) | Set_binary_mode b -> (try Out_channel.set_binary_mode chan b; Ok Unit with e -> Error e) | Set_buffered b -> (try Out_channel.set_buffered chan b; Ok Unit with e -> Error e) | Is_buffered -> (try Ok (Bool (Out_channel.is_buffered chan)) with e -> Error e) end module In_channel_lin = Lin_domain.Make_internal (In_channel_ops) [@@alert "-internal"] module Out_channel_lin = Lin_domain.Make_internal (Out_channel_ops) [@@alert "-internal"] let () = QCheck_base_runner.run_tests_main [ In_channel_lin.lin_test ~count:1000 ~name:"Lin.Internal In_channel test with domains"; Out_channel_lin.lin_test ~count:1000 ~name:"Lin.Internal Out_channel test with domains"; ] let () = Sys.remove temp_readonly multicoretests-0.7/src/io/lin_tests_domain.ml000066400000000000000000000007771474367232000215540ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of In_channels *) (* ********************************************************************** *) module IC_domain = Lin_domain.Make(Lin_tests_spec_io.ICConf) let _ = QCheck_base_runner.run_tests_main [ IC_domain.neg_lin_test ~count:1000 ~name:"Lin In_channel test with Domain"; IC_domain.stress_test ~count:1000 ~name:"Lin In_channel stress test with Domain"; ] multicoretests-0.7/src/io/lin_tests_spec_io.ml000066400000000000000000000073311474367232000217170ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of in and out channels *) (* ********************************************************************** *) (* Try to find a text file rather than a binary to test In_channel, so that input_line makes more sense *) let in_file = let path0 = Filename.dirname Sys.executable_name and up p = Filename.concat p Filename.parent_dir_name and candidate p = Filename.concat p "dune" in let path1 = up path0 in let path2 = up path1 in let path3 = up path2 in let path4 = up path3 in let candidates = List.map candidate [ path0; path1; path2; path3; path4 ] in let existing = List.filter Sys.file_exists candidates in match existing with | [] -> Sys.executable_name | f :: _ -> f module ICConf : Lin.Spec = struct type t = In_channel.t let init () = In_channel.open_bin in_file let cleanup = In_channel.close open Lin let int,int64 = nat_small,nat64_small let bytes = let open QCheck in let zeroed_bytes n = Bytes.make n '\000' in let shrink b = Iter.map zeroed_bytes (Shrink.int (Bytes.length b)) and gen = Gen.map zeroed_bytes Gen.small_nat in let bytes = make ~shrink ~small:Bytes.length ~print:Print.bytes gen in gen_deconstructible bytes (print Lin.bytes) Bytes.equal let api = [ (* Only one t is tested, so skip stdin and opening functions *) (* val_ "In_channel.stdin" In_channel.stdin (t) ; *) (* val_ "In_channel.open_bin" In_channel.open_bin (string @-> t) ; *) (* val_ "In_channel.open_text" In_channel.open_text (string @-> t) ; *) (* val_ "In_channel.open_gen" In_channel.open_gen (open_flag list @-> int @-> string @-> t) ; *) (* val_ "In_channel.with_open_bin" In_channel.with_open_bin (string @-> (t @-> 'a) @-> 'a) ; *) (* val_ "In_channel.with_open_text" In_channel.with_open_text (string @-> (t @-> 'a) @-> 'a) ; *) (* val_ "In_channel.with_open_gen" In_channel.with_open_gen (open_flag list @-> int @-> string @-> (t @-> 'a) @-> 'a) ; *) val_ "In_channel.seek" In_channel.seek (t @-> int64 @-> returning_or_exc unit) ; val_ "In_channel.pos" In_channel.pos (t @-> returning int64) ; val_ "In_channel.length" In_channel.length (t @-> returning_or_exc int64) ; val_ "In_channel.close" In_channel.close (t @-> returning unit) ; val_ "In_channel.close_noerr" In_channel.close_noerr (t @-> returning unit) ; val_ "In_channel.input_char" In_channel.input_char (t @-> returning_or_exc (option char)) ; val_ "In_channel.input_byte" In_channel.input_byte (t @-> returning_or_exc (option int)) ; val_ "In_channel.input_line" In_channel.input_line (t @-> returning_or_exc (option string)) ; val_ "In_channel.input" In_channel.input (t @-> bytes @-> int @-> int @-> returning_or_exc int) ; val_ "In_channel.really_input" In_channel.really_input (t @-> bytes @-> int @-> int @-> returning_or_exc (option unit)) ; val_ "In_channel.really_input_string" In_channel.really_input_string (t @-> int @-> returning_or_exc (option string)) ; (* input_all generates counter-examples that are impossibly long *) (* val_ "In_channel.input_all" In_channel.input_all (t @-> returning_or_exc string) ; *) val_ "In_channel.set_binary_mode" In_channel.set_binary_mode (t @-> bool @-> returning_or_exc unit) ; ] end multicoretests-0.7/src/io/lin_tests_thread.ml000066400000000000000000000007021474367232000215400ustar00rootroot00000000000000(* ********************************************************************** *) (* Tests of In_channels *) (* ********************************************************************** *) module IC_thread = Lin_thread.Make(Lin_tests_spec_io.ICConf) [@@alert "-experimental"] let _ = QCheck_base_runner.run_tests_main [ IC_thread.neg_lin_test ~count:1000 ~name:"Lin In_channel test with Thread"; ] multicoretests-0.7/src/io/stm_tests.ml000066400000000000000000000364711474367232000202460ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Out_channels *) module OCConf = struct type cmd = | Open_text | Seek of int64 | Pos | Length | Close | Close_noerr | Flush | Output_char of char | Output_byte of int | Output_string of string | Output_bytes of bytes | Output of bytes * int * int | Output_substring of string * int * int | Set_binary_mode of bool | Set_buffered of bool | Is_buffered let pp_cmd par fmt x = let open Util.Pp in match x with | Open_text -> cst0 "Open_text" fmt | Seek i -> cst1 pp_int64 "Seek" par fmt i | Pos -> cst0 "Pos" fmt | Length -> cst0 "Length" fmt | Close -> cst0 "Close" fmt | Close_noerr -> cst0 "Close_noerr" fmt | Flush -> cst0 "Flush" fmt | Output_char c -> cst1 pp_char "Output_char" par fmt c | Output_byte i -> cst1 pp_int "Output_byte" par fmt i | Output_string s -> cst1 pp_string "Output_string" par fmt s | Output_bytes b -> cst1 pp_bytes "Output_bytes" par fmt b | Output (b,p,l) -> cst3 pp_bytes pp_int pp_int "Output" par fmt b p l | Output_substring (s,p,l) -> cst3 pp_string pp_int pp_int "Output_substring" par fmt s p l | Set_binary_mode b -> cst1 pp_bool "Set_binary_mode" par fmt b | Set_buffered b -> cst1 pp_bool "Set_buffered" par fmt b | Is_buffered -> cst0 "Is_buffered" fmt let show_cmd = Util.Pp.to_show pp_cmd (* a path and an open channel to that file; we need to keep the path to cleanup after the test run *) type sut = { path : string; mutable channel : Out_channel.t } type state = Closed | Open of { position : int64; length : int64; buffered : bool; binary_mode : bool; } let arb_cmd s = let int64_gen = Gen.(map Int64.of_int small_int) in let char_gen = Gen.printable in let byte_gen = Gen.small_int in let string_gen = Gen.small_string in let bytes_gen = Gen.bytes_small in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) (match s with | Closed -> Gen.(frequency [ (* generate only Open or Close cmds in Closed *) 20,return Open_text; 1,map (fun i -> Seek i) int64_gen; 1,return Pos; 1,return Length; 1,return Close; 1,return Close_noerr; 1,return Flush; 1,map (fun c -> Output_char c) char_gen; 1,map (fun i -> Output_byte i) byte_gen; 1,map (fun c -> Output_string c) string_gen; 1,map (fun b -> Output_bytes b) bytes_gen; 1,map3 (fun b p l -> Output (b,p,l)) bytes_gen byte_gen byte_gen; 1,map3 (fun s p l -> Output_substring (s,p,l)) string_gen byte_gen byte_gen; 1,map (fun b -> Set_binary_mode b) Gen.bool; 1,map (fun b -> Set_buffered b) Gen.bool; 1,return Is_buffered; ]) | Open _ -> Gen.(frequency [ (*1,return Open_text;*) 3,map (fun i -> Seek i) int64_gen; 3,return Pos; 3,return Length; 1,return Close; 1,return Close_noerr; 3,return Flush; 3,map (fun c -> Output_char c) char_gen; 3,map (fun i -> Output_byte i) byte_gen; 3,map (fun c -> Output_string c) string_gen; 3,map (fun b -> Output_bytes b) bytes_gen; 3,map3 (fun b p l -> Output (b,p,l)) bytes_gen byte_gen byte_gen; 3,map3 (fun s p l -> Output_substring (s,p,l)) string_gen byte_gen byte_gen; 3,map (fun b -> Set_binary_mode b) Gen.bool; 3,map (fun b -> Set_buffered b) Gen.bool; 3,return Is_buffered; ])) let init_state = Open { position = 0L; length = 0L; buffered = true; binary_mode = false; } let count_nls s = String.fold_right (fun c count -> if c = '\n' then 1+count else count) s 0 let in_windows_text_mode binary_mode = (Sys.win32 || Sys.cygwin) && not binary_mode let next_state c s = match c,s with | Open_text, Closed -> Open { position = 0L; length = 0L; buffered = true; binary_mode = false; } | Open_text, Open _ -> s (* non-open cmd on closed Out_channel *) | Output_char _, Closed | Output_byte _, Closed | Output_string _, Closed | Output_bytes _, Closed | Output (_,_,_), Closed | Output_substring (_,_,_), Closed | Seek _, Closed | Close, Closed | Close_noerr, Closed | Set_binary_mode _, Closed | Set_buffered _, Closed -> s (* non-open cmd on open Out_channel *) | Seek p, Open { position = _; length; buffered; binary_mode } -> Open { position = p; length = Int64.max length p; buffered; binary_mode; } | Pos,_ -> s | Length,_ -> s | Close, Open _ -> Closed | Close_noerr, Open _ -> Closed | Flush, _ -> s | Set_binary_mode b, Open { position; length; buffered; binary_mode = _ } -> Open { position; length; buffered; binary_mode = b } | Is_buffered, _ -> s | Set_buffered b, Open { position; length; buffered = _; binary_mode } -> Open { position; length; buffered = b; binary_mode } (* output on open Out_channel *) | Output_char c, Open { position; length; buffered; binary_mode } -> let position = Int64.succ position in let length = (* Windows text mode maps '\n' to "\r\n" *) Int64.add length (if in_windows_text_mode binary_mode && c = '\n' then 2L else 1L) in Open { position; length; buffered; binary_mode; } | Output_byte i, Open { position; length; buffered; binary_mode } -> let position = Int64.succ position in let length = (* Windows text mode maps '\n' to "\r\n" *) Int64.add length (if in_windows_text_mode binary_mode && (i mod 256 = 10) then 2L else 1L) in Open { position; length; buffered; binary_mode; } | Output_string arg, Open { position; length; buffered; binary_mode } -> let arg_len = String.length arg in let position = Int64.add position (Int64.of_int arg_len) in let length = (* Windows text mode maps '\n' to "\r\n" *) Int64.add length (if in_windows_text_mode binary_mode then Int64.of_int (arg_len + count_nls arg) else Int64.of_int arg_len) in Open { position; length; buffered; binary_mode; } | Output_bytes arg, Open { position; length; buffered; binary_mode } -> let arg_len = Bytes.length arg in let position = Int64.add position (Int64.of_int arg_len) in let length = (* Windows text mode maps '\n' to "\r\n" *) Int64.add length (if in_windows_text_mode binary_mode then Int64.of_int (arg_len + count_nls (String.of_bytes arg)) else Int64.of_int arg_len) in Open { position; length; buffered; binary_mode; } | Output (b,p,l), Open { position; length; buffered; binary_mode } -> let bytes_len = Bytes.length b in if p < 0 || p >= bytes_len || l < 0 || p+l > bytes_len then s else let position = Int64.add position (Int64.of_int l) in let length = (* Windows text mode maps '\n' to "\r\n" *) Int64.add length (if in_windows_text_mode binary_mode then Int64.of_int (l + count_nls String.(sub (of_bytes b) p l)) else Int64.of_int l) in Open { position; length; buffered; binary_mode; } | Output_substring (str,p,l), Open { position; length; buffered; binary_mode } -> let str_len = String.length str in if p < 0 || p >= str_len || l < 0 || p+l > str_len then s else let position = Int64.add position (Int64.of_int l) in let length = (* Windows text mode maps '\n' to "\r\n" *) Int64.add length (if in_windows_text_mode binary_mode then Int64.of_int (l + count_nls String.(sub str p l)) else Int64.of_int l) in Open { position; length; buffered; binary_mode; } let init_sut () = let path = Filename.temp_file "stm-" "" in let channel = Out_channel.open_text path in { path; channel } let cleanup { path; channel } = (try Out_channel.close channel with Sys_error _ -> ()); Sys.remove path let precond c s = match c,s with | Open_text, Closed -> true | Open_text, Open _ -> false | _, Closed -> true | _, Open _ -> true let run c ({path;channel = oc} as r) = match c with | Open_text -> Res (result unit exn, protect (fun path -> (r.channel <- Out_channel.open_text path;())) path) | Seek p -> Res (result unit exn, protect (Out_channel.seek oc) p) | Pos -> Res (result int64 exn, protect Out_channel.pos oc) | Length -> Res (result int64 exn, protect Out_channel.length oc) | Close -> Res (result unit exn, protect Out_channel.close oc) | Close_noerr -> Res (result unit exn, protect Out_channel.close_noerr oc) | Flush -> Res (result unit exn, protect Out_channel.flush oc) | Output_char c -> Res (result unit exn, protect (Out_channel.output_char oc) c) | Output_byte i -> Res (result unit exn, protect (Out_channel.output_byte oc) i) | Output_string s -> Res (result unit exn, protect (Out_channel.output_string oc) s) | Output_bytes b -> Res (result unit exn, protect (Out_channel.output_bytes oc) b) | Output (b,p,l) -> Res (result unit exn, protect (Out_channel.output oc b p) l) | Output_substring (s,p,l) -> Res (result unit exn, protect (Out_channel.output_substring oc s p) l) | Set_binary_mode b -> if Sys.win32 || Sys.cygwin then Res (result unit exn, protect (fun b -> (Out_channel.flush oc; Out_channel.set_binary_mode oc b)) b) (* flush before changing mode *) else Res (result unit exn, protect (Out_channel.set_binary_mode oc) b) | Set_buffered b -> Res (result unit exn, protect (Out_channel.set_buffered oc) b) | Is_buffered -> Res (result bool exn, protect Out_channel.is_buffered oc) let postcond c (s:state) res = match c, res with | Open_text, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, (Ok () | Error (Sys_error _)) -> true (*"/tmp/stm-03ba23: Too many open files"*) | _ -> false) | Seek _, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, Error (Sys_error _) -> true (* Sys_error("Bad file descriptor") *) | Open _, Ok () -> true | _ -> false) | Pos, Res ((Result (Int64,Exn),_), r) -> (match s, r with | Closed, (Ok _ | Error (Sys_error _)) -> true (* pos on closed channel unspecified *) | Open { position; length = _; buffered = _; binary_mode = _ }, Ok p -> p = position | _ -> false) | Length, Res ((Result (Int64,Exn),_), r) -> (match s,r with | Closed, Error (Sys_error _) -> true (* Sys_error("Bad file descriptor") *) | Open { position = _; length; buffered = _; (* because of buffering the result and the model may disagree *) binary_mode = _ }, Ok i -> i <= length | _ -> false) | Close, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, (Ok () | Error (Sys_error _)) (*"Close exception" - unspecified *) | Open _, Ok () -> true | _ -> false) | Close_noerr, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, Error (Sys_error _) -> false (* should not generate an error *) | Closed, Ok () -> true | Open _, Ok () -> true | _ -> false) | Flush, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, Error (Sys_error _) -> false (* should not generate an error *) | Closed, Ok () -> true | Open _, Ok () -> true | _ -> false) | Output_char _c, Res ((Result (Unit,Exn),_), r) -> (match s,r with (* "Output functions raise a Sys_error exception when [...] applied to a closed output channel" *) | Closed, Error (Sys_error _) -> true | Open _, Ok () -> true | _ -> false) | Output_byte _i, Res ((Result (Unit,Exn),_), r) -> (match s,r with (* "Output functions raise a Sys_error exception when [...] applied to a closed output channel" *) | Closed, Error (Sys_error _) -> true | Open _, Ok () -> true | _ -> false) | Output_string str, Res ((Result (Unit,Exn),_), r) -> (match s,r with (* "Output functions raise a Sys_error exception when [...] applied to a closed output channel" *) | Closed, Error (Sys_error _) -> true | Closed, Ok () -> str = "" (* accepting this is actually against the above spec *) | Open _, Ok () -> true | _ -> false) | Output_bytes b, Res ((Result (Unit,Exn),_), r) -> (match s,r with (* "Output functions raise a Sys_error exception when [...] applied to a closed output channel" *) | Closed, Error (Sys_error _) -> true | Closed, Ok () -> b = Bytes.empty (* accepting this is actually against the above spec *) | Open _, Ok () -> true | _ -> false) | Output (b,p,l), Res ((Result (Unit,Exn),_), r) -> (match s,r with (* "Output functions raise a Sys_error exception when [...] applied to a closed output channel" *) | Closed, Error (Sys_error _) -> true | Closed, Ok () -> l = 0 (* accepting this is actually against the above spec *) | Open _, Ok () -> true | (Open _|Closed), Error (Invalid_argument _) -> (*"output"*) let bytes_len = Bytes.length b in p < 0 || p >= bytes_len || l < 0 || p+l > bytes_len | _, _ -> false) | Output_substring (str,p,l), Res ((Result (Unit,Exn),_), r) -> (match s,r with (* "Output functions raise a Sys_error exception when [...] applied to a closed output channel" *) | Closed, Error (Sys_error _) -> true | Closed, Ok () -> l = 0 (* accepting this is actually against the above spec *) | Open _, Ok () -> true | (Open _|Closed), Error (Invalid_argument _) -> (*"output_substring"*) let str_len = String.length str in p < 0 || p >= str_len || l < 0 || p+l > str_len | _, _ -> false) | Set_binary_mode _, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, (Ok () | Error (Sys_error _)) -> true (* set_binary_mode on closed channel unspecified *) | Open _, Ok () -> true | _, _ -> false) | Set_buffered _, Res ((Result (Unit,Exn),_), r) -> (match s,r with | Closed, (Ok () | Error (Sys_error _)) -> true (* set_buffered on closed channel unspecified *) | Open _, Ok () -> true | _, _ -> false) | Is_buffered, Res ((Result (Bool,Exn),_), r) -> (match s,r with | Closed, (Ok _ | Error (Sys_error _)) -> true (* is_buffered on closed channel unspecified *) | Open { position = _; length = _; buffered; binary_mode = _ }, Ok r -> r = buffered | _, _ -> false) | _, _ -> false end module OCSTM_seq = STM_sequential.Make(OCConf) module OCSTM_dom = STM_domain.Make(OCConf) ;; QCheck_base_runner.run_tests_main [ OCSTM_seq.agree_test ~count:1000 ~name:"STM Out_channel test sequential"; OCSTM_dom.agree_test_par ~count:1000 ~name:"STM Out_channel test parallel"; ] multicoretests-0.7/src/lazy/000077500000000000000000000000001474367232000162245ustar00rootroot00000000000000multicoretests-0.7/src/lazy/dune000066400000000000000000000010701474367232000171000ustar00rootroot00000000000000;; Parallel STM_seq STM_domain and Lin tests of the stdlib Lazy module (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) multicoretests-0.7/src/lazy/lin_internal_tests.ml000066400000000000000000000101451474367232000224570ustar00rootroot00000000000000open QCheck (** parallel linearization tests of Lazy *) (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let work () = let r = ref 0 in for _ = 1 to 100 do r := !r + tak 18 12 6; (*assert (7 = tak 18 12 6);*) done; !r (* module Lazy : sig type 'a t = 'a CamlinternalLazy.t exception Undefined external force : 'a t -> 'a = "%lazy_force" val map : ('a -> 'b) -> 'a t -> 'b t val is_val : 'a t -> bool val from_val : 'a -> 'a t val map_val : ('a -> 'b) -> 'a t -> 'b t val from_fun : (unit -> 'a) -> 'a t val force_val : 'a t -> 'a end *) module LBase = struct type cmd = | Force | Force_val | Is_val | Map of int_fun | Map_val of int_fun and int_fun = (int -> int) fun_ let pp_cmd par fmt x = let open Util.Pp in let pp_int_fun = of_show Fn.print in match x with | Force -> cst0 "Force" fmt | Force_val -> cst0 "Force_val" fmt | Is_val -> cst0 "Is_val" fmt | Map x -> cst1 pp_int_fun "Map" par fmt x | Map_val x -> cst1 pp_int_fun "Map_val" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int_fun = (fun1 Observable.int QCheck.small_nat).gen in oneof [ pure Force; pure Force_val; pure Is_val; map (fun x -> Map x) int_fun; map (fun x -> Map_val x) int_fun; ] (* let shrink_cmd c = match c with | Force | Force_val | Is_val -> Iter.empty | Map f -> Iter.map (fun f -> Map f) (Fn.shrink f) | Map_val f -> Iter.map (fun f -> Map_val f) (Fn.shrink f) *) (* the Lazy tests already take a while to run - so better avoid spending extra time shrinking *) let shrink_cmd = Shrink.nil type t = int Lazy.t let cleanup _ = () type res = | RForce of (int, exn) result | RForce_val of (int, exn) result | RIs_val of bool | RMap of (int, exn) result | RMap_val of (int, exn) result let pp_res par fmt x = let open Util.Pp in match x with | RForce x -> cst1 (pp_result pp_int pp_exn) "RForce" par fmt x | RForce_val x -> cst1 (pp_result pp_int pp_exn) "RForce_val" par fmt x | RIs_val x -> cst1 pp_bool "RIs_val" par fmt x | RMap x -> cst1 (pp_result pp_int pp_exn) "RMap" par fmt x | RMap_val x -> cst1 (pp_result pp_int pp_exn) "RMap_val" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RForce x, RForce y -> equal_result equal_int equal_exn x y | RForce_val x, RForce_val y -> equal_result equal_int equal_exn x y | RIs_val x, RIs_val y -> equal_bool x y | RMap x, RMap y -> equal_result equal_int equal_exn x y | RMap_val x, RMap_val y -> equal_result equal_int equal_exn x y | _, _ -> false let run c l = match c with | Force -> RForce (Util.protect Lazy.force l) | Force_val -> RForce_val (Util.protect Lazy.force_val l) | Is_val -> RIs_val (Lazy.is_val l) | Map (Fun (_,f)) -> RMap (try Ok (Lazy.force (Lazy.map f l)) with exn -> Error exn) (*we force the "new lazy"*) | Map_val (Fun (_,f)) -> RMap_val (try Ok (Lazy.force (Lazy.map_val f l)) with exn -> Error exn) (*we force the "new lazy"*) end module LTlazy = Lin_domain.Make_internal(struct include LBase let init () = lazy (work ()) end) [@alert "-internal"] module LTfromval = Lin_domain.Make_internal(struct include LBase let init () = Lazy.from_val 42 end) [@alert "-internal"] module LTfromfun = Lin_domain.Make_internal(struct include LBase let init () = Lazy.from_fun work end) [@alert "-internal"] ;; QCheck_base_runner.run_tests_main (let count = 100 in [LTlazy.neg_lin_test ~count ~name:"Lin.Internal Lazy test with Domain"; LTfromval.lin_test ~count ~name:"Lin.Internal Lazy test with Domain from_val"; LTfromfun.neg_lin_test ~count ~name:"Lin.Internal Lazy test with Domain from_fun"; ]) multicoretests-0.7/src/lazy/lin_tests.ml000066400000000000000000000052221474367232000205630ustar00rootroot00000000000000(** parallel linearization tests of Lazy *) (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let work () = let r = ref 0 in for _ = 1 to 100 do r := !r + tak 18 12 6; (*assert (7 = tak 18 12 6);*) done; !r (* module Lazy : sig type 'a t = 'a CamlinternalLazy.t exception Undefined external force : 'a t -> 'a = "%lazy_force" val map : ('a -> 'b) -> 'a t -> 'b t val is_val : 'a t -> bool val from_val : 'a -> 'a t val map_val : ('a -> 'b) -> 'a t -> 'b t val from_fun : (unit -> 'a) -> 'a t val force_val : 'a t -> 'a end *) module LBase = struct type t = int Lazy.t let cleanup _ = () open Lin (* hack to work around missing function generators *) let fun_gen _ty _ty' = let print_fun _ = "Stdlib.succ" in let fun_gen = QCheck.(make ~print:print_fun (Gen.return Stdlib.succ)) in gen fun_gen print_fun let force_map f l = Lazy.force (Lazy.map f l) let force_map_val f l = Lazy.force (Lazy.map_val f l) let int = nat_small let api = [ val_ "Lazy.force" Lazy.force (t @-> returning_or_exc int); val_ "Lazy.force_val" Lazy.force_val (t @-> returning_or_exc int); val_ "Lazy.is_val" Lazy.is_val (t @-> returning bool); (*val_ "Lazy.map" Lazy.map (fun_gen int int @-> t @-> returning_or_exc t);*) val_ "Lazy.force o Lazy.map" force_map (fun_gen int int @-> t @-> returning_or_exc int); (*val_ "Lazy.map_val" Lazy.map (fun_gen int int @-> t @-> returning_or_exc t);*) val_ "Lazy.force o Lazy.map_val" force_map_val (fun_gen int int @-> t @-> returning_or_exc int); ] end module LTlazyAPI = struct include LBase let init () = lazy (work ()) end module LTlazy_domain = Lin_domain.Make(LTlazyAPI) module LTfromvalAPI = struct include LBase let init () = Lazy.from_val 42 end module LTfromval_domain = Lin_domain.Make(LTfromvalAPI) module LTfromfunAPI = struct include LBase let init () = Lazy.from_fun work end module LTfromfun_domain = Lin_domain.Make(LTfromfunAPI) ;; QCheck_base_runner.run_tests_main (let count = 100 in [LTlazy_domain.neg_lin_test ~count ~name:"Lin Lazy test with Domain"; LTlazy_domain.stress_test ~count ~name:"Lin Lazy stress test with Domain"; LTfromval_domain.lin_test ~count ~name:"Lin Lazy test with Domain from_val"; LTfromfun_domain.neg_lin_test ~count ~name:"Lin Lazy test with Domain from_fun"; LTfromfun_domain.stress_test ~count ~name:"Lin Lazy stress test with Domain from_fun"; ]) multicoretests-0.7/src/lazy/stm_tests.ml000066400000000000000000000104431474367232000206050ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Lazy *) (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let work () = let r = ref 0 in for _ = 1 to 100 do r := !r + tak 18 12 6; (*assert (7 = tak 18 12 6);*) done; !r (* module Lazy : sig type 'a t = 'a CamlinternalLazy.t exception Undefined external force : 'a t -> 'a = "%lazy_force" val map : ('a -> 'b) -> 'a t -> 'b t val is_val : 'a t -> bool val from_val : 'a -> 'a t val map_val : ('a -> 'b) -> 'a t -> 'b t val from_fun : (unit -> 'a) -> 'a t val force_val : 'a t -> 'a end *) module LConfbase = struct type cmd = | Force | Force_val | Is_val | Map of (int -> int) fun_ | Map_val of (int -> int) fun_ let pp_cmd par fmt x = let open Util.Pp in match x with | Force -> cst0 "Force" fmt | Force_val -> cst0 "Force_val" fmt | Is_val -> cst0 "Is_val" fmt | Map x -> cst1 pp_fun_ "Map" par fmt x | Map_val x -> cst1 pp_fun_ "Map_val" par fmt x let show_cmd = Util.Pp.to_show pp_cmd type state = int * bool type sut = int Lazy.t let arb_cmd _s = let int' = small_nat in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Force; Gen.return Force_val; Gen.return Is_val; Gen.map (fun f -> Map f) (fun1 Observable.int int').gen; Gen.map (fun f -> Map_val f) (fun1 Observable.int int').gen; ]) let cleanup _ = () let next_state c s = match c with | Force | Force_val -> (fst s,true) | Is_val -> s | Map _ | Map_val _ -> (fst s,true) (*run forces the "lazy child"*) let precond _ _ = true (* type res = | RForce of (int,exn) result | RForce_val of (int,exn) result | RIs_val of bool | RMap of (int,exn) result | RMap_val of (int,exn) result [@@deriving show { with_path = false }] *) let run c l = match c with | Force -> Res (result int exn, protect Lazy.force l) | Force_val -> Res (result int exn, protect Lazy.force_val l) | Is_val -> Res (bool, Lazy.is_val l) | Map (Fun (_,f)) -> Res (result int exn, try Ok (Lazy.force (Lazy.map f l)) with exn -> Error exn) (*we force the "new lazy"*) | Map_val (Fun (_,f)) -> Res (result int exn, try Ok (Lazy.force (Lazy.map_val f l)) with exn -> Error exn) (*we force the "new lazy"*) let postcond c (s : state) res = match c,res with | (Force|Force_val), Res ((Result (Int,Exn), _), v) -> v = Ok (fst s) | Is_val, Res ((Bool,_),r) -> r = snd s | (Map (Fun (_,f)) | Map_val (Fun (_,f))), Res ((Result (Int,Exn), _), i) -> i = Ok (f (fst s)) | _,_ -> false end module LTlazy_seq = STM_sequential.Make(struct include LConfbase let init_state = (7 * 100, false) let init_sut () = lazy (work ()) end) module LTfromval_seq = STM_sequential.Make(struct include LConfbase let init_state = (42, true) let init_sut () = Lazy.from_val 42 end) module LTfromfun_seq = STM_sequential.Make(struct include LConfbase let init_state = (7 * 100, false) let init_sut () = Lazy.from_fun work end) module LTlazy_dom = STM_domain.Make(struct include LConfbase let init_state = (7 * 100, false) let init_sut () = lazy (work ()) end) module LTfromval_dom = STM_domain.Make(struct include LConfbase let init_state = (42, true) let init_sut () = Lazy.from_val 42 end) module LTfromfun_dom = STM_domain.Make(struct include LConfbase let init_state = (7 * 100, false) let init_sut () = Lazy.from_fun work end) ;; QCheck_base_runner.run_tests_main (let count = 200 in [LTlazy_seq.agree_test ~count ~name:"STM Lazy test sequential"; LTfromval_seq.agree_test ~count ~name:"STM Lazy test sequential from_val"; LTfromfun_seq.agree_test ~count ~name:"STM Lazy test sequential from_fun"; LTlazy_dom.neg_agree_test_par ~count ~name:"STM Lazy test parallel"; LTfromval_dom.agree_test_par ~count ~name:"STM Lazy test parallel from_val"; LTfromfun_dom.neg_agree_test_par ~count ~name:"STM Lazy test parallel from_fun"; ]) multicoretests-0.7/src/neg_tests/000077500000000000000000000000001474367232000172405ustar00rootroot00000000000000multicoretests-0.7/src/neg_tests/CList.ml000066400000000000000000000015561474367232000206170ustar00rootroot00000000000000(** a simple concurrent list - from Sadiq *) type 'a conc_list = { value: 'a; next: 'a conc_list option } let rec add_node list_head n = (* try to add a new node to head *) let old_head = Atomic.get list_head in let new_node = { value = n ; next = (Some old_head) } in (* introduce bug *) if Atomic.get list_head = old_head then begin Atomic.set list_head new_node; true end else add_node list_head n let list_init i = Atomic.make { value = i ; next = None } let member list_head n = let rec check_from_node node = match (node.value, node.next) with | (v, _) when v = n -> true | (_, None) -> false | (_ , Some(next_node)) -> check_from_node next_node in (* try to find the node *) check_from_node (Atomic.get list_head) let add_and_check list_head n () = assert(add_node list_head n); assert(member list_head n) multicoretests-0.7/src/neg_tests/dune000066400000000000000000000056321474367232000201240ustar00rootroot00000000000000;; Negative tests to confirm that approach works (library (name stm_tests_spec_ref) (modules stm_tests_spec_ref) (package multicoretests) (libraries qcheck-core qcheck-stm.stm) ) (test (name stm_tests_sequential_ref) (modules stm_tests_sequential_ref) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.sequential) (action (run %{test} --verbose)) ) (test (name stm_tests_domain_ref) (modules stm_tests_domain_ref) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name stm_tests_domain_ref_asym) (modules stm_tests_domain_ref_asym) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name stm_tests_thread_ref) (modules stm_tests_thread_ref) (package multicoretests) (libraries stm_tests_spec_ref qcheck-stm.thread) (action (run %{test} --verbose)) ) (library (name CList) (modules CList) (package multicoretests) ) (test (name stm_tests_conclist) (modules stm_tests_conclist) (package multicoretests) (libraries CList qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) ;; Linearization tests of ref and Clist with Lin (library (name lin_tests_common) (modules lin_tests_common) (package multicoretests) (libraries CList qcheck-lin.lin) ) (library (name lin_internal_tests_common) (modules lin_internal_tests_common) (package multicoretests) (libraries CList qcheck-lin.lin) ) (test (name lin_tests_domain) (modules lin_tests_domain) (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_common qcheck-lin.domain) (action (run %{test} --verbose)) ) (test (name lin_tests_thread) (modules lin_tests_thread) (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_common qcheck-lin.thread) ; (action (run %{test} --verbose)) (action (progn)) ) (test (name lin_tests_effect) (modules lin_tests_effect) (package multicoretests) (flags (:standard -w -27)) (libraries lin_tests_common qcheck-lin.effect) (action (run %{test} --verbose)) ) ;; Linearization tests of ref and Clist with Lin.Internal (test (name lin_internal_tests_domain) (modules lin_internal_tests_domain) (package multicoretests) (flags (:standard -w -27)) (libraries lin_internal_tests_common qcheck-lin.domain) ; (action (run %{test} --verbose)) (action (progn)) ) (tests (names lin_internal_tests_thread_ref lin_internal_tests_thread_conclist) (modules lin_internal_tests_thread_ref lin_internal_tests_thread_conclist) (package multicoretests) (flags (:standard -w -27)) (libraries lin_internal_tests_common qcheck-lin.thread) (action (run %{test} --verbose)) ) (test (name lin_internal_tests_effect) (modules lin_internal_tests_effect) (package multicoretests) (flags (:standard -w -27)) (libraries lin_internal_tests_common qcheck-lin.effect) ; (action (run ./%{deps} --verbose)) (action (progn)) ) multicoretests-0.7/src/neg_tests/lin_internal_tests_common.ml000066400000000000000000000143571474367232000250540ustar00rootroot00000000000000open QCheck (* ********************************************************************** *) (* Tests of a simple reference *) (* ********************************************************************** *) module Sut_int = struct let init () = ref 0 let get r = !r let set r i = r:=i let add r i = let old = !r in r:= i + old (* buggy: not atomic *) let incr r = incr r (* buggy: not atomic *) let decr r = decr r (* buggy: not atomic *) end module Sut_int64 = struct let init () = ref Int64.zero let get r = !r let set r i = r:=i let add r i = let old = !r in r:= Int64.add i old (* buggy: not atomic *) let incr r = add r Int64.one (* buggy: not atomic *) let decr r = add r Int64.minus_one (* buggy: not atomic *) end module RConf_int = struct type t = int ref type cmd = | Get | Set of int | Add of int | Incr | Decr let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Add x -> cst1 pp_int "Add" par fmt x | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int = nat in oneof [ pure Get; map (fun x -> Set x) int; map (fun x -> Add x) int; pure Incr; pure Decr; ] let shrink_cmd c = match c with | Get | Incr | Decr -> Iter.empty | Set i -> Iter.map (fun i -> Set i) (Shrink.int i) | Add i -> Iter.map (fun i -> Add i) (Shrink.int i) type res = | RGet of int | RSet | RAdd | RIncr | RDecr let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RAdd -> cst0 "RAdd" fmt | RIncr -> cst0 "RIncr" fmt | RDecr -> cst0 "RDecr" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int x y | RSet, RSet -> true | RAdd, RAdd -> true | RIncr, RIncr -> true | RDecr, RDecr -> true | _, _ -> false let init () = Sut_int.init () let run c r = match c with | Get -> RGet (Sut_int.get r) | Set i -> (Sut_int.set r i; RSet) | Add i -> (Sut_int.add r i; RAdd) | Incr -> (Sut_int.incr r; RIncr) | Decr -> (Sut_int.decr r; RDecr) let cleanup _ = () end module RConf_int64 = struct type t = int64 ref type cmd = | Get | Set of int64 | Add of int64 | Incr | Decr let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int64 "Set" par fmt x | Add x -> cst1 pp_int64 "Add" par fmt x | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int64 = map Int64.of_int nat in oneof [ pure Get; map (fun x -> Set x) int64; map (fun x -> Add x) int64; pure Incr; pure Decr; ] let shrink_cmd c = match c with | Get | Incr | Decr -> Iter.empty | Set i -> Iter.map (fun i -> Set i) (Shrink.int64 i) | Add i -> Iter.map (fun i -> Add i) (Shrink.int64 i) type res = | RGet of int64 | RSet | RAdd | RIncr | RDecr let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int64 "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RAdd -> cst0 "RAdd" fmt | RIncr -> cst0 "RIncr" fmt | RDecr -> cst0 "RDecr" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int64 x y | RSet, RSet -> true | RAdd, RAdd -> true | RIncr, RIncr -> true | RDecr, RDecr -> true | _, _ -> false let init () = Sut_int64.init () let run c r = match c with | Get -> RGet (Sut_int64.get r) | Set i -> (Sut_int64.set r i; RSet) | Add i -> (Sut_int64.add r i; RAdd) | Incr -> (Sut_int64.incr r; RIncr) | Decr -> (Sut_int64.decr r; RDecr) let cleanup _ = () end (* ********************************************************************** *) (* Tests of the buggy concurrent list CList *) (* ********************************************************************** *) module CLConf (T : sig type t val zero : t val of_int : int -> t val to_string : t -> string val shrink : t Shrink.t end) = struct module Lin = Lin.Internal [@alert "-internal"] type t = T.t CList.conc_list Atomic.t type int' = T.t type cmd = | Add_node of int' | Member of int' let pp_cmd par fmt x = let open Util.Pp in let pp_int' = of_show T.to_string in match x with | Add_node x -> cst1 pp_int' "Add_node" par fmt x | Member x -> cst1 pp_int' "Member" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int' = map T.of_int nat in oneof [ map (fun x -> Add_node x) int'; map (fun x -> Member x) int' ] let shrink_cmd c = match c with | Add_node i -> Iter.map (fun i -> Add_node i) (T.shrink i) | Member i -> Iter.map (fun i -> Member i) (T.shrink i) type res = | RAdd_node of bool | RMember of bool let pp_res par fmt x = let open Util.Pp in match x with | RAdd_node x -> cst1 pp_bool "RAdd_node" par fmt x | RMember x -> cst1 pp_bool "RMember" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RAdd_node x, RAdd_node y -> equal_bool x y | RMember x, RMember y -> equal_bool x y | _, _ -> false let init () = CList.list_init T.zero let run c r = match c with | Add_node i -> RAdd_node (CList.add_node r i) | Member i -> RMember (CList.member r i) let cleanup _ = () end module Int = struct include Stdlib.Int let of_int (i:int) : t = i let shrink = Shrink.int end module Int64 = struct include Stdlib.Int64 let shrink = Shrink.int64 end multicoretests-0.7/src/neg_tests/lin_internal_tests_domain.ml000066400000000000000000000015351474367232000250250ustar00rootroot00000000000000open Lin_internal_tests_common module RT_int_domain = Lin_domain.Make_internal(RConf_int) [@alert "-internal"] module RT_int64_domain = Lin_domain.Make_internal(RConf_int64) [@alert "-internal"] module CLT_int_domain = Lin_domain.Make_internal(CLConf (Int)) [@alert "-internal"] module CLT_int64_domain = Lin_domain.Make_internal(CLConf (Int64)) [@alert "-internal"] (** This is a driver of the negative tests over the Domain module *) ;; QCheck_base_runner.run_tests_main (let count = 15000 in [RT_int_domain.neg_lin_test ~count ~name:"Lin.Internal ref int test with Domain"; RT_int64_domain.neg_lin_test ~count ~name:"Lin.Internal ref int64 test with Domain"; CLT_int_domain.neg_lin_test ~count ~name:"Lin.Internal CList int test with Domain"; CLT_int64_domain.neg_lin_test ~count ~name:"Lin.Internal CList int64 test with Domain"]) multicoretests-0.7/src/neg_tests/lin_internal_tests_effect.ml000066400000000000000000000132471474367232000250150ustar00rootroot00000000000000open Lin_internal_tests_common (** This is a driver of the negative tests over the Effect module *) (* Q: What constitutes a Fiber-unsafe API? A: Tests that behave differently when run with/without a fiber-based scheduler certainly do. The following raises the Yield effect inside the `run` command. This results in an `Unhandled` exception when running outside a fiber-based scheduler, such as when interpreting these sequentially. *) module RConf_int' = struct include RConf_int type res = | RGet of int | RSet | RAdd of (unit, exn) result | RIncr | RDecr let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RAdd x -> cst1 (pp_result pp_unit pp_exn) "RAdd" par fmt x | RIncr -> cst0 "RIncr" fmt | RDecr -> cst0 "RDecr" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int x y | RSet, RSet -> true | RAdd x, RAdd y -> equal_result equal_unit equal_exn x y | RIncr, RIncr -> true | RDecr, RDecr -> true | _, _ -> false let run c r = match c with | Get -> RGet (Sut_int.get r) | Set i -> (Sut_int.set r i; RSet) | Add i -> (try let tmp = Sut_int.get r in Lin_effect.yield (); Sut_int.set r (tmp+i); RAdd (Ok ()) with exn -> RAdd (Error exn)) | Incr -> (Sut_int.incr r; RIncr) | Decr -> (Sut_int.decr r; RDecr) end module RT_int_effect = Lin_effect.Make_internal(RConf_int) [@alert "-internal"] module RT_int'_effect = Lin_effect.Make_internal(RConf_int') [@alert "-internal"] module RConf_int64' = struct include RConf_int64 type res = | RGet of int64 | RSet | RAdd of (unit, exn) result | RIncr | RDecr let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int64 "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RAdd x -> cst1 (pp_result pp_unit pp_exn) "RAdd" par fmt x | RIncr -> cst0 "RIncr" fmt | RDecr -> cst0 "RDecr" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int64 x y | RSet, RSet -> true | RAdd x, RAdd y -> equal_result equal_unit equal_exn x y | RIncr, RIncr -> true | RDecr, RDecr -> true | _, _ -> false let run c r = match c with | Get -> RGet (Sut_int64.get r) | Set i -> (Sut_int64.set r i; RSet) | Add i -> (try let tmp = Sut_int.get r in Lin_effect.yield (); Sut_int.set r (Int64.add tmp i); RAdd (Ok ()) with exn -> RAdd (Error exn)) | Incr -> (Sut_int64.incr r; RIncr) | Decr -> (Sut_int64.decr r; RDecr) end module RT_int64_effect = Lin_effect.Make_internal(RConf_int64) [@alert "-internal"] module RT_int64'_effect = Lin_effect.Make_internal(RConf_int64') [@alert "-internal"] module CLConf_int' = struct include CLConf(Int) type res = | RAdd_node of (bool, exn) result | RMember of bool let pp_res par fmt x = let open Util.Pp in match x with | RAdd_node x -> cst1 (pp_result pp_bool pp_exn) "RAdd_node" par fmt x | RMember x -> cst1 pp_bool "RMember" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RAdd_node x, RAdd_node y -> equal_result equal_bool equal_exn x y | RMember x, RMember y -> equal_bool x y | _, _ -> false let run c r = match c with | Add_node i -> RAdd_node (try Lin_effect.yield (); Ok (CList.add_node r i) with exn -> Error exn) | Member i -> RMember (CList.member r i) end module CLT_int_effect = Lin_effect.Make_internal(CLConf (Int)) [@alert "-internal"] module CLT_int'_effect = Lin_effect.Make_internal(CLConf_int') [@alert "-internal"] module CLConf_int64' = struct include CLConf(Int64) type res = | RAdd_node of (bool, exn) result | RMember of bool let pp_res par fmt x = let open Util.Pp in match x with | RAdd_node x -> cst1 (pp_result pp_bool pp_exn) "RAdd_node" par fmt x | RMember x -> cst1 pp_bool "RMember" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RAdd_node x, RAdd_node y -> equal_result equal_bool equal_exn x y | RMember x, RMember y -> equal_bool x y | _, _ -> false let run c r = match c with | Add_node i -> RAdd_node (try Lin_effect.yield (); Ok (CList.add_node r i) with exn -> Error exn) | Member i -> RMember (CList.member r i) end module CLT_int64_effect = Lin_effect.Make_internal(CLConf(Int64)) [@alert "-internal"] module CLT_int64'_effect = Lin_effect.Make_internal(CLConf_int64') [@alert "-internal"] ;; QCheck_base_runner.run_tests_main (let count = 20_000 in [ (* We don't expect the first four tests to fail as each `cmd` is completed before a `Yield` *) RT_int_effect.lin_test ~count ~name:"Lin.Internal ref int test with Effect"; RT_int64_effect.lin_test ~count ~name:"Lin.Internal ref int64 test with Effect"; CLT_int_effect.lin_test ~count ~name:"Lin.Internal CList int test with Effect"; CLT_int64_effect.lin_test ~count ~name:"Lin.Internal CList int64 test with Effect"; (* These next four tests are negative - and are expected to fail with exception `Unhandled` *) RT_int'_effect.neg_lin_test ~count ~name:"negative Lin.Internal ref int test with Effect"; RT_int64'_effect.neg_lin_test ~count ~name:"negative Lin.Internal ref int64 test with Effect"; CLT_int'_effect.neg_lin_test ~count ~name:"negative Lin.Internal CList int test with Effect"; CLT_int64'_effect.neg_lin_test ~count ~name:"negative Lin.Internal CList int64 test with Effect" ]) multicoretests-0.7/src/neg_tests/lin_internal_tests_thread_conclist.ml000066400000000000000000000014211474367232000267150ustar00rootroot00000000000000open Lin_internal_tests_common (** This is a driver of the negative CList tests over the Thread module *) module CLT_int_thread = Lin_thread.Make_internal(CLConf (Int)) [@alert "-internal"] module CLT_int64_thread = Lin_thread.Make_internal(CLConf (Int64)) [@alert "-internal"] let _ = if Sys.backend_type = Sys.Bytecode then Printf.printf "Lin.Internal CList tests with Thread disabled under bytecode\n\n%!" else let count = 1000 in QCheck_base_runner.run_tests_main [ CLT_int_thread.lin_test ~count ~name:"Lin.Internal CList int test with Thread"; (* unboxed, hence no allocations to trigger context switch *) CLT_int64_thread.lin_test ~count ~name:"Lin.Internal CList int64 test with Thread" (* not triggering context switch, unfortunately *) ] multicoretests-0.7/src/neg_tests/lin_internal_tests_thread_ref.ml000066400000000000000000000014071474367232000256570ustar00rootroot00000000000000open Lin_internal_tests_common (** This is a driver of the negative ref tests over the Thread module *) module RT_int_thread = Lin_thread.Make_internal(RConf_int) [@alert "-internal"] module RT_int64_thread = Lin_thread.Make_internal(struct include RConf_int64 let shrink_cmd = QCheck.Shrink.nil end ) [@alert "-internal"] ;; if Sys.backend_type = Sys.Bytecode then Printf.printf "Lin.Internal ref tests with Thread disabled under bytecode\n\n%!" else QCheck_base_runner.run_tests_main (let count = 1000 in [RT_int_thread.lin_test ~count ~name:"Lin.Internal ref int test with Thread"; (* unboxed, hence no allocations to trigger context switch *) RT_int64_thread.neg_lin_test ~count:15000 ~name:"Lin.Internal ref int64 test with Thread"]) multicoretests-0.7/src/neg_tests/lin_tests_common.ml000066400000000000000000000053751474367232000231600ustar00rootroot00000000000000open Lin (** ********************************************************************** *) (** Tests of a simple reference *) (** ********************************************************************** *) module Sut_int = struct let init () = ref 0 let get r = !r let set r i = r:=i let add r i = let old = !r in r:= i + old (* buggy: not atomic *) let incr r = add r 1 (* buggy: not atomic *) let decr r = add r (-1) (* buggy: not atomic *) end module Sut_int64 = struct let init () = ref Int64.zero let get r = !r let set r i = r:=i let add r i = let old = !r in r:= Int64.add i old (* buggy: not atomic *) let incr r = add r Int64.one (* buggy: not atomic *) let decr r = add r Int64.minus_one (* buggy: not atomic *) end module Ref_int_spec : Spec = struct type t = int ref let init () = Sut_int.init () let cleanup _ = () let int = nat_small let api = [ val_ "Sut_int.get" Sut_int.get (t @-> returning int); val_ "Sut_int.set" Sut_int.set (t @-> int @-> returning unit); val_ "Sut_int.add" Sut_int.add (t @-> int @-> returning unit); val_ "Sut_int.incr" Sut_int.incr (t @-> returning unit); val_ "Sut_int.decr" Sut_int.decr (t @-> returning unit); ] end module Ref_int64_spec : Spec = struct type t = int64 ref let init () = Sut_int64.init () let cleanup _ = () let int64 = nat64_small let api = [ val_ "Sut_int64.get" Sut_int64.get (t @-> returning int64); val_ "Sut_int64.set" Sut_int64.set (t @-> int64 @-> returning unit); val_ "Sut_int64.add" Sut_int64.add (t @-> int64 @-> returning unit); val_ "Sut_int64.incr" Sut_int64.incr (t @-> returning unit); val_ "Sut_int64.decr" Sut_int64.decr (t @-> returning unit); ] end (** ********************************************************************** *) (** Tests of the buggy concurrent list CList *) (** ********************************************************************** *) module CList_spec_int : Spec = struct type t = int CList.conc_list Atomic.t let init () = CList.list_init 0 let cleanup _ = () let int = nat_small let api = [ val_ "CList.add_node" CList.add_node (t @-> int @-> returning bool); val_ "CList.member" CList.member (t @-> int @-> returning bool); ] end module CList_spec_int64 : Spec = struct type t = int64 CList.conc_list Atomic.t let init () = CList.list_init Int64.zero let cleanup _ = () let int64 = nat64_small let api = [ val_ "CList.add_node" CList.add_node (t @-> int64 @-> returning bool); val_ "CList.member" CList.member (t @-> int64 @-> returning bool); ] end multicoretests-0.7/src/neg_tests/lin_tests_domain.ml000066400000000000000000000013021474367232000231210ustar00rootroot00000000000000open Lin_tests_common module RT_int_domain = Lin_domain.Make(Ref_int_spec) module RT_int64_domain = Lin_domain.Make(Ref_int64_spec) module CLT_int_domain = Lin_domain.Make(CList_spec_int) module CLT_int64_domain = Lin_domain.Make(CList_spec_int64) (** This is a driver of the negative tests over the Domain module *) ;; QCheck_base_runner.run_tests_main (let count = 10000 in [RT_int_domain.neg_lin_test ~count ~name:"Lin ref int test with Domain"; RT_int64_domain.neg_lin_test ~count ~name:"Lin ref int64 test with Domain"; CLT_int_domain.neg_lin_test ~count ~name:"Lin CList int test with Domain"; CLT_int64_domain.neg_lin_test ~count ~name:"Lin CList int64 test with Domain"]) multicoretests-0.7/src/neg_tests/lin_tests_effect.ml000066400000000000000000000077521474367232000231250ustar00rootroot00000000000000open Lin_tests_common open Lin (** This is a driver of the negative tests over the Effect module *) (* Q: What constitutes a Fiber-unsafe API? A: Tests that behave differently when run with/without a fiber-based scheduler certainly do. The following raises the Yield effect inside the `run` command. This results in an `Unhandled` exception when running outside a fiber-based scheduler, such as when interpreting these sequentially. *) module Sut_int' = struct include Sut_int let add r i = let old = !r in Lin_effect.yield (); set r (old+i) end module Ref_int'_spec : Spec = struct type t = int ref let init () = Sut_int'.init () let cleanup _ = () let api = [ val_ "Sut_int'.get" Sut_int'.get (t @-> returning int); val_ "Sut_int'.set" Sut_int'.set (t @-> int @-> returning unit); val_ "Sut_int'.add" Sut_int'.add (t @-> int @-> returning_or_exc unit); val_ "Sut_int'.incr" Sut_int'.incr (t @-> returning unit); val_ "Sut_int'.decr" Sut_int'.decr (t @-> returning unit); ] end module RT_int_effect = Lin_effect.Make(Ref_int_spec) [@alert "-experimental"] module RT_int'_effect = Lin_effect.Make(Ref_int'_spec) [@alert "-experimental"] module Sut_int64' = struct include Sut_int64 let add r i = let old = !r in Lin_effect.yield (); set r (Int64.add old i) end module Ref_int64'_spec : Spec = struct type t = int64 ref let init () = Sut_int64'.init () let cleanup _ = () let api = [ val_ "Sut_int64'.get" Sut_int64'.get (t @-> returning int64); val_ "Sut_int64'.set" Sut_int64'.set (t @-> int64 @-> returning unit); val_ "Sut_int64'.add" Sut_int64'.add (t @-> int64 @-> returning_or_exc unit); val_ "Sut_int64'.incr" Sut_int64'.incr (t @-> returning unit); val_ "Sut_int64'.decr" Sut_int64'.decr (t @-> returning unit); ] end module RT_int64_effect = Lin_effect.Make(Ref_int64_spec) [@alert "-experimental"] module RT_int64'_effect = Lin_effect.Make(Ref_int64'_spec) [@alert "-experimental"] module CList_spec_int' : Spec = struct type t = int CList.conc_list Atomic.t let init () = CList.list_init 0 let cleanup _ = () let add_node r i = Lin_effect.yield (); CList.add_node r i let api = [ val_ "CList.add_node" add_node (t @-> int @-> returning_or_exc bool); val_ "CList.member" CList.member (t @-> int @-> returning bool); ] end module CList_spec_int64' : Spec = struct type t = int64 CList.conc_list Atomic.t let init () = CList.list_init Int64.zero let add_node r i = Lin_effect.yield (); CList.add_node r i let cleanup _ = () let api = [ val_ "CList.add_node" add_node (t @-> int64 @-> returning_or_exc bool); val_ "CList.member" CList.member (t @-> int64 @-> returning bool); ] end module CLT_int_effect = Lin_effect.Make(CList_spec_int) [@alert "-experimental"] module CLT_int'_effect = Lin_effect.Make(CList_spec_int') [@alert "-experimental"] module CLT_int64_effect = Lin_effect.Make(CList_spec_int64) [@alert "-experimental"] module CLT_int64'_effect = Lin_effect.Make(CList_spec_int64') [@alert "-experimental"] ;; QCheck_base_runner.run_tests_main (let count = 20_000 in [ (* We don't expect the first four tests to fail as each `cmd` is completed before a `Yield` *) RT_int_effect.lin_test ~count ~name:"Lin ref int test with Effect"; RT_int64_effect.lin_test ~count ~name:"Lin ref int64 test with Effect"; CLT_int_effect.lin_test ~count ~name:"Lin CList int test with Effect"; CLT_int64_effect.lin_test ~count ~name:"Lin CList int64 test with Effect"; (* These next four tests are negative - and are expected to fail with exception `Unhandled` *) RT_int'_effect.neg_lin_test ~count ~name:"negative Lin ref int test with Effect"; RT_int64'_effect.neg_lin_test ~count ~name:"negative Lin ref int64 test with Effect"; CLT_int'_effect.neg_lin_test ~count ~name:"negative Lin CList int test with Effect"; CLT_int64'_effect.neg_lin_test ~count ~name:"negative Lin CList int64 test with Effect" ]) multicoretests-0.7/src/neg_tests/lin_tests_thread.ml000066400000000000000000000017261474367232000231330ustar00rootroot00000000000000open Lin_tests_common (** This is a driver of the negative tests over the Thread module *) module RT_int_thread = Lin_thread.Make(Ref_int_spec) [@alert "-experimental"] module RT_int64_thread = Lin_thread.Make(Ref_int64_spec) [@alert "-experimental"] module CLT_int_thread = Lin_thread.Make(CList_spec_int) [@alert "-experimental"] module CLT_int64_thread = Lin_thread.Make(CList_spec_int64) [@alert "-experimental"] ;; QCheck_base_runner.run_tests_main (let count = 1000 in [RT_int_thread.lin_test ~count ~name:"Lin ref int test with Thread"; (* unboxed, hence no allocations to trigger context switch *) RT_int64_thread.neg_lin_test ~count:15000 ~name:"Lin ref int64 test with Thread"; CLT_int_thread.lin_test ~count ~name:"Lin CList int test with Thread"; (* unboxed, hence no allocations to trigger context switch *) CLT_int64_thread.lin_test ~count ~name:"Lin CList int64 test with Thread"]) (* not triggering context switch, unfortunately *) multicoretests-0.7/src/neg_tests/stm_tests_conclist.ml000066400000000000000000000040161474367232000235160ustar00rootroot00000000000000open QCheck open STM (** This is a parallel test of the buggy concurrent list CList *) module CLConf (T : sig type t val zero : t val of_int : int -> t val to_string : t -> string end) = struct type cmd = | Add_node of T.t | Member of T.t let pp_cmd par fmt x = let open Util.Pp in let pp_t = of_show T.to_string in match x with | Add_node x -> cst1 pp_t "Add_node" par fmt x | Member x -> cst1 pp_t "Member" par fmt x let show_cmd = Util.Pp.to_show pp_cmd type state = T.t list type sut = T.t CList.conc_list Atomic.t let arb_cmd s = let int_gen = Gen.(map T.of_int nat) in let mem_gen = if s=[] then int_gen else Gen.oneof [int_gen; Gen.oneofl s] in QCheck.make ~print:show_cmd (Gen.oneof [ Gen.map (fun i -> Add_node i) int_gen; Gen.map (fun i -> Member i) mem_gen; ]) let init_state = [ T.zero ] let init_sut () = CList.list_init T.zero let cleanup _ = () let next_state c s = match c with | Add_node i -> i::s | Member _i -> s let run c r = match c with | Add_node i -> Res (bool, CList.add_node r i) | Member i -> Res (bool, CList.member r i) let precond _ _ = true let postcond c s res = match c,res with | Add_node _, Res ((Bool,_),v) -> v = true | Member i, Res ((Bool,_),v) -> v = List.mem i s | _,_ -> false end module Int = struct include Stdlib.Int let of_int (i:int) : t = i end module CLT_int_seq = STM_sequential.Make(CLConf(Int)) module CLT_int_dom = STM_domain.Make(CLConf(Int)) module CLT_int64_seq = STM_sequential.Make(CLConf(Int64)) module CLT_int64_dom = STM_domain.Make(CLConf(Int64)) ;; QCheck_base_runner.run_tests_main (let count = 1000 in [CLT_int_seq.agree_test ~count ~name:"STM int CList test sequential"; CLT_int64_seq.agree_test ~count ~name:"STM int64 CList test sequential"; CLT_int_dom.neg_agree_test_par ~count ~name:"STM int CList test parallel"; CLT_int64_dom.neg_agree_test_par ~count ~name:"STM int64 CList test parallel"]) multicoretests-0.7/src/neg_tests/stm_tests_domain_ref.ml000066400000000000000000000005061474367232000240030ustar00rootroot00000000000000open Stm_tests_spec_ref module RT_int = STM_domain.Make(RConf_int) module RT_int64 = STM_domain.Make(RConf_int64) ;; QCheck_base_runner.run_tests_main [RT_int.neg_agree_test_par ~count:1000 ~name:"STM int ref test parallel"; RT_int64.neg_agree_test_par ~count:1000 ~name:"STM int64 ref test parallel"; ] multicoretests-0.7/src/neg_tests/stm_tests_domain_ref_asym.ml000066400000000000000000000005341474367232000250350ustar00rootroot00000000000000open Stm_tests_spec_ref module RT_int = STM_domain.Make(RConf_int) module RT_int64 = STM_domain.Make(RConf_int64) ;; QCheck_base_runner.run_tests_main [RT_int.neg_agree_test_par_asym ~count:5000 ~name:"STM int ref test parallel asymmetric"; RT_int64.neg_agree_test_par_asym ~count:5000 ~name:"STM int64 ref test parallel asymmetric"; ] multicoretests-0.7/src/neg_tests/stm_tests_sequential_ref.ml000066400000000000000000000005311474367232000247040ustar00rootroot00000000000000open Stm_tests_spec_ref module RT_int_seq = STM_sequential.Make(RConf_int) module RT_int64_seq = STM_sequential.Make(RConf_int64) ;; QCheck_base_runner.run_tests_main (let count = 1000 in [RT_int_seq.agree_test ~count ~name:"STM int ref test sequential"; RT_int64_seq.agree_test ~count ~name:"STM int64 ref test sequential"; ]) multicoretests-0.7/src/neg_tests/stm_tests_spec_ref.ml000066400000000000000000000077041474367232000234750ustar00rootroot00000000000000open QCheck open STM (** This is a parallel test of refs *) module Sut_int = struct let init () = ref 0 let get r = !r let set r i = r:=i let add r i = let old = !r in r:=i + old (* buggy: not atomic *) let incr r = incr r (* buggy: not atomic *) let decr r = decr r (* buggy: not atomic *) end module Sut_int64 = struct let init () = ref Int64.zero let get r = !r let set r i = r:=i let add r i = let old = !r in r:= Int64.add i old (* buggy: not atomic *) let incr r = add r Int64.one (* buggy: not atomic *) let decr r = add r Int64.minus_one (* buggy: not atomic *) end module RConf_int = struct type sut = int ref type state = int type cmd = | Get | Set of int | Add of int | Incr | Decr let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Add x -> cst1 pp_int "Add" par fmt x | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt let show_cmd = Util.Pp.to_show pp_cmd let arb_cmd _s = let int_gen = Gen.nat in let shrink_cmd c = match c with | Set i -> Iter.map (fun i -> Set i) (Shrink.int i) | Add i -> Iter.map (fun i -> Add i) (Shrink.int i) | _ -> Iter.empty in QCheck.make ~print:show_cmd ~shrink:shrink_cmd (Gen.oneof [Gen.return Get; Gen.map (fun i -> Set i) int_gen; Gen.map (fun i -> Add i) int_gen; Gen.return Incr; Gen.return Decr; ]) let init_state = 0 let init_sut () = Sut_int.init () let cleanup _ = () let next_state c s = match c with | Get -> s | Set i -> i (*if i<>1213 then i else s*) (* an artificial fault *) | Add i -> s+i | Incr -> s+1 | Decr -> s-1 let precond _ _ = true let run c r = match c with | Get -> Res (int, Sut_int.get r) | Set i -> Res (unit, Sut_int.set r i) | Add i -> Res (unit, Sut_int.add r i) | Incr -> Res (unit, Sut_int.incr r) | Decr -> Res (unit, Sut_int.decr r) let postcond c (s : state) res = match c,res with | Get, Res ((Int,_),v) -> v = s (*&& v<>42*) (*an injected bug*) | Set _, Res ((Unit,_),_) -> true | Add _, Res ((Unit,_),_) -> true | Incr, Res ((Unit,_),_) -> true | Decr, Res ((Unit,_),_) -> true | _,_ -> false end module RConf_int64 = struct type sut = int64 ref type state = int64 type cmd = | Get | Set of int64 | Add of int64 | Incr | Decr let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int64 "Set" par fmt x | Add x -> cst1 pp_int64 "Add" par fmt x | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt let show_cmd = Util.Pp.to_show pp_cmd let arb_cmd _s = let int64_gen = Gen.(map Int64.of_int nat) in QCheck.make ~print:show_cmd (Gen.oneof [Gen.return Get; Gen.map (fun i -> Set i) int64_gen; Gen.map (fun i -> Add i) int64_gen; Gen.return Incr; Gen.return Decr; ]) let init_state = 0L let init_sut () = Sut_int64.init () let cleanup _ = () let next_state c s = match c with | Get -> s | Set i -> i (*if i<>1213 then i else s*) (* an artificial fault *) | Add i -> Int64.add s i | Incr -> Int64.succ s | Decr -> Int64.pred s let precond _ _ = true let run c r = match c with | Get -> Res (int64, Sut_int64.get r) | Set i -> Res (unit, Sut_int64.set r i) | Add i -> Res (unit, Sut_int64.add r i) | Incr -> Res (unit, Sut_int64.incr r) | Decr -> Res (unit, Sut_int64.decr r) let postcond c s res = match c,res with | Get, Res ((Int64,_),(v:int64)) -> v = s (*&& v<>42L*) (*an injected bug*) | Set _, Res ((Unit,_),_) -> true | Add _, Res ((Unit,_),_) -> true | Incr, Res ((Unit,_),_) -> true | Decr, Res ((Unit,_),_) -> true | _,_ -> false end multicoretests-0.7/src/neg_tests/stm_tests_thread_ref.ml000066400000000000000000000007571474367232000240130ustar00rootroot00000000000000open Stm_tests_spec_ref module RT_int = STM_thread.Make(RConf_int) [@alert "-experimental"] module RT_int64 = STM_thread.Make(RConf_int64) [@alert "-experimental"] ;; if Sys.backend_type = Sys.Bytecode then Printf.printf "STM ref tests with Thread disabled under bytecode\n\n%!" else QCheck_base_runner.run_tests_main [RT_int.agree_test_conc ~count:250 ~name:"STM int ref test with Thread"; RT_int64.neg_agree_test_conc ~count:5000 ~name:"STM int64 ref test with Thread"; ] multicoretests-0.7/src/queue/000077500000000000000000000000001474367232000163715ustar00rootroot00000000000000multicoretests-0.7/src/queue/dune000066400000000000000000000007121474367232000172470ustar00rootroot00000000000000;; Linearization tests of the stdlib Queue library (test (name lin_tests) (modules lin_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) ;(action (run %{test} --verbose)) (action (progn)) ) multicoretests-0.7/src/queue/lin_internal_tests.ml000066400000000000000000000133531474367232000226300ustar00rootroot00000000000000open QCheck module Spec = struct type t = int Queue.t let m = Mutex.create () type cmd = | Add of int | Take | Take_opt | Peek | Peek_opt | Clear | Is_empty | Fold of fct * int | Length and fct = (int -> int -> int) fun_ let pp_cmd par fmt x = let open Util.Pp in let pp_fct = of_show Fn.print in match x with | Add x -> cst1 pp_int "Add" par fmt x | Take -> cst0 "Take" fmt | Take_opt -> cst0 "Take_opt" fmt | Peek -> cst0 "Peek" fmt | Peek_opt -> cst0 "Peek_opt" fmt | Clear -> cst0 "Clear" fmt | Is_empty -> cst0 "Is_empty" fmt | Fold (x, y) -> cst2 pp_fct pp_int "Fold" par fmt x y | Length -> cst0 "Length" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int = nat and fct = (fun2 Observable.int Observable.int QCheck.small_int).gen in oneof [ map (fun x -> Add x) int; pure Take; pure Take_opt; pure Peek; pure Peek_opt; pure Clear; pure Is_empty; map2 (fun x y -> Fold (x, y)) fct int; pure Length; ] let shrink_cmd c = match c with | Take | Take_opt | Peek | Peek_opt | Clear | Is_empty | Length -> Iter.empty | Add i -> Iter.map (fun i -> Add i) (Shrink.int i) | Fold (f,i) -> Iter.( (map (fun f -> Fold (f,i)) (Fn.shrink f)) <+> (map (fun i -> Fold (f,i)) (Shrink.int i))) type res = | RAdd | RTake of (int, exn) result | RTake_opt of int option | RPeek of (int, exn) result | RPeek_opt of int option | RClear | RIs_empty of bool | RFold of int | RLength of int let pp_res par fmt x = let open Util.Pp in match x with | RAdd -> cst0 "RAdd" fmt | RTake x -> cst1 (pp_result pp_int pp_exn) "RTake" par fmt x | RTake_opt x -> cst1 (pp_option pp_int) "RTake_opt" par fmt x | RPeek x -> cst1 (pp_result pp_int pp_exn) "RPeek" par fmt x | RPeek_opt x -> cst1 (pp_option pp_int) "RPeek_opt" par fmt x | RClear -> cst0 "RClear" fmt | RIs_empty x -> cst1 pp_bool "RIs_empty" par fmt x | RFold x -> cst1 pp_int "RFold" par fmt x | RLength x -> cst1 pp_int "RLength" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RAdd, RAdd -> true | RTake x, RTake y -> equal_result equal_int equal_exn x y | RTake_opt x, RTake_opt y -> equal_option equal_int x y | RPeek x, RPeek y -> equal_result equal_int equal_exn x y | RPeek_opt x, RPeek_opt y -> equal_option equal_int x y | RClear, RClear -> true | RIs_empty x, RIs_empty y -> equal_bool x y | RFold x, RFold y -> equal_int x y | RLength x, RLength y -> equal_int x y | _, _ -> false let init () = Queue.create () let cleanup _ = () end module QConf = struct include Spec let run c q = match c with | Add i -> Queue.add i q; RAdd | Take -> RTake (Util.protect Queue.take q) | Take_opt -> RTake_opt (Queue.take_opt q) | Peek -> RPeek (Util.protect Queue.peek q) | Peek_opt -> RPeek_opt (Queue.peek_opt q) | Length -> RLength (Queue.length q) | Is_empty -> RIs_empty (Queue.is_empty q) | Fold (f, a) -> RFold (Queue.fold (Fn.apply f) a q) | Clear -> Queue.clear q; RClear end module QMutexConf = struct include Spec let run c q = match c with | Add i -> Mutex.lock m; Queue.add i q; Mutex.unlock m; RAdd | Take -> Mutex.lock m; let r = Util.protect Queue.take q in Mutex.unlock m; RTake r | Take_opt -> Mutex.lock m; let r = Queue.take_opt q in Mutex.unlock m; RTake_opt r | Peek -> Mutex.lock m; let r = Util.protect Queue.peek q in Mutex.unlock m; RPeek r | Peek_opt -> Mutex.lock m; let r = Queue.peek_opt q in Mutex.unlock m; RPeek_opt r | Length -> Mutex.lock m; let l = Queue.length q in Mutex.unlock m; RLength l | Is_empty -> Mutex.lock m; let b = Queue.is_empty q in Mutex.unlock m; RIs_empty b | Fold (f, a) -> Mutex.lock m; let r = (Queue.fold (Fn.apply f) a q) in Mutex.unlock m; RFold r | Clear -> Mutex.lock m; Queue.clear q; Mutex.unlock m; RClear end module QMT_domain = Lin_domain.Make_internal(QMutexConf) [@alert "-internal"] module QMT_thread = Lin_thread.Make_internal(QMutexConf) [@alert "-internal"] module QT_domain = Lin_domain.Make_internal(QConf) [@alert "-internal"] module QT_thread = Lin_thread.Make_internal(QConf) [@alert "-internal"] ;; QCheck_base_runner.run_tests_main [ QMT_domain.lin_test ~count:1000 ~name:"Lin.Internal Queue test with Domain and mutex"; QMT_thread.lin_test ~count:1000 ~name:"Lin.Internal Queue test with Thread and mutex"; QT_domain.neg_lin_test ~count:1000 ~name:"Lin.Internal Queue test with Domain without mutex"; QT_thread.lin_test ~count:1000 ~name:"Lin.Internal Queue test with Thread without mutex"; ] multicoretests-0.7/src/queue/lin_tests.ml000066400000000000000000000027241474367232000207340ustar00rootroot00000000000000module Queue_spec : Lin.Spec = struct open Lin type t = int Queue.t let init () = Queue.create () let cleanup _ = () let int = int_small let api = [ val_ "Queue.add" Queue.add (int @-> t @-> returning unit); val_ "Queue.take" Queue.take (t @-> returning_or_exc int); val_ "Queue.take_opt" Queue.take_opt (t @-> returning (option int)); val_ "Queue.peek" Queue.peek (t @-> returning_or_exc int); val_ "Queue.peek_opt" Queue.peek_opt (t @-> returning (option int)); val_ "Queue.clear" Queue.clear (t @-> returning unit); val_ "Queue.is_empty" Queue.is_empty (t @-> returning bool); val_ "Queue.length" Queue.length (t @-> returning int); (* val_ "Queue.fold" Queue.fold ... need function type combinator *) ] end module Lin_queue_domain = Lin_domain.Make(Queue_spec) module Lin_queue_thread = Lin_thread.Make(Queue_spec) [@alert "-experimental"] let () = let tests = [ Lin_queue_domain.neg_lin_test ~count:1000 ~name:"Lin Queue test with Domain"; Lin_queue_domain.stress_test ~count:1000 ~name:"Lin Queue stress test with Domain"; Lin_queue_thread.lin_test ~count:250 ~name:"Lin Queue test with Thread"; ] in let tests = if Sys.backend_type = Sys.Bytecode then ( Printf.printf "Lin Queue test with Thread disabled under bytecode\n\n%!"; [ List.hd tests ]) else tests in QCheck_base_runner.run_tests_main tests multicoretests-0.7/src/semaphore/000077500000000000000000000000001474367232000172305ustar00rootroot00000000000000multicoretests-0.7/src/semaphore/dune000066400000000000000000000006351474367232000201120ustar00rootroot00000000000000;; Tests of Semaphore.Counting (test (name stm_tests_counting) (modules stm_tests_counting) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) ;; Tests of Semaphore.Binary (test (name stm_tests_binary) (modules stm_tests_binary) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/semaphore/stm_tests_binary.ml000066400000000000000000000035621474367232000231610ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Semaphore.Binary *) (* Semaphore API these tests will exercise val make : bool -> t val release : t -> unit val acquire : t -> unit val try_acquire : t -> bool *) module SBConf = struct type sut = Semaphore.Binary.t type state = int type cmd = | Release | Acquire | TryAcquire let pp_cmd _ fmt x = let open Util.Pp in match x with | Release -> cst0 "Release" fmt | Acquire -> cst0 "Acquire" fmt | TryAcquire -> cst0 "TryAcquire" fmt let show_cmd = Util.Pp.to_show pp_cmd let init_state = 1 let init_sut () = Semaphore.Binary.make true let cleanup _ = () let arb_cmd s = let cmds = [ Release; TryAcquire; ] in let cmds = if s = 1 then Acquire :: cmds else cmds in QCheck.make ~print:show_cmd (Gen.oneofl cmds) let next_state c s = match c with | Release -> 1 | Acquire -> 0 | TryAcquire -> if s = 1 then 0 else 0 let run c sem = match c with | Release -> Res (unit, Semaphore.Binary.release sem) | Acquire -> Res (unit, Semaphore.Binary.acquire sem) | TryAcquire -> Res (bool, Semaphore.Binary.try_acquire sem) let precond c s = match c with | Acquire -> s = 1 | _ -> true let postcond c s res = match c,res with | Release, Res ((Unit,_), _) | Acquire, Res ((Unit,_), _) -> true | TryAcquire, Res ((Bool,_),r) -> r = (s = 1) | _ -> false end module SBTest_seq = STM_sequential.Make(SBConf) module SBTest_dom = STM_domain.Make(SBConf) let _ = QCheck_base_runner.run_tests_main (let count = 500 in [SBTest_seq.agree_test ~count ~name:"STM Semaphore.Binary test sequential"; SBTest_dom.agree_test_par ~count ~name:"STM Semaphore.Binary test parallel"; ]) multicoretests-0.7/src/semaphore/stm_tests_counting.ml000066400000000000000000000046731474367232000235270ustar00rootroot00000000000000open QCheck open STM (** parallel STM tests of Semaphore.Counting *) (* Semaphore API these tests will exercise val make : int -> t val release : t -> unit val acquire : t -> unit val try_acquire : t -> bool val get_value : t -> int *) module SC = Semaphore.Counting module SCConf = struct type sut = SC.t type state = int type cmd = | Release | Acquire | TryAcquire | GetValue let pp_cmd _ fmt x = let open Util.Pp in match x with | Release -> cst0 "Release" fmt | Acquire -> cst0 "Acquire" fmt | TryAcquire -> cst0 "TryAcquire" fmt | GetValue -> cst0 "GetValue" fmt let show_cmd = Util.Pp.to_show pp_cmd let init_state = 2 let init_sut () = SC.make init_state let cleanup _ = () let arb_cmd s = let cmds = [ Release; TryAcquire; GetValue ] in let cmds = if s > 0 then Acquire :: cmds else cmds in QCheck.make ~print:show_cmd (Gen.oneofl cmds) let next_state c s = match c with | Release -> s+1 | Acquire -> s-1 | TryAcquire -> if s > 0 then s-1 else s | GetValue -> s let run c sem = match c with | Release -> Res (unit, SC.release sem) | Acquire -> Res (unit, SC.acquire sem) | TryAcquire -> Res (bool, SC.try_acquire sem) | GetValue -> Res (int, SC.get_value sem) let precond c s = match c with | Acquire -> s > 0 | _ -> true let postcond c s res = match c,res with | Release, Res ((Unit,_), _) | Acquire, Res ((Unit,_), _) -> true | TryAcquire, Res ((Bool,_),r) -> r = (s > 0) | GetValue, Res ((Int,_),r) -> r = s | _ -> false end module SCTest_seq = STM_sequential.Make(SCConf) module SCTest_dom_gv = STM_domain.Make(SCConf) module SCTest_dom = STM_domain.Make(struct include SCConf let arb_cmd s = let cmds = [ Release; TryAcquire; ] in (* No GetValue *) let cmds = if s > 0 then Acquire :: cmds else cmds in QCheck.make ~print:show_cmd (Gen.oneofl cmds) end) let _ = QCheck_base_runner.run_tests_main (let count = 200 in [SCTest_seq.agree_test ~count ~name:"STM Semaphore.Counting test sequential"; SCTest_dom_gv.agree_test_par ~count ~name:"STM Semaphore.Counting test parallel (w/ get_value)"; SCTest_dom.agree_test_par ~count ~name:"STM Semaphore.Counting test parallel (w/o get_value)"; ]) multicoretests-0.7/src/stack/000077500000000000000000000000001474367232000163525ustar00rootroot00000000000000multicoretests-0.7/src/stack/dune000066400000000000000000000007141474367232000172320ustar00rootroot00000000000000;; Linearization tests of the stdlib Stack module (test (name lin_tests) (modules lin_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) (test (name lin_internal_tests) (modules lin_internal_tests) (package multicoretests) (flags (:standard -w -27)) (libraries qcheck-lin.domain qcheck-lin.thread) ; (action (run %{test} --verbose)) (action (progn)) ) multicoretests-0.7/src/stack/lin_internal_tests.ml000066400000000000000000000132771474367232000226160ustar00rootroot00000000000000open QCheck module Spec = struct type t = int Stack.t let m = Mutex.create () type cmd = | Push of int | Pop | Pop_opt | Top | Top_opt | Clear | Is_empty | Fold of fct * int | Length and fct = (int -> int -> int) fun_ let pp_cmd par fmt x = let open Util.Pp in let pp_fct = of_show Fn.print in match x with | Push x -> cst1 pp_int "Push" par fmt x | Pop -> cst0 "Pop" fmt | Pop_opt -> cst0 "Pop_opt" fmt | Top -> cst0 "Top" fmt | Top_opt -> cst0 "Top_opt" fmt | Clear -> cst0 "Clear" fmt | Is_empty -> cst0 "Is_empty" fmt | Fold (x, y) -> cst2 pp_fct pp_int "Fold" par fmt x y | Length -> cst0 "Length" fmt let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let open QCheck.Gen in let int = nat and fct = (fun2 Observable.int Observable.int QCheck.small_int).gen in oneof [ map (fun x -> Push x) int; pure Pop; pure Pop_opt; pure Top; pure Top_opt; pure Clear; pure Is_empty; map2 (fun x y -> Fold (x, y)) fct int; pure Length; ] let shrink_cmd c = match c with | Pop | Pop_opt | Top | Top_opt | Clear | Is_empty | Length -> Iter.empty | Push i -> Iter.map (fun i -> Push i) (Shrink.int i) | Fold (f,i) -> Iter.( (map (fun f -> Fold (f,i)) (Fn.shrink f)) <+> (map (fun i -> Fold (f,i)) (Shrink.int i))) type res = | RPush | RPop of (int, exn) result | RPop_opt of int option | RTop of (int, exn) result | RTop_opt of int option | RClear | RIs_empty of bool | RFold of int | RLength of int let pp_res par fmt x = let open Util.Pp in match x with | RPush -> cst0 "RPush" fmt | RPop x -> cst1 (pp_result pp_int pp_exn) "RPop" par fmt x | RPop_opt x -> cst1 (pp_option pp_int) "RPop_opt" par fmt x | RTop x -> cst1 (pp_result pp_int pp_exn) "RTop" par fmt x | RTop_opt x -> cst1 (pp_option pp_int) "RTop_opt" par fmt x | RClear -> cst0 "RClear" fmt | RIs_empty x -> cst1 pp_bool "RIs_empty" par fmt x | RFold x -> cst1 pp_int "RFold" par fmt x | RLength x -> cst1 pp_int "RLength" par fmt x let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RPush, RPush -> true | RPop x, RPop y -> equal_result equal_int equal_exn x y | RPop_opt x, RPop_opt y -> equal_option equal_int x y | RTop x, RTop y -> equal_result equal_int equal_exn x y | RTop_opt x, RTop_opt y -> equal_option equal_int x y | RClear, RClear -> true | RIs_empty x, RIs_empty y -> equal_bool x y | RFold x, RFold y -> equal_int x y | RLength x, RLength y -> equal_int x y | _, _ -> false let init () = Stack.create () let cleanup _ = () end module SConf = struct include Spec let run c s = match c with | Push i -> Stack.push i s; RPush | Pop -> RPop (Util.protect Stack.pop s) | Pop_opt -> RPop_opt (Stack.pop_opt s) | Top -> RTop (Util.protect Stack.top s) | Top_opt -> RTop_opt (Stack.top_opt s) | Clear -> Stack.clear s; RClear | Is_empty -> RIs_empty (Stack.is_empty s) | Fold (f, a) -> RFold (Stack.fold (Fn.apply f) a s) | Length -> RLength (Stack.length s) end module SMutexConf = struct include Spec let run c s = match c with | Push i -> Mutex.lock m; Stack.push i s; Mutex.unlock m; RPush | Pop -> Mutex.lock m; let r = Util.protect Stack.pop s in Mutex.unlock m; RPop r | Pop_opt -> Mutex.lock m; let r = Stack.pop_opt s in Mutex.unlock m; RPop_opt r | Top -> Mutex.lock m; let r = Util.protect Stack.top s in Mutex.unlock m; RTop r | Top_opt -> Mutex.lock m; let r = Stack.top_opt s in Mutex.unlock m; RTop_opt r | Clear -> Mutex.lock m; Stack.clear s; Mutex.unlock m; RClear | Is_empty -> Mutex.lock m; let b = Stack.is_empty s in Mutex.unlock m; RIs_empty b | Fold (f, a) -> Mutex.lock m; let r = Stack.fold (Fn.apply f) a s in Mutex.unlock m; RFold r | Length -> Mutex.lock m; let l = Stack.length s in Mutex.unlock m; RLength l end module ST_domain = Lin_domain.Make_internal(SConf) [@alert "-internal"] module ST_thread = Lin_thread.Make_internal(SConf) [@alert "-internal"] module SMT_domain = Lin_domain.Make_internal(SMutexConf) [@alert "-internal"] module SMT_thread = Lin_thread.Make_internal(SMutexConf) [@alert "-internal"] ;; QCheck_base_runner.run_tests_main [ SMT_domain.lin_test ~count:1000 ~name:"Lin.Internal Stack test with Domain and mutex"; SMT_thread.lin_test ~count:1000 ~name:"Lin.Internal Stack test with Thread and mutex"; ST_domain.neg_lin_test ~count:1000 ~name:"Lin.Internal Stack test with Domain without mutex"; ST_thread.lin_test ~count:1000 ~name:"Lin.Internal Stack test with Thread without mutex"; ] multicoretests-0.7/src/stack/lin_tests.ml000066400000000000000000000026641474367232000207200ustar00rootroot00000000000000module Stack_spec : Lin.Spec = struct open Lin type t = int Stack.t let init () = Stack.create () let cleanup _ = () let int = int_small let api = [ val_ "Stack.push" Stack.push (int @-> t @-> returning unit); val_ "Stack.pop" Stack.pop (t @-> returning_or_exc int); val_ "Stack.pop_opt" Stack.pop_opt (t @-> returning (option int)); val_ "Stack.top" Stack.top (t @-> returning_or_exc int); val_ "Stack.top_opt" Stack.top_opt (t @-> returning (option int)); val_ "Stack.clear" Stack.clear (t @-> returning unit); val_ "Stack.is_empty" Stack.is_empty (t @-> returning bool); val_ "Stack.length" Stack.length (t @-> returning int); (* val_ "Stack.fold" Stack.fold (t @-> missing function type in the api ... *) ] end module Stack_domain = Lin_domain.Make(Stack_spec) module Stack_thread = Lin_thread.Make(Stack_spec) [@alert "-experimental"] let () = let tests = [ Stack_domain.neg_lin_test ~count:1000 ~name:"Lin Stack test with Domain"; Stack_domain.stress_test ~count:1000 ~name:"Lin Stack stress test with Domain"; Stack_thread.lin_test ~count:250 ~name:"Lin Stack test with Thread"; ] in let tests = if Sys.backend_type = Sys.Bytecode then ( Printf.printf "Lin Stack test with Thread disabled under bytecode\n\n%!"; [ List.hd tests ]) else tests in QCheck_base_runner.run_tests_main tests multicoretests-0.7/src/statistics/000077500000000000000000000000001474367232000174375ustar00rootroot00000000000000multicoretests-0.7/src/statistics/README.md000066400000000000000000000122311474367232000207150ustar00rootroot00000000000000Statistical tests for development ================================= We try to apply statistics to ensure that potential improvements are indeed improvements. This is harder with non-deterministic behaviour. - To time two versions against eachother [hyperfine](https://github.com/sharkdp/hyperfine) is a nice tool. It takes care of performing repetitions and making a statistical test. - For other kinds of numeric data PHK's [`ministat`](http://web.mit.edu/freebsd/head/usr.bin/ministat/) is handy ([a GitHub copy](https://github.com/cemeyer/ministat-linux)). `ministat` accepts two files of numbers and computes a student T-test. - To compare error rates (number of defects in a production line - or falsified QuickCheck properties!) a statistical z-test is handy. The below walks through an example using the included `z_test.ml`. Statistical tests for thread interpretation ------------------------------------------- This contains a script for performing a statistical test comparing binomial distributions (these have a yes/no answer). Use it by passing 4 command-line parameters: ``` $ z_test.exe 10000 51 10000 44 z-test of two proportions z = 0.719897 Is |z| = |0.719897| > z_alpha2 = 1.960000 ? No, failed to reject null hypothesis ``` Here we give it the count of 10000 trials, with 51 and 44 `yes` outcomes, respectively. The script will then perform a Z-test deciding whether one distribution is statistically significant from the other with 95% confidence. References: https://stats.stackexchange.com/questions/113602/test-if-two-binomial-distributions-are-statistically-different-from-each-other https://en.wikipedia.org/wiki/Test_statistic https://www.itl.nist.gov/div898/handbook/prc/section3/prc33.htm An example in detail -------------------- For example, here is a driver running 10.000 tests and recording how many of them falsifies the tested property. In this case it records how many test inputs falsified the property `int64 ref`s over `Thread`s are sequentially consistent: ```ocaml open QCheck open Lin_tests_common open RT_int64 open Util (** This is a statistics driver of the negative tests over the Thread module *) let count = ref 0 let t = let rep_count = 100 in let seq_len,par_len = 20,15 in Test.make ~count:10_000 ~retries:5 ~name:("Linearizable ref int64 test with Thread") (set_shrink Shrink.nil (arb_cmds_par seq_len par_len)) (fun triple -> try let res = repeat rep_count lin_prop_thread triple in if not res then count := 1 + !count; true with _ -> count := 1 + !count; true) ;; QCheck_runner.run_tests ~verbose:true ([t]) ;; Printf.printf "%i / 10_000\n%!" (!count) ``` As an example, we want to compare `interp_thread` with a `Thread.yield`: ```ocaml let interp_thread sut cs = let cs_arr = Array.of_list cs in let res_arr = Array.map (fun c -> Thread.yield (); Spec.run c sut) cs_arr in List.combine cs (Array.to_list res_arr) ``` which produces the following: ``` random seed: 57832003 generated error fail pass / total time test name [âś“] 10000 0 0 10000 / 10000 586.0s Linearizable ref int64 test with Thread ================================================================================ success (ran 1 tests) 51 / 10_000 ``` with an alternative `interp_thread` implementation using `Thread.delay 2e-9`: ``` let interp_thread sut cs = let cs_arr = Array.of_list cs in let res_arr = Array.map (fun c -> Thread.delay 2e-9; Spec.run c sut) cs_arr in List.combine cs (Array.to_list res_arr) ``` which produces: ``` random seed: 241340313 generated error fail pass / total time test name [âś“] 10000 0 0 10000 / 10000 974.9s Linearizable ref int64 test with Thread ================================================================================ success (ran 1 tests) 44 / 10_000 ``` Writing these as a table: ``` trials succ perc. yield 10_000 51 0.0051 delay2e-9 10_000 44 0.0044 ``` The script now performs the following calculation: ``` H_0: p_yield = p_delay H_A: p_yield <> p_delay 0.0051 - 0.0044 z = ------------------------------------------- = 0.719897 sqrt( p * (1-p) * (1/10000 + 1/10000) ) 10000 * 0.0051 + 10000 * 0.0044 51 + 44 p = ----------------------------------- = --------- = 0.00475 10000 + 10000 20000 ``` To decide whethere the second worse, we compare `|z| = |0.719897| > z_alpha2 = 1.960000` and conclude that there is not statistical significant difference (at 95% confidence). Aspect that have been tested for `Thread` ----------------------------------------- Significance of ... - longer delay? no, delay no better/worse than yield - while-wait? yes, better - extra yields in Thread.create? no - array vs list-alloc? - explicit pair-alloc, non-tail rec: yes, better - tail-rec, with accumulator: no - avoid yield in seq.prefix interp? no worse, slightly higher - avoid pref_obs ref? no worse, slightly higher - significance of repetition with `repeat`? 100 improves 75 improves 50 improves 25 improves 10 improves 1 - ... multicoretests-0.7/src/statistics/dune000066400000000000000000000000341474367232000203120ustar00rootroot00000000000000(executable (name z_test)) multicoretests-0.7/src/statistics/z_test.ml000066400000000000000000000035231474367232000213040ustar00rootroot00000000000000(* usage: z-test 10000 51 10000 44 *) let print_usage_and_exit () = (print_endline "usage: z-test 10000 51 10000 44"; exit 1) let check_and_convert_trials s = try let trials = int_of_string s in if trials < 0 then (Printf.printf "error: negative trial count: %i\n" trials; print_usage_and_exit ()) else if trials = 0 then (Printf.printf "error: trial count is zero: %i\n" trials; print_usage_and_exit ()) else trials with | Failure _ -> print_usage_and_exit () let check_and_convert_succ s = try let succ = int_of_string s in if succ < 0 then (Printf.printf "error: negative success count: %i\n" succ; print_usage_and_exit ()) else succ with | Failure _ -> print_usage_and_exit () let check_consistency trials succ = if trials < succ then (Printf.printf "error: more successes than trials! %i < %i\n" trials succ; print_usage_and_exit ()) ;; if Array.length Sys.argv <> 5 then print_usage_and_exit () ;; let trials1 = check_and_convert_trials Sys.argv.(1) let succ1 = check_and_convert_succ Sys.argv.(2) let trials2 = check_and_convert_trials Sys.argv.(3) let succ2 = check_and_convert_succ Sys.argv.(4) ;; check_consistency trials1 succ1;; check_consistency trials2 succ2;; let trials1 = float_of_int trials1 let succ1 = float_of_int succ1 let trials2 = float_of_int trials2 let succ2 = float_of_int succ2 let p1 = succ1 /. trials1 let p2 = succ2 /. trials2 let p = (succ1 +. succ2) /. (trials1 +. trials2) let z = (p1 -. p2) /. sqrt (p *. (1. -. p) *. ( (1. /. trials1) +. (1. /. trials2) )) let z_alpha2 = 1.96 ;; print_endline "z-test of two proportions";; Printf.printf "z = %f\n%!" z;; Printf.printf "Is |z| = |%f| > z_alpha2 = %f ?\n" z z_alpha2;; if Float.abs z > z_alpha2 then Printf.printf "Yes, null hypothesis rejected\n%!" else Printf.printf "No, failed to reject null hypothesis\n%!" multicoretests-0.7/src/sys/000077500000000000000000000000001474367232000160635ustar00rootroot00000000000000multicoretests-0.7/src/sys/dune000066400000000000000000000002741474367232000167440ustar00rootroot00000000000000;; Test of the Sys library (test (name stm_tests) (modules stm_tests) (package multicoretests) (libraries qcheck-stm.sequential qcheck-stm.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/sys/stm_tests.ml000066400000000000000000000305331474367232000204460ustar00rootroot00000000000000open QCheck open STM module SConf = struct type path = string list type cmd = | File_exists of path | Mkdir of path * string | Rmdir of path * string | Readdir of path | Mkfile of path * string let pp_cmd par fmt x = let open Util.Pp in let pp_path = pp_list pp_string in match x with | File_exists x -> cst1 pp_path "File_exists" par fmt x | Mkdir (x, y) -> cst2 pp_path pp_string "Mkdir" par fmt x y | Rmdir (x, y) -> cst2 pp_path pp_string "Rmdir" par fmt x y | Readdir x -> cst1 pp_path "Readdir" par fmt x | Mkfile (x, y) -> cst2 pp_path pp_string "Mkfile" par fmt x y let show_cmd = Util.Pp.to_show pp_cmd module Map_names = Map.Make (String) type filesys = | Directory of {fs_map: filesys Map_names.t} | File type state = filesys type sut = unit let (/) = Filename.concat let update_map_name map_name k v = Map_names.update k (fun _ -> Some v) map_name (* var gen_existing_path : filesys -> path Gen.t *) let rec gen_existing_path fs = match fs with | File -> Gen.return [] | Directory d -> (match Map_names.bindings d.fs_map with | [] -> Gen.return [] | bindings -> Gen.(oneofl bindings >>= fun (n, sub_fs) -> Gen.oneof [ Gen.return [n]; Gen.map (fun l -> n::l) (gen_existing_path sub_fs)] ) ) (* var gen_existing_pair : filesys -> (path * string) option Gen.t *) let rec gen_existing_pair fs = match fs with | File -> Gen.return None (*failwith "no sandbox directory"*) | Directory d -> (match Map_names.bindings d.fs_map with | [] -> Gen.return None | bindings -> Gen.(oneofl bindings >>= fun (n, sub_fs) -> oneof [ return (Some ([],n)); map (function None -> Some ([],n) | Some (path,name) -> Some (n::path,name)) (gen_existing_pair sub_fs)] ) ) let name_gen = Gen.oneofl ["aaa" ; "bbb" ; "ccc" ; "ddd" ; "eee"] let path_gen s = Gen.(oneof [gen_existing_path s; list_size (int_bound 5) name_gen]) (* can be empty *) let pair_gen s = let fresh_pair_gen = Gen.(pair (list_size (int_bound 5) name_gen)) name_gen in Gen.(oneof [ fresh_pair_gen; (gen_existing_pair s >>= function None -> fresh_pair_gen | Some (p,_) -> map (fun n -> (p,n)) name_gen); (gen_existing_pair s >>= function None -> fresh_pair_gen | Some (p,n) -> return (p,n)); ]) let arb_cmd s = QCheck.make ~print:show_cmd Gen.(oneof [ map (fun path -> File_exists path) (path_gen s); map (fun (path,new_dir_name) -> Mkdir (path, new_dir_name)) (pair_gen s); map (fun (path,delete_dir_name) -> Rmdir (path, delete_dir_name)) (pair_gen s); map (fun path -> Readdir path) (path_gen s); map (fun (path,new_file_name) -> Mkfile (path, new_file_name)) (pair_gen s); ]) let sandbox_root = "_sandbox" let init_state = Directory {fs_map = Map_names.empty} let rec find_opt_model fs path = match fs with | File -> if path = [] then Some fs else None | Directory d -> (match path with | [] -> Some (Directory d) | hd :: tl -> (match Map_names.find_opt hd d.fs_map with | None -> None | Some fs -> find_opt_model fs tl)) let mem_model fs path = find_opt_model fs path <> None let rec mkdir_model fs path new_dir_name = match fs with | File -> fs | Directory d -> (match path with | [] -> let new_dir = Directory {fs_map = Map_names.empty} in Directory {fs_map = Map_names.add new_dir_name new_dir d.fs_map} | next_in_path :: tl_path -> (match Map_names.find_opt next_in_path d.fs_map with | None -> fs | Some sub_fs -> let nfs = mkdir_model sub_fs tl_path new_dir_name in if nfs = sub_fs then fs else let new_map = Map_names.remove next_in_path d.fs_map in let new_map = Map_names.add next_in_path nfs new_map in Directory {fs_map = new_map})) let readdir_model fs path = match find_opt_model fs path with | None -> None | Some fs -> (match fs with | File -> None | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map [])) let rec rmdir_model fs path delete_dir_name = match fs with | File -> fs | Directory d -> (match path with | [] -> (match Map_names.find_opt delete_dir_name d.fs_map with | Some (Directory target) when Map_names.is_empty target.fs_map -> Directory {fs_map = Map_names.remove delete_dir_name d.fs_map} | None | Some File | Some (Directory _) -> fs) | next_in_path :: tl_path -> (match Map_names.find_opt next_in_path d.fs_map with | None -> fs | Some sub_fs -> let nfs = rmdir_model sub_fs tl_path delete_dir_name in if nfs = sub_fs then fs else Directory {fs_map = (update_map_name d.fs_map next_in_path nfs)})) let rec mkfile_model fs path new_file_name = match fs with | File -> fs | Directory d -> (match path with | [] -> let new_file = File in Directory {fs_map = Map_names.add new_file_name new_file d.fs_map} | next_in_path :: tl_path -> (match Map_names.find_opt next_in_path d.fs_map with | None -> fs | Some sub_fs -> let nfs = mkfile_model sub_fs tl_path new_file_name in if nfs = sub_fs then fs else Directory {fs_map = update_map_name d.fs_map next_in_path nfs})) let next_state c fs = match c with | File_exists _path -> fs | Mkdir (path, new_dir_name) -> if mem_model fs (path @ [new_dir_name]) then fs else mkdir_model fs path new_dir_name | Rmdir (path,delete_dir_name) -> if mem_model fs (path @ [delete_dir_name]) then rmdir_model fs path delete_dir_name else fs | Readdir _path -> fs | Mkfile (path, new_file_name) -> if mem_model fs (path @ [new_file_name]) then fs else mkfile_model fs path new_file_name let init_sut () = try Sys.mkdir sandbox_root 0o700 with Sys_error msg when msg = sandbox_root ^ ": File exists" -> () let cleanup _ = match Sys.os_type with | "Cygwin" | "Unix" -> ignore (Sys.command ("rm -r " ^ Filename.quote sandbox_root)) | "Win32" -> ignore (Sys.command ("rd /s /q " ^ Filename.quote sandbox_root)) | v -> failwith ("Sys tests not working with " ^ v) let precond _c _s = true let p path = (List.fold_left (/) sandbox_root path) let mkfile filepath = let flags = [Open_wronly; Open_creat; Open_excl] in Out_channel.with_open_gen flags 0o666 filepath (fun _ -> ()) let run c _file_name = match c with | File_exists path -> Res (bool, Sys.file_exists (p path)) | Mkdir (path, new_dir_name) -> Res (result unit exn, protect (Sys.mkdir ((p path) / new_dir_name)) 0o755) | Rmdir (path, delete_dir_name) -> Res (result unit exn, protect (Sys.rmdir) ((p path) / delete_dir_name)) | Readdir path -> Res (result (array string) exn, protect (Sys.readdir) (p path)) | Mkfile (path, new_file_name) -> Res (result unit exn, protect mkfile (p path / new_file_name)) let fs_is_a_dir fs = match fs with | Directory _ -> true | File -> false let path_is_a_dir fs path = match find_opt_model fs path with | None -> false | Some target_fs -> fs_is_a_dir target_fs let postcond c (fs: filesys) res = match c, res with | File_exists path, Res ((Bool,_),b) -> b = mem_model fs path | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [new_dir_name]) in (match res with | Error err -> (match err with | Sys_error s -> (s = (p complete_path) ^ ": Permission denied") || (s = (p complete_path) ^ ": File exists" && mem_model fs complete_path) || ((s = (p complete_path) ^ ": No such file or directory" || s = (p complete_path) ^ ": Invalid argument") && not (mem_model fs path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) then s = (p complete_path) ^ ": No such file or directory" else s = (p complete_path) ^ ": Not a directory" | _ -> false) | Ok () -> mem_model fs path && path_is_a_dir fs path && not (mem_model fs complete_path)) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [delete_dir_name]) in (match res with | Error err -> (match err with | Sys_error s -> (s = (p complete_path) ^ ": Permission denied") || (s = (p complete_path) ^ ": Directory not empty" && not (readdir_model fs complete_path = Some [])) || (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) (* if not a directory *) then s = (p complete_path) ^ ": Invalid argument" else s = (p complete_path) ^ ": Not a directory" | _ -> false) | Ok () -> mem_model fs complete_path && path_is_a_dir fs complete_path && readdir_model fs complete_path = Some []) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Error err -> (match err with | Sys_error s -> (s = (p path) ^ ": Permission denied") || (s = (p path) ^ ": No such file or directory" && not (mem_model fs path)) || if Sys.win32 && not (path_is_a_dir fs path) (* if not a directory *) then s = (p path) ^ ": Invalid argument" else s = (p path) ^ ": Not a directory" | _ -> false) | Ok array_of_subdir -> (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) if Sys.win32 && not (mem_model fs path) then array_of_subdir = [||] else (mem_model fs path && path_is_a_dir fs path && (match readdir_model fs path with | None -> false | Some l -> List.sort String.compare l = List.sort String.compare (Array.to_list array_of_subdir)))) | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> ( let complete_path = path @ [ new_file_name ] in let concatenated_path = p complete_path in let match_msg err msg = err = concatenated_path ^ ": " ^ msg in let match_msgs err = List.exists (match_msg err) in let msgs_already_exists = ["File exists"; "Permission denied"] (* Permission denied: seen (sometimes?) on Windows *) and msgs_non_existent_dir = ["No such file or directory"; "Invalid argument"; "Permission denied"] (* Invalid argument: seen on macOS Permission denied: seen on Windows *) and msg_path_not_dir = match Sys.os_type with | "Cygwin" | "Unix" -> "Not a directory" | "Win32" -> "No such file or directory" | v -> failwith ("Sys tests not working with " ^ v) in match res with | Error err -> ( match err with | Sys_error s -> (mem_model fs complete_path && match_msgs s msgs_already_exists) || (not (mem_model fs path) && match_msgs s msgs_non_existent_dir) || (not (path_is_a_dir fs path) && match_msg s msg_path_not_dir) | _ -> false) | Ok () -> path_is_a_dir fs path && not (mem_model fs complete_path)) | _,_ -> false end let run_cmd cmd = let ic = Unix.open_process_in cmd in let os = In_channel.input_line ic in ignore (Unix.close_process_in ic); os let uname_os () = run_cmd "uname -s" module Sys_seq = STM_sequential.Make(SConf) module Sys_dom = STM_domain.Make(SConf) ;; QCheck_base_runner.run_tests_main [ Sys_seq.agree_test ~count:1000 ~name:"STM Sys test sequential"; if Sys.unix && uname_os () = Some "Linux" then Sys_dom.agree_test_par ~count:200 ~name:"STM Sys test parallel" else Sys_dom.neg_agree_test_par ~count:2500 ~name:"STM Sys test parallel"; Sys_dom.stress_test_par ~count:1000 ~name:"STM Sys stress test parallel"; ] multicoretests-0.7/src/thread/000077500000000000000000000000001474367232000165145ustar00rootroot00000000000000multicoretests-0.7/src/thread/dune000066400000000000000000000006341474367232000173750ustar00rootroot00000000000000;; Tests of the stdlib Domain library ;; Tests of Domain's spawn functionality (non-STM) (test (name thread_joingraph) (modules thread_joingraph) (package multicoretests) (libraries threads qcheck-core util) (action (run %{test} --verbose)) ) (test (name thread_createtree) (modules thread_createtree) (package multicoretests) (libraries threads qcheck-core util) (action (run %{test} --verbose)) ) multicoretests-0.7/src/thread/thread_createtree.ml000066400000000000000000000044731474367232000225300ustar00rootroot00000000000000(** This tests the Thread module's create/join primitives. *) (* Idea: generate a series of spawn trees: Create / | | \ / | | \ / | | \ Incr Create Incr Create / | \ | / | \ | / | \ | Incr Incr Incr Decr Each tree is interpreted over Thread: - [Create] call [Thread.create] for each child - [Incr] and [Decr] call [Atomic.incr] and [Atomic.decr], respectively *) open QCheck type cmd = | Incr | Decr (*| Join*) | Create of cmd list let rec pp_cmd par fmt x = let open Util.Pp in match x with | Incr -> cst0 "Incr" fmt | Decr -> cst0 "Decr" fmt | Create x -> cst1 (pp_list pp_cmd) "Create" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen max_height max_degree = let height_gen = Gen.int_bound max_height in let degree_gen = Gen.int_bound max_degree in Gen.sized_size height_gen @@ Gen.fix (fun rgen n -> match n with | 0 -> Gen.oneofl [Incr;Decr] | _ -> Gen.oneof [ Gen.oneofl [Incr;Decr]; Gen.map (fun ls -> Create ls) (Gen.list_size degree_gen (rgen (n-1))) ]) let rec shrink_cmd = function | Incr | Decr -> Iter.empty | Create cs -> let open Iter in (return Incr) <+> (map (fun cs' -> Create cs') (Shrink.list_elems shrink_cmd cs)) <+> (map (fun cs' -> Create cs') (Shrink.list_spine cs)) let rec interp s = function | Incr -> succ s | Decr -> pred s | Create cs -> List.fold_left (fun s' c -> interp s' c) s cs let rec thread_interp a = function | Incr -> Atomic.incr a | Decr -> Atomic.decr a | Create cs -> let ts = List.map (fun c -> Thread.create (fun () -> thread_interp a c) ()) cs in List.iter Thread.join ts let t ~max_height ~max_degree = Test.make ~name:"thread_createtree - with Atomic" ~count:1000 ~retries:100 (make ~print:show_cmd ~shrink:shrink_cmd (gen max_height max_degree)) (fun c -> (*Printf.printf "%s\n%!" (show_cmd c);*) let a = Atomic.make 0 in let () = thread_interp a c in Atomic.get a = interp 0 c) let test = if Sys.word_size == 64 then t ~max_height:5 ~max_degree:10 else t ~max_height:3 ~max_degree:3 ;; QCheck_base_runner.run_tests_main [test] multicoretests-0.7/src/thread/thread_joingraph.ml000066400000000000000000000113371474367232000223630ustar00rootroot00000000000000(** Generate direct tests of the Thread module's create/join primitives. It does so by generating a random, acyclic dependency graph of [create]d [Thread.t]s each waiting to [join] with its dependency. *) open QCheck (* Generates a sparse DAG of join dependencies *) (* Each thread is represented by record with an optional array index to model at most 1 dependency each *) (* This example DAG A/0 <--- B/1 ^. \ `- C/2 <--- D/3 is represented as: [| {dep=None ...}; {dep=Some 0 ...}; {dep=Some 0 ...}; {dep=Some 2 ...} |] Since each thread can only be joined once, A/0 is joined by B/1 (not C/2) *) type work_kind = Atomic_incr | Tak | Gc_minor type node = { dep : int option; work : work_kind } type test_input = { num_threads : int; dependencies : node array } let gen_deps gen_work n st = Array.init n (fun i -> let dep = if i<>0 && Gen.bool st then Some (Gen.int_bound (i-1) st) else None in let work = gen_work st in { dep; work }) let show_work_kind w = match w with | Atomic_incr -> "Atomic_incr" | Tak -> "Tak" | Gc_minor -> "Gc_minor" let pp_work_kind = Util.Pp.of_show show_work_kind let pp_node par fmt {dep;work} = let open Util.Pp in pp_record par fmt [ pp_field "dep" (pp_option pp_int) dep; pp_field "work" pp_work_kind work; ] let pp_test_input par fmt { num_threads; dependencies } = let open Util.Pp in pp_record par fmt [ pp_field "num_threads" pp_int num_threads; pp_field "dependencies" (pp_array pp_node) dependencies; ] let show_test_input = Util.Pp.to_show pp_test_input let shrink_node n = Iter.map (fun opt -> { n with dep = opt}) (Shrink.(option nil) n.dep) let shrink_deps test_input = let ls = Array.to_list test_input.dependencies in let is = Shrink.list ~shrink:shrink_node ls in Iter.map (fun deps -> let len = List.length deps in let arr = Array.of_list deps in let deps = Array.mapi (fun i j_node -> let dep = match i,j_node.dep with | 0, _ | _,None -> None | _,Some 0 -> Some 0 | _, Some j -> if j<0 || j>=len || j>=i (* ensure reduced dep is valid *) then Some ((j + i) mod i) else Some j in { j_node with dep }) arr in { num_threads=len; dependencies=deps }) is let arb_deps gen_work thread_bound = let gen_deps = Gen.(int_bound (thread_bound-1) >>= fun num_threads -> let num_threads = succ num_threads in gen_deps gen_work num_threads >>= fun dependencies -> return { num_threads; dependencies }) in make ~print:show_test_input ~shrink:shrink_deps gen_deps (*let thread_id id i = Printf.sprintf "(thread %i, index %i)" id i*) let is_first_with_dep i dep deps = [] = List.filteri (fun j node -> j < i && node.dep = Some dep) (Array.to_list deps) (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let work () = for _ = 1 to 100 do assert (7 = tak 18 12 6); done let a = Atomic.make 0 let interp_work w = match w with | Atomic_incr -> Atomic.incr a | Tak -> work () | Gc_minor -> Gc.minor () let build_dep_graph test_input = let rec build i thread_acc = if i=test_input.num_threads then List.rev thread_acc else let p = (match test_input.dependencies.(i).dep with | None -> Thread.create (fun () -> interp_work test_input.dependencies.(i).work ) () | Some dep -> Thread.create (fun () -> interp_work test_input.dependencies.(i).work; (*f();*) if is_first_with_dep i dep test_input.dependencies then let p' = List.nth thread_acc (i-1-dep) in Thread.join p'; ) ()) in build (i+1) (p::thread_acc) in build 0 [] let test_arb_work ~thread_bound = Test.make ~name:"Thread.create/join" ~count:100 (arb_deps (Gen.frequencyl [(10,Atomic_incr); (10,Tak); (1,Gc_minor)]) thread_bound) (fun test_input -> Atomic.set a 0; let ps = build_dep_graph test_input in List.iteri (fun i p -> if not (Array.exists (fun n -> n.dep = Some i) test_input.dependencies) then Thread.join p) ps; Atomic.get a = Array.fold_left (fun a n -> if n.work = Atomic_incr then 1+a else a) 0 test_input.dependencies) let bound_arb = if Sys.word_size == 64 then 100 else 16 ;; QCheck_base_runner.run_tests_main [test_arb_work ~thread_bound:bound_arb; ] multicoretests-0.7/src/threadomain/000077500000000000000000000000001474367232000175405ustar00rootroot00000000000000multicoretests-0.7/src/threadomain/dune000066400000000000000000000003171474367232000204170ustar00rootroot00000000000000;; Tests of the interactions between Threads and Domains (test (name threadomain) (modules threadomain) (package multicoretests) (libraries util qcheck-core threads) (action (run %{test} --verbose)) ) multicoretests-0.7/src/threadomain/threadomain.ml000066400000000000000000000133741474367232000223750ustar00rootroot00000000000000open QCheck2 (* We mix domains and threads. We use the name _node_ for either a domain or a thread *) (** Generate a permutation of [0..sz-1] *) let permutation sz = Gen.shuffle_a (Array.init sz (fun x -> x)) (** Generate a tree of size nodes The tree is represented as an array [a] of integers, [a.(i)] being the parent of node [i]. Node [0] is the root of the tree. *) let tree sz = let open Gen in let rec aux a i = if i == 0 then ( a.(i) <- -1 ; pure a ) else ( let* v = int_bound (i-1) in a.(i) <- v ; aux a (i-1) ) in aux (Array.make sz 0) (sz-1) type worktype = Burn | Tak of int let pp_worktype par fmt x = let open Util.Pp in match x with Burn -> cst0 "Burn" fmt | Tak x -> cst1 pp_int "Tak" par fmt x (** A test of spawn and join [spawn_tree] describes which domain/thread should spawn which other domains/threads [join_permutation] maps nodes to their position in the [join_tree] [join_tree] describes which domain/thread should wait on which other domains/threads [domain_or] describes whether a given node is a domain (true) or a thread (false) All those arrays should be of the same length, maybe an array of tuples would be a better choice, but make harder to read *) type spawn_join = { spawn_tree: int array; join_permutation: int array; join_tree: int array; domain_or: bool array; workload: worktype array } let pp_spawn_join par fmt { spawn_tree; join_permutation; join_tree; domain_or; workload } = let open Util.Pp in pp_record par fmt [ pp_field "spawn_tree" (pp_array pp_int) spawn_tree; pp_field "join_permutation" (pp_array pp_int) join_permutation; pp_field "join_tree" (pp_array pp_int) join_tree; pp_field "domain_or" (pp_array pp_bool) domain_or; pp_field "workload" (pp_array pp_worktype) workload; ] let show_spawn_join = Util.Pp.to_show pp_spawn_join (* Ensure that any domain is higher up in the join tree than all its threads, so that we cannot have a thread waiting on its domain even indirectly *) let fix_permutation sz sj = let swap arr i j = let x = arr.(i) in arr.(i) <- arr.(j) ; arr.(j) <- x in let rec dom_of_thd i = let candidate = sj.spawn_tree.(i) in if candidate = -1 || sj.domain_or.(candidate) then candidate else dom_of_thd candidate in for i = 0 to sz-1 do if not sj.domain_or.(i) then let i' = sj.join_permutation.(i) in let d = dom_of_thd i in let d' = if d = -1 then d else sj.join_permutation.(d) in if d' > i' then swap sj.join_permutation i d done ; sj let build_spawn_join sz spawn_tree join_permutation join_tree domain_or workload = fix_permutation sz { spawn_tree; join_permutation; join_tree; domain_or; workload } let worktype = let open Gen in oneof [pure Burn; map (fun i -> Tak i) (int_bound 200)] let gen_spawn_join sz = let open Gen in build_spawn_join sz <$> tree sz <*> permutation sz <*> tree sz <*> array_size (pure sz) (frequencyl [(4, false); (1, true)]) <*> array_size (pure sz) worktype type handle = | NoHdl | DomainHdl of unit Domain.t | ThreadHdl of Thread.t (* All the node handles. Since they’ll be used to join, they are stored in join_permutation order *) type handles = { handles: handle array; available: Semaphore.Binary.t array } let global = Atomic.make 0 let join_one hdls i = Semaphore.Binary.acquire hdls.available.(i) ; ( match hdls.handles.(i) with | NoHdl -> failwith "Semaphore acquired but no handle to join" | DomainHdl h -> ( Domain.join h ; hdls.handles.(i) <- NoHdl ) | ThreadHdl h -> ( Thread.join h ; hdls.handles.(i) <- NoHdl ) ) (** In this first test each spawned domain calls [work] - and then optionally join. *) (* a simple work item, from ocaml/testsuite/tests/misc/takc.ml *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let rec burn l = if List.hd l > 12 then () else burn (l @ l |> List.map (fun x -> x + 1)) let work w = match w with | Burn -> burn [8] | Tak i -> for _ = 1 to i do assert (7 = tak 18 12 6); done let rec spawn_one sj hdls i = hdls.handles.(sj.join_permutation.(i)) <- if sj.domain_or.(i) then DomainHdl (Domain.spawn (run_node sj hdls i)) else ThreadHdl (Thread.create (run_node sj hdls i) ()) ; Semaphore.Binary.release hdls.available.(sj.join_permutation.(i)) and run_node sj hdls i () = let sz = Array.length sj.spawn_tree in (* spawn nodes *) for j = i+1 to sz-1 do if sj.spawn_tree.(j) == i then spawn_one sj hdls j done ; Atomic.incr global ; work sj.workload.(i) ; (* join nodes *) let i' = sj.join_permutation.(i) in for j = i'+1 to sz-1 do if sj.join_tree.(j) == i' then join_one hdls j done let run_all_nodes sj = Atomic.set global 0 ; let sz = Array.length sj.spawn_tree in let hdls = { handles = Array.make sz NoHdl; available = Array.init sz (fun _ -> Semaphore.Binary.make false) } in spawn_one sj hdls 0; join_one hdls 0; (* all the nodes should have been joined now *) Array.for_all (fun h -> h = NoHdl) hdls.handles && Atomic.get global = sz let nb_nodes = let max = if Sys.word_size == 64 then 100 else 16 in Gen.int_range 2 max let main_test = Test.make ~name:"Mash up of threads and domains" ~count:500 ~print:show_spawn_join (Gen.sized_size nb_nodes gen_spawn_join) run_all_nodes (* to debug deadlocks: *) (* (Util.fork_prop_with_timeout 1 run_all_nodes) *) let _ = QCheck_base_runner.run_tests_main [ main_test ] multicoretests-0.7/src/weak/000077500000000000000000000000001474367232000161745ustar00rootroot00000000000000multicoretests-0.7/src/weak/dune000066400000000000000000000026551474367232000170620ustar00rootroot00000000000000;; Test of the weak array library (test (name stm_tests_weak_seq) (modules stm_tests_weak_spec stm_tests_weak_seq) (package multicoretests) (libraries qcheck-stm.sequential) (action (run %{test} --verbose)) ) (test (name stm_tests_weak_par) (modules stm_tests_weak_spec stm_tests_weak_par) (package multicoretests) (libraries qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name stm_tests_weak_par_stress) (modules stm_tests_weak_spec stm_tests_weak_par_stress) (package multicoretests) (libraries qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name stm_tests_hashset_seq) (modules stm_tests_hashset_spec stm_tests_hashset_seq) (package multicoretests) (libraries qcheck-stm.sequential) (action (run %{test} --verbose)) ) (test (name stm_tests_hashset_par) (modules stm_tests_hashset_spec stm_tests_hashset_par) (package multicoretests) (libraries qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name stm_tests_hashset_par_stress) (modules stm_tests_hashset_spec stm_tests_hashset_par_stress) (package multicoretests) (libraries qcheck-stm.domain) (action (run %{test} --verbose)) ) (test (name lin_tests) (modules lin_tests) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) (test (name lin_tests_hashset) (modules lin_tests_hashset) (package multicoretests) (libraries qcheck-lin.domain) (action (run %{test} --verbose)) ) multicoretests-0.7/src/weak/lin_tests.ml000066400000000000000000000022361474367232000205350ustar00rootroot00000000000000(* ********************************************************************** *) (* Lin Tests [Weak] *) (* ********************************************************************** *) module WConf = struct type t = int64 Weak.t let weak_size = 16 let init () = Weak.create weak_size let cleanup _ = () open Lin let int,int64 = nat_small,nat64_small let api = [ val_ "Weak.length" Weak.length (t @-> returning int); val_ "Weak.set" Weak.set (t @-> int @-> option int64 @-> returning_or_exc unit); val_ "Weak.get" Weak.get (t @-> int @-> returning_or_exc (option int64)); val_ "Weak.get_copy" Weak.get_copy (t @-> int @-> returning_or_exc (option int64)); val_ "Weak.check" Weak.check (t @-> int @-> returning_or_exc bool); val_ "Weak.fill" Weak.fill (t @-> int @-> int @-> option int64 @-> returning_or_exc unit); (*val blit : 'a t -> int -> 'a t -> int -> int -> unit *) ] end module WT_domain = Lin_domain.Make(WConf) ;; QCheck_base_runner.run_tests_main [ WT_domain.stress_test ~count:1000 ~name:"Lin Weak stress test with Domain"; ] multicoretests-0.7/src/weak/lin_tests_hashset.ml000066400000000000000000000027771474367232000222660ustar00rootroot00000000000000(* ********************************************************************** *) (* Lin tests of [Weak Hashset] *) (* ********************************************************************** *) module WHSConf = struct module WHS = Weak.Make(String) type t = WHS.t let weak_size = 16 let init () = WHS.create weak_size let cleanup t = WHS.clear t open Lin let string = string_small let api = [ val_ "Weak.S.clear" WHS.clear (t @-> returning unit); val_ "Weak.S.merge" WHS.merge (t @-> string @-> returning_or_exc string); val_ "Weak.S.add" WHS.add (t @-> string @-> returning_or_exc unit); val_ "Weak.S.remove" WHS.remove (t @-> string @-> returning_or_exc unit); val_ "Weak.S.find" WHS.find (t @-> string @-> returning_or_exc string); val_ "Weak.S.find_opt" WHS.find_opt (t @-> string @-> returning_or_exc (option string)); val_ "Weak.S.find_all" WHS.find_all (t @-> string @-> returning_or_exc (list string)); val_ "Weak.S.mem" WHS.mem (t @-> string @-> returning_or_exc bool); (*val iter : (data -> unit) -> t -> unit*) (*val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a*) val_ "Weak.S.count" WHS.count (t @-> returning int); (*val stats : t -> int * int * int * int * int * int*) ] end module WHST_domain = Lin_domain.Make(WHSConf) ;; QCheck_base_runner.run_tests_main [ WHST_domain.stress_test ~count:1000 ~name:"Lin Weak HashSet stress test with Domain"; ] multicoretests-0.7/src/weak/stm_tests_hashset_par.ml000066400000000000000000000003761474367232000231420ustar00rootroot00000000000000(** parallel STM tests of Weak hashsets *) module WeakHashsetSTM_dom = STM_domain.Make(Stm_tests_hashset_spec) let _ = QCheck_base_runner.run_tests_main [ WeakHashsetSTM_dom.neg_agree_test_par ~count:5000 ~name:"STM Weak HashSet test parallel" ] multicoretests-0.7/src/weak/stm_tests_hashset_par_stress.ml000066400000000000000000000004111474367232000245330ustar00rootroot00000000000000(** parallel STM stress tests of Weak hashsets *) module WeakHashsetSTM_dom = STM_domain.Make(Stm_tests_hashset_spec) let _ = QCheck_base_runner.run_tests_main [ WeakHashsetSTM_dom.stress_test_par ~count:1000 ~name:"STM Weak HashSet stress test parallel" ] multicoretests-0.7/src/weak/stm_tests_hashset_seq.ml000066400000000000000000000003761474367232000231500ustar00rootroot00000000000000(** sequential STM tests of Weak hashsets *) module WeakHashsetSTM_seq = STM_sequential.Make(Stm_tests_hashset_spec) let _ = QCheck_base_runner.run_tests_main [ WeakHashsetSTM_seq.agree_test ~count:1000 ~name:"STM Weak HashSet test sequential" ] multicoretests-0.7/src/weak/stm_tests_hashset_spec.ml000066400000000000000000000130231474367232000233030ustar00rootroot00000000000000open QCheck open STM (** STM specification of Weak hashsets *) type cmd = | Clear | Merge of data | Add of data | Remove of data | Mem of data (*val iter : (data -> unit) -> t -> unit*) (*val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a*) | Find of data | Find_opt of data | Find_all of data | Count | Stats and data = int64 let pp_cmd par fmt x = let open Util.Pp in let pp_data = pp_int64 in match x with | Clear -> cst0 "Clear" fmt | Merge x -> cst1 pp_data "Merge" par fmt x | Add x -> cst1 pp_data "Add" par fmt x | Remove x -> cst1 pp_data "Remove" par fmt x | Mem x -> cst1 pp_data "Mem" par fmt x | Find x -> cst1 pp_data "Find" par fmt x | Find_opt x -> cst1 pp_data "Find_opt" par fmt x | Find_all x -> cst1 pp_data "Find_all" par fmt x | Count -> cst0 "Count" fmt | Stats -> cst0 "Stats" fmt let show_cmd = Util.Pp.to_show pp_cmd type state = data list module Int64 = struct [@@@warning "-unused-value-declaration"] (* support Int64.hash added in 5.1, without triggering an 'unused hash' error *) external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc] let hash x = seeded_hash_param 10 100 0 x include Stdlib.Int64 end module WHS = Weak.Make(Int64) type sut = WHS.t let shrink_data d = Shrink.int64 d let _shrink_cmd c = match c with | Clear -> Iter.empty | Merge d -> Iter.map (fun d -> Merge d) (shrink_data d) | Add d -> Iter.map (fun d -> Add d) (shrink_data d) | Remove d -> Iter.map (fun d -> Remove d) (shrink_data d) | Find d -> Iter.map (fun d -> Find d) (shrink_data d) | Find_opt d -> Iter.map (fun d -> Find_opt d) (shrink_data d) | Find_all d -> Iter.map (fun d -> Find_all d) (shrink_data d) | Mem d -> Iter.map (fun d -> Mem d) (shrink_data d) | Count -> Iter.empty | Stats -> Iter.empty let arb_cmd s = let data_gen = match s with | [] -> Gen.(map Int64.of_int small_int) | _::_ -> Gen.(oneof [oneofl s; map Int64.of_int small_int]) in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(frequency [ 1,return Clear; 1,map (fun d -> Merge d) data_gen; 1,map (fun d -> Add d) data_gen; 1,map (fun d -> Remove d) data_gen; 1,map (fun d -> Find d) data_gen; 1,map (fun d -> Find_opt d) data_gen; 1,map (fun d -> Find_all d) data_gen; 1,map (fun d -> Mem d) data_gen; 3,return Count; 2,return Stats; ]) let init_state = [] let rec remove_first d s = match s with | [] -> s | d'::s' -> if d=d' then s' else d'::(remove_first d s') let next_state c s = match c with | Clear -> [] | Merge d -> if List.mem d s then s else d::s | Add d -> d::s | Remove d -> remove_first d s | Find _ | Find_opt _ | Find_all _ | Mem _ | Count | Stats -> s let weak_size = 16 (* The SUT state is GC dependent - run a minor GC to have a clean starting point *) let init_sut () = Gc.minor (); WHS.create weak_size let cleanup _ = () let precond c _s = match c with | _ -> true type _ ty += Tup6 : 'a ty * 'b ty * 'c ty * 'd ty * 'e ty * 'f ty -> ('a * 'b * 'c * 'd * 'e * 'f) ty let tup6 spec_a spec_b spec_c spec_d spec_e spec_f = let (ty_a,show_a) = spec_a in let (ty_b,show_b) = spec_b in let (ty_c,show_c) = spec_c in let (ty_d,show_d) = spec_d in let (ty_e,show_e) = spec_e in let (ty_f,show_f) = spec_f in (Tup6 (ty_a,ty_b,ty_c,ty_d,ty_e,ty_f), QCheck.Print.tup6 show_a show_b show_c show_d show_e show_f) let run c hs = match c with | Clear -> Res (unit, WHS.clear hs) | Merge d -> Res (result int64 exn, protect (WHS.merge hs) d) | Add d -> Res (result unit exn, protect (WHS.add hs) d) | Remove d -> Res (result unit exn, protect (WHS.remove hs) d) | Find d -> Res (result int64 exn, protect (WHS.find hs) d) | Find_opt d -> Res (result (option int64) exn, protect (WHS.find_opt hs) d) | Find_all d -> Res (result (list int64) exn, protect (WHS.find_all hs) d) | Mem d -> Res (result bool exn, protect (WHS.mem hs) d) | Count -> Res (int, WHS.count hs) | Stats -> Res (tup6 int int int int int int, WHS.stats hs) let postcond c (s:data list) res = match c, res with | Clear, Res ((Unit,_),()) -> true | Merge d, Res ((Result (Int64,Exn),_),r) -> (match r with | Error e -> e = Invalid_argument "index out of bounds" | Ok r -> if List.mem d s then r = d else r == d) | Add _, Res ((Result (Unit,Exn),_),r) -> r = Error (Invalid_argument "index out of bounds") || r = Ok () | Remove _, Res ((Result (Unit,Exn),_),r) -> r = Error (Invalid_argument "index out of bounds") || r = Ok () | Find d, Res ((Result (Int64,Exn),_),r) -> r = Error (Invalid_argument "index out of bounds") || r = Error Not_found || (List.mem d s && r = Ok d) | Find_opt d, Res ((Result (Option Int64,Exn),_),r) -> r = Error (Invalid_argument "index out of bounds") || r = Ok None || r = Ok (Some d) | Find_all d, Res ((Result (List Int64,Exn),_),r) -> (match r with | Error e -> e = Invalid_argument "index out of bounds" | Ok r -> List.for_all (fun d' -> d' = d) r) | Mem d, Res ((Result (Bool,Exn),_),r) -> r = Error (Invalid_argument "index out of bounds") || r = Ok (List.mem d s) || r = Ok false | Count, Res ((Int,_),r) -> r <= List.length s | Stats, Res ((Tup6 (Int,Int,Int,Int,Int,Int),_),r) -> let (len,entries,sum,smallest,median,biggest) = r in len = weak_size && entries <= List.length s && sum >= 0 && smallest >= 0 && median >= 0 && biggest >= 0 | _,_ -> false multicoretests-0.7/src/weak/stm_tests_weak_par.ml000066400000000000000000000003431474367232000224240ustar00rootroot00000000000000(** parallel STM tests of Weak arrays *) module WeakSTM_dom = STM_domain.Make(Stm_tests_weak_spec) let _ = QCheck_base_runner.run_tests_main [ WeakSTM_dom.neg_agree_test_par ~count:5000 ~name:"STM Weak test parallel" ] multicoretests-0.7/src/weak/stm_tests_weak_par_stress.ml000066400000000000000000000003561474367232000240330ustar00rootroot00000000000000(** parallel stress STM tests of Weak arrays *) module WeakSTM_dom = STM_domain.Make(Stm_tests_weak_spec) let _ = QCheck_base_runner.run_tests_main [ WeakSTM_dom.stress_test_par ~count:1000 ~name:"STM Weak stress test parallel" ] multicoretests-0.7/src/weak/stm_tests_weak_seq.ml000066400000000000000000000003431474367232000224320ustar00rootroot00000000000000(** sequential STM tests of Weak arrays *) module WeakSTM_seq = STM_sequential.Make(Stm_tests_weak_spec) let _ = QCheck_base_runner.run_tests_main [ WeakSTM_seq.agree_test ~count:1000 ~name:"STM Weak test sequential" ] multicoretests-0.7/src/weak/stm_tests_weak_spec.ml000066400000000000000000000071641474367232000226040ustar00rootroot00000000000000open QCheck open STM (** STM specification of Weak arrays *) type cmd = | Length | Set of int * data option | Get of int | Get_copy of int | Check of int | Fill of int * int * data option and data = int64 let pp_cmd par fmt x = let open Util.Pp in match x with | Length -> cst0 "Length" fmt | Set (x, y) -> cst2 pp_int (pp_option pp_int64) "Set" par fmt x y | Get x -> cst1 pp_int "Get" par fmt x | Get_copy x -> cst1 pp_int "Get_copy" par fmt x | Check x -> cst1 pp_int "Check" par fmt x | Fill (x, y, z) -> cst3 pp_int pp_int (pp_option pp_int64) "Fill" par fmt x y z let show_cmd = Util.Pp.to_show pp_cmd type state = data option list type sut = data Weak.t let _shrink_cmd c = match c with | Length -> Iter.empty | Set (i, d_opt) -> Iter.map (fun i -> Set (i,d_opt)) (Shrink.int i) | Get i -> Iter.map (fun i -> Get i) (Shrink.int i) | Get_copy i -> Iter.map (fun i -> Get_copy i) (Shrink.int i) | Check i -> Iter.map (fun i -> Check i) (Shrink.int i) | Fill (i,j,d_opt) -> Iter.(map (fun i -> Fill (i,j,d_opt)) (Shrink.int i) <+> map (fun j -> Fill (i,j,d_opt)) (Shrink.int j)) let arb_cmd s = let int_gen = Gen.(oneof [small_nat; int_bound (List.length s - 1)]) in let int64_gen = Gen.(map Int64.of_int small_int) in QCheck.make ~print:show_cmd (*~shrink:shrink_cmd*) Gen.(frequency [ 1,return Length; 1,map2 (fun i c -> Set (i,c)) int_gen (option int64_gen); 2,map (fun i -> Get i) int_gen; 2,map (fun i -> Get_copy i) int_gen; 2,map (fun i -> Check i) int_gen; 1,map3 (fun i len c -> Fill (i,len,c)) int_gen int_gen (option int64_gen); (* hack: reusing int_gen for length *) ]) let weak_size = 16 let init_state = List.init weak_size (fun _ -> None) let next_state c s = match c with | Length -> s | Set (i,c) -> List.mapi (fun j c' -> if i=j then c else c') s | Get _ -> s | Get_copy _ -> s | Check _ -> s | Fill (i,l,c) -> if i >= 0 && l >= 0 && i+l-1 < List.length s then List.mapi (fun j c' -> if i <= j && j <= i+l-1 then c else c') s else s let init_sut () = Gc.minor (); Weak.create weak_size let cleanup _ = () let precond c _s = match c with | _ -> true let run c a = match c with | Length -> Res (int, Weak.length a) | Set (i,c) -> Res (result unit exn, protect (Weak.set a i) c) | Get i -> Res (result (option int64) exn, protect (Weak.get a) i) | Get_copy i -> Res (result (option int64) exn, protect (Weak.get_copy a) i) | Check i -> Res (result bool exn, protect (Weak.check a) i) | Fill (i,l,c) -> Res (result unit exn, protect (Weak.fill a i l) c) let postcond c (s:int64 option list) res = match c, res with | Length, Res ((Int,_),i) -> i = List.length s | Set (i,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "Weak.set") else r = Ok () | Get i, Res ((Result (Option Int64,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "Weak.get") else r = Ok (List.nth s i) | Get_copy i, Res ((Result (Option Int64,Exn),_), r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "Weak.get_copy") else r = Ok (List.nth s i) | Check i, Res ((Result (Bool,Exn),_),r) -> if i < 0 || i >= List.length s then r = Error (Invalid_argument "Weak.check") else r = Ok (None <> List.nth s i) | Fill (i,l,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "Weak.fill") else r = Ok () | _, _ -> false multicoretests-0.7/test/000077500000000000000000000000001474367232000154355ustar00rootroot00000000000000multicoretests-0.7/test/cleanup_lin.ml000066400000000000000000000037701474367232000202670ustar00rootroot00000000000000open QCheck (** This is a variant of refs to test for exactly one cleanup per init (no double cleanup, no missing cleanup) *) let cleanup_counter = Atomic.make 0 module RConf = struct exception Already_cleaned type status = Inited | Cleaned type cmd = Get | Set of int | Add of int let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Add x -> cst1 pp_int "Add" par fmt x let show_cmd = Util.Pp.to_show pp_cmd type t = (status ref) * (int ref) let gen_cmd = let int_gen = Gen.nat in (Gen.oneof [Gen.return Get; Gen.map (fun i -> Set i) int_gen; Gen.map (fun i -> Add i) int_gen; ]) let shrink_cmd = Shrink.nil let init () = Atomic.incr cleanup_counter ; (ref Inited, ref 0) let cleanup (status,_) = Atomic.decr cleanup_counter ; if !status = Cleaned then raise Already_cleaned else status := Cleaned type res = RGet of int | RSet | RAdd let pp_res par fmt x = let open Util.Pp in match x with | RGet x -> cst1 pp_int "RGet" par fmt x | RSet -> cst0 "RSet" fmt | RAdd -> cst0 "RAdd" fmt let show_res = Util.Pp.to_show pp_res let equal_res x y = let open Util.Equal in match (x, y) with | RGet x, RGet y -> equal_int x y | RSet, RSet -> true | RAdd, RAdd -> true | _, _ -> false let run c (_,r) = match c with | Get -> RGet (!r) | Set i -> (r:=i; RSet) | Add i -> (let old = !r in r := i + old; RAdd) (* buggy: not atomic *) end module RT = Lin_domain.Make_internal(RConf) [@alert "-internal"] ;; Test.check_exn (let seq_len,par_len = 20,15 in Test.make ~count:1000 ~name:("exactly one-cleanup test") (RT.arb_cmds_triple seq_len par_len) (fun input -> try ignore (RT.lin_prop input); Atomic.get cleanup_counter = 0 with | RConf.Already_cleaned -> failwith "Already cleaned" | _ -> Atomic.get cleanup_counter = 0 )) multicoretests-0.7/test/cleanup_stm.ml000066400000000000000000000046251474367232000203100ustar00rootroot00000000000000open QCheck open STM exception Cleanup_without_init exception Already_cleaned exception Random_postcond_failure type status = Inited | Cleaned let status = ref None (* global ref to keep track of cleanup/init status *) (** This is a variant of refs to test for missing and double cleanup *) module RConf = struct type cmd = Get | Set of int | Add of int let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Add x -> cst1 pp_int "Add" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let int_gen = Gen.nat in (Gen.oneof [Gen.return Get; Gen.map (fun i -> Set i) int_gen; Gen.map (fun i -> Add i) int_gen; ]) let arb_cmd _ = make ~print:show_cmd gen_cmd type state = int let init_state = 0 let next_state c s = match c with | Get -> s | Set i -> i | Add i -> s+i type sut = int ref let init_sut () = assert (!status = None || !status = Some Cleaned); status := Some Inited; ref 0 let cleanup _ = match !status with | None -> raise Cleanup_without_init | Some Cleaned -> raise Already_cleaned | Some Inited -> status := Some Cleaned let run c r = match c with | Get -> Res (int, !r) | Set i -> Res (unit, (r:=i)) | Add i -> Res (unit, let old = !r in r := i + old) (* buggy: not atomic *) let precond _ _ = true let postcond c (s:state) res = match c,res with | Get, Res ((Int,_),r) -> if r>70 then raise Random_postcond_failure; r = s | Set _, Res ((Unit,_),_) | Add _, Res ((Unit,_),_) -> true | _,_ -> false end module RT_seq = STM_sequential.Make(RConf) module RT_dom = STM_domain.Make(RConf) let rand = Random.State.make_self_init () let i = ref 0 ;; for _i=1 to 250 do try Test.check_exn ~rand (RT_seq.agree_test ~count:1000 ~name:"STM ensure cleanup test sequential") with _e -> incr i; assert (!status = Some Cleaned); done; assert (!i = 250); Printf.printf "STM ensure cleanup: sequential test OK\n%!"; (* reset things *) i := 0; status := None; for _i=1 to 100 do try Test.check_exn ~rand (Test.make ~count:1000 ~name:"STM ensure cleanup test parallel" (RT_dom.arb_cmds_triple 20 12) RT_dom.agree_prop_par) (* without retries *) with _e -> incr i; assert (!status = Some Cleaned); done; assert (!i = 100); Printf.printf "STM ensure cleanup: parallel test OK\n%!"; multicoretests-0.7/test/dune000066400000000000000000000055331474367232000163210ustar00rootroot00000000000000;; Internal tests (test (name util_print_test) (modules util_print_test) (package qcheck-multicoretests-util) (libraries qcheck-multicoretests-util)) (test (name util_pp) (modules util_pp) (package qcheck-multicoretests-util) (libraries qcheck-core qcheck-multicoretests-util) (action (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=0" (setenv MCTUTILS_TRUNCATE "" (run %{dep:util_pp.exe}))))) (rule (alias runtest) (package qcheck-multicoretests-util) (action (progn (with-outputs-to util_pp_trunc150.output (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=0" (setenv MCTUTILS_TRUNCATE 150 (run %{dep:util_pp.exe})))) (diff? util_pp_trunc150.expected util_pp_trunc150.output)))) (rule (alias runtest) (package qcheck-multicoretests-util) (action (progn (with-outputs-to util_pp_trunc79.output (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=0" (setenv MCTUTILS_TRUNCATE 79 (run %{dep:util_pp.exe})))) (diff? util_pp_trunc79.expected util_pp_trunc79.output)))) (rule (alias runtest) (package qcheck-multicoretests-util) (action (progn (with-outputs-to util_pp_trunc5.output (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=0" (setenv MCTUTILS_TRUNCATE 5 (run %{dep:util_pp.exe})))) (diff? util_pp_trunc5.expected util_pp_trunc5.output)))) (executable (name cleanup_lin) (modules cleanup_lin) (libraries qcheck-lin.domain) (enabled_if (>= %{ocaml_version} 5))) (rule (alias runtest) (package qcheck-lin) (action (run %{exe:cleanup_lin.exe} --verbose)) (enabled_if (>= %{ocaml_version} 5))) (executable (name cleanup_stm) (modules cleanup_stm) (libraries qcheck-stm.sequential qcheck-stm.domain) (enabled_if (>= %{ocaml_version} 5))) (rule (alias runtest) (package qcheck-stm) (action (run %{exe:cleanup_stm.exe} --verbose)) (enabled_if (>= %{ocaml_version} 5))) (rule (enabled_if (and (= %{arch_sixtyfour} true) (>= %{ocaml_version} 5))) (action (copy mutable_set_v5.expected.64 mutable_set_v5.expected))) (rule (enabled_if (and (= %{arch_sixtyfour} false) (>= %{ocaml_version} 5))) (action (copy mutable_set_v5.expected.32 mutable_set_v5.expected))) (rule (enabled_if (and (= %{arch_sixtyfour} true) (< %{ocaml_version} 5))) (action (copy mutable_set_v4.expected.64 mutable_set_v5.expected))) (rule (enabled_if (and (= %{arch_sixtyfour} false) (< %{ocaml_version} 5))) (action (copy mutable_set_v4.expected.32 mutable_set_v5.expected))) (test (name mutable_set_v5) (modules mutable_set_v5) (package qcheck-stm) (libraries qcheck-stm.sequential threads.posix) (action (with-accepted-exit-codes 1 (setenv OCAMLRUNPARAM "%{env:OCAMLRUNPARAM=b},v=0" (run ./%{test} --seed 229109553))))) (test (name stm_next_state_exc) (modules stm_next_state_exc) (package qcheck-stm) (libraries qcheck-stm.sequential qcheck-stm.domain) (enabled_if (>= %{ocaml_version} 5))) multicoretests-0.7/test/mutable_set_v4.expected.32000066400000000000000000000011701474367232000223170ustar00rootroot00000000000000 random seed: 229109553 --- Failure -------------------------------------------------------------------- Test STM sequential tests failed (9 shrink steps): Add (-923247292) Remove (-923247292) Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM sequential tests: Results incompatible with model Add (-923247292) : () Remove (-923247292) : Some (-923247292) Cardinal : 1 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) multicoretests-0.7/test/mutable_set_v4.expected.64000066400000000000000000000012531474367232000223260ustar00rootroot00000000000000 random seed: 229109553 --- Failure -------------------------------------------------------------------- Test STM sequential tests failed (11 shrink steps): Add (-3576245632788335623) Remove (-3576245632788335623) Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM sequential tests: Results incompatible with model Add (-3576245632788335623) : () Remove (-3576245632788335623) : Some (-3576245632788335623) Cardinal : 1 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) multicoretests-0.7/test/mutable_set_v5.expected.32000066400000000000000000000011701474367232000223200ustar00rootroot00000000000000 random seed: 229109553 --- Failure -------------------------------------------------------------------- Test STM sequential tests failed (2 shrink steps): Add (-286715106) Remove (-286715106) Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM sequential tests: Results incompatible with model Add (-286715106) : () Remove (-286715106) : Some (-286715106) Cardinal : 1 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) multicoretests-0.7/test/mutable_set_v5.expected.64000066400000000000000000000012351474367232000223270ustar00rootroot00000000000000 random seed: 229109553 --- Failure -------------------------------------------------------------------- Test STM sequential tests failed (6 shrink steps): Add 3036269937054427589 Remove 3036269937054427589 Cardinal +++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Messages for test STM sequential tests: Results incompatible with model Add 3036269937054427589 : () Remove 3036269937054427589 : Some (3036269937054427589) Cardinal : 1 ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) multicoretests-0.7/test/mutable_set_v5.ml000066400000000000000000000065331474367232000207140ustar00rootroot00000000000000module type S = sig type elt type t val empty : unit -> t val mem : elt -> t -> bool val add : elt -> t -> unit val cardinal : t -> int val remove : elt -> t -> elt option end module Lib : sig module Make : functor (Ord : Set.OrderedType) -> S with type elt = Ord.t end = struct module Make (Ord : Set.OrderedType) = struct module S = Set.Make (Ord) type elt = Ord.t type t = { mutable content : S.t; mutable cardinal : int; mutex : Mutex.t} let empty () = { content = S.empty; cardinal = 0; mutex = Mutex.create () } let mem_non_lock a t = S.mem a t.content let mem a t = Mutex.lock t.mutex; let b = mem_non_lock a t in Mutex.unlock t.mutex; b let add a t = Mutex.lock t.mutex; if not (mem_non_lock a t) then begin t.content <- S.add a t.content; t.cardinal <- t.cardinal + 1; end; Mutex.unlock t.mutex let cardinal t = Mutex.lock t.mutex; let c = t.cardinal in Mutex.unlock t.mutex; c let remove a t = Mutex.lock t.mutex; let r = if mem_non_lock a t then begin t.content <- S.remove a t.content; (* t.cardinal <- t.cardinal - 1; *) Some a end else None in Mutex.unlock t.mutex; r end end open QCheck open STM module Lib_spec : Spec = struct module S = Lib.Make (Int) type sut = S.t let init_sut () = S.empty () let cleanup _ = () type cmd = Mem of int | Add of int | Cardinal | Remove of int let pp_cmd par fmt x = let open Util.Pp in match x with | Mem x -> cst1 pp_int "Mem" par fmt x | Add x -> cst1 pp_int "Add" par fmt x | Cardinal -> cst0 "Cardinal" fmt | Remove x -> cst1 pp_int "Remove" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let run cmd sut = match cmd with | Mem i -> Res (bool, S.mem i sut) | Add i -> Res (unit, S.add i sut) | Cardinal -> Res (int, S.cardinal sut) | Remove i -> Res (option int, S.remove i sut) type state = int list let init_state = [] let next_state cmd state = match cmd with | Mem _ -> state | Add i -> if List.mem i state then state else i :: state | Cardinal -> state | Remove i -> if List.mem i state then List.filter (fun x -> x <> i) state else state let precond _cmd _state = true let postcond cmd state res = match cmd, res with | Mem i, Res ((Bool,_), b) -> b = List.mem i state | Cardinal, Res ((Int,_), l) -> l = List.length state | Add _, Res ((Unit,_),_) -> true | Remove i, Res ((Option Int, _), Some x) -> List.mem i state && i = x | Remove i, Res ((Option Int, _), None) -> not (List.mem i state) | _ -> false let arb_cmd state = let gen = match state with | [] -> Gen.int | xs -> Gen.(oneof [oneofl xs; int]) in QCheck.make ~print:show_cmd (QCheck.Gen.oneof [Gen.return Cardinal; Gen.map (fun i -> Mem i) gen; Gen.map (fun i -> Add i) gen; Gen.map (fun i -> Remove i) gen; ]) end module Lib_sequential = STM_sequential.Make(Lib_spec) let _ = QCheck_base_runner.run_tests_main [Lib_sequential.agree_test ~count:100 ~name:"STM sequential tests"] multicoretests-0.7/test/stm_next_state_exc.ml000066400000000000000000000047201474367232000216720ustar00rootroot00000000000000open QCheck open STM exception Random_next_state_failure (** This is a variant of refs to test for exceptions in next_state *) module RConf = struct type cmd = Get | Set of int | Add of int let pp_cmd par fmt x = let open Util.Pp in match x with | Get -> cst0 "Get" fmt | Set x -> cst1 pp_int "Set" par fmt x | Add x -> cst1 pp_int "Add" par fmt x let show_cmd = Util.Pp.to_show pp_cmd let gen_cmd = let int_gen = Gen.nat in (Gen.oneof [Gen.return Get; Gen.map (fun i -> Set i) int_gen; Gen.map (fun i -> Add i) int_gen; ]) let arb_cmd _ = make ~print:show_cmd gen_cmd type state = int let init_state = 0 let next_state c s = match c with | Get -> s | Set i -> i | Add i -> if i>70 then raise Random_next_state_failure; s+i type sut = int ref let init_sut () = ref 0 let cleanup _ = () let run c r = match c with | Get -> Res (int, !r) | Set i -> Res (unit, (r:=i)) | Add i -> Res (unit, let old = !r in r := i + old) (* buggy: not atomic *) let precond _ _ = true let postcond c (s:state) res = match c,res with | Get, Res ((Int,_),r) -> r = s | Set _, Res ((Unit,_),_) | Add _, Res ((Unit,_),_) -> true | _,_ -> false end module RT_int = STM.Internal.Make(RConf)[@alert "-internal"] module RT_seq = STM_sequential.Make(RConf) module RT_dom = STM_domain.Make(RConf) let () = QCheck_base_runner.set_seed 301717275 let _ = QCheck_base_runner.run_tests ~verbose:true [RT_int.consistency_test ~count:1000 ~name:"STM test exception during next_state consistency"] let () = (* raises Test_error not handled by neg_agree_test so handled explicitly *) let name = "STM test exception during next_state sequential" in try Test.check_exn (RT_seq.agree_test ~count:1000 ~name); Printf.printf "%s unexpectedly succeeded\n%!" name; with Test.Test_error (err_name,_,Random_next_state_failure,_) -> assert (err_name = name); Printf.printf "%s failed with Random_next_state_failure as expected\n%!" name let () = (* raises Test_error not handled by neg_agree_test so handled explicitly *) let name = "STM test exception during next_state parallel" in try Test.check_exn (RT_dom.agree_test_par ~count:1000 ~name); Printf.printf "%s unexpectedly succeeded\n%!" name; with Test.Test_error (err_name,_,Random_next_state_failure,_) -> assert (err_name = name); Printf.printf "%s failed with Random_next_state_failure as expected\n%!" name multicoretests-0.7/test/util_pp.expected000066400000000000000000000130141474367232000206330ustar00rootroot00000000000000Test of pp_bool: true Test of pp_int (positive): 12345 Test of pp_int (negative): -12345 Test of pp_int32 (positive): 12345l Test of pp_int64 (negative): -12345L Test of pp_float (infinity): infinity Test of pp_float (pi): 3.14159265359 Test of pp_char (printable): 'a' Test of pp_char (unprintable): '\000' Test of pp_string: "Hello world" Test of pp_string (long): "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" Test of pp_bytes (empty): "" Test of pp_bytes (long): "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" Test of pp_option pp_int (positive): Some 12345 Test of pp_option pp_int (negative): Some (-12345) Test of pp_result pp_int pp_string: Ok (-12345) Test of pp_result pp_int pp_string: Error "Failure" Test of pp_pair pp_char pp_int: ('a', -12345) Test of pp_list pp_int: [1; 2; 3; -1; -2; -3] Test of pp_list pp_int (long): [1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3] Test of pp_seq pp_int: <-5; -4; -3; -2; -1; 0; 1; 2; 3; 4; 5> Test of pp_seq pp_int (long): <-50; -49; -48; -47; -46; -45; -44; -43; -42; -41; -40; -39; -38; -37; -36; -35; -34; -33; -32; -31; -30; -29; -28; -27; -26; -25; -24; -23; -22; -21; -20; -19; -18; -17; -16; -15; -14; -13; -12; -11; -10; -9; -8; -7; -6; -5; -4; -3; -2; -1; 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40; 41; 42; 43; 44; 45; 46; 47; 48; 49; 50> Test of pp_array pp_int: [|1; 2; 3; -1; -2; -3|] Test of pp_array pp_int (long): [|0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0|] Test of pp_record: { key = 123; value = "content" } Test of pp_fun_: {(Some (-123456), 'a', "xyz") -> true; (None, 'b', "") -> true; _ -> true} multicoretests-0.7/test/util_pp.ml000066400000000000000000000041631474367232000174470ustar00rootroot00000000000000(* Tests of Util.Pp *) open Util.Pp let pr name pp x = Printf.printf "Test of %s:\n%s\n\n" name (to_show pp x) let seq_interval x y () = let rec aux i = let open Seq in if i <= y then Cons (i, fun () -> aux (i + 1)) else Nil in aux x let fun_val () = let open QCheck in let bool = set_gen (Gen.return true) bool in (* fix co-domain/range across RNGs *) let gen = fun3 Observable.(option int) Observable.char Observable.string bool in let fun_ = Gen.generate1 gen.gen in let _ = Fn.apply fun_ (Some (-123456)) 'a' "xyz" in let _ = Fn.apply fun_ None 'b' "" in fun_ let _ = pr "pp_bool" pp_bool true; pr "pp_int (positive)" pp_int 12345; pr "pp_int (negative)" pp_int (-12345); pr "pp_int32 (positive)" pp_int32 12345l; pr "pp_int64 (negative)" pp_int64 (-12345L); pr "pp_float (infinity)" pp_float Float.infinity; pr "pp_float (pi)" pp_float Float.pi; pr "pp_char (printable)" pp_char 'a'; pr "pp_char (unprintable)" pp_char '\000'; pr "pp_string" pp_string "Hello world"; pr "pp_string (long)" pp_string (String.make 1234 'a'); pr "pp_bytes (empty)" pp_bytes Bytes.empty; pr "pp_bytes (long)" pp_bytes (Bytes.make 1234 'b'); pr "pp_option pp_int (positive)" (pp_option pp_int) (Some 12345); pr "pp_option pp_int (negative)" (pp_option pp_int) (Some (-12345)); pr "pp_result pp_int pp_string" (pp_result pp_int pp_string) (Ok (-12345)); pr "pp_result pp_int pp_string" (pp_result pp_int pp_string) (Error "Failure"); pr "pp_pair pp_char pp_int" (pp_pair pp_char pp_int) ('a', -12345); let l = [ 1; 2; 3; -1; -2; -3 ] in pr "pp_list pp_int" (pp_list pp_int) l; let l = l @ l @ l @ l in let l = l @ l @ l @ l in let l = l @ l @ l @ l in pr "pp_list pp_int (long)" (pp_list pp_int) l; pr "pp_seq pp_int" (pp_seq pp_int) (seq_interval (-5) 5); pr "pp_seq pp_int (long)" (pp_seq pp_int) (seq_interval (-50) 50); pr "pp_array pp_int" (pp_array pp_int) [| 1; 2; 3; -1; -2; -3 |]; pr "pp_array pp_int (long)" (pp_array pp_int) (Array.make 100 0); pr "pp_record" pp_record [ pp_field "key" pp_int 123; pp_field "value" pp_string "content" ]; pr "pp_fun_" pp_fun_ (fun_val ()) multicoretests-0.7/test/util_pp_trunc150.expected000066400000000000000000000034661474367232000223060ustar00rootroot00000000000000Test of pp_bool: true Test of pp_int (positive): 12345 Test of pp_int (negative): -12345 Test of pp_int32 (positive): 12345l Test of pp_int64 (negative): -12345L Test of pp_float (infinity): infinity Test of pp_float (pi): 3.14159265359 Test of pp_char (printable): 'a' Test of pp_char (unprintable): '\000' Test of pp_string: "Hello world" Test of pp_string (long): "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa... (truncated) Test of pp_bytes (empty): "" Test of pp_bytes (long): "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb... (truncated) Test of pp_option pp_int (positive): Some 12345 Test of pp_option pp_int (negative): Some (-12345) Test of pp_result pp_int pp_string: Ok (-12345) Test of pp_result pp_int pp_string: Error "Failure" Test of pp_pair pp_char pp_int: ('a', -12345) Test of pp_list pp_int: [1; 2; 3; -1; -2; -3] Test of pp_list pp_int (long): [1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; ... (truncated) Test of pp_seq pp_int: <-5; -4; -3; -2; -1; 0; 1; 2; 3; 4; 5> Test of pp_seq pp_int (long): <-50; -49; -48; -47; -46; -45; -44; -43; -42; -41; -40; -39; -38; -37; -36; -35; -34; -33; -32; -31; -30; -29; -28; -27; -26; -25; -24; ... (truncated) Test of pp_array pp_int: [|1; 2; 3; -1; -2; -3|] Test of pp_array pp_int (long): [|0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0;... (truncated) Test of pp_record: { key = 123; value = "content" } Test of pp_fun_: {(Some (-123456), 'a', "xyz") -> true; (None, 'b', "") -> true; _ -> true} multicoretests-0.7/test/util_pp_trunc5.expected000066400000000000000000000020351474367232000221340ustar00rootroot00000000000000Test of pp_bool: true Test of pp_int (positive): 12345 Test of pp_int (negative): -12345 Test of pp_int32 (positive): 12345l Test of pp_int64 (negative): -12345L Test of pp_float (infinity): infinity Test of pp_float (pi): 3.14159265359 Test of pp_char (printable): 'a' Test of pp_char (unprintable): '\000' Test of pp_string: "Hello world" Test of pp_string (long): ... (truncated) Test of pp_bytes (empty): "" Test of pp_bytes (long): ... (truncated) Test of pp_option pp_int (positive): Some 12345 Test of pp_option pp_int (negative): Some (-12345) Test of pp_result pp_int pp_string: Ok (-12345) Test of pp_result pp_int pp_string: ... (truncated) Test of pp_pair pp_char pp_int: ('a', -12345) Test of pp_list pp_int: ... (truncated) Test of pp_list pp_int (long): ... (truncated) Test of pp_seq pp_int: ... (truncated) Test of pp_seq pp_int (long): ... (truncated) Test of pp_array pp_int: ... (truncated) Test of pp_array pp_int (long): ... (truncated) Test of pp_record: ... (truncated) Test of pp_fun_: ... (truncated) multicoretests-0.7/test/util_pp_trunc79.expected000066400000000000000000000027231474367232000222330ustar00rootroot00000000000000Test of pp_bool: true Test of pp_int (positive): 12345 Test of pp_int (negative): -12345 Test of pp_int32 (positive): 12345l Test of pp_int64 (negative): -12345L Test of pp_float (infinity): infinity Test of pp_float (pi): 3.14159265359 Test of pp_char (printable): 'a' Test of pp_char (unprintable): '\000' Test of pp_string: "Hello world" Test of pp_string (long): "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa... (truncated) Test of pp_bytes (empty): "" Test of pp_bytes (long): "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb... (truncated) Test of pp_option pp_int (positive): Some 12345 Test of pp_option pp_int (negative): Some (-12345) Test of pp_result pp_int pp_string: Ok (-12345) Test of pp_result pp_int pp_string: Error "Failure" Test of pp_pair pp_char pp_int: ('a', -12345) Test of pp_list pp_int: [1; 2; 3; -1; -2; -3] Test of pp_list pp_int (long): [1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1; 2; 3; -1; -2; -3; 1... (truncated) Test of pp_seq pp_int: <-5; -4; -3; -2; -1; 0; 1; 2; 3; 4; 5> Test of pp_seq pp_int (long): <-50; -49; -48; -47; -46; -45; -44; -43; -42; -41; -40; -39; -38;... (truncated) Test of pp_array pp_int: [|1; 2; 3; -1; -2; -3|] Test of pp_array pp_int (long): [|0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; ... (truncated) Test of pp_record: { key = 123; value = "content" } Test of pp_fun_: {(Some (-123456), 'a', "xyz") -> true; (None, 'b', "") -> true; _ -> true} multicoretests-0.7/test/util_print_test.expected000066400000000000000000000012371474367232000224130ustar00rootroot00000000000000" | " " A " " | " " .---------------------." " | | " " A C " " B " " C " "" " | " " A " " | " " .---------------------." " | | " " A C " " B " " C " "" multicoretests-0.7/test/util_print_test.ml000066400000000000000000000024521474367232000212220ustar00rootroot00000000000000type cmd = A | B | C let show_cmd c = match c with | A -> "A" | B -> "B" | C -> "C" let print_and_check_output s res = let ss = (String.split_on_char '\n' s) in List.iter (fun s -> Printf.printf "\"%s\"\n%!" s) ss; assert (List.equal String.equal res ss) ;; let s1 = Util.print_triple_vertical ~fig_indent:1 show_cmd ([A],[A;B;C],[C]) in let res1 = [ " | "; " A "; " | "; " .---------------------."; " | | "; " A C "; " B "; " C "; ""] in print_and_check_output s1 res1 (*assert (List.equal String.equal res1 ss1)*) ;; let s2 = Util.print_triple_vertical ~fig_indent:1 ~center_prefix:false show_cmd ([A],[A;B;C],[C]) in let res2 = [ " | "; " A "; " | "; " .---------------------."; " | | "; " A C "; " B "; " C "; ""] in print_and_check_output s2 res2 multicoretests-0.7/tools/000077500000000000000000000000001474367232000156165ustar00rootroot00000000000000multicoretests-0.7/tools/cheapp.awk000066400000000000000000000063741474367232000175740ustar00rootroot00000000000000function order () { return sprintf("%03d", NR) } function massage_type (prefix, type) { if (type ~ /^[[:alnum:]_']*$/) { return prefix type } else if (type ~ /^\(.*\) [[:alnum:]_']*$/) { main = gensub(/^\(.*\) ([[:alnum:]_']*)$/, "\\1", "1", type) arg1 = gensub(/^\(([^,]*), *.*\) [[:alnum:]_']*$/, "\\1", "1", type) arg2 = gensub(/^\([^,]*, *(.*)\) [[:alnum:]_']*$/, "\\1", "1", type) return prefix main " (" massage_type(prefix,arg1) ") (" massage_type(prefix,arg2) ")" } else if (type ~ /^.* [[:alnum:]_'][[:alnum:]_']*$/) { main = gensub(/^.* ([[:alnum:]_'][[:alnum:]_']*)$/, "\\1", "1", type) arg = gensub(/^ *(.*) [[:alnum:]_'][[:alnum:]_']*$/, "\\1", "1", type) return prefix main " (" massage_type(prefix,arg) ")" } else { return "\"CANNOT HANDLE " type "\"" } } /^ *type/ { o = order() print "(*0" o "src*) " $0 print "(*1" o "ppr*) let pp_" $2 " par fmt x = let open Util.Pp in match x with" print "(*2" o "shw*) let show_" $2 " = Util.Pp.to_show pp_" $2 print "(*3" o "gen*) let gen_" $2 " = let open QCheck.Gen in oneof [" print "(*4" o "equ*) let equal_" $2 " x y = let open Util.Equal in match x, y with" } /^ *\| [[:alpha:]_']+ *$/ { o = order() print "(*0" o "src*) " $0 print "(*1" o "ppr*) | " $2 " -> cst0 \"" $2 "\" fmt" print "(*3" o "gen*) pure " $2 ";" print "(*4" o "equ*) | " $2 "," $2 " -> true" } /^ *\| [[:alpha:]_']+ of [^*]*$/ { o = order() typ = gensub(/^ *\| [[:alpha:]_']+ of ([^*]*)$/, "\\1", "1") print "(*0" o "src*) " $0 print "(*1" o "ppr*) | " $2 " x -> cst1 (" massage_type("pp_",typ) ") \"" $2 "\" par fmt x" print "(*3" o "gen*) map (fun x -> " $2 " x) (" massage_type("",typ) ");" print "(*4" o "equ*) | " $2 " x," $2 " y -> " massage_type("equal_",typ) " x y" } /^ *\| [[:alpha:]_']+ of [^*]* \* [^*]*$/ { o = order() typ1 = gensub(/^ *\| [[:alpha:]_']+ of ([^*]*) \* [^*]*$/, "\\1", "1") typ2 = gensub(/^ *\| [[:alpha:]_']+ of [^*]* \* ([^*]*)$/, "\\1", "1") print "(*0" o "src*) " $0 print "(*1" o "ppr*) | " $2 "(x,y) -> cst2 (" massage_type("pp_",typ1) ") (" massage_type("pp_",typ2) ") \"" $2 "\" par fmt x y" print "(*3" o "gen*) map2 (fun x y -> " $2 "(x,y)) (" massage_type("",typ1) ") (" massage_type("",typ2) ");" print "(*4" o "equ*) | " $2 "(x,y)," $2 "(a,b) -> " massage_type("equal_",typ1) " x a && " massage_type("equal_",typ2) " y b" } /^ *\| [[:alpha:]_']+ of [^*]* \* [^*]* \* [^*]*$/ { o = order() typ1 = gensub(/^ *\| [[:alpha:]_']+ of ([^*]*) \* [^*]* \* [^*]*$/, "\\1", "1") typ2 = gensub(/^ *\| [[:alpha:]_']+ of [^*]* \* ([^*]*) \* [^*]*$/, "\\1", "1") typ3 = gensub(/^ *\| [[:alpha:]_']+ of [^*]* \* [^*]* \* ([^*]*)$/, "\\1", "1") print "(*0" o "src*) " $0 print "(*1" o "ppr*) | " $2 "(x,y,z) -> cst3 (" massage_type("pp_",typ1) ") (" massage_type("pp_",typ2) ") (" massage_type("pp_",typ3) ") \"" $2 "\" par fmt x y z" print "(*3" o "gen*) map3 (fun x y z -> " $2 "(x,y,z)) (" massage_type("",typ1) ") (" massage_type("",typ2) ") (" massage_type("",typ3) ");" print "(*4" o "equ*) | " $2 "(x,y,z)," $2 "(a,b,c) -> " massage_type("equal_",typ1) " x a && " massage_type("equal_",typ2) " y b && " massage_type("equal_",typ3) " z c" } END { o = sprintf("%03d", NR+1) print "(*3" o "gen*) ]" print "(*4" o "equ*) | _, _ -> false" } multicoretests-0.7/tools/cheapp.sh000077500000000000000000000004011474367232000174100ustar00rootroot00000000000000#!/bin/sh ocamlformat --impl --enable-outside-detected-project --no-version-check --type-decl=sparse - | gawk -f "$(dirname "$0")/cheapp.awk" | sort | cut -c 13- | ocamlformat --impl --enable-outside-detected-project --no-version-check - | sed 's/^./ &/'