pax_global_header 0000666 0000000 0000000 00000000064 14743672320 0014522 g ustar 00root root 0000000 0000000 52 comment=9621d6d3d443131adeba126c0fba400ea3a21939
multicoretests-0.7/ 0000775 0000000 0000000 00000000000 14743672320 0014456 5 ustar 00root root 0000000 0000000 multicoretests-0.7/.gitattributes 0000664 0000000 0000000 00000000021 14743672320 0017342 0 ustar 00root root 0000000 0000000 *.sh text eol=lf
multicoretests-0.7/.github/ 0000775 0000000 0000000 00000000000 14743672320 0016016 5 ustar 00root root 0000000 0000000 multicoretests-0.7/.github/runner.sh 0000775 0000000 0000000 00000011736 14743672320 0017676 0 ustar 00root root 0000000 0000000 #!/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/ 0000775 0000000 0000000 00000000000 14743672320 0020053 5 ustar 00root root 0000000 0000000 multicoretests-0.7/.github/workflows/common.yml 0000664 0000000 0000000 00000011610 14743672320 0022065 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000447 14743672320 0022517 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000531 14743672320 0023543 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000535 14743672320 0023550 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000001732 14743672320 0022274 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000406 14743672320 0023272 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000421 14743672320 0024142 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000470 14743672320 0023436 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000400 14743672320 0022746 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000404 14743672320 0023325 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000336 14743672320 0022353 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000470 14743672320 0024325 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000503 14743672320 0025175 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000552 14743672320 0024471 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000462 14743672320 0024010 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000466 14743672320 0024367 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000420 14743672320 0023377 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000474 14743672320 0024332 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000507 14743672320 0025202 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000556 14743672320 0024476 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000466 14743672320 0024015 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000472 14743672320 0024365 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000424 14743672320 0023404 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000424 14743672320 0023433 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000506 14743672320 0024466 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000512 14743672320 0024464 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000424 14743672320 0023615 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000506 14743672320 0024650 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000512 14743672320 0024646 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000513 14743672320 0024126 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000445 14743672320 0022336 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000575 14743672320 0025170 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000527 14743672320 0023371 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000601 14743672320 0025157 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000533 14743672320 0023367 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000573 14743672320 0025015 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000502 14743672320 0023211 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000577 14743672320 0025022 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000000506 14743672320 0023216 0 ustar 00root root 0000000 0000000 name: 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.yml 0000664 0000000 0000000 00000002206 14743672320 0021532 0 ustar 00root root 0000000 0000000 name: 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/.gitignore 0000664 0000000 0000000 00000000012 14743672320 0016437 0 ustar 00root root 0000000 0000000 _build
*~
multicoretests-0.7/AUTHORS 0000664 0000000 0000000 00000000216 14743672320 0015525 0 ustar 00root root 0000000 0000000 The following people have contributed to multicoretests:
Jan Midtgaard
Olivier Nicole
Nicolas Osborne
Naomi Spargo
Samuel Hym
Charlène Gros
multicoretests-0.7/CHANGES.md 0000664 0000000 0000000 00000005623 14743672320 0016056 0 ustar 00root root 0000000 0000000 # 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/LICENSE 0000664 0000000 0000000 00000002514 14743672320 0015465 0 ustar 00root root 0000000 0000000 BSD 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/Makefile 0000664 0000000 0000000 00000000100 14743672320 0016105 0 ustar 00root root 0000000 0000000 all:
dune build
clean:
dune clean
rm -f *~ src/*~ issues/*~
multicoretests-0.7/README.md 0000664 0000000 0000000 00000115513 14743672320 0015743 0 ustar 00root root 0000000 0000000 Multicore tests
===============
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/opam.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-52x.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-52x.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-debug.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-musl.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-32bit.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-52x-fp.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-52x.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-52x-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-52x.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-530-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-530-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-debug.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-musl.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-32bit.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-530-trunk-fp.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-530-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-530-trunk-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-530-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-530-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-530-trunk-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-intel-540-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/macosx-arm64-540-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-debug.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-musl.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-32bit.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/linux-540-trunk-fp.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-540-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/mingw-540-trunk-bytecode.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/cygwin-540-trunk.yml)
[](https://github.com/ocaml-multicore/multicoretests/actions/workflows/msvc-540-trunk.yml)
[](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/ 0000775 0000000 0000000 00000000000 14743672320 0015223 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/README.md 0000664 0000000 0000000 00000001006 14743672320 0016477 0 ustar 00root root 0000000 0000000 This 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/ 0000775 0000000 0000000 00000000000 14743672320 0016656 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/example/dune 0000664 0000000 0000000 00000000520 14743672320 0017531 0 ustar 00root root 0000000 0000000 ;; 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-project 0000664 0000000 0000000 00000000020 14743672320 0021170 0 ustar 00root root 0000000 0000000 (lang dune 2.9)
multicoretests-0.7/doc/example/dune-workspace 0000664 0000000 0000000 00000000000 14743672320 0021516 0 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/example/lin_tests.ml 0000664 0000000 0000000 00000001641 14743672320 0021216 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000003760 14743672320 0021243 0 ustar 00root root 0000000 0000000 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"; ])
multicoretests-0.7/doc/lin/ 0000775 0000000 0000000 00000000000 14743672320 0016005 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/lin/dune 0000664 0000000 0000000 00000000373 14743672320 0016666 0 ustar 00root root 0000000 0000000 (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.mld 0000664 0000000 0000000 00000027554 14743672320 0017627 0 ustar 00root root 0000000 0000000 {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.ml 0000664 0000000 0000000 00000002721 14743672320 0020645 0 ustar 00root root 0000000 0000000 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 (
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.ml 0000664 0000000 0000000 00000003536 14743672320 0021662 0 ustar 00root root 0000000 0000000 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 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/ 0000775 0000000 0000000 00000000000 14743672320 0020146 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/paper-examples/dune 0000664 0000000 0000000 00000000520 14743672320 0021021 0 ustar 00root root 0000000 0000000 ;; 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-project 0000664 0000000 0000000 00000000020 14743672320 0022460 0 ustar 00root root 0000000 0000000 (lang dune 2.9)
multicoretests-0.7/doc/paper-examples/dune-workspace 0000664 0000000 0000000 00000000000 14743672320 0023006 0 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/paper-examples/lin_tests.ml 0000664 0000000 0000000 00000002124 14743672320 0022503 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000004714 14743672320 0022533 0 ustar 00root root 0000000 0000000 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 =
| 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/ 0000775 0000000 0000000 00000000000 14743672320 0017445 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/paper-latex/.latexmkrc 0000664 0000000 0000000 00000000172 14743672320 0021440 0 ustar 00root root 0000000 0000000 # 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.md 0000664 0000000 0000000 00000000154 14743672320 0020724 0 ustar 00root root 0000000 0000000 To compile (requires fonts Libertinus and Fira Mono installed as OpenType
fonts):
```
latexmk paper.tex
```
multicoretests-0.7/doc/paper-latex/biblio.bib 0000664 0000000 0000000 00000014232 14743672320 0021365 0 ustar 00root root 0000000 0000000
@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.tex 0000664 0000000 0000000 00000000125 14743672320 0021451 0 ustar 00root root 0000000 0000000 \providecommand{\tightlist}{%
\setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}}
multicoretests-0.7/doc/paper-latex/paper.tex 0000664 0000000 0000000 00000040416 14743672320 0021303 0 ustar 00root root 0000000 0000000 \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.tex 0000664 0000000 0000000 00000002763 14743672320 0021766 0 ustar 00root root 0000000 0000000 \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.md 0000664 0000000 0000000 00000042634 14743672320 0016665 0 ustar 00root root 0000000 0000000 Multicoretests - 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.pdf 0000664 0000000 0000000 00000155177 14743672320 0017045 0 ustar 00root root 0000000 0000000 %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˝;t Tű…ő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”‘´Á[ ůý#ďYy Z9Ô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ů‚ =—!*„x I׆§‚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ĽdZ Ię嚤]zŠdo†ĺ•6ôÍ ¶ĘwćdcOzY˛CÖŽFűU®á8|:pÚű•[˝Ľ@hű˝$Rh732’˦-W@ŢĐg<Ô t˛+˛™^{:os({ľÍ7¶ś*†‹ň6Đł^(j€Á:'™/W|p»@<ĂŃ ć!` ö–y l8JĐ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Đđt Oi·Ś4#PnÓqś` °Ýz´śŔ+ôɲ©ŕdşGneč/žĐ_nZOčű§I©éü€~¨ô= ЧkżŽtKQëË`ˇçÉÚ§ ąŮŘeŢÁł[‘x»‡ů¸O˝Áľ ‡żp% `ôšę\¸ J"âҢű+Ś…Ii“Ůrő– Ío ČżÔ•¨`R3 •®çťm.±KęÂ?xŰť ;» ÜsFwR 8XhvčĎ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 !vN yĆ)Ľî,#»±Ć=ň‰až‘čEX0B›*0ÄĂËRš¨ßIݲiď÷ÔŞí€(¬+č0¦ŕ{ű™!Kމ}•Öz"»cŃÚ±ó “zK[„<–§š/ę‘iÖŤ‰HAÝeâ`&9*a†&G¶óFĹ 2ĺ¶]'źed•ö€ëˇpÓ VDÜŐAt?Ů’äu yiÝCá~
"Ř8Ă+“¬+YDetşm¦h‚°¦ë+Ý=zBÄŚv7
G…†făä-`/lˇşÚ„U•Ó¡j<5ĂBľb?ňŻĚď4¤Ż¨@[› ®Đ•ďĽ“Ň,ťĘŽ, ·‡Ň-.ź©Š¦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ö3 zG Mň•E™ŚĂTÓ$T¶j*…°WÁŐc Ž\ ŻŃńsĆ4jš}ěĄňěH9ËŔ2^ĐF;ŐĆľfšcŚ«Uíq6ę
Ă Ż&±Ľ»GúÖ ŮUBˇ‹Ňp=bEĐ[%G†űé4
ň- šąŚ§OXšđű»P\÷˛~ű[,Ŕ úÔÎpGÇ2ă&6OX˛ Ý{ź{‡˙_Ę#€hćQĆľQC p†ěĚ/ض 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-˘K 7í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ŐTv hí@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}L Bń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—ÂýÔ×ŮÔSV wzš5ŻćĄŔUĚ€Öx,x_ü`ńCŽ ¸Í6 ¦2\kdsgF€*w(i JcĆßĺÂĘßt,> †ZĘüYĹůŕČű¶ńŔ‚ *8-ĹH›/`öîJ fF˛š˛Âá}°Öé†RyËOÉ Řᨢ}c‘FŰą:ŰiÁ ˝„CR-ÚÂq;oM§‘âObÚŠhĺĄ)‡tN}P mŽîË·ů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ŚLĚ §×Ý~gąÖ±«ŐóěÁĄ–á[ăîZ®düŚ‡?JH»Ýβ»_dUH[^é‡
¨ňŚ[ż†˘W iš
Úß«: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–Ý;î˝}»–¨/Ęu qőéÚĺ0y ă¶dR±AnˇđWŮîu 9ŞŚÁ OYÉá¬j?ˇ; wĂ TQL9YźÁßקT!îU «°
Żfş§ŢęËŇ{¨ČDâS+gÄlRPy۶•©rŕĚ8‘¸Â>wĚ8w0·,j '°@jÖ˛ę[䌦ŃÁŤ~:5K$©Ńć˘yJ)¦R‚´ÇP¦˛ńlŮC8…Z‰!~ŕ7{şź’?é.ş†Ţ|r[÷ăAŁř
UÝ·úŞňNÖ“6YŠ˛“EĘ5Ş ú[§!§.5Á~÷¶Ţ‡AuŰČ{{R>Učß±d[îŔF”ćyę٤ú ŞüNZ¸¦
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… 3 G&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•Ëb h«=ÍÚ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'6 z'.łMđ¸ńçă…Ň/áśŘä/*VHmŠŁsBm 8"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˘.ĆŤ…9 LÂ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ĎO1 fźË«‰; ú"Ę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Ö«ÓY Eq\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 ˘>}D OÍť·böô#Ţ
Ý´564".fYĐÖĐMŁ–Ç…ůo>2Çů¤s ě ,r>ĺá rźóiOçc}†ôlŘçÉžáOöąţĎ dHäA ľ·=üdżďe?N~oŕłÂ+Ť‡‰î÷đxlĐ°áâU˙ałi‘ćEĆĆ&ľ Ed_ßľ_Ţ?öţĎ « é—Ő?nŔôß|ď<ĐŕU˙ŕ؇ }資ç?üłw;gxäéGNŠ#Ĺ˙~´˙cŻ=ţĐă« /ů{ĐO>‘öäň'?$ Ľű)ËCŢúÄĐńĎ<;óٝÔĎÍ~î÷çK^<ś ·ż1"odŕ¨űF5ŹŢ4:gôń—ľ¤ CĆŚ S4öü¸SăżžĐ>ńŐ— 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đHtc 2-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Ô ÔŐc Vh. Ó‹úâ …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đ׌"¬fx fx¬ĐÜ 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»™Ŕ|ťvv1§^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é|+ © ţęĹĎa YÁ:>~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’Ö n qă©›™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ťR QŐł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éYg qQś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ÉQR˛ đĆ+Ľ¬Š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Ě?ŇÎߧ ¦tRT ˝Ń`Đîʖb‡.ĺśÜÓzâöm‹˙tíc Ŕ Ă Q–”‘śkC" )žŘrm9Ů9PWl˛
z N ý}álŘ™” żâOőďľIŰČĽMSâV#ĽŽ«rÇÖŻ¸‘rŹ·QĽřIčpľďMűt×qť˛l‚Ą×,»@fĘÔg¨!yqÄ–»Ö#‰n«˛Ą%?Ď6 5Ý!<µˇ†~˝.¶ 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ŽżŰm 7íąő˝Á
ş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˙é“—đż4 r>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ü6c€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`Ś!ô V wSłö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ü î\c 6&·ŢŕƱżó˘Îü‹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µY6őăęĘ]ňóŠ\‡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{n 7ž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ΆŃ4 f§ť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ŁĚ™Zw k: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đz Z~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÷[Ną#´ß‰Ă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Ýđy3ÂŐüçsŢ/I/ß(ć~',۶f7”Š4ŐWňXZTk,-EQw›T¦„‡BäŽĘN–1"ăp†ő/í¸˝SSŚľ$’y˘LФ;·-¬…*ŢzI8 q6ă;–QšQ…Ž8- yŞ×ÍĐÔ¸PFţ¦áŇ"Î7ś1GUXZ^Z
âýÓ t0Ő‡y9v;{t#ßÉôűk’÷U´EÝÍşNÝY(ű¸|™xę’°čÔ‚\OF h/:‘N{Ę"Tw
óĘOŠ±—„ŘĺQ™ eťë’ţ_gc'no×3ű®“č!Uâ©Čýó„äB{2©5¬'×2vşň’¨I˙ÚŁ +C Ńtżt JÓ
Ł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@Čg y2Ŕ‡2Ŕł;2Ŕe/4¬”ŔŽŚ=üéřÄśą& Ç>í€nÝ ĚËŔŐr(ľn×´b óˇćYwŢ°’€ż˛#倮ˇÇťô*€~ĄŚjHW Źil˙W»2$ú™N1+ j‚źi«ŕô΂]âĘkBj–aC
ˇ‰{/Č”¤ÔfeXW¶â€;8 UÓFI±´’
©1 WĹ펅…°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
9 eŠĄ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’–żČ[’#s 7MţĐ~Őš<ď Ňšl’—ŤŁ˛K˛•49[őIÉËA»śă9"MÉé©5W¬µčąŐ ,zŐ›×[X´÷j·čýćĺůŚ
endstream
endobj
139 0 obj
<>
stream
xÚë©ţ˙w˙ďű¬ń˙˙˙o AÜ ~
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ˤż-’î@x 3ť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#~‚;Ż€·Á1 w“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Źň~c n¬ßĽ ňŠ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>ŘĽů8 sÎÔ"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´űI m%†víA&>–łB˝¨0‰śN´‡I ýŰz
;¬?ąČ …±Lß®ľjHáĂÍšZ•s 15‰ź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‰űXy uě““ĽÔ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^ wcyqi tíÝů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ňh G Ť¶üŢüşŐ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™ âĽŔ§Â^âS k\ _=şüö ĽŔ!| † Ś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ܨŮáV JE¸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/ 0000775 0000000 0000000 00000000000 14743672320 0016026 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/stm/dune 0000664 0000000 0000000 00000001573 14743672320 0016712 0 ustar 00root root 0000000 0000000 (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.mld 0000664 0000000 0000000 00000053215 14743672320 0017641 0 ustar 00root root 0000000 0000000 {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.ml 0000664 0000000 0000000 00000003641 14743672320 0021275 0 ustar 00root root 0000000 0000000 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 = 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.ml 0000664 0000000 0000000 00000004000 14743672320 0021264 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000003765 14743672320 0021306 0 ustar 00root root 0000000 0000000 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
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.ml 0000664 0000000 0000000 00000004473 14743672320 0021304 0 ustar 00root root 0000000 0000000 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;
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.ml 0000664 0000000 0000000 00000006050 14743672320 0021276 0 ustar 00root root 0000000 0000000 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
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.ml 0000664 0000000 0000000 00000006210 14743672320 0021275 0 ustar 00root root 0000000 0000000 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
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/ 0000775 0000000 0000000 00000000000 14743672320 0016200 5 ustar 00root root 0000000 0000000 multicoretests-0.7/doc/util/dune 0000664 0000000 0000000 00000000113 14743672320 0017051 0 ustar 00root root 0000000 0000000 (documentation
(package qcheck-multicoretests-util)
(mld_files index))
multicoretests-0.7/doc/util/index.mld 0000664 0000000 0000000 00000001246 14743672320 0020010 0 ustar 00root root 0000000 0000000 {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/dune 0000664 0000000 0000000 00000003727 14743672320 0015345 0 ustar 00root root 0000000 0000000 (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-project 0000664 0000000 0000000 00000004364 14743672320 0017007 0 ustar 00root root 0000000 0000000 (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-workspace 0000664 0000000 0000000 00000000000 14743672320 0017316 0 ustar 00root root 0000000 0000000 multicoretests-0.7/lib/ 0000775 0000000 0000000 00000000000 14743672320 0015224 5 ustar 00root root 0000000 0000000 multicoretests-0.7/lib/STM.ml 0000664 0000000 0000000 00000027272 14743672320 0016233 0 ustar 00root root 0000000 0000000 (** 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.mli 0000664 0000000 0000000 00000023711 14743672320 0016376 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000013230 14743672320 0017547 0 ustar 00root root 0000000 0000000 open 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.mli 0000664 0000000 0000000 00000014071 14743672320 0017724 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000002232 14743672320 0020452 0 ustar 00root root 0000000 0000000 open 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.mli 0000664 0000000 0000000 00000002702 14743672320 0020625 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000005510 14743672320 0017551 0 ustar 00root root 0000000 0000000 open 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.mli 0000664 0000000 0000000 00000003264 14743672320 0017726 0 ustar 00root root 0000000 0000000 (** 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/dune 0000664 0000000 0000000 00000002577 14743672320 0016115 0 ustar 00root root 0000000 0000000 (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.ml 0000664 0000000 0000000 00000047035 14743672320 0016351 0 ustar 00root root 0000000 0000000 module 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.mli 0000664 0000000 0000000 00000034657 14743672320 0016530 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000004160 14743672320 0017670 0 ustar 00root root 0000000 0000000 open 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.mli 0000664 0000000 0000000 00000003535 14743672320 0020046 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000010405 14743672320 0017654 0 ustar 00root root 0000000 0000000 open 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.mli 0000664 0000000 0000000 00000003417 14743672320 0020032 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000003737 14743672320 0017701 0 ustar 00root root 0000000 0000000 open 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.mli 0000664 0000000 0000000 00000002612 14743672320 0020041 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000025703 14743672320 0016542 0 ustar 00root root 0000000 0000000 let 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.mli 0000664 0000000 0000000 00000021153 14743672320 0016706 0 ustar 00root root 0000000 0000000 (** 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.opam 0000664 0000000 0000000 00000002046 14743672320 0020424 0 ustar 00root root 0000000 0000000 # 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.template 0000664 0000000 0000000 00000000043 14743672320 0022231 0 ustar 00root root 0000000 0000000 x-maintenance-intent: ["(latest)"]
multicoretests-0.7/qcheck-lin.opam 0000664 0000000 0000000 00000002374 14743672320 0017360 0 ustar 00root root 0000000 0000000 # 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.template 0000664 0000000 0000000 00000000043 14743672320 0021161 0 ustar 00root root 0000000 0000000 x-maintenance-intent: ["(latest)"]
multicoretests-0.7/qcheck-multicoretests-util.opam 0000664 0000000 0000000 00000002004 14743672320 0022625 0 ustar 00root root 0000000 0000000 # 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.template 0000664 0000000 0000000 00000000043 14743672320 0024440 0 ustar 00root root 0000000 0000000 x-maintenance-intent: ["(latest)"]
multicoretests-0.7/qcheck-stm.opam 0000664 0000000 0000000 00000002252 14743672320 0017374 0 ustar 00root root 0000000 0000000 # 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.template 0000664 0000000 0000000 00000000043 14743672320 0021202 0 ustar 00root root 0000000 0000000 x-maintenance-intent: ["(latest)"]
multicoretests-0.7/src/ 0000775 0000000 0000000 00000000000 14743672320 0015245 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/README.md 0000664 0000000 0000000 00000013400 14743672320 0016522 0 ustar 00root root 0000000 0000000 Current 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/ 0000775 0000000 0000000 00000000000 14743672320 0016363 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/array/dune 0000664 0000000 0000000 00000001026 14743672320 0017240 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000010046 14743672320 0022616 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000003172 14743672320 0020724 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000014366 14743672320 0020754 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016521 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/atomic/dune 0000664 0000000 0000000 00000001221 14743672320 0017373 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000013534 14743672320 0022761 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001720 14743672320 0021057 0 ustar 00root root 0000000 0000000 module 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.ml 0000664 0000000 0000000 00000005437 14743672320 0021111 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0017045 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/bigarray/dune 0000664 0000000 0000000 00000000543 14743672320 0017725 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000002107 14743672320 0021403 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000006445 14743672320 0021435 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016516 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/buffer/dune 0000664 0000000 0000000 00000000277 14743672320 0017402 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000013600 14743672320 0021075 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016373 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/bytes/dune 0000664 0000000 0000000 00000000543 14743672320 0017253 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000007017 14743672320 0020736 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000007324 14743672320 0020760 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016514 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/domain/domain_joingraph.ml 0000664 0000000 0000000 00000014052 14743672320 0022360 0 ustar 00root root 0000000 0000000 (**
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.ml 0000664 0000000 0000000 00000005307 14743672320 0022412 0 ustar 00root root 0000000 0000000 (** 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/dune 0000664 0000000 0000000 00000001400 14743672320 0017365 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000002177 14743672320 0021723 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000005727 14743672320 0021750 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0017076 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/dynarray/dune 0000664 0000000 0000000 00000002153 14743672320 0017755 0 ustar 00root root 0000000 0000000 (* -*- 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.ml 0000664 0000000 0000000 00000003557 14743672320 0021446 0 ustar 00root root 0000000 0000000 module 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.ml 0000664 0000000 0000000 00000072021 14743672320 0021457 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016715 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/dynlink/dune 0000664 0000000 0000000 00000000445 14743672320 0017576 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000000017 14743672320 0020114 0 ustar 00root root 0000000 0000000 let value = 12
multicoretests-0.7/src/dynlink/libB.ml 0000664 0000000 0000000 00000000017 14743672320 0020115 0 ustar 00root root 0000000 0000000 let value = 34
multicoretests-0.7/src/dynlink/lin_tests.ml 0000664 0000000 0000000 00000002522 14743672320 0021254 0 ustar 00root root 0000000 0000000 (* ************************************ *)
(* 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/ 0000775 0000000 0000000 00000000000 14743672320 0017227 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/ephemeron/dune 0000664 0000000 0000000 00000001011 14743672320 0020076 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000003003 14743672320 0021561 0 ustar 00root root 0000000 0000000 (* ************************************************************ *)
(* 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.ml 0000664 0000000 0000000 00000000335 14743672320 0022451 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000000335 14743672320 0022457 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000011443 14743672320 0022623 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0017411 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/floatarray/dune 0000664 0000000 0000000 00000000516 14743672320 0020271 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000004171 14743672320 0021752 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000011465 14743672320 0021777 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0015636 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/gc/dune 0000664 0000000 0000000 00000003510 14743672320 0016513 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000000051 14743672320 0017773 0 ustar 00root root 0000000 0000000 external get : unit -> int = "page_size"
multicoretests-0.7/src/gc/pagesizestub.c 0000664 0000000 0000000 00000000717 14743672320 0020514 0 ustar 00root root 0000000 0000000 #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.ml 0000664 0000000 0000000 00000000601 14743672320 0022075 0 ustar 00root root 0000000 0000000 (* 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.ml 0000664 0000000 0000000 00000001255 14743672320 0022111 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001505 14743672320 0023252 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000000445 14743672320 0021062 0 ustar 00root root 0000000 0000000 (* 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.ml 0000664 0000000 0000000 00000000463 14743672320 0022465 0 ustar 00root root 0000000 0000000 (* 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.ml 0000664 0000000 0000000 00000001121 14743672320 0021060 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001366 14743672320 0022236 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000046245 14743672320 0021242 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016672 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/hashtbl/dune 0000664 0000000 0000000 00000001056 14743672320 0017552 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000010130 14743672320 0023117 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000002624 14743672320 0021234 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000010674 14743672320 0021261 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0015654 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/io/dune 0000664 0000000 0000000 00000001673 14743672320 0016541 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000010652 14743672320 0022112 0 ustar 00root root 0000000 0000000 (* 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.ml 0000664 0000000 0000000 00000000777 14743672320 0021554 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000007331 14743672320 0021717 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000000702 14743672320 0021540 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000036471 14743672320 0020246 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016224 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/lazy/dune 0000664 0000000 0000000 00000001070 14743672320 0017100 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000010145 14743672320 0022457 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000005222 14743672320 0020563 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000010443 14743672320 0020605 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0017240 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/neg_tests/CList.ml 0000664 0000000 0000000 00000001556 14743672320 0020617 0 ustar 00root root 0000000 0000000 (** 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/dune 0000664 0000000 0000000 00000005632 14743672320 0020124 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000014357 14743672320 0025054 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001535 14743672320 0025025 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000013247 14743672320 0025015 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001421 14743672320 0026715 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001407 14743672320 0025657 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000005375 14743672320 0023160 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001302 14743672320 0023121 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000007752 14743672320 0023125 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000001726 14743672320 0023133 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000004016 14743672320 0023516 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000000506 14743672320 0024003 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000000534 14743672320 0025035 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000000531 14743672320 0024704 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000007704 14743672320 0023475 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000000757 14743672320 0024013 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016371 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/queue/dune 0000664 0000000 0000000 00000000712 14743672320 0017247 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000013353 14743672320 0022630 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000002724 14743672320 0020734 0 ustar 00root root 0000000 0000000 module 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/ 0000775 0000000 0000000 00000000000 14743672320 0017230 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/semaphore/dune 0000664 0000000 0000000 00000000635 14743672320 0020112 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000003562 14743672320 0023161 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000004673 14743672320 0023527 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016352 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/stack/dune 0000664 0000000 0000000 00000000714 14743672320 0017232 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000013277 14743672320 0022616 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000002664 14743672320 0020720 0 ustar 00root root 0000000 0000000 module 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/ 0000775 0000000 0000000 00000000000 14743672320 0017437 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/statistics/README.md 0000664 0000000 0000000 00000012231 14743672320 0020715 0 ustar 00root root 0000000 0000000 Statistical 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/dune 0000664 0000000 0000000 00000000034 14743672320 0020312 0 ustar 00root root 0000000 0000000 (executable
(name z_test))
multicoretests-0.7/src/statistics/z_test.ml 0000664 0000000 0000000 00000003523 14743672320 0021304 0 ustar 00root root 0000000 0000000 (*
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/ 0000775 0000000 0000000 00000000000 14743672320 0016063 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/sys/dune 0000664 0000000 0000000 00000000274 14743672320 0016744 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000030533 14743672320 0020446 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016514 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/thread/dune 0000664 0000000 0000000 00000000634 14743672320 0017375 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000004473 14743672320 0022530 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000011337 14743672320 0022363 0 ustar 00root root 0000000 0000000 (**
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/ 0000775 0000000 0000000 00000000000 14743672320 0017540 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/threadomain/dune 0000664 0000000 0000000 00000000317 14743672320 0020417 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000013374 14743672320 0022375 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0016174 5 ustar 00root root 0000000 0000000 multicoretests-0.7/src/weak/dune 0000664 0000000 0000000 00000002655 14743672320 0017062 0 ustar 00root root 0000000 0000000 ;; 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.ml 0000664 0000000 0000000 00000002236 14743672320 0020535 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000002777 14743672320 0022266 0 ustar 00root root 0000000 0000000 (* ********************************************************************** *)
(* 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.ml 0000664 0000000 0000000 00000000376 14743672320 0023142 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000000411 14743672320 0024533 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000000376 14743672320 0023150 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000013023 14743672320 0023303 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000000343 14743672320 0022424 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000000356 14743672320 0024033 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000000343 14743672320 0022432 0 ustar 00root root 0000000 0000000 (** 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.ml 0000664 0000000 0000000 00000007164 14743672320 0022604 0 ustar 00root root 0000000 0000000 open 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/ 0000775 0000000 0000000 00000000000 14743672320 0015435 5 ustar 00root root 0000000 0000000 multicoretests-0.7/test/cleanup_lin.ml 0000664 0000000 0000000 00000003770 14743672320 0020267 0 ustar 00root root 0000000 0000000 open 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.ml 0000664 0000000 0000000 00000004625 14743672320 0020310 0 ustar 00root root 0000000 0000000 open 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/dune 0000664 0000000 0000000 00000005533 14743672320 0016321 0 ustar 00root root 0000000 0000000 ;; 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.32 0000664 0000000 0000000 00000001170 14743672320 0022317 0 ustar 00root root 0000000 0000000 [2K
random seed: 229109553
--- [31;1mFailure[0m --------------------------------------------------------------------
Test STM sequential tests failed (9 shrink steps):
Add (-923247292)
Remove (-923247292)
Cardinal
+++ [34;1mMessages[0m ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Messages for test STM sequential tests:
Results incompatible with model
Add (-923247292) : ()
Remove (-923247292) : Some (-923247292)
Cardinal : 1
================================================================================
[31;1mfailure[0m (1 tests failed, 0 tests errored, ran 1 tests)
multicoretests-0.7/test/mutable_set_v4.expected.64 0000664 0000000 0000000 00000001253 14743672320 0022326 0 ustar 00root root 0000000 0000000 [2K
random seed: 229109553
--- [31;1mFailure[0m --------------------------------------------------------------------
Test STM sequential tests failed (11 shrink steps):
Add (-3576245632788335623)
Remove (-3576245632788335623)
Cardinal
+++ [34;1mMessages[0m ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Messages for test STM sequential tests:
Results incompatible with model
Add (-3576245632788335623) : ()
Remove (-3576245632788335623) : Some (-3576245632788335623)
Cardinal : 1
================================================================================
[31;1mfailure[0m (1 tests failed, 0 tests errored, ran 1 tests)
multicoretests-0.7/test/mutable_set_v5.expected.32 0000664 0000000 0000000 00000001170 14743672320 0022320 0 ustar 00root root 0000000 0000000 [2K
random seed: 229109553
--- [31;1mFailure[0m --------------------------------------------------------------------
Test STM sequential tests failed (2 shrink steps):
Add (-286715106)
Remove (-286715106)
Cardinal
+++ [34;1mMessages[0m ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Messages for test STM sequential tests:
Results incompatible with model
Add (-286715106) : ()
Remove (-286715106) : Some (-286715106)
Cardinal : 1
================================================================================
[31;1mfailure[0m (1 tests failed, 0 tests errored, ran 1 tests)
multicoretests-0.7/test/mutable_set_v5.expected.64 0000664 0000000 0000000 00000001235 14743672320 0022327 0 ustar 00root root 0000000 0000000 [2K
random seed: 229109553
--- [31;1mFailure[0m --------------------------------------------------------------------
Test STM sequential tests failed (6 shrink steps):
Add 3036269937054427589
Remove 3036269937054427589
Cardinal
+++ [34;1mMessages[0m ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Messages for test STM sequential tests:
Results incompatible with model
Add 3036269937054427589 : ()
Remove 3036269937054427589 : Some (3036269937054427589)
Cardinal : 1
================================================================================
[31;1mfailure[0m (1 tests failed, 0 tests errored, ran 1 tests)
multicoretests-0.7/test/mutable_set_v5.ml 0000664 0000000 0000000 00000006533 14743672320 0020714 0 ustar 00root root 0000000 0000000 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
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.ml 0000664 0000000 0000000 00000004720 14743672320 0021672 0 ustar 00root root 0000000 0000000 open 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.expected 0000664 0000000 0000000 00000013014 14743672320 0020633 0 ustar 00root root 0000000 0000000 Test 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.ml 0000664 0000000 0000000 00000004163 14743672320 0017447 0 ustar 00root root 0000000 0000000 (* 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.expected 0000664 0000000 0000000 00000003466 14743672320 0022306 0 ustar 00root root 0000000 0000000 Test 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.expected 0000664 0000000 0000000 00000002035 14743672320 0022134 0 ustar 00root root 0000000 0000000 Test 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.expected 0000664 0000000 0000000 00000002723 14743672320 0022233 0 ustar 00root root 0000000 0000000 Test 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.expected 0000664 0000000 0000000 00000001237 14743672320 0022413 0 ustar 00root root 0000000 0000000 " | "
" A "
" | "
" .---------------------."
" | | "
" A C "
" B "
" C "
""
" | "
" A "
" | "
" .---------------------."
" | | "
" A C "
" B "
" C "
""
multicoretests-0.7/test/util_print_test.ml 0000664 0000000 0000000 00000002452 14743672320 0021222 0 ustar 00root root 0000000 0000000 type 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/ 0000775 0000000 0000000 00000000000 14743672320 0015616 5 ustar 00root root 0000000 0000000 multicoretests-0.7/tools/cheapp.awk 0000664 0000000 0000000 00000006374 14743672320 0017574 0 ustar 00root root 0000000 0000000 function 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.sh 0000775 0000000 0000000 00000000401 14743672320 0017410 0 ustar 00root root 0000000 0000000 #!/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/^./ &/'