; Merge from https://github.com/Ravenbrook/mps

mps/.github/workflows/build-and-test.yml

@@ -0,0 +1,114 @@
+# .github/workflows/build-and-test.yml -- GitHub CI build and test configuration for the MPS
+#
+# Copyright (c) 2019-2022 `GitHub contributors`_ (MIT License).
+# Copyright (c) 2023 Ravenbrook Limited. See end of file for license.
+#
+# See design.mps.test.ci.
+#
+# TODO: Exclude certain branches.
+#
+# TODO: Regular builds of version branches.  See
+# <https://docs.github.com/en/actions/using-workflows/workflow-syntax-for-github-actions#onschedule>.
+
+name: build and test
+
+on:
+  - push
+  - pull_request
+  # Also run when triggered manually, e.g. by tool/github-ci-kick
+  # <https://docs.github.com/en/actions/managing-workflow-runs/manually-running-a-workflow>
+  - workflow_dispatch
+
+jobs:
+
+  posix:
+
+    # The build matrix for GitHub CI on Posix platforms
+    #
+    # See design.mps.tests.ci.github.platforms.
+    #
+    # FreeBSD and ARM64 targets are in Travis CI, configured by
+    # .travis.yml.
+    #
+    # See <https://docs.github.com/en/actions/using-jobs/using-a-matrix-for-your-jobs#using-a-matrix-strategy>.
+    
+    strategy:
+      fail-fast: false # don't cancel all builds when one build fails
+      matrix:
+        os: [ubuntu-latest, macos-latest]
+        compiler: [clang, gcc]
+        exclude:
+          - os: macos-latest
+            compiler: gcc
+
+    runs-on: ${{ matrix.os }}
+
+    # See design.mps.tests.ci.run.posix.
+    steps:
+    - uses: actions/checkout@v4 # see <https://github.com/actions/checkout/blob/main/README.md#usage>
+    - run: CC=${{ matrix.compiler }} ./configure
+    - run: make
+    - run: make test
+
+  windows:
+
+    runs-on: windows-latest
+
+    # See design.mps.tests.ci.run.windows.
+    #
+    # The path to Visual Studio is documented at
+    # <https://github.com/actions/runner-images/blob/e6fcf60b8e6c0f80a065327eaefe836881c28b68/images/win/Windows2022-Readme.md?plain=1#L215>.
+
+    steps:
+    - uses: actions/checkout@v4 # see <https://github.com/actions/checkout/blob/main/README.md#usage>
+    - run: |
+         call "C:\Program Files\Microsoft Visual Studio\2022\Enterprise\VC\Auxiliary\Build\vcvarsall.bat" x64
+         cd code
+         nmake /f w3i6mv.nmk all testci testansi testpollnone
+      shell: cmd
+
+
+# A. REFERENCES
+#
+# [GitHub CI] "About continuous integration"; <https://docs.github.com/en/actions/automating-builds-and-tests/about-continuous-integration>.
+#
+#
+# B. DOCUMENT HISTORY
+#
+# 2023-01-11 RB Adapted from <https://github.com/actions/starter-workflows/blob/9f245d9aba830ad16a097a45c78331a05114d815/ci/c-cpp.yml>.
+# 2023-01-15 RB Added licence and document history.
+#
+#
+# C. COPYRIGHT AND LICENSE
+#
+# NOTE: This is the `MIT Licence <https://opensource.org/licenses/MIT>`_
+# inherited from
+# <https://github.com/actions/starter-workflows/blob/9f245d9aba830ad16a097a45c78331a05114d815/ci/c-cpp.yml> and not the usual licence for the MPS.
+#
+# Copyright (c) 2019-2022 `GitHub contributors`_.
+# Copyright (c) 2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation files
+# (the "Software"), to deal in the Software without restriction,
+# including without limitation the rights to use, copy, modify, merge,
+# publish, distribute, sublicense, and/or sell copies of the Software,
+# and to permit persons to whom the Software is furnished to do so,
+# subject to the following conditions:
+# 
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+# 
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+# BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+# ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+# CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+#
+# .. _GitHub contributors: https://github.com/actions/starter-workflows/commits/1d9d6d7fb0a8a27ef98efbbfa9689cd14c906383/ci/c-cpp.yml
+#
+#
+# $Id$

mps/.github/workflows/fixme-check.yml

@@ -0,0 +1,21 @@
+# .github/workflows/fixme-check.yml -- check for FIXME task labels
+#
+# This is a GitHub CI workflow
+# <https://docs.github.com/en/actions/automating-builds-and-tests/about-continuous-integration>
+# to check for FIXME and similar task labels left unresolved in the
+# MPS source tree.
+
+name: FIXME check
+
+on:
+  # Run as part of CI checks on branch push and on merged pull request.
+  - push
+  - pull_request
+  - workflow_dispatch # allow manual triggering
+
+jobs:
+  check-fixme:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4 # see <https://github.com/actions/checkout/blob/main/README.md#usage>
+      - run: tool/check-fixme

mps/.github/workflows/rst-check.yml

@@ -0,0 +1,23 @@
+# .github/workflows/rst-check.yml -- check syntax of reStructuredText files
+#
+# This is a GitHub CI workflow
+# <https://docs.github.com/en/actions/using-workflows/about-workflows>
+# to check the syntax of reStructuredText files.
+
+name: reStructuredText syntax check
+
+on:
+  # Run as part of CI checks on branch push and on merged pull request.
+  - push
+  - pull_request
+  - workflow_dispatch # allow manual triggering
+
+jobs:
+  check-rst:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4 # see <https://github.com/actions/checkout/blob/main/README.md#usage>
+      - name: Install docutils
+        run: sudo apt-get install -y docutils
+      - name: Check reStructuredText syntax
+        run: tool/check-rst

mps/.github/workflows/shell-script-check.yml

@@ -0,0 +1,23 @@
+# .github/workflows/shell-script-check.yml -- check shell scripts
+#
+# This is a GitHub CI workflow
+# <https://docs.github.com/en/actions/using-workflows/about-workflows>
+# to check shell scripts.
+
+name: shell script check
+
+on:
+  # Run as part of CI checks on branch push and on merged pull request.
+  - push
+  - pull_request
+  - workflow_dispatch # allow manual triggering
+
+jobs:
+  check-shell-scripts:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4 # see <https://github.com/actions/checkout/blob/main/README.md#usage>
+      - name: Install shellcheck
+        run: sudo apt-get install -y shellcheck
+      - name: Check shell scripts
+        run: tool/check-shell-scripts

mps/.gitignore

@@ -0,0 +1,32 @@
+# .p4ignore -- Perforce files to ignore from MPS Project
+# $Id$
+# Don't forget to consider files in more specific directories.
+# Personal Perforce configurations
+.p4config
+# Mac OS X Finder turds
+.DS_Store
+# Patch results
+*.orig
+*.rej
+# Autoconf and Automake output
+Makefile
+autom4te.cache
+config.log
+config.status
+.deps
+.dirstamp
+bin
+lib
+# Misc
+TAGS
+*.dSYM
+*.pyc
+test/obj
+test/test/log
+test/test/obj
+....gcda
+....gcno
+\#*#
+*~
+.#.*
+core

mps/.p4ignore

@@ -0,0 +1 @@
+.gitignore

mps/.readthedocs.yaml

@@ -0,0 +1,70 @@
+# .readthedocs.yaml -- Build configuration for MPS manual on Read The Docs
+#
+# Copyright (c) 2023 Ravenbrook Limited. See end of file for license.
+#
+# This file controls how Read the Docs builds and publishes the MPS
+# manual at <https://memory-pool-system.readthedocs.io/>.
+#
+# See <https://docs.readthedocs.io/en/stable/config-file/v2.html> for
+# the file format.
+#
+# Project configuration is at
+# <https://readthedocs.org/projects/memory-pool-system/>.  The GitHub
+# Ravenbot user <sysadmins@ravenbrook.com> is an administrator
+# <https://readthedocs.org/profiles/Ravenbot/>.
+
+version: 2
+
+build:
+  os: ubuntu-22.04
+  tools:
+    python: '3'
+
+python:
+  install:
+    - requirements: manual/requirements.pip
+
+sphinx:
+  configuration: manual/source/conf.py
+  fail_on_warning: true
+
+# A. REFERENCES
+#
+# [Readthedocs] "Read the Docs: Documentation Simplified";
+# <https://docs.readthedocs.io/en/stable/>.
+#
+#
+# B. DOCUMENT HISTORY
+#
+# 2023-02-02 RB Created as part of MPS GitHub migration.
+#
+#
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright © 2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
+# 
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+# 
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+# 
+# 2. 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.
+#
+#
+# $Id$

mps/.travis.yml

@@ -0,0 +1,105 @@
+# .travis.yml -- Travis CI configuration for the MPS
+#
+# Copyright (c) 2013-2023 Ravenbrook Limited. See end of file for license.
+#
+# See design.mps.test.ci.
+
+# Some branches don't need builds.  Add them here to avoid using build
+# resources and unnecessary build messages.
+branches:
+  except:
+    - branch/2023-01-07/pull-request-merge-procedure
+    - branch/2023-01-11/github-ci
+
+language: c # see <https://docs.travis-ci.com/user/languages/c/>.
+
+# The build matrix for Travis CI
+#
+# See design.mps.tests.ci.travis.platforms.
+#
+# Most x86_64/amd64 builds are in GitHub CI, configured by
+# .github/workflows/build-and-test.yml.
+
+os:
+  - freebsd
+  - linux
+arch:
+  - arm64
+compiler:
+  - clang
+  - gcc
+
+script: # see design.mps.test.ci.run.posix
+- ./configure --prefix=$PWD/prefix && make install && make test
+
+matrix:
+
+  # Extra build jobs to add to the matrix
+  include:
+
+    # GitHub CI does not provide FreeBSD
+    # <https://docs.github.com/en/actions/using-github-hosted-runners/about-github-hosted-runners#supported-runners-and-hardware-resources>
+    # on any architecture, so we add it here for amd64.  See also
+    # design.mps.tests.ci.travis.platforms.
+
+    - os: freebsd
+      arch: amd64
+      compiler: clang
+    - os: freebsd
+      arch: amd64
+      compiler: gcc
+
+  # Specific combinations to exclude from the matrix
+  exclude:
+    - os: osx
+      compiler: gcc
+
+notifications:
+  email:
+    - mps-travis@ravenbrook.com
+
+# This shows how you can ask Travis to install or update packages.
+#before_install:
+#  - if test "$TRAVIS_OS_NAME" = "linux"; then sudo apt-get -qq update; fi
+#  - if test "$TRAVIS_OS_NAME" = "linux"; then sudo apt-get install -y gcc-4.7; fi
+
+
+# A. REFERENCES
+#
+#
+# B. DOCUMENT HISTORY
+#
+# 2013-05-19 RB Created.
+# 2023-01-15 RB Added licence and (note) document history.
+#
+#
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2013-2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+#
+#
+# $Id$

mps/CONTRIBUTING

@@ -0,0 +1 @@
+contributing.rst

mps/INSTALL

@@ -0,0 +1 @@
+manual/build.txt

mps/Makefile.in

@@ -0,0 +1,115 @@
+# Makefile.in -- source for autoconf Makefile
+#
+# $Id$
+# Copyright (C) 2012-2023 Ravenbrook Limited.  See end of file for license.
+#
+# YOU DON'T NEED AUTOCONF TO BUILD THE MPS
+# This is just here for people who want or expect a configure script.
+# See [Building the Memory Pool System](manual/build.txt) for how best
+# to build and integrate the MPS.
+#
+# THIS IS NOT A GNU MAKEFILE
+# This makefile be compatible with the default make on every (Posix)
+# target platform, e.g. BSD make.
+#
+
+INSTALL=@INSTALL@
+INSTALL_DATA=@INSTALL_DATA@
+INSTALL_PROGRAM=@INSTALL_PROGRAM@
+MAKE=@MAKE@
+MPS_OS_NAME=@MPS_OS_NAME@
+MPS_ARCH_NAME=@MPS_ARCH_NAME@
+MPS_BUILD_NAME=@MPS_BUILD_NAME@
+MPS_TARGET_NAME=$(MPS_OS_NAME)$(MPS_ARCH_NAME)$(MPS_BUILD_NAME)
+EXTRA_TARGETS=@EXTRA_TARGETS@
+prefix=$(DESTDIR)@prefix@
+TARGET_OPTS=-C code -f $(MPS_TARGET_NAME).gmk EXTRA_TARGETS="$(EXTRA_TARGETS)"
+XCODEBUILD=xcrun xcodebuild -project code/mps.xcodeproj
+
+all: @BUILD_TARGET@
+
+build-via-make:
+	$(MAKE) $(TARGET_OPTS)
+
+clean-make-build:
+	$(MAKE) $(TARGET_OPTS) clean
+
+install-make-build: make-install-dirs build-via-make
+	$(INSTALL_DATA) code/mps*.h $(prefix)/include/
+	$(INSTALL_DATA) code/$(MPS_TARGET_NAME)/cool/mps.a $(prefix)/lib/libmps-debug.a
+	$(INSTALL_DATA) code/$(MPS_TARGET_NAME)/hot/mps.a $(prefix)/lib/libmps.a
+	for PROGRAM in $(EXTRA_TARGETS); do $(INSTALL_PROGRAM) code/$(MPS_TARGET_NAME)/hot/$$PROGRAM $(prefix)/bin/$$PROGRAM; done
+
+build-via-xcode:
+	$(XCODEBUILD) -config Debug
+	$(XCODEBUILD) -config Release
+
+clean-xcode-build:
+	$(XCODEBUILD) -config Debug   clean
+	$(XCODEBUILD) -config Release clean
+
+install-xcode-build: make-install-dirs build-via-xcode
+	$(INSTALL_DATA) code/mps*.h $(prefix)/include/
+	$(INSTALL_DATA) code/xc/Debug/libmps.a $(prefix)/lib/libmps-debug.a
+	$(INSTALL_DATA) code/xc/Release/libmps.a $(prefix)/lib/libmps.a
+	for PROGRAM in $(EXTRA_TARGETS); do $(INSTALL_PROGRAM) code/xc/Release/$$PROGRAM $(prefix)/bin/$$PROGRAM; done
+
+Makefile: Makefile.in config.status
+	./config.status Makefile
+
+clean: @CLEAN_TARGET@
+
+config.status: configure
+
+configure: configure.ac
+	autoreconf -vif
+
+distclean: clean
+	rm -rf autom4te.cache/ config.log config.status Makefile
+
+make-install-dirs:
+	mkdir -p $(prefix)/bin
+	mkdir -p $(prefix)/lib
+	mkdir -p $(prefix)/include
+
+install: @INSTALL_TARGET@
+
+test-make-build:
+	$(MAKE) $(TARGET_OPTS) testci testratio testscheme
+	$(MAKE) -C code -f anan$(MPS_BUILD_NAME).gmk VARIETY=cool clean testansi
+	$(MAKE) -C code -f anan$(MPS_BUILD_NAME).gmk VARIETY=cool CFLAGS="-DCONFIG_POLL_NONE" clean testpollnone
+
+test-xcode-build:
+	$(XCODEBUILD) -config Debug   -target testci
+	$(XCODEBUILD) -config Release -target testci
+
+test: @TEST_TARGET@
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2012-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.

mps/NEWS

@@ -0,0 +1 @@
+manual/source/release.rst

mps/README

@@ -0,0 +1 @@
+readme.txt

mps/code/.gitignore

@@ -0,0 +1,63 @@
+# code/.p4ignore -- Perforce files to ignore list
+# $Id$
+# Make output
+anangc
+ananll
+ananmv
+fri3gc
+fri3ll
+fri6gc
+fri6ll
+lia6gc
+lia6ll
+lii3gc
+lii6gc
+lii6ll
+w3i3mv
+w3i6mv
+xca6ll
+xci3gc
+xci3ll
+xci6gc
+xci6ll
+# Visual Studio junk
+Debug
+Release
+*.filters
+*.user
+*.suo
+# Telemetry event logs
+mpsio*.log
+mpsio*.sql
+mpsio*.txt
+# Build products
+*.o
+*.obj
+*.a
+*.so
+*.lib
+*.exe
+a.out
+core
+# Xcode junk
+xc
+mps.xcodeproj/xcuserdata
+mps.xcodeproj/project.xcworkspace
+tags
+# Temporary files
+0
+1
+2
+3
+4
+5
+6
+7
+8
+9
+# Mac OS X Finder turds
+.DS_Store
+# Emacs backups
+*~
+# GNU make dependencies
+*/*/*.d

mps/code/.p4ignore

@@ -0,0 +1 @@
+.gitignore

mps/code/abq.c

@@ -0,0 +1,330 @@
+/* abq.c: QUEUE IMPLEMENTATION
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .purpose: A fixed-length FIFO queue.
+ *
+ * .design: <design/abq>
+ */
+
+#include "meter.h"
+#include "abq.h"
+#include "mpm.h"
+
+SRCID(abq, "$Id$");
+
+
+/* Private prototypes */
+
+static Size ABQQueueSize(Count elements, Size elementSize);
+static Index ABQNextIndex(ABQ abq, Index index);
+static void *ABQElement(ABQ abq, Index index);
+
+
+/* Methods */
+
+/* ABQInit -- Initialize an ABQ
+ *
+ * elements is the number of elements the queue can hold
+ */
+Res ABQInit(Arena arena, ABQ abq, void *owner, Count elements, Size elementSize)
+{
+  void *p;
+  Res res;
+
+  AVERT(Arena, arena);
+  AVER(abq != NULL);
+  AVER(elements > 0);
+
+  /* Allocate a dummy extra element in order to be able to distinguish
+     "empty" from "full" */
+  elements = elements + 1;
+
+  res = ControlAlloc(&p, arena, ABQQueueSize(elements, elementSize));
+  if (res != ResOK)
+    return res;
+
+  abq->elements = elements;
+  abq->elementSize = elementSize;
+  abq->in = 0;
+  abq->out = 0;
+  abq->queue = p;
+
+  METER_INIT(abq->push, "push", owner);
+  METER_INIT(abq->pop, "pop", owner);
+  METER_INIT(abq->peek, "peek", owner);
+  METER_INIT(abq->delete, "delete", owner);
+
+  abq->sig = ABQSig;
+
+  AVERT(ABQ, abq);
+  return ResOK;
+}
+
+
+/* ABQCheck -- validate an ABQ */
+Bool ABQCheck(ABQ abq)
+{
+  CHECKS(ABQ, abq);
+  CHECKL(abq->elements > 0);
+  CHECKL(abq->elementSize > 0);
+  CHECKL(abq->in < abq->elements);
+  CHECKL(abq->out < abq->elements);
+  CHECKL(abq->queue != NULL);
+
+  return TRUE;
+}
+
+
+/* ABQFinish -- finish an ABQ */
+void ABQFinish(Arena arena, ABQ abq)
+{
+  AVERT(Arena, arena);
+  AVERT(ABQ, abq);
+
+  METER_EMIT(&abq->push);
+  METER_EMIT(&abq->pop);
+  METER_EMIT(&abq->peek);
+  METER_EMIT(&abq->delete);
+  ControlFree(arena, abq->queue, ABQQueueSize(abq->elements, abq->elementSize));
+
+  abq->elements = 0;
+  abq->queue = NULL;
+
+  abq->sig = SigInvalid;
+}
+
+
+/* ABQPush -- push an element onto the tail of the ABQ */
+Bool ABQPush(ABQ abq, void *element)
+{
+  AVERT(ABQ, abq);
+
+  METER_ACC(abq->push, ABQDepth(abq));
+
+  if (ABQIsFull(abq))
+    return FALSE;
+
+  (void)mps_lib_memcpy(ABQElement(abq, abq->in), element, abq->elementSize);
+  abq->in = ABQNextIndex(abq, abq->in);
+
+  AVERT(ABQ, abq);
+  return TRUE;
+}
+
+
+/* ABQPop -- pop an element from the head of the ABQ */
+Bool ABQPop(ABQ abq, void *elementReturn)
+{
+  AVER(elementReturn != NULL);
+  AVERT(ABQ, abq);
+
+  METER_ACC(abq->pop, ABQDepth(abq));
+
+  if (ABQIsEmpty(abq))
+    return FALSE;
+
+  (void)mps_lib_memcpy(elementReturn, ABQElement(abq, abq->out), abq->elementSize);
+
+  abq->out = ABQNextIndex(abq, abq->out);
+
+  AVERT(ABQ, abq);
+  return TRUE;
+}
+
+
+/* ABQPeek -- peek at the head of the ABQ */
+Bool ABQPeek(ABQ abq, void *elementReturn)
+{
+  AVER(elementReturn != NULL);
+  AVERT(ABQ, abq);
+
+  METER_ACC(abq->peek, ABQDepth(abq));
+
+  if (ABQIsEmpty(abq))
+    return FALSE;
+
+  (void)mps_lib_memcpy(elementReturn, ABQElement(abq, abq->out), abq->elementSize);
+
+  /* Identical to pop, but don't increment out */
+
+  AVERT(ABQ, abq);
+  return TRUE;
+}
+
+
+/* ABQDescribe -- Describe an ABQ */
+Res ABQDescribe(ABQ abq, ABQDescribeElement describeElement, mps_lib_FILE *stream, Count depth)
+{
+  Res res;
+  Index index;
+
+  if (!TESTT(ABQ, abq))
+    return ResFAIL;
+  if (stream == NULL)
+    return ResFAIL;
+
+  res = WriteF(stream, depth,
+               "ABQ $P {\n", (WriteFP)abq,
+               "  elements $U\n", (WriteFU)abq->elements,
+               "  elementSize $W\n", (WriteFW)abq->elementSize,
+               "  in $U\n", (WriteFU)abq->in,
+               "  out $U\n", (WriteFU)abq->out,
+               "  queue:\n",
+               NULL);
+  if(res != ResOK)
+    return res;
+
+  for (index = abq->out; index != abq->in; ) {
+    res = (*describeElement)(ABQElement(abq, index), stream, depth + 2);
+    if(res != ResOK)
+      return res;
+    index = ABQNextIndex(abq, index);
+  }
+
+  METER_WRITE(abq->push, stream, depth + 2);
+  METER_WRITE(abq->pop, stream, depth + 2);
+  METER_WRITE(abq->peek, stream, depth + 2);
+  METER_WRITE(abq->delete, stream, depth + 2);
+
+  res = WriteF(stream, depth, "} ABQ $P\n", (WriteFP)abq, NULL);
+  if(res != ResOK)
+    return res;
+
+  return ResOK;
+}
+
+
+/* ABQIsEmpty -- Is an ABQ empty? */
+Bool ABQIsEmpty(ABQ abq)
+{
+  AVERT(ABQ, abq);
+
+  return abq->out == abq->in;
+}
+
+
+/* ABQIsFull -- Is an ABQ full? */
+Bool ABQIsFull(ABQ abq)
+{
+  AVERT(ABQ, abq);
+
+  return ABQNextIndex(abq, abq->in) == abq->out;
+}
+
+
+/* ABQDepth -- return the number of elements in an ABQ */
+Count ABQDepth(ABQ abq)
+{
+  Index out, in;
+
+  AVERT(ABQ, abq);
+  out = abq->out;
+  in = abq->in;
+
+  if (in >= out)
+    return in - out;
+  else
+    return in + abq->elements - out;
+}
+
+
+/* ABQIterate -- call 'visitor' for each element in an ABQ */
+void ABQIterate(ABQ abq, ABQVisitor visitor, void *closure)
+{
+  Index copy, index, in;
+
+  AVERT(ABQ, abq);
+  AVER(FUNCHECK(visitor));
+
+  copy = abq->out;
+  index = abq->out;
+  in = abq->in;
+
+  while (index != in) {
+    void *element = ABQElement(abq, index);
+    Bool delete = FALSE;
+    Bool cont;
+    cont = (*visitor)(&delete, element, closure);
+    AVERT(Bool, cont);
+    AVERT(Bool, delete);
+    if (!delete) {
+      if (copy != index)
+        (void)mps_lib_memcpy(ABQElement(abq, copy), element, abq->elementSize);
+      copy = ABQNextIndex(abq, copy);
+    }
+    index = ABQNextIndex(abq, index);
+    if (!cont)
+      break;
+  }
+
+  /* If any elements were deleted, need to copy remainder of queue. */
+  if (copy != index) {
+    while (index != in) {
+      (void)mps_lib_memcpy(ABQElement(abq, copy), ABQElement(abq, index),
+                           abq->elementSize);
+      copy = ABQNextIndex(abq, copy);
+      index = ABQNextIndex(abq, index);
+    }
+    abq->in = copy;
+  }
+
+  AVERT(ABQ, abq);
+}
+
+
+/* ABQQueueSize -- calculate the storage required for the vector to
+   store the elements */
+static Size ABQQueueSize(Count elements, Size elementSize)
+{
+  return (Size)(elements * elementSize);
+}
+
+
+/* ABQNextIndex -- calculate the next index into the queue vector from
+   the current one */
+static Index ABQNextIndex(ABQ abq, Index index)
+{
+  Index next = index + 1;
+  if (next == abq->elements)
+    next = 0;
+  return next;
+}
+
+/* ABQElement -- return pointer to the index'th element in the queue
+   vector. */
+static void *ABQElement(ABQ abq, Index index)
+{
+  return PointerAdd(abq->queue, index * abq->elementSize);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/abq.h

@@ -0,0 +1,90 @@
+/* abq.h: QUEUE INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .purpose: A fixed-length FIFO queue.
+ *
+ * .design: <design/abq>
+ */
+
+#ifndef abq_h
+#define abq_h
+
+#include "meter.h"
+#include "mpm.h"
+
+
+/* Signatures */
+
+#define ABQSig ((Sig)0x519AB099) /* SIGnature ABQ */
+
+
+/* Prototypes  */
+
+typedef struct ABQStruct *ABQ;
+typedef Res (*ABQDescribeElement)(void *element, mps_lib_FILE *stream, Count depth);
+typedef Bool (*ABQVisitor)(Bool *deleteReturn, void *element, void *closure);
+
+extern Res ABQInit(Arena arena, ABQ abq, void *owner, Count elements, Size elementSize);
+extern Bool ABQCheck(ABQ abq);
+extern void ABQFinish(Arena arena, ABQ abq);
+extern Bool ABQPush(ABQ abq, void *element);
+extern Bool ABQPop(ABQ abq, void *elementReturn);
+extern Bool ABQPeek(ABQ abq, void *elementReturn);
+extern Res ABQDescribe(ABQ abq, ABQDescribeElement describeElement, mps_lib_FILE *stream, Count depth);
+extern Bool ABQIsEmpty(ABQ abq);
+extern Bool ABQIsFull(ABQ abq);
+extern Count ABQDepth(ABQ abq);
+extern void ABQIterate(ABQ abq, ABQVisitor visitor, void *closure);
+
+
+/* Types */
+
+typedef struct ABQStruct
+{
+  Sig sig;              /* design.mps.sig.field */
+  Count elements;
+  Size elementSize;
+  Index in;
+  Index out;
+  void *queue;
+
+  /* Meter queue depth at each operation */
+  METER_DECL(push)
+  METER_DECL(pop)
+  METER_DECL(peek)
+  METER_DECL(delete)
+} ABQStruct;
+
+#endif /* abq_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/abqtest.c

@@ -0,0 +1,210 @@
+/* abqtest.c: AVAILABLE BLOCK QUEUE TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+#include "abq.h"
+#include "mps.h"
+#include "mpsavm.h"
+#include "mpscmfs.h"
+#include "mpstd.h"
+#include "testlib.h"
+
+#include <stdio.h> /* printf */
+
+
+SRCID(abqtest, "$Id$");
+
+static mps_pool_t pool;
+static ABQStruct abq; /* the ABQ which we will use */
+static Size abqSize; /* the size of the current ABQ */
+
+#define ABQ_SIZE 10
+#define TEST_ITER 10000
+
+
+static unsigned long abqRnd(unsigned long n)
+{
+  return rnd()%n;
+}
+
+
+static unsigned pushee = 1;
+static unsigned popee = 1;
+static unsigned deleted = 0;
+
+
+typedef struct TestBlockStruct *TestBlock;
+
+typedef struct TestBlockStruct
+{
+  TestBlock next;
+  unsigned id;
+  Addr base;
+  Addr limit;
+} TestBlockStruct;
+
+
+static TestBlock testBlocks = NULL;
+
+
+static TestBlock CreateTestBlock(unsigned no)
+{
+  TestBlock b;
+  mps_addr_t p;
+
+  die(mps_alloc(&p, pool, sizeof(TestBlockStruct)), "alloc");
+
+  b = p;
+  b->next = testBlocks;
+  b->id = no;
+  b->base = 0;
+  b->limit = 0;
+
+  testBlocks = b;
+
+  return b;
+}
+
+
+static void DestroyTestBlock(TestBlock b)
+{
+  if (b == testBlocks)
+    testBlocks = b->next;
+  else {
+    TestBlock prev;
+
+    for (prev = testBlocks; prev != 0; prev = prev->next)
+      if (prev->next == b) {
+        prev->next = b->next;
+        break;
+      }
+  }
+
+  mps_free(pool, b, sizeof(TestBlockStruct));
+}
+
+typedef struct TestClosureStruct *TestClosure;
+typedef struct TestClosureStruct {
+  TestBlock b;
+  Res res;
+} TestClosureStruct;
+
+static Bool TestDeleteCallback(Bool *deleteReturn, void *element,
+                               void *closure)
+{
+  TestBlock *a = (TestBlock *)element;
+  TestClosure cl = (TestClosure)closure;
+  if (*a == cl->b) {
+    *deleteReturn = TRUE;
+    cl->res = ResOK;
+  } else {
+    *deleteReturn = FALSE;
+  }
+  return TRUE;
+}
+
+
+static void step(void)
+{
+  TestBlock a;
+
+  switch (abqRnd(9)) {
+    case 0: case 1: case 2: case 3:
+  push:
+      a = CreateTestBlock(pushee);
+      if (!ABQPush(&abq, &a)) {
+        goto pop;
+      }
+      pushee++;
+      break;
+    case 5: case 6: case 7: case 8:
+  pop:
+      if (!ABQPop(&abq, &a)) {
+        goto push;
+      }
+      if (popee == deleted) {
+        popee++;
+        deleted = 0;
+      }
+      cdie(a->id == popee, "pop");
+      popee++;
+      DestroyTestBlock(a);
+      break;
+    default:
+      if (!deleted && (pushee > popee)) {
+        TestBlock b;
+        TestClosureStruct cl;
+        deleted = (unsigned)abqRnd (pushee - popee) + popee;
+        for (b = testBlocks; b != NULL; b = b->next)
+          if (b->id == deleted)
+            break;
+        cdie(b != NULL, "found to delete");
+        cl.b = b;
+        cl.res = ResFAIL;
+        ABQIterate(&abq, TestDeleteCallback, &cl);
+        cdie(cl.res == ResOK, "ABQIterate");
+      }
+  }
+}
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  int i;
+
+  testlib_init(argc, argv);
+
+  abqSize = 0;
+
+  die(mps_arena_create_k(&arena, mps_arena_class_vm(), mps_args_none),
+      "mps_arena_create");
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_MFS_UNIT_SIZE, sizeof(TestBlockStruct));
+    die(mps_pool_create_k(&pool, arena, mps_class_mfs(), args), "pool_create");
+  } MPS_ARGS_END(args);
+
+  die(ABQInit((Arena)arena, &abq, NULL, ABQ_SIZE, sizeof(TestBlock)),
+      "ABQInit");
+
+  abqSize = ABQ_SIZE;
+
+  for (i = 0; i < TEST_ITER; i++) {
+    step();
+  }
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/addrobj.c

@@ -0,0 +1,240 @@
+/* addrobj.c: BASE ADDRESS FROM INTERIOR POINTER TEST
+ *
+ * Copyright (c) 2023 Ravenbrook Limited. See end of file for license.
+ *
+ * .overview This test is for mps_addr_object(). Its intention is to
+ * verify that the function returns the appropriate base pointer to an
+ * object when provided with an interior pointer. It also tests that the
+ * function fails appropriately when the provided with a pointer to
+ * unmanaged memory, or to an object in a pool that doesn't support this
+ * feature.
+ *
+ * .limitations Objects that have been moved should cause the function to
+ * fail with MPS_RES_FAIL, however this is not tested. It could be tested if
+ * a testbench deliberately created a forwarding object, however this might
+ * confuse a pool that does automatic garbage collection such as AMC or AMCZ,
+ * so any such test would need to be designed to handle that.
+ * This test only examines behaviour in AMCZ and MVFF pools, i.e. A pool (AMCZ)
+ * which currently implements mps_addr_object() and one (MVFF) that doesn't.
+ */
+
+#include "mps.h"
+#include "testlib.h"
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mpsavm.h"
+#include "mpscamc.h"
+#include "mpscmvff.h"
+#include "stdio.h"
+#include <stdlib.h>
+
+/* Define an object size to allocate. The size chosen doesn't matter much, except that this testbench assumes
+   that the object is large enough that a pointer could point to the interior of the object, without also
+   pointing to the base pointer of the object at the same time. For char pointers, this is probably 2 bytes.
+   Since we are using the Dylan library, we define the size of the object in terms of Dylan slots. See
+   fmtdytst.c for details of the Dylan object structure.*/
+#define N_SLOT_TESTOBJ 100
+
+static void test_main(void)
+{
+  mps_arena_t arena;
+  mps_pool_t amcz_pool, mvff_pool;
+  mps_ap_t obj_ap;
+  mps_fmt_t obj_fmt;
+  mps_root_t testobj_root;
+  mps_res_t res;
+  /* In another testbench (extcon.c) we observed unreliable failures to do with registering the cold end
+     of the stack.  See GitHub issue #210
+     <https://github.com/Ravenbrook/mps/issues/210>.  For now, we
+     declare this as a separate root. */
+  static mps_addr_t testobj;
+  mps_addr_t out, in;
+
+  /* Create arena */
+  die(mps_arena_create_k(&arena, mps_arena_class_vm(), mps_args_none), "mps_arena_create_k");
+
+
+  /* INTRO TO TESTS: There are several tests. They test the expected "normal" operation of the
+     function, using an interior pointer, also corner cases where the interior pointer equals the
+     base pointer, where it equals the limit pointer. We also test asking about an address in unmanaged
+     memory, and about an address in a pool which currently does not support mps_addr_object. If you write
+     more tests, describe them here.*/
+
+
+  /* TEST 1: Test using an interior pointer in an object in an AMCZ pool.
+     At the time of writing this test, the AMCZ pool is the only pool where
+     there exists a requirement to provide base addresses from interior pointers.
+     Currently, the AMCZ pool (and by extension, the AMC pool which shares the same
+     module as AMCZ) is the only pool for which mps_addr_object is implemented */
+
+  /* Use the dylan format for convenience */
+  die(dylan_fmt(&obj_fmt, arena), "dylan_fmt");
+
+  /* Create the pool */
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, obj_fmt);
+    die(mps_pool_create_k(&amcz_pool, arena, mps_class_amcz(), args), "mps_pool_create_k amcz");
+  } MPS_ARGS_END(args);
+
+  /* Create an area of ambiguous pointers to keep the object alive and in place, in this case
+     the area only contains room for a single reference since we are only using one object to test */
+  die(mps_root_create_area(&testobj_root, arena,
+                           mps_rank_ambig(), (mps_rm_t)0,
+                           &testobj, &testobj+1,
+                           mps_scan_area, NULL),
+          "mps_root_create_area");
+
+  /* Create the allocation point */
+  die(mps_ap_create_k(&obj_ap, amcz_pool, mps_args_none), "mps_ap_create_k");
+
+  /* Make a Dylan object, size = (N_SLOT_TESTOBJ+2) * sizeof(mps_word_t).
+     (See fmtdytst.c for size calculation) */
+  {
+    /* Because make_dylan_vector returns its pointer-to-object as an mps_word_t rather than an
+       mps_addr_t, and commits the object, we need to somehow safely allocate our object without
+       type punning and without risking that our object be destroyed.
+       Rather than redefine our reference table with type mps_word_t, which hides the intention of the table,
+       park the arena to disable garbage collection. Allocate our dylan object on the (unregistered) stack
+       storing its address in an mps_word_t. Then store this mps_word_t as an mps_addr_t in our reference
+       table, and release the arena since our object is now safely pinned.
+       Another approach would be to create another static registered root for ambiguous references of type
+       mps_word_t and then copy to the mps_addr_t root, which would avoid needing to park the arena.
+    */
+    mps_word_t p_word;
+    mps_arena_park(arena);
+    die(make_dylan_vector(&p_word, obj_ap, N_SLOT_TESTOBJ), "make_dylan_vector");
+    /* If we hadn't parked the arena, our vector might have been GC'd here */
+    testobj = (mps_addr_t)p_word;
+    mps_arena_release(arena);
+  }
+
+  /* Construct a pointer to roughly halfway inside the object */
+  in = (mps_addr_t)((char *)testobj + (N_SLOT_TESTOBJ/2) * sizeof(mps_word_t));
+
+  /* Ensure that this is an interior pointer, and not the base pointer,
+     since we want to make sure we are testing with a true interior pointer and not
+     one that also happens to be the base pointer. This Insist is intended to protect
+     against the testbench losing its ability to test "true" interior pointers (i.e. ones
+     which don't match the base pointer) if the test object sizes were changed to be very
+     small. Note that we don't currently consider the "limit" of the object as a corner case
+     (so we don't Insist(in != limit) ) but we do consider limit+1, i.e. the pointer to the
+     next object to be a corner case. This test could be updated to consider in == limit as a
+     corner case. */
+  Insist(in > testobj);
+
+  /* Do Test */
+  res = mps_addr_object(&out, arena, in);
+  Insist(out == testobj);
+  Insist(res == MPS_RES_OK);
+  printf("Interior pointer input: passed\n");
+
+
+  /* TEST 2: Test using the base pointer itself as an input*/
+
+  in = testobj;
+
+  /* Do Test */
+  res = mps_addr_object(&out, arena, in);
+  Insist(out == testobj);
+  Insist(res == MPS_RES_OK);
+  printf("Base pointer input: passed\n");
+
+
+
+   /* TEST 3: Test using a pointer one-off-the-end of the object*/
+
+  in =  (mps_addr_t)((char *)testobj + (N_SLOT_TESTOBJ + 2) * sizeof(mps_word_t));
+
+  /* Do Test */
+  res = mps_addr_object(&out, arena, in);
+  Insist(res == MPS_RES_FAIL);
+  printf("Pointer to next object input: passed\n");
+
+
+  /* Clean up from above tests */
+  mps_root_destroy(testobj_root);
+  mps_ap_destroy(obj_ap);
+  mps_pool_destroy(amcz_pool);
+  mps_fmt_destroy(obj_fmt);
+
+
+  /* TEST 4: Test using a pointer in unmanaged memory */
+
+  /* Use malloc to allocate non-mps-managed memory on the heap */
+  in = malloc(sizeof(mps_word_t));
+  Insist(NULL != in);
+
+  /* Do the test */
+  res = mps_addr_object(&out, arena, in);
+
+  /* Expect MPS to fail to find a base pointer for addresses not in managed memory */
+  Insist(res == MPS_RES_FAIL);
+  printf("Pointer to unmanaged memory input: passed\n");
+
+  /* clean up from this test */
+  if (NULL != in)
+    free(in);
+
+
+  /* TEST 5: Test using a pointer in a pool which currently doesn't implement mps_addr_object */
+
+  /* Create mvff pool for which mps_addr_object is not implemented */
+  die(mps_pool_create_k(&mvff_pool, arena, mps_class_mvff(), mps_args_none), "mps_pool_create_k mvff");
+
+  /* allocate an object (just some memory) in this pool */
+  die(mps_alloc(&in, mvff_pool, sizeof(mps_word_t)), "mps_alloc");
+
+  /* Do the test */
+  res = mps_addr_object(&out, arena, in);
+
+  Insist(res == MPS_RES_UNIMPL);
+  printf("Pointer to object in pool where mps_addr_object not implemented: passed\n");
+
+
+  /* If more tests are added here, briefly describe them above under "INTRO TO TESTS" comment */
+
+  /* Final clean up */
+  mps_free(mvff_pool, in, sizeof(mps_word_t));
+  mps_pool_destroy(mvff_pool);
+  mps_arena_destroy(arena);
+}
+
+int main(int argc, char *argv[])
+{
+  testlib_init(argc, argv);
+
+  test_main();
+
+  printf("%s: Conclusion, failed to find any defects.\n", argv[0]);
+
+  return 0;
+}
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2022-2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/airtest.c

@@ -0,0 +1,191 @@
+/* airtest.c: AMBIGUOUS INTERIOR REFERENCE TEST
+ *
+ * $Id$
+ * Copyright (c) 2014-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .overview: This test case creates a bunch of vectors, registers
+ * them for finalization, and then discards the base pointers to those
+ * objects, keeping only ambiguous interior references to the vector
+ * entries in the stack-allocated table s.
+ *
+ * .options: The test has two options:
+ *
+ * 'interior' is the value passed as MPS_KEY_INTERIOR when creating
+ * the AMC pool. If TRUE, interior pointers must keep objects alive,
+ * and so if any of these objects are finalized, the test fails. If
+ * FALSE, interior pointers do not keep objects alive, so it is likely
+ * that all the objects will be finalized.
+ *
+ * 'stack' is TRUE if the C stack is registered as a root. (If FALSE,
+ * we register the table of interior pointers as an ambiguous root.)
+ *
+ * .fail.lii6ll: The test case passes on most platforms with
+ * interior=FALSE and stack=TRUE (that is, all vectors get finalized),
+ * but fails on lii6ll in variety HOT. Rather than struggle to defeat
+ * the Clang optimizer, we choose not to test in this configuration.
+ * In any case, the MPS does not guarantee anything about timely
+ * finalization <manual/html/topic/finalization.html#cautions>.
+ */
+
+#include "mps.h"
+#include "mpsavm.h"
+#include "mpscamc.h"
+#include "mpslib.h"
+#include "testlib.h"
+#include "fmtscheme.h"
+
+#define OBJ_LEN (1u << 4)
+#define OBJ_COUNT 10
+
+static void test_air(int interior, int stack)
+{
+  size_t n_finalized = 0;
+  size_t i, j;
+  obj_t *s[OBJ_COUNT] = {0};
+  mps_root_t root = NULL;
+  if (!stack) {
+    mps_addr_t *p = (void *)s;
+    die(mps_root_create_table(&root, scheme_arena, mps_rank_ambig(), 0, p,
+                              OBJ_COUNT), "mps_root_create_table");
+  }
+  mps_message_type_enable(scheme_arena, mps_message_type_finalization());
+  for (j = 0; j < OBJ_COUNT; ++j) {
+    obj_t n = scheme_make_integer(obj_ap, (long)j);
+    obj_t obj = scheme_make_vector(obj_ap, OBJ_LEN, n);
+    mps_addr_t ref = obj;
+    mps_finalize(scheme_arena, &ref);
+    s[j] = obj->vector.vector;
+  }
+  for (i = 1; i < OBJ_LEN; ++i) {
+    obj_t n = scheme_make_integer(obj_ap, (long)i);
+    mps_message_t msg;
+    for (j = 0; j + 1 < OBJ_COUNT; ++j) {
+      *++s[j] = n;
+    }
+    mps_arena_collect(scheme_arena);
+    mps_arena_release(scheme_arena);
+    if (mps_message_get(&msg, scheme_arena, mps_message_type_finalization())) {
+      mps_addr_t ref;
+      mps_message_finalization_ref(&ref, scheme_arena, msg);
+      ++ n_finalized;
+      if (interior) {
+        obj_t o;
+        o = ref;
+        error("wrongly finalized vector %ld at %p",
+              o->vector.vector[0]->integer.integer, (void *)o);
+      }
+    }
+  }
+  if (!interior && n_finalized < OBJ_COUNT) {
+    error("only finalized %"PRIuLONGEST" out of %"PRIuLONGEST" vectors.",
+          (ulongest_t)n_finalized, (ulongest_t)OBJ_COUNT);
+  }
+  if (!stack) {
+    mps_root_destroy(root);
+  }
+}
+
+static mps_gen_param_s obj_gen_params[] = {
+  { 150, 0.85 },
+  { 170, 0.45 }
+};
+
+static void test_main(void *marker, int interior, int stack)
+{
+  mps_res_t res;
+  mps_chain_t obj_chain;
+  mps_fmt_t obj_fmt;
+  mps_thr_t thread;
+  mps_root_t reg_root = NULL;
+
+  res = mps_arena_create_k(&scheme_arena, mps_arena_class_vm(), mps_args_none);
+  if (res != MPS_RES_OK)
+    error("Couldn't create arena");
+
+  res = mps_chain_create(&obj_chain, scheme_arena,
+                         sizeof(obj_gen_params) / sizeof(*obj_gen_params),
+                         obj_gen_params);
+  if (res != MPS_RES_OK)
+    error("Couldn't create obj chain");
+
+  scheme_fmt(&obj_fmt);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_CHAIN, obj_chain);
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, obj_fmt);
+    MPS_ARGS_ADD(args, MPS_KEY_INTERIOR, interior);
+    die(mps_pool_create_k(&obj_pool, scheme_arena, mps_class_amc(), args),
+        "mps_pool_create_k");
+  } MPS_ARGS_END(args);
+
+  res = mps_ap_create_k(&obj_ap, obj_pool, mps_args_none);
+  if (res != MPS_RES_OK)
+    error("Couldn't create obj allocation point");
+
+  res = mps_thread_reg(&thread, scheme_arena);
+  if (res != MPS_RES_OK)
+    error("Couldn't register thread");
+
+  if (stack) {
+    res = mps_root_create_thread(&reg_root, scheme_arena, thread, marker);
+    if (res != MPS_RES_OK)
+      error("Couldn't create root");
+  }
+
+  test_air(interior, stack);
+
+  mps_arena_park(scheme_arena);
+  if (stack)
+    mps_root_destroy(reg_root);
+  mps_thread_dereg(thread);
+  mps_ap_destroy(obj_ap);
+  mps_pool_destroy(obj_pool);
+  mps_chain_destroy(obj_chain);
+  mps_fmt_destroy(obj_fmt);
+  mps_arena_destroy(scheme_arena);
+}
+
+int main(int argc, char *argv[])
+{
+  void *marker = &marker;
+
+  testlib_init(argc, argv);
+
+  test_main(marker, TRUE, TRUE);
+  test_main(marker, TRUE, FALSE);
+  /* not test_main(marker, FALSE, TRUE) -- see .fail.lii6ll. */
+  test_main(marker, FALSE, FALSE);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2014-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/amcss.c

@@ -0,0 +1,385 @@
+/* amcss.c: POOL CLASS AMC STRESS TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ */
+
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "testlib.h"
+#include "mpm.h"
+#include "mpslib.h"
+#include "mpscamc.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#include "mps.h"
+#include "mpslib.h"
+
+#include <stdio.h> /* fflush, printf, putchar */
+
+
+/* These values have been tuned in the hope of getting one dynamic collection. */
+#define testArenaSIZE     ((size_t)1000*1024)
+#define gen1SIZE          ((size_t)20)
+#define gen2SIZE          ((size_t)85)
+#define avLEN             3
+#define exactRootsCOUNT   180
+#define ambigRootsCOUNT   50
+#define genCOUNT          2
+#define collectionsCOUNT  37
+#define rampSIZE          9
+#define initTestFREQ      6000
+
+/* testChain -- generation parameters for the test */
+
+static mps_gen_param_s testChain[genCOUNT] = {
+  { gen1SIZE, 0.85 }, { gen2SIZE, 0.45 } };
+
+
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL           ((mps_addr_t)MPS_WORD_CONST(0xDECEA5ED))
+
+
+static mps_arena_t arena;
+static mps_ap_t ap;
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+static size_t scale;            /* Overall scale factor. */
+static unsigned long nCollsStart;
+static unsigned long nCollsDone;
+
+
+/* report -- report statistics from any messages */
+
+static void report(void)
+{
+  mps_message_type_t type;
+
+  while(mps_message_queue_type(&type, arena)) {
+    mps_message_t message;
+
+    cdie(mps_message_get(&message, arena, type), "message get");
+
+    if (type == mps_message_type_gc_start()) {
+      nCollsStart += 1;
+      printf("\n{\n  Collection %lu started.  Because:\n", nCollsStart);
+      printf("    %s\n", mps_message_gc_start_why(arena, message));
+      printf("    clock: %"PRIuLONGEST"\n", (ulongest_t)mps_message_clock(arena, message));
+
+    } else if (type == mps_message_type_gc()) {
+      size_t live, condemned, not_condemned;
+
+      nCollsDone += 1;
+      live = mps_message_gc_live_size(arena, message);
+      condemned = mps_message_gc_condemned_size(arena, message);
+      not_condemned = mps_message_gc_not_condemned_size(arena, message);
+
+      printf("\n  Collection %lu finished:\n", nCollsDone);
+      printf("    live %"PRIuLONGEST"\n", (ulongest_t)live);
+      printf("    condemned %"PRIuLONGEST"\n", (ulongest_t)condemned);
+      printf("    not_condemned %"PRIuLONGEST"\n", (ulongest_t)not_condemned);
+      printf("    clock: %"PRIuLONGEST"\n", (ulongest_t)mps_message_clock(arena, message));
+      printf("}\n");
+    } else {
+      cdie(0, "unknown message type");
+      break;
+    }
+
+    mps_message_discard(arena, message);
+  }
+}
+
+
+/* make -- create one new object */
+
+static mps_addr_t make(size_t rootsCount)
+{
+  /* The calls variable is useful when debugging to stop the debugging
+     after a certain number of allocations using a debugger
+     "watchpoint".  Allocations are a good "clock tick" for this test.
+     The test itself doesn't use the variable, so we declare it
+     volatile, which also forces updates into memory. */
+  static volatile unsigned long calls = 0;
+  size_t length = rnd() % (scale * avLEN);
+  size_t size = (length+2) * sizeof(mps_word_t);
+  mps_addr_t p;
+  mps_res_t res;
+  ++ calls;
+
+  do {
+    MPS_RESERVE_BLOCK(res, p, ap, size);
+    if (res) {
+      ArenaDescribe(arena, mps_lib_get_stderr(), 4);
+      die(res, "MPS_RESERVE_BLOCK");
+    }
+    res = dylan_init(p, size, exactRoots, rootsCount);
+    if (res)
+      die(res, "dylan_init");
+  } while(!mps_commit(ap, p, size));
+
+  return p;
+}
+
+
+/* test_stepper -- stepping function for walk */
+
+static void test_stepper(mps_addr_t object, mps_fmt_t fmt, mps_pool_t pool,
+                         void *p, size_t s)
+{
+  testlib_unused(object); testlib_unused(fmt); testlib_unused(pool);
+  testlib_unused(s);
+  (*(unsigned long *)p)++;
+}
+
+
+/* area_scan -- area scanning function for mps_pool_walk */
+
+static mps_res_t area_scan(mps_ss_t ss, void *base, void *limit, void *closure)
+{
+  unsigned long *count = closure;
+  mps_res_t res;
+  while (base < limit) {
+    mps_addr_t prev = base;
+    ++ *count;
+    res = dylan_scan1(ss, &base);
+    if (res != MPS_RES_OK) return res;
+    Insist(prev < base);
+  }
+  Insist(base == limit);
+  return MPS_RES_OK;
+}
+
+
+/* test -- the body of the test */
+
+static void test(mps_pool_class_t pool_class, size_t roots_count)
+{
+  mps_fmt_t format;
+  mps_chain_t chain;
+  mps_root_t exactRoot, ambigRoot;
+  unsigned long objs; size_t i;
+  mps_word_t collections, rampSwitch;
+  mps_alloc_pattern_t ramp = mps_alloc_pattern_ramp();
+  int ramping;
+  mps_ap_t busy_ap;
+  mps_addr_t busy_init;
+  mps_pool_t pool;
+  int described = 0;
+
+  die(dylan_fmt(&format, arena), "fmt_create");
+  die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
+
+  die(mps_pool_create(&pool, arena, pool_class, format, chain),
+      "pool_create(amc)");
+
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+  die(mps_ap_create(&busy_ap, pool, mps_rank_exact()), "BufferCreate 2");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  for(i = 0; i < ambigRootsCOUNT; ++i)
+    ambigRoots[i] = rnd_addr();
+
+  die(mps_root_create_table_masked(&exactRoot, arena,
+                                   mps_rank_exact(), (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT,
+                                   (mps_word_t)1),
+      "root_create_table(exact)");
+  die(mps_root_create_table(&ambigRoot, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &ambigRoots[0], ambigRootsCOUNT),
+      "root_create_table(ambig)");
+
+  /* create an ap, and leave it busy */
+  die(mps_reserve(&busy_init, busy_ap, 64), "mps_reserve busy");
+
+  nCollsStart = 0;
+  nCollsDone = 0;
+  collections = 0;
+  rampSwitch = rampSIZE;
+  die(mps_ap_alloc_pattern_begin(ap, ramp), "pattern begin (ap)");
+  die(mps_ap_alloc_pattern_begin(busy_ap, ramp), "pattern begin (busy_ap)");
+  ramping = 1;
+  objs = 0;
+  while (collections < collectionsCOUNT) {
+    size_t r;
+
+    report();
+    if (collections != nCollsStart) {
+      if (!described) {
+        die(ArenaDescribe(arena, mps_lib_get_stdout(), 0), "ArenaDescribe");
+        described = TRUE;
+      }
+      collections = nCollsStart;
+
+      printf("%lu objects (nCollsStart=%"PRIuLONGEST")\n", objs,
+             (ulongest_t)collections);
+
+      /* test mps_arena_has_addr */
+      {
+        size_t hitRatio;
+        unsigned hitsWanted = 4;  /* aim for 4 hits (on average) */
+        /* [Note: The for-loop condition used to be "i < 4 * hitRatio",
+         *  with "4" an unexplained naked constant.  I have now labelled
+         *  it "hitsWanted", as I think that is the intent.  RHSK]
+         */
+
+        /* how many random addrs must we try, to hit the arena once? */
+        hitRatio = (0xfffffffful / mps_arena_committed(arena));
+        for (i = 0; i < hitsWanted * hitRatio ; i++) {
+          /* An exact root maybe in the arena, so add a random 32-bit
+           * offset to it.  We may get no hits if it is objNULL.
+           */
+          mps_addr_t p = (char *)exactRoots[rnd() % exactRootsCOUNT]
+                         + rnd()-0x80000000ul;
+          if (mps_arena_has_addr(arena, p)) {
+            printf("%p is in the arena\n", p);
+          }
+        }
+      }
+
+      for (i = 0; i < exactRootsCOUNT; ++i)
+        cdie(exactRoots[i] == objNULL
+             || (dylan_check(exactRoots[i])
+                 && mps_arena_has_addr(arena, exactRoots[i])),
+             "all roots check");
+      cdie(!mps_arena_has_addr(arena, NULL),
+           "NULL in arena");
+
+      if (collections == collectionsCOUNT / 2) {
+        unsigned long count1 = 0, count2 = 0;
+        mps_arena_park(arena);
+        mps_arena_formatted_objects_walk(arena, test_stepper, &count1, 0);
+        die(mps_pool_walk(pool, area_scan, &count2), "mps_pool_walk");
+        mps_arena_release(arena);
+        printf("stepped on %lu objects.\n", count1);
+        printf("walked %lu objects.\n", count2);
+        Insist(count1 == count2);
+      }
+      if (collections == rampSwitch) {
+        int begin_ramp = !ramping
+          || /* Every other time, switch back immediately. */ (collections & 1);
+
+        rampSwitch += rampSIZE;
+        if (ramping) {
+          die(mps_ap_alloc_pattern_end(ap, ramp), "pattern end (ap)");
+          die(mps_ap_alloc_pattern_end(busy_ap, ramp), "pattern end (busy_ap)");
+          ramping = 0;
+          /* kill half of the roots */
+          for(i = 0; i < exactRootsCOUNT; i += 2) {
+            if (exactRoots[i] != objNULL) {
+              cdie(dylan_check(exactRoots[i]), "ramp kill check");
+              exactRoots[i] = objNULL;
+            }
+          }
+        }
+        if (begin_ramp) {
+          die(mps_ap_alloc_pattern_begin(ap, ramp),
+              "pattern rebegin (ap)");
+          die(mps_ap_alloc_pattern_begin(busy_ap, ramp),
+              "pattern rebegin (busy_ap)");
+          ramping = 1;
+        }
+      }
+    }
+
+    r = (size_t)rnd();
+    if (r & 1) {
+      i = (r >> 1) % exactRootsCOUNT;
+      if (exactRoots[i] != objNULL)
+        cdie(dylan_check(exactRoots[i]), "dying root check");
+      exactRoots[i] = make(roots_count);
+      if (exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+        dylan_write(exactRoots[(exactRootsCOUNT-1) - i],
+                    exactRoots, exactRootsCOUNT);
+    } else {
+      i = (r >> 1) % ambigRootsCOUNT;
+      ambigRoots[(ambigRootsCOUNT-1) - i] = make(roots_count);
+      /* Create random interior pointers */
+      ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 1);
+    }
+
+    if (r % initTestFREQ == 0)
+      *(int*)busy_init = -1; /* check that the buffer is still there */
+
+    if (objs % 1024 == 0) {
+      report();
+      putchar('.');
+      (void)fflush(stdout);
+    }
+
+    ++objs;
+  }
+
+  (void)mps_commit(busy_ap, busy_init, 64);
+  mps_arena_park(arena);
+  mps_ap_destroy(busy_ap);
+  mps_ap_destroy(ap);
+  mps_root_destroy(exactRoot);
+  mps_root_destroy(ambigRoot);
+  mps_pool_destroy(pool);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(format);
+  mps_arena_release(arena);
+}
+
+int main(int argc, char *argv[])
+{
+  size_t i, grainSize;
+  mps_thr_t thread;
+
+  testlib_init(argc, argv);
+
+  scale = (size_t)1 << (rnd() % 6);
+  for (i = 0; i < genCOUNT; ++i) testChain[i].mps_capacity *= scale;
+  grainSize = rnd_grain(scale * testArenaSIZE);
+  printf("Picked scale=%lu grainSize=%lu\n", (unsigned long)scale, (unsigned long)grainSize);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, scale * testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, grainSize);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "arena_create");
+  } MPS_ARGS_END(args);
+  mps_message_type_enable(arena, mps_message_type_gc());
+  mps_message_type_enable(arena, mps_message_type_gc_start());
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  test(mps_class_amc(), exactRootsCOUNT);
+  test(mps_class_amcz(), 0);
+  mps_thread_dereg(thread);
+  report();
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/amcsshe.c

@@ -0,0 +1,295 @@
+/* amcsshe.c: POOL CLASS AMC STRESS TEST WITH HEADER
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (c) 2002 Global Graphics Software.
+ */
+
+#include "fmthe.h"
+#include "fmtdytst.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include "mpscamc.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#include "mps.h"
+
+#include <stdio.h> /* fflush, printf, putchar */
+
+
+/* These values have been tuned in the hope of getting one dynamic collection. */
+#define headerFACTOR      ((float)(20 + headerSIZE) / 20)
+/* headerFACTOR measures how much larger objects are compared to fmtdy. */
+#define testArenaSIZE     ((size_t)(2000*headerFACTOR)*1024)
+#define gen1SIZE          ((size_t)(150*headerFACTOR))
+#define gen2SIZE          ((size_t)(170*headerFACTOR))
+#define avLEN             3
+#define exactRootsCOUNT   200
+#define ambigRootsCOUNT   50
+#define bogusRootsCOUNT   4096
+#define collectionsCOUNT  37
+#define rampSIZE          9
+#define initTestFREQ      6000
+#define genCOUNT          2
+
+/* testChain -- generation parameters for the test */
+
+static mps_gen_param_s testChain[genCOUNT] = {
+  { gen1SIZE, 0.85 }, { gen2SIZE, 0.45 } };
+
+
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL           ((mps_addr_t)MPS_WORD_CONST(0xDECEA5ED))
+
+
+static mps_pool_t pool;
+static mps_ap_t ap;
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+static mps_addr_t bogusRoots[bogusRootsCOUNT];
+
+static mps_addr_t make(size_t roots_count)
+{
+  size_t length = rnd() % (2*avLEN);
+  size_t size = (length+2) * sizeof(mps_word_t);
+  mps_addr_t p, userP;
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, p, ap, size + headerSIZE);
+    if (res)
+      die(res, "MPS_RESERVE_BLOCK");
+    userP = (mps_addr_t)((char*)p + headerSIZE);
+    res = dylan_init(userP, size, exactRoots, roots_count);
+    if (res)
+      die(res, "dylan_init");
+    ((int*)p)[0] = realHeader;
+    ((int*)p)[1] = 0xED0ED;
+  } while(!mps_commit(ap, p, size + headerSIZE));
+
+  return userP;
+}
+
+
+/* report - report statistics from any terminated GCs */
+
+static void report(mps_arena_t arena)
+{
+  mps_message_t message;
+  static int nCollections = 0;
+
+  while (mps_message_get(&message, arena, mps_message_type_gc())) {
+    size_t live, condemned, not_condemned;
+
+    live = mps_message_gc_live_size(arena, message);
+    condemned = mps_message_gc_condemned_size(arena, message);
+    not_condemned = mps_message_gc_not_condemned_size(arena, message);
+
+    printf("\nCollection %d finished:\n", ++nCollections);
+    printf("live %"PRIuLONGEST"\n", (ulongest_t)live);
+    printf("condemned %"PRIuLONGEST"\n", (ulongest_t)condemned);
+    printf("not_condemned %"PRIuLONGEST"\n", (ulongest_t)not_condemned);
+
+    mps_message_discard(arena, message);
+  }
+}
+
+
+/* test -- the body of the test */
+
+static void *test(mps_arena_t arena, mps_pool_class_t pool_class,
+                  size_t roots_count)
+{
+  mps_fmt_t format;
+  mps_chain_t chain;
+  mps_root_t exactRoot, ambigRoot, bogusRoot;
+  unsigned long objs; size_t i;
+  mps_word_t collections, rampSwitch;
+  mps_alloc_pattern_t ramp = mps_alloc_pattern_ramp();
+  int ramping;
+  mps_ap_t busy_ap;
+  mps_addr_t busy_init;
+
+  die(EnsureHeaderFormat(&format, arena), "fmt_create");
+  die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
+
+  die(mps_pool_create(&pool, arena, pool_class, format, chain),
+      "pool_create(amc)");
+
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+  die(mps_ap_create(&busy_ap, pool, mps_rank_exact()), "BufferCreate 2");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  for(i = 0; i < ambigRootsCOUNT; ++i)
+    ambigRoots[i] = rnd_addr();
+
+  die(mps_root_create_table_masked(&exactRoot, arena,
+                                   mps_rank_exact(), (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT,
+                                   (mps_word_t)1),
+      "root_create_table(exact)");
+  die(mps_root_create_table(&ambigRoot, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &ambigRoots[0], ambigRootsCOUNT),
+      "root_create_table(ambig)");
+  die(mps_root_create_table(&bogusRoot, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &bogusRoots[0], bogusRootsCOUNT),
+      "root_create_table(bogus)");
+
+  /* create an ap, and leave it busy */
+  die(mps_reserve(&busy_init, busy_ap, 64), "mps_reserve busy");
+
+  collections = 0;
+  rampSwitch = rampSIZE;
+  die(mps_ap_alloc_pattern_begin(ap, ramp), "pattern begin (ap)");
+  die(mps_ap_alloc_pattern_begin(busy_ap, ramp), "pattern begin (busy_ap)");
+  ramping = 1;
+  objs = 0;
+  while (collections < collectionsCOUNT) {
+    mps_word_t c;
+    size_t r;
+
+    c = mps_collections(arena);
+
+    if (collections != c) {
+      collections = c;
+      printf("\nCollection %"PRIuLONGEST", %lu objects.\n",
+             (ulongest_t)c, objs);
+      report(arena);
+      for (r = 0; r < exactRootsCOUNT; ++r) {
+        if (exactRoots[r] != objNULL)
+          die(HeaderFormatCheck(exactRoots[r]), "wrapper check");
+      }
+      if (collections == rampSwitch) {
+        int begin_ramp = !ramping
+          || /* Every other time, switch back immediately. */ (collections & 1);
+
+        rampSwitch += rampSIZE;
+        if (ramping) {
+          die(mps_ap_alloc_pattern_end(ap, ramp), "pattern end (ap)");
+          die(mps_ap_alloc_pattern_end(busy_ap, ramp), "pattern end (busy_ap)");
+          ramping = 0;
+          /* kill half of the roots */
+          for(i = 0; i < exactRootsCOUNT; i += 2) {
+            if (exactRoots[i] != objNULL) {
+              die(HeaderFormatCheck(exactRoots[i]), "ramp kill check");
+              exactRoots[i] = objNULL;
+            }
+          }
+        }
+        if (begin_ramp) {
+          die(mps_ap_alloc_pattern_begin(ap, ramp),
+              "pattern rebegin (ap)");
+          die(mps_ap_alloc_pattern_begin(busy_ap, ramp),
+              "pattern rebegin (busy_ap)");
+          ramping = 1;
+        }
+      }
+      /*  fill bogusRoots with variations of a real pointer */
+      r = rnd() % exactRootsCOUNT;
+      if (exactRoots[r] != objNULL) {
+        char *p = (char*)exactRoots[r];
+
+        for(i = 0; i < bogusRootsCOUNT; ++i)
+          bogusRoots[i] = (mps_addr_t)(p + i);
+      }
+    }
+
+    r = (size_t)rnd();
+    if (r & 1) {
+      i = (r >> 1) % exactRootsCOUNT;
+      if (exactRoots[i] != objNULL)
+        die(HeaderFormatCheck(exactRoots[i]), "wrapper check");
+      exactRoots[i] = make(roots_count);
+      if (exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+        dylan_write(exactRoots[(exactRootsCOUNT-1) - i],
+                    exactRoots, exactRootsCOUNT);
+    } else {
+      i = (r >> 1) % ambigRootsCOUNT;
+      ambigRoots[(ambigRootsCOUNT-1) - i] = make(roots_count);
+      /* Create random interior pointers */
+      ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 1);
+    }
+
+    if (r % initTestFREQ == 0)
+      *(int*)busy_init = -1; /* check that the buffer is still there */
+
+    if (objs % 1024 == 0) {
+      report(arena);
+      putchar('.');
+      (void)fflush(stdout);
+    }
+
+    ++objs;
+  }
+
+  (void)mps_commit(busy_ap, busy_init, 64);
+  mps_arena_park(arena);
+  mps_ap_destroy(busy_ap);
+  mps_ap_destroy(ap);
+  mps_root_destroy(exactRoot);
+  mps_root_destroy(ambigRoot);
+  mps_root_destroy(bogusRoot);
+  mps_pool_destroy(pool);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(format);
+  mps_arena_release(arena);
+
+  return NULL;
+}
+
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  mps_thr_t thread;
+
+  testlib_init(argc, argv);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(testArenaSIZE));
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "arena_create");
+  } MPS_ARGS_END(args);
+  mps_message_type_enable(arena, mps_message_type_gc());
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  test(arena, mps_class_amc(), exactRootsCOUNT);
+  test(arena, mps_class_amcz(), 0);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/amcssth.c

@@ -0,0 +1,387 @@
+/* amcssth.c: POOL CLASS AMC STRESS TEST WITH TWO THREADS
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (c) 2002 Global Graphics Software.
+ *
+ * The main thread parks the arena half way through the test case and
+ * runs mps_pool_walk() and mps_arena_formatted_objects_walk(). This
+ * checks that walking works while the other threads continue to
+ * allocate in the background.
+ */
+
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "testlib.h"
+#include "testthr.h"
+#include "mpslib.h"
+#include "mpscamc.h"
+#include "mpsavm.h"
+
+#include <stdio.h> /* fflush, printf, putchar */
+
+
+/* These values have been tuned in the hope of getting one dynamic collection. */
+#define testArenaSIZE     ((size_t)1000*1024)
+#define gen1SIZE          ((size_t)150)
+#define gen2SIZE          ((size_t)170)
+#define avLEN             3
+#define exactRootsCOUNT   180
+#define ambigRootsCOUNT   50
+#define genCOUNT          2
+#define collectionsCOUNT  37
+#define rampSIZE          9
+#define initTestFREQ      6000
+
+/* testChain -- generation parameters for the test */
+
+static mps_gen_param_s testChain[genCOUNT] = {
+  { gen1SIZE, 0.85 }, { gen2SIZE, 0.45 } };
+
+
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL           ((mps_addr_t)MPS_WORD_CONST(0xDECEA5ED))
+
+
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+
+
+static mps_word_t collections;
+static mps_arena_t arena;
+static mps_root_t exactRoot, ambigRoot;
+static unsigned long objs = 0;
+
+
+/* make -- create one new object */
+
+static mps_addr_t make(mps_ap_t ap, size_t roots_count)
+{
+  size_t length = rnd() % (2*avLEN);
+  size_t size = (length+2) * sizeof(mps_word_t);
+  mps_addr_t p;
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, p, ap, size);
+    if (res)
+      die(res, "MPS_RESERVE_BLOCK");
+    res = dylan_init(p, size, exactRoots, roots_count);
+    if (res)
+      die(res, "dylan_init");
+  } while(!mps_commit(ap, p, size));
+
+  return p;
+}
+
+
+/* test_stepper -- stepping function for walk */
+
+static void test_stepper(mps_addr_t object, mps_fmt_t fmt, mps_pool_t pool,
+                         void *p, size_t s)
+{
+  testlib_unused(object); testlib_unused(fmt); testlib_unused(pool);
+  testlib_unused(s);
+  (*(unsigned long *)p)++;
+}
+
+
+/* area_scan -- area scanning function for mps_pool_walk */
+
+static mps_res_t area_scan(mps_ss_t ss, void *base, void *limit, void *closure)
+{
+  unsigned long *count = closure;
+  mps_res_t res;
+  while (base < limit) {
+    mps_addr_t prev = base;
+    ++ *count;
+    res = dylan_scan1(ss, &base);
+    if (res != MPS_RES_OK) return res;
+    Insist(prev < base);
+  }
+  Insist(base == limit);
+  return MPS_RES_OK;
+}
+
+
+/* churn -- create an object and install into roots */
+
+static void churn(mps_ap_t ap, size_t roots_count)
+{
+  size_t i;
+  size_t r;
+
+  ++objs;
+  r = (size_t)rnd();
+  if (r & 1) {
+    i = (r >> 1) % exactRootsCOUNT;
+    if (exactRoots[i] != objNULL)
+      cdie(dylan_check(exactRoots[i]), "dying root check");
+    exactRoots[i] = make(ap, roots_count);
+    if (exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+      dylan_write(exactRoots[(exactRootsCOUNT-1) - i],
+                  exactRoots, exactRootsCOUNT);
+  } else {
+    i = (r >> 1) % ambigRootsCOUNT;
+    ambigRoots[(ambigRootsCOUNT-1) - i] = make(ap, roots_count);
+    /* Create random interior pointers */
+    ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 1);
+  }
+}
+
+
+typedef struct closure_s {
+  mps_pool_t pool;
+  size_t roots_count;
+} closure_s, *closure_t;
+
+static void *kid_thread(void *arg)
+{
+  void *marker = &marker;
+  mps_thr_t thread1, thread2;
+  mps_root_t reg_root;
+  mps_ap_t ap;
+  closure_t cl = arg;
+
+  /* Register the thread twice to check this is supported -- see
+   * <design/thread-manager#.req.register.multi>
+   */
+  die(mps_thread_reg(&thread1, arena), "thread_reg");
+  die(mps_thread_reg(&thread2, arena), "thread_reg");
+  die(mps_root_create_thread(&reg_root, arena, thread1, marker),
+      "root_create");
+
+  die(mps_ap_create(&ap, cl->pool, mps_rank_exact()), "BufferCreate(fooey)");
+  while(mps_collections(arena) < collectionsCOUNT) {
+    churn(ap, cl->roots_count);
+  }
+  mps_ap_destroy(ap);
+
+  mps_root_destroy(reg_root);
+  mps_thread_dereg(thread2);
+  mps_thread_dereg(thread1);
+
+  return NULL;
+}
+
+
+/* test -- the body of the test */
+
+static void test_pool(const char *name, mps_pool_t pool, size_t roots_count)
+{
+  size_t i;
+  mps_word_t rampSwitch;
+  mps_alloc_pattern_t ramp = mps_alloc_pattern_ramp();
+  int ramping;
+  mps_ap_t ap, busy_ap;
+  mps_addr_t busy_init;
+  testthr_t kids[10];
+  closure_s cl;
+  int walked = FALSE, ramped = FALSE;
+
+  printf("\n------ pool: %s-------\n", name);
+
+  cl.pool = pool;
+  cl.roots_count = roots_count;
+  collections = 0;
+
+  for (i = 0; i < NELEMS(kids); ++i)
+    testthr_create(&kids[i], kid_thread, &cl);
+
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+  die(mps_ap_create(&busy_ap, pool, mps_rank_exact()), "BufferCreate 2");
+
+  /* create an ap, and leave it busy */
+  die(mps_reserve(&busy_init, busy_ap, 64), "mps_reserve busy");
+
+  rampSwitch = rampSIZE;
+  die(mps_ap_alloc_pattern_begin(ap, ramp), "pattern begin (ap)");
+  die(mps_ap_alloc_pattern_begin(busy_ap, ramp), "pattern begin (busy_ap)");
+  ramping = 1;
+  while (collections < collectionsCOUNT) {
+    mps_message_type_t type;
+
+    if (mps_message_queue_type(&type, arena)) {
+      mps_message_t msg;
+      mps_bool_t b = mps_message_get(&msg, arena, type);
+      Insist(b); /* we just checked there was one */
+
+      if (type == mps_message_type_gc()) {
+        size_t live = mps_message_gc_live_size(arena, msg);
+        size_t condemned = mps_message_gc_condemned_size(arena, msg);
+        size_t not_condemned = mps_message_gc_not_condemned_size(arena, msg);
+
+        printf("\nCollection %lu finished:\n", (unsigned long)collections++);
+        printf("live %"PRIuLONGEST"\n", (ulongest_t)live);
+        printf("condemned %"PRIuLONGEST"\n", (ulongest_t)condemned);
+        printf("not_condemned %"PRIuLONGEST"\n", (ulongest_t)not_condemned);
+
+      } else if (type == mps_message_type_gc_start()) {
+        printf("\nCollection %lu started, %lu objects, committed=%lu.\n",
+               (unsigned long)collections, objs,
+               (unsigned long)mps_arena_committed(arena));
+
+        for (i = 0; i < exactRootsCOUNT; ++i)
+          cdie(exactRoots[i] == objNULL || dylan_check(exactRoots[i]),
+               "all roots check");
+
+        if (collections >= collectionsCOUNT / 2 && !walked)
+        {
+          unsigned long count1 = 0, count2 = 0;
+          mps_arena_park(arena);
+          mps_arena_formatted_objects_walk(arena, test_stepper, &count1, 0);
+          die(mps_pool_walk(pool, area_scan, &count2), "mps_pool_walk");
+          mps_arena_release(arena);
+          printf("stepped on %lu objects.\n", count1);
+          printf("walked %lu objects.\n", count2);
+          walked = TRUE;
+        }
+        if (collections >= rampSwitch && !ramped) {
+          /* Every other time, switch back immediately. */
+          int begin_ramp = !ramping || (collections & 1);
+
+          rampSwitch += rampSIZE;
+          if (ramping) {
+            die(mps_ap_alloc_pattern_end(ap, ramp), "pattern end (ap)");
+            die(mps_ap_alloc_pattern_end(busy_ap, ramp),
+                "pattern end (busy_ap)");
+            ramping = 0;
+            /* kill half of the roots */
+            for(i = 0; i < exactRootsCOUNT; i += 2) {
+              if (exactRoots[i] != objNULL) {
+                cdie(dylan_check(exactRoots[i]), "ramp kill check");
+                exactRoots[i] = objNULL;
+              }
+            }
+          }
+          if (begin_ramp) {
+            die(mps_ap_alloc_pattern_begin(ap, ramp),
+                "pattern rebegin (ap)");
+            die(mps_ap_alloc_pattern_begin(busy_ap, ramp),
+                "pattern rebegin (busy_ap)");
+            ramping = 1;
+          }
+        }
+        ramped = TRUE;
+      }
+
+      mps_message_discard(arena, msg);
+    }
+
+    churn(ap, roots_count);
+    {
+      size_t r = (size_t)rnd();
+      if (r % initTestFREQ == 0)
+        *(int*)busy_init = -1; /* check that the buffer is still there */
+    }
+    if (objs % 1024 == 0) {
+      putchar('.');
+      fflush(stdout);
+    }
+  }
+
+  (void)mps_commit(busy_ap, busy_init, 64);
+  mps_ap_destroy(busy_ap);
+  mps_ap_destroy(ap);
+
+  for (i = 0; i < NELEMS(kids); ++i)
+    testthr_join(&kids[i], NULL);
+}
+
+static void test_arena(void)
+{
+  size_t i;
+  mps_fmt_t format;
+  mps_chain_t chain;
+  mps_thr_t thread;
+  mps_root_t reg_root;
+  mps_pool_t amc_pool, amcz_pool;
+  void *marker = &marker;
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(testArenaSIZE));
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "arena_create");
+  } MPS_ARGS_END(args);
+  mps_message_type_enable(arena, mps_message_type_gc());
+  mps_message_type_enable(arena, mps_message_type_gc_start());
+
+  die(dylan_fmt(&format, arena), "fmt_create");
+  die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  for(i = 0; i < ambigRootsCOUNT; ++i)
+    ambigRoots[i] = rnd_addr();
+
+  die(mps_root_create_table_masked(&exactRoot, arena,
+                                   mps_rank_exact(), (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT,
+                                   (mps_word_t)1),
+      "root_create_table(exact)");
+  die(mps_root_create_table(&ambigRoot, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &ambigRoots[0], ambigRootsCOUNT),
+      "root_create_table(ambig)");
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  die(mps_root_create_thread(&reg_root, arena, thread, marker),
+      "root_create");
+
+  die(mps_pool_create(&amc_pool, arena, mps_class_amc(), format, chain),
+      "pool_create(amc)");
+  die(mps_pool_create(&amcz_pool, arena, mps_class_amcz(), format, chain),
+      "pool_create(amcz)");
+
+  test_pool("AMC", amc_pool, exactRootsCOUNT);
+  test_pool("AMCZ", amcz_pool, 0);
+
+  mps_arena_park(arena);
+  mps_pool_destroy(amc_pool);
+  mps_pool_destroy(amcz_pool);
+  mps_root_destroy(reg_root);
+  mps_thread_dereg(thread);
+  mps_root_destroy(exactRoot);
+  mps_root_destroy(ambigRoot);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(format);
+  mps_arena_destroy(arena);
+}
+
+int main(int argc, char *argv[])
+{
+  testlib_init(argc, argv);
+  test_arena();
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/amsss.c

@@ -0,0 +1,275 @@
+/* amsss.c: POOL CLASS AMS STRESS TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (c) 2002 Global Graphics Software.
+ *
+ * .design: Adapted from amcss.c, but not counting collections, just
+ * total size of objects allocated (because epoch doesn't increment when
+ * AMS is collected).  */
+
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include "mpscams.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#include "mps.h"
+#include "mpm.h"
+
+#include <stdio.h> /* fflush, printf */
+
+
+#define exactRootsCOUNT 50
+#define ambigRootsCOUNT 100
+/* This is enough for three GCs. */
+#define totalSizeMAX    800 * (size_t)1024
+#define totalSizeSTEP   200 * (size_t)1024
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL         ((mps_addr_t)MPS_WORD_CONST(0xDECEA5ED))
+#define testArenaSIZE   ((size_t)1<<20)
+#define initTestFREQ    3000
+#define splatTestFREQ   6000
+static mps_gen_param_s testChain[1] = { { 160, 0.90 } };
+
+
+static mps_arena_t arena;
+static mps_ap_t ap;
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+static size_t totalSize = 0;
+
+
+/* report - report statistics from any messages */
+
+static void report(void)
+{
+  static int nStart = 0;
+  static int nComplete = 0;
+  mps_message_type_t type;
+
+  while(mps_message_queue_type(&type, arena)) {
+    mps_message_t message;
+
+    cdie(mps_message_get(&message, arena, type), "message get");
+
+    if (type == mps_message_type_gc_start()) {
+      printf("\nCollection start %d.  Because:\n", ++nStart);
+      printf("%s\n", mps_message_gc_start_why(arena, message));
+
+    } else if (type == mps_message_type_gc()) {
+      size_t live, condemned, not_condemned;
+
+      live = mps_message_gc_live_size(arena, message);
+      condemned = mps_message_gc_condemned_size(arena, message);
+      not_condemned = mps_message_gc_not_condemned_size(arena, message);
+
+      printf("\nCollection complete %d:\n", ++nComplete);
+      printf("live %"PRIuLONGEST"\n", (ulongest_t)live);
+      printf("condemned %"PRIuLONGEST"\n", (ulongest_t)condemned);
+      printf("not_condemned %"PRIuLONGEST"\n", (ulongest_t)not_condemned);
+
+    } else {
+      cdie(0, "unknown message type");
+    }
+
+    mps_message_discard(arena, message);
+  }
+}
+
+
+/* make -- object allocation and init */
+
+static mps_addr_t make(void)
+{
+  size_t length = rnd() % 20, size = (length+2) * sizeof(mps_word_t);
+  mps_addr_t p;
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, p, ap, size);
+    if (res)
+      die(res, "MPS_RESERVE_BLOCK");
+    res = dylan_init(p, size, exactRoots, exactRootsCOUNT);
+    if (res)
+      die(res, "dylan_init");
+  } while(!mps_commit(ap, p, size));
+
+  totalSize += size;
+  return p;
+}
+
+
+/* test -- the actual stress test */
+
+static mps_pool_debug_option_s freecheckOptions =
+  { NULL, 0, "Dead", 4 };
+
+static void test_pool(mps_pool_class_t pool_class, mps_arg_s args[],
+                      mps_bool_t haveAmbiguous)
+{
+  mps_pool_t pool;
+  mps_root_t exactRoot, ambigRoot = NULL;
+  size_t lastStep = 0, i, r;
+  unsigned long objs;
+  mps_ap_t busy_ap;
+  mps_addr_t busy_init;
+
+  die(mps_pool_create_k(&pool, arena, pool_class, args), "pool_create");
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+  die(mps_ap_create(&busy_ap, pool, mps_rank_exact()), "BufferCreate 2");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  if (haveAmbiguous)
+    for(i = 0; i < ambigRootsCOUNT; ++i)
+      ambigRoots[i] = rnd_addr();
+
+  die(mps_root_create_table_masked(&exactRoot, arena,
+                                   mps_rank_exact(), (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT,
+                                   (mps_word_t)1),
+      "root_create_table(exact)");
+  if (haveAmbiguous)
+    die(mps_root_create_table(&ambigRoot, arena,
+                              mps_rank_ambig(), (mps_rm_t)0,
+                              &ambigRoots[0], ambigRootsCOUNT),
+        "root_create_table(ambig)");
+
+  /* create an ap, and leave it busy */
+  die(mps_reserve(&busy_init, busy_ap, 64), "mps_reserve busy");
+
+  die(PoolDescribe(pool, mps_lib_get_stdout(), 0), "PoolDescribe");
+
+  objs = 0; totalSize = 0;
+  while(totalSize < totalSizeMAX) {
+    if (totalSize > lastStep + totalSizeSTEP) {
+      lastStep = totalSize;
+      printf("\nSize %"PRIuLONGEST" bytes, %lu objects.\n",
+             (ulongest_t)totalSize, objs);
+      (void)fflush(stdout);
+      for(i = 0; i < exactRootsCOUNT; ++i)
+        cdie(exactRoots[i] == objNULL || dylan_check(exactRoots[i]),
+             "all roots check");
+    }
+
+    r = (size_t)rnd();
+    if (!haveAmbiguous || (r & 1)) {
+      i = (r >> 1) % exactRootsCOUNT;
+      if (exactRoots[i] != objNULL)
+        cdie(dylan_check(exactRoots[i]), "dying root check");
+      exactRoots[i] = make();
+      if (exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+        dylan_write(exactRoots[(exactRootsCOUNT-1) - i],
+                    exactRoots, exactRootsCOUNT);
+    } else {
+      i = (r >> 1) % ambigRootsCOUNT;
+      ambigRoots[(ambigRootsCOUNT-1) - i] = make();
+      /* Create random interior pointers */
+      ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 1);
+    }
+
+    if (rnd() % initTestFREQ == 0)
+      *(int*)busy_init = -1; /* check that the buffer is still there */
+
+    if (rnd() % splatTestFREQ == 0)
+      mps_pool_check_free_space(pool);
+
+    ++objs;
+    if (objs % 256 == 0) {
+      printf(".");
+      report();
+      (void)fflush(stdout);
+    }
+  }
+
+  (void)mps_commit(busy_ap, busy_init, 64);
+  mps_ap_destroy(busy_ap);
+  mps_ap_destroy(ap);
+  mps_root_destroy(exactRoot);
+  if (haveAmbiguous)
+    mps_root_destroy(ambigRoot);
+
+  mps_pool_destroy(pool);
+}
+
+
+int main(int argc, char *argv[])
+{
+  int i;
+  mps_thr_t thread;
+  mps_fmt_t format;
+  mps_chain_t chain;
+
+  testlib_init(argc, argv);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(testArenaSIZE));
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "arena_create");
+  } MPS_ARGS_END(args);
+
+  mps_message_type_enable(arena, mps_message_type_gc_start());
+  mps_message_type_enable(arena, mps_message_type_gc());
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  die(mps_fmt_create_A(&format, arena, dylan_fmt_A()), "fmt_create");
+  die(mps_chain_create(&chain, arena, 1, testChain), "chain_create");
+
+  for (i = 0; i < 8; i++) {
+    int debug = i % 2;
+    int ownChain = (i / 2) % 2;
+    int ambig = (i / 4) % 2;
+    printf("\n\n*** AMS%s with %sCHAIN and %sSUPPORT_AMBIGUOUS\n",
+           debug ? " Debug" : "",
+           ownChain ? "" : "!",
+           ambig ? "" : "!");
+    MPS_ARGS_BEGIN(args) {
+      MPS_ARGS_ADD(args, MPS_KEY_FORMAT, format);
+      if (ownChain)
+        MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
+      MPS_ARGS_ADD(args, MPS_KEY_AMS_SUPPORT_AMBIGUOUS, ambig);
+      MPS_ARGS_ADD(args, MPS_KEY_POOL_DEBUG_OPTIONS, &freecheckOptions);
+      test_pool(debug ? mps_class_ams_debug() : mps_class_ams(), args, ambig);
+    } MPS_ARGS_END(args);
+  }
+
+  mps_arena_park(arena);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(format);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/amssshe.c

@@ -0,0 +1,199 @@
+/* amssshe.c: POOL CLASS AMS STRESS TEST WITH HEADERS
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .design: Adapted from amsss.c.
+ */
+
+#include "fmthe.h"
+#include "fmtdytst.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include "mpscams.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#include "mps.h"
+
+#include <stdio.h> /* fflush, printf */
+
+
+#define exactRootsCOUNT 50
+#define ambigRootsCOUNT 100
+/* This is enough for five GCs. */
+#define totalSizeMAX    800 * (size_t)1024
+#define totalSizeSTEP   200 * (size_t)1024
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL         ((mps_addr_t)MPS_WORD_CONST(0xDECEA5ED))
+#define testArenaSIZE   ((size_t)16<<20)
+#define initTestFREQ    6000
+static mps_gen_param_s testChain[1] = { { 160, 0.90 } };
+
+
+static mps_pool_t pool;
+static mps_ap_t ap;
+static mps_addr_t exactRoots[exactRootsCOUNT];
+static mps_addr_t ambigRoots[ambigRootsCOUNT];
+static size_t totalSize = 0;
+
+
+static mps_addr_t make(void)
+{
+  size_t length = rnd() % 20, size = (length+2) * sizeof(mps_word_t);
+  mps_addr_t p, userP;
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, p, ap, size + headerSIZE);
+    if(res)
+      die(res, "MPS_RESERVE_BLOCK");
+    userP = (mps_addr_t)((char*)p + headerSIZE);
+    res = dylan_init(userP, size, exactRoots, exactRootsCOUNT);
+    if(res)
+      die(res, "dylan_init");
+    ((int*)p)[0] = realHeader;
+    ((int*)p)[1] = 0xED0ED;
+  } while(!mps_commit(ap, p, size + headerSIZE));
+
+  totalSize += size;
+  return userP;
+}
+
+
+static void test(mps_arena_t arena)
+{
+  mps_fmt_t format;
+  mps_chain_t chain;
+  mps_root_t exactRoot, ambigRoot;
+  size_t lastStep = 0, i, r;
+  unsigned long objs;
+  mps_ap_t busy_ap;
+  mps_addr_t busy_init;
+
+  die(EnsureHeaderFormat(&format, arena), "make header format");
+  die(mps_chain_create(&chain, arena, 1, testChain), "chain_create");
+  die(mps_pool_create(&pool, arena, mps_class_ams(), format, chain,
+                      TRUE), "pool_create(ams)");
+
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+  die(mps_ap_create(&busy_ap, pool, mps_rank_exact()), "BufferCreate 2");
+
+  for(i = 0; i < exactRootsCOUNT; ++i)
+    exactRoots[i] = objNULL;
+  for(i = 0; i < ambigRootsCOUNT; ++i)
+    ambigRoots[i] = rnd_addr();
+
+  die(mps_root_create_table_masked(&exactRoot, arena,
+                                   mps_rank_exact(), (mps_rm_t)0,
+                                   &exactRoots[0], exactRootsCOUNT,
+                                   (mps_word_t)1),
+      "root_create_table(exact)");
+  die(mps_root_create_table(&ambigRoot, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &ambigRoots[0], ambigRootsCOUNT),
+      "root_create_table(ambig)");
+
+  /* create an ap, and leave it busy */
+  die(mps_reserve(&busy_init, busy_ap, 64), "mps_reserve busy");
+
+  objs = 0;
+  while(totalSize < totalSizeMAX) {
+    if(totalSize > lastStep + totalSizeSTEP) {
+      lastStep = totalSize;
+      printf("\nSize %"PRIuLONGEST" bytes, %lu objects.\n",
+             (ulongest_t)totalSize, objs);
+      (void)fflush(stdout);
+      for(i = 0; i < exactRootsCOUNT; ++i)
+        cdie(exactRoots[i] == objNULL || dylan_check(exactRoots[i]),
+             "all roots check");
+    }
+
+    r = (size_t)rnd();
+    if(r & 1) {
+      i = (r >> 1) % exactRootsCOUNT;
+      if(exactRoots[i] != objNULL)
+        cdie(dylan_check(exactRoots[i]), "dying root check");
+      exactRoots[i] = make();
+      if(exactRoots[(exactRootsCOUNT-1) - i] != objNULL)
+        dylan_write(exactRoots[(exactRootsCOUNT-1) - i],
+                    exactRoots, exactRootsCOUNT);
+    } else {
+      i = (r >> 1) % ambigRootsCOUNT;
+      ambigRoots[(ambigRootsCOUNT-1) - i] = make();
+      /* Create random interior pointers */
+      ambigRoots[i] = (mps_addr_t)((char *)(ambigRoots[i/2]) + 1);
+    }
+
+    if(rnd() % initTestFREQ == 0)
+      *(int*)busy_init = -1; /* check that the buffer is still there */
+
+    ++objs;
+    if (objs % 256 == 0) {
+      printf(".");
+      (void)fflush(stdout);
+    }
+  }
+
+  (void)mps_commit(busy_ap, busy_init, 64);
+  mps_arena_park(arena);
+  mps_ap_destroy(busy_ap);
+  mps_ap_destroy(ap);
+  mps_root_destroy(exactRoot);
+  mps_root_destroy(ambigRoot);
+  mps_pool_destroy(pool);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(format);
+  mps_arena_release(arena);
+}
+
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  mps_thr_t thread;
+
+  testlib_init(argc, argv);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, rnd_grain(testArenaSIZE));
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "arena_create");
+  } MPS_ARGS_END(args);
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  test(arena);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/anangc.gmk

@@ -0,0 +1,55 @@
+# -*- makefile -*-
+#
+# anangc.gmk: BUILD FOR ANSI/ANSI/GCC PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = anangc
+
+MPMPF = \
+    lockan.c \
+    prmcan.c \
+    prmcanan.c \
+    protan.c \
+    span.c \
+    than.c \
+    vman.c
+
+LIBS = -lm -lpthread
+
+include gc.gmk
+
+CFLAGSCOMPILER += -DCONFIG_PF_ANSI -DCONFIG_THREAD_SINGLE
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/ananll.gmk

@@ -0,0 +1,56 @@
+# -*- makefile -*-
+#
+# ananll.gmk: BUILD FOR ANSI/ANSI/Clang PLATFORM
+#
+# $Id$
+# Copyright (c) 2014-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = ananll
+
+MPMPF = \
+    lockan.c \
+    prmcan.c \
+    prmcanan.c \
+    protan.c \
+    span.c \
+    than.c \
+    vman.c
+
+LIBS = -lm -lpthread
+
+include ll.gmk
+
+CFLAGSCOMPILER += -DCONFIG_PF_ANSI -DCONFIG_THREAD_SINGLE
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+
+

mps/code/ananmv.nmk

@@ -0,0 +1,51 @@
+# ananmv.nmk: ANSI/ANSI/MICROSOFT VISUAL C/C++ NMAKE FILE -*- makefile -*-
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = ananmv
+
+PFMDEFS = /DCONFIG_PF_ANSI /DCONFIG_THREAD_SINGLE
+
+MPMPF = \
+    [lockan] \
+    [prmcan] \
+    [prmcanan] \
+    [protan] \
+    [span] \
+    [than] \
+    [vman]
+
+!INCLUDE commpre.nmk
+!INCLUDE mv.nmk
+!INCLUDE commpost.nmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/apss.c

@@ -0,0 +1,274 @@
+/* apss.c: AP MANUAL ALLOC STRESS TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ */
+
+
+#include "mpscmvff.h"
+#include "mpscmvt.h"
+#include "mpslib.h"
+#include "mpsacl.h"
+#include "mpsavm.h"
+
+#include "testlib.h"
+#include "mpslib.h"
+
+#include <stdio.h> /* printf */
+#include <stdlib.h> /* malloc */
+
+
+#define testArenaSIZE   ((((size_t)3)<<24) - 4)
+#define testSetSIZE 200
+#define testLOOPS 10
+#define MAX_ALIGN 64 /* TODO: Make this test work up to arena_grain_size? */
+
+
+/* make -- allocate one object */
+
+static mps_res_t make(mps_addr_t *p, mps_ap_t ap, size_t size)
+{
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, *p, ap, size);
+    if(res != MPS_RES_OK)
+      return res;
+  } while(!mps_commit(ap, *p, size));
+
+  return MPS_RES_OK;
+}
+
+
+/* check_allocated_size -- check the allocated size of the pool */
+
+static void check_allocated_size(mps_pool_t pool, mps_ap_t ap, size_t allocated)
+{
+  size_t total_size = mps_pool_total_size(pool);
+  size_t free_size = mps_pool_free_size(pool);
+  size_t ap_free = (size_t)((char *)ap->limit - (char *)ap->init);
+  Insist(total_size - free_size == allocated + ap_free);
+}
+
+
+/* stress -- create a pool of the requested type and allocate in it */
+
+static mps_res_t stress(mps_arena_t arena, mps_pool_debug_option_s *options,
+                        mps_align_t align,
+                        size_t (*size)(size_t i, mps_align_t align),
+                        const char *name, mps_pool_class_t pool_class,
+                        mps_arg_s args[])
+{
+  mps_res_t res = MPS_RES_OK;
+  mps_pool_t pool;
+  mps_ap_t ap;
+  size_t i, k;
+  int *ps[testSetSIZE];
+  size_t ss[testSetSIZE];
+  size_t allocated = 0;         /* Total allocated memory */
+  size_t debugOverhead = options ? 2 * alignUp(options->fence_size, align) : 0;
+
+  printf("stress %s\n", name);
+
+  die(mps_pool_create_k(&pool, arena, pool_class, args), "pool_create");
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+
+  /* allocate a load of objects */
+  for (i=0; i<testSetSIZE; ++i) {
+    mps_addr_t obj;
+    ss[i] = (*size)(i, align);
+    res = make(&obj, ap, ss[i]);
+    if (res != MPS_RES_OK)
+      goto allocFail;
+    ps[i] = obj;
+    allocated += ss[i] + debugOverhead;
+    if (ss[i] >= sizeof(ps[i]))
+      *ps[i] = 1; /* Write something, so it gets swap. */
+    check_allocated_size(pool, ap, allocated);
+  }
+
+  /* Check introspection functions */
+  for (i = 0; i < NELEMS(ps); ++i) {
+    mps_pool_t addr_pool = NULL;
+    Insist(mps_arena_has_addr(arena, ps[i]));
+    Insist(mps_addr_pool(&addr_pool, arena, ps[i]));
+    Insist(addr_pool == pool);
+  }
+
+  mps_pool_check_fenceposts(pool);
+
+  for (k=0; k<testLOOPS; ++k) {
+    /* shuffle all the objects */
+    for (i=0; i<testSetSIZE; ++i) {
+      size_t j = rnd()%(testSetSIZE-i);
+      void *tp;
+      size_t ts;
+
+      tp = ps[j]; ts = ss[j];
+      ps[j] = ps[i]; ss[j] = ss[i];
+      ps[i] = tp; ss[i] = ts;
+    }
+    /* free half of the objects */
+    /* upper half, as when allocating them again we want smaller objects */
+    /* see randomSize() */
+    for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
+      mps_free(pool, (mps_addr_t)ps[i], ss[i]);
+      /* if (i == testSetSIZE/2) */
+      /*   PoolDescribe((Pool)pool, mps_lib_stdout); */
+      Insist(ss[i] + debugOverhead <= allocated);
+      allocated -= ss[i] + debugOverhead;
+    }
+    /* allocate some new objects */
+    for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
+      mps_addr_t obj;
+      ss[i] = (*size)(i, align);
+      res = make(&obj, ap, ss[i]);
+      if (res != MPS_RES_OK)
+        goto allocFail;
+      ps[i] = obj;
+      allocated += ss[i] + debugOverhead;
+    }
+    check_allocated_size(pool, ap, allocated);
+  }
+
+allocFail:
+  mps_ap_destroy(ap);
+  mps_pool_destroy(pool);
+
+  return res;
+}
+
+
+/* randomSizeAligned -- produce sizes both large and small, aligned to
+ * align.
+ */
+
+static size_t randomSizeAligned(size_t i, mps_align_t align)
+{
+  size_t maxSize = 2 * 160 * 0x2000;
+  /* Reduce by a factor of 2 every 10 cycles.  Total allocation about 40 MB. */
+  return alignUp(rnd() % max((maxSize >> (i / 10)), 2) + 1, align);
+}
+
+
+static mps_pool_debug_option_s bothOptions = {
+  /* .fence_template = */   "post",
+  /* .fence_size = */       4,
+  /* .free_template = */    "DEAD",
+  /* .free_size = */        4
+};
+
+static mps_pool_debug_option_s fenceOptions = {
+  /* .fence_template = */   "123456789abcdef",
+  /* .fence_size = */       15,
+  /* .free_template = */    NULL,
+  /* .free_size = */        0
+};
+
+
+/* test -- create arena using given class and arguments; test all the
+ * pool classes in this arena
+ */
+
+static void test(mps_arena_class_t arena_class, mps_arg_s arena_args[],
+                 size_t arena_grain_size,
+                 mps_pool_debug_option_s *options)
+{
+  mps_arena_t arena;
+  die(mps_arena_create_k(&arena, arena_class, arena_args), "mps_arena_create");
+
+  (void)arena_grain_size; /* TODO: test larger alignments up to this */
+
+  MPS_ARGS_BEGIN(args) {
+    mps_align_t align = rnd_align(sizeof(void *), MAX_ALIGN);
+    MPS_ARGS_ADD(args, MPS_KEY_ALIGN, align);
+    MPS_ARGS_ADD(args, MPS_KEY_MVFF_ARENA_HIGH, TRUE);
+    MPS_ARGS_ADD(args, MPS_KEY_MVFF_SLOT_HIGH, TRUE);
+    MPS_ARGS_ADD(args, MPS_KEY_MVFF_FIRST_FIT, TRUE);
+    MPS_ARGS_ADD(args, MPS_KEY_SPARE, rnd_double());
+    die(stress(arena, NULL, align, randomSizeAligned, "MVFF",
+               mps_class_mvff(), args), "stress MVFF");
+  } MPS_ARGS_END(args);
+
+  /* IWBN to test MVFFDebug, but the MPS doesn't support debugging
+     allocation points. See job003995. */
+  (void)options;
+
+  MPS_ARGS_BEGIN(args) {
+    mps_align_t align = rnd_align(sizeof(void *), MAX_ALIGN);
+    MPS_ARGS_ADD(args, MPS_KEY_ALIGN, align);
+    die(stress(arena, NULL, align, randomSizeAligned, "MVT",
+               mps_class_mvt(), args), "stress MVT");
+  } MPS_ARGS_END(args);
+
+  /* Manual allocation should not cause any garbage collections. */
+  Insist(mps_collections(arena) == 0);
+  mps_arena_destroy(arena);
+}
+
+
+int main(int argc, char *argv[])
+{
+  size_t arena_grain_size;
+
+  testlib_init(argc, argv);
+
+  arena_grain_size = rnd_grain(testArenaSIZE);
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, 2 * testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    MPS_ARGS_ADD(args, MPS_KEY_COMMIT_LIMIT, testArenaSIZE);
+    test(mps_arena_class_vm(), args, arena_grain_size, &fenceOptions);
+  } MPS_ARGS_END(args);
+
+  arena_grain_size = rnd_grain(2 * testArenaSIZE);
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, 2 * testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, FALSE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    test(mps_arena_class_vm(), args, arena_grain_size, &bothOptions);
+  } MPS_ARGS_END(args);
+
+  arena_grain_size = rnd_grain(testArenaSIZE);
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, FALSE);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_CL_BASE, malloc(testArenaSIZE));
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    test(mps_arena_class_cl(), args, arena_grain_size, &bothOptions);
+  } MPS_ARGS_END(args);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/arenacl.c

@@ -0,0 +1,502 @@
+/* arenacl.c: ARENA CLASS USING CLIENT MEMORY
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .design: <design/arena#.client>.
+ *
+ * .improve.remember: One possible performance improvement is to
+ * remember (a conservative approximation to) the indices of the first
+ * and last free pages in each chunk, and start searching from these
+ * in ChunkAlloc.  See request.epcore.170534_.
+ *
+ * .. _request.epcore.170534: https://info.ravenbrook.com/project/mps/import/2001-11-05/mmprevol/request/epcore/170534
+ */
+
+#include "boot.h"
+#include "tract.h"
+#include "bt.h"
+#include "mpm.h"
+#include "mpsacl.h"
+
+SRCID(arenacl, "$Id$");
+
+DECLARE_CLASS(Arena, ClientArena, AbstractArena);
+
+
+/* ClientArenaStruct -- Client Arena Structure */
+
+#define ClientArenaSig ((Sig)0x519A6EC7) /* SIGnature AREna CLient */
+
+typedef struct ClientArenaStruct {
+  ArenaStruct arenaStruct; /* generic arena structure */
+  Sig sig;                 /* design.mps.sig.field.end.outer */
+} ClientArenaStruct;
+typedef struct ClientArenaStruct *ClientArena;
+
+
+/* CLChunk -- chunk structure */
+
+typedef struct ClientChunkStruct *ClientChunk;
+
+#define ClientChunkSig ((Sig)0x519A6C2C) /* SIGnature ARena CLient Chunk */
+
+typedef struct ClientChunkStruct {
+  ChunkStruct chunkStruct;     /* generic chunk */
+  Size freePages;              /* number of free pages in chunk */
+  Addr pageBase;               /* base of first managed page in chunk */
+  Sig sig;                     /* design.mps.sig.field.end.outer */
+} ClientChunkStruct;
+
+#define ClientChunk2Chunk(clchunk) (&(clchunk)->chunkStruct)
+#define Chunk2ClientChunk(chunk) PARENT(ClientChunkStruct, chunkStruct, chunk)
+
+
+/* ClientChunkClientArena -- get the client arena from a client chunk */
+
+#define ClientChunkClientArena(clchunk) \
+  Arena2ClientArena(ChunkArena(ClientChunk2Chunk(clchunk)))
+
+
+/* ClientChunkCheck -- check the consistency of a client chunk */
+
+ATTRIBUTE_UNUSED
+static Bool ClientChunkCheck(ClientChunk clChunk)
+{
+  Chunk chunk;
+
+  CHECKS(ClientChunk, clChunk);
+  chunk = ClientChunk2Chunk(clChunk);
+  CHECKD(Chunk, chunk);
+  CHECKL(clChunk->freePages <= chunk->pages);
+  /* check they don't overlap (knowing the order) */
+  CHECKL((Addr)(chunk + 1) < (Addr)chunk->allocTable);
+  return TRUE;
+}
+
+
+/* ClientArenaCheck -- check the consistency of a client arena */
+
+ATTRIBUTE_UNUSED
+static Bool ClientArenaCheck(ClientArena clientArena)
+{
+  Arena arena = MustBeA(AbstractArena, clientArena);
+
+  /* See <code/arena.c#.reserved.check> */
+  CHECKL(arena->committed <= arena->reserved);
+  CHECKL(arena->spareCommitted == 0);
+
+  return TRUE;
+}
+
+
+/* clientChunkCreate -- create a ClientChunk */
+
+static Res clientChunkCreate(Chunk *chunkReturn, ClientArena clientArena,
+                             Addr base, Addr limit)
+{
+  Arena arena = MustBeA(AbstractArena, clientArena);
+  ClientChunk clChunk;
+  Chunk chunk;
+  Addr alignedBase;
+  BootBlockStruct bootStruct;
+  BootBlock boot = &bootStruct;
+  Res res;
+  void *p;
+
+  AVER(chunkReturn != NULL);
+  AVER(base != (Addr)0);
+  AVER(limit != (Addr)0);
+  AVER(limit > base);
+
+  /* Initialize boot block. */
+  /* Chunk has to be page-aligned, and the boot allocs must be within it. */
+  alignedBase = AddrAlignUp(base, ArenaGrainSize(arena));
+  AVER(alignedBase < limit);
+  res = BootBlockInit(boot, (void *)alignedBase, (void *)limit);
+  if (res != ResOK)
+    goto failBootInit;
+
+  /* Allocate the chunk. */
+  /* TODO: Add reference to design. */
+  res = BootAlloc(&p, boot, sizeof(ClientChunkStruct), MPS_PF_ALIGN);
+  if (res != ResOK)
+    goto failChunkAlloc;
+  clChunk = p;
+  chunk = ClientChunk2Chunk(clChunk);
+
+  res = ChunkInit(chunk, arena, alignedBase,
+                  AddrAlignDown(limit, ArenaGrainSize(arena)),
+                  AddrOffset(base, limit), boot);
+  if (res != ResOK)
+    goto failChunkInit;
+
+  arena->committed += ChunkPagesToSize(chunk, chunk->allocBase);
+
+  BootBlockFinish(boot);
+
+  clChunk->sig = ClientChunkSig;
+  AVERT(ClientChunk, clChunk);
+  *chunkReturn = chunk;
+  return ResOK;
+
+failChunkInit:
+failChunkAlloc:
+failBootInit:
+  return res;
+}
+
+
+/* ClientChunkInit -- initialize a ClientChunk */
+
+static Res ClientChunkInit(Chunk chunk, BootBlock boot)
+{
+  Res res;
+  ClientChunk clChunk;
+  void *p;
+
+  /* chunk is supposed to be uninitialized, so don't check it. */
+  clChunk = Chunk2ClientChunk(chunk);
+  AVERT(BootBlock, boot);
+
+  /* TODO: An old comment claimed this is too large.
+     Does it fail to exclude the page table or something? */
+  clChunk->freePages = chunk->pages;
+
+  /* Put the page table as late as possible, as in VM systems we don't want */
+  /* to map it. */
+  res = BootAlloc(&p, boot, chunk->pageTablePages << chunk->pageShift, chunk->pageSize);
+  if (res != ResOK)
+    return res;
+  chunk->pageTable = p;
+
+  return ResOK;
+}
+
+
+/* clientChunkDestroy -- destroy a ClientChunk */
+
+static Bool clientChunkDestroy(Tree tree, void *closure)
+{
+  Arena arena;
+  Chunk chunk;
+  ClientChunk clChunk;
+  Size size;
+
+  AVERT(Tree, tree);
+  AVER(closure == UNUSED_POINTER);
+  UNUSED(closure);
+
+  chunk = ChunkOfTree(tree);
+  AVERT(Chunk, chunk);
+  arena = ChunkArena(chunk);
+  AVERT(Arena, arena);
+  clChunk = Chunk2ClientChunk(chunk);
+  AVERT(ClientChunk, clChunk);
+  AVER(chunk->pages == clChunk->freePages);
+
+  size = ChunkPagesToSize(chunk, chunk->allocBase);
+  AVER(arena->committed >= size);
+  arena->committed -= size;
+
+  clChunk->sig = SigInvalid;
+  ChunkFinish(chunk);
+
+  return TRUE;
+}
+
+
+/* ClientChunkFinish -- finish a ClientChunk */
+
+static void ClientChunkFinish(Chunk chunk)
+{
+  /* Can't check chunk as it's not valid anymore. */
+  UNUSED(chunk);
+}
+
+
+/* ClientArenaVarargs -- parse obsolete varargs */
+
+static void ClientArenaVarargs(ArgStruct args[MPS_ARGS_MAX], va_list varargs)
+{
+  args[0].key = MPS_KEY_ARENA_SIZE;
+  args[0].val.size = va_arg(varargs, Size);
+  args[1].key = MPS_KEY_ARENA_CL_BASE;
+  args[1].val.addr = va_arg(varargs, Addr);
+  args[2].key = MPS_KEY_ARGS_END;
+  AVERT(ArgList, args);
+}
+
+
+/* ClientArenaInit -- create and initialize the client arena
+ *
+ * .init.memory: Creates the arena structure in the chuck given, and
+ * makes the first chunk from the memory left over.
+ * .arena.init: Once the arena has been allocated, we call ArenaInit
+ * to do the generic part of init.
+ */
+
+ARG_DEFINE_KEY(ARENA_CL_BASE, Addr);
+
+static Res ClientArenaCreate(Arena *arenaReturn, ArgList args)
+{
+  Arena arena;
+  ClientArena clientArena;
+  Size size;
+  Size clArenaSize;   /* aligned size of ClientArenaStruct */
+  Addr base, limit, chunkBase;
+  Align grainSize = 1;
+  Res res;
+  Chunk chunk;
+  mps_arg_s arg;
+
+  AVER(arenaReturn != NULL);
+  AVERT(ArgList, args);
+
+  ArgRequire(&arg, args, MPS_KEY_ARENA_SIZE);
+  size = arg.val.size;
+  ArgRequire(&arg, args, MPS_KEY_ARENA_CL_BASE);
+  base = arg.val.addr;
+  if (ArgPick(&arg, args, MPS_KEY_ARENA_GRAIN_SIZE))
+    grainSize = arg.val.size;
+  grainSize = SizeAlignUp(grainSize, ARENA_CLIENT_GRAIN_SIZE);
+  grainSize = SizeAlignUp(grainSize, ProtGranularity());
+
+  AVER(base != (Addr)0);
+  AVERT(ArenaGrainSize, grainSize);
+
+  if (size < grainSize * MPS_WORD_WIDTH)
+    /* Not enough room for a full complement of zones. */
+    return ResMEMORY;
+
+  clArenaSize = SizeAlignUp(sizeof(ClientArenaStruct), MPS_PF_ALIGN);
+  if (size < clArenaSize)
+    return ResMEMORY;
+
+  limit = AddrAdd(base, size);
+
+  /* allocate the arena */
+  base = AddrAlignUp(base, MPS_PF_ALIGN);
+  clientArena = (ClientArena)base;
+  chunkBase = AddrAlignUp(AddrAdd(base, clArenaSize), MPS_PF_ALIGN);
+  if (chunkBase > limit)
+    return ResMEMORY;
+
+  arena = CouldBeA(AbstractArena, clientArena);
+
+  res = NextMethod(Arena, ClientArena, init)(arena, grainSize, args);
+  if (res != ResOK)
+    goto failSuperInit;
+  SetClassOfPoly(arena, CLASS(ClientArena));
+  AVER(clientArena == MustBeA(ClientArena, arena));
+
+  /* have to have a valid arena before calling ChunkCreate */
+  clientArena->sig = ClientArenaSig;
+
+  res = clientChunkCreate(&chunk, clientArena, chunkBase, limit);
+  if (res != ResOK)
+    goto failChunkCreate;
+  arena->primary = chunk;
+
+  /* Set the zone shift to divide the initial chunk into the same */
+  /* number of zones as will fit into a reference set (the number of */
+  /* bits in a word). Note that some zones are discontiguous in the */
+  /* arena if the size is not a power of 2. */
+  arena->zoneShift = SizeFloorLog2(size >> MPS_WORD_SHIFT);
+  AVER(ArenaGrainSize(arena) == ChunkPageSize(arena->primary));
+
+  EVENT7(ArenaCreateCL, arena, size, base, grainSize,
+         ClassOfPoly(Arena, arena), ArenaGlobals(arena)->systemPools,
+         arena->serial);
+  AVERT(ClientArena, clientArena);
+  *arenaReturn = arena;
+  return ResOK;
+
+failChunkCreate:
+  NextMethod(Inst, ClientArena, finish)(MustBeA(Inst, arena));
+failSuperInit:
+  AVER(res != ResOK);
+  return res;
+}
+
+
+/* ClientArenaDestroy -- destroy the arena */
+
+static void ClientArenaDestroy(Arena arena)
+{
+  ClientArena clientArena = MustBeA(ClientArena, arena);
+
+  /* Destroy all chunks, including the primary. See
+   * <design/arena#.chunk.delete> */
+  arena->primary = NULL;
+  TreeTraverseAndDelete(&arena->chunkTree, clientChunkDestroy,
+                        UNUSED_POINTER);
+
+  clientArena->sig = SigInvalid;
+
+  /* Destroying the chunks should leave nothing behind. */
+  AVER(arena->reserved == 0);
+  AVER(arena->committed == 0);
+
+  NextMethod(Inst, ClientArena, finish)(MustBeA(Inst, arena));
+}
+
+
+/* ClientArenaExtend -- extend the arena */
+
+static Res ClientArenaExtend(Arena arena, Addr base, Size size)
+{
+  ClientArena clientArena = MustBeA(ClientArena, arena);
+  Chunk chunk;
+
+  AVER(base != (Addr)0);
+  AVER(size > 0);
+
+  return clientChunkCreate(&chunk, clientArena, base, AddrAdd(base, size));
+}
+
+
+/* ClientArenaPagesMarkAllocated -- Mark the pages allocated */
+
+static Res ClientArenaPagesMarkAllocated(Arena arena, Chunk chunk,
+                                         Index baseIndex, Count pages,
+                                         Pool pool)
+{
+  Index i;
+  ClientChunk clChunk;
+
+  AVERT(Arena, arena);
+  AVERT(Chunk, chunk);
+  clChunk = Chunk2ClientChunk(chunk);
+  AVERT(ClientChunk, clChunk);
+  AVER(chunk->allocBase <= baseIndex);
+  AVER(pages > 0);
+  AVER(baseIndex + pages <= chunk->pages);
+  AVERT(Pool, pool);
+
+  for (i = 0; i < pages; ++i)
+    PageAlloc(chunk, baseIndex + i, pool);
+
+  arena->committed += ChunkPagesToSize(chunk, pages);
+  AVER(clChunk->freePages >= pages);
+  clChunk->freePages -= pages;
+
+  return ResOK;
+}
+
+
+/* ClientChunkPageMapped -- determine if a page is mapped */
+
+static Bool ClientChunkPageMapped(Chunk chunk, Index index)
+{
+  UNUSED(chunk);
+  UNUSED(index);
+
+  AVERT(Chunk, chunk);
+  AVER(index < chunk->pages);
+
+  return TRUE;
+}
+
+
+/* ClientArenaFree - free a region in the arena */
+
+static void ClientArenaFree(Addr base, Size size, Pool pool)
+{
+  Arena arena;
+  Chunk chunk = NULL;           /* suppress "may be used uninitialized" */
+  Size pages;
+  Index pi, baseIndex, limitIndex;
+  Bool foundChunk;
+  ClientChunk clChunk;
+
+  AVER(base != NULL);
+  AVER(size > (Size)0);
+  AVERT(Pool, pool);
+  arena = PoolArena(pool);
+  AVERC(ClientArena, arena);
+  AVER(SizeIsAligned(size, ChunkPageSize(arena->primary)));
+  AVER(AddrIsAligned(base, ChunkPageSize(arena->primary)));
+
+  foundChunk = ChunkOfAddr(&chunk, arena, base);
+  AVER(foundChunk);
+  clChunk = Chunk2ClientChunk(chunk);
+  AVERT(ClientChunk, clChunk);
+
+  pages = ChunkSizeToPages(chunk, size);
+  baseIndex = INDEX_OF_ADDR(chunk, base);
+  limitIndex = baseIndex + pages;
+  AVER(baseIndex < limitIndex);
+  AVER(limitIndex <= chunk->pages);
+
+  for(pi = baseIndex; pi < limitIndex; pi++) {
+    Tract tract = PageTract(ChunkPage(chunk, pi));
+
+    AVER(TractPool(tract) == pool);
+    TractFinish(tract);
+  }
+
+  AVER(BTIsSetRange(chunk->allocTable, baseIndex, limitIndex));
+  BTResRange(chunk->allocTable, baseIndex, limitIndex);
+
+  AVER(arena->committed >= size);
+  arena->committed -= size;
+  clChunk->freePages += pages;
+}
+
+
+/* ClientArenaClass  -- The Client arena class definition */
+
+DEFINE_CLASS(Arena, ClientArena, klass)
+{
+  INHERIT_CLASS(klass, ClientArena, AbstractArena);
+  klass->size = sizeof(ClientArenaStruct);
+  klass->varargs = ClientArenaVarargs;
+  klass->create = ClientArenaCreate;
+  klass->destroy = ClientArenaDestroy;
+  klass->extend = ClientArenaExtend;
+  klass->pagesMarkAllocated = ClientArenaPagesMarkAllocated;
+  klass->free = ClientArenaFree;
+  klass->chunkInit = ClientChunkInit;
+  klass->chunkFinish = ClientChunkFinish;
+  klass->chunkPageMapped = ClientChunkPageMapped;
+  AVERT(ArenaClass, klass);
+}
+
+
+/* mps_arena_class_cl -- return the arena class CL */
+
+mps_arena_class_t mps_arena_class_cl(void)
+{
+  return (mps_arena_class_t)CLASS(ClientArena);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/arenacv.c

@@ -0,0 +1,517 @@
+/* arenacv.c: ARENA COVERAGE TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .coverage: At the moment, we're only trying to cover the new code
+ * (partial mapping of the page table and vm overflow).
+ *
+ * .note.tract-size: If the page size is divisible by sizeof(TractStruct), many
+ * test cases end up being essentially identical -- there just aren't that
+ * many different cases then.
+ *
+ * .improve.gap-below: Could test different-sized gaps below the tract
+ * being allocated; this requires using two adjacent zones.
+ */
+
+#include "mpm.h"
+#include "poolmvff.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include "mpsavm.h"
+#include "mpsacl.h"
+
+#include <stdio.h> /* printf */
+#include <stdlib.h> /* malloc */
+
+
+#define tractsSIZE 500
+
+
+/* testAllocAndIterate  -- Test arena allocation and iteration
+ *
+ * .tract-seg: Test allocation and iteration, using both low-level
+ * tracts and higher-level segments. To do this, contrive a set of
+ * allocation and iteration functions which are interchangeable.
+ */
+
+/* Type definitions for the interchangability interface */
+
+
+/* AllocInfo -- interchangeable info about  allocated regions */
+
+typedef struct AllocInfoStruct *AllocInfo;
+
+typedef struct AllocInfoStruct {
+  union {
+    struct {
+      Addr base;
+      Size size;
+      Pool pool;
+    } tractData;
+    struct {
+      Seg seg;
+    } segData;
+  } the;
+} AllocInfoStruct;
+
+typedef Res (*AllocFun)(AllocInfoStruct *aiReturn, LocusPref pref,
+                        Size size, Pool pool);
+
+typedef void (*FreeFun)(AllocInfo ai);
+
+typedef Bool (*FirstFun)(AllocInfoStruct *aiReturn, Arena arena);
+
+typedef Bool (*NextFun)(AllocInfoStruct *nextReturn, AllocInfo ai,
+                        Arena arena);
+
+typedef Count (*UnitsFun)(Count pages);
+
+typedef void (*TestFun)(AllocInfo ai, Arena arena);
+
+typedef void (*CopyFun)(AllocInfoStruct *toReturn, AllocInfo from);
+
+
+/*  AllocatorClass -- encapsulates an allocation mechanism */
+
+typedef struct AllocatorClassStruct *AllocatorClass;
+
+typedef struct AllocatorClassStruct {
+  AllocFun alloc;         /* allocation method */
+  FreeFun free;           /* deallocation method */
+  FirstFun first;         /* find first block for iteration */
+  NextFun next;           /* find next block for iteration */
+  UnitsFun units;         /* number of iteration objects for pages */
+  TestFun test;           /* consistency check a region */
+  CopyFun copy;           /* copy an AllocationInfo object */
+} AllocatorClassStruct;
+
+
+/* tractSearchInChunk -- find a tract in a chunk
+ *
+ * .tract-search: Searches for a tract in the chunk starting at page
+ * index i, return FALSE if there is none.
+ */
+
+static Bool tractSearchInChunk(Tract *tractReturn, Chunk chunk, Index i)
+{
+  AVER_CRITICAL(chunk->allocBase <= i);
+  AVER_CRITICAL(i <= chunk->pages);
+
+  while (i < chunk->pages
+         && !(BTGet(chunk->allocTable, i)
+              && PageIsAllocated(ChunkPage(chunk, i)))) {
+    ++i;
+  }
+  if (i == chunk->pages)
+    return FALSE;
+  AVER(i < chunk->pages);
+  *tractReturn = PageTract(ChunkPage(chunk, i));
+  return TRUE;
+}
+
+
+/* tractSearch -- find next tract above address
+ *
+ * Searches for the next tract in increasing address order.
+ * The tract returned is the next one along from addr (i.e.,
+ * it has a base address bigger than addr and no other tract
+ * with a base address bigger than addr has a smaller base address).
+ *
+ * Returns FALSE if there is no tract to find (end of the arena).
+ */
+
+static Bool tractSearch(Tract *tractReturn, Arena arena, Addr addr)
+{
+  Bool b;
+  Chunk chunk;
+  Tree tree;
+
+  b = ChunkOfAddr(&chunk, arena, addr);
+  if (b) {
+    Index i;
+
+    i = INDEX_OF_ADDR(chunk, addr);
+    /* There are fewer pages than addresses, therefore the */
+    /* page index can never wrap around */
+    AVER_CRITICAL(i+1 != 0);
+
+    if (tractSearchInChunk(tractReturn, chunk, i+1)) {
+      return TRUE;
+    }
+  }
+  while (TreeFindNext(&tree, ArenaChunkTree(arena), TreeKeyOfAddrVar(addr),
+                      ChunkCompare))
+  {
+    chunk = ChunkOfTree(tree);
+    addr = chunk->base;
+    /* Start from allocBase to skip the tables. */
+    if (tractSearchInChunk(tractReturn, chunk, chunk->allocBase)) {
+      return TRUE;
+    }
+  }
+  return FALSE;
+}
+
+
+/* Implementation of the tract-based interchangability interface */
+
+static Res allocAsTract(AllocInfoStruct *aiReturn, LocusPref pref,
+                        Size size, Pool pool)
+{
+  Res res;
+  Addr base;
+  res = ArenaAlloc(&base, pref, size, pool);
+  if (res == ResOK) {
+    aiReturn->the.tractData.base = base;
+    aiReturn->the.tractData.size = size;
+    aiReturn->the.tractData.pool = pool;
+  }
+  return res;
+}
+
+static void freeAsTract(AllocInfo ai)
+{
+  ArenaFree(ai->the.tractData.base,
+            ai->the.tractData.size,
+            ai->the.tractData.pool);
+}
+
+static Bool firstAsTract(AllocInfoStruct *aiReturn, Arena arena)
+{
+  Bool res;
+  Tract tract;
+  res = tractSearch(&tract, arena, 0);
+  if (res) {
+    aiReturn->the.tractData.base = TractBase(tract);
+    aiReturn->the.tractData.size = ArenaGrainSize(arena);;
+    aiReturn->the.tractData.pool = TractPool(tract);
+  }
+  return res;
+}
+
+static Bool nextAsTract(AllocInfoStruct *nextReturn, AllocInfo ai,
+                        Arena arena)
+{
+  Bool res;
+  Tract tract;
+  res = tractSearch(&tract, arena, ai->the.tractData.base);
+  if (res) {
+    nextReturn->the.tractData.base = TractBase(tract);
+    nextReturn->the.tractData.size = ArenaGrainSize(arena);;
+    nextReturn->the.tractData.pool = TractPool(tract);
+  }
+  return res;
+}
+
+static Count unitsAsTract(Count pages)
+{
+  return pages; /* one tract for each page */
+}
+
+
+static void testAsTract(AllocInfo ai, Arena arena)
+{
+  /* Test TractOfAddr */
+  Tract tract;
+  Addr base;
+  Bool found;
+
+  found = TractOfAddr(&tract, arena, ai->the.tractData.base);
+  cdie(found, "TractOfAddr");
+  base = TractBase(tract);
+  cdie(base == ai->the.tractData.base, "base");
+
+}
+
+static void copyAsTract(AllocInfoStruct *toReturn, AllocInfo from)
+{
+  toReturn->the.tractData.base = from->the.tractData.base;
+  toReturn->the.tractData.size = from->the.tractData.size;
+  toReturn->the.tractData.pool = from->the.tractData.pool;
+}
+
+static AllocatorClassStruct allocatorTractStruct = {
+  allocAsTract,
+  freeAsTract,
+  firstAsTract,
+  nextAsTract,
+  unitsAsTract,
+  testAsTract,
+  copyAsTract
+};
+
+
+/* Implementation of the segment-based interchangability interface */
+
+static Res allocAsSeg(AllocInfoStruct *aiReturn, LocusPref pref,
+                      Size size, Pool pool)
+{
+  Res res;
+  Seg seg;
+  res = SegAlloc(&seg, CLASS(Seg), pref, size, pool, argsNone);
+  if (res == ResOK) {
+    aiReturn->the.segData.seg = seg;
+  }
+  return res;
+}
+
+static void freeAsSeg(AllocInfo ai)
+{
+  SegFree(ai->the.segData.seg);
+}
+
+static Bool firstAsSeg(AllocInfoStruct *aiReturn, Arena arena)
+{
+  Bool res;
+  Seg seg;
+  res = SegFirst(&seg, arena);
+  if (res) {
+    aiReturn->the.segData.seg = seg;
+  }
+  return res;
+}
+
+static Bool nextAsSeg(AllocInfoStruct *nextReturn, AllocInfo ai,
+                      Arena arena)
+{
+  Bool res;
+  Seg seg;
+  res = SegNext(&seg, arena, ai->the.segData.seg);
+  if (res) {
+    nextReturn->the.segData.seg = seg;
+  }
+  return res;
+}
+
+static Count unitsAsSeg(Count pages)
+{
+  if (0 == pages)
+    return 0; /* can't have a zero length seg */
+  else
+    return 1; /* one seg no matter how many pages */
+}
+
+static void testAsSeg(AllocInfo ai, Arena arena)
+{
+  /* Test size functions */
+  Seg seg = ai->the.segData.seg;
+  Addr base, limit;
+  Size size;
+
+  UNUSED(arena);
+  base = SegBase(seg);
+  limit = SegLimit(seg);
+  size = SegSize(seg);
+  cdie(size == AddrOffset(base, limit), "size");
+}
+
+static void copyAsSeg(AllocInfoStruct *toReturn, AllocInfo from)
+{
+  toReturn->the.segData.seg = from->the.segData.seg;
+}
+
+static AllocatorClassStruct allocatorSegStruct = {
+  allocAsSeg,
+  freeAsSeg,
+  firstAsSeg,
+  nextAsSeg,
+  unitsAsSeg,
+  testAsSeg,
+  copyAsSeg
+};
+
+
+/* The main function can use either tracts or segs */
+
+static void testAllocAndIterate(Arena arena, Pool pool,
+                                Size pageSize, Count numPerPage,
+                                AllocatorClass allocator)
+{
+  AllocInfoStruct offsetRegion, gapRegion, newRegion, topRegion;
+  LocusPrefStruct pref;
+  Count offset, gap, new;
+  ZoneSet zone = (ZoneSet)2;
+  int i;
+
+  LocusPrefInit(&pref);
+
+  /* Testing the behaviour with various sizes of gaps in the page table. */
+
+  /* Assume the allocation strategy is first-fit.  The idea of the tests is */
+  /* to allocate a region of memory, then deallocate a gap in the middle, */
+  /* then allocate a new region that fits in the gap with various amounts */
+  /* left over.  Like this: */
+  /* |-offsetRegion-||----gapRegion----||-topRegion-| */
+  /* |-offsetRegion-||-newRegion-|      |-topRegion-| */
+  /* This is done with three different sizes of offsetRegion, in two */
+  /* different zones to ensure that all page boundary cases are tested. */
+  for(i = 0; i < 2; ++i) { /* zone loop */
+    for(offset = 0; offset <= 2*numPerPage; offset += numPerPage) {
+      if(offset != 0)
+        die(allocator->alloc(&offsetRegion, &pref, offset * pageSize, pool),
+            "offsetRegion");
+      for(gap = numPerPage+1; gap <= 3 * (numPerPage+1);
+          gap += (numPerPage+1)) {
+        die(allocator->alloc(&gapRegion, &pref, gap * pageSize, pool),
+            "gapRegion");
+        die(allocator->alloc(&topRegion, &pref, pageSize, pool),
+            "topRegion");
+        allocator->free(&gapRegion);
+        for(new = 1; new <= gap; new += numPerPage) {
+          AllocInfoStruct thisRegion, nextRegion;
+          Count regionNum, expected;
+          Res enoughRegions;
+
+          die(allocator->alloc(&newRegion, &pref, new * pageSize, pool),
+              "newRegion");
+
+          /* Test iterators */
+          cdie(allocator->first(&thisRegion, arena), "first");
+          regionNum = 1;
+          while (allocator->next(&nextRegion, &thisRegion, arena)) {
+            regionNum++;
+            allocator->copy(&thisRegion, &nextRegion);
+          }
+
+          /* Should be able to iterate over at least offset, new, top */
+          expected =
+            allocator->units(offset) +
+            allocator->units(new) +
+            allocator->units(1);
+
+          if (regionNum >= expected)
+            enoughRegions = ResOK;
+          else
+            enoughRegions = ResFAIL;
+
+          die(enoughRegions, "Not enough regions");
+
+          allocator->free(&newRegion);
+        }
+
+      allocator->free(&topRegion);
+      }
+      if(offset != 0) {
+        allocator->test(&offsetRegion, arena);
+        allocator->free(&offsetRegion);
+      }
+    }
+    LocusPrefExpress(&pref, LocusPrefZONESET, &zone);
+  }
+}
+
+
+static void testPageTable(ArenaClass klass, Size size, Addr addr, Bool zoned)
+{
+  Arena arena; Pool pool;
+  Size pageSize;
+  Count tractsPerPage;
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_CL_BASE, addr);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, zoned);
+    die(ArenaCreate(&arena, klass, args), "ArenaCreate");
+  } MPS_ARGS_END(args);
+
+  die(PoolCreate(&pool, arena, PoolClassMVFF(), argsNone), "PoolCreate");
+
+  pageSize = ArenaGrainSize(arena);
+  tractsPerPage = pageSize / sizeof(TractStruct);
+  printf("%ld tracts per page in the page table.\n", (long)tractsPerPage);
+
+  /* test tract allocation and iteration */
+  testAllocAndIterate(arena, pool, pageSize, tractsPerPage,
+                      &allocatorTractStruct);
+
+  /* test segment allocation and iteration */
+  testAllocAndIterate(arena, pool, pageSize, tractsPerPage,
+                      &allocatorSegStruct);
+
+  die(ArenaDescribe(arena, mps_lib_get_stdout(), 0), "ArenaDescribe");
+  die(ArenaDescribeTracts(arena, mps_lib_get_stdout(), 0),
+      "ArenaDescribeTracts");
+
+  PoolDestroy(pool);
+  ArenaDestroy(arena);
+}
+
+
+/* testSize -- test arena size overflow
+ *
+ * Just try allocating larger arenas, doubling the size each time, until
+ * it fails, then check the error code.
+ */
+
+static void testSize(Size size)
+{
+  ArenaClass klass = (ArenaClass)mps_arena_class_vm();
+  Arena arena;
+  Res res;
+
+  do {
+    MPS_ARGS_BEGIN(args) {
+      MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, size);
+      res = ArenaCreate(&arena, klass, args);
+    } MPS_ARGS_END(args);
+    if (res == ResOK)
+      ArenaDestroy(arena);
+    else
+      die((res == ResRESOURCE) ? ResOK : res, "right error code");
+    size *= 2;
+  } while (size == 0);
+}
+
+
+#define TEST_ARENA_SIZE              ((Size)16<<22)
+
+
+int main(int argc, char *argv[])
+{
+  void *block;
+
+  testlib_init(argc, argv);
+
+  testPageTable((ArenaClass)mps_arena_class_vm(), TEST_ARENA_SIZE, 0, TRUE);
+  testPageTable((ArenaClass)mps_arena_class_vm(), TEST_ARENA_SIZE, 0, FALSE);
+
+  block = malloc(TEST_ARENA_SIZE);
+  cdie(block != NULL, "malloc");
+  testPageTable((ArenaClass)mps_arena_class_cl(), TEST_ARENA_SIZE, block, FALSE);
+
+  testSize(TEST_ARENA_SIZE);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/arg.c

@@ -0,0 +1,240 @@
+/* arg.c: ARGUMENT LISTS
+ *
+ * $Id$
+ * Copyright (c) 2013-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/keyword-arguments.rst>.
+ */
+
+#include "config.h"
+#include "check.h"
+#include "mpm.h"
+#include "dbgpool.h"
+
+SRCID(arg, "$Id$");
+
+
+/* ArgCheckCant -- default argument checker
+ *
+ * This is a default value for the KeyStruct check field for keywords
+ * that don't have any meaningful checking they can do.
+ */
+
+Bool ArgCheckCant(Arg arg)
+{
+  UNUSED(arg);
+  return TRUE;
+}
+
+static Bool ArgCheckShouldnt(Arg arg)
+{
+  UNUSED(arg);
+  NOTREACHED;
+  return FALSE;
+}
+
+Bool ArgCheckFormat(Arg arg)
+{
+  CHECKD(Format, arg->val.format);
+  return TRUE;
+}
+
+Bool ArgCheckChain(Arg arg)
+{
+  CHECKD(Chain, arg->val.chain);
+  return TRUE;
+}
+
+Bool ArgCheckSize(Arg arg)
+{
+  UNUSED(arg); /* TODO: Add and call SizeCheck */
+  return TRUE;
+}
+
+Bool ArgCheckAddr(Arg arg)
+{
+  UNUSED(arg); /* TODO: Add and call AddrCheck */
+  return TRUE;
+}
+
+Bool ArgCheckPoolDebugOptions(Arg arg)
+{
+  CHECKD_NOSIG(PoolDebugOptions, (PoolDebugOptions)arg->val.pool_debug_options);
+  return TRUE;
+}
+
+Bool ArgCheckFun(Arg arg)
+{
+  /* TODO: Fix potential pun here on Harvard architectures where
+     function pointers are not compatible with other pointers. */
+  CHECKL(FUNCHECK(arg->val.addr_method));
+  return TRUE;
+}
+
+Bool ArgCheckAlign(Arg arg)
+{
+  CHECKL(AlignCheck(arg->val.align));
+  return TRUE;
+}
+
+Bool ArgCheckBool(Arg arg)
+{
+  CHECKL(BoolCheck(arg->val.b));
+  return TRUE;
+}
+
+Bool ArgCheckCount(Arg arg)
+{
+  UNUSED(arg); /* TODO: Add and call CountCheck */
+  return TRUE;
+}
+
+Bool ArgCheckPointer(Arg arg)
+{
+  CHECKL(arg != NULL);
+  return TRUE;
+}
+
+Bool ArgCheckRankSet(Arg arg)
+{
+  CHECKL(COMPATTYPE(RankSet, unsigned));
+  CHECKL(RankSetCheck(arg->val.u));
+  return TRUE;
+}
+
+Bool ArgCheckRank(Arg arg)
+{
+  CHECKL(RankCheck(arg->val.rank));
+  return TRUE;
+}
+
+Bool ArgCheckdouble(Arg arg)
+{
+  /* Don't call isfinite() here because it's not in C89, and because
+     infinity is a valid value for MPS_KEY_PAUSE_TIME. */
+  UNUSED(arg);
+  return TRUE;
+}
+
+Bool ArgCheckPool(Arg arg)
+{
+  CHECKD(Pool, arg->val.pool);
+  return TRUE;
+}
+
+
+ARG_DEFINE_KEY(ARGS_END, Shouldnt);
+
+ArgStruct mps_args_none[] = {{MPS_KEY_ARGS_END, {0}}};
+
+
+/* KeyCheck -- check the validity of an argument key */
+
+Bool KeyCheck(Key key)
+{
+  CHECKS(Key, key);
+  CHECKL(key->name != NULL);
+  CHECKL(FUNCHECK(key->check));
+  return TRUE;
+}
+
+
+Bool ArgCheck(Arg arg)
+{
+  CHECKL(arg != NULL);
+  CHECKD(Key, arg->key);
+  CHECKL(arg->key->check(arg));
+  return TRUE;
+}
+
+
+/* ArgCheck -- check the validity of an argument list */
+
+Bool ArgListCheck(ArgList args)
+{
+  Index i;
+  CHECKL(args != NULL);
+  for (i = 0; args[i].key != MPS_KEY_ARGS_END; ++i) {
+    CHECKL(i < MPS_ARGS_MAX);
+    CHECKD_NOSIG(Arg, &args[i]);
+  }
+  return TRUE;
+}
+
+
+/* ArgPick -- try to pick an argument out of the argument list by keyword */
+
+Bool ArgPick(ArgStruct *argOut, ArgList args, Key key)
+{
+  Index i;
+
+  AVER(argOut != NULL);
+  AVERT(ArgList, args);
+  AVERT(Key, key);
+
+  for (i = 0; args[i].key != MPS_KEY_ARGS_END; ++i)
+    if (args[i].key == key)
+      goto found;
+  return FALSE;
+
+found:
+  AVERT(Arg, &args[i]);
+  *argOut = args[i];
+  for(;;) {
+    args[i] = args[i + 1];
+    if (args[i].key == MPS_KEY_ARGS_END)
+      break;
+    ++i;
+  }
+  return TRUE;
+}
+
+
+/* ArgRequire -- take a required argument out of the argument list by keyword */
+
+void ArgRequire(ArgStruct *argOut, ArgList args, Key key)
+{
+  Bool b = ArgPick(argOut, args, key);
+  ASSERT(b, key->name);
+}
+
+
+/* ArgTrivVarargs -- class method to ignore deprecated varargs */
+
+void ArgTrivVarargs(ArgStruct args[MPS_ARGS_MAX], va_list varargs)
+{
+  UNUSED(varargs);
+  args[0].key = MPS_KEY_ARGS_END;
+  AVERT(ArgList, args);
+}
+
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/arg.h

@@ -0,0 +1,91 @@
+/* arg.h: Keyword argument lists
+ *
+ * $Id$
+ * Copyright (c) 2013-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/keyword-arguments.rst>.
+ */
+
+#ifndef arg_h
+#define arg_h
+
+#include "mpmtypes.h"
+
+
+/* KeyStruct -- keyword argument structure
+ *
+ * NOTE: Whether or not to have an argument checking field and functions
+ * could be conditional on build variety.  Checking arguments isn't on
+ * the critical path, but this might save space if the MPS is being
+ * deployed in a tight memory situation.
+ */
+
+#define KeySig          ((Sig)0x519CE111) /* SIGnature KEYyy */
+typedef struct mps_key_s {
+  Sig sig;                      /* design.mps.sig.field */
+  const char *name;
+  Bool (*check)(Arg arg);
+} KeyStruct;
+
+#define ARG_DEFINE_KEY(id, type) \
+  extern const KeyStruct _mps_key_##id; \
+  const KeyStruct _mps_key_##id = {KeySig, "MPS_KEY_" #id, ArgCheck##type}
+
+#define argsNone mps_args_none
+
+extern Bool KeyCheck(Key key);
+extern Bool ArgCheck(Arg arg);
+extern Bool ArgListCheck(ArgList args);
+
+extern Bool ArgPick(ArgStruct *argOut, ArgList args, Key key);
+extern void ArgRequire(ArgStruct *argOut, ArgList args, Key key);
+extern void ArgTrivVarargs(ArgStruct args[MPS_ARGS_MAX], va_list varargs);
+
+extern Bool ArgCheckCant(Arg arg);
+extern Bool ArgCheckFormat(Arg arg);
+extern Bool ArgCheckChain(Arg arg);
+extern Bool ArgCheckSize(Arg arg);
+extern Bool ArgCheckAddr(Arg arg);
+extern Bool ArgCheckPoolDebugOptions(Arg arg);
+extern Bool ArgCheckFun(Arg arg);
+extern Bool ArgCheckAlign(Arg arg);
+extern Bool ArgCheckBool(Arg arg);
+extern Bool ArgCheckCount(Arg arg);
+extern Bool ArgCheckPointer(Arg arg);
+extern Bool ArgCheckRankSet(Arg arg);
+extern Bool ArgCheckRank(Arg arg);
+extern Bool ArgCheckdouble(Arg arg);
+extern Bool ArgCheckPool(Arg arg);
+
+
+#endif /* arg_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2013-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/awlut.c

@@ -0,0 +1,396 @@
+/* awlut.c: POOL CLASS AWL UNIT TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * DESIGN
+ *
+ * .design: see <design/poolawl#.test>
+ */
+
+#include "mpscawl.h"
+#include "mpsclo.h"
+#include "mpsavm.h"
+#include "fmtdy.h"
+#include "testlib.h"
+#include "testthr.h"
+#include "mpslib.h"
+#include "mps.h"
+#include "mpstd.h"
+
+#include <stdio.h> /* printf */
+#include <string.h> /* strlen */
+
+
+#define testArenaSIZE     ((size_t)64<<20)
+#define TABLE_SLOTS 49
+#define ITERATIONS 5000
+#define CHATTER 100
+
+
+static mps_word_t bogus_class;
+
+#define UNINIT 0x041412ED
+
+#define DYLAN_ALIGN 4 /* depends on value defined in fmtdy.c */
+
+
+/* size_tAlignUp -- align w up to alignment a */
+
+#define size_tAlignUp(w, a) (((w) + (a) - 1) & ~((size_t)(a) - 1))
+
+
+static mps_word_t wrapper_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* Extra word */
+  (mps_word_t)4<<2|2,                     /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8),    /* V */
+  (mps_word_t)1<<2|1,                     /* VL */
+  1                             /* patterns */
+};
+
+
+static mps_word_t string_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  0,                            /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8)|(mps_word_t)3<<3|4,   /* V */
+  1                             /* VL */
+};
+
+static mps_word_t table_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  (mps_word_t)1<<2|1,                     /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8)|2,  /* V */
+  1                             /* VL */
+};
+
+
+static void initialise_wrapper(mps_word_t *wrapper)
+{
+  wrapper[0] = (mps_word_t)&wrapper_wrapper;
+  wrapper[1] = (mps_word_t)&bogus_class;
+}
+
+
+/* alloc_string  - create a dylan string object
+ *
+ * create a dylan string object (byte vector) whose contents
+ * are the string s (including the terminating NUL)
+ * .assume.dylan-obj
+ */
+
+static mps_word_t *alloc_string(const char *s, mps_ap_t ap)
+{
+  size_t l;
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  l = strlen(s)+1;
+  /* number of words * sizeof word */
+  objsize = (2 + (l+sizeof(mps_word_t)-1)/sizeof(mps_word_t))
+            * sizeof(mps_word_t);
+  objsize = size_tAlignUp(objsize, DYLAN_ALIGN);
+  do {
+    size_t i;
+    char *s2;
+
+    die(mps_reserve(&p, ap, objsize), "Reserve Leaf\n");
+    object = p;
+    object[0] = (mps_word_t)string_wrapper;
+    object[1] = l << 2 | 1;
+    s2 = (char *)&object[2];
+    for(i = 0; i < l; ++i) {
+      s2[i] = s[i];
+    }
+  } while(!mps_commit(ap, p, objsize));
+  return object;
+}
+
+
+/* alloc_table -- create a table with n variable slots
+ *
+ * .assume.dylan-obj
+ */
+
+static mps_word_t *alloc_table(size_t n, mps_ap_t ap)
+{
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  objsize = (3 + n) * sizeof(mps_word_t);
+  objsize = size_tAlignUp(objsize, MPS_PF_ALIGN);
+  do {
+    size_t i;
+
+    die(mps_reserve(&p, ap, objsize), "Reserve Table\n");
+    object = p;
+    object[0] = (mps_word_t)table_wrapper;
+    object[1] = 0;
+    object[2] = n << 2 | 1;
+    for(i = 0; i < n; ++i) {
+      object[3+i] = 0;
+    }
+  } while(!mps_commit(ap, p, objsize));
+  return object;
+}
+
+
+/* gets the nth slot from a table
+ * .assume.dylan-obj
+ */
+static mps_word_t *table_slot(mps_word_t *table, size_t n)
+{
+  return (mps_word_t *)table[3+n];
+}
+
+
+/* sets the nth slot in a table
+ * .assume.dylan-obj
+ */
+static void set_table_slot(mps_word_t *table, size_t n, mps_word_t *p)
+{
+  cdie(table[0] == (mps_word_t)table_wrapper, "set_table_slot");
+  table[3+n] = (mps_word_t)p;
+}
+
+
+/* links two tables together via their link slot
+ * (1st fixed part slot)
+ */
+static void table_link(mps_word_t *t1, mps_word_t *t2)
+{
+  cdie(t1[0] == (mps_word_t)table_wrapper, "table_link 1");
+  cdie(t2[0] == (mps_word_t)table_wrapper, "table_link 2");
+  t1[1] = (mps_word_t)t2;
+  t2[1] = (mps_word_t)t1;
+}
+
+
+typedef struct tables_s {
+  mps_arena_t arena;
+  mps_word_t *weaktable;
+  mps_word_t *exacttable;
+  mps_word_t *preserve[TABLE_SLOTS];    /* preserves objects in the weak */
+                                        /* table by referring to them */
+  mps_ap_t weakap, exactap, bogusap, leafap;
+} tables_s, *tables_t;
+
+
+/* populate -- populate the weak table in a thread
+ *
+ * We use a thread to populate the table to avoid leaving any
+ * references to objects in the table in registers, so that we can
+ * test their weakness properly.
+ */
+
+static void *populate(void *state)
+{
+  tables_t tables = state;
+  size_t i;
+  mps_thr_t me;
+  mps_root_t root;
+
+  die(mps_thread_reg(&me, tables->arena), "mps_thread_reg(populate)");
+  die(mps_root_create_thread(&root, tables->arena, me, &state), "mps_root_create_thread(populate)");
+
+  tables->exacttable = alloc_table(TABLE_SLOTS, tables->exactap);
+  tables->weaktable = alloc_table(TABLE_SLOTS, tables->weakap);
+  table_link(tables->exacttable, tables->weaktable);
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    mps_word_t *string;
+    if (rnd() % 2 == 0) {
+      string = alloc_string("iamalive", tables->leafap);
+      tables->preserve[i] = string;
+    } else {
+      string = alloc_string("iamdead", tables->leafap);
+      tables->preserve[i] = 0;
+    }
+    set_table_slot(tables->weaktable, i, string);
+    string = alloc_string("iamexact", tables->leafap);
+    set_table_slot(tables->exacttable, i, string);
+  }
+
+  mps_root_destroy(root);
+  mps_thread_dereg(me);
+
+  return NULL;
+}
+
+static void test(mps_arena_t arena,
+                 mps_ap_t leafap, mps_ap_t exactap, mps_ap_t weakap,
+                 mps_ap_t bogusap)
+{
+  tables_s tables;
+  size_t i, j;
+  testthr_t thr;
+  void *p;
+
+  /* Leave bogusap between reserve and commit for the duration */
+  die(mps_reserve(&p, bogusap, 64), "Reserve bogus");
+
+  tables.arena = arena;
+  tables.exactap = exactap;
+  tables.weakap = weakap;
+  tables.leafap = leafap;
+  tables.bogusap = bogusap;
+
+  /* We using a thread for its pararallel execution, so just create
+     and wait for it to finish. */
+  testthr_create(&thr, populate, &tables);
+  testthr_join(&thr, NULL);
+
+  for(j = 0; j < ITERATIONS; ++j) {
+    for(i = 0; i < TABLE_SLOTS; ++i) {
+      (void)alloc_string("spong", leafap);
+    }
+  }
+
+  die(mps_arena_collect(arena), "mps_arena_collect");
+  mps_arena_release(arena);
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    if (tables.preserve[i] == 0) {
+      if (table_slot(tables.weaktable, i)) {
+        error("Strongly unreachable weak table entry found, "
+              "slot %"PRIuLONGEST".\n", (ulongest_t)i);
+      } else {
+        if (table_slot(tables.exacttable, i) != 0) {
+          error("Weak table entry deleted, but corresponding "
+                "exact table entry not deleted, slot %"PRIuLONGEST".\n",
+                (ulongest_t)i);
+        }
+      }
+    }
+  }
+
+  (void)mps_commit(bogusap, p, 64);
+}
+
+
+/* setup -- set up pools for the test
+ *
+ * guff serves two purposes:
+ *  - a pseudo stack base for the stack root.
+ *  - pointer to a guff structure, which packages some values needed
+ *   (arena and thr mostly)
+ */
+
+struct guff_s {
+  mps_arena_t arena;
+  mps_thr_t thr;
+};
+
+ATTRIBUTE_NOINLINE
+static void setup(struct guff_s *guff)
+{
+  mps_arena_t arena;
+  mps_pool_t leafpool;
+  mps_pool_t tablepool;
+  mps_fmt_t dylanfmt;
+  mps_fmt_t dylanweakfmt;
+  mps_ap_t leafap, exactap, weakap, bogusap;
+  mps_root_t stack;
+  mps_thr_t thr;
+
+  arena = guff->arena;
+  thr = guff->thr;
+
+  die(mps_root_create_thread(&stack, arena, thr, guff),
+      "Root Create\n");
+  die(mps_fmt_create_A(&dylanfmt, arena, dylan_fmt_A()),
+      "Format Create\n");
+  die(mps_fmt_create_A(&dylanweakfmt, arena, dylan_fmt_A_weak()),
+      "Format Create (weak)\n");
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, dylanfmt);
+    die(mps_pool_create_k(&leafpool, arena, mps_class_lo(), args),
+        "Leaf Pool Create\n");
+  } MPS_ARGS_END(args);
+  die(mps_pool_create(&tablepool, arena, mps_class_awl(), dylanweakfmt,
+                      dylan_weak_dependent),
+      "Table Pool Create\n");
+  die(mps_ap_create(&leafap, leafpool, mps_rank_exact()),
+      "Leaf AP Create\n");
+  die(mps_ap_create(&exactap, tablepool, mps_rank_exact()),
+      "Exact AP Create\n");
+  die(mps_ap_create(&weakap, tablepool, mps_rank_weak()),
+      "Weak AP Create\n");
+  die(mps_ap_create(&bogusap, tablepool, mps_rank_exact()),
+      "Bogus AP Create\n");
+
+  test(arena, leafap, exactap, weakap, bogusap);
+
+  mps_ap_destroy(bogusap);
+  mps_ap_destroy(weakap);
+  mps_ap_destroy(exactap);
+  mps_ap_destroy(leafap);
+  mps_pool_destroy(tablepool);
+  mps_pool_destroy(leafpool);
+  mps_fmt_destroy(dylanweakfmt);
+  mps_fmt_destroy(dylanfmt);
+  mps_root_destroy(stack);
+}
+
+
+int main(int argc, char *argv[])
+{
+  struct guff_s guff;
+  mps_arena_t arena;
+  mps_thr_t thread;
+
+  testlib_init(argc, argv);
+
+  initialise_wrapper(wrapper_wrapper);
+  initialise_wrapper(string_wrapper);
+  initialise_wrapper(table_wrapper);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "arena_create\n");
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  guff.arena = arena;
+  guff.thr = thread;
+  setup(&guff);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/awluthe.c

@@ -0,0 +1,398 @@
+/* awluthe.c: POOL CLASS AWL UNIT TEST WITH OBJECT HEADERS
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * DESIGN
+ *
+ * .design: see <design/poolawl#.test>
+ */
+
+#include "mpscawl.h"
+#include "mpsclo.h"
+#include "mpsavm.h"
+#include "fmthe.h"
+#include "fmtdy.h"
+#include "testlib.h"
+#include "testthr.h"
+#include "mpslib.h"
+#include "mps.h"
+#include "mpstd.h"
+
+#include <string.h> /* strlen */
+#include <stdio.h> /* printf */
+
+
+#define testArenaSIZE     ((size_t)64<<20)
+#define TABLE_SLOTS 49
+#define ITERATIONS 5000
+#define CHATTER 100
+
+
+static mps_word_t bogus_class;
+
+#define UNINIT 0x041412ED
+
+#define DYLAN_ALIGN 4 /* depends on value defined in fmtdy.c */
+
+
+/* size_tAlignUp -- align w up to alignment a */
+
+#define size_tAlignUp(w, a) (((w) + (a) - 1) & ~((size_t)(a) - 1))
+
+
+static mps_word_t wrapper_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* Extra word */
+  (mps_word_t)4<<2|2,                     /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8),    /* V */
+  (mps_word_t)1<<2|1,                     /* VL */
+  1                             /* patterns */
+};
+
+
+static mps_word_t string_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  0,                            /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8)|(mps_word_t)3<<3|4,   /* V */
+  1                             /* VL */
+};
+
+static mps_word_t table_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  (mps_word_t)1<<2|1,                     /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8)|2,  /* V */
+  1                             /* VL */
+};
+
+
+static void initialise_wrapper(mps_word_t *wrapper)
+{
+  wrapper[0] = (mps_word_t)&wrapper_wrapper;
+  wrapper[1] = (mps_word_t)&bogus_class;
+}
+
+
+/* alloc_string  - create a dylan string object
+ *
+ * create a dylan string object (byte vector) whose contents
+ * are the string s (including the terminating NUL)
+ * .assume.dylan-obj
+ */
+
+static mps_word_t *alloc_string(const char *s, mps_ap_t ap)
+{
+  size_t l;
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  l = strlen(s)+1;
+  /* number of words * sizeof word */
+  objsize = (2 + (l+sizeof(mps_word_t)-1)/sizeof(mps_word_t))
+            * sizeof(mps_word_t);
+  objsize = size_tAlignUp(objsize, DYLAN_ALIGN);
+  do {
+    size_t i;
+    char *s2;
+
+    die(mps_reserve(&p, ap, objsize + headerSIZE), "Reserve Leaf\n");
+    object = (mps_word_t *)((char *)p + headerSIZE);
+    object[0] = (mps_word_t)string_wrapper;
+    object[1] = l << 2 | 1;
+    s2 = (char *)&object[2];
+    for(i = 0; i < l; ++i) {
+      s2[i] = s[i];
+    }
+    ((int*)p)[0] = realHeader;
+    ((int*)p)[1] = 0xED0ED;
+  } while(!mps_commit(ap, p, objsize + headerSIZE));
+  return object;
+}
+
+
+/* alloc_table -- create a table with n variable slots
+ *
+ * .assume.dylan-obj
+ */
+
+static mps_word_t *alloc_table(size_t n, mps_ap_t ap)
+{
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  objsize = (3 + n) * sizeof(mps_word_t);
+  objsize = size_tAlignUp(objsize, MPS_PF_ALIGN);
+  do {
+    size_t i;
+
+    die(mps_reserve(&p, ap, objsize + headerSIZE), "Reserve Table\n");
+    object = (mps_word_t *)((char *)p + headerSIZE);
+    object[0] = (mps_word_t)table_wrapper;
+    object[1] = 0;
+    object[2] = n << 2 | 1;
+    for(i = 0; i < n; ++i) {
+      object[3+i] = 0;
+    }
+    ((int*)p)[0] = realHeader;
+    ((int*)p)[1] = 0xED0ED;
+  } while(!mps_commit(ap, p, objsize + headerSIZE));
+  return object;
+}
+
+
+/* gets the nth slot from a table
+ * .assume.dylan-obj
+ */
+static mps_word_t *table_slot(mps_word_t *table, size_t n)
+{
+  return (mps_word_t *)table[3+n];
+}
+
+
+/* sets the nth slot in a table
+ * .assume.dylan-obj
+ */
+static void set_table_slot(mps_word_t *table, size_t n, mps_word_t *p)
+{
+  cdie(table[0] == (mps_word_t)table_wrapper, "set_table_slot");
+  table[3+n] = (mps_word_t)p;
+}
+
+
+/* links two tables together via their link slot
+ * (1st fixed part slot)
+ */
+static void table_link(mps_word_t *t1, mps_word_t *t2)
+{
+  cdie(t1[0] == (mps_word_t)table_wrapper, "table_link 1");
+  cdie(t2[0] == (mps_word_t)table_wrapper, "table_link 2");
+  t1[1] = (mps_word_t)t2;
+  t2[1] = (mps_word_t)t1;
+}
+
+
+typedef struct tables_s {
+  mps_arena_t arena;
+  mps_word_t *weaktable;
+  mps_word_t *exacttable;
+  mps_word_t *preserve[TABLE_SLOTS];    /* preserves objects in the weak */
+                                        /* table by referring to them */
+  mps_ap_t weakap, exactap, bogusap, leafap;
+} tables_s, *tables_t;
+
+/* populate -- populate the weak table in a thread
+ *
+ * We use a thread to populate the table to avoid leaving any
+ * references to objects in the table in registers, so that we can
+ * test their weakness properly.
+ */
+
+static void *populate(void *state)
+{
+  tables_t tables = state;
+  size_t i;
+  mps_thr_t me;
+  mps_root_t root;
+
+  die(mps_thread_reg(&me, tables->arena), "mps_thread_reg(populate)");
+  die(mps_root_create_thread(&root, tables->arena, me, &state), "mps_root_create_thread(populate)");
+
+  tables->exacttable = alloc_table(TABLE_SLOTS, tables->exactap);
+  tables->weaktable = alloc_table(TABLE_SLOTS, tables->weakap);
+  table_link(tables->exacttable, tables->weaktable);
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    mps_word_t *string;
+    if (rnd() % 2 == 0) {
+      string = alloc_string("iamalive", tables->leafap);
+      tables->preserve[i] = string;
+    } else {
+      string = alloc_string("iamdead", tables->leafap);
+      tables->preserve[i] = 0;
+    }
+    set_table_slot(tables->weaktable, i, string);
+    string = alloc_string("iamexact", tables->leafap);
+    set_table_slot(tables->exacttable, i, string);
+  }
+
+  mps_root_destroy(root);
+  mps_thread_dereg(me);
+
+  return NULL;
+}
+
+static void test(mps_arena_t arena,
+                 mps_ap_t leafap, mps_ap_t exactap, mps_ap_t weakap,
+                 mps_ap_t bogusap)
+{
+  tables_s tables;
+  size_t i, j;
+  testthr_t thr;
+  void *p;
+
+  /* Leave bogusap between reserve and commit for the duration */
+  die(mps_reserve(&p, bogusap, 64), "Reserve bogus");
+
+  tables.arena = arena;
+  tables.exactap = exactap;
+  tables.weakap = weakap;
+  tables.leafap = leafap;
+  tables.bogusap = bogusap;
+
+  /* We using a thread for its pararallel execution, so just create
+     and wait for it to finish. */
+  testthr_create(&thr, populate, &tables);
+  testthr_join(&thr, NULL);
+
+  for(j = 0; j < ITERATIONS; ++j) {
+    for(i = 0; i < TABLE_SLOTS; ++i) {
+      (void)alloc_string("spong", leafap);
+    }
+  }
+
+  die(mps_arena_collect(arena), "mps_arena_collect");
+  mps_arena_release(arena);
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    if (tables.preserve[i] == 0) {
+      if (table_slot(tables.weaktable, i)) {
+        error("Strongly unreachable weak table entry found, "
+              "slot %"PRIuLONGEST".\n", (ulongest_t)i);
+      } else {
+        if (table_slot(tables.exacttable, i) != 0) {
+          error("Weak table entry deleted, but corresponding "
+                "exact table entry not deleted, slot %"PRIuLONGEST".\n",
+                (ulongest_t)i);
+        }
+      }
+    }
+  }
+
+  (void)mps_commit(bogusap, p, 64);
+}
+
+
+/* setup -- set up pools for the test
+ *
+ * guff serves two purposes:
+ *  - a pseudo stack base for the stack root.
+ *  - pointer to a guff structure, which packages some values needed
+ *   (arena and thr mostly)
+ */
+
+struct guff_s {
+  mps_arena_t arena;
+  mps_thr_t thr;
+};
+
+ATTRIBUTE_NOINLINE
+static void setup(struct guff_s *guff)
+{
+  mps_arena_t arena;
+  mps_pool_t leafpool;
+  mps_pool_t tablepool;
+  mps_fmt_t dylanfmt;
+  mps_fmt_t dylanweakfmt;
+  mps_ap_t leafap, exactap, weakap, bogusap;
+  mps_root_t stack;
+  mps_thr_t thr;
+
+  arena = guff->arena;
+  thr = guff->thr;
+
+  die(mps_root_create_thread(&stack, arena, thr, guff),
+      "Root Create\n");
+  die(EnsureHeaderFormat(&dylanfmt, arena), "EnsureHeaderFormat");
+  die(EnsureHeaderWeakFormat(&dylanweakfmt, arena), "EnsureHeaderWeakFormat");
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, dylanfmt);
+    die(mps_pool_create_k(&leafpool, arena, mps_class_lo(), args),
+        "Leaf Pool Create\n");
+  } MPS_ARGS_END(args);
+  die(mps_pool_create(&tablepool, arena, mps_class_awl(), dylanweakfmt,
+                      dylan_weak_dependent),
+      "Table Pool Create\n");
+  die(mps_ap_create(&leafap, leafpool, mps_rank_exact()),
+      "Leaf AP Create\n");
+  die(mps_ap_create(&exactap, tablepool, mps_rank_exact()),
+      "Exact AP Create\n");
+  die(mps_ap_create(&weakap, tablepool, mps_rank_weak()),
+      "Weak AP Create\n");
+  die(mps_ap_create(&bogusap, tablepool, mps_rank_exact()),
+      "Bogus AP Create\n");
+
+  test(arena, leafap, exactap, weakap, bogusap);
+
+  mps_ap_destroy(bogusap);
+  mps_ap_destroy(weakap);
+  mps_ap_destroy(exactap);
+  mps_ap_destroy(leafap);
+  mps_pool_destroy(tablepool);
+  mps_pool_destroy(leafpool);
+  mps_fmt_destroy(dylanweakfmt);
+  mps_fmt_destroy(dylanfmt);
+  mps_root_destroy(stack);
+}
+
+
+int main(int argc, char *argv[])
+{
+  struct guff_s guff;
+  mps_arena_t arena;
+  mps_thr_t thread;
+
+  testlib_init(argc, argv);
+
+  initialise_wrapper(wrapper_wrapper);
+  initialise_wrapper(string_wrapper);
+  initialise_wrapper(table_wrapper);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "arena_create\n");
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  guff.arena = arena;
+  guff.thr = thread;
+  setup(&guff);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/awlutth.c

@@ -0,0 +1,355 @@
+/* awlutth.c: THREADING UNIT TEST USING POOL CLASS AWL
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * DESIGN
+ *
+ * .design: see <design/poolawl#.test>
+ */
+
+#include "mpscawl.h"
+#include "mpsclo.h"
+#include "mpsavm.h"
+#include "fmtdy.h"
+#include "testlib.h"
+#include "testthr.h"
+#include "mpslib.h"
+#include "mps.h"
+#include "mpstd.h"
+
+#include <stdio.h> /* printf, puts */
+#include <string.h> /* strlen */
+
+
+#define testArenaSIZE     ((size_t)64<<20)
+#define TABLE_SLOTS 50
+#define ITERATIONS 5000
+#define CHATTER 100
+/* The number that a half of all numbers generated from rnd are less
+ * than.  Hence, probability a-half, or P a-half */
+/* see <code/testlib.h> */
+#define P_A_HALF (1024uL*1024uL*1024uL - 1)     /* 2^30 - 1 */
+
+
+static mps_word_t bogus_class;
+
+#define UNINIT 0x041412ED
+
+#define DYLAN_ALIGN 4 /* depends on value defined in fmtdy.c */
+
+
+static mps_word_t wrapper_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* Extra word */
+  (mps_word_t)4<<2|2,                     /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8),    /* V (version 2) */
+  (mps_word_t)1<<2|1,                     /* VL */
+  1                             /* patterns */
+};
+
+
+static mps_word_t string_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  0,                            /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8)|(mps_word_t)3<<3|4,   /* V */
+  1                             /* VL */
+};
+
+static mps_word_t table_wrapper[] = {
+  UNINIT,                       /* wrapper */
+  UNINIT,                       /* class */
+  0,                            /* extra word */
+  (mps_word_t)1<<2|1,                     /* F */
+  (mps_word_t)2<<(MPS_WORD_WIDTH - 8)|2,  /* V */
+  1                             /* VL */
+};
+
+
+static void initialise_wrapper(mps_word_t *wrapper)
+{
+  wrapper[0] = (mps_word_t)&wrapper_wrapper;
+  wrapper[1] = (mps_word_t)&bogus_class;
+}
+
+
+/* create a dylan string object (byte vector) whose contents
+ * are the string s (including the terminating NUL)
+ * .assume.dylan-obj */
+static mps_word_t *alloc_string(const char *s, mps_ap_t ap)
+{
+  size_t l;
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+
+  l = strlen(s)+1;
+  /* number of words * sizeof word */
+  objsize = (2 + (l+sizeof(mps_word_t)-1)/sizeof(mps_word_t)) *
+            sizeof(mps_word_t);
+  objsize = (objsize + DYLAN_ALIGN-1)/DYLAN_ALIGN*DYLAN_ALIGN;
+  do {
+    size_t i;
+    char *s2;
+
+    die(mps_reserve(&p, ap, objsize), "Reserve Leaf\n");
+    object = p;
+    object[0] = (mps_word_t)string_wrapper;
+    object[1] = l << 2 | 1;
+    s2 = (char *)&object[2];
+    for(i = 0; i < l; ++i) {
+      s2[i] = s[i];
+    }
+  } while(!mps_commit(ap, p, objsize));
+  return object;
+}
+
+
+/* alloc_table -- create a table with n variable slots
+ *
+ * .assume.dylan-obj
+ */
+static mps_word_t *alloc_table(unsigned long n, mps_ap_t ap)
+{
+  size_t objsize;
+  void *p;
+  mps_word_t *object;
+  objsize = (3 + n) * sizeof(mps_word_t);
+  objsize = (objsize + MPS_PF_ALIGN-1)/MPS_PF_ALIGN*MPS_PF_ALIGN;
+  do {
+    unsigned long i;
+
+    die(mps_reserve(&p, ap, objsize), "Reserve Table\n");
+    object = p;
+    object[0] = (mps_word_t)table_wrapper;
+    object[1] = 0;
+    object[2] = n << 2 | 1;
+    for(i = 0; i < n; ++i) {
+      object[3+i] = 0;
+    }
+  } while(!mps_commit(ap, p, objsize));
+  return object;
+}
+
+
+/* gets the nth slot from a table
+ * .assume.dylan-obj
+ */
+static mps_word_t *table_slot(mps_word_t *table, unsigned long n)
+{
+  return (mps_word_t *)table[3+n];
+}
+
+/* sets the nth slot in a table
+ * .assume.dylan-obj
+ */
+static void set_table_slot(mps_word_t *table,
+                           unsigned long n, mps_word_t *p)
+{
+  cdie(table[0] == (mps_word_t)table_wrapper, "set_table_slot");
+  table[3+n] = (mps_word_t)p;
+}
+
+/* links two tables together via their link slot
+ * (1st fixed part slot)
+ */
+static void table_link(mps_word_t *t1, mps_word_t *t2)
+{
+  cdie(t1[0] == (mps_word_t)table_wrapper, "table_link 1");
+  cdie(t2[0] == (mps_word_t)table_wrapper, "table_link 2");
+  t1[1] = (mps_word_t)t2;
+  t2[1] = (mps_word_t)t1;
+}
+
+
+static void test(mps_ap_t leafap, mps_ap_t exactap, mps_ap_t weakap,
+                 mps_ap_t bogusap)
+{
+  mps_word_t *weaktable;
+  mps_word_t *exacttable;
+  mps_word_t *preserve[TABLE_SLOTS];    /* preserves objects in the weak */
+                                        /* table by referring to them */
+  unsigned long i, j;
+  void *p;
+
+  exacttable = alloc_table(TABLE_SLOTS, exactap);
+  weaktable = alloc_table(TABLE_SLOTS, weakap);
+  table_link(exacttable, weaktable);
+
+  /* Leave bogusap between reserve and commit for the duration */
+  die(mps_reserve(&p, bogusap, 64), "Reserve bogus");
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    mps_word_t *string;
+    if(rnd() < P_A_HALF) {
+      string = alloc_string("iamalive", leafap);
+      preserve[i] = string;
+    } else {
+      string = alloc_string("iamdead", leafap);
+      preserve[i] = 0;
+    }
+    set_table_slot(weaktable, i, string);
+    string = alloc_string("iamexact", leafap);
+    set_table_slot(exacttable, i, string);
+  }
+
+  for(j = 0; j < ITERATIONS; ++j) {
+    for(i = 0; i < TABLE_SLOTS; ++i) {
+      mps_word_t *string;
+
+      string = alloc_string("spong", leafap);
+      UNUSED(string);
+    }
+  }
+
+  for(i = 0; i < TABLE_SLOTS; ++i) {
+    if(preserve[i] == 0) {
+      if(table_slot(weaktable, i)) {
+        fprintf(stdout,
+                "Strongly unreachable weak table entry found, "
+                "slot %lu.\n",
+                i);
+      } else {
+        if(table_slot(exacttable, i) != 0) {
+          fprintf(stdout,
+                  "Weak table entry deleted, but corresponding "
+                  "exact table entry not deleted, slot %lu.\n",
+                  i);
+        }
+      }
+    }
+  }
+
+  (void)mps_commit(bogusap, p, 64);
+  puts("A okay\n");
+}
+
+
+struct guff_s {
+  mps_arena_t arena;
+  mps_thr_t thr;
+};
+
+/* guff serves two purposes:
+ * A pseudo stack base for the stack root.
+ * Pointer to a guff structure, which packages some values needed
+ * (arena and thr mostly) */
+ATTRIBUTE_NOINLINE
+static void setup(struct guff_s *guff)
+{
+  mps_arena_t arena;
+  mps_pool_t leafpool;
+  mps_pool_t tablepool;
+  mps_fmt_t dylanfmt;
+  mps_fmt_t dylanweakfmt;
+  mps_ap_t leafap, exactap, weakap, bogusap;
+  mps_root_t stack;
+  mps_thr_t thr;
+
+  arena = guff->arena;
+  thr = guff->thr;
+
+  die(mps_root_create_thread(&stack, arena, thr, guff),
+      "Root Create\n");
+  die(mps_fmt_create_A(&dylanfmt, arena, dylan_fmt_A()),
+      "Format Create\n");
+  die(mps_fmt_create_A(&dylanweakfmt, arena, dylan_fmt_A_weak()),
+      "Format Create (weak)\n");
+  die(mps_pool_create(&leafpool, arena, mps_class_lo(), dylanfmt),
+      "Leaf Pool Create\n");
+  die(mps_pool_create(&tablepool, arena, mps_class_awl(), dylanweakfmt,
+                      dylan_weak_dependent),
+      "Table Pool Create\n");
+  die(mps_ap_create(&leafap, leafpool, mps_rank_exact()),
+      "Leaf AP Create\n");
+  die(mps_ap_create(&exactap, tablepool, mps_rank_exact()),
+      "Exact AP Create\n");
+  die(mps_ap_create(&weakap, tablepool, mps_rank_weak()),
+      "Weak AP Create\n");
+  die(mps_ap_create(&bogusap, tablepool, mps_rank_exact()),
+      "Bogus AP Create\n");
+
+  test(leafap, exactap, weakap, bogusap);
+
+  mps_ap_destroy(bogusap);
+  mps_ap_destroy(weakap);
+  mps_ap_destroy(exactap);
+  mps_ap_destroy(leafap);
+  mps_pool_destroy(tablepool);
+  mps_pool_destroy(leafpool);
+  mps_fmt_destroy(dylanweakfmt);
+  mps_fmt_destroy(dylanfmt);
+  mps_root_destroy(stack);
+}
+
+
+static void *setup_thr(void *v)
+{
+  struct guff_s guff;
+  mps_arena_t arena = v;
+  mps_thr_t thread;
+
+  die(mps_thread_reg(&thread, arena), "thread_reg");
+  guff.arena = arena;
+  guff.thr = thread;
+  setup(&guff);
+  mps_thread_dereg(thread);
+
+  return NULL;
+}
+
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  testthr_t thread1;
+
+  testlib_init(argc, argv);
+
+  initialise_wrapper(wrapper_wrapper);
+  initialise_wrapper(string_wrapper);
+  initialise_wrapper(table_wrapper);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "arena_create\n");
+  testthr_create(&thread1, setup_thr, arena);
+  setup_thr(arena);
+  testthr_join(&thread1, NULL);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/boot.c

@@ -0,0 +1,155 @@
+/* boot.c: BOOTSTRAP ALLOCATOR
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .overview: A structure and protocols for allocating memory from a
+ * given block.  Very simple, it basically just increments a pointer.
+ *
+ * .boot.c: The Bootstrap Allocator is used to allocate C structures
+ * for use in the implementation, not client objects.  Therefore,
+ * we use "C types" (void *, size_t) not "client types" (Addr, Size).
+ */
+
+#include "boot.h"
+#include "mpm.h"
+
+SRCID(boot, "$Id$");
+
+
+#define BootBlockSig ((Sig)0x519B002B) /* SIGnature BOOT Block */
+
+
+/* BootBlockCheck -- check a BootBlock structure */
+
+Bool BootBlockCheck(BootBlock boot)
+{
+  CHECKS(BootBlock, boot);
+  CHECKL(boot->base != NULL);
+  CHECKL(boot->alloc != NULL);
+  CHECKL(boot->limit != NULL);
+  CHECKL(boot->base <= boot->alloc);
+  CHECKL(boot->alloc <= boot->limit);
+  CHECKL(boot->base < boot->limit);
+
+  return TRUE;
+}
+
+
+/* BootBlockInit -- initialize a BootBlock
+ *
+ * boot: a pointer to the structure to be initialized
+ *   (must have been allocated by the caller, probably on the stack).
+ * base: a pointer to the base of the memory to be allocated from
+ *   from (the memory need not be committed)
+ * limit: a pointer to the limit of the memory to be allocated from
+ */
+
+Res BootBlockInit(BootBlockStruct *boot, void *base, void *limit)
+{
+  /* Can't check boot as we are supposed to be initializing it */
+  AVER(boot != NULL);
+  AVER(base != NULL);
+  AVER(limit != NULL);
+  AVER(base < limit);
+
+  boot->base = base;
+  boot->alloc = base;
+  boot->limit = limit;
+  boot->sig = BootBlockSig;
+
+  AVERT(BootBlock, boot);
+  return ResOK;
+}
+
+
+/* BootBlockFinish -- finish a BootBlock structure */
+
+void BootBlockFinish(BootBlock boot)
+{
+  AVERT(BootBlock, boot);
+
+  boot->base = boot->alloc = boot->limit = NULL;
+  boot->sig = SigInvalid;
+}
+
+
+/* BootAllocated
+ *
+ * Returns the total amount allocated using this descriptor
+ */
+size_t BootAllocated(BootBlock boot)
+{
+  AVERT(BootBlock, boot);
+
+  return PointerOffset(boot->base, boot->alloc);
+}
+
+
+/* BootAlloc -- allocate from BootBlock structure
+ *
+ * preturn: The returned pointer, see .boot.c.
+ * boot: must have been initialized with BootBlockInit().
+ * size: size of requested object, see .boot.c.
+ * align: required alignment of object, see .boot.c.
+ */
+
+Res BootAlloc(void **pReturn, BootBlock boot, size_t size, size_t align)
+{
+  void *blockBase, *blockLimit;  /* base, limit of candidate block */
+
+  AVER(pReturn != NULL);
+  AVERT(BootBlock, boot);
+  AVER(size > 0);
+  AVERT(Align, (Align)align);
+
+  /* Align alloc pointer up and bounds check. */
+  blockBase = PointerAlignUp(boot->alloc, align);
+  if(boot->limit <= blockBase || blockBase < boot->alloc) {
+    return ResMEMORY;
+  }
+  blockLimit = PointerAdd(blockBase, size);
+  /* Following checks that the ordering constraint holds: */
+  /* boot->alloc <= blockBase < blockLimit <= boot->limit */
+  /* (if it doesn't hold then something overallocated/wrapped round) */
+  if(blockBase < boot->alloc ||
+     blockLimit <= blockBase ||
+     boot->limit < blockLimit) {
+    return ResMEMORY;
+  }
+
+  /* Fits!  So allocate it */
+  boot->alloc = blockLimit;
+  *pReturn = blockBase;
+  return ResOK;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/boot.h

@@ -0,0 +1,64 @@
+/* boot.h: BOOTSTRAP ALLOCATOR INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .overview:  A protocol for allocating memory from a given block.
+ */
+
+#ifndef boot_h
+#define boot_h
+
+#include "mpmtypes.h"
+
+
+/* BootBlockStruct -- descriptor of the block to allocate from */
+
+typedef struct BootBlockStruct
+{
+  Sig sig;      /* design.mps.sig.field */
+  void *base;
+  void *alloc;
+  void *limit;
+} BootBlockStruct;
+
+
+extern Res BootBlockInit(BootBlockStruct *boot, void *base, void *limit);
+extern void BootBlockFinish(BootBlock boot);
+extern Res BootAlloc(void **pReturn, BootBlock boot, size_t size,
+                     size_t align);
+extern size_t BootAllocated(BootBlock boot);
+extern Bool BootBlockCheck(BootBlock boot);
+
+
+#endif /* boot_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/bt.h

@@ -0,0 +1,105 @@
+/* bt.h: Bit Table Interface
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/bt>
+ */
+
+#ifndef bt_h
+#define bt_h
+
+#include "mpmtypes.h"
+
+
+/* <design/bt#if.size> */
+extern Size (BTSize)(Count length);
+#define BTSize(n) (((n) + MPS_WORD_WIDTH-1) / MPS_WORD_WIDTH * sizeof(Word))
+
+/* <design/bt#.if.get> */
+extern Bool (BTGet)(BT bt, Index index);
+#define BTGet(a, i) \
+  ((Bool)(((a)[((i) >> MPS_WORD_SHIFT)] \
+           >> ((i) & ~((Word)-1 << MPS_WORD_SHIFT))) \
+          & (Word)1))
+
+/* <design/bt#.if.set> */
+extern void (BTSet)(BT bt, Index index);
+#define BTSet(a, i) \
+  BEGIN \
+    (a)[((i)>>MPS_WORD_SHIFT)] |= (Word)1<<((i)&~((Word)-1<<MPS_WORD_SHIFT)); \
+  END
+
+/* <design/bt#.if.res> */
+extern void (BTRes)(BT bt, Index index);
+#define BTRes(a, i) \
+  BEGIN \
+    (a)[((i)>>MPS_WORD_SHIFT)] &= \
+      ~((Word)1 << ((i) & ~((Word)-1<<MPS_WORD_SHIFT))); \
+  END
+
+
+extern Bool BTCheck(BT bt);
+extern Res BTCreate(BT *btReturn, Arena arena, Count length);
+extern void BTDestroy(BT bt, Arena arena, Count length);
+
+extern void BTSetRange(BT bt, Index base, Index limit);
+extern Bool BTIsSetRange(BT bt, Index base, Index limit);
+extern void BTResRange(BT bt, Index base, Index limit);
+extern Bool BTIsResRange(BT bt, Index base, Index limit);
+
+extern Bool BTFindShortResRange(Index *baseReturn, Index *limitReturn,
+                                BT bt, Index searchBase, Index searchLimit,
+                                Count length);
+extern Bool BTFindShortResRangeHigh(Index *baseReturn, Index *limitReturn,
+                                    BT bt, Index searchBase, Index searchLimit,
+                                    Count length);
+extern Bool BTFindLongResRange(Index *baseReturn, Index *limitReturn,
+                               BT bt, Index searchBase, Index searchLimit,
+                               Count length);
+extern Bool BTFindLongResRangeHigh(Index *baseReturn, Index *limitReturn,
+                                   BT bt, Index searchBase, Index searchLimit,
+                                   Count length);
+
+extern Bool BTRangesSame(BT BTx, BT BTy, Index base, Index limit);
+
+extern void BTCopyInvertRange(BT fromBT, BT toBT, Index base, Index limit);
+extern void BTCopyRange(BT fromBT, BT toBT, Index base, Index limit);
+extern void BTCopyOffsetRange(BT fromBT, BT toBT,
+                              Index fromBase, Index fromLimit,
+                              Index toBase, Index toLimit);
+
+extern Count BTCountResRange(BT bt, Index base, Index limit);
+
+
+#endif /* bt_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/btcv.c

@@ -0,0 +1,599 @@
+/* btss.c: BIT TABLE COVERAGE TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .readership: MPS developers
+ *
+ * .coverage: Direct coverage of BTFind*ResRange*, BTRangesSame,
+ * BTISResRange, BTIsSetRange, BTCopyRange, BTCopyOffsetRange.
+ * Reasonable coverage of BTCopyInvertRange, BTResRange,
+ * BTSetRange, BTRes, BTSet, BTCreate, BTDestroy.
+ */
+
+
+#include "mpm.h"
+#include "mpsavm.h"
+#include "mps.h"
+#include "testlib.h"
+#include "mpslib.h"
+
+#include <stdio.h> /* printf */
+
+SRCID(btcv, "$Id$");
+
+
+/* bt*Symmetric -- Symmetric operations on bit tables
+ *
+ * The operations take 2 bit tables, btlo & bthi.
+ * They perform the equivalent BT* operation on btlo, and
+ * a reflected operation on the bits of bthi from the opposite
+ * direction.
+ */
+
+#define btReflectIndex(btSize, i) (btSize - (i) - 1)
+#define btReflectLimit(btSize, i) (btSize - (i))
+
+
+static void btSetSymmetric(BT btlo, BT bthi, Count btSize, Index i)
+{
+  BTSet(btlo, i);
+  BTSet(bthi, btReflectIndex(btSize, i));
+}
+
+static void btResSymmetric(BT btlo, BT bthi, Count btSize, Index i)
+{
+  BTRes(btlo, i);
+  BTRes(bthi, btReflectIndex(btSize, i));
+}
+
+static void btSetRangeSymmetric(BT btlo, BT bthi, Count btSize,
+                                Index base, Index limit)
+{
+  BTSetRange(btlo, base, limit);
+  BTSetRange(bthi, btReflectLimit(btSize, limit), btReflectLimit(btSize, base));
+}
+
+static void btResRangeSymmetric(BT btlo, BT bthi, Count btSize,
+                                Index base, Index limit)
+{
+  BTResRange(btlo, base, limit);
+  BTResRange(bthi, btReflectLimit(btSize, limit), btReflectLimit(btSize, base));
+}
+
+
+typedef Bool (*BTFinderFn)(Index *foundBase_o, Index *foundLimit_o,
+                           BT bt, Index base, Index limit, Count length);
+
+
+/* btTestSingleRange -- Test expectations for calls to BTFind*ResRange*
+ *
+ */
+
+static void btTestSingleRange(BTFinderFn finder, BT bt,
+                              Index base, Index limit,
+                              Count length,
+                              Bool expect,
+                              Index expectBase, Index expectLimit)
+{
+   Bool found;
+   Index foundBase, foundLimit;
+
+   found = finder(&foundBase, &foundLimit, bt, base, limit, length);
+   cdie(found == expect, "FindResRange result");
+   if (expect) {
+     cdie(foundBase == expectBase, "FindResRange base");
+     cdie(foundLimit == expectLimit, "FindResRange limit");
+   }
+}
+
+
+/* btTestResRange -- Test expectations for calls to BTFindShortResRange
+ *
+ * Symmetrically call BTFindShortResRange / BTFindShortResRangeHigh
+ * and test the expected results
+ */
+
+static void btTestResRange(BT btlo, BT bthi, Count btSize,
+                           Index base, Index limit,
+                           Count length,
+                           Bool expect,
+                           Index expectBase, Index expectLimit)
+{
+  btTestSingleRange(BTFindShortResRange, btlo,
+                    base, limit,
+                    length, expect,
+                    expectBase, expectLimit);
+
+  btTestSingleRange(BTFindShortResRangeHigh, bthi,
+                    btReflectLimit(btSize, limit),
+                    btReflectLimit(btSize, base),
+                    length, expect,
+                    btReflectLimit(btSize, expectLimit),
+                    btReflectLimit(btSize, expectBase));
+}
+
+
+/* btTestLongResRange -- Test expectations for calls to BTFindLongResRange
+ *
+ * Symmetrically call BTFindLongResRange / BTFindLongResRangeHigh
+ * and test the expected results
+ */
+
+static void btTestLongResRange(BT btlo, BT bthi, Count btSize,
+                               Index base, Index limit,
+                               Count length,
+                               Bool expect,
+                               Index expectBase, Index expectLimit)
+{
+  btTestSingleRange(BTFindLongResRange, btlo,
+                    base, limit,
+                    length, expect,
+                    expectBase, expectLimit);
+
+  btTestSingleRange(BTFindLongResRangeHigh, bthi,
+                    btReflectLimit(btSize, limit),
+                    btReflectLimit(btSize, base),
+                    length, expect,
+                    btReflectLimit(btSize, expectLimit),
+                    btReflectLimit(btSize, expectBase));
+}
+
+
+/* btAllResTest -- tests with only a reset range
+ *
+ * Test finding reset ranges in an all-reset table.
+ */
+
+static void btAllResTest(BT btlo, BT bthi, Count btSize,
+                         Index base, Index limit,
+                         Count length)
+{
+  btResRangeSymmetric(btlo, bthi, btSize, 0, btSize);
+  btTestResRange(btlo, bthi, btSize, base, limit, length,
+                 TRUE, base, base + length);
+  btTestLongResRange(btlo, bthi, btSize, base, limit, length,
+                     TRUE, base, limit);
+}
+
+
+/* btNoResTest -- tests with no reset ranges
+ *
+ * Test finding reset ranges in an all-set search area of a table.
+ * Reset the area outside the search to ensure it doesn't get found
+ * by mistake.
+ */
+
+static void btNoResTest(BT btlo, BT bthi, Count btSize,
+                        Index base, Index limit,
+                        Count length)
+{
+  btResRangeSymmetric(btlo, bthi, btSize, 0, btSize);
+  btSetRangeSymmetric(btlo, bthi, btSize, base, limit);
+  btTestResRange(btlo, bthi, btSize, base, limit, length,
+                 FALSE, 0, 0);
+  btTestLongResRange(btlo, bthi, btSize, base, limit, length,
+                     FALSE, 0, 0);
+}
+
+
+/* btResAndFindTest -- Test finding ranges of given size
+ *
+ * Resets the range between resBase & resLimit, and then attempts
+ * to find it by searching in the range between base & limit.
+ * Expect to find the range if it's long enough,
+ */
+
+static void btResAndFindTest(BT btlo, BT bthi, Count btSize,
+                             Index base, Index limit,
+                             Index resBase, Index resLimit,
+                             Count length)
+{
+  btResRangeSymmetric(btlo, bthi, btSize, resBase, resLimit);
+  if ((resLimit - resBase) < length) {
+    btTestResRange(btlo, bthi, btSize, base, limit, length,
+                   FALSE, 0, 0);
+    btTestLongResRange(btlo, bthi, btSize, base, limit, length,
+                       FALSE, 0, 0);
+  } else {
+    btTestResRange(btlo, bthi, btSize, base, limit, length,
+                   TRUE, resBase, resBase + length);
+    btTestLongResRange(btlo, bthi, btSize, base, limit, length,
+                       TRUE, resBase, resLimit);
+  }
+}
+
+
+
+/* btSingleResTest -- tests with a single reset range
+ *
+ * Test finding single ranges of various sizes
+ */
+
+static void btSingleResTest(BT btlo, BT bthi, Count btSize,
+                            Index base, Index limit,
+                            Count length)
+{
+  Count resLen;
+  /* choose varying range lengths from too short to longer than needed */
+  for (resLen = length - 1; resLen <= length + 1; resLen++) {
+    if ((resLen > 0) && (resLen < (limit - base -2))) {
+      /* place the ranges both near the beginning & near the end */
+      /* of the search space */
+      Index resBase, resLimit;
+      for (resBase = base; resBase <= base +2; resBase++) {
+        btResRangeSymmetric(btlo, bthi, btSize, 0, btSize);
+        btSetRangeSymmetric(btlo, bthi, btSize, base, limit);
+        btResAndFindTest(btlo, bthi, btSize, base, limit,
+                         resBase, resBase + resLen, length);
+      }
+      for (resLimit = limit; resLimit >= limit -2; resLimit--) {
+        btResRangeSymmetric(btlo, bthi, btSize, 0, btSize);
+        btSetRangeSymmetric(btlo, bthi, btSize, base, limit);
+        btResAndFindTest(btlo, bthi, btSize, base, limit,
+                         resLimit - resLen, resLimit, length);
+      }
+    }
+  }
+}
+
+
+
+/* btDoubleResTest -- Test finding double ranges of various sizes
+ *
+ * Set up 2 ranges with various relative positions. The first
+ * range is always too small.
+ */
+
+
+/* Constants describing the type of arrangement of the 2 ranges */
+enum {
+  ArrangeGAP1 = 0,
+  ArrangeGAP2 = 1,
+  ArrangeSPREAD = 2,
+  ArrangeMAX
+};
+
+typedef unsigned Arrangement;
+
+/* Choose a limit for reset range 1 */
+static Index btArrangeRes1(Arrangement arrange,
+                           Index base, Index res2Base,
+                           Count length)
+{
+  switch (arrange) {
+
+  case ArrangeGAP1: {
+      /* Gap between ranges is of length 1 */
+      return res2Base - 1;
+    }
+
+  case ArrangeGAP2: {
+      /* Gap between ranges is of length 2 */
+      return res2Base - 2;
+    }
+
+  case ArrangeSPREAD: {
+      /* range 1 starts as far before range 2 as possible */
+      return base + length;
+    }
+
+  default:
+    NOTREACHED;
+    return 0; /* keep the compiler happy */
+  }
+}
+
+/* Constants describing the type of pattern for the first range */
+enum {
+  PatternLEN1 = 0,
+  PatternSETMID = 1,
+  PatternJUSTSMALL = 2,
+  PatternMAX
+};
+
+typedef unsigned Pattern;
+
+/* Choose a limit for reset range 1 */
+static void btResetFirstRange(BT btlo, BT bthi, Count btSize,
+                              Index res1Limit,
+                              Count length,
+                              Pattern pattern)
+{
+  switch (pattern) {
+
+  case PatternLEN1: {
+      /* First range is a single reset bit */
+      btResSymmetric(btlo, bthi, btSize, res1Limit-1);
+      return;
+    }
+
+  case PatternSETMID: {
+      /* Actually make 2 ranges here by setting a bit in the middle */
+      Index mid = res1Limit - length + (length / 2);
+      btResRangeSymmetric(btlo, bthi, btSize, res1Limit-length, res1Limit);
+      btSetSymmetric(btlo, bthi, btSize, mid);
+      return;
+    }
+
+  case PatternJUSTSMALL: {
+      /* Range of (length - 1) */
+      btResRangeSymmetric(btlo, bthi, btSize,
+                          1 + res1Limit - length, res1Limit);
+      return;
+    }
+
+  default:
+    NOTREACHED;
+  }
+}
+
+
+static void btDoubleResTest(BT btlo, BT bthi, Count btSize,
+                            Index base, Index limit,
+                            Count length)
+{
+  Count res2Len;
+
+  if (length < 2)
+    return; /* no possibility of making the first range too small */
+
+  /* choose varying range lengths for second res range */
+  for (res2Len = length - 1; res2Len <= length + 1; res2Len++) {
+    if ((res2Len > 0) && (res2Len < (limit - base -2))) {
+      Index res2Limit;
+      /* place the second ranges near the end of the search space */
+      for (res2Limit = limit; res2Limit >= limit-8; res2Limit--) {
+        Index res2Base = res2Limit - res2Len;
+        Arrangement arrange;
+        /* Pick one of a number of possible arrangements of the ranges */
+        for (arrange = ArrangeGAP1; arrange < ArrangeMAX; arrange++) {
+          Index res1Limit = btArrangeRes1(arrange, base, res2Base, length);
+          Pattern pat;
+          /* Pick one of a number of pattern types for range 1 */
+          for (pat = PatternLEN1; pat < PatternMAX; pat++) {
+            btResRangeSymmetric(btlo, bthi, btSize, 0, btSize);
+            btSetRangeSymmetric(btlo, bthi, btSize, base, limit);
+            btResetFirstRange(btlo, bthi, btSize, res1Limit, length, pat);
+            /* Set up range 2 and expect to find it when searching */
+            btResAndFindTest(btlo, bthi, btSize, base, limit,
+                             res2Base, res2Limit, length);
+          }
+        }
+      }
+    }
+  }
+}
+
+
+/* btFindRangeTests -- Test BTFind*ResRange*
+ *
+ * Run a variety of FindResRange tests with different table patterns.
+ */
+
+static void btFindRangeTests(BT btlo, BT bthi, Count btSize,
+                             Index base, Index limit,
+                             Count length)
+{
+  btAllResTest(btlo, bthi, btSize, base, limit, length);
+  btNoResTest(btlo, bthi, btSize, base, limit, length);
+  btSingleResTest(btlo, bthi, btSize, base, limit, length);
+  btDoubleResTest(btlo, bthi, btSize, base, limit, length);
+}
+
+
+
+/* btIsRangeTests -- Test BTIsResRange & BTIsSetRange
+ *
+ * Test ranges which are all reset or set apart from single
+ * bits near to the base and limit (both inside and outside
+ * the range).
+ *
+ * Test BTRangesSame by using the same bit patterns and comparing
+ * with an appropriate all-set or all-reset table.
+ *
+ * These tests also test BTCopyInvertRange
+ */
+
+static void btIsRangeTests(BT bt1, BT bt2, Count btSize,
+                           Index base, Index limit)
+{
+  Index minBase, maxLimit, b, l;
+
+  if (base > 0) {
+    minBase = base - 1;
+  } else {
+    minBase = 0;
+  }
+
+  if (limit < btSize) {
+    maxLimit = limit + 1;
+  } else {
+    maxLimit = btSize;
+  }
+
+  for (b = minBase; b <= base+1; b++) {
+    for (l = maxLimit; l >= limit-1; l--) {
+      /* test a table which is all reset apart from a set bit */
+      /* near each of the base and limit of the range in question */
+      Bool outside; /* true if set bits are both outside test range */
+
+      outside = (b < base) && (l > limit);
+      BTResRange(bt1, 0, btSize);
+      BTSet(bt1, b);
+      BTSet(bt1, l - 1);
+
+      /* invert the table for the inverse test */
+      BTCopyInvertRange(bt1, bt2, 0, btSize);
+
+      /* Check it with BTIsResRange, and the inverse with BTIsSetRange */
+      cdie(BTIsResRange(bt1, base, limit) == outside, "BTISResRange");
+      cdie(BTIsSetRange(bt2, base, limit) == outside, "BTISSetRange");
+
+      /* Check the same range with BTRangesSame on an empty table */
+      BTResRange(bt2, 0, btSize);
+      cdie(BTRangesSame(bt1, bt2, base, limit) == outside, "BTRangeSame");
+
+      /* Check the inverse with BTRangesSame on a full table */
+      BTCopyInvertRange(bt1, bt2, 0, btSize);
+      BTSetRange(bt1, 0, btSize);
+      cdie(BTRangesSame(bt1, bt2, base, limit) == outside, "BTRangeSame");
+    }
+  }
+}
+
+
+/* btCopyTests -- Test BTCopyRange & BTCopyOffsetRange
+ *
+ * Test copying ranges which are all reset or set apart from
+ * single bits near to the base and limit (both inside and outside
+ * the range).
+ *
+ */
+
+static void btCopyTests(BT bt1, BT bt2, Count btSize,
+                        Index base, Index limit)
+{
+  Index minBase, maxLimit, b, l;
+
+  if (base > 0) {
+    minBase = base - 1;
+  } else {
+    minBase = 0;
+  }
+
+  if (limit < btSize) {
+    maxLimit = limit + 1;
+  } else {
+    maxLimit = btSize;
+  }
+
+  for (b = minBase; b <= base+1; b++) {
+    for (l = maxLimit; l >= limit-1; l--) {
+      /* initialize a table which is all reset apart from a set bit */
+      /* near each of the base and limit of the range in question */
+      Bool outside; /* true if set bits are both outside test range */
+
+      outside = (b < base) && (l > limit);
+      BTResRange(bt1, 0, btSize);
+      BTSet(bt1, b);
+      BTSet(bt1, l - 1);
+
+      /* check copying the region to the bottom of the other table */
+      BTCopyOffsetRange(bt1, bt2, base, limit, 0, limit - base);
+      cdie(BTIsResRange(bt2, 0, limit - base) == outside, "BTIsResRange");
+
+      /* check copying the region to the top of the other table */
+      BTCopyOffsetRange(bt1, bt2,
+                        base, limit, btSize + base - limit, btSize);
+      cdie(BTIsResRange(bt2, btSize + base - limit, btSize) == outside,
+           "BTIsResRange");
+
+      /* check copying the region to the same place in the other table */
+      BTCopyOffsetRange(bt1, bt2, base, limit, base, limit);
+      cdie(BTIsResRange(bt2, base, limit) == outside, "BTIsResRange");
+
+      /* copy the range and check its the same */
+      BTCopyRange(bt1, bt2, base, limit);
+      cdie(BTRangesSame(bt1, bt2, base, limit), "BTRangeSame");
+
+      /* invert the table, then copy it and check it again */
+      BTCopyInvertRange(bt2, bt1, 0, btSize);
+      BTCopyRange(bt1, bt2, base, limit);
+      cdie(BTRangesSame(bt1, bt2, base, limit), "BTRangeSame");
+    }
+  }
+}
+
+
+
+/* btTests --  Do all the tests
+ */
+
+static void btTests(BT btlo, BT bthi, Count btSize)
+{
+  Index base, limit;
+
+  /* Perform lots of tests over different subranges */
+  for (base = 0; base < MPS_WORD_WIDTH; base++) {
+    for (limit = btSize; limit > (btSize-MPS_WORD_WIDTH); limit--) {
+      /* Perform Is*Range tests over those subranges */
+      btIsRangeTests(btlo, bthi, btSize, base, limit);
+
+      /* Perform Copy*Range tests over those subranges */
+      btCopyTests(btlo, bthi, btSize, base, limit);
+
+      /* Perform FindResRange tests with different lengths */
+      btFindRangeTests(btlo, bthi, btSize, base, limit, 1);
+      btFindRangeTests(btlo, bthi, btSize, base, limit, 2);
+      btFindRangeTests(btlo, bthi, btSize, base, limit, MPS_WORD_WIDTH - 1);
+      btFindRangeTests(btlo, bthi, btSize, base, limit, MPS_WORD_WIDTH);
+      btFindRangeTests(btlo, bthi, btSize, base, limit, MPS_WORD_WIDTH + 1);
+      btFindRangeTests(btlo, bthi, btSize, base, limit, limit - base -1);
+      btFindRangeTests(btlo, bthi, btSize, base, limit, limit - base);
+    }
+  }
+}
+
+
+/* Start the world */
+
+#define testArenaSIZE (((size_t)64)<<20)
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t mpsArena;
+  Arena arena; /* the ANSI arena which we use to allocate the BT */
+  BT btlo, bthi;
+  Count btSize;
+
+  /* tests need 4 whole words plus a few extra bits */
+  btSize = MPS_WORD_WIDTH * 4 + 10;
+
+  testlib_init(argc, argv);
+
+  die(mps_arena_create(&mpsArena, mps_arena_class_vm(), testArenaSIZE),
+      "mps_arena_create");
+  arena = (Arena)mpsArena; /* avoid pun */
+
+  die((mps_res_t)BTCreate(&btlo, arena, btSize),
+      "failed to create low bit table");
+
+  die((mps_res_t)BTCreate(&bthi, arena, btSize),
+      "failed to create high bit table");
+
+  btTests(btlo, bthi, btSize);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/bttest.c

@@ -0,0 +1,405 @@
+/* bttest.c: BIT TABLE TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+
+#include "mpm.h"
+#include "mps.h"
+#include "mpsavm.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include "mpstd.h"
+
+#include <stdio.h> /* fflush, fgets, printf, putchar, puts */
+#include <stdlib.h> /* exit, strtol */
+
+SRCID(bttest, "$Id$");
+
+
+static BT bt; /* the BT which we will use */
+static Size btSize; /* the size of the current BT */
+static Arena arena; /* the arena which we use to allocate the BT */
+
+
+#define MAX_ARGS 3
+
+
+static Word args[MAX_ARGS];
+static Count argCount;
+
+
+static Bool argInRange(Index arg)
+{
+  if (bt == NULL) {
+    printf("no BT\n");
+    return FALSE;
+  }
+  if (args[arg] >= btSize) {
+    printf("out of range\n");
+    return FALSE;
+  }
+  return TRUE;
+}
+
+
+static Bool checkDefaultRange(Index arg)
+{
+  if (bt == NULL) {
+    printf("no BT\n");
+    return FALSE;
+  }
+  if (argCount == arg+1) {
+    printf("range half-specified\n");
+    return FALSE;
+  }
+  if (argCount == arg) { /* use default range */
+    args[arg] = 0;
+    args[arg+1] = btSize;
+    return TRUE;
+  }
+  if (args[arg] >= args[arg+1]) {
+    printf("range ill-formed\n");
+    return FALSE;
+  }
+  if (args[arg+1] > btSize) {
+    printf("range too high\n");
+    return FALSE;
+  }
+  return TRUE; /* explicit valid range */
+}
+
+
+static void quit(void)
+{
+  exit(0);
+}
+
+
+static void destroy(void)
+{
+  if (bt != NULL) {
+    BTDestroy(bt, arena, btSize);
+    bt = NULL;
+  } else {
+    printf("No BT to destroy\n");
+  }
+}
+
+static void create(void)
+{
+  Res res;
+  if (args[0] < 1) {
+    printf("can't create a BT of size 0\n");
+    return;
+  }
+  if (bt != NULL)
+    destroy();
+  res = BTCreate(&bt, arena, args[0]);
+  if (res == ResOK) {
+    btSize = args[0];
+    BTResRange(bt, 0, btSize);
+  } else {
+    printf("BTCreate returned %d\n",res);
+  }
+}
+
+
+static void set(void)
+{
+  if (argInRange(0))
+    (BTSet)(bt, args[0]);
+}
+
+
+static void reset(void)
+{
+  if (argInRange(0))
+    (BTRes)(bt, args[0]);
+}
+
+
+static void get(void)
+{
+  if (argInRange(0)) {
+    Bool b = (BTGet)(bt, args[0]);
+    puts(b ? "TRUE" : "FALSE");
+  }
+}
+
+
+static void setRange(void)
+{
+  if (checkDefaultRange(0))
+    BTSetRange(bt, args[0], args[1]);
+}
+
+
+static void resetRange(void)
+{
+  if (checkDefaultRange(0))
+    BTResRange(bt, args[0], args[1]);
+}
+
+
+static void isSetRange(void)
+{
+  if (checkDefaultRange(0)) {
+    Bool b = BTIsSetRange(bt, args[0], args[1]);
+    puts(b ? "TRUE" : "FALSE");
+  }
+}
+
+
+static void isResRange(void)
+{
+  if (checkDefaultRange(0)) {
+    Bool b = BTIsResRange(bt, args[0], args[1]);
+    puts(b ? "TRUE" : "FALSE");
+  }
+}
+
+
+static void findShortResRange(void)
+{
+  if (checkDefaultRange(1)) {
+    if (args[0] > (args[2] - args[1])) {
+      printf("can't fit length in range\n");
+    } else {
+      Index base, limit;
+      Bool b = BTFindShortResRange(&base, &limit, bt,
+                                   args[1], args[2], args[0]);
+      if (b)
+        printf("%"PRIuLONGEST" - %"PRIuLONGEST"\n",
+               (ulongest_t)base, (ulongest_t)limit);
+      else
+        printf("FALSE\n");
+    }
+  }
+}
+
+
+static void findShortResRangeHigh(void)
+{
+  if (checkDefaultRange(1)) {
+    if (args[0] > (args[2] - args[1])) {
+      printf("can't fit length in range\n");
+    } else {
+      Index base, limit;
+      Bool b = BTFindShortResRangeHigh(&base, &limit, bt,
+                                       args[1], args[2], args[0]);
+      if (b)
+        printf("%"PRIuLONGEST" - %"PRIuLONGEST"\n",
+               (ulongest_t)base, (ulongest_t)limit);
+      else
+        printf("FALSE\n");
+    }
+  }
+}
+
+static void findLongResRange(void)
+{
+  if (checkDefaultRange(1)) {
+    if (args[0] > (args[2] - args[1])) {
+      printf("can't fit length in range\n");
+    } else {
+      Index base, limit;
+      Bool b = BTFindLongResRange(&base, &limit, bt,
+                                  args[1], args[2], args[0]);
+      if (b)
+        printf("%"PRIuLONGEST" - %"PRIuLONGEST"\n",
+               (ulongest_t)base, (ulongest_t)limit);
+      else
+        printf("FALSE\n");
+    }
+  }
+}
+
+
+static void help(void)
+{
+  printf("c <s>             create a BT of size 's'\n"
+         "d                 destroy the current BT\n"
+         "s <i>             set the bit index 'i'\n"
+         "r <i>             reset the bit index 'i'\n"
+         "g <i>             get the bit index 'i'\n");
+  printf("sr [<i> <i>]      set the specified range\n"
+         "rr [<i> <i>]      reset the specified range\n"
+         "is [<i> <i>]      is the specified range set?\n"
+         "ir [<i> <i>]      is the specified range reset?\n");
+  printf("f <l> [<i> <i>]   find a reset range of length 'l'.\n"
+         "fh <l> [<i> <i>]  find a reset range length 'l', working downwards\n"
+         "fl <l> [<i> <i>]  find a reset range of length at least 'l'\n"
+         "q                 quit\n"
+         "?                 print this message\n");
+  printf("\n"
+         "No way of testing BTSize, BTRangesSame, or BTCopyInvertRange.\n");
+}
+
+
+static struct commandShapeStruct {
+  const char *name;
+  Count min_args;
+  Count max_args;
+  void (*fun)(void);
+} commandShapes[] = {
+  {"c", 1, 1, create},
+  {"d", 0, 0, destroy},
+  {"s", 1, 1, set},
+  {"r", 1, 1, reset},
+  {"g", 1, 1, get},
+  {"sr", 0, 2, setRange},
+  {"rr", 0, 2, resetRange},
+  {"is", 0, 2, isSetRange},
+  {"ir", 0, 2, isResRange},
+  {"f", 1, 3, findShortResRange},
+  {"fh", 1, 3, findShortResRangeHigh},
+  {"fl", 1, 3, findLongResRange},
+  {"?", 0, 0, help},
+  {"q", 0, 0, quit},
+  { NULL, 0, 0, NULL}
+};
+
+
+typedef struct commandShapeStruct *commandShape;
+
+
+static void obeyCommand(const char *command)
+{
+  commandShape shape = commandShapes;
+  while(shape->name != NULL) {
+    const char *csp = shape->name;
+    const char *p = command;
+    while (*csp == *p) {
+      csp++;
+      p++;
+    }
+    if ((*csp == 0) && ((*p == '\n') || (*p == ' '))) { /* complete match */
+      argCount = 0;
+      while ((*p == ' ') && (argCount < shape->max_args)) {
+        /* get an argument */
+        char *newP;
+        long l;
+        l = strtol(p, &newP, 0);
+        if(l < 0) { /* negative integer */
+          printf("negative integer arguments are invalid\n");
+          return;
+        }
+        args[argCount] = (unsigned long)l;
+        if (newP == p) { /* strtoul failed */
+          printf("couldn't parse an integer argument\n");
+          return;
+        }
+        p = newP;
+        ++ argCount;
+      }
+      if (argCount < shape->min_args) {
+        printf("insufficient arguments to command\n");
+      } else if (*p != '\n') {
+        printf("too many arguments to command\n");
+      } else { /* do the command */
+        shape->fun();
+      }
+      return;
+    } else {
+      ++ shape; /* try next command */
+    }
+  }
+  printf("command not understood\n");
+  help();
+}
+
+
+static void showBT(void)
+{
+  Index i;
+  char c;
+  if (bt == NULL)
+    return;
+  i = 0;
+  while((i < btSize) && (i < 50)) {
+    if (i % 10 == 0)
+      c = (char)(((i / 10) % 10) + '0');
+    else
+      c = ' ';
+    putchar(c);
+    ++ i;
+  }
+  putchar('\n');
+  i = 0;
+  while((i < btSize) && (i < 50)) {
+    c = (char)((i % 10) +'0');
+    putchar(c);
+    ++ i;
+  }
+  putchar('\n');
+  i = 0;
+  while(i < btSize) {
+    if (BTGet(bt,i))
+      c = 'O';
+    else
+      c = '.';
+    putchar(c);
+    ++ i;
+    if (i % 50 == 0)
+      putchar('\n');
+  }
+  putchar('\n');
+}
+
+
+#define testArenaSIZE (((size_t)64)<<20)
+
+int main(int argc, char *argv[])
+{
+  bt = NULL;
+  btSize = 0;
+
+  testlib_init(argc, argv);
+
+  die(mps_arena_create((mps_arena_t*)&arena, mps_arena_class_vm(),
+                       testArenaSIZE),
+      "mps_arena_create");
+  while(1) {
+    char input[100];
+    printf("bt test> ");
+    (void)fflush(stdout);
+    if (fgets(input, 100, stdin)) {
+      obeyCommand(input);
+      showBT();
+    } else {
+      return 0;
+    }
+  }
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/cbs.h

@@ -0,0 +1,85 @@
+/* cbs.h: CBS -- Coalescing Block Structure
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/cbs>.
+ */
+
+#ifndef cbs_h
+#define cbs_h
+
+#include "arg.h"
+#include "mpmtypes.h"
+#include "mpm.h"
+#include "mpmst.h"
+#include "rangetree.h"
+#include "splay.h"
+
+typedef struct CBSFastBlockStruct *CBSFastBlock;
+typedef struct CBSFastBlockStruct {
+  struct RangeTreeStruct rangeTreeStruct;
+  Size maxSize; /* accurate maximum block size of sub-tree */
+} CBSFastBlockStruct;
+
+typedef struct CBSZonedBlockStruct *CBSZonedBlock;
+typedef struct CBSZonedBlockStruct {
+  struct CBSFastBlockStruct cbsFastBlockStruct;
+  ZoneSet zones; /* union zone set of all ranges in sub-tree */
+} CBSZonedBlockStruct;
+
+typedef struct CBSStruct *CBS, *CBSFast, *CBSZoned;
+
+extern Bool CBSCheck(CBS cbs);
+
+
+/* CBSLand -- convert CBS to Land
+ *
+ * We would like to use MustBeA(Land, cbs) for this, but it produces
+ * bogus warnings about strict aliasing from GCC 4.7 (and probably
+ * 4.8).  We can abolish this macro when those are no longer in use in
+ * MPS development.
+ */
+
+#define CBSLand(cbs) (&(cbs)->landStruct)
+
+
+DECLARE_CLASS(Land, CBS, Land);
+DECLARE_CLASS(Land, CBSFast, CBS);
+DECLARE_CLASS(Land, CBSZoned, CBSFast);
+
+extern const struct mps_key_s _mps_key_cbs_block_pool;
+#define CBSBlockPool (&_mps_key_cbs_block_pool)
+#define CBSBlockPool_FIELD pool
+
+#endif /* cbs_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/check.h

@@ -0,0 +1,402 @@
+/* check.h: ASSERTION INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ *
+ * .aver: This header defines a family of AVER and NOTREACHED macros.
+ * These macros should be used to instrument and annotate code with
+ * invariants, and so provide both interface and internal consistency
+ * checks.
+ *
+ * .comment: Non-obvious AVER statements should always be accompanied by
+ * a comment.
+ *
+ * .disable: When assertions are disabled, AVER expands to something
+ * which contains the condition but discards the result. Compilers
+ * will throw the code away, but check its syntax.
+ *
+ * .trans.level-check: CheckLevel itself is not checked anywhere.
+ *
+ * .careful: BE CAREFUL when changing this file.  It is easy to make mistakes
+ * and change the checking level in a variety and thereby its performance
+ * without realising it.  This has happened before.  Eyeball the preprocessor
+ * output for each variety.  For example:
+ *
+ *   cc -E -DCONFIG_VAR_RASH trace.c
+ *   cc -E -DCONFIG_VAR_HOT trace.c
+ *   cc -E -DCONFIG_VAR_COOL trace.c
+ *
+ * Then look at TraceCheck to make sure checking is right, TraceAddWhite
+ * for general assertions, and TraceFix for the critical path assertions.
+ */
+
+#ifndef check_h
+#define check_h
+
+#include "config.h"
+#include "misc.h"
+#include "mpslib.h"
+#include "protocol.h"
+
+
+/* ASSERT -- basic assertion
+ *
+ * The ASSERT macro is equivalent to the ISO C assert() except that it is
+ * always defined, and uses the assertion handler from the MPS plinth, which
+ * can be replaced by the client code.
+ *
+ * It is not intended for direct use within the MPS.  Use AVER and CHECK
+ * macros, which can be controlled by both build and run-time configuration.
+ */
+
+#define ASSERT(cond, condstring) \
+  BEGIN \
+    if (LIKELY(cond)) NOOP; else \
+      mps_lib_assert_fail(MPS_FILE, __LINE__, (condstring)); \
+  END
+
+#define ASSERTP(cond, condstring, default_) \
+  ((void)(LIKELY(cond) \
+          || (mps_lib_assert_fail(MPS_FILE, __LINE__, (condstring)), FALSE)), \
+   (default_))
+
+#define ASSERT_ISTYPE(type, val) (type ## Check(val))
+#define ASSERT_TYPECHECK(type, val) \
+  ASSERT(ASSERT_ISTYPE(type, val), "TypeCheck " #type ": " #val)
+
+#define ASSERT_ISCLASS(klass, val) (klass ## Check(CouldBeA(klass, val)))
+#define ASSERT_CLASSCHECK(klass, val) \
+  ASSERT(ASSERT_ISCLASS(klass, val), "ClassCheck " #klass ": " #val)
+
+#define ASSERT_NULLCHECK(type, val) \
+  ASSERT((val) != NULL, "NullCheck " #type ": " #val)
+
+
+/* CheckLevel -- control for check method behaviour
+ *
+ * When the MPS is build with AVER_AND_CHECK_ALL (in a "cool" variety) the
+ * static variable CheckLevel controls the frequency and detail of
+ * consistency checking on structures.
+ *
+ * By default, CHECKLEVEL is defined to a static value in config.h, though
+ * it can be overridden on the compiler command line, e.g.
+ *   cc -DCHECKLEVEL=CheckLevelSHALLOW ...
+ *
+ * However, if CHECKLEVEL_DYNAMIC is defined we use a variable to control
+ * the level of checking.  The run-time overhead for this is quite high
+ * (observed double run-time on amcss when the variable is set to SHALLOW).
+ * CHECKLEVEL_DYNAMIC should be set to the initial level for the variable,
+ * which is in mpm.c.
+ *
+ * In general, it's better to adjust the check level by defining CHECKLEVEL
+ * but this is intended to meet the case where a run-time adjustable
+ * checking level is required -- where recompilation or relinking is
+ * undesirable or impossible.
+ *
+ * TODO: Should also allow the check level variable to come from an
+ * environment variable.
+ */
+
+enum {
+  CheckLevelMINIMAL = 0,  /* local sig check only */
+  CheckLevelSHALLOW = 1,  /* local invariants, */
+                          /* and adjacent (up, down) sig checks */
+  CheckLevelDEEP = 2      /* local invariants, */
+                          /* and adjacent up sig checks */
+                          /* and recursive down full type checks */
+};
+
+#ifdef CHECKLEVEL_DYNAMIC
+extern unsigned CheckLevel;
+#undef CHECKLEVEL
+#define CHECKLEVEL CheckLevel
+#endif
+
+
+/* AVER, AVERT, AVERC, AVERP -- MPM assertions
+ *
+ * AVER and friends are used to assert conditions in the code.
+ *
+ * AVER checks an expression.
+ *
+ * AVERT checks that a value is of the correct type and may perform
+ * consistency checks on the value by calling a check function.
+ *
+ * AVERC checks that a value is of the correct class (including
+ * subclasses) and may perform consistency checks on the value by
+ * calling a check function.
+ *
+ * AVERP checks an expression but is itself a void * expression, and
+ * so can be used in expression macros.
+ *
+ * AVER etc. are on by default, and check conditions even in "hot"
+ * varieties intended to work in production.  To avoid the cost of a
+ * check in critical parts of the code, use AVER_CRITICAL etc., but
+ * only when you've *proved* that this makes a difference to
+ * performance that affects requirements.
+ */
+
+#if defined(AVER_AND_CHECK_NONE)
+
+#define AVER(cond)                  DISCARD(cond)
+#define AVERT(type, val)            DISCARD(ASSERT_ISTYPE(type, val))
+#define AVERC(klass, val)           DISCARD(ASSERT_ISCLASS(klass, val))
+#define AVERP(cond, dflt)           (DISCARD_EXP(cond), dflt)
+#define AVERPC(cond, condstring, dflt) (DISCARD_EXP(cond), dflt)
+
+#else
+
+#define AVER(cond)                  ASSERT(cond, #cond)
+#define AVERT                       ASSERT_TYPECHECK
+#define AVERC                       ASSERT_CLASSCHECK
+#define AVERP(cond, dflt)           ASSERTP(cond, #cond, dflt)
+#define AVERPC                      ASSERTP
+
+#endif
+
+#if defined(AVER_AND_CHECK_ALL)
+
+#define AVER_CRITICAL(cond)         ASSERT(cond, #cond)
+#define AVERT_CRITICAL              ASSERT_TYPECHECK
+#define AVERC_CRITICAL              ASSERT_CLASSCHECK
+#define AVERP_CRITICAL(cond, dflt)  ASSERTP(cond, #cond, dflt)
+#define AVERPC_CRITICAL             ASSERTP
+
+#else
+
+#define AVER_CRITICAL               DISCARD
+#define AVERT_CRITICAL(type, val)   DISCARD(ASSERT_ISTYPE(type, val))
+#define AVERC_CRITICAL(klass, val)  DISCARD(ASSERT_ISCLASS(klass, val))
+#define AVERP_CRITICAL(cond, dflt)  (DISCARD_EXP(cond), dflt)
+#define AVERPC_CRITICAL(cond, condstring, dflt) (DISCARD_EXP(cond), dflt)
+
+#endif
+
+
+/* NOTREACHED -- control should never reach this statement
+ *
+ * This is a sort of AVER; it is equivalent to AVER(FALSE), but will produce
+ * a more informative message.
+ */
+
+#if defined(AVER_AND_CHECK_NONE)
+
+#define NOTREACHED NOOP
+
+#else
+
+#define NOTREACHED \
+  BEGIN \
+    mps_lib_assert_fail(__FILE__, __LINE__, "unreachable code"); \
+  END
+
+#endif
+
+
+/* TESTT -- check type simply
+ *
+ * Must be thread safe.  <design/interface-c#.thread-safety>
+ * and <design/interface-c#.check.space>.
+ */
+
+#define TESTT(type, val)       ((val) != NULL && (val)->sig == type ## Sig)
+
+
+/* TESTC -- check class simply
+ *
+ * TODO: Does this need to be thread safe like TESTT?
+ */
+
+#define TESTC(klass, val)       ((val) != NULL && IsA(klass, val))
+
+
+/* CHECKS, CHECKC -- Check Signature, Check Class
+ *
+ * (if CHECKLEVEL == CheckLevelMINIMAL, this is all we check)
+ */
+
+#if defined(AVER_AND_CHECK_NONE)
+#define CHECKS(type, val)       DISCARD(TESTT(type, val))
+#define CHECKC(klass, val)      DISCARD(MustBeA(klass, val))
+#else
+#define CHECKS(type, val) \
+  ASSERT(TESTT(type, val), "SigCheck " #type ": " #val)
+#define CHECKC(klass, val) \
+  ASSERT(TESTC(klass, val), "ClassCheck " #klass ": " #val)
+#endif
+
+
+/* CHECKL, CHECKD, CHECKU -- local, "down", and "up" checks
+ *
+ * Each type should have a function defined called <type>Check that checks
+ * the consistency of the type.  This function should return TRUE iff the
+ * value passes consistency checks.  In general, it should assert otherwise,
+ * but we allow for the possibility of returning FALSE in this case for
+ * configuration adaptability.
+ *
+ * For structure types, the check function should:
+ *
+ *  - check its own signature with CHECKS
+ *
+ *  - check fields that it "owns" with CHECKL, like asserts
+ *
+ *  - check "down" values which are its "children" with CHECKD
+ *
+ *  - check "up" values which are its "parents" with CHECKU.
+ *
+ * These various checks will be compiled out or compiled to be controlled
+ * by CHECKLEVEL.
+ *
+ * For example:
+ *
+ *     Bool MessageCheck(Message message)
+ *     {
+ *       CHECKS(Message, message);
+ *       CHECKU(Arena, message->arena);
+ *       CHECKD(MessageClass, message->class);
+ *       CHECKL(RingCheck(&message->queueRing));
+ *       CHECKL(MessageIsClocked(message) || (message->postedClock == 0));
+ *       return TRUE;
+ *     }
+ *
+ * The parent/child distinction depends on the structure, but in the MPS
+ * the Arena has no parents, and has children which are Pools, which have
+ * children which are Segments, etc.
+ *
+ * The important thing is to have a partial order on types so that recursive
+ * checking will terminate.  When CHECKLEVEL is set to DEEP, checking will
+ * recurse into check methods for children, but will only do a shallow
+ * signature check on parents, avoiding infinite regression.
+ */
+
+#if defined(AVER_AND_CHECK_ALL)
+
+#define CHECK_BY_LEVEL(minimal, shallow, deep) \
+  BEGIN \
+    switch (CHECKLEVEL) { \
+    case CheckLevelDEEP: deep; break; \
+    case CheckLevelSHALLOW: shallow; break; \
+    default: NOTREACHED; /* fall through */ \
+    case CheckLevelMINIMAL: minimal; break; \
+    } \
+  END
+
+#define CHECKL(cond) \
+  CHECK_BY_LEVEL(NOOP, \
+                 ASSERT(cond, #cond), \
+                 ASSERT(cond, #cond))
+
+#define CHECKD(type, val) \
+  CHECK_BY_LEVEL(NOOP, \
+                 CHECKS(type, val), \
+                 ASSERT_TYPECHECK(type, val))
+
+#define CHECKD_NOSIG(type, val) \
+  CHECK_BY_LEVEL(NOOP, \
+                 ASSERT_NULLCHECK(type, val), \
+                 ASSERT_TYPECHECK(type, val))
+
+#define CHECKD_CLASS(klass, val) \
+  CHECK_BY_LEVEL(NOOP, \
+                 CHECKC(klass, val) \
+                 ASSERT_CLASSCHECK(klass, val))
+
+#define CHECKU(type, val) \
+  CHECK_BY_LEVEL(NOOP, \
+                 CHECKS(type, val), \
+                 CHECKS(type, val))
+
+#define CHECKU_NOSIG(type, val) \
+  CHECK_BY_LEVEL(NOOP, \
+                 ASSERT_NULLCHECK(type, val), \
+                 ASSERT_NULLCHECK(type, val))
+
+#else /* AVER_AND_CHECK_ALL, not */
+
+/* TODO: This gives comparable performance to RASH when compiling
+   using mps.c and -O2 (to get check methods inlined), but is it a bit
+   too minimal?  How much do we rely on check methods? */
+
+#define CHECKL(cond)             DISCARD(cond)
+#define CHECKD(type, val)        DISCARD(TESTT(type, val))
+#define CHECKD_NOSIG(type, val)  DISCARD((val) != NULL)
+#define CHECKD_CLASS(klass, val) DISCARD((val) != NULL)
+#define CHECKU(type, val)        DISCARD(TESTT(type, val))
+#define CHECKU_NOSIG(type, val)  DISCARD((val) != NULL)
+
+#endif /* AVER_AND_CHECK_ALL */
+
+
+/* COMPAT* -- type compatibility checking
+ *
+ * .check.macros: The COMPAT* macros use some C trickery to attempt to
+ * verify that certain types and fields are equivalent. They do not do
+ * a complete job. This trickery is justified by the security gained
+ * in knowing that <code/mps.h> matches the MPM. See
+ * <design/interface-c#.check.types>. [This paragraph is intended to
+ * satisfy rule.impl.trick.]
+ */
+
+/* compile-time check */
+#define COMPATLVALUE(lv1, lv2) \
+  ((void)sizeof((lv1) = (lv2)), (void)sizeof((lv2) = (lv1)), TRUE)
+
+/* aims to test whether t1 and t2 are assignment-compatible */
+#define COMPATTYPE(t1, t2) \
+  (sizeof(t1) == sizeof(t2) && \
+   COMPATLVALUE(*((t1 *)0), *((t2 *)0)))
+
+#define COMPATFIELDAPPROX(s1, f1, s2, f2) \
+  (sizeof(((s1 *)0)->f1) == sizeof(((s2 *)0)->f2) && \
+   offsetof(s1, f1) == offsetof(s2, f2))
+
+#define COMPATFIELD(s1, f1, s2, f2) \
+  (COMPATFIELDAPPROX(s1, f1, s2, f2) && \
+   COMPATLVALUE(((s1 *)0)->f1, ((s2 *)0)->f2))
+
+
+/* NONNEGATIVE -- test that value is greater than or equal to zero
+ *
+ * We'd like to write "x >= 0" but when x belongs to an unsigned
+ * integral type then this results in a "comparison of unsigned
+ * expression >= 0 is always true" warning from GCC if -Wextra is
+ * specified. We also don't want to remove these assertions because
+ * they protect us against errors if the type of x should ever be
+ * changed to a signed type on some platform.
+ *
+ * Note that this macro evaluates its argument twice.
+ */
+#define NONNEGATIVE(x) ((x) == 0 || (x) > 0)
+
+#endif /* check_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/clock.h

@@ -0,0 +1,208 @@
+/* clock.h -- Fast clocks and timers
+ *
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * $Id$
+ *
+ * .design: <design/clock>.
+ */
+
+#ifndef clock_h
+#define clock_h
+
+#include "mpmtypes.h" /* for Word */
+
+
+/* EVENT_CLOCK -- fast event timestamp clock
+ *
+ * On platforms that support it, we want to stamp events with a very cheap
+ * and fast high-resolution timer.
+ */
+
+/* Microsoft C provides an intrinsic for the Intel rdtsc instruction.
+ * <https://docs.microsoft.com/en-us/cpp/intrinsics/rdtsc>
+ */
+#if (defined(MPS_ARCH_I3) || defined(MPS_ARCH_I6)) && defined(MPS_BUILD_MV)
+
+typedef unsigned __int64 EventClock;
+
+typedef union EventClockUnion {
+  struct {
+    unsigned low, high;
+  } half;
+  unsigned __int64 whole;
+} EventClockUnion;
+
+#define EVENT_CLOCK_MAKE(lvalue, low, high) \
+  BEGIN \
+  ((EventClockUnion*)&(lvalue))->half.low = (low); \
+  ((EventClockUnion*)&(lvalue))->half.high = (high); \
+  END
+
+#if _MSC_VER >= 1400
+
+#pragma intrinsic(__rdtsc)
+
+#define EVENT_CLOCK(lvalue) \
+  BEGIN \
+    (lvalue) = __rdtsc(); \
+  END
+
+#else /* _MSC_VER < 1400 */
+
+/* This is mostly a patch for Open Dylan's bootstrap on Windows, which is
+   using Microsoft Visual Studio 6 because of support for CodeView debugging
+   information. */
+
+#include "mpswin.h" /* KILL IT WITH FIRE! */
+
+#define EVENT_CLOCK(lvalue) \
+  BEGIN \
+    LARGE_INTEGER _count; \
+    QueryPerformanceCounter(&_count); \
+    (lvalue) = _count.QuadPart; \
+  END
+
+#endif /* _MSC_VER < 1400 */
+
+#if defined(MPS_ARCH_I3)
+
+/* We can't use a shift to get the top half of the 64-bit event clock,
+   because that introduces a dependency on `__aullshr` in the C run-time. */
+
+#define EVENT_CLOCK_PRINT(stream, clock) \
+  fprintf(stream, "%08lX%08lX", \
+          (*(EventClockUnion *)&(clock)).half.high, \
+          (*(EventClockUnion *)&(clock)).half.low)
+
+#define EVENT_CLOCK_WRITE(stream, depth, clock)  \
+  WriteF(stream, depth, "$W$W", \
+         (*(EventClockUnion *)&(clock)).half.high, \
+         (*(EventClockUnion *)&(clock)).half.low, \
+         NULL)
+
+#elif defined(MPS_ARCH_I6)
+
+#if defined(MPS_BUILD_MV)
+
+#define EVENT_CLOCK_PRINT(stream, clock) \
+  fprintf(stream, "%016llX", (clock));
+
+#else
+
+#define EVENT_CLOCK_PRINT(stream, clock) \
+  fprintf(stream, "%016lX", (clock));
+
+#endif
+
+#define EVENT_CLOCK_WRITE(stream, depth, clock) \
+  WriteF(stream, depth, "$W", (WriteFW)(clock), NULL)
+
+#endif
+
+#endif /* Microsoft C on Intel */
+
+/* If we have GCC or Clang, assemble the rdtsc instruction */
+#if !defined(EVENT_CLOCK) && \
+    (defined(MPS_ARCH_I3) || defined(MPS_ARCH_I6)) && \
+      (defined(MPS_BUILD_GC) || defined(MPS_BUILD_LL))
+
+/* Use __extension__ to enable use of a 64-bit type on 32-bit pedantic
+   GCC or Clang. */
+__extension__ typedef unsigned long long EventClock;
+
+#define EVENT_CLOCK_MAKE(lvalue, low, high) \
+  ((lvalue) = ((EventClock)(high) << 32) + ((EventClock)(low) & (0xfffffffful)))
+
+/* Clang provides a cross-platform builtin for a fast timer, but it
+ * was not available on Mac OS X 10.8 until the release of XCode 4.6.
+ * <https://clang.llvm.org/docs/LanguageExtensions.html#builtins>
+ */
+#if defined(MPS_BUILD_LL)
+
+#if __has_builtin(__builtin_readcyclecounter)
+
+#define EVENT_CLOCK(lvalue) \
+  BEGIN \
+    (lvalue) = __builtin_readcyclecounter(); \
+  END
+
+#endif /* __has_builtin(__builtin_readcyclecounter) */
+
+#endif /* Clang */
+
+#ifndef EVENT_CLOCK
+
+#define EVENT_CLOCK(lvalue) \
+  BEGIN \
+    unsigned _l, _h; \
+    __asm__ __volatile__("rdtsc" : "=a"(_l), "=d"(_h)); \
+    (lvalue) = ((EventClock)_h << 32) | _l; \
+  END
+
+#endif
+
+/* The __extension__ keyword doesn't work on printf formats, so we
+   concatenate two 32-bit hex numbers to print the 64-bit value. */
+#define EVENT_CLOCK_PRINT(stream, clock) \
+  fprintf(stream, "%08lX%08lX", \
+          (unsigned long)((clock) >> 32), \
+          (unsigned long)((clock) & 0xffffffff))
+
+#define EVENT_CLOCK_WRITE(stream, depth, clock) \
+  WriteF(stream, depth, "$W$W", (WriteFW)((clock) >> 32), (WriteFW)clock, NULL)
+
+#endif /* Intel, GCC or Clang */
+
+/* no fast clock, use plinth, probably from the C library */
+#ifndef EVENT_CLOCK
+
+typedef mps_clock_t EventClock;
+
+#define EVENT_CLOCK_MAKE(lvalue, low, high) \
+  ((lvalue) = ((EventClock)(high) << 32) + ((EventClock)(low) & (0xfffffffful)))
+
+#define EVENT_CLOCK(lvalue) \
+  BEGIN \
+    (lvalue) = mps_clock(); \
+  END
+
+#define EVENT_CLOCK_PRINT(stream, clock) \
+  fprintf(stream, "%lu", (unsigned long)clock)
+
+#define EVENT_CLOCK_WRITE(stream, depth, clock) \
+  WriteF(stream, depth, "$W", (WriteFW)clock, NULL)
+
+#endif
+
+
+#endif /* clock_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/comm.gmk

@@ -0,0 +1,749 @@
+# -*- makefile -*-
+#
+# comm.gmk: COMMON GNUMAKEFILE FRAGMENT
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+#
+# DESCRIPTION
+#
+# This makefile fragment is included in more specific makefiles for
+# platforms which use GNU make.
+#
+# PARAMETERS
+#
+# Assumes the following variables and definitions:
+# EXTRA_TARGETS     a list of extra targets to build
+# CFLAGSCOMPILER    a list of flags for all compilations
+# CFLAGSCOMPILERSTRICT a list of flags for almost all compilations
+# CFLAGSCOMPILERLAX a list of flags for compilations which can't be as
+#                   strict (e.g. because they have to include a third-
+#                   party header file that isn't -ansi -pedantic).
+# CFLAGSDEBUG       a list of flags for compilations with maximum debug
+#                   information, and any optimization possible
+# CFLAGSOPT         a list of flags for compilations with maximum
+#                   optimization, and any debug info possible
+# CC                the command for the C compiler
+# LINKFLAGS         a list of flags passed to the linker
+# ARFLAGSPFM        platform-specific flags for ar
+# RANLIB            the command to index a library (default: none needed)
+# gendep  optionally defined to be a command sequence for
+#         generating the dependency file (.d) from a C file (.c);
+#         it is used in a rule of the form:
+#           $(PFM)/$(VARIETY)/%.d: %.c
+# PFM     platform code, e.g. "sus8gc"
+# LIBS    extra libraries to include in tests (usually "-lm")
+# NOISY   if defined and non-empty, causes commands to be emitted
+# MPMPF   platform-dependent C sources for the "mpm" part
+# MPMS    assembler sources for the "mpm" part (.s files)
+#
+# %%PART: When adding a new part, add a new parameter above for the
+# files included in the part.
+#
+# EDITING
+#
+# To add new targets, varieties, and parts:
+# Search for the string "%%TARGET", "%%VARIETY", or "%%PART" in this
+# makefile and follow the instructions.  If you're adding a part, you'll
+# have to change the makefiles for all the platforms which use this
+# makefile to define the source list for that part, and the GNUmakefile
+# to include a recursive call to the name of that part.
+#
+# CHECK PARAMETERS
+#
+# Old versions of GNU make don't have the $(error) function, but lines
+# starting "error" cause it to exit with an error. [These only test to
+# see whether the symbol is defined. We could be more thorough and
+# test the syntax and content. -- richard 1995-09-07]
+
+ifndef CC
+error "comm.gmk: CC not defined"
+endif
+ifndef CFLAGSCOMPILER
+error "comm.gmk: CFLAGSCOMPILER not defined"
+endif
+ifndef CFLAGSDEBUG
+error "comm.gmk: CFLAGSDEBUG not defined"
+endif
+ifndef CFLAGSOPT
+error "comm.gmk: CFLAGSOPT not defined"
+endif
+
+
+# TELEMETRY TARGETS
+
+EVENT_TARGETS = mpseventcnv mpseventpy mpseventsql mpseventtxt
+
+
+# EXTRA TARGETS
+#
+# Don't build mpseventsql by default (might not have sqlite3 installed),
+# but do build the other event target.
+
+EXTRA_TARGETS ?= $(filter-out mpseventsql,$(EVENT_TARGETS))
+
+
+#
+# %%PART: When adding a new part, add checks for the parameter with the
+#         sources for the new part.
+
+ifndef PFM
+error "comm.gmk: PFM not defined"
+endif
+ifndef MPMPF
+error "comm.gmk: MPMPF not defined"
+endif
+
+
+# DECLARATIONS
+
+ifdef NOISY
+ECHO = :
+else
+.SILENT:
+ECHO = echo
+endif
+
+.PHONY: phony
+
+
+# C FLAGS
+
+# These flags are included in all compilations.
+# Avoid using PFMDEFS in platform makefiles, as they prevent the MPS being
+# built with a simple command like "cc -c mps.c".
+CFLAGSCOMMONSTRICT = $(PFMDEFS) $(CFLAGSCOMPILER) $(CFLAGSCOMPILERSTRICT)
+CFLAGSCOMMONLAX = $(PFMDEFS) $(CFLAGSCOMPILER) $(CFLAGSCOMPILERLAX)
+
+# %%VARIETY: When adding a new variety, define a macro containing the set
+# of flags for the new variety.
+
+# These flags are added to compilations for the indicated variety.
+CFRASH = -DCONFIG_VAR_RASH $(CFLAGSOPT)
+CFHOT  = -DCONFIG_VAR_HOT  $(CFLAGSOPT)
+CFCOOL = -DCONFIG_VAR_COOL $(CFLAGSDEBUG)
+
+# Bind CFLAGSVARIETY to the appropriate set of flags for the variety.
+# %%VARIETY: When adding a new variety, add a test for the variety and
+# set CFLAGSVARIETY here.
+ifeq ($(VARIETY),rash)
+CFLAGSVARIETY=$(CFRASH)
+else
+ifeq ($(VARIETY),hot)
+CFLAGSVARIETY=$(CFHOT)
+else
+ifeq ($(VARIETY),cool)
+CFLAGSVARIETY=$(CFCOOL)
+else
+ifneq ($(VARIETY),)
+$(error Variety "$(VARIETY)" not recognized: must be rash/hot/cool)
+endif
+endif
+endif
+endif
+
+CFLAGSSTRICT=$(CFLAGSCOMMONSTRICT) $(CFLAGSVARIETY) $(CFLAGS)
+CFLAGSLAX=$(CFLAGSCOMMONLAX) $(CFLAGSVARIETY) $(CFLAGS)
+ARFLAGS=rc$(ARFLAGSPFM)
+
+
+# == Common definitions ==
+# %%PART: When adding a new part, add it here, unless it's platform-specific
+# These values are defined here because they have no variation between
+# platforms.
+
+AMC = poolamc.c
+AMS = poolams.c
+AWL = poolawl.c
+LO = poollo.c
+SNC = poolsnc.c
+POOLN = pooln.c
+MV2 = poolmv2.c
+MVFF = poolmvff.c
+TESTLIB = testlib.c
+TESTTHR = testthrix.c
+FMTDY = fmtdy.c fmtno.c
+FMTDYTST = fmtdy.c fmtno.c fmtdytst.c
+FMTHETST = fmthe.c fmtdy.c fmtno.c fmtdytst.c
+FMTSCM = fmtscheme.c
+PLINTH = mpsliban.c mpsioan.c
+MPMCOMMON = \
+    abq.c \
+    arena.c \
+    arenacl.c \
+    arenavm.c \
+    arg.c \
+    boot.c \
+    bt.c \
+    buffer.c \
+    cbs.c \
+    dbgpool.c \
+    dbgpooli.c \
+    event.c \
+    failover.c \
+    format.c \
+    freelist.c \
+    global.c \
+    land.c \
+    ld.c \
+    locus.c \
+    message.c \
+    meter.c \
+    mpm.c \
+    mpsi.c \
+    nailboard.c \
+    policy.c \
+    pool.c \
+    poolabs.c \
+    poolmfs.c \
+    poolmrg.c \
+    protocol.c \
+    range.c \
+    rangetree.c \
+    ref.c \
+    ring.c \
+    root.c \
+    sa.c \
+    sac.c \
+    scan.c \
+    seg.c \
+    shield.c \
+    splay.c \
+    ss.c \
+    table.c \
+    trace.c \
+    traceanc.c \
+    tract.c \
+    trans.c \
+    tree.c \
+    version.c \
+    vm.c \
+    walk.c
+POOLS = $(AMC) $(AMS) $(AWL) $(LO) $(MV2) $(MVFF) $(SNC)
+MPM = $(MPMCOMMON) $(MPMPF) $(POOLS) $(PLINTH)
+
+
+# These map the source file lists onto object files and dependency files
+# in the platform/variety directory.
+#
+# %%PART: When adding a new part, add a new macro which expands to the files
+# included in the part.
+
+ifdef VARIETY
+MPMOBJ = $(MPM:%.c=$(PFM)/$(VARIETY)/%.o) \
+         $(MPMS:%.s=$(PFM)/$(VARIETY)/%.o)
+FMTDYOBJ = $(FMTDY:%.c=$(PFM)/$(VARIETY)/%.o)
+FMTDYTSTOBJ = $(FMTDYTST:%.c=$(PFM)/$(VARIETY)/%.o)
+FMTHETSTOBJ = $(FMTHETST:%.c=$(PFM)/$(VARIETY)/%.o)
+FMTSCMOBJ = $(FMTSCM:%.c=$(PFM)/$(VARIETY)/%.o)
+PLINTHOBJ = $(PLINTH:%.c=$(PFM)/$(VARIETY)/%.o)
+POOLNOBJ = $(POOLN:%.c=$(PFM)/$(VARIETY)/%.o)
+TESTLIBOBJ = $(TESTLIB:%.c=$(PFM)/$(VARIETY)/%.o)
+TESTTHROBJ = $(TESTTHR:%.c=$(PFM)/$(VARIETY)/%.o)
+endif
+
+
+# == Test cases ==
+#
+# %%TARGET: When adding a new target, add it to one of the variables
+# in this section. Library components go in LIB_TARGETS.
+
+LIB_TARGETS=mps.a mpsplan.a
+
+# Test executables go in TEST_TARGETS.
+
+TEST_TARGETS=\
+    abqtest \
+    addrobj \
+    airtest \
+    amcss \
+    amcsshe \
+    amcssth \
+    amsss \
+    amssshe \
+    apss \
+    arenacv \
+    awlut \
+    awluthe \
+    awlutth \
+    btcv \
+    bttest \
+    djbench \
+    extcon \
+    finalcv \
+    finaltest \
+    forktest \
+    fotest \
+    gcbench \
+    landtest \
+    locbwcss \
+    lockcov \
+    lockut \
+    locusss \
+    locv \
+    messtest \
+    mpmss \
+    mpsicv \
+    mv2test \
+    nailboardtest \
+    poolncv \
+    qs \
+    sacss \
+    segsmss \
+    sncss \
+    steptest \
+    tagtest \
+    teletest \
+    walkt0 \
+    zcoll \
+    zmess \
+    ztfm
+
+# This target records programs that we were once able to build but
+# can't at the moment:
+
+UNBUILDABLE_TARGETS=\
+    replay # depends on the EPVM pool
+
+ALL_TARGETS=$(LIB_TARGETS) $(TEST_TARGETS) $(EXTRA_TARGETS)
+
+
+# == Pseudo-targets ==
+
+all: $(ALL_TARGETS)
+
+
+# == Automated test suites ==
+#
+# See design.mps.tests.target.
+
+TEST_SUITES=testrun testci testall testansi testpollnone
+
+$(addprefix $(PFM)/$(VARIETY)/,$(TEST_SUITES)): $(TEST_TARGETS)
+	../tool/testrun.sh -s "$(notdir $@)" "$(PFM)/$(VARIETY)"
+
+
+# == Automated performance testing ==
+#
+# See design.mps.tests.target.testratio.
+
+TESTRATIO_SEED = 1564912146
+
+define ratio
+TIME_HOT=$$(/usr/bin/time -p $(PFM)/hot/$(1) -x $(TESTRATIO_SEED) $(2) 2>&1 | tail -2 | awk '{T += $$2} END {print T}'); \
+TIME_RASH=$$(/usr/bin/time -p $(PFM)/rash/$(1) -x $(TESTRATIO_SEED) $(2) 2>&1 | tail -2 | awk '{T += $$2} END {print T}'); \
+RATIO=$$(awk "BEGIN{print int(100 * $$TIME_HOT / $$TIME_RASH)}"); \
+printf "Performance ratio (hot/rash) for $(2): %d%%\n" $$RATIO
+endef
+
+testratio: phony
+	$(MAKE) -f $(PFM).gmk VARIETY=hot djbench gcbench
+	$(MAKE) -f $(PFM).gmk VARIETY=rash djbench gcbench
+	$(call ratio,gcbench,amc)
+	$(call ratio,djbench,mvff)
+
+
+# == MMQA test suite ==
+#
+# See test/README for documentation on running the MMQA test suite.
+
+MMQA=perl test/qa -p $(PFM) -v $(VARIETY)
+
+$(PFM)/$(VARIETY)/testmmqa:
+	if [ "$(VARIETY)" = "cool" ]; then (cd ../test && $(MMQA) runset testsets/coolonly); fi
+	(cd ../test && $(MMQA) runset testsets/argerr testsets/conerr testsets/passing)
+
+
+# == Toy Scheme interpreter ==
+
+testscheme: phony
+	$(MAKE) -C ../example/scheme test
+
+
+# These convenience targets allow one to type "make foo" to build target
+# foo in selected varieties (or none, for the latter rule).
+
+$(LIB_TARGETS) $(TEST_TARGETS) $(EVENT_TARGETS) $(TEST_SUITES) testmmqa: phony
+ifdef VARIETY
+	$(MAKE) -f $(PFM).gmk TARGET=$@ variety
+else
+	$(MAKE) -f $(PFM).gmk TARGET=$@ target
+endif
+
+
+# "clean" removes the directory containing the build results for the
+# platform.
+
+clean: phony
+	$(ECHO) "$(PFM): $@"
+	rm -rf "$(PFM)"
+
+# "target" builds some varieties of the target named in the TARGET
+# macro.
+#
+# %%VARIETY: When adding a new target, optionally add a recursive make call
+# for the new variety, if it should be built by default.  It probably
+# shouldn't without a product design decision and an update of the readme
+# and build manual!
+#
+# Note that we build VARIETY=cool before VARIETY=hot because
+# the former doesn't need to optimize and so detects errors more
+# quickly; and because the former uses file-at-a-time compilation and
+# so can pick up where it left off instead of having to start from the
+# beginning of mps.c
+
+ifdef TARGET
+ifndef VARIETY
+target: phony
+	$(MAKE) -f $(PFM).gmk VARIETY=cool variety
+	$(MAKE) -f $(PFM).gmk VARIETY=hot variety
+endif
+endif
+
+
+# "variety" builds the target named in the TARGET macro using the
+# variety named in the VARIETY macro.
+
+ifdef VARIETY
+ifdef TARGET
+variety: $(PFM)/$(VARIETY)/$(TARGET)
+endif
+endif
+
+
+# THE MPS LIBRARY
+#
+# The MPS library is built in two ways:
+#
+#   1. In the usual way, from a pile of object files compiled from their
+#      corresponding sources.
+#
+#   2. From mps.c, which effectively concatenates all the sources, allowing
+#      important global optimisation and inlining to occur.
+#
+# We mostly use the method (2), because it is fast to compile and execute.
+# But we use method (1) for some varieties to ensure correctness of
+# code (linkage errors are masked by (2)) and to maintain a correct list
+# of source files in case method (2) won't work on some future constrained
+# platform.
+#
+# %%VARIETY: When adding a new variety, add a rule for how to build the
+# MPS library for the variety.
+
+$(PFM)/rash/mps.a: $(PFM)/rash/mps.o
+$(PFM)/hot/mps.a: $(PFM)/hot/mps.o
+$(PFM)/cool/mps.a: $(MPMOBJ)
+
+
+# OTHER GENUINE TARGETS
+#
+# Each line defines an executable or library target to be built and the
+# object files it is built from.  These lines add dependencies to the
+# generic rules below, and should not include commands to execute.
+#
+# %%TARGET: When adding a new target, add the dependencies for the new target
+# here.
+
+ifdef VARIETY
+
+$(PFM)/$(VARIETY)/abqtest: $(PFM)/$(VARIETY)/abqtest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/addrobj: $(PFM)/$(VARIETY)/addrobj.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/airtest: $(PFM)/$(VARIETY)/airtest.o \
+	$(FMTSCMOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/amcss: $(PFM)/$(VARIETY)/amcss.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/amcsshe: $(PFM)/$(VARIETY)/amcsshe.o \
+	$(FMTHETSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/amcssth: $(PFM)/$(VARIETY)/amcssth.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/amsss: $(PFM)/$(VARIETY)/amsss.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/amssshe: $(PFM)/$(VARIETY)/amssshe.o \
+	$(FMTHETSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/apss: $(PFM)/$(VARIETY)/apss.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/arenacv: $(PFM)/$(VARIETY)/arenacv.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/awlut: $(PFM)/$(VARIETY)/awlut.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/awluthe: $(PFM)/$(VARIETY)/awluthe.o \
+        $(FMTHETSTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/awlutth: $(PFM)/$(VARIETY)/awlutth.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/btcv: $(PFM)/$(VARIETY)/btcv.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/bttest: $(PFM)/$(VARIETY)/bttest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/djbench: $(PFM)/$(VARIETY)/djbench.o \
+	$(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)/$(VARIETY)/extcon: $(PFM)/$(VARIETY)/extcon.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/finalcv: $(PFM)/$(VARIETY)/finalcv.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/finaltest: $(PFM)/$(VARIETY)/finaltest.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/forktest: $(PFM)/$(VARIETY)/forktest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/fotest: $(PFM)/$(VARIETY)/fotest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/gcbench: $(PFM)/$(VARIETY)/gcbench.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)/$(VARIETY)/landtest: $(PFM)/$(VARIETY)/landtest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/locbwcss: $(PFM)/$(VARIETY)/locbwcss.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/lockcov: $(PFM)/$(VARIETY)/lockcov.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/lockut: $(PFM)/$(VARIETY)/lockut.o \
+	$(TESTLIBOBJ) $(TESTTHROBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/locusss: $(PFM)/$(VARIETY)/locusss.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/locv: $(PFM)/$(VARIETY)/locv.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/messtest: $(PFM)/$(VARIETY)/messtest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpmss: $(PFM)/$(VARIETY)/mpmss.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpsicv: $(PFM)/$(VARIETY)/mpsicv.o \
+	$(FMTDYTSTOBJ) $(FMTHETSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mv2test: $(PFM)/$(VARIETY)/mv2test.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/nailboardtest: $(PFM)/$(VARIETY)/nailboardtest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/poolncv: $(PFM)/$(VARIETY)/poolncv.o \
+	$(POOLNOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/qs: $(PFM)/$(VARIETY)/qs.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/sacss: $(PFM)/$(VARIETY)/sacss.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/segsmss: $(PFM)/$(VARIETY)/segsmss.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/sncss: $(PFM)/$(VARIETY)/sncss.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/steptest: $(PFM)/$(VARIETY)/steptest.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/tagtest: $(PFM)/$(VARIETY)/tagtest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/teletest: $(PFM)/$(VARIETY)/teletest.o \
+	$(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/walkt0: $(PFM)/$(VARIETY)/walkt0.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/zcoll: $(PFM)/$(VARIETY)/zcoll.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/zmess: $(PFM)/$(VARIETY)/zmess.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/ztfm: $(PFM)/$(VARIETY)/ztfm.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpseventcnv: $(PFM)/$(VARIETY)/eventcnv.o \
+  $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpseventpy: $(PFM)/$(VARIETY)/eventpy.o \
+  $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpseventtxt: $(PFM)/$(VARIETY)/eventtxt.o \
+  $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpseventsql: $(PFM)/$(VARIETY)/eventsql.o \
+  $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/replay: $(PFM)/$(VARIETY)/replay.o \
+  $(PFM)/$(VARIETY)/eventrep.o \
+  $(PFM)/$(VARIETY)/table.o \
+  $(PFM)/$(VARIETY)/mps.a
+
+$(PFM)/$(VARIETY)/mpsplan.a: $(PLINTHOBJ)
+
+endif
+
+
+# GENERIC RULES
+#
+# These generate build output in the <pfm>/<variety> directory.
+
+# Object files
+
+define run-cc-strict
+$(ECHO) "$(PFM): $@"
+mkdir -p $(PFM)
+mkdir -p $(PFM)/$(VARIETY)
+$(CC) $(CFLAGSSTRICT) -c -o $@ $<
+endef
+
+define run-cc-lax
+$(ECHO) "$(PFM): $@ - compiling with lax flags."
+mkdir -p $(PFM)
+mkdir -p $(PFM)/$(VARIETY)
+$(CC) $(CFLAGSLAX) -c -o $@ $<
+endef
+
+# .rule.c-to-o:
+$(PFM)/$(VARIETY)/%.o: %.c
+	$(run-cc-strict)
+
+$(PFM)/$(VARIETY)/eventsql.o: eventsql.c
+	$(run-cc-lax)
+
+$(PFM)/$(VARIETY)/%.o: %.s
+	$(run-cc-strict)
+
+$(PFM)/$(VARIETY)/%.o: %.S
+	$(run-cc-strict)
+
+# Dependencies
+#
+# These are included into _this_ makefile (see below).  GNU make does the
+# right thing as long as it knows how to make the dependency files before
+# including them.
+
+ifdef gendep
+
+$(PFM)/$(VARIETY)/%.d: %.c
+	$(ECHO) "$(PFM): $@"
+	mkdir -p $(PFM)
+	mkdir -p $(PFM)/$(VARIETY)
+	$(gendep)
+
+ifdef VARIETY
+ifdef TARGET
+
+# %%VARIETY: When adding a new variety, add the dependencies files for it
+# here.
+ifeq ($(VARIETY),rash)
+include $(PFM)/$(VARIETY)/mps.d
+else
+ifeq ($(VARIETY),hot)
+include $(PFM)/$(VARIETY)/mps.d
+else
+include $(MPM:%.c=$(PFM)/$(VARIETY)/%.d)
+endif # VARIETY != hot
+endif # VARIETY != rash
+
+# %%PART: When adding a new part, add the dependencies file for the
+# new part here.
+include \
+    $(FMTDY:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(FMTDYTST:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(FMTHETST:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(FMTSCM:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(PLINTH:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(POOLN:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(TESTLIB:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(TESTTHR:%.c=$(PFM)/$(VARIETY)/%.d) \
+    $(EXTRA_TARGETS:mps%=$(PFM)/$(VARIETY)/%.d) \
+    $(TEST_TARGETS:%=$(PFM)/$(VARIETY)/%.d)
+
+endif # !defined TARGET
+endif # !defined VARIETY
+
+endif # !defined gendep
+
+# Library
+
+ifndef RANLIB
+RANLIB = :
+endif
+
+$(PFM)/$(VARIETY)/%.a:
+	$(ECHO) "$(PFM): $@"
+	rm -f $@
+	$(AR) $(ARFLAGS) $@ $^
+	$(RANLIB) $@
+
+# Executable
+
+$(PFM)/$(VARIETY)/%:
+	$(ECHO) "$(PFM): $@"
+	$(CC) $(CFLAGSSTRICT) $(LINKFLAGS) -o $@ $^ $(LIBS)
+
+$(PFM)/$(VARIETY)/mpseventsql:
+	$(ECHO) "$(PFM): $@"
+	$(CC) $(CFLAGSLAX) $(LINKFLAGS) -o $@ $^ $(LIBS) -lsqlite3
+
+# Special targets for development
+
+# Currently FreeBSD 7 GCC 4.2.1 is the best platform we have for warning
+# us about strict aliasing rule violations caused by type puns.  This
+# target reveals them, and produces an assembler output file that can be
+# examined to see if they're actually dangerous.  RB 2012-09-07
+
+find-puns: phony
+	{ echo '#include "mps.c"'; echo '#include "fmtdy.c"'; } | \
+	gcc -S -fverbose-asm -ansi -pedantic -Wall -Wstrict-aliasing=2 -O3 -x c -o pun.s -
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+
+

mps/code/commpost.nmk

@@ -0,0 +1,416 @@
+# commpost.nmk: SECOND COMMON FRAGMENT FOR PLATFORMS USING NMAKE -*- makefile -*-
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+#
+# DESCRIPTION
+#
+# Second common makefile fragment for w3*mv.nmk.  See commpre.nmk
+
+
+# == Pseudo-targets ==
+
+all: $(ALL_TARGETS)
+
+
+# Convenience targets
+
+$(ALL_TARGETS) $(OPTIONAL_TARGETS):
+!IFDEF VARIETY
+	$(MAKE) /nologo /f $(PFM).nmk TARGET=$@ variety
+!ELSE
+	$(MAKE) /nologo /f $(PFM).nmk TARGET=$@ target
+!ENDIF
+
+# "clean" removes the directory containing the build results.
+# Depends on there being no file called "clean".
+# Note that we suspend error processing on the if line because rmdir
+# sometimes exits with an error and the message "The directory is not
+# empty" even if the /s option is given. See job003854.
+
+clean:
+	$(ECHO) $(PFM): $@
+	-if exist $(PFM) rmdir /q /s $(PFM)
+
+# target target
+# %%VARIETY: When adding a new variety, optionally, add a recursive make
+# call for the new variety, if it should be built by default.  It probably
+# shouldn't without a product design decision and an update of the readme
+# and build manual!
+# Depends on there being no file called "target".
+
+!IFDEF TARGET
+!IFNDEF VARIETY
+target:
+	$(MAKE) /nologo /f $(PFM).nmk VARIETY=cool variety
+	$(MAKE) /nologo /f $(PFM).nmk VARIETY=hot variety
+!ENDIF
+!ENDIF
+
+# variety
+# Depends on there being no file called "variety".
+
+!IFDEF VARIETY
+!IFDEF TARGET
+variety: $(PFM)\$(VARIETY)\$(TARGET)
+!ENDIF
+!ENDIF
+
+# testrun testci testall testansi testpollnone
+# Runs automated test cases. See design.mps.tests.target.
+
+testrun testci testall testansi testpollnone: $(TEST_TARGETS)
+!IFDEF VARIETY
+	..\tool\testrun.bat $(PFM) $(VARIETY) $@
+!ELSE
+	$(MAKE) /nologo /f $(PFM).nmk VARIETY=cool $@
+	$(MAKE) /nologo /f $(PFM).nmk VARIETY=hot $@
+!ENDIF
+
+
+# FLAGS AMALGAMATION
+#
+# %%VARIETY: When adding a new variety, add the following macros that
+# expand to sets of flags that the variety should use:
+#
+# CFLAGS --  when compiling C;
+# CFLAGSSQL -- when compiling mpseventsql;
+# LINKFLAGS -- when building executables;
+# LIBFLAGS -- when building libraries.
+
+!IF "$(VARIETY)" == "hot"
+CFLAGS=$(CFLAGSCOMMONPRE) $(CFHOT) $(CFLAGSCOMMONPOST)
+CFLAGSSQL=$(CFLAGSSQLPRE) $(CFHOT) $(CFLAGSSQLPOST)
+LINKFLAGS=$(LINKFLAGSCOMMON) $(LFHOT)
+LIBFLAGS=$(LIBFLAGSCOMMON) $(LIBFLAGSHOT)
+
+!ELSEIF "$(VARIETY)" == "cool"
+CFLAGS=$(CFLAGSCOMMONPRE) $(CFCOOL) $(CFLAGSCOMMONPOST)
+CFLAGSSQL=$(CFLAGSSQLPRE) $(CFCOOL) $(CFLAGSSQLPOST)
+LINKFLAGS=$(LINKFLAGSCOMMON) $(LFCOOL)
+LIBFLAGS=$(LIBFLAGSCOMMON) $(LIBFLAGSCOOL)
+
+!ELSEIF "$(VARIETY)" == "rash"
+CFLAGS=$(CFLAGSCOMMONPRE) $(CFRASH) $(CFLAGSCOMMONPOST)
+CFLAGSSQL=$(CFLAGSSQLPRE) $(CFRASH) $(CFLAGSSQLPOST)
+LINKFLAGS=$(LINKFLAGSCOMMON) $(LFRASH)
+LIBFLAGS=$(LIBFLAGSCOMMON) $(LIBFLAGSRASH)
+
+!ENDIF
+
+
+# SOURCE TO OBJECT FILE MAPPINGS
+#
+# %%PART: When adding a new part, add new macros which expand to the object
+# files included in the part
+#
+# Note: nmake doesn't expand variables within a string replacement
+# operation. We work around this by writing out a temporary makefile
+# and including it.
+
+TEMPMAKE=$(TEMP)\mps.nmk
+!IF [echo MPMOBJ0 = $$(MPM:[=$(PFM)\$(VARIETY)\) > $(TEMPMAKE)] == 0 \
+ && [echo FMTDYOBJ0 = $$(FMTDY:[=$(PFM)\$(VARIETY)\) >> $(TEMPMAKE)] == 0 \
+ && [echo FMTTESTOBJ0 = $$(FMTTEST:[=$(PFM)\$(VARIETY)\) >> $(TEMPMAKE)] == 0 \
+ && [echo FMTSCHEMEOBJ0 = $$(FMTSCHEME:[=$(PFM)\$(VARIETY)\) >> $(TEMPMAKE)] == 0 \
+ && [echo POOLNOBJ0 = $$(POOLN:[=$(PFM)\$(VARIETY)\) >> $(TEMPMAKE)] == 0 \
+ && [echo TESTLIBOBJ0 = $$(TESTLIB:[=$(PFM)\$(VARIETY)\) >> $(TEMPMAKE)] == 0 \
+ && [echo TESTTHROBJ0 = $$(TESTTHR:[=$(PFM)\$(VARIETY)\) >> $(TEMPMAKE)] == 0
+!INCLUDE $(TEMPMAKE)
+!IF [del $(TEMPMAKE)] != 0
+!ERROR Failed to delete $(TEMPMAKE)
+!ENDIF
+!ENDIF
+
+MPMOBJ = $(MPMOBJ0:]=.obj)
+FMTDYOBJ = $(FMTDYOBJ0:]=.obj)
+FMTTESTOBJ = $(FMTTESTOBJ0:]=.obj)
+FMTSCHEMEOBJ = $(FMTSCHEMEOBJ0:]=.obj)
+POOLNOBJ = $(POOLNOBJ0:]=.obj)
+TESTLIBOBJ = $(TESTLIBOBJ0:]=.obj)
+TESTTHROBJ = $(TESTTHROBJ0:]=.obj)
+
+
+# THE MPS LIBRARY
+#
+# The MPS library is built in two ways:
+#
+#   1. In the usual way, from a pile of object files compiled from their
+#      corresponding sources.
+#
+#   2. From mps.c, which effectively concatenates all the sources, allowing
+#      important global optimisation and inlining to occur.
+#
+# We mostly use the method (2), because it is fast to compile and execute.
+# But we use method (1) for some varieties to ensure correctness of
+# code (linkage errors are masked by (2)) and to maintain a correct list
+# of source files in case method (1) won't work on some future constrained
+# platform.
+#
+# %%VARIETY: When adding a new variety, add a rule for how to build the
+# MPS library for the variety
+
+$(PFM)\rash\mps.lib: $(PFM)\rash\mps.obj
+	$(ECHO) $@
+	$(LIBMAN) $(LIBFLAGS) /OUT:$@ $**
+
+$(PFM)\hot\mps.lib: $(PFM)\hot\mps.obj
+	$(ECHO) $@
+	$(LIBMAN) $(LIBFLAGS) /OUT:$@ $**
+
+$(PFM)\cool\mps.lib: $(MPMOBJ)
+	$(ECHO) $@
+	$(LIBMAN) $(LIBFLAGS) /OUT:$@ $**
+
+
+# OTHER GENUINE TARGETS
+#
+# Each line defines an executable or library target to be built and the object
+# files it is build from.  For an executable these lines add dependencies to
+# the generic rules below, and should not include commands to execute.
+# For a library this is not possible and the target should include commands
+# to build it.
+# %%TARGET: When adding a new target, add your new target here
+
+!IFDEF VARIETY
+
+$(PFM)\$(VARIETY)\abqtest.exe: $(PFM)\$(VARIETY)\abqtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\addrobj.exe: $(PFM)\$(VARIETY)\addrobj.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\airtest.exe: $(PFM)\$(VARIETY)\airtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTSCHEMEOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\amcss.exe: $(PFM)\$(VARIETY)\amcss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\amcsshe.exe: $(PFM)\$(VARIETY)\amcsshe.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\amcssth.exe: $(PFM)\$(VARIETY)\amcssth.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\amsss.exe: $(PFM)\$(VARIETY)\amsss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\amssshe.exe: $(PFM)\$(VARIETY)\amssshe.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\apss.exe: $(PFM)\$(VARIETY)\apss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\arenacv.exe:  $(PFM)\$(VARIETY)\arenacv.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\awlut.exe: $(PFM)\$(VARIETY)\awlut.obj \
+        $(FMTTESTOBJ) \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\awluthe.exe:  $(PFM)\$(VARIETY)\awluthe.obj \
+	$(FMTTESTOBJ) \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\awlutth.exe:  $(PFM)\$(VARIETY)\awlutth.obj \
+	$(FMTTESTOBJ) \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\btcv.exe: $(PFM)\$(VARIETY)\btcv.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\bttest.exe: $(PFM)\$(VARIETY)\bttest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\djbench.exe: $(PFM)\$(VARIETY)\djbench.obj \
+	$(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\extcon.exe: $(PFM)\$(VARIETY)\extcon.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\finalcv.exe: $(PFM)\$(VARIETY)\finalcv.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\finaltest.exe: $(PFM)\$(VARIETY)\finaltest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\fotest.exe: $(PFM)\$(VARIETY)\fotest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\gcbench.exe: $(PFM)\$(VARIETY)\gcbench.obj \
+	$(FMTTESTOBJ) $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\landtest.exe: $(PFM)\$(VARIETY)\landtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\locbwcss.exe: $(PFM)\$(VARIETY)\locbwcss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\lockcov.exe: $(PFM)\$(VARIETY)\lockcov.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\lockut.exe: $(PFM)\$(VARIETY)\lockut.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) $(TESTTHROBJ)
+
+$(PFM)\$(VARIETY)\locusss.exe: $(PFM)\$(VARIETY)\locusss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\locv.exe:  $(PFM)\$(VARIETY)\locv.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\messtest.exe: $(PFM)\$(VARIETY)\messtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\mpmss.exe: $(PFM)\$(VARIETY)\mpmss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\mpsicv.exe: $(PFM)\$(VARIETY)\mpsicv.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\mv2test.exe: $(PFM)\$(VARIETY)\mv2test.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\nailboardtest.exe: $(PFM)\$(VARIETY)\nailboardtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\poolncv.exe: $(PFM)\$(VARIETY)\poolncv.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ) $(POOLNOBJ)
+
+$(PFM)\$(VARIETY)\qs.exe: $(PFM)\$(VARIETY)\qs.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\sacss.exe: $(PFM)\$(VARIETY)\sacss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\segsmss.exe: $(PFM)\$(VARIETY)\segsmss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\sncss.exe: $(PFM)\$(VARIETY)\sncss.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\steptest.exe: $(PFM)\$(VARIETY)\steptest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\tagtest.exe: $(PFM)\$(VARIETY)\tagtest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\teletest.exe: $(PFM)\$(VARIETY)\teletest.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\walkt0.exe: $(PFM)\$(VARIETY)\walkt0.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\zcoll.exe: $(PFM)\$(VARIETY)\zcoll.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\zmess.exe: $(PFM)\$(VARIETY)\zmess.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\ztfm.exe: $(PFM)\$(VARIETY)\ztfm.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
+$(PFM)\$(VARIETY)\mpseventcnv.exe: $(PFM)\$(VARIETY)\eventcnv.obj \
+	$(PFM)\$(VARIETY)\mps.lib
+
+$(PFM)\$(VARIETY)\mpseventpy.exe: $(PFM)\$(VARIETY)\eventpy.obj \
+	$(PFM)\$(VARIETY)\mps.lib
+
+$(PFM)\$(VARIETY)\mpseventtxt.exe: $(PFM)\$(VARIETY)\eventtxt.obj \
+	$(PFM)\$(VARIETY)\mps.lib
+
+$(PFM)\$(VARIETY)\mpseventsql.exe: $(PFM)\$(VARIETY)\eventsql.obj \
+	$(PFM)\$(VARIETY)\sqlite3.obj $(PFM)\$(VARIETY)\mps.lib
+
+$(PFM)\$(VARIETY)\replay.exe: $(PFM)\$(VARIETY)\replay.obj \
+  $(PFM)\$(VARIETY)\eventrep.obj \
+  $(PFM)\$(VARIETY)\table.obj \
+  $(PFM)\$(VARIETY)\mps.lib
+
+# Have to rename the object file, because the names must match, or
+# the template rule for .exe.obj won't be used.
+$(PFM)\$(VARIETY)\replaysw.obj: $(PFM)\$(VARIETY)\replay.obj
+	$(ECHO) $@
+	copy $** $@ >nul:
+
+$(PFM)\$(VARIETY)\mpseventcnv.obj: $(PFM)\$(VARIETY)\eventcnv.obj
+	copy $** $@ >nul:
+
+$(PFM)\$(VARIETY)\mpseventpy.obj: $(PFM)\$(VARIETY)\eventpy.obj
+	copy $** $@ >nul:
+
+$(PFM)\$(VARIETY)\mpseventtxt.obj: $(PFM)\$(VARIETY)\eventtxt.obj
+	copy $** $@ >nul:
+
+$(PFM)\$(VARIETY)\mpseventsql.obj: $(PFM)\$(VARIETY)\eventsql.obj
+	copy $** $@ >nul:
+
+!ENDIF
+
+
+# GENERIC RULES
+
+# Object files
+
+{}.c{$(PFM)\$(VARIETY)}.obj:
+	$(ECHO) $@
+	@if not exist $(PFM) mkdir $(PFM)
+	@if not exist $(PFM)\$(VARIETY) mkdir $(PFM)\$(VARIETY)
+	$(CC) /c $(CFLAGS) /Fo$@ $<
+
+$(PFM)\$(VARIETY)\sqlite3.obj:
+	$(ECHO) $@
+	@if not exist $(PFM) mkdir $(PFM)
+	@if not exist $(PFM)\$(VARIETY) mkdir $(PFM)\$(VARIETY)
+        $(CC) /c $(CFLAGSSQL) /Fo$@ sqlite3.c
+
+{}.asm{$(PFM)\$(VARIETY)}.obj:
+	$(ECHO) $@
+	@if not exist $(PFM) mkdir $(PFM)
+	@if not exist $(PFM)\$(VARIETY) mkdir $(PFM)\$(VARIETY)
+	$(MASM) /nologo /c /Fo$@ $<
+
+# Coverage files
+#{$(PFM)\$(VARIETY)}.exe{$(PFM)\$(VARIETY)}.cov:
+#	$(ECHO) $@
+#	cd $(PFM)\$(VARIETY)
+#	prep /nologo /lv  $(<F)
+#	profile /nologo $(<B)
+#	prep /nologo /m $(<B)
+#	plist /nologo /D ..\.. $(<B) > $(@F)
+
+
+# Executables
+
+{$(PFM)\$(VARIETY)}.obj{$(PFM)\$(VARIETY)}.exe:
+	$(ECHO) $@
+	$(LINKER) $(LINKFLAGS) /OUT:$@ $(**)
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/commpre.nmk

@@ -0,0 +1,363 @@
+# commpre.nmk: FIRST COMMON FRAGMENT FOR PLATFORMS USING NMAKE -*- makefile -*-1
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+#
+# DESCRIPTION
+#
+# .description: This makefile fragment is included in more specific
+# makefiles for platforms which use the "mv" builder.  This is
+# the first of two common makefile fragments (the other is commpost.nmk).
+# Alas, due to shortcomings in nmake, it is not possible to use only one
+# common fragment.
+#
+# %%PART: When adding a new part, add a new parameter for the files included
+# in the part
+# Parameters:
+#   PFM        platform code, e.g. "w3i3mv"
+#   PFMDEFS    /D options to define platforms preprocessor symbols
+#              to the compiler. Avoid using this if possible, as it
+#              prevents the MPS being built with a simple command like
+#              "cl mps.c".
+#   MPMCOMMON  list of sources which make up the "mpm" part for all
+#              platforms. Each source is stripped of its .c extension
+#              and surrounded with [brackets].
+#   MPMPF      as above for the current platform.
+#   PLINTH     as above for the "plinth" part
+#   AMC        as above for the "amc" part
+#   AMS        as above for the "ams" part
+#   LO         as above for the "lo" part
+#   POOLN      as above for the "pooln" part
+#   SNC        as above for the "snc" part
+#   POOLS      as above for all pools included in the target
+#   MPM        as above for the MPMCOMMON + MPMPF + PLINTH + POOLS
+#   DW         as above for the "dw" part
+#   FMTTEST    as above for the "fmttest" part
+#   FMTSCHEME  as above for the "fmtscheme" part
+#   TESTLIB    as above for the "testlib" part
+#   TESTTHR    as above for the "testthr" part
+#   NOISY      if defined, causes command to be emitted
+#
+#
+# EDITING
+#
+# To add new targets, varieties, and parts:
+# Search for the string "%%TARGET", "%%VARIETY", or "%%PART" in this makefile
+# and follow the instructions.
+#
+
+
+# TARGETS
+#
+#
+# %%TARGET: When adding a new target, add it to one of the variables
+# in this section. Library components go in LIB_TARGETS.
+
+LIB_TARGETS=mps.lib
+
+# Test cases go in TEST_TARGETS.
+
+TEST_TARGETS=\
+    abqtest.exe \
+    addrobj.exe \
+    airtest.exe \
+    amcss.exe \
+    amcsshe.exe \
+    amcssth.exe \
+    amsss.exe \
+    amssshe.exe \
+    apss.exe \
+    arenacv.exe \
+    awlut.exe \
+    awluthe.exe \
+    awlutth.exe \
+    btcv.exe \
+    bttest.exe \
+    djbench.exe \
+    extcon.exe \
+    finalcv.exe \
+    finaltest.exe \
+    fotest.exe \
+    gcbench.exe \
+    landtest.exe \
+    locbwcss.exe \
+    lockcov.exe \
+    lockut.exe \
+    locusss.exe \
+    locv.exe \
+    messtest.exe \
+    mpmss.exe \
+    mpsicv.exe \
+    mv2test.exe \
+    nailboardtest.exe \
+    poolncv.exe \
+    qs.exe \
+    sacss.exe \
+    segsmss.exe \
+    sncss.exe \
+    steptest.exe \
+    tagtest.exe \
+    teletest.exe \
+    walkt0.exe \
+    zcoll.exe \
+    zmess.exe \
+    ztfm.exe
+
+# Stand-alone programs go in EXTRA_TARGETS if they should always be
+# built, or in OPTIONAL_TARGETS if they should only be built if
+
+EXTRA_TARGETS=mpseventcnv.exe mpseventpy.exe mpseventtxt.exe
+OPTIONAL_TARGETS=mpseventsql.exe
+
+# This target records programs that we were once able to build but
+# can't at the moment:
+#
+# replay -- depends on the EPVM pool.
+
+UNBUILDABLE_TARGETS=replay.exe
+
+ALL_TARGETS=$(LIB_TARGETS) $(TEST_TARGETS) $(EXTRA_TARGETS)
+
+
+# PARAMETERS
+#
+#
+# %%PART: When adding a new part, add the sources for the new part here.
+
+MPMCOMMON=\
+    [abq] \
+    [arena] \
+    [arenacl] \
+    [arenavm] \
+    [arg] \
+    [boot] \
+    [bt] \
+    [buffer] \
+    [cbs] \
+    [dbgpool] \
+    [dbgpooli] \
+    [event] \
+    [failover] \
+    [format] \
+    [freelist] \
+    [global] \
+    [land] \
+    [ld] \
+    [locus] \
+    [message] \
+    [meter] \
+    [mpm] \
+    [mpsi] \
+    [nailboard] \
+    [policy] \
+    [pool] \
+    [poolabs] \
+    [poolmfs] \
+    [poolmrg] \
+    [poolmv2] \
+    [protocol] \
+    [range] \
+    [rangetree] \
+    [ref] \
+    [ring] \
+    [root] \
+    [sa] \
+    [sac] \
+    [scan] \
+    [seg] \
+    [shield] \
+    [splay] \
+    [ss] \
+    [table] \
+    [trace] \
+    [traceanc] \
+    [tract] \
+    [trans] \
+    [tree] \
+    [version] \
+    [vm] \
+    [walk]
+PLINTH = [mpsliban] [mpsioan]
+AMC = [poolamc]
+AMS = [poolams]
+AWL = [poolawl]
+LO = [poollo]
+MVFF = [poolmvff]
+POOLN = [pooln]
+SNC = [poolsnc]
+FMTDY = [fmtdy] [fmtno]
+FMTTEST = [fmthe] [fmtdy] [fmtno] [fmtdytst]
+FMTSCHEME = [fmtscheme]
+TESTLIB = [testlib] [getoptl]
+TESTTHR = [testthrw3]
+POOLS = $(AMC) $(AMS) $(AWL) $(LO) $(MV2) $(MVFF) $(SNC)
+MPM = $(MPMCOMMON) $(MPMPF) $(POOLS) $(PLINTH)
+
+
+# CHECK PARAMETERS
+#
+#
+# %%PART: When adding a new part, add checks for the parameter with the
+# sources for the new part.
+
+!IFNDEF PFM
+!ERROR commpre.nmk: PFM not defined
+!ENDIF
+!IFNDEF MPM
+!ERROR commpre.nmk: MPM not defined
+!ENDIF
+!IFNDEF MPMCOMMON
+!ERROR commpre.nmk: MPMCOMMON not defined
+!ENDIF
+!IFNDEF MPMPF
+!ERROR commpre.nmk: MPMPF not defined
+!ENDIF
+!IFNDEF PLINTH
+!ERROR commpre.nmk: PLINTH not defined
+!ENDIF
+!IFNDEF LO
+!ERROR commpre.nmk: LO not defined
+!ENDIF
+!IFNDEF AMC
+!ERROR commpre.nmk: AMC not defined
+!ENDIF
+!IFNDEF AMS
+!ERROR commpre.nmk: AMS not defined
+!ENDIF
+!IFNDEF POOLN
+!ERROR commpre.nmk: POOLN not defined
+!ENDIF
+!IFNDEF SNC
+!ERROR commpre.nmk: SNC not defined
+!ENDIF
+!IFNDEF FMTDY
+!ERROR commpre.nmk: FMTDY not defined
+!ENDIF
+!IFNDEF FMTTEST
+!ERROR commpre.nmk: FMTTEST not defined
+!ENDIF
+!IFNDEF FMTSCHEME
+!ERROR commpre.nmk: FMTSCHEME not defined
+!ENDIF
+!IFNDEF TESTLIB
+!ERROR commpre.nmk: TESTLIB not defined
+!ENDIF
+!IFNDEF TESTTHR
+!ERROR commpre.nmk: TESTTHR not defined
+!ENDIF
+
+
+# DECLARATIONS
+
+
+!IFDEF NOISY
+ECHO = rem
+!ELSE
+.SILENT:
+ECHO = echo
+!ENDIF
+
+
+# C FLAGS
+
+CFLAGSTARGETPRE =
+CFLAGSTARGETPOST =
+CRTFLAGSHOT =
+CRTFLAGSCOOL =
+LINKFLAGSHOT =
+LINKFLAGSCOOL =
+
+CFLAGSSQLPRE = /nologo $(PFMDEFS)
+CFLAGSCOMMONPRE = /nologo $(PFMDEFS) $(CFLAGSTARGETPRE)
+CFLAGSSQLPOST =
+CFLAGSCOMMONPOST = $(CFLAGSTARGETPOST)
+
+# Flags for use in the variety combinations
+CFLAGSHOT = /O2
+# (above /O2 (maximise speed) used to be set to /Ox
+# (maximise optimisations) in for tool versions before VS 9)
+# We used to have /GZ here (stack probe).
+# Note that GZ is specific to version 12 of the cl tool.  drj 2003-11-04
+# It is ignored on earlier versions of the cl tool.
+# /GZ here generates a dependency on the C library and when we are
+# building a DLL, mpsdy.dll, the linker step will fail (error LNK2001:
+# unresolved external symbol __chkesp).  See
+# http://support.microsoft.com/kb/q191669/
+CFLAGSCOOL =
+CFLAGSINTERNAL = /Zi
+CFLAGSEXTERNAL =
+
+# The combinations of variety
+# %%VARIETY: When adding a new variety, define a macro containing the set
+# of flags for the new variety.
+CFRASH = /DCONFIG_VAR_RASH $(CRTFLAGSHOT)  $(CFLAGSHOT)  $(CFLAGSEXTERNAL)
+CFHOT  = /DCONFIG_VAR_HOT  $(CRTFLAGSHOT)  $(CFLAGSHOT)  $(CFLAGSINTERNAL)
+CFCOOL = /DCONFIG_VAR_COOL $(CRTFLAGSCOOL) $(CFLAGSCOOL) $(CFLAGSINTERNAL)
+
+# Microsoft documentation is not very clear on the point of using both
+# optimization and debug information
+
+# LINKER FLAGS
+# %%VARIETY: When adding a new variety, define a macro containing the flags
+# for the new variety
+LINKER = link
+LINKFLAGSCOMMON = /nologo /LARGEADDRESSAWARE
+LINKFLAGSINTERNAL = /DEBUG
+# ( Internal flags used to be set to /DEBUG:full )
+LINKFLAGSEXTERNAL = /RELEASE
+
+LFRASH = $(LINKFLAGSHOT)    $(LINKFLAGSEXTERNAL)
+LFHOT  = $(LINKFLAGSHOT)    $(LINKFLAGSINTERNAL)
+LFCOOL = $(LINKFLAGSCOOL)   $(LINKFLAGSINTERNAL)
+
+#LFCV = /PROFILE /DEBUG:full /DEBUGTYPE:cv
+
+# Library manager
+# %%VARIETY: When adding a new variety, define a macro containing the flags
+# for the new variety
+LIBMAN = lib                  # can't call this LIB - it screws the environment
+LIBFLAGSCOMMON =
+
+LIBFLAGSRASH =
+LIBFLAGSHOT =
+LIBFLAGSCOOL =
+
+# Browser database manager [not used at present]
+#BSC = bscmake
+#BSCFLAGS = /nologo /n
+
+
+# == Common definitions ==
+# %%PART: When adding a new part, add it here, unless it's platform-specific
+# [It is not possible use a macro, like $(PFM), in a substitution,
+# hence all parts end up being platform-specific.]
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/config.h

@@ -0,0 +1,768 @@
+/* config.h: MPS CONFIGURATION
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (c) 2002 Global Graphics Software.
+ *
+ * PURPOSE
+ *
+ * This module translates from high-level symbols defined by the
+ * external build system (gnumake, nmake, etc.) into specific sets
+ * of features used by MPS modules.
+ *
+ * TODO: It also defines defaults for various parts of the MPS.
+ * Perhaps this should be split into a separate header with better
+ * documentation.  See
+ * <https://github.com/Ravenbrook/mps/issues/176#issuecomment-1443192870>.
+ *
+ * DESIGN
+ *
+ * <design/config>.
+ *
+ * TODO: Many of the default constants defined in this file do not
+ * have documented justification.  See GitHub issue #176
+ * <https://github.com/Ravenbrook/mps/issues/176>.
+ */
+
+#ifndef config_h
+#define config_h
+
+
+/* CONFIG_VAR_* -- variety Configuration
+ *
+ * These are translated into the directives CONFIG_ASSERT, CONFIG_STATS,
+ * CONFIG_LOG, etc. which control actual compilation features.
+ */
+
+/* CONFIG_VAR_RASH -- the rash and reckless variety
+ *
+ * This variety switches off as many features as possible for maximum
+ * performance, but is therefore unsafe and undebuggable.  It is not intended
+ * for use, but for comparison with the hot variety, to check that assertion,
+ * logging, etc. have negligible overhead.
+ */
+
+#if defined(CONFIG_VAR_RASH)
+/* no asserts */
+/* no statistic meters */
+/* no telemetry log events */
+
+
+/* CONFIG_VAR_COOL -- cool variety
+ *
+ * The cool variety is intended for use when developing an integration with
+ * the MPS or debugging memory problems or collecting detailed telemetry
+ * data for performance analysis.  It has more thorough consistency checking
+ * and data collection and output, and full debugging information.
+ */
+
+#elif defined(CONFIG_VAR_COOL)
+#define CONFIG_ASSERT
+#define CONFIG_ASSERT_ALL
+#define CONFIG_ASSERT_ABORT
+#define CONFIG_STATS
+#ifndef CHECKLEVEL
+#define CHECKLEVEL      CheckLevelSHALLOW
+#endif
+#define CONFIG_LOG
+#define CONFIG_LOG_ALL
+
+
+#else /* CONFIG_VAR_* */
+
+/* CONFIG_VAR_HOT -- the hot variety
+ *
+ * This variety is the default variety for distribution in products that use
+ * the MPS.  It has maximum performance while retaining a good level of
+ * consistency checking and allowing some debugging and telemetry features.
+ */
+
+/* #elif defined(CONFIG_VAR_HOT) */
+#define CONFIG_ASSERT
+/* Note, not CONFIG_ASSERT_ABORT */
+#ifndef CHECKLEVEL
+#define CHECKLEVEL      CheckLevelMINIMAL
+#endif
+/* no statistic meters */
+#define CONFIG_LOG
+
+#endif /* CONFIG_VAR_* */
+
+
+/* Build Features */
+
+
+#if defined(CONFIG_ASSERT)
+/* asserts: AVER, AVERT, NOTREACHED, CHECKx */
+/* note: a direct call to ASSERT() will *still* fire */
+#define AVER_AND_CHECK
+#if defined(CONFIG_ASSERT_ALL)
+#define AVER_AND_CHECK_ALL
+#define MPS_ASSERT_STRING "assertastic"
+#else /* CONFIG_ASSERT_ALL, not */
+#define MPS_ASSERT_STRING "asserted"
+#endif /* CONFIG_ASSERT_ALL */
+#else /* CONFIG_ASSERT, not */
+#define AVER_AND_CHECK_NONE
+#define MPS_ASSERT_STRING "nonasserted"
+#endif
+#if defined(CONFIG_ASSERT_ABORT)
+#define ASSERT_ABORT() abort()
+#else
+#define ASSERT_ABORT() NOOP
+#endif
+
+
+#if defined(CONFIG_STATS)
+/* CONFIG_STATS = STATISTICS = METERs */
+#define STATISTICS
+#define MPS_STATS_STRING "stats"
+#else
+#define STATISTICS_NONE
+#define MPS_STATS_STRING "nonstats"
+#endif
+
+
+#if defined(CONFIG_LOG)
+/* TELEMETRY = LOG = EVENTs */
+#define EVENT
+#if defined(CONFIG_LOG_ALL)
+#define EVENT_ALL 1     /* log events on critical path */
+#define MPS_LOG_STRING "logtastic"
+#else /* CONFIG_LOG_ALL, not */
+#define EVENT_ALL 0     /* don't log events on critical path */
+#define MPS_LOG_STRING "logging"
+#endif /* CONFIG_LOG_ALL */
+#else /* CONFIG_LOG, not */
+#define EVENT_NONE
+#define MPS_LOG_STRING "nonlogging"
+#endif /* CONFIG_LOG */
+
+
+/* CONFIG_PLINTH_NONE -- exclude the ANSI plinth
+ *
+ * Some MPS deployment environments want to avoid dependencies on the
+ * standard C library.  In this case, the plinth, defined in mpslib.h must
+ * be supplied when linking.
+ *
+ * For example, Open Dylan on Windows does not link the C library, but
+ * supplies its own plinth directly using Windows and Dylan interfaces.
+ *
+ * CONFIG_PLINTH_NONE tells mps.c to exclude the ANSI plinth and removes
+ * all standard C library dependencies.  e.g.
+ *
+ *     cc -O2 -c -DCONFIG_PLINTH_NONE mps.c
+ */
+
+#if !defined(CONFIG_PLINTH_NONE)
+#define PLINTH
+#else
+#define PLINTH_NONE
+#endif
+
+
+/* CONFIG_PF_ANSI -- use the ANSI platform
+ *
+ * This symbol tells mps.c to exclude the sources for the
+ * auto-detected platform, and use the generic ("ANSI") platform
+ * instead.
+ */
+
+#if defined(CONFIG_PF_ANSI)
+#define PLATFORM_ANSI
+#endif
+
+
+/* CONFIG_THREAD_SINGLE -- support single-threaded execution only
+ *
+ * This symbol causes the MPS to be built for single-threaded
+ * execution only, where locks are not needed and so the generic
+ * ("ANSI") lock module lockan.c can be used instead of the
+ * platform-specific lock module.
+ */
+
+#if !defined(CONFIG_THREAD_SINGLE)
+#define LOCK
+#else
+#define LOCK_NONE
+#endif
+
+
+/* CONFIG_POLL_NONE -- no support for polling
+ *
+ * This symbol causes the MPS to built without support for polling.
+ * This means that garbage collections will only happen if requested
+ * explicitly via mps_arena_collect() or mps_arena_step(), but it also
+ * means that protection is not needed, and so shield operations can
+ * be replaced with no-ops in mpm.h.
+ */
+
+#if !defined(CONFIG_POLL_NONE)
+#define REMEMBERED_SET
+#define SHIELD
+#else
+#if !defined(CONFIG_THREAD_SINGLE)
+#error "CONFIG_POLL_NONE without CONFIG_THREAD_SINGLE"
+#endif
+#define REMEMBERED_SET_NONE
+#define SHIELD_NONE
+#endif
+
+
+#define MPS_VARIETY_STRING \
+  MPS_ASSERT_STRING "." MPS_LOG_STRING "." MPS_STATS_STRING
+
+
+/* Platform Configuration */
+
+#include "mpstd.h"
+
+/* Suppress Visual C warnings at /W4 (warning level 4) */
+/* This is also done in testlib.h. */
+
+#ifdef MPS_BUILD_MV
+
+/* "constant conditional" (provoked by MPS_END) */
+#pragma warning(disable: 4127)
+
+#endif /* MPS_BUILD_MV */
+
+
+/* Suppress Pelles C warnings at /W2 (warning level 2) */
+/* Some of the same settings are done in testlib.h. */
+
+#ifdef MPS_BUILD_PC
+
+/* "Unreachable code" (provoked by AVER, if condition is constantly true). */
+#pragma warn(disable: 2154)
+
+/* "Consider changing type to 'size_t' for loop variable" */
+#pragma warn(disable: 2804)
+
+#endif /* MPS_BUILD_PC */
+
+
+/* MPS_FILE -- expands to __FILE__ in nested macros */
+
+#ifdef MPS_BUILD_PC
+
+/* Pelles C loses definition of __FILE__ in deeply nested macro
+ * expansions. See <https://forum.pellesc.de/index.php?topic=5474.0>
+ */
+#define MPS_FILE "<__FILE__ unavailable in " MPS_PF_STRING ">"
+
+#else
+
+#define MPS_FILE __FILE__
+
+#endif
+
+
+/* Function attributes */
+/* Some of these are also defined in testlib.h */
+
+/* Attribute for functions that take a printf-like format argument, so
+ * that the compiler can check the format specifiers against the types
+ * of the arguments.
+ * GCC: <https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-format-function-attribute>
+ * Clang: <https://clang.llvm.org/docs/AttributeReference.html#format-gnu-format>
+ */
+#if defined(MPS_BUILD_GC) || defined(MPS_BUILD_LL)
+#define ATTRIBUTE_FORMAT(ARGLIST) __attribute__((__format__ ARGLIST))
+#else
+#define ATTRIBUTE_FORMAT(ARGLIST)
+#endif
+
+/* Attribute for functions that should not be instrumented by Clang's
+ * address sanitizer.
+ * <https://clang.llvm.org/docs/AddressSanitizer.html#attribute-no-sanitize-address>
+ */
+#if defined(MPS_BUILD_LL)
+#if __has_feature(address_sanitizer)
+#define ATTRIBUTE_NO_SANITIZE_ADDRESS __attribute__((__no_sanitize_address__))
+#else
+#define ATTRIBUTE_NO_SANITIZE_ADDRESS
+#endif
+#else
+#define ATTRIBUTE_NO_SANITIZE_ADDRESS
+#endif
+
+/* Attribute for functions that must not be inlined.
+ * GCC: <https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-noinline-function-attribute>
+ * MSVC: <https://docs.microsoft.com/en-us/cpp/cpp/noinline>
+ */
+#if defined(MPS_BUILD_GC) || defined(MPS_BUILD_LL)
+#define ATTRIBUTE_NOINLINE __attribute__((__noinline__))
+#elif defined(MPS_BUILD_MV)
+#define ATTRIBUTE_NOINLINE __declspec(noinline)
+#else
+#define ATTRIBUTE_NOINLINE
+#endif
+
+/* Attribute for functions that do not return.
+ * GCC: <https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-noreturn-function-attribute>
+ * Clang: <https://clang.llvm.org/docs/AttributeReference.html#id1>
+ */
+#if defined(MPS_BUILD_GC) || defined(MPS_BUILD_LL)
+#define ATTRIBUTE_NORETURN __attribute__((__noreturn__))
+#else
+#define ATTRIBUTE_NORETURN
+#endif
+
+/* Attribute for functions that may be unused in some build configurations.
+ * GCC: <https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-unused-function-attribute>
+ *
+ * This attribute must be applied to all Check functions, otherwise
+ * the RASH variety fails to compile with -Wunused-function. (It
+ * should not be applied to functions that are unused in all build
+ * configurations: these functions should not be compiled.)
+ */
+#if defined(MPS_BUILD_GC) || defined(MPS_BUILD_LL)
+#define ATTRIBUTE_UNUSED __attribute__((__unused__))
+#else
+#define ATTRIBUTE_UNUSED
+#endif
+
+
+/* Compiler extensions */
+
+/* LIKELY -- likely conditions
+ *
+ * Use to annotate conditions that are likely to be true, such as
+ * assertions, to help move unlikely code out-of-line.  See
+ * <https://gcc.gnu.org/onlinedocs/gcc/Other-Builtins.html>.
+ */
+
+#if defined(MPS_BUILD_GC) || defined(MPS_BUILD_LL)
+#define LIKELY(exp) __builtin_expect((exp) != 0, 1)
+#else
+#define LIKELY(exp) ((exp) != 0)
+#endif
+
+
+/* Buffer Configuration -- see <code/buffer.c> */
+
+#define BUFFER_RANK_DEFAULT (mps_rank_exact())
+
+
+/* Format defaults: see <code/format.c> */
+
+#define FMT_ALIGN_DEFAULT ((Align)MPS_PF_ALIGN)
+#define FMT_HEADER_SIZE_DEFAULT ((Size)0)
+#define FMT_SCAN_DEFAULT (&FormatNoScan)
+#define FMT_SKIP_DEFAULT (&FormatNoSkip)
+#define FMT_FWD_DEFAULT (&FormatNoMove)
+#define FMT_ISFWD_DEFAULT (&FormatNoIsMoved)
+#define FMT_PAD_DEFAULT (&FormatNoPad)
+#define FMT_CLASS_DEFAULT (&FormatDefaultClass)
+
+
+/* Pool AMC Configuration -- see <code/poolamc.c> */
+
+#define AMC_INTERIOR_DEFAULT TRUE
+/* AMC treats objects larger than or equal to this as "Large" */
+#define AMC_LARGE_SIZE_DEFAULT ((Size)32768)
+#define AMC_EXTEND_BY_DEFAULT  ((Size)8192)
+
+
+/* Pool AMS Configuration -- see <code/poolams.c> */
+
+#define AMS_SUPPORT_AMBIGUOUS_DEFAULT TRUE
+#define AMS_GEN_DEFAULT       0
+
+
+/* Pool AWL Configuration -- see <code/poolawl.c> */
+
+#define AWL_GEN_DEFAULT       0
+#define AWL_HAVE_SEG_SA_LIMIT   TRUE
+#define AWL_SEG_SA_LIMIT        200     /* TODO: Improve guesswork with measurements */
+#define AWL_HAVE_TOTAL_SA_LIMIT FALSE
+#define AWL_TOTAL_SA_LIMIT      0
+
+
+/* Pool LO Configuration -- see <code/poollo.c> */
+
+#define LO_GEN_DEFAULT       0
+
+
+/* Pool MFS Configuration -- see <code/poolmfs.c> */
+
+#define MFS_EXTEND_BY_DEFAULT ((Size)65536)
+
+
+/* Pool MVFF Configuration -- see <code/poolmvff.c> */
+
+#define MVFF_EXTEND_BY_DEFAULT   ((Size)65536)
+#define MVFF_AVG_SIZE_DEFAULT    ((Size)32)
+#define MVFF_ALIGN_DEFAULT       MPS_PF_ALIGN
+#define MVFF_SLOT_HIGH_DEFAULT   FALSE
+#define MVFF_ARENA_HIGH_DEFAULT  FALSE
+#define MVFF_FIRST_FIT_DEFAULT   TRUE
+#define MVFF_SPARE_DEFAULT       0.75
+
+
+/* Pool MVT Configuration -- see <code/poolmv2.c> */
+
+/* TODO: These numbers were lifted from mv2test and need thought.  See
+   GitHub issue #176
+   <https://github.com/Ravenbrook/mps/issues/176>. */
+
+#define MVT_ALIGN_DEFAULT         MPS_PF_ALIGN
+#define MVT_MIN_SIZE_DEFAULT      MPS_PF_ALIGN
+#define MVT_MEAN_SIZE_DEFAULT     32
+#define MVT_MAX_SIZE_DEFAULT      8192
+#define MVT_RESERVE_DEPTH_DEFAULT 1024
+#define MVT_FRAG_LIMIT_DEFAULT    30
+
+
+/* Arena Configuration -- see <code/arena.c> */
+
+#define ArenaPollALLOCTIME (65536.0)
+
+/* .client.seg-size: ARENA_CLIENT_GRAIN_SIZE is the minimum size, in
+ * bytes, of a grain in the client arena. It's set at 8192 with no
+ * particular justification. */
+
+#define ARENA_CLIENT_GRAIN_SIZE          ((Size)8192)
+
+#define ARENA_DEFAULT_COMMIT_LIMIT ((Size)-1)
+
+#define ARENA_SPARE_DEFAULT     0.75
+
+/* ARENA_DEFAULT_PAUSE_TIME is the maximum time (in seconds) that
+ * operations within the arena may pause the mutator for.  The default
+ * is set for typical human interaction.  See mps_arena_pause_time_set
+ * in the manual. */
+
+#define ARENA_DEFAULT_PAUSE_TIME (0.1)
+
+#define ARENA_DEFAULT_ZONED     TRUE
+
+/* ARENA_MINIMUM_COLLECTABLE_SIZE is the minimum size (in bytes) of
+ * collectable memory that might be considered worthwhile to run a
+ * full garbage collection. */
+
+#define ARENA_MINIMUM_COLLECTABLE_SIZE ((Size)1000000)
+
+/* ARENA_DEFAULT_COLLECTION_RATE is an estimate of the MPS's
+ * collection rate (in work per second; see <design/type#.work>), for
+ * use in the case where there isn't enough data to use a measured
+ * value. */
+
+#define ARENA_DEFAULT_COLLECTION_RATE (25000000.0)
+
+/* ARENA_DEFAULT_COLLECTION_OVERHEAD is an estimate of the MPS's
+ * collection overhead (in seconds), for use in the case where there
+ * isn't enough data to use a measured value. */
+
+#define ARENA_DEFAULT_COLLECTION_OVERHEAD (0.1)
+
+/* ARENA_MAX_COLLECT_FRACTION is the maximum fraction of runtime that
+ * ArenaStep is prepared to spend in collections. */
+
+#define ARENA_MAX_COLLECT_FRACTION (0.1)
+
+/* ArenaDefaultZONESET is the zone set used by LocusPrefDEFAULT.
+ *
+ * TODO: This is left over from before branches 2014-01-29/mps-chain-zones
+ * and 2014-01-17/cbs-tract-alloc reformed allocation, and may now be
+ * doing more harm than good. Experiment with setting to ZoneSetUNIV. */
+
+#define ArenaDefaultZONESET (ZoneSetUNIV << (MPS_WORD_WIDTH / 2))
+
+/* LocusPrefDEFAULT is the allocation preference used by manual pool
+ * classes (these don't care where they allocate). */
+
+#define LocusPrefDEFAULT { \
+  LocusPrefSig,        /* sig */ \
+  FALSE,               /* high */ \
+  ArenaDefaultZONESET, /* zoneSet */ \
+  ZoneSetEMPTY,        /* avoid */ \
+}
+
+#define LDHistoryLENGTH ((Size)4)
+
+/* Value of MPS_KEY_EXTEND_BY for the arena control pool. */
+#define CONTROL_EXTEND_BY ((Size)32768)
+
+#define VM_ARENA_SIZE_DEFAULT ((Size)1 << 28)
+
+
+/* Locus configuration -- see <code/locus.c> */
+
+/* Weighting for the current observation, in the exponential moving
+ * average computation of the mortality of a generation. */
+#define LocusMortalityALPHA (0.4)
+
+
+/* Stack probe configuration -- see <code/sp*.c> */
+
+/* Currently StackProbe has a useful implementation only on Windows. */
+#if defined(MPS_OS_W3) && !defined(CONFIG_PF_ANSI)
+/* See <design/sp#.sol.depth.analysis> for a justification of this value. */
+#define StackProbeDEPTH ((Size)500)
+#else
+#define StackProbeDEPTH ((Size)0)
+#endif
+
+
+/* Shield Configuration -- see <code/shield.c> */
+
+#define ShieldQueueLENGTH  512  /* initial length of shield queue */
+#define ShieldDepthWIDTH     4  /* log2(max nested exposes + 1) */
+
+
+/* VM Configuration -- see <code/vm*.c> */
+
+#define VMAN_PAGE_SIZE ((Align)4096)
+#define VMJunkBYTE ((unsigned char)0xA9)
+#define VMParamSize (sizeof(Word))
+
+
+/* .feature.li: Linux feature specification
+ *
+ * The MPS needs the following symbols which are not defined if the
+ * -ansi option is given to GCC:
+ *
+ * Source      Symbols                   Header        Feature
+ * =========== ========================= ============= ====================
+ * eventtxt.c  setenv                    <stdlib.h>    _GNU_SOURCE
+ * lockix.c    pthread_mutexattr_settype <pthread.h>   _XOPEN_SOURCE >= 500
+ * prmcix.h    stack_t, siginfo_t        <signal.h>    _XOPEN_SOURCE
+ * prmclii3.c  REG_EAX etc.              <ucontext.h>  _GNU_SOURCE
+ * prmclii6.c  REG_RAX etc.              <ucontext.h>  _GNU_SOURCE
+ * pthrdext.c  sigaction etc.            <signal.h>    _XOPEN_SOURCE
+ * vmix.c      MAP_ANON                  <sys/mman.h>  _GNU_SOURCE
+ *
+ * It is not possible to localize these feature specifications around
+ * the individual headers: all headers share a common set of features
+ * (via <feature.h>) and so all sources in the same compilation unit
+ * must turn on the same set of features.
+ *
+ * See "Feature Test Macros" in the Glibc Manual:
+ * <https://www.gnu.org/software/libc/manual/html_node/Feature-Test-Macros.html>
+ */
+
+#if defined(MPS_OS_LI)
+
+#if defined(_XOPEN_SOURCE) && _XOPEN_SOURCE < 500
+#undef _XOPEN_SOURCE
+#endif
+#if !defined(_XOPEN_SOURCE)
+#define _XOPEN_SOURCE 500
+#endif
+
+#if !defined(_GNU_SOURCE)
+#define _GNU_SOURCE
+#endif
+
+#endif
+
+
+/* .feature.xc: macOS feature specification
+ *
+ * The MPS needs the following symbols which are not defined by default
+ *
+ * Source      Symbols                   Header        Feature
+ * =========== ========================= ============= ====================
+ * prmclii3.c  __eax etc.                <ucontext.h>  _XOPEN_SOURCE
+ * prmclii6.c  __rax etc.                <ucontext.h>  _XOPEN_SOURCE
+ *
+ * It is not possible to localize these feature specifications around
+ * the individual headers: all headers share a common set of features
+ * (via <sys/cdefs.h>) and so all sources in the same compilation unit
+ * must turn on the same set of features.
+ */
+
+#if defined(MPS_OS_XC)
+
+#if !defined(_XOPEN_SOURCE)
+#define _XOPEN_SOURCE
+#endif
+
+#endif
+
+
+/* Almost all of protxc.c etc. are architecture-independent, but unfortunately
+   the Mach headers don't provide architecture neutral symbols for simple
+   things like thread states.  These definitions fix that. */
+
+#if defined(MPS_OS_XC)
+#if defined(MPS_ARCH_A6)
+
+#define THREAD_STATE_COUNT ARM_THREAD_STATE64_COUNT
+#define THREAD_STATE_FLAVOR ARM_THREAD_STATE64
+#define THREAD_STATE_S arm_thread_state64_t
+
+#elif defined(MPS_ARCH_I6)
+
+#define THREAD_STATE_COUNT x86_THREAD_STATE64_COUNT
+#define THREAD_STATE_FLAVOR x86_THREAD_STATE64
+#define THREAD_STATE_S x86_thread_state64_t
+
+#elif defined(MPS_ARCH_I3)
+
+#define THREAD_STATE_COUNT x86_THREAD_STATE32_COUNT
+#define THREAD_STATE_FLAVOR x86_THREAD_STATE32
+#define THREAD_STATE_S x86_thread_state32_t
+
+#else
+
+#error "Unknown macOS architecture"
+
+#endif
+#endif
+
+
+/* POSIX thread extensions configuration -- see <code/pthrdext.c> */
+
+#if defined(MPS_OS_LI) || defined(MPS_OS_FR)
+
+/* PTHREADEXT_SIGSUSPEND -- signal used to suspend a thread
+ * <design/pthreadext#.impl.signals>
+ */
+#if defined(CONFIG_PTHREADEXT_SIGSUSPEND)
+#define PTHREADEXT_SIGSUSPEND CONFIG_PTHREADEXT_SIGSUSPEND
+#else
+#define PTHREADEXT_SIGSUSPEND SIGXFSZ
+#endif
+
+/* PTHREADEXT_SIGRESUME -- signal used to resume a thread
+ * <design/pthreadext#.impl.signals>
+ */
+#if defined(CONFIG_PTHREADEXT_SIGRESUME)
+#define PTHREADEXT_SIGRESUME CONFIG_PTHREADEXT_SIGRESUME
+#else
+#define PTHREADEXT_SIGRESUME SIGXCPU
+#endif
+
+#endif
+
+
+/* Tracer Configuration -- see <code/trace.c> */
+
+#define TraceLIMIT ((size_t)1)
+/* I count 4 function calls to scan, 10 to copy. */
+#define TraceCopyScanRATIO (1.5)
+
+
+/* Events
+ *
+ * EventBufferSIZE is the number of words in the global event buffer.
+ */
+
+#define EventBufferSIZE ((size_t)4096)
+#define EventStringLengthMAX ((size_t)255) /* Not including NUL */
+
+
+/* Assert Buffer */
+
+#define ASSERT_BUFFER_SIZE      ((Size)512)
+
+
+/* memory operator configuration
+ *
+ * We need efficient operators similar to memcpy, memset, and memcmp.
+ * In general, we cannot use the C library mem functions directly as
+ * that would not be freestanding.  However, on some platforms we can do
+ * this, because they are inlined by the compiler and so do not actually
+ * create a dependence on an external library.
+ */
+
+#if defined(MPS_PF_W3I3MV)
+/* MSVC on Intel inlines mem* when optimizing */
+#define mps_lib_memset(p, c, l) memset(p, c, l)
+#define mps_lib_memcpy(p, q, s) memcpy(p, q, s)
+#define mps_lib_memcmp(p, q, s) memcmp(p, q, s)
+/* get prototypes for ANSI mem* */
+#include <string.h>
+#endif
+
+
+/* Product Configuration
+ *
+ * Deprecated, see design/config/#req.prod>.  This now only contains the
+ * configuration used by the former "MPS" product, which is now the only
+ * product.
+ */
+
+#define MPS_PROD_STRING         "mps"
+#define MPS_PROD_MPS
+
+
+/* Default chain for GC pools
+ *
+ * TODO: The default should be to measure liveness and make sensible
+ * decisions. See job003794.
+ */
+
+#define ChainDEFAULT \
+  { \
+    {  8 * 1024, 0.85 }, /* nursery */ \
+    { 36 * 1024, 0.45 }  /* second gen, after which dynamic */ \
+  }
+
+
+/* Write barrier deferral
+ *
+ * <design/write-barrier#.deferral>.
+ *
+ * TODO: These settings were determined by trial and error, but should
+ * be based on measurement of the protection overhead on each
+ * platform.  We know it's extremely different between macOS and
+ * Windows, for example.  <design/write-barrier#.improv.by-os>.
+ *
+ * TODO: Consider basing the count on the amount of time that has
+ * passed in the mutator rather than the number of scans.
+ */
+
+#define WB_DEFER_BITS  2  /* bitfield width for deferral count */
+#define WB_DEFER_INIT  3  /* boring scans after new segment */
+#define WB_DEFER_DELAY 3  /* boring scans after interesting scan */
+#define WB_DEFER_HIT   1  /* boring scans after barrier hit */
+
+
+/* Apple Hardened Runtime
+ *
+ * The MAYBE_HARDENED_RUNTIME macro is true if Apple's "Hardened
+ * Runtime" feature may be enabled, and so calls to mmap() and
+ * mprotect() with PROT_WRITE | PROT_EXEC may fail with EACCES.
+ * See <design/prot#impl.xc.prot.exec> for details.
+ */
+#if defined(MPS_OS_XC) && defined(MPS_ARCH_A6)
+#define MAYBE_HARDENED_RUNTIME 1
+#else
+#define MAYBE_HARDENED_RUNTIME 0
+#endif
+
+#endif /* config_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/dbgpool.c

@@ -0,0 +1,813 @@
+/* dbgpool.c: POOL DEBUG MIXIN
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ *
+ * .source: <design/object-debug>
+ */
+
+#include "dbgpool.h"
+#include "poolmfs.h"
+#include "splay.h"
+#include "mpm.h"
+#include <stdarg.h>
+
+SRCID(dbgpool, "$Id$");
+
+
+/* tagStruct -- tags for storing info about allocated objects */
+
+typedef struct tagStruct {
+  /* We don't want to pay the expense of a sig in every tag */
+  Addr addr;
+  Size size;
+  TreeStruct treeStruct;
+  char userdata[1 /* actually variable length */];
+} tagStruct;
+
+#define TagTree(tag)    (&(tag)->treeStruct)
+#define TagOfTree(tree) TREE_ELT(tag, treeStruct, tree)
+
+typedef tagStruct *Tag;
+
+
+/* tag init methods: copying the user-supplied data into the tag */
+
+static void TagTrivInit(void* tag, va_list args)
+{
+  UNUSED(tag); UNUSED(args);
+}
+
+
+/* TagComp -- splay comparison function for address ordering of tags */
+
+static Compare TagCompare(Tree node, TreeKey key)
+{
+  Addr addr1, addr2;
+
+  addr1 = *(Addr *)key;
+  addr2 = TagOfTree(node)->addr;
+  if (addr1 < addr2)
+    return CompareLESS;
+  else if (addr1 > addr2) {
+    /* Check key is not inside the object of this tag */
+    AVER_CRITICAL(AddrAdd(addr2, TagOfTree(node)->size) <= addr1);
+    return CompareGREATER;
+  } else
+    return CompareEQUAL;
+}
+
+static TreeKey TagKey(Tree node)
+{
+  return &TagOfTree(node)->addr;
+}
+
+
+/* PoolDebugMixinCheck -- check a PoolDebugMixin */
+
+Bool PoolDebugMixinCheck(PoolDebugMixin debug)
+{
+  /* Nothing to check about fenceTemplate */
+  /* Nothing to check about fenceSize */
+  /* Nothing to check about freeTemplate */
+  /* Nothing to check about freeSize */
+  if (debug->tagInit != NULL) {
+    CHECKL(FUNCHECK(debug->tagInit));
+    /* Nothing to check about tagSize */
+    CHECKD(Pool, debug->tagPool);
+    CHECKL(COMPATTYPE(Addr, void*)); /* tagPool relies on this */
+    /* Nothing to check about missingTags */
+    CHECKD(SplayTree, &debug->index);
+  }
+  UNUSED(debug); /* see <code/mpm.c#check.unused> */
+  return TRUE;
+}
+
+
+/* DebugPoolDebugMixin -- gets the debug mixin, if any */
+
+#define DebugPoolDebugMixin(pool) (Method(Pool, pool, debugMixin)(pool))
+
+
+/* PoolNoDebugMixin -- debug mixin methods for pools with no mixin */
+
+PoolDebugMixin PoolNoDebugMixin(Pool pool)
+{
+  AVERT(Pool, pool);
+  return NULL;
+}
+
+
+/* PoolDebugOptionsCheck -- check a PoolDebugOptions */
+
+Bool PoolDebugOptionsCheck(PoolDebugOptions opt)
+{
+  CHECKL(opt != NULL);
+  if (opt->fenceSize != 0) {
+    CHECKL(opt->fenceTemplate != NULL);
+    /* Nothing to check about fenceSize */
+  }
+  if (opt->freeSize != 0) {
+    CHECKL(opt->freeTemplate != NULL);
+    /* Nothing to check about freeSize */
+  }
+  return TRUE;
+}
+
+
+/* DebugPoolInit -- init method for a debug pool
+ *
+ * Someday, this could be split into fence and tag init methods.
+ */
+
+ARG_DEFINE_KEY(POOL_DEBUG_OPTIONS, PoolDebugOptions);
+
+static PoolDebugOptionsStruct debugPoolOptionsDefault = {
+  "POST", 4, "DEAD", 4,
+};
+
+static Res DebugPoolInit(Pool pool, Arena arena, PoolClass klass, ArgList args)
+{
+  Res res;
+  PoolDebugOptions options = &debugPoolOptionsDefault;
+  PoolDebugMixin debug;
+  TagInitFunction tagInit;
+  Size tagSize;
+  ArgStruct arg;
+
+  AVER(pool != NULL);
+  AVERT(Arena, arena);
+  AVERT(PoolClass, klass);
+  AVERT(ArgList, args);
+
+  if (ArgPick(&arg, args, MPS_KEY_POOL_DEBUG_OPTIONS))
+    options = (PoolDebugOptions)arg.val.pool_debug_options;
+
+  AVERT(PoolDebugOptions, options);
+
+  /* @@@@ Tag parameters should be taken from options, but tags have */
+  /* not been published yet. */
+  tagInit = NULL; tagSize = 0;
+
+  res = SuperclassPoly(Pool, klass)->init(pool, arena, klass, args);
+  if (res != ResOK)
+    return res;
+
+  SetClassOfPoly(pool, klass);
+  debug = DebugPoolDebugMixin(pool);
+  AVER(debug != NULL);
+
+  /* fencepost init */
+  /* @@@@ This parses a user argument, options, so it should really */
+  /* go through the MPS interface.  The template needs to be copied */
+  /* into Addr memory, to avoid breaking <design/type#.addr.use>. */
+  debug->fenceSize = options->fenceSize;
+  if (debug->fenceSize != 0) {
+    /* Fenceposting turns on tagging */
+    if (tagInit == NULL) {
+      tagSize = 0;
+      tagInit = TagTrivInit;
+    }
+    debug->fenceTemplate = options->fenceTemplate;
+  }
+
+  /* free-checking init */
+  /* @@@@ This parses a user argument, options, so it should really */
+  /* go through the MPS interface.  The template needs to be copied */
+  /* into Addr memory, to avoid breaking <design/type#addr.use>. */
+  debug->freeSize = options->freeSize;
+  if (debug->freeSize != 0) {
+    debug->freeTemplate = options->freeTemplate;
+  }
+
+  /* tag init */
+  debug->tagInit = tagInit;
+  if (debug->tagInit != NULL) {
+    debug->tagSize = tagSize + sizeof(tagStruct) - 1;
+    /* This pool has to be like the arena control pool: the blocks */
+    /* allocated must be accessible using void*. */
+    MPS_ARGS_BEGIN(pcArgs) {
+      /* By setting EXTEND_BY to debug->tagSize we get the smallest
+         possible extensions compatible with the tags, and so the
+         least amount of wasted space. */
+      MPS_ARGS_ADD(pcArgs, MPS_KEY_EXTEND_BY, debug->tagSize);
+      MPS_ARGS_ADD(pcArgs, MPS_KEY_MFS_UNIT_SIZE, debug->tagSize);
+      res = PoolCreate(&debug->tagPool, PoolArena(pool), PoolClassMFS(), pcArgs);
+    } MPS_ARGS_END(pcArgs);
+    if (res != ResOK)
+      goto tagFail;
+    debug->missingTags = 0;
+    SplayTreeInit(&debug->index, TagCompare, TagKey, SplayTrivUpdate);
+  }
+
+  debug->sig = PoolDebugMixinSig;
+  AVERT(PoolDebugMixin, debug);
+  return ResOK;
+
+tagFail:
+  SuperclassPoly(Inst, klass)->finish(MustBeA(Inst, pool));
+  AVER(res != ResOK);
+  return res;
+}
+
+
+/* DebugPoolFinish -- finish method for a debug pool */
+
+static void DebugPoolFinish(Inst inst)
+{
+  Pool pool = MustBeA(AbstractPool, inst);
+  PoolDebugMixin debug;
+  PoolClass klass;
+
+  AVERT(Pool, pool);
+
+  debug = DebugPoolDebugMixin(pool);
+  AVER(debug != NULL);
+  AVERT(PoolDebugMixin, debug);
+  if (debug->tagInit != NULL) {
+    SplayTreeFinish(&debug->index);
+    PoolDestroy(debug->tagPool);
+  }
+  klass = ClassOfPoly(Pool, pool);
+  SuperclassPoly(Inst, klass)->finish(inst);
+}
+
+
+/* patternIterate -- call visitor for occurrences of pattern between
+ * base and limit
+ *
+ * pattern is an arbitrary pattern that's size bytes long.
+ *
+ * Imagine that the entirety of memory were covered by contiguous
+ * copies of pattern starting at address 0. Then call visitor for each
+ * copy (or part) of pattern that lies between base and limit. In each
+ * call, target is the address of the copy or part (where base <=
+ * target < limit); source is the corresponding byte of the pattern
+ * (where pattern <= source < pattern + size); and size is the length
+ * of the copy or part.
+ */
+
+typedef Bool (*patternVisitor)(Addr target, ReadonlyAddr source, Size size);
+
+static Bool patternIterate(ReadonlyAddr pattern, Size size,
+                           Addr base, Addr limit, patternVisitor visitor)
+{
+  Addr p;
+
+  AVER(pattern != NULL);
+  AVER(0 < size);
+  AVER(base != NULL);
+  AVER(base <= limit);
+
+  p = base;
+  while (p < limit) {
+    Addr end = AddrAdd(p, size);
+    Addr rounded = AddrRoundUp(p, size);
+    Size offset = (Word)p % size;
+    if (end < p || rounded < p) {
+      /* Address range overflow */
+      break;
+    } else if (p == rounded && end <= limit) {
+      /* Room for a whole copy */
+      if (!(*visitor)(p, pattern, size))
+        return FALSE;
+      p = end;
+    } else if (p < rounded && rounded <= end && rounded <= limit) {
+      /* Copy up to rounded */
+      if (!(*visitor)(p, ReadonlyAddrAdd(pattern, offset),
+                      AddrOffset(p, rounded)))
+        return FALSE;
+      p = rounded;
+    } else {
+      /* Copy up to limit */
+      AVER(limit <= end);
+      AVER(p == rounded || limit <= rounded);
+      if (!(*visitor)(p, ReadonlyAddrAdd(pattern, offset),
+                      AddrOffset(p, limit)))
+        return FALSE;
+      p = limit;
+    }
+  }
+
+  return TRUE;
+}
+
+
+/* patternCopy -- copy pattern to fill a range
+ *
+ * Fill the range of addresses from base (inclusive) to limit
+ * (exclusive) with copies of pattern (which is size bytes long).
+ */
+
+static Bool patternCopyVisitor(Addr target, ReadonlyAddr source, Size size)
+{
+  (void)AddrCopy(target, source, size);
+  return TRUE;
+}
+
+static void patternCopy(ReadonlyAddr pattern, Size size, Addr base, Addr limit)
+{
+  (void)patternIterate(pattern, size, base, limit, patternCopyVisitor);
+}
+
+
+/* patternCheck -- check pattern against a range
+ *
+ * Compare the range of addresses from base (inclusive) to limit
+ * (exclusive) with copies of pattern (which is size bytes long). The
+ * copies of pattern must be arranged so that fresh copies start at
+ * aligned addresses wherever possible.
+ */
+
+static Bool patternCheckVisitor(Addr target, ReadonlyAddr source, Size size)
+{
+  return AddrComp(target, source, size) == 0;
+}
+
+static Bool patternCheck(ReadonlyAddr pattern, Size size, Addr base, Addr limit)
+{
+  return patternIterate(pattern, size, base, limit, patternCheckVisitor);
+}
+
+
+/* debugPoolSegIterate -- iterate over a range of segments in an arena
+ *
+ * Expects to be called on a range corresponding to objects within a
+ * single pool.
+ *
+ * NOTE: This relies on pools consistently using segments
+ * contiguously.
+ */
+
+static void debugPoolSegIterate(Arena arena, Addr base, Addr limit,
+                                void (*visitor)(Arena, Seg))
+{
+  Seg seg;
+
+  if (SegOfAddr(&seg, arena, base)) {
+    do {
+      base = SegLimit(seg);
+      (*visitor)(arena, seg);
+    } while (base < limit && SegOfAddr(&seg, arena, base));
+    AVER(base >= limit); /* shouldn't run out of segments */
+  }
+}
+
+static void debugPoolShieldExpose(Arena arena, Seg seg)
+{
+  ShieldExpose(arena, seg);
+}
+
+static void debugPoolShieldCover(Arena arena, Seg seg)
+{
+  ShieldCover(arena, seg);
+}
+
+
+/* freeSplat -- splat free block with splat pattern */
+
+static void freeSplat(PoolDebugMixin debug, Pool pool, Addr base, Addr limit)
+{
+  Arena arena;
+
+  AVER(base < limit);
+
+  /* If the block is in one or more segments, make sure the segments
+     are exposed so that we can overwrite the block with the pattern. */
+  arena = PoolArena(pool);
+  debugPoolSegIterate(arena, base, limit, debugPoolShieldExpose);
+  patternCopy(debug->freeTemplate, debug->freeSize, base, limit);
+  debugPoolSegIterate(arena, base, limit, debugPoolShieldCover);
+}
+
+
+/* freeCheck -- check free block for splat pattern */
+
+static Bool freeCheck(PoolDebugMixin debug, Pool pool, Addr base, Addr limit)
+{
+  Bool res;
+  Arena arena;
+
+  AVER(base < limit);
+
+  /* If the block is in one or more segments, make sure the segments
+     are exposed so we can read the pattern. */
+  arena = PoolArena(pool);
+  debugPoolSegIterate(arena, base, limit, debugPoolShieldExpose);
+  res = patternCheck(debug->freeTemplate, debug->freeSize, base, limit);
+  debugPoolSegIterate(arena, base, limit, debugPoolShieldCover);
+  return res;
+}
+
+
+/* freeCheckAlloc -- allocation wrapper for free-checking */
+
+static Res freeCheckAlloc(Addr *aReturn, PoolDebugMixin debug, Pool pool,
+                          Size size)
+{
+  Res res;
+  Addr new;
+  PoolClass klass;
+
+  AVER(aReturn != NULL);
+
+  klass = ClassOfPoly(Pool, pool);
+  res = SuperclassPoly(Pool, klass)->alloc(&new, pool, size);
+  if (res != ResOK)
+    return res;
+  if (debug->freeSize != 0)
+    ASSERT(freeCheck(debug, pool, new, AddrAdd(new, size)),
+           "free space corrupted on alloc");
+
+  *aReturn = new;
+  return res;
+}
+
+
+/* freeCheckFree -- freeing wrapper for free-checking */
+
+static void freeCheckFree(PoolDebugMixin debug,
+                          Pool pool, Addr old, Size size)
+{
+  PoolClass klass;
+  if (debug->freeSize != 0)
+    freeSplat(debug, pool, old, AddrAdd(old, size));
+  klass = ClassOfPoly(Pool, pool);
+  SuperclassPoly(Pool, klass)->free(pool, old, size);
+}
+
+
+/* fenceAlloc -- allocation wrapper for fenceposts
+ *
+ * Allocates an object, adding fenceposts on both sides.  Layout:
+ *
+ * |----------|-------------------------------------|------|----------|
+ *   start fp              client object              slop    end fp
+ *
+ * slop is the extra allocation from rounding up the client request to
+ * the pool's alignment. The fenceposting code adds this slop so that
+ * there's a better chance of the end fencepost being flush with the
+ * next object (though it can't be guaranteed, since the underlying
+ * pool could have allocated an even larger block). The alignment slop
+ * is filled from the fencepost template as well.
+ *
+ * Keep in sync with fenceCheck.
+ */
+
+static Res fenceAlloc(Addr *aReturn, PoolDebugMixin debug, Pool pool,
+                      Size size)
+{
+  Res res;
+  Addr obj, startFence, clientNew, clientLimit, limit;
+  Size alignedFenceSize, alignedSize;
+
+  AVER(aReturn != NULL);
+  AVERT(PoolDebugMixin, debug);
+  AVERT(Pool, pool);
+
+  alignedFenceSize = SizeAlignUp(debug->fenceSize, PoolAlignment(pool));
+  alignedSize = SizeAlignUp(size, PoolAlignment(pool));
+  res = freeCheckAlloc(&obj, debug, pool,
+                       alignedSize + 2 * alignedFenceSize);
+  if (res != ResOK)
+    return res;
+
+  startFence = obj;
+  clientNew = AddrAdd(startFence, alignedFenceSize);
+  clientLimit = AddrAdd(clientNew, size);
+  limit = AddrAdd(clientNew, alignedSize + alignedFenceSize);
+
+  /* @@@@ shields? */
+  patternCopy(debug->fenceTemplate, debug->fenceSize, startFence, clientNew);
+  patternCopy(debug->fenceTemplate, debug->fenceSize, clientLimit, limit);
+
+  *aReturn = clientNew;
+  return ResOK;
+}
+
+
+/* fenceCheck -- check fences of an object
+ *
+ * Keep in sync with fenceAlloc.
+ */
+
+static Bool fenceCheck(PoolDebugMixin debug, Pool pool, Addr obj, Size size)
+{
+  Addr startFence, clientNew, clientLimit, limit;
+  Size alignedFenceSize, alignedSize;
+
+  AVERT_CRITICAL(PoolDebugMixin, debug);
+  AVERT_CRITICAL(Pool, pool);
+  /* Can't check obj */
+
+  alignedFenceSize = SizeAlignUp(debug->fenceSize, PoolAlignment(pool));
+  alignedSize = SizeAlignUp(size, PoolAlignment(pool));
+
+  startFence = AddrSub(obj, alignedFenceSize);
+  clientNew = obj;
+  clientLimit = AddrAdd(clientNew, size);
+  limit = AddrAdd(clientNew, alignedSize + alignedFenceSize);
+
+  /* @@@@ shields? */
+  return patternCheck(debug->fenceTemplate, debug->fenceSize,
+                      startFence, clientNew)
+    && patternCheck(debug->fenceTemplate, debug->fenceSize,
+                    clientLimit, limit);
+}
+
+
+/* fenceFree -- freeing wrapper for fenceposts */
+
+static void fenceFree(PoolDebugMixin debug,
+                      Pool pool, Addr old, Size size)
+{
+  Size alignedFenceSize, alignedSize;
+
+  ASSERT(fenceCheck(debug, pool, old, size), "fencepost check on free"); /* <design/check/#.common> */
+
+  alignedFenceSize = SizeAlignUp(debug->fenceSize, PoolAlignment(pool));
+  alignedSize = SizeAlignUp(size, PoolAlignment(pool));
+  freeCheckFree(debug, pool, AddrSub(old, alignedFenceSize),
+                alignedSize + 2 * alignedFenceSize);
+}
+
+
+/* tagAlloc -- allocation wrapper for tagged pools */
+
+static Res tagAlloc(PoolDebugMixin debug,
+                    Pool pool, Addr new, Size size)
+{
+  Tag tag;
+  Res res;
+  Bool b;
+  Addr addr;
+
+  UNUSED(pool);
+  res = PoolAlloc(&addr, debug->tagPool, debug->tagSize);
+  if (res != ResOK)
+    return res;
+  tag = (Tag)addr;
+  tag->addr = new; tag->size = size;
+  TreeInit(TagTree(tag));
+  /* In the future, we might call debug->tagInit here. */
+  b = SplayTreeInsert(&debug->index, TagTree(tag));
+  AVER(b);
+  return ResOK;
+}
+
+
+/* tagFree -- deallocation wrapper for tagged pools */
+
+static void tagFree(PoolDebugMixin debug, Pool pool, Addr old, Size size)
+{
+  Tree node;
+  Tag tag;
+  Bool b;
+
+  AVERT(PoolDebugMixin, debug);
+  AVERT(Pool, pool);
+  AVER(size > 0);
+
+  if (!SplayTreeFind(&node, &debug->index, &old)) {
+    AVER(debug->missingTags > 0);
+    debug->missingTags--;
+    return;
+  }
+  tag = TagOfTree(node);
+  AVER(tag->size == size);
+  AVER(tag->addr == old);
+  b = SplayTreeDelete(&debug->index, node);
+  AVER(b); /* expect tag to be in the tree */
+  TreeFinish(node);
+  PoolFree(debug->tagPool, (Addr)tag, debug->tagSize);
+}
+
+
+/* DebugPoolAlloc -- alloc method for a debug pool
+ *
+ * Eventually, tag init args will need to be handled somewhere here.
+ */
+
+static Res DebugPoolAlloc(Addr *aReturn, Pool pool, Size size)
+{
+  Res res;
+  Addr new = NULL; /* suppress "may be used uninitialized" warning */
+  PoolDebugMixin debug;
+
+  AVER(aReturn != NULL);
+  AVERT(Pool, pool);
+  AVER(size > 0);
+
+  debug = DebugPoolDebugMixin(pool);
+  AVER(debug != NULL);
+  AVERT(PoolDebugMixin, debug);
+  if (debug->fenceSize != 0)
+    res = fenceAlloc(&new, debug, pool, size);
+  else
+    res = freeCheckAlloc(&new, debug, pool, size);
+  if (res != ResOK)
+    return res;
+  /* Allocate object first, so it fits even when the tag doesn't. */
+  if (debug->tagInit != NULL) {
+    res = tagAlloc(debug, pool, new, size);
+    if (res != ResOK)
+      goto tagFail;
+  }
+
+  *aReturn = new;
+  return res;
+
+tagFail:
+  fenceFree(debug, pool, new, size);
+  return res;
+}
+
+
+/* DebugPoolFree -- free method for a debug pool */
+
+static void DebugPoolFree(Pool pool, Addr old, Size size)
+{
+  PoolDebugMixin debug;
+
+  AVERT(Pool, pool);
+  /* Can't check old */
+  AVER(size > 0);
+
+  debug = DebugPoolDebugMixin(pool);
+  AVER(debug != NULL);
+  AVERT(PoolDebugMixin, debug);
+
+  if (debug->fenceSize != 0)
+    fenceFree(debug, pool, old, size);
+  else
+    freeCheckFree(debug, pool, old, size);
+  /* Free the object first, to get fences checked before tag. */
+  if (debug->tagInit != NULL)
+    tagFree(debug, pool, old, size);
+}
+
+
+/* TagWalk -- walk all objects in the pool using tags */
+
+typedef void (*ObjectsVisitor)(Addr addr, Size size, Format fmt,
+                               Pool pool, void *tagData, void *p);
+
+static void TagWalk(Pool pool, ObjectsVisitor visitor, void *p)
+{
+  Tree node;
+  PoolDebugMixin debug;
+
+  AVERT(Pool, pool);
+  AVER(FUNCHECK(visitor));
+  /* Can't check p */
+
+  debug = DebugPoolDebugMixin(pool);
+  AVER(debug != NULL);
+  AVERT(PoolDebugMixin, debug);
+
+  node = SplayTreeFirst(&debug->index);
+  while (node != TreeEMPTY) {
+    Tag tag = TagOfTree(node);
+
+    (*visitor)(tag->addr, tag->size, NULL, pool, &tag->userdata, p);
+    node = SplayTreeNext(&debug->index, &tag->addr);
+  }
+}
+
+
+/* fenceCheckingStep -- step function for DebugPoolCheckFences */
+
+static void fenceCheckingStep(Addr addr, Size size, Format fmt,
+                              Pool pool, void *tagData, void *p)
+{
+  /* no need to check arguments checked in the caller */
+  UNUSED(fmt); UNUSED(tagData);
+  ASSERT(fenceCheck((PoolDebugMixin)p, pool, addr, size),
+         "fencepost check requested by client");
+}
+
+
+/* DebugPoolCheckFences -- check all the fenceposts in the pool */
+
+void DebugPoolCheckFences(Pool pool)
+{
+  PoolDebugMixin debug;
+
+  AVERT(Pool, pool);
+  debug = DebugPoolDebugMixin(pool);
+  if (debug == NULL)
+    return;
+  AVERT(PoolDebugMixin, debug);
+
+  if (debug->fenceSize != 0)
+    TagWalk(pool, fenceCheckingStep, (void *)debug);
+}
+
+
+/* DebugPoolFreeSplat -- if in a free-checking debug pool, splat free block */
+
+void DebugPoolFreeSplat(Pool pool, Addr base, Addr limit)
+{
+  PoolDebugMixin debug;
+
+  AVERT(Pool, pool);
+  AVER(PoolHasAddr(pool, base));
+  AVER(PoolHasAddr(pool, AddrSub(limit, 1)));
+
+  debug = DebugPoolDebugMixin(pool);
+  if (debug != NULL) {
+    AVERT(PoolDebugMixin, debug);
+    if (debug->freeSize != 0)
+      freeSplat(debug, pool, base, limit);
+  }
+}
+
+
+/* DebugPoolFreeCheck -- if in a free-checking debug pool, check free block */
+
+void DebugPoolFreeCheck(Pool pool, Addr base, Addr limit)
+{
+  PoolDebugMixin debug;
+
+  AVERT(Pool, pool);
+  AVER(PoolHasAddr(pool, base));
+  AVER(PoolHasAddr(pool, AddrSub(limit, 1)));
+
+  debug = DebugPoolDebugMixin(pool);
+  if (debug != NULL) {
+    AVERT(PoolDebugMixin, debug);
+    if (debug->freeSize != 0)
+      ASSERT(freeCheck(debug, pool, base, limit),
+             "free space corrupted on release"); /* <design/check/#.common> */
+  }
+}
+
+
+/* freeCheckingStep -- step function for DebugPoolCheckFreeSpace */
+
+static void freeCheckingStep(Addr base, Addr limit, Pool pool, void *p)
+{
+  /* no need to check arguments checked in the caller */
+  ASSERT(freeCheck((PoolDebugMixin)p, pool, base, limit),
+         "free space corrupted on client check");
+}
+
+
+/* DebugPoolCheckFreeSpace -- check free space in the pool for overwrites */
+
+void DebugPoolCheckFreeSpace(Pool pool)
+{
+  PoolDebugMixin debug;
+
+  AVERT(Pool, pool);
+  debug = DebugPoolDebugMixin(pool);
+  if (debug == NULL)
+    return;
+  AVERT(PoolDebugMixin, debug);
+
+  if (debug->freeSize != 0)
+    PoolFreeWalk(pool, freeCheckingStep, (void *)debug);
+}
+
+
+/* PoolClassMixInDebug -- mix in the debug support for class init */
+
+void PoolClassMixInDebug(PoolClass klass)
+{
+  /* Can't check klass because it's not initialized yet */
+  klass->instClassStruct.finish = DebugPoolFinish;
+  klass->init = DebugPoolInit;
+  klass->alloc = DebugPoolAlloc;
+  klass->free = DebugPoolFree;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/dbgpool.h

@@ -0,0 +1,101 @@
+/* dbgpool.h: POOL DEBUG MIXIN
+ *
+ * <design/object-debug>.
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ */
+
+#ifndef dbgpool_h
+#define dbgpool_h
+
+#include "splay.h"
+#include "mpmtypes.h"
+#include <stdarg.h>
+
+
+/* tag init function: copies the user-supplied data into the tag */
+
+typedef void (*TagInitFunction)(void *tag, va_list args);
+
+
+/* PoolDebugOptions -- option structure for debug pool init
+ *
+ * This must be kept in sync with <code/mps.h#mps_pool_debug_option_s>.
+ */
+
+typedef struct PoolDebugOptionsStruct {
+  const void *fenceTemplate;
+  Size  fenceSize;
+  const void *freeTemplate;
+  Size  freeSize;
+  /* TagInitFunction tagInit; */
+  /* Size  tagSize; */
+} PoolDebugOptionsStruct;
+
+typedef PoolDebugOptionsStruct *PoolDebugOptions;
+
+
+/* PoolDebugMixinStruct -- internal structure for debug mixins */
+
+#define PoolDebugMixinSig ((Sig)0x519B0DB9)  /* SIGnature POol DeBuG */
+
+typedef struct PoolDebugMixinStruct {
+  Sig sig; /* design.mps.sig.field */
+  const struct AddrStruct *fenceTemplate;
+  Size fenceSize;
+  const struct AddrStruct *freeTemplate;
+  Size freeSize;
+  TagInitFunction tagInit;
+  Size tagSize;
+  Pool tagPool;
+  Count missingTags;
+  SplayTreeStruct index;
+} PoolDebugMixinStruct;
+
+
+extern Bool PoolDebugOptionsCheck(PoolDebugOptions opt);
+
+extern Bool PoolDebugMixinCheck(PoolDebugMixin dbg);
+
+extern void PoolClassMixInDebug(PoolClass klass);
+
+extern void DebugPoolCheckFences(Pool pool);
+extern void DebugPoolCheckFreeSpace(Pool pool);
+
+extern void DebugPoolFreeSplat(Pool pool, Addr base, Addr limit);
+extern void DebugPoolFreeCheck(Pool pool, Addr base, Addr limit);
+
+
+#endif /* dbgpool_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/dbgpooli.c

@@ -0,0 +1,84 @@
+/* dbgpooli.c: POOL DEBUG MIXIN C INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ *
+ * .source: <design/object-debug>
+ */
+
+#include "dbgpool.h"
+#include "mps.h"
+#include "mpm.h"
+
+SRCID(dbgpooli, "$Id$");
+
+
+/* mps_pool_check_fenceposts -- check all the fenceposts in the pool */
+
+void mps_pool_check_fenceposts(mps_pool_t mps_pool)
+{
+  Pool pool = (Pool)mps_pool;
+  Arena arena;
+
+  /* TESTT not AVERT, see <design/interface-c#.check.space */
+  AVER(TESTT(Pool, pool));
+  arena = PoolArena(pool);
+
+  ArenaEnter(arena);
+
+  AVERT(Pool, pool);
+  DebugPoolCheckFences(pool);
+
+  ArenaLeave(arena);
+}
+
+
+/* mps_pool_check_free_space -- check free space in the pool for overwrites */
+
+void mps_pool_check_free_space(mps_pool_t mps_pool)
+{
+  Pool pool = (Pool)mps_pool;
+  Arena arena;
+
+  /* TESTT not AVERT, see <design/interface-c#.check.space */
+  AVER(TESTT(Pool, pool));
+  arena = PoolArena(pool);
+
+  ArenaEnter(arena);
+
+  AVERT(Pool, pool);
+  DebugPoolCheckFreeSpace(pool);
+
+  ArenaLeave(arena);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/djbench.c

@@ -0,0 +1,423 @@
+/* djbench.c -- "DJ" Benchmark on ANSI C library
+ *
+ * $Id$
+ * Copyright (c) 2013-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * This is an allocation stress benchmark test for manual variable pools
+ * and also for stdlib malloc/free (for comparison).
+ *
+ * It repeatedly runs over an array of blocks and allocates or frees them
+ * with some probability, then frees all the remaining blocks at the end.
+ * This test can be iterated.
+ */
+
+#include "mps.c"
+
+#include "testlib.h"
+#include "testthr.h"
+
+#ifdef MPS_OS_W3
+#include "getopt.h"
+#else
+#include <getopt.h>
+#endif
+
+#include <stdio.h> /* fprintf, stderr */
+#include <stdlib.h> /* alloca, exit, EXIT_SUCCESS, EXIT_FAILURE */
+#include <time.h> /* CLOCKS_PER_SEC, clock */
+
+#define DJMUST(expr) \
+  do { \
+    mps_res_t res = (expr); \
+    if (res != MPS_RES_OK) { \
+      fprintf(stderr, #expr " returned %d\n", res); \
+      exit(EXIT_FAILURE); \
+    } \
+  } while(0)
+
+static mps_arena_t arena;
+static mps_pool_t pool;
+
+
+/* The benchmark behaviour is defined as a macro in order to give realistic
+   opportunities for compiler optimisation and the intended inlining of the
+   MPS functions. */
+
+static rnd_state_t seed = 0;      /* random number seed */
+static unsigned nthreads = 1;     /* threads */
+static unsigned niter = 50;       /* iterations */
+static unsigned npass = 100;      /* passes over blocks */
+static unsigned nblocks = 64;     /* number of blocks */
+static unsigned sshift = 18;      /* log2 max block size in words */
+static double pact = 0.2;         /* probability per pass of acting */
+static unsigned rinter = 75;      /* pass interval for recursion */
+static unsigned rmax = 10;        /* maximum recursion depth */
+static mps_bool_t zoned = TRUE;   /* arena allocates using zones */
+static size_t arena_size = 256ul * 1024 * 1024; /* arena size */
+static size_t arena_grain_size = 1; /* arena grain size */
+static double spare = ARENA_SPARE_DEFAULT; /* spare commit fraction */
+
+#define DJRUN(fname, alloc, free) \
+  static unsigned fname##_inner(mps_ap_t ap, unsigned depth, unsigned r) { \
+    struct {void *p; size_t s;} *blocks = alloca(sizeof(blocks[0]) * nblocks); \
+    unsigned j, k; \
+    \
+    for (k = 0; k < nblocks; ++k) { \
+      blocks[k].p = NULL; \
+      blocks[k].s = 0; \
+    } \
+    \
+    for (j = 0; j < npass; ++j) { \
+      for (k = 0; k < nblocks; ++k) { \
+        if (rnd() % 16384 < pact * 16384) { \
+          if (blocks[k].p == NULL) { \
+            size_t s = rnd() % ((sizeof(void *) << (rnd() % sshift)) - 1); \
+            void *p = NULL; \
+            if (s > 0) \
+              alloc(p, s); \
+            blocks[k].p = p; \
+            blocks[k].s = s; \
+          } else { \
+            free(blocks[k].p, blocks[k].s); \
+            blocks[k].p = NULL; \
+          } \
+        } \
+      } \
+      if (rinter > 0 && depth > 0 && ++r % rinter == 0) { \
+        /* putchar('>'); fflush(stdout); */ \
+        r = fname##_inner(ap, depth - 1, r); \
+        /* putchar('<'); fflush(stdout); */ \
+      } \
+    } \
+    \
+    for (k = 0; k < nblocks; ++k) { \
+      if (blocks[k].p) { \
+        free(blocks[k].p, blocks[k].s); \
+        blocks[k].p = NULL; \
+      } \
+    } \
+    return r; \
+  } \
+  \
+  static void *fname(void *p) { \
+    unsigned i; \
+    mps_ap_t ap = NULL; \
+    if (pool != NULL) \
+      DJMUST(mps_ap_create_k(&ap, pool, mps_args_none)); \
+    for (i = 0; i < niter; ++i) \
+      (void)fname##_inner(ap, rmax, 0); \
+    if (ap != NULL) \
+      mps_ap_destroy(ap); \
+    return p; \
+  }
+
+
+/* malloc/free benchmark */
+
+#define MALLOC_ALLOC(p, s) do { p = malloc(s); } while(0)
+#define MALLOC_FREE(p, s)  do { free(p); } while(0)
+
+DJRUN(dj_malloc, MALLOC_ALLOC, MALLOC_FREE)
+
+
+/* mps_alloc/mps_free benchmark */
+
+#define MPS_ALLOC(p, s) do { mps_alloc(&p, pool, s); } while(0)
+#define MPS_FREE(p, s)  do { mps_free(pool, p, s); } while(0)
+
+DJRUN(dj_alloc, MPS_ALLOC, MPS_FREE)
+
+
+/* reserve/free benchmark */
+
+#define ALIGN_UP(s, a) (((s) + ((a) - 1)) & ~((a) - 1))
+#define RESERVE_ALLOC(p, s) \
+  do { \
+    size_t _s = ALIGN_UP(s, (size_t)MPS_PF_ALIGN); \
+    (void)mps_reserve(&p, ap, _s); \
+    (void)mps_commit(ap, p, _s); \
+  } while(0)
+#define RESERVE_FREE(p, s)  do { mps_free(pool, p, s); } while(0)
+
+DJRUN(dj_reserve, RESERVE_ALLOC, RESERVE_FREE)
+
+typedef void *(*dj_t)(void *);
+
+static void weave(dj_t dj)
+{
+  testthr_t *threads = alloca(sizeof(threads[0]) * nthreads);
+  unsigned t;
+
+  for (t = 0; t < nthreads; ++t)
+    testthr_create(&threads[t], dj, NULL);
+
+  for (t = 0; t < nthreads; ++t)
+    testthr_join(&threads[t], NULL);
+}
+
+
+static void watch(dj_t dj, const char *name)
+{
+  clock_t start, finish;
+
+  start = clock();
+  if (nthreads == 1)
+    dj(NULL);
+  else
+    weave(dj);
+  finish = clock();
+
+  printf("%s: %g\n", name, (double)(finish - start) / CLOCKS_PER_SEC);
+}
+
+
+/* Wrap a call to dj benchmark that doesn't require MPS setup */
+
+static void wrap(dj_t dj, mps_pool_class_t dummy, const char *name)
+{
+  (void)dummy;
+  pool = NULL;
+  watch(dj, name);
+}
+
+
+/* Wrap a call to a dj benchmark that requires MPS setup */
+
+static void arena_wrap(dj_t dj, mps_pool_class_t pool_class, const char *name)
+{
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, arena_size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, zoned);
+    MPS_ARGS_ADD(args, MPS_KEY_SPARE, spare);
+    DJMUST(mps_arena_create_k(&arena, mps_arena_class_vm(), args));
+  } MPS_ARGS_END(args);
+  DJMUST(mps_pool_create_k(&pool, arena, pool_class, mps_args_none));
+  watch(dj, name);
+  mps_pool_destroy(pool);
+  mps_arena_destroy(arena);
+}
+
+
+/* Command-line options definitions.  See getopt_long(3). */
+
+static struct option longopts[] = {
+  {"help",             no_argument,       NULL, 'h'},
+  {"nthreads",         required_argument, NULL, 't'},
+  {"niter",            required_argument, NULL, 'i'},
+  {"npass",            required_argument, NULL, 'p'},
+  {"nblocks",          required_argument, NULL, 'b'},
+  {"sshift",           required_argument, NULL, 's'},
+  {"pact",             required_argument, NULL, 'c'},
+  {"rinter",           required_argument, NULL, 'r'},
+  {"rmax",             required_argument, NULL, 'd'},
+  {"seed",             required_argument, NULL, 'x'},
+  {"arena-size",       required_argument, NULL, 'm'},
+  {"arena-grain-size", required_argument, NULL, 'a'},
+  {"arena-unzoned",    no_argument,       NULL, 'z'},
+  {"spare",            required_argument, NULL, 'S'},
+  {NULL,               0,                 NULL, 0  }
+};
+
+
+/* Test definitions. */
+
+static mps_pool_class_t dummy_class(void)
+{
+  return NULL;
+}
+
+static struct {
+  const char *name;
+  void (*wrap)(dj_t, mps_pool_class_t, const char *name);
+  dj_t dj;
+  mps_pool_class_t (*pool_class)(void);
+} pools[] = {
+  {"mvt",   arena_wrap, dj_reserve, mps_class_mvt},
+  {"mvff",  arena_wrap, dj_reserve, mps_class_mvff},
+  {"mvffa", arena_wrap, dj_alloc,   mps_class_mvff}, /* mvff with alloc */
+  {"an",    wrap,       dj_malloc,  dummy_class},
+};
+
+
+/* Command-line driver */
+
+int main(int argc, char *argv[])
+{
+  int ch;
+  unsigned i;
+  mps_bool_t seed_specified = FALSE;
+
+  seed = rnd_seed();
+
+  while ((ch = getopt_long(argc, argv, "ht:i:p:b:s:c:r:d:m:a:x:zS:",
+                           longopts, NULL)) != -1)
+    switch (ch) {
+    case 't':
+      nthreads = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'i':
+      niter = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'p':
+      npass = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'b':
+      nblocks = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 's':
+      sshift = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'c':
+      pact = strtod(optarg, NULL);
+      break;
+    case 'r':
+      rinter = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'd':
+      rmax = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'x':
+      seed = strtoul(optarg, NULL, 10);
+      seed_specified = TRUE;
+      break;
+    case 'z':
+      zoned = FALSE;
+      break;
+    case 'm': {
+        char *p;
+        arena_size = (unsigned)strtoul(optarg, &p, 10);
+        switch(toupper(*p)) {
+        case 'G': arena_size <<= 30; break;
+        case 'M': arena_size <<= 20; break;
+        case 'K': arena_size <<= 10; break;
+        case '\0': break;
+        default:
+          fprintf(stderr, "Bad arena size %s\n", optarg);
+          return EXIT_FAILURE;
+        }
+      }
+      break;
+    case 'a': {
+        char *p;
+        arena_grain_size = (unsigned)strtoul(optarg, &p, 10);
+        switch(toupper(*p)) {
+        case 'G': arena_grain_size <<= 30; break;
+        case 'M': arena_grain_size <<= 20; break;
+        case 'K': arena_grain_size <<= 10; break;
+        case '\0': break;
+        default:
+          fprintf(stderr, "Bad arena grain size %s\n", optarg);
+          return EXIT_FAILURE;
+        }
+      }
+      break;
+    case 'S':
+      spare = strtod(optarg, NULL);
+      break;
+    default:
+      /* This is printed in parts to keep within the 509 character
+         limit for string literals in portable standard C. */
+      fprintf(stderr,
+              "Usage: %s [option...] [test...]\n"
+              "Options:\n"
+              "  -m n, --arena-size=n[KMG]?\n"
+              "    Initial size of arena (default %lu)\n"
+              "  -g n, --arena-grain-size=n[KMG]?\n"
+              "    Arena grain size (default %lu)\n"
+              "  -t n, --nthreads=n\n"
+              "    Launch n threads each running the test\n"
+              "  -i n, --niter=n\n"
+              "    Iterate each test n times (default %u)\n"
+              "  -p n, --npass=n\n"
+              "    Pass over the block array n times (default %u)\n"
+              "  -b n, --nblocks=n\n"
+              "    Length of the block array (default %u)\n"
+              "  -s n, --sshift=n\n"
+              "    Log2 max block size in words (default %u)\n",
+              argv[0],
+              (unsigned long)arena_size,
+              (unsigned long)arena_grain_size,
+              niter,
+              npass,
+              nblocks,
+              sshift);
+      fprintf(stderr,
+              "  -c p, --pact=p\n"
+              "    Probability of acting on a block (default %g)\n"
+              "  -r n, --rinter=n\n"
+              "    Recurse every n passes if n > 0 (default %u)\n"
+              "  -d n, --rmax=n\n"
+              "    Maximum recursion depth (default %u)\n"
+              "  -x n, --seed=n\n"
+              "    Random number seed (default from entropy)\n"
+              "  -z, --arena-unzoned\n"
+              "    Disabled zoned allocation in the arena\n"
+              "  -S f, --spare\n"
+              "    Maximum spare committed fraction (default %f)\n",
+              pact,
+              rinter,
+              rmax,
+              spare);
+      fprintf(stderr,
+              "Tests:\n"
+              "  mvt   pool class MVT\n"
+              "  mvff  pool class MVFF (buffer interface)\n"
+              "  mvffa pool class MVFF (alloc interface)\n"
+              "  an    malloc\n");
+      return EXIT_FAILURE;
+    }
+  argc -= optind;
+  argv += optind;
+
+  if (!seed_specified) {
+    printf("seed: %lu\n", seed);
+    (void)fflush(stdout);
+  }
+
+  while (argc > 0) {
+    for (i = 0; i < NELEMS(pools); ++i)
+      if (strcmp(argv[0], pools[i].name) == 0)
+        goto found;
+    fprintf(stderr, "unknown pool test \"%s\"\n", argv[0]);
+    return EXIT_FAILURE;
+  found:
+    (void)mps_lib_assert_fail_install(assert_die);
+    rnd_state_set(seed);
+    pools[i].wrap(pools[i].dj, pools[i].pool_class(), pools[i].name);
+    --argc;
+    ++argv;
+  }
+
+  return EXIT_SUCCESS;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2013-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/event.c

@@ -0,0 +1,568 @@
+/* event.c: EVENT LOGGING
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .sources: mps.design.event
+ *
+ * TRANSGRESSIONS (rule.impl.trans)
+ *
+ * .trans.ifdef: This file should logically be split into two, event.c
+ * (which contains NOOP definitions, for general use) and eventdl.c, which
+ * is specific to the logging variety and actually does logging (maybe).
+ * Unfortunately, the build system doesn't really cope, and so this file
+ * consists of two versions which are conditional on the EVENT symbol.
+ */
+
+#include "mpm.h"
+#include "event.h"
+#include "mpsio.h"
+#include "lock.h"
+
+SRCID(event, "$Id$");
+
+
+#ifdef EVENT /* .trans.ifdef */
+
+
+static Bool eventInited = FALSE;
+static Bool eventIOInited = FALSE;
+static mps_io_t eventIO;
+static Serial EventInternSerial;
+
+/* Buffers in which events are recorded, from the top down. */
+char EventBuffer[EventKindLIMIT][EventBufferSIZE];
+
+/* Pointers to last event logged into each buffer. */
+char *EventLast[EventKindLIMIT];
+
+/* Pointers to the last event written out of each buffer. */
+static char *EventWritten[EventKindLIMIT];
+
+EventControlSet EventKindControl;       /* Bit set used to control output. */
+
+
+/* A single event structure output once per buffer flush. */
+static EventEventClockSyncStruct eventClockSyncStruct;
+
+
+/* eventClockSync -- Populate and write the clock sync event. */
+
+static Res eventClockSync(void)
+{
+  Res res;
+  size_t size;
+
+  size= size_tAlignUp(sizeof(eventClockSyncStruct), EVENT_ALIGN);
+  eventClockSyncStruct.code = EventEventClockSyncCode;
+  eventClockSyncStruct.size = (EventSize)size;
+  EVENT_CLOCK(eventClockSyncStruct.clock);
+  eventClockSyncStruct.f0 = (Word)mps_clock();
+  res = (Res)mps_io_write(eventIO, (void *)&eventClockSyncStruct, size);
+  if (res != ResOK)
+    goto failWrite;
+
+  res = ResOK;
+failWrite:
+  return res;
+}
+
+
+/* EventFlush -- flush event buffer (perhaps to the event stream) */
+
+void EventFlush(EventKind kind)
+{
+  AVER(eventInited);
+  AVER(NONNEGATIVE(kind));
+  AVER(kind < EventKindLIMIT);
+
+  AVER(EventBuffer[kind] <= EventLast[kind]);
+  AVER(EventLast[kind] <= EventWritten[kind]);
+  AVER(EventWritten[kind] <= EventBuffer[kind] + EventBufferSIZE);
+
+  /* Send all pending events to the event stream. */
+  EventSync();
+
+  /* Flush the in-memory buffer whether or not we send this buffer, so
+     that we can continue to record recent events. */
+  EventLast[kind] = EventWritten[kind] = EventBuffer[kind] + EventBufferSIZE;
+}
+
+
+/* EventSync -- synchronize the event stream with the buffers */
+
+void EventSync(void)
+{
+  EventKind kind;
+  Bool wrote = FALSE;
+
+  for (kind = 0; kind < EventKindLIMIT; ++kind) {
+
+    /* Is event logging enabled for this kind of event, or are or are we just
+       writing to the buffer for backtraces, cores, and other debugging? */
+    if (BS_IS_MEMBER(EventKindControl, kind)) {
+      size_t size;
+      Res res;
+
+      AVER(EventBuffer[kind] <= EventLast[kind]);
+      AVER(EventLast[kind] <= EventWritten[kind]);
+      AVER(EventWritten[kind] <= EventBuffer[kind] + EventBufferSIZE);
+
+      size = (size_t)(EventWritten[kind] - EventLast[kind]);
+      if (size > 0) {
+
+        /* Ensure the IO stream is open.  We do this late so that no stream is
+           created if no events are enabled by telemetry control. */
+        if (!eventIOInited) {
+          res = (Res)mps_io_create(&eventIO);
+          if(res != ResOK) {
+            /* TODO: Consider taking some other action if open fails. */
+            return;
+          }
+          eventIOInited = TRUE;
+        }
+
+        /* Writing might be faster if the size is aligned to a multiple of the
+           C library or kernel's buffer size.  We could pad out the buffer with
+           a marker for this purpose. */
+
+        res = (Res)mps_io_write(eventIO, (void *)EventLast[kind], size);
+        if (res == ResOK) {
+          /* TODO: Consider taking some other action if a write fails. */
+          EventWritten[kind] = EventLast[kind];
+          wrote = TRUE;
+        }
+      }
+    }
+  }
+
+  /* If we wrote out events, send an EventClockSync event and flush
+     the telemetry stream. */
+  if (wrote) {
+    (void)eventClockSync();
+    (void)mps_io_flush(eventIO);
+  }
+}
+
+
+/* EventInit -- start using the event system, initialize if necessary */
+
+void EventInit(void)
+{
+  /* Make local enums for all event params in order to check that the indexes
+     in the parameter definition macros are in order, and that parameter
+     idents are unique. */
+
+#define EVENT_CHECK_ENUM_PARAM(name, index, sort, ident, doc) \
+  Event##name##Param##ident,
+
+#define EVENT_CHECK_ENUM(X, name, code, used, kind) \
+  enum Event##name##ParamEnum { \
+    EVENT_##name##_PARAMS(EVENT_CHECK_ENUM_PARAM, name) \
+    Event##name##ParamLIMIT \
+  };
+
+  EVENT_LIST(EVENT_CHECK_ENUM, X)
+
+  /* Check consistency of the event definitions.  These are all compile-time
+     checks and should get optimised away. */
+
+#define EVENT_PARAM_CHECK_P(name, index)
+#define EVENT_PARAM_CHECK_A(name, index)
+#define EVENT_PARAM_CHECK_W(name, index)
+#define EVENT_PARAM_CHECK_U(name, index)
+#define EVENT_PARAM_CHECK_D(name, index)
+#define EVENT_PARAM_CHECK_B(name, index)
+#define EVENT_PARAM_CHECK_S(name, index) \
+  AVER(index + 1 == Event##name##ParamLIMIT); /* strings must come last */
+
+#define EVENT_PARAM_CHECK(name, index, sort, ident, doc) \
+  AVER(index == Event##name##Param##ident); \
+  AVER(sizeof(EventF##sort) >= 0); /* check existence of type */ \
+  EVENT_PARAM_CHECK_##sort(name, index)
+
+#define EVENT_CHECK(X, name, code, used, kind) \
+  AVER(size_tAlignUp(sizeof(Event##name##Struct), EVENT_ALIGN) \
+       <= EventSizeMAX); \
+  AVER(Event##name##Code == code); \
+  AVER(0 <= code); \
+  AVER(code <= EventCodeMAX); \
+  AVER(sizeof(#name) - 1 <= EventNameMAX); \
+  AVER((Bool)Event##name##Used == used); \
+  AVERT(Bool, used); \
+  AVER(0 <= Event##name##Kind); \
+  AVER((EventKind)Event##name##Kind < EventKindLIMIT); \
+  EVENT_##name##_PARAMS(EVENT_PARAM_CHECK, name)
+
+  EVENT_LIST(EVENT_CHECK, X);
+
+  /* Ensure that no event can be larger than the maximum event size. */
+  AVER(EventBufferSIZE <= EventSizeMAX);
+
+  /* Only if this is the first call. */
+  if (!eventInited) { /* See .trans.log */
+    LockClaimGlobalRecursive();
+    if (!eventInited) {
+      EventKind kind;
+      for (kind = 0; kind < EventKindLIMIT; ++kind) {
+        AVER(EventLast[kind] == NULL);
+        AVER(EventWritten[kind] == NULL);
+        EventLast[kind] = EventWritten[kind] = EventBuffer[kind] + EventBufferSIZE;
+      }
+      eventInited = TRUE;
+      EventKindControl = (Word)mps_lib_telemetry_control();
+      EventInternSerial = (Serial)1; /* 0 is reserved */
+      (void)EventInternString(MPSVersion()); /* emit version */
+      EVENT7(EventInit, EVENT_VERSION_MAJOR, EVENT_VERSION_MEDIAN,
+             EVENT_VERSION_MINOR, EventCodeMAX, EventNameMAX, MPS_WORD_WIDTH,
+             mps_clocks_per_sec());
+      /* flush these initial events to get the first ClockSync out. */
+      EventSync();
+    }
+    LockReleaseGlobalRecursive();
+  }
+}
+
+
+/* EventFinish -- stop using the event system */
+
+void EventFinish(void)
+{
+  AVER(eventInited);
+
+  EventSync();
+}
+
+
+/* EventControl -- Change or read control word
+ *
+ * Resets the bits specified in resetMask, and flips those in
+ * flipMask.  Returns old value.
+ *
+ * Operations can be implemented as follows:
+ *   Set(M)   EventControl(M,M)
+ *   Reset(M) EventControl(M,0)
+ *   Flip(M)  EventControl(0,M)
+ *   Read()   EventControl(0,0)
+ *
+ * TODO: Candy-machine interface is a transgression.
+ */
+
+EventControlSet EventControl(EventControlSet resetMask,
+                             EventControlSet flipMask)
+{
+  EventControlSet oldValue = EventKindControl;
+
+  /* EventKindControl = (EventKindControl & ~resetMask) ^ flipMask */
+  EventKindControl =
+    BS_SYM_DIFF(BS_DIFF(EventKindControl, resetMask), flipMask);
+
+  return oldValue;
+}
+
+
+/* EventInternString -- emit an Intern event on the (null-term) string given */
+
+EventStringId EventInternString(const char *label)
+{
+  AVER(label != NULL);
+  return EventInternGenString(StringLength(label), label);
+}
+
+
+/* EventInternGenString -- emit an Intern event on the string given */
+
+EventStringId EventInternGenString(size_t len, const char *label)
+{
+  EventStringId id;
+
+  AVER(label != NULL);
+
+  id = EventInternSerial;
+  ++EventInternSerial;
+
+  EVENT2S(Intern, id, len, label);
+
+  return id;
+}
+
+
+/* EventLabelAddr -- emit event to label address with the given id */
+
+void EventLabelAddr(Addr addr, EventStringId id)
+{
+  AVER((Serial)id < EventInternSerial);
+
+  EVENT2(Label, addr, id);
+}
+
+
+/* EventLabelPointer -- emit event to label pointer with the given id */
+
+void EventLabelPointer(Pointer pointer, EventStringId id)
+{
+  AVER((Serial)id < EventInternSerial);
+
+  EVENT2(LabelPointer, pointer, id);
+}
+
+
+/* Convert event parameter sort to WriteF arguments */
+
+#define EVENT_WRITE_PARAM_MOST(name, index, sort) \
+  " $"#sort, (WriteF##sort)event->name.f##index,
+#define EVENT_WRITE_PARAM_A EVENT_WRITE_PARAM_MOST
+#define EVENT_WRITE_PARAM_P EVENT_WRITE_PARAM_MOST
+#define EVENT_WRITE_PARAM_U EVENT_WRITE_PARAM_MOST
+#define EVENT_WRITE_PARAM_W EVENT_WRITE_PARAM_MOST
+#define EVENT_WRITE_PARAM_D EVENT_WRITE_PARAM_MOST
+#define EVENT_WRITE_PARAM_S EVENT_WRITE_PARAM_MOST
+#define EVENT_WRITE_PARAM_B(name, index, sort) \
+  " $U", (WriteFU)event->name.f##index,
+
+
+Res EventDescribe(Event event, mps_lib_FILE *stream, Count depth)
+{
+  Res res;
+
+  /* TODO: Some sort of EventCheck would be good */
+  if (event == NULL)
+    return ResFAIL;
+  if (stream == NULL)
+    return ResFAIL;
+
+  res = WriteF(stream, depth,
+               "Event $P {\n", (WriteFP)event,
+               "  code $U\n", (WriteFU)event->any.code,
+               "  clock ", NULL);
+  if (res != ResOK)
+    return res;
+  res = EVENT_CLOCK_WRITE(stream, depth, event->any.clock);
+  if (res != ResOK)
+    return res;
+  res = WriteF(stream, depth, "\n  size $U\n", (WriteFU)event->any.size, NULL);
+  if (res != ResOK)
+    return res;
+
+  switch (event->any.code) {
+
+#define EVENT_DESC_PARAM(name, index, sort, ident, doc) \
+                 "\n  $S", (WriteFS)#ident, \
+                 EVENT_WRITE_PARAM_##sort(name, index, sort)
+
+#define EVENT_DESC(X, name, code, used, kind) \
+  case code: \
+    res = WriteF(stream, depth, \
+                 "  event \"$S\"", (WriteFS)#name, \
+                 EVENT_##name##_PARAMS(EVENT_DESC_PARAM, name) \
+                 NULL); \
+    if (res != ResOK) \
+      return res; \
+    break;
+
+  EVENT_LIST(EVENT_DESC, X)
+
+  default:
+    res = WriteF(stream, depth, "  event type unknown", NULL);
+    if (res != ResOK)
+      return res;
+    /* TODO: Hexdump unknown event contents. */
+    break;
+  }
+
+  res = WriteF(stream, depth,
+               "\n} Event $P\n", (WriteFP)event,
+               NULL);
+  return res;
+}
+
+
+Res EventWrite(Event event, mps_lib_FILE *stream)
+{
+  Res res;
+
+  if (event == NULL)
+    return ResFAIL;
+  if (stream == NULL)
+    return ResFAIL;
+
+  res = EVENT_CLOCK_WRITE(stream, 0, event->any.clock);
+  if (res != ResOK)
+    return res;
+
+  switch (event->any.code) {
+
+#define EVENT_WRITE_PARAM(name, index, sort, ident, doc) \
+  EVENT_WRITE_PARAM_##sort(name, index, sort)
+
+#define EVENT_WRITE(X, name, code, used, kind) \
+  case code: \
+    res = WriteF(stream, 0, " $S", (WriteFS)#name, \
+                 EVENT_##name##_PARAMS(EVENT_WRITE_PARAM, name) \
+                 NULL); \
+    if (res != ResOK) \
+      return res; \
+    break;
+  EVENT_LIST(EVENT_WRITE, X)
+
+  default:
+    res = WriteF(stream, 0, " <unknown code $U>",
+                 (WriteFU)event->any.code, NULL);
+    if (res != ResOK)
+      return res;
+    /* TODO: Hexdump unknown event contents. */
+    break;
+  }
+
+  return ResOK;
+}
+
+
+void EventDump(mps_lib_FILE *stream)
+{
+  EventKind kind;
+
+  AVER(stream != NULL);
+
+  /* This can happen if there's a backtrace very early in the life of
+     the MPS, and will cause an access violation if we continue. */
+  if (!eventInited) {
+    (void)WriteF(stream, 0, "No events\n", NULL);
+    return;
+  }
+
+  for (kind = 0; kind < EventKindLIMIT; ++kind) {
+    char *cursor = EventLast[kind];
+    const char *end = EventBuffer[kind] + EventBufferSIZE;
+    while (cursor < end) {
+      Event event = (void *)cursor;
+      /* Try to keep going even if there's an error, because this is
+         used for debugging and we'll take what we can get. */
+      (void)EventWrite(event, stream);
+      (void)WriteF(stream, 0, "\n", NULL);
+      cursor += event->any.size;
+    }
+  }
+}
+
+
+#else /* EVENT, not */
+
+
+void EventSync(void)
+{
+  NOOP;
+}
+
+
+void EventInit(void)
+{
+  NOOP;
+}
+
+
+void EventFinish(void)
+{
+  NOOP;
+}
+
+
+EventControlSet EventControl(EventControlSet resetMask,
+                             EventControlSet flipMask)
+{
+  UNUSED(resetMask);
+  UNUSED(flipMask);
+  return BS_EMPTY(EventControlSet);
+}
+
+
+EventStringId EventInternString(const char *label)
+{
+  UNUSED(label);
+  /* EventInternString is reached in varieties without events, but the result
+     is not used for anything. */
+  return (EventStringId)0x4026EAC8;
+}
+
+
+Word EventInternGenString(size_t len, const char *label)
+{
+  UNUSED(len); UNUSED(label);
+  /* EventInternGenString is reached in varieties without events, but
+     the result is not used for anything. */
+  return (EventStringId)0x4026EAC8;
+}
+
+
+void EventLabelAddr(Addr addr, Word id)
+{
+  UNUSED(addr);
+  UNUSED(id);
+  /* EventLabelAddr is reached in varieties without events, but doesn't have
+     to do anything. */
+}
+
+
+void EventLabelPointer(Pointer pointer, Word id)
+{
+  UNUSED(pointer);
+  UNUSED(id);
+  /* EventLabelPointer is reached in varieties without events, but
+     doesn't have to do anything. */
+}
+
+
+Res EventDescribe(Event event, mps_lib_FILE *stream, Count depth)
+{
+  UNUSED(event);
+  UNUSED(stream);
+  UNUSED(depth);
+  return ResUNIMPL;
+}
+
+
+Res EventWrite(Event event, mps_lib_FILE *stream)
+{
+  UNUSED(event);
+  UNUSED(stream);
+  return ResUNIMPL;
+}
+
+
+void EventDump(mps_lib_FILE *stream)
+{
+  UNUSED(stream);
+}
+
+
+#endif /* EVENT */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/event.h

@@ -0,0 +1,234 @@
+/* <code/event.h> -- Event Logging Interface
+ *
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * $Id$
+ *
+ * READERSHIP
+ *
+ * .readership: MPS developers.
+ *
+ * DESIGN
+ *
+ * .design: <design/telemetry>.
+ */
+
+#ifndef event_h
+#define event_h
+
+#include "eventcom.h"
+#include "mpm.h"
+#include "eventdef.h"
+#include "mpslib.h"
+
+
+typedef Word EventStringId;
+typedef Word EventControlSet;
+
+extern void EventSync(void);
+extern void EventInit(void);
+extern void EventFinish(void);
+extern EventControlSet EventControl(EventControlSet resetMask,
+                                    EventControlSet flipMask);
+extern EventStringId EventInternString(const char *label);
+extern EventStringId EventInternGenString(size_t, const char *label);
+extern void EventLabelAddr(Addr addr, Word id);
+extern void EventLabelPointer(Pointer pointer, Word id);
+extern void EventFlush(EventKind kind);
+extern Res EventDescribe(Event event, mps_lib_FILE *stream, Count depth);
+extern Res EventWrite(Event event, mps_lib_FILE *stream);
+extern void EventDump(mps_lib_FILE *stream);
+
+
+#ifdef EVENT
+
+/* Event writing support */
+
+extern char EventBuffer[EventKindLIMIT][EventBufferSIZE];
+extern char *EventLast[EventKindLIMIT];
+extern Word EventKindControl;
+
+
+/* EVENT_BEGIN -- flush buffer if necessary and write event header */
+
+#define EVENT_BEGIN(name, structSize)                           \
+  BEGIN                                                         \
+    Event##name##Struct *_event;                                \
+    EventKind _kind = Event##name##Kind;                        \
+    size_t _size = size_tAlignUp(structSize, EVENT_ALIGN);      \
+    AVER(Event##name##Used);                                    \
+    if (_size > (size_t)(EventLast[Event##name##Kind]           \
+                         - EventBuffer[Event##name##Kind]))     \
+      EventFlush(Event##name##Kind);                            \
+    AVER(_size <= (size_t)(EventLast[Event##name##Kind]         \
+                           - EventBuffer[Event##name##Kind]));  \
+    _event = (void *)(EventLast[Event##name##Kind] - _size);    \
+    _event->code = Event##name##Code;                           \
+    _event->size = (EventSize)_size;                            \
+    EVENT_CLOCK(_event->clock);
+
+#define EVENT_END                   \
+    EventLast[_kind] -= _size;      \
+  END
+
+
+/* EVENTn -- event emitting macros
+ *
+ * The macros EVENT0, EVENT1, etc. are used throughout the MPS to emit an
+ * event with parameters.  They work by appending the event parameters to
+ * an event buffer, which is flushed to the telemetry output stream when
+ * full.  EVENT2S is a special case that takes a variable length string.
+ */
+
+#define EVENT2S(name, p0, length, string) \
+  BEGIN \
+    size_t _string_len = (length); \
+    size_t size; \
+    AVER(_string_len <= EventStringLengthMAX); \
+    size = offsetof(Event##name##Struct, f1) + _string_len + sizeof('\0'); \
+    EVENT_BEGIN(name, size) \
+      _event->f0 = (p0); \
+      (void)mps_lib_memcpy(_event->f1, (string), _string_len); \
+      _event->f1[_string_len] = '\0'; \
+    EVENT_END; \
+  END
+
+#define EVENT0 EVENT_RECORD0
+#define EVENT1 EVENT_RECORD1
+#define EVENT2 EVENT_RECORD2
+#define EVENT3 EVENT_RECORD3
+#define EVENT4 EVENT_RECORD4
+#define EVENT5 EVENT_RECORD5
+#define EVENT6 EVENT_RECORD6
+#define EVENT7 EVENT_RECORD7
+#define EVENT8 EVENT_RECORD8
+#define EVENT9 EVENT_RECORD9
+#define EVENT10 EVENT_RECORD10
+#define EVENT11 EVENT_RECORD11
+#define EVENT12 EVENT_RECORD12
+#define EVENT13 EVENT_RECORD13
+#define EVENT14 EVENT_RECORD14
+
+#else /* !EVENT */
+
+#define EVENT0 EVENT_IGNORE0
+#define EVENT1 EVENT_IGNORE1
+#define EVENT2 EVENT_IGNORE2
+#define EVENT3 EVENT_IGNORE3
+#define EVENT4 EVENT_IGNORE4
+#define EVENT5 EVENT_IGNORE5
+#define EVENT6 EVENT_IGNORE6
+#define EVENT7 EVENT_IGNORE7
+#define EVENT8 EVENT_IGNORE8
+#define EVENT9 EVENT_IGNORE9
+#define EVENT10 EVENT_IGNORE10
+#define EVENT11 EVENT_IGNORE11
+#define EVENT12 EVENT_IGNORE12
+#define EVENT13 EVENT_IGNORE13
+#define EVENT14 EVENT_IGNORE14
+
+#endif /* !EVENT */
+
+#if EVENT_ALL
+
+#define EVENT_CRITICAL0 EVENT0
+#define EVENT_CRITICAL1 EVENT1
+#define EVENT_CRITICAL2 EVENT2
+#define EVENT_CRITICAL3 EVENT3
+#define EVENT_CRITICAL4 EVENT4
+#define EVENT_CRITICAL5 EVENT5
+#define EVENT_CRITICAL6 EVENT6
+#define EVENT_CRITICAL7 EVENT7
+#define EVENT_CRITICAL8 EVENT8
+#define EVENT_CRITICAL9 EVENT9
+#define EVENT_CRITICAL10 EVENT10
+#define EVENT_CRITICAL11 EVENT11
+#define EVENT_CRITICAL12 EVENT12
+#define EVENT_CRITICAL13 EVENT13
+#define EVENT_CRITICAL14 EVENT14
+
+#else /* !EVENT_ALL */
+
+#define EVENT_CRITICAL0 EVENT_IGNORE0
+#define EVENT_CRITICAL1 EVENT_IGNORE1
+#define EVENT_CRITICAL2 EVENT_IGNORE2
+#define EVENT_CRITICAL3 EVENT_IGNORE3
+#define EVENT_CRITICAL4 EVENT_IGNORE4
+#define EVENT_CRITICAL5 EVENT_IGNORE5
+#define EVENT_CRITICAL6 EVENT_IGNORE6
+#define EVENT_CRITICAL7 EVENT_IGNORE7
+#define EVENT_CRITICAL8 EVENT_IGNORE8
+#define EVENT_CRITICAL9 EVENT_IGNORE9
+#define EVENT_CRITICAL10 EVENT_IGNORE10
+#define EVENT_CRITICAL11 EVENT_IGNORE11
+#define EVENT_CRITICAL12 EVENT_IGNORE12
+#define EVENT_CRITICAL13 EVENT_IGNORE13
+#define EVENT_CRITICAL14 EVENT_IGNORE14
+
+#endif /* !EVENT_ALL */
+
+
+/* The following lines were generated with
+   python -c 'for i in range(15): print("#define EVENT_RECORD{i}(name{args}) EVENT_BEGIN(name, sizeof(Event##name##Struct)) {assign} EVENT_END\n#define EVENT_IGNORE{i}(name{args}) BEGIN {unused} END".format(i=i, args="".join(map(", p{}".format, range(i))), assign=" ".join(map("_event->f{0} = (p{0});".format, range(i))), unused=" ".join(map("UNUSED(p{});".format, range(i)))))'
+ */
+#define EVENT_RECORD0(name) EVENT_BEGIN(name, sizeof(Event##name##Struct))  EVENT_END
+#define EVENT_IGNORE0(name) BEGIN  END
+#define EVENT_RECORD1(name, p0) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); EVENT_END
+#define EVENT_IGNORE1(name, p0) BEGIN UNUSED(p0); END
+#define EVENT_RECORD2(name, p0, p1) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); EVENT_END
+#define EVENT_IGNORE2(name, p0, p1) BEGIN UNUSED(p0); UNUSED(p1); END
+#define EVENT_RECORD3(name, p0, p1, p2) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); EVENT_END
+#define EVENT_IGNORE3(name, p0, p1, p2) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); END
+#define EVENT_RECORD4(name, p0, p1, p2, p3) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); EVENT_END
+#define EVENT_IGNORE4(name, p0, p1, p2, p3) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); END
+#define EVENT_RECORD5(name, p0, p1, p2, p3, p4) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); EVENT_END
+#define EVENT_IGNORE5(name, p0, p1, p2, p3, p4) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); END
+#define EVENT_RECORD6(name, p0, p1, p2, p3, p4, p5) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); EVENT_END
+#define EVENT_IGNORE6(name, p0, p1, p2, p3, p4, p5) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); END
+#define EVENT_RECORD7(name, p0, p1, p2, p3, p4, p5, p6) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); EVENT_END
+#define EVENT_IGNORE7(name, p0, p1, p2, p3, p4, p5, p6) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); END
+#define EVENT_RECORD8(name, p0, p1, p2, p3, p4, p5, p6, p7) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); EVENT_END
+#define EVENT_IGNORE8(name, p0, p1, p2, p3, p4, p5, p6, p7) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); END
+#define EVENT_RECORD9(name, p0, p1, p2, p3, p4, p5, p6, p7, p8) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); _event->f8 = (p8); EVENT_END
+#define EVENT_IGNORE9(name, p0, p1, p2, p3, p4, p5, p6, p7, p8) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); UNUSED(p8); END
+#define EVENT_RECORD10(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); _event->f8 = (p8); _event->f9 = (p9); EVENT_END
+#define EVENT_IGNORE10(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); UNUSED(p8); UNUSED(p9); END
+#define EVENT_RECORD11(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); _event->f8 = (p8); _event->f9 = (p9); _event->f10 = (p10); EVENT_END
+#define EVENT_IGNORE11(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); UNUSED(p8); UNUSED(p9); UNUSED(p10); END
+#define EVENT_RECORD12(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); _event->f8 = (p8); _event->f9 = (p9); _event->f10 = (p10); _event->f11 = (p11); EVENT_END
+#define EVENT_IGNORE12(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); UNUSED(p8); UNUSED(p9); UNUSED(p10); UNUSED(p11); END
+#define EVENT_RECORD13(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); _event->f8 = (p8); _event->f9 = (p9); _event->f10 = (p10); _event->f11 = (p11); _event->f12 = (p12); EVENT_END
+#define EVENT_IGNORE13(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); UNUSED(p8); UNUSED(p9); UNUSED(p10); UNUSED(p11); UNUSED(p12); END
+#define EVENT_RECORD14(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13) EVENT_BEGIN(name, sizeof(Event##name##Struct)) _event->f0 = (p0); _event->f1 = (p1); _event->f2 = (p2); _event->f3 = (p3); _event->f4 = (p4); _event->f5 = (p5); _event->f6 = (p6); _event->f7 = (p7); _event->f8 = (p8); _event->f9 = (p9); _event->f10 = (p10); _event->f11 = (p11); _event->f12 = (p12); _event->f13 = (p13); EVENT_END
+#define EVENT_IGNORE14(name, p0, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13) BEGIN UNUSED(p0); UNUSED(p1); UNUSED(p2); UNUSED(p3); UNUSED(p4); UNUSED(p5); UNUSED(p6); UNUSED(p7); UNUSED(p8); UNUSED(p9); UNUSED(p10); UNUSED(p11); UNUSED(p12); UNUSED(p13); END
+
+#endif /* event_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/eventcnv.c

@@ -0,0 +1,366 @@
+/* eventcnv.c: Simple event log converter
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * This is a command-line tool that converts a binary format telemetry output
+ * stream from the MPS into a more-portable textual format.
+ *
+ * eventcnv can only read binary-format files that come from an MPS
+ * compiled on the same platform, whereas the text-format files it
+ * produces can be processed on any platform.
+ *
+ * The default MPS library will write a telemetry stream to a file
+ * when the environment variable MPS_TELEMETRY_CONTROL is set to an
+ * integer whose bits select event kinds.  For example:
+ *
+ *   MPS_TELEMETRY_CONTROL=7 amcss
+ *
+ * will run the amcss test program and emit a telemetry file with
+ * event kinds 0, 1, 2.  The file can then be converted into a sorted
+ * text format log with a command like:
+ *
+ *   eventcnv | sort > mps-events.txt
+ *
+ * These text-format files have one line per event, and can be
+ * manipulated by various programs systems in the usual Unix way.
+ *
+ * The binary telemetry filename can be specified with a -f
+ * command-line argument (use -f - to specify standard input).  If no
+ * filename is specified on the command line, the environment variable
+ * MPS_TELEMETRY_FILENAME is consulted (this is the same environment
+ * variable used to specify the telemetry file to the MPS library).
+ * If the environment variable does not exist, the default filename of
+ * "mpsio.log" is used.
+ *
+ * $Id$
+ */
+
+#include "config.h"
+#include "eventdef.h"
+#include "eventcom.h"
+#include "testlib.h" /* for ulongest_t and associated print formats */
+
+#include <stddef.h> /* for size_t */
+#include <stdio.h> /* for printf */
+#include <stdlib.h> /* for EXIT_FAILURE */
+#include <assert.h> /* for assert */
+#include <string.h> /* for strcmp */
+#include "mpstd.h"
+
+#define DEFAULT_TELEMETRY_FILENAME "mpsio.log"
+#define TELEMETRY_FILENAME_ENVAR   "MPS_TELEMETRY_FILENAME"
+
+static EventClock eventTime; /* current event time */
+static const char *prog; /* program name */
+
+/* Errors and Warnings */
+
+/* fevwarn -- flush stdout, write message to stderr */
+
+ATTRIBUTE_FORMAT((printf, 2, 0))
+static void fevwarn(const char *prefix, const char *format, va_list args)
+{
+  (void)fflush(stdout); /* sync */
+  (void)fprintf(stderr, "%s: %s @", prog, prefix);
+  (void)EVENT_CLOCK_PRINT(stderr, eventTime);
+  (void)fprintf(stderr, " ");
+  (void)vfprintf(stderr, format, args);
+  (void)fprintf(stderr, "\n");
+}
+
+/* evwarn -- flush stdout, warn to stderr */
+
+ATTRIBUTE_FORMAT((printf, 1, 2))
+static void evwarn(const char *format, ...)
+{
+  va_list args;
+
+  va_start(args, format);
+  fevwarn("Warning", format, args);
+  va_end(args);
+}
+
+/* everror -- flush stdout, message to stderr, exit */
+
+ATTRIBUTE_FORMAT((printf, 1, 2))
+static void everror(const char *format, ...)
+{
+  va_list args;
+
+  va_start(args, format);
+  fevwarn("Error", format, args);
+  va_end(args);
+  exit(EXIT_FAILURE);
+}
+
+
+/* usage -- usage message */
+
+static void usage(void)
+{
+  (void)fprintf(stderr, "Usage: %s [-f logfile] [-h]\n"
+                "See \"Telemetry\" in the reference manual for instructions.\n",
+                prog);
+}
+
+
+/* usageError -- explain usage and error */
+
+static void usageError(void)
+{
+  usage();
+  everror("Bad usage");
+}
+
+
+/* parseArgs -- parse command line arguments, return log file name */
+
+static char *parseArgs(int argc, char *argv[])
+{
+  char *name = NULL;
+  int i = 1;
+
+  if (argc >= 1)
+    prog = argv[0];
+  else
+    prog = "unknown";
+
+  while (i < argc) { /* consider argument i */
+    if (argv[i][0] == '-') { /* it's an option argument */
+      switch (argv[i][1]) {
+      case 'f': /* file name */
+        ++ i;
+        if (i == argc)
+          usageError();
+        else
+          name = argv[i];
+        break;
+      case '?': case 'h': /* help */
+        usage();
+        exit(EXIT_SUCCESS);
+      default:
+        usageError();
+      }
+    } /* if option */
+    ++ i;
+  }
+  return name;
+}
+
+
+/* Printing routines */
+
+static void printHex(ulongest_t val)
+{
+  printf(" %"PRIXLONGEST, (ulongest_t)val);
+}
+
+#define printParamP(p) printHex((ulongest_t)p)
+#define printParamA(a) printHex((ulongest_t)a)
+#define printParamU(u) printHex((ulongest_t)u)
+#define printParamW(w) printHex((ulongest_t)w)
+#define printParamB(b) printHex((ulongest_t)b)
+
+static void printParamD(double d)
+{
+  printf(" %.10G", d);
+}
+
+static void printParamS(const char *str)
+{
+  size_t i;
+  putchar(' ');
+  putchar('"');
+  for (i = 0; str[i] != '\0'; ++i) {
+    char c = str[i];
+    if (c == '"' || c == '\\')
+      putchar('\\');
+    putchar(c);
+  }
+  putchar('"');
+}
+
+
+/* EventRead -- read one event from the file */
+
+static Res eventRead(Bool *eofOut, EventUnion *event, FILE *stream)
+{
+  size_t n;
+  size_t rest;
+
+  /* Read the prefix common to all event structures, in order to decode the
+     event size. */
+  n = fread(&event->any, sizeof(event->any), 1, stream);
+  if (n < 1) {
+    if (feof(stream)) {
+      *eofOut = TRUE;
+      return ResOK;
+    }
+    return ResIO;
+  }
+
+  if (event->any.size < sizeof(event->any))
+    return ResFAIL; /* invalid size: too small */
+
+  if (event->any.size > sizeof(*event))
+    return ResFAIL; /* invalid size: too large */
+
+  /* Read the rest of the event. */
+  rest = event->any.size - sizeof(event->any);
+  if (rest > 0) {
+    n = fread((char *)event + sizeof(event->any), rest, 1, stream);
+    if (n < 1) {
+      if (feof(stream))
+        return ResFAIL; /* truncated event */
+      else
+        return ResIO;
+    }
+  }
+
+  *eofOut = FALSE;
+  return ResOK;
+}
+
+/* readLog -- read and parse log */
+
+static void readLog(FILE *stream)
+{
+  for(;;) { /* loop for each event */
+    EventUnion eventUnion;
+    Event event = &eventUnion;
+    EventCode code;
+    Res res;
+    Bool eof = FALSE; /* suppress warnings about uninitialized use */
+
+    /* Read and parse event. */
+    res = eventRead(&eof, event, stream);
+    if (res == ResFAIL)
+      everror("Truncated log");
+    else if (res == ResIO)
+      everror("I/O error reading log");
+    else if (res != ResOK)
+      everror("Unknown error reading log");
+    if (eof)
+      break;
+
+    eventTime = event->any.clock;
+    code = event->any.code;
+
+    /* Special handling for some events, prior to text output */
+
+    switch(code) {
+    case EventEventInitCode:
+      if ((event->EventInit.f0 != EVENT_VERSION_MAJOR) ||
+          (event->EventInit.f1 != EVENT_VERSION_MEDIAN) ||
+          (event->EventInit.f2 != EVENT_VERSION_MINOR))
+        evwarn("Event log version does not match: %d.%d.%d vs %d.%d.%d",
+               event->EventInit.f0,
+               event->EventInit.f1,
+               event->EventInit.f2,
+               EVENT_VERSION_MAJOR,
+               EVENT_VERSION_MEDIAN,
+               EVENT_VERSION_MINOR);
+
+      if (event->EventInit.f3 > EventCodeMAX)
+        evwarn("Event log may contain unknown events with codes from %d to %d",
+               EventCodeMAX+1, event->EventInit.f3);
+
+      if (event->EventInit.f5 != MPS_WORD_WIDTH)
+        /* This probably can't happen; other things will break
+         * before we get here */
+        evwarn("Event log has incompatible word width: %d instead of %d",
+               event->EventInit.f5,
+               MPS_WORD_WIDTH);
+      break;
+    default:
+      /* No special treatment needed. */
+      break;
+    }
+
+    (void)EVENT_CLOCK_PRINT(stdout, eventTime);
+    printf(" %4X", (unsigned)code);
+
+    switch (code) {
+#define EVENT_PARAM_PRINT(name, index, sort, ident, doc) \
+      printParam##sort(event->name.f##index);
+#define EVENT_PRINT(X, name, code, used, kind)          \
+      case code:                                        \
+        EVENT_##name##_PARAMS(EVENT_PARAM_PRINT, name)  \
+        break;
+      EVENT_LIST(EVENT_PRINT, X)
+    default:
+      evwarn("Unknown event code %d", code);
+    }
+
+    putchar('\n');
+    (void)fflush(stdout);
+  } /* while(!feof(input)) */
+}
+
+
+/* CHECKCONV -- check t2 can be cast to t1 without loss */
+
+#define CHECKCONV(t1, t2) \
+  (sizeof(t1) >= sizeof(t2))
+
+
+/* main */
+
+int main(int argc, char *argv[])
+{
+  const char *filename;
+  FILE *input;
+
+  assert(CHECKCONV(ulongest_t, Word));
+  assert(CHECKCONV(ulongest_t, Addr));
+  assert(CHECKCONV(ulongest_t, void *));
+  assert(CHECKCONV(ulongest_t, EventCode));
+
+  filename = parseArgs(argc, argv);
+  if (!filename) {
+    filename = getenv(TELEMETRY_FILENAME_ENVAR);
+    if(!filename)
+      filename = DEFAULT_TELEMETRY_FILENAME;
+  }
+
+  if (strcmp(filename, "-") == 0)
+    input = stdin;
+  else {
+    input = fopen(filename, "rb");
+    if (input == NULL)
+      everror("unable to open \"%s\"\n", filename);
+  }
+
+  readLog(input);
+
+  return EXIT_SUCCESS;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/eventcom.h

@@ -0,0 +1,168 @@
+/* <code/eventcom.h> -- Event Logging Common Definitions
+ *
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * $Id$
+ *
+ * .sources: mps.design.telemetry
+ */
+
+#ifndef eventcom_h
+#define eventcom_h
+
+#include <limits.h>
+#include "mpmtypes.h" /* for Word */
+#include "eventdef.h"
+#include "clock.h"
+
+
+/* Event Kinds --- see <design/telemetry>
+ *
+ * All events are classified as being of one event type.
+ * They are small enough to be able to be used as members of a bit set.
+ */
+
+#define EventKindENUM(ENUM, X) \
+  ENUM(X, Arena,  "Per space or arena") \
+  ENUM(X, Pool,   "Per pool") \
+  ENUM(X, Trace,  "Per trace or scan") \
+  ENUM(X, Seg,    "Per seg") \
+  ENUM(X, Ref,    "Per ref or fix") \
+  ENUM(X, Object, "Per alloc or object") \
+  ENUM(X, User,   "User-invoked")
+
+#define ENUM_DECLARE(name) \
+  enum name##Enum { \
+    name##ENUM(ENUM_DECLARE_ROW, name) \
+    name##LIMIT \
+  };
+
+#define ENUM_DECLARE_ROW(enumName, rowName, rowDoc) \
+  enumName##rowName,
+
+ENUM_DECLARE(EventKind)
+
+
+/* Event type definitions
+ *
+ * Various constants for each event type to describe them, so that they
+ * can easily be looked up from macros by name.
+ */
+
+/* Note that enum values can be up to fifteen bits long portably. */
+#define EVENT_ENUM(X, name, code, used, kind) \
+    Event##name##Code = code, \
+    Event##name##Used = used, \
+    Event##name##Kind = EventKind##kind,
+
+enum EventDefinitionsEnum {
+  EVENT_LIST(EVENT_ENUM, X)
+  /* suppress comma-at-end-of-enum warning */
+  EventEnumWarningSuppressor = USHRT_MAX
+};
+
+
+/* Event*Struct -- Event Structures
+ *
+ * Declare the structures that are used to encode events in the internal event
+ * buffers and on the binary telemetry output stream.
+ */
+
+/* Types for common event fields */
+typedef unsigned short EventCode;
+typedef unsigned EventKind;
+typedef unsigned short EventSize;
+#define EventSizeMAX USHRT_MAX
+
+/* Common prefix for all event structures.  The size field allows an event
+   reader to skip over events whose codes it does not recognise. */
+#define EVENT_ANY_FIELDS(X) \
+  X(EventCode, code, "encoding of the event type") \
+  X(EventSize, size, "allows reader to skip events of unknown code") \
+  X(EventClock, clock, "when the event occurred")
+
+#define EVENT_ANY_STRUCT_FIELD(TYPE, NAME, DOC) TYPE NAME;
+
+typedef struct EventAnyStruct {
+  EVENT_ANY_FIELDS(EVENT_ANY_STRUCT_FIELD)
+} EventAnyStruct;
+
+/* Event field types, for indexing by macro on the event parameter sort */
+typedef void *EventFP;                  /* pointer to C object */
+typedef Addr EventFA;                   /* address on the heap */
+typedef Word EventFW;                   /* word */
+typedef unsigned EventFU;               /* unsigned integer */
+typedef char EventFS[EventStringLengthMAX + sizeof('\0')]; /* string */
+typedef double EventFD;                 /* double */
+typedef unsigned char EventFB;          /* Boolean */
+
+/* Event packing bitfield specifiers */
+#define EventFP_BITFIELD
+#define EventFA_BITFIELD
+#define EventFW_BITFIELD
+#define EventFU_BITFIELD
+#define EventFS_BITFIELD
+#define EventFD_BITFIELD
+#define EventFB_BITFIELD
+
+#define EVENT_STRUCT_FIELD(X, index, sort, ident, doc) \
+  EventF##sort f##index EventF##sort##_BITFIELD;
+
+#define EVENT_STRUCT(X, name, _code, used, kind) \
+  typedef struct Event##name##Struct { \
+    EVENT_ANY_FIELDS(EVENT_ANY_STRUCT_FIELD) \
+    EVENT_##name##_PARAMS(EVENT_STRUCT_FIELD, X) \
+  } Event##name##Struct;
+
+EVENT_LIST(EVENT_STRUCT, X)
+
+/* Maximum alignment requirement of any event type. */
+#define EVENT_ALIGN (sizeof(EventFP))
+
+
+/* Event -- event union type
+ *
+ * Event is the type of a pointer to EventUnion, which is a union of all
+ * event structures.  This can be used as the type of any event, decoded
+ * by examining event->any.code.
+ */
+
+#define EVENT_UNION_MEMBER(X, name, code, used, kind) \
+  Event##name##Struct name;
+
+typedef union EventUnion {
+  EventAnyStruct any;
+  EVENT_LIST(EVENT_UNION_MEMBER, X)
+} EventUnion, *Event;
+
+
+#endif /* eventcom_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/eventdef.h

@@ -0,0 +1,708 @@
+/* <code/eventdef.h> -- Event Logging Definitions
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/telemetry>
+ *
+ * .desc: This file declares macros that define the types of events and their
+ * properties.
+ *
+ * TRANSGRESSIONS
+ *
+ * .kind.abuse: A few events have a kind which is not obvious from the
+ * type of the objects that the event relates to.  They are given the
+ * kind that that have on the grounds of expected use.  The kinds are
+ * used in controlling the overall volume of telemetry and these events are
+ * given kinds so that they are grouped under the same control as events
+ * you are likely to want to see them with.  (So for example, lots of
+ * scanner events have the same kind, Seg, because if you are interested
+ * in one then you're probably interested in them all and it's a similar
+ * amount of data).
+ */
+
+#ifndef eventdef_h
+#define eventdef_h
+
+
+/* EVENT_VERSION_* -- three part version number
+ *
+ * Increment the minor version when adding new events,
+ * the median version when changing an existing event,
+ * and the major version when changing the format of the event file.
+ *
+ * These are passed as parameters to the EventInit event at the start
+ * of a telemetry stream, allowing that stream to be identified.
+ */
+
+#define EVENT_VERSION_MAJOR  ((unsigned)2)
+#define EVENT_VERSION_MEDIAN ((unsigned)0)
+#define EVENT_VERSION_MINOR  ((unsigned)0)
+
+
+/* EVENT_LIST -- list of event types and general properties
+ *
+ * The columns are:
+ *
+ * 1. Type: The name of the event type, without the leading "Event";
+ * 2. Code: The unique 16-bit code associated with this event type;
+ * 3. Used: Whether this event type is used at all;
+ * 4. Kind: Category into which this event falls, without the "EventKind";
+ *
+ * When you retire an event type, don't delete it from the list, but
+ * set the "Used" column to FALSE. This serves as documentation for
+ * what the event code means in older logs, and prevents the codes
+ * being re-used. <design/telemetry/#.reg.code>.
+ *
+ * When you add an event type, you must also add an EVENT_*_PARAMS
+ * macro specifying its parameters.
+ *
+ * TODO: Add a doc string to each event type.
+ */
+
+#define EventNameMAX ((size_t)19)
+#define EventCodeMAX ((EventCode)0x005c)
+
+#define EVENT_LIST(EVENT, X) \
+  /*       0123456789012345678 <- don't exceed without changing EventNameMAX */ \
+  EVENT(X, AMCScanNailed      , 0x0001,  TRUE, Seg) \
+  EVENT(X, AWLDeclineSeg      , 0x0002,  TRUE, Seg) \
+  EVENT(X, AWLDeclineTotal    , 0x0003,  TRUE, Seg) \
+  EVENT(X, ArenaAccessBegin   , 0x0004,  TRUE, Arena) \
+  EVENT(X, ArenaAccessEnd     , 0x0005,  TRUE, Arena) \
+  EVENT(X, ArenaAlloc         , 0x0006,  TRUE, Arena) \
+  EVENT(X, ArenaAllocFail     , 0x0007,  TRUE, Arena) \
+  EVENT(X, ArenaCreateCL      , 0x0008,  TRUE, Arena) \
+  EVENT(X, ArenaCreateVM      , 0x0009,  TRUE, Arena) \
+  EVENT(X, ArenaDestroy       , 0x000a,  TRUE, Arena) \
+  EVENT(X, ArenaExtend        , 0x000b,  TRUE, Arena) \
+  EVENT(X, ArenaFree          , 0x000c,  TRUE, Arena) \
+  EVENT(X, ArenaPollBegin     , 0x000d,  TRUE, Arena) \
+  EVENT(X, ArenaPollEnd       , 0x000e,  TRUE, Arena) \
+  EVENT(X, ArenaSetEmergency  , 0x000f,  TRUE, Arena) \
+  EVENT(X, ArenaSetSpare      , 0x0010,  TRUE, Arena) \
+  EVENT(X, ArenaUseFreeZone   , 0x0011,  TRUE, Arena) \
+  EVENT(X, BufferCommit       , 0x0012,  TRUE, Object) \
+  EVENT(X, BufferEmpty        , 0x0013,  TRUE, Seg) \
+  EVENT(X, BufferFill         , 0x0014,  TRUE, Seg) \
+  EVENT(X, BufferFinish       , 0x0015,  TRUE, Pool) /* see .kind.abuse */ \
+  EVENT(X, BufferInit         , 0x0016,  TRUE, Pool) /* see .kind.abuse */ \
+  EVENT(X, BufferInitRank     , 0x0017,  TRUE, Pool) \
+  EVENT(X, BufferInitSeg      , 0x0018,  TRUE, Pool) \
+  EVENT(X, BufferReserve      , 0x0019,  TRUE, Object) \
+  EVENT(X, ChainCondemnAuto   , 0x001a,  TRUE, Trace) \
+  EVENT(X, CommitLimitSet     , 0x001b,  TRUE, Arena) \
+  EVENT(X, EventClockSync     , 0x001c,  TRUE, Arena) \
+  EVENT(X, EventInit          , 0x001d,  TRUE, Arena) \
+  EVENT(X, GenFinish          , 0x001e,  TRUE, Arena) \
+  EVENT(X, GenInit            , 0x001f,  TRUE, Arena) \
+  EVENT(X, GenZoneSet         , 0x0020,  TRUE, Arena) \
+  EVENT(X, Intern             , 0x0021,  TRUE, User) \
+  EVENT(X, Label              , 0x0022,  TRUE, User) \
+  EVENT(X, LabelPointer       , 0x0023,  TRUE, User) \
+  EVENT(X, LandInit           , 0x0024,  TRUE, Pool) \
+  EVENT(X, MessagesDropped    , 0x0025,  TRUE, Arena) \
+  EVENT(X, MessagesExist      , 0x0026,  TRUE, Arena) \
+  EVENT(X, MeterInit          , 0x0027,  TRUE, Pool) \
+  EVENT(X, MeterValues        , 0x0028,  TRUE, Pool) \
+  EVENT(X, PauseTimeSet       , 0x0029,  TRUE, Arena) \
+  EVENT(X, PoolAlloc          , 0x002a,  TRUE, Object) \
+  EVENT(X, PoolFinish         , 0x002b,  TRUE, Pool) \
+  EVENT(X, PoolFree           , 0x002c,  TRUE, Object) \
+  EVENT(X, PoolInit           , 0x002d,  TRUE, Pool) \
+  EVENT(X, PoolInitAMC        , 0x002e,  TRUE, Pool) \
+  EVENT(X, PoolInitAMCZ       , 0x002f,  TRUE, Pool) \
+  EVENT(X, PoolInitAMS        , 0x0030,  TRUE, Pool) \
+  EVENT(X, PoolInitAWL        , 0x0031,  TRUE, Pool) \
+  EVENT(X, PoolInitLO         , 0x0032,  TRUE, Pool) \
+  EVENT(X, PoolInitMFS        , 0x0033,  TRUE, Pool) \
+  EVENT(X, PoolInitMVFF       , 0x0034,  TRUE, Pool) \
+  EVENT(X, PoolInitMVT        , 0x0035,  TRUE, Pool) \
+  EVENT(X, PoolInitSNC        , 0x0036,  TRUE, Pool) \
+  EVENT(X, RootScan           , 0x0037,  TRUE, Seg) /* see .kind.abuse */ \
+  EVENT(X, SegAlloc           , 0x0038,  TRUE, Seg) \
+  EVENT(X, SegAllocFail       , 0x0039,  TRUE, Seg) \
+  EVENT(X, SegFree            , 0x003a,  TRUE, Seg) \
+  EVENT(X, SegMerge           , 0x003b,  TRUE, Seg) \
+  EVENT(X, SegReclaim         , 0x003c,  TRUE, Seg) \
+  EVENT(X, SegScan            , 0x003d,  TRUE, Seg) \
+  EVENT(X, SegSetGrey         , 0x003e,  TRUE, Seg) \
+  EVENT(X, SegSetSummary      , 0x003f,  TRUE, Seg) \
+  EVENT(X, SegSplit           , 0x0040,  TRUE, Seg) \
+  EVENT(X, TraceAccess        , 0x0041,  TRUE, Seg) \
+  EVENT(X, TraceBandAdvance   , 0x0042,  TRUE, Trace) \
+  EVENT(X, TraceCondemnAll    , 0x0043,  TRUE, Trace) \
+  EVENT(X, TraceCreate        , 0x0044,  TRUE, Trace) \
+  EVENT(X, TraceCreatePoolGen , 0x0045,  TRUE, Trace) \
+  EVENT(X, TraceDestroy       , 0x0046,  TRUE, Trace) \
+  EVENT(X, TraceEndGen        , 0x0047,  TRUE, Trace) \
+  EVENT(X, TraceFindGrey      , 0x0048,  TRUE, Seg) \
+  EVENT(X, TraceFix           , 0x0049,  TRUE, Ref) \
+  EVENT(X, TraceFixSeg        , 0x004a,  TRUE, Ref) \
+  EVENT(X, TraceFlipBegin     , 0x004b,  TRUE, Trace) \
+  EVENT(X, TraceFlipEnd       , 0x004c,  TRUE, Trace) \
+  EVENT(X, TraceReclaim       , 0x004d,  TRUE, Trace) \
+  EVENT(X, TraceScanArea      , 0x004e,  TRUE, Seg) /* see .kind.abuse */ \
+  EVENT(X, TraceScanAreaTagged, 0x004f,  TRUE, Seg) /* see .kind.abuse */ \
+  EVENT(X, TraceScanSingleRef , 0x0050,  TRUE, Seg) /* see .kind.abuse */ \
+  EVENT(X, TraceStart         , 0x0051,  TRUE, Trace) \
+  EVENT(X, TraceStatFix       , 0x0052,  TRUE, Trace) \
+  EVENT(X, TraceStatReclaim   , 0x0053,  TRUE, Trace) \
+  EVENT(X, TraceStatScan      , 0x0054,  TRUE, Trace) \
+  EVENT(X, VMArenaExtendDone  , 0x0055,  TRUE, Arena) \
+  EVENT(X, VMArenaExtendFail  , 0x0056,  TRUE, Arena) \
+  EVENT(X, VMArenaExtendStart , 0x0057,  TRUE, Arena) \
+  EVENT(X, VMCompact          , 0x0058,  TRUE, Arena) \
+  EVENT(X, VMFinish           , 0x0059,  TRUE, Arena) \
+  EVENT(X, VMInit             , 0x005a,  TRUE, Arena) \
+  EVENT(X, VMMap              , 0x005b,  TRUE, Seg) \
+  EVENT(X, VMUnmap            , 0x005c,  TRUE, Seg)
+
+
+/* Remember to update EventNameMAX and EventCodeMAX above!
+   (These are checked in EventInit.) */
+
+
+/* EVENT_*_PARAMS -- definition of event parameters
+ *
+ * For each event type in EVENT_LIST, these macros list the parameters of
+ * the event.  The columns are:
+ *
+ * 1. index (used to define numeric field names);
+ * 2. sort (Pointer, Addr, Word, Unsigned, String, Double, Bool);
+ * 3. identifier (for display or use in code).
+ * 4. documentation.
+ */
+
+#define EVENT_AMCScanNailed_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, loops, "number of times around the loop") \
+  PARAM(X,  1, W, summary, "summary of segment being scanned") \
+  PARAM(X,  2, W, white, "scan state white set") \
+  PARAM(X,  3, W, unfixed, "scan state unfixed summary") \
+  PARAM(X,  4, W, fixed, "scan state fixed summary") \
+  PARAM(X,  5, W, refset, "scan state refset")
+
+#define EVENT_AWLDeclineSeg_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, seg, "segment declined single access") \
+  PARAM(X,  1, W, singleAccesses, "single accesses this cycle")
+
+#define EVENT_AWLDeclineTotal_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, seg, "segment declined single access") \
+  PARAM(X,  1, W, succAccesses, "total successive accesses")
+
+#define EVENT_ArenaAccessBegin_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, P, addr, "address that was accessed") \
+  PARAM(X,  2, U, mode, "set of access modes")
+
+#define EVENT_ArenaAccessEnd_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena")
+
+#define EVENT_ArenaAlloc_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, P, baseTract, "first allocated tract") \
+  PARAM(X,  2, A, base, "base of the allocated block") \
+  PARAM(X,  3, W, size, "size of the allocated block in bytes") \
+  PARAM(X,  4, P, pool, "pool that requested the allocation")
+
+#define EVENT_ArenaAllocFail_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, W, size, "requested allocation size") \
+  PARAM(X,  2, P, pool, "pool that requested allocation") \
+  PARAM(X,  3, U, res, "result code")
+
+#define EVENT_ArenaCreateCL_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, W, size, "size of memory given to arena in bytes") \
+  PARAM(X,  2, A, base, "base address of memory given to arena") \
+  PARAM(X,  3, W, grainSize, "arena's grain size in bytes") \
+  PARAM(X,  4, P, arenaClass, "arena's class") \
+  PARAM(X,  5, W, systemPools, "number of system pools") \
+  PARAM(X,  6, U, serial, "arena's serial number")
+
+#define EVENT_ArenaCreateVM_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, W, userSize, "requested address space in bytes") \
+  PARAM(X,  2, W, chunkSize, "arena's chunk size in bytes") \
+  PARAM(X,  3, W, grainSize, "arena's grain size in bytes") \
+  PARAM(X,  4, P, arenaClass, "arena's class") \
+  PARAM(X,  5, W, systemPools, "number of system pools") \
+  PARAM(X,  6, U, serial, "arena's serial number")
+
+#define EVENT_ArenaDestroy_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena")
+
+#define EVENT_ArenaExtend_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, A, base, "base of new chunk") \
+  PARAM(X,  2, W, size, "size of new chunk")
+
+#define EVENT_ArenaFree_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, A, base, "base of the freed block") \
+  PARAM(X,  2, W, size, "size of the freed block in bytes") \
+  PARAM(X,  3, P, pool, "pool that freed the block")
+
+#define EVENT_ArenaPollBegin_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "arena about to be polled")
+
+#define EVENT_ArenaPollEnd_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "arena that was polled") \
+  PARAM(X,  1, B, workWasDone, "any collection work done in poll?")
+
+#define EVENT_ArenaSetEmergency_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, B, emergency, "emergency mode?")
+
+#define EVENT_ArenaSetSpare_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, D, spare, "spare committed fraction")
+
+#define EVENT_ArenaUseFreeZone_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, W, zoneSet, "zones that aren't free any longer")
+
+#define EVENT_BufferCommit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, A, p, "committed object") \
+  PARAM(X,  2, W, size, "size of committed object") \
+  PARAM(X,  3, A, clientClass, "format's class of 0 if no format")
+
+#define EVENT_BufferEmpty_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, W, spare, "remaining free memory")
+
+#define EVENT_BufferFill_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, W, size, "size of client request") \
+  PARAM(X,  2, A, base, "base of pool allocation") \
+  PARAM(X,  3, W, filled, "size of pool allocation")
+
+#define EVENT_BufferFinish_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer")
+
+#define EVENT_BufferInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, P, pool, "buffer's pool") \
+  PARAM(X,  2, B, isMutator, "belongs to client program?")
+
+#define EVENT_BufferInitRank_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, P, pool, "buffer's pool") \
+  PARAM(X,  2, B, isMutator, "belongs to client program?") \
+  PARAM(X,  3, U, rank, "rank of references in buffer")
+
+#define EVENT_BufferInitSeg_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, P, pool, "buffer's pool") \
+  PARAM(X,  2, B, isMutator, "belongs to client program?")
+
+#define EVENT_BufferReserve_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, buffer, "the buffer") \
+  PARAM(X,  1, A, init, "buffer's init pointer") \
+  PARAM(X,  2, W, size, "size of client request")
+
+#define EVENT_ChainCondemnAuto_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "chain's arena") \
+  PARAM(X,  1, P, chain, "chain with gens being condemned") \
+  PARAM(X,  2, P, trace, "trace for which gens condemned") \
+  PARAM(X,  3, W, topCondemnedGenIndex, "condemned gens [0..this]") \
+  PARAM(X,  4, W, genCount, "total gens in chain")
+
+#define EVENT_CommitLimitSet_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, W, limit, "new commit limit") \
+  PARAM(X,  2, U, res, "result code")
+
+#define EVENT_EventClockSync_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, clock, "mps_clock() value")
+
+#define EVENT_EventInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, U, major, "EVENT_VERSION_MAJOR") \
+  PARAM(X,  1, U, median, "EVENT_VERSION_MEDIAN") \
+  PARAM(X,  2, U, minor, "EVENT_VERSION_MINOR") \
+  PARAM(X,  3, U, maxCode, "EventCodeMAX") \
+  PARAM(X,  4, U, maxNameLen, "EventNameMAX") \
+  PARAM(X,  5, U, wordWidth, "MPS_WORD_WIDTH") \
+  PARAM(X,  6, W, clocksPerSec, "mps_clocks_per_sec()")
+
+#define EVENT_GenFinish_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "generation's arena") \
+  PARAM(X,  1, P, gen, "the generation") \
+  PARAM(X,  2, U, serial, "serial number within arena")
+
+#define EVENT_GenInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "generation's arena") \
+  PARAM(X,  1, P, gen, "the generation") \
+  PARAM(X,  2, U, serial, "serial number within arena") \
+  PARAM(X,  3, W, capacity, "capacity in bytes") \
+  PARAM(X,  4, D, mortality, "initial mortality estimate")
+
+#define EVENT_GenZoneSet_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "generation's arena") \
+  PARAM(X,  1, P, gen, "the generation") \
+  PARAM(X,  2, W, zoneSet, "generation's new summary")
+
+#define EVENT_Intern_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, stringId, "identifier of interned string") \
+  PARAM(X,  1, S, string, "the interned string")
+
+#define EVENT_Label_PARAMS(PARAM, X) \
+  PARAM(X,  0, A, address, "address") \
+  PARAM(X,  1, W, stringId, "string identifier of its label")
+
+#define EVENT_LabelPointer_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pointer, "pointer") \
+  PARAM(X,  1, W, stringId, "string identifier of its label")
+
+#define EVENT_LandInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, land, "the land") \
+  PARAM(X,  1, P, owner, "owner pointer")
+
+#define EVENT_MessagesDropped_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, count, "count of messages dropped")
+
+#define EVENT_MessagesExist_PARAMS(PARAM, X)
+
+#define EVENT_MeterInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, meter, "the meter") \
+  PARAM(X,  1, P, owner, "owner pointer")
+
+#define EVENT_MeterValues_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, meter, "the meter") \
+  PARAM(X,  1, D, total, "sum of metered amounts") \
+  PARAM(X,  2, D, meanSquared, "mean square of metered amounts") \
+  PARAM(X,  3, W, count, "number of metered amounts") \
+  PARAM(X,  4, W, max, "maximum metered amount") \
+  PARAM(X,  5, W, min, "minimum metered amount")
+
+#define EVENT_PauseTimeSet_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, D, pauseTime, "the new maximum pause time, in seconds")
+
+#define EVENT_PoolAlloc_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, A, pReturn, "base of allocated memory") \
+  PARAM(X,  2, W, size, "size of client request")
+
+#define EVENT_PoolFinish_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, arena, "pool's arena")
+
+#define EVENT_PoolFree_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, A, old, "base of freed memory") \
+  PARAM(X,  2, W, size, "size of client request")
+
+#define EVENT_PoolInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, arena, "pool's arena") \
+  PARAM(X,  2, P, poolClass, "pool's class") \
+  PARAM(X,  3, U, serial, "pool's serial number within the arena")
+
+#define EVENT_PoolInitAMCZ_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, format, "pool's format")
+
+#define EVENT_PoolInitAMC_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, format, "pool's format")
+
+#define EVENT_PoolInitAMS_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, format, "pool's format")
+
+#define EVENT_PoolInitAWL_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, format, "pool's format")
+
+#define EVENT_PoolInitLO_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, format, "pool's format")
+
+#define EVENT_PoolInitMFS_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, W, extendBy, "size of extents") \
+  PARAM(X,  2, B, extendSelf, "automatically extend?") \
+  PARAM(X,  3, W, unitSize, "size of allocations")
+
+#define EVENT_PoolInitMVFF_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, W, extendBy, "size of extents") \
+  PARAM(X,  2, W, avgSize, "predicted mean size of blocks") \
+  PARAM(X,  3, W, align, "alignment of blocks") \
+  PARAM(X,  4, B, slotHigh, "allocate at high addresses within extents?") \
+  PARAM(X,  5, B, arenaHigh, "allocate extents at high addresses?") \
+  PARAM(X,  6, B, firstFit, "allocate from first free block?")
+
+#define EVENT_PoolInitMVT_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, W, minSize, "predicted minimum size of blocks") \
+  PARAM(X,  2, W, meanSize, "predicted mean size of blocks") \
+  PARAM(X,  3, W, maxSize, "predicted maximum size of blocks") \
+  PARAM(X,  4, W, reserveDepth, "reserve space for this many allocations") \
+  PARAM(X,  5, W, fragLimig, "fragmentation limit")
+
+#define EVENT_PoolInitSNC_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, pool, "the pool") \
+  PARAM(X,  1, P, format, "pool's format")
+
+#define EVENT_RootScan_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, root, "the root") \
+  PARAM(X,  1, W, ts, "scanning for this set of traces") \
+  PARAM(X,  2, W, summary, "summary after scan")
+
+#define EVENT_SegAlloc_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, P, seg, "new segment") \
+  PARAM(X,  2, A, base, "base address") \
+  PARAM(X,  3, W, size, "segment size") \
+  PARAM(X,  4, P, pool, "pool making request")
+
+#define EVENT_SegAllocFail_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, W, size, "requested segment size") \
+  PARAM(X,  2, P, pool, "pool making request") \
+  PARAM(X,  3, U, res, "result code")
+
+#define EVENT_SegFree_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "segment's arena") \
+  PARAM(X,  1, P, seg, "the segment")
+
+#define EVENT_SegMerge_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, segLo, "low segment") \
+  PARAM(X,  1, P, segHi, "high segment")
+
+#define EVENT_SegReclaim_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, seg, "the segment") \
+  PARAM(X,  1, P, pool, "segment's pool") \
+  PARAM(X,  2, P, arena, "pool's arena") \
+  PARAM(X,  3, P, trace, "reclaiming for this trace")
+
+#define EVENT_SegScan_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, seg, "the segment") \
+  PARAM(X,  1, P, pool, "segment's pool") \
+  PARAM(X,  2, P, arena, "pool's arena") \
+  PARAM(X,  3, U, ts, "scanning for this set of traces") \
+  PARAM(X,  4, U, rank, "scanning at this rank")
+
+#define EVENT_SegSetGrey_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "segment's arena") \
+  PARAM(X,  1, P, seg, "the segment") \
+  PARAM(X,  2, U, grey, "greyen for this set of traces")
+
+#define EVENT_SegSetSummary_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "segment's arena") \
+  PARAM(X,  1, P, seg, "the segment") \
+  PARAM(X,  2, W, size, "its size in bytes") \
+  PARAM(X,  3, W, oldSummary, "old summary") \
+  PARAM(X,  4, W, newSummary, "new summary")
+
+#define EVENT_SegSplit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, seg, "old segment") \
+  PARAM(X,  1, P, segLo, "new low segment") \
+  PARAM(X,  2, P, segHi, "new high segment") \
+  PARAM(X,  3, A, at, "split address")
+
+#define EVENT_TraceAccess_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, P, seg, "segment accessed") \
+  PARAM(X,  2, U, mode, "set of access modes")
+
+#define EVENT_TraceBandAdvance_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, P, trace, "the trace") \
+  PARAM(X,  2, W, rank, "new rank")
+
+#define EVENT_TraceCondemnAll_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "trace's arena") \
+  PARAM(X,  1, P, trace, "trace")
+
+#define EVENT_TraceCreate_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "trace that was created") \
+  PARAM(X,  1, P, arena, "arena in which created") \
+  PARAM(X,  2, U, why, "reason for creation")
+
+#define EVENT_TraceCreatePoolGen_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, gen, "generation") \
+  PARAM(X,  1, W, capacity, "capacity of generation") \
+  PARAM(X,  2, D, mortality, "mortality of generation") \
+  PARAM(X,  3, W, zone, "zone set of generation") \
+  PARAM(X,  4, P, pool, "pool") \
+  PARAM(X,  5, W, totalSize, "total size of pool gen") \
+  PARAM(X,  6, W, freeSize, "free size of pool gen") \
+  PARAM(X,  7, W, newSize, "new size of pool gen") \
+  PARAM(X,  8, W, oldSize, "old size of pool gen") \
+  PARAM(X,  9, W, newDeferredSize, "new size (deferred) of pool gen") \
+  PARAM(X, 10, W, oldDeferredSize, "old size (deferred) of pool gen")
+
+#define EVENT_TraceDestroy_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "trace's arena") \
+  PARAM(X,  1, P, trace, "the trace")
+
+#define EVENT_TraceEndGen_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "the arena") \
+  PARAM(X,  1, P, trace, "the trace") \
+  PARAM(X,  2, P, gen, "the generation") \
+  PARAM(X,  3, W, condemned, "bytes condemned in generation") \
+  PARAM(X,  4, W, forwarded, "bytes forwarded from generation") \
+  PARAM(X,  5, W, preservedInPlace, "bytes preserved in generation") \
+  PARAM(X,  6, D, mortalityTrace, "mortality (in last trace only)") \
+  PARAM(X,  7, D, mortalityAverage, "mortality (moving average)")
+
+#define EVENT_TraceFindGrey_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "trace's arena") \
+  PARAM(X,  1, P, trace, "the trace") \
+  PARAM(X,  2, P, seg, "grey segment found") \
+  PARAM(X,  3, W, rank, "current rank")
+
+#define EVENT_TraceFix_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, ss, "the scan state") \
+  PARAM(X,  1, P, refIO, "pointer to reference") \
+  PARAM(X,  2, A, ref, "reference fixed") \
+  PARAM(X,  3, U, rank, "current rank")
+
+#define EVENT_TraceFixSeg_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, seg, "the segment")
+
+#define EVENT_TraceFlipBegin_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "the trace") \
+  PARAM(X,  1, P, arena, "trace's arena")
+
+#define EVENT_TraceFlipEnd_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "the trace") \
+  PARAM(X,  1, P, arena, "trace's arena")
+
+#define EVENT_TraceReclaim_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "the trace") \
+  PARAM(X,  1, P, arena, "trace's arena")
+
+#define EVENT_TraceScanArea_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, ss, "the scan state") \
+  PARAM(X,  1, P, base, "base of scanned area") \
+  PARAM(X,  2, P, limit, "limit of scanned area")
+
+#define EVENT_TraceScanAreaTagged_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, ss, "the scan state") \
+  PARAM(X,  1, P, base, "base of scanned area") \
+  PARAM(X,  2, P, limit, "limit of scanned area")
+
+#define EVENT_TraceScanSingleRef_PARAMS(PARAM, X) \
+  PARAM(X,  0, U, ts, "set of traces") \
+  PARAM(X,  1, U, rank, "current rank") \
+  PARAM(X,  2, P, arena, "traces' arena") \
+  PARAM(X,  3, P, refIO, "pointer to reference")
+
+#define EVENT_TraceStart_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, arena, "trace's arena") \
+  PARAM(X,  1, P, trace, "trace being started") \
+  PARAM(X,  2, D, mortality, "as passed to TraceStart") \
+  PARAM(X,  3, D, finishingTime, "as passed to TraceStart") \
+  PARAM(X,  4, W, condemned, "condemned bytes") \
+  PARAM(X,  5, W, notCondemned, "collectible but not condemned bytes") \
+  PARAM(X,  6, W, foundation, "foundation size") \
+  PARAM(X,  7, W, white, "white reference set") \
+  PARAM(X,  8, W, quantumWork, "tracing work to be done in each poll")
+
+#define EVENT_TraceStatFix_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "the trace") \
+  PARAM(X,  1, P, arena, "trace's arena") \
+  PARAM(X,  2, W, fixRefCount, "references which pass zone check") \
+  PARAM(X,  3, W, segRefCount, "references which refer to segments") \
+  PARAM(X,  4, W, whiteSegRefCount, "references which refer to white segments") \
+  PARAM(X,  5, W, nailCount, "segments nailed by ambiguous references") \
+  PARAM(X,  6, W, snapCount, "references snapped to forwarded objects") \
+  PARAM(X,  7, W, forwardedCount, "objects preserved by moving") \
+  PARAM(X,  8, W, forwardedSize, "bytes preserved by moving") \
+  PARAM(X,  9, W, preservedInPlaceCount, "objects preserved in place") \
+  PARAM(X, 10, W, preservedInPlaceSize, "bytes preserved in place")
+
+#define EVENT_TraceStatReclaim_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "the trace") \
+  PARAM(X,  1, P, arena, "trace's arena") \
+  PARAM(X,  2, W, reclaimCount, "segments reclaimed") \
+  PARAM(X,  3, W, reclaimSize, "bytes reclaimed")
+
+#define EVENT_TraceStatScan_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, trace, "the trace") \
+  PARAM(X,  1, P, arena, "trace's arena") \
+  PARAM(X,  2, W, rootScanCount, "number of roots scanned") \
+  PARAM(X,  3, W, rootScanSize, "total size of scanned roots") \
+  PARAM(X,  4, W, rootCopiedSize, "bytes copied by scanning roots ") \
+  PARAM(X,  5, W, segScanCount, "number of segments scanned") \
+  PARAM(X,  6, W, segScanSize, "total size of scanned segments") \
+  PARAM(X,  7, W, segCopiedSize, "bytes copied by scanning segments") \
+  PARAM(X,  8, W, singleScanCount, "number of single references scanned") \
+  PARAM(X,  9, W, singleScanSize, "total size of single references scanned") \
+  PARAM(X, 10, W, singleCopiedSize, "bytes copied by scanning single references") \
+  PARAM(X, 11, W, readBarrierHitCount, "read barrier faults") \
+  PARAM(X, 12, W, greySegMax, "maximum number of grey segments") \
+  PARAM(X, 13, W, pointlessScanCount, "pointless segment scans")
+
+#define EVENT_VMArenaExtendDone_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, chunkSize, "request succeeded for chunkSize bytes") \
+  PARAM(X,  1, W, reserved, "new VMArenaReserved")
+
+#define EVENT_VMArenaExtendFail_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, chunkMin, "no remaining address space chunk >= chunkMin") \
+  PARAM(X,  1, W, reserved, "current VMArenaReserved")
+
+#define EVENT_VMArenaExtendStart_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, size, "size to accommodate") \
+  PARAM(X,  1, W, chunkSize, "chunkSize to try") \
+  PARAM(X,  2, W, reserved, "current VMArenaReserved")
+
+#define EVENT_VMCompact_PARAMS(PARAM, X) \
+  PARAM(X,  0, W, vmem0, "pre-collection reserved size") \
+  PARAM(X,  1, W, vmem1, "pre-compact reserved size") \
+  PARAM(X,  2, W, vmem2, "post-compact reserved size")
+
+#define EVENT_VMFinish_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, vm, "the VM")
+
+#define EVENT_VMInit_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, vm, "the VM") \
+  PARAM(X,  1, A, base, "base of VM") \
+  PARAM(X,  2, A, limit, "limit of VM")
+
+#define EVENT_VMMap_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, vm, "the VM") \
+  PARAM(X,  1, A, base, "base of mapped addresses") \
+  PARAM(X,  2, A, limit, "limit of mapped addresses")
+
+#define EVENT_VMUnmap_PARAMS(PARAM, X) \
+  PARAM(X,  0, P, vm, "the VM") \
+  PARAM(X,  1, A, base, "base of unmapped addresses") \
+  PARAM(X,  2, A, limit, "limit of unmapped addresses")
+
+#endif /* eventdef_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/eventpy.c

@@ -0,0 +1,226 @@
+/* eventpy.c: GENERATE PYTHON INTERFACE TO EVENTS
+ *
+ * $Id$
+ * Copyright (c) 2016-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * This command-line program emits Python data structures that can be
+ * used to parse a telemetry stream in the binary format for the
+ * platform it was compiled for.
+ */
+
+#include <assert.h> /* assert */
+#include <stddef.h> /* offsetof */
+#include <stdio.h> /* printf, puts */
+
+#include "event.h"
+
+/* See <https://docs.python.org/3/library/struct.html#byte-order-size-and-alignment> */
+#if defined(MPS_ARCH_A6) || defined(MPS_ARCH_I3) || defined(MPS_ARCH_I6)
+#define BYTE_ORDER "<"
+#else
+#error "Can't determine byte order for platform architecture."
+#endif
+
+
+/* format -- output struct format code corresponding to event field
+ *
+ * size is the size of the field in bytes
+ * sort is a one-character string corresponding to the EventF* typedef
+ * for the field, thus "P" for a field of type EventFP.
+ *
+ * See <https://docs.python.org/3/library/struct.html>
+ */
+
+static void format(size_t size, const char *sort)
+{
+  switch (sort[0]) {
+  case 'B':
+    printf("?");
+    break;
+  case 'D':
+    printf("d");
+    break;
+  case 'S':
+    /* Strings can't be handled through the struct format mechanism
+       because we don't know their length until the header has been
+       read. */
+    break;
+  default:
+    switch (size) {
+    case 1:
+      printf("B");
+      break;
+    case 2:
+      printf("H");
+      break;
+    case 4:
+      printf("L");
+      break;
+    case 8:
+      printf("Q");
+      break;
+    default:
+      assert(FALSE);
+      break;
+    }
+  }
+}
+
+int main(int argc, char *argv[])
+{
+  size_t size, prev_offset;
+  char prev_sort;
+  UNUSED(argc);
+  UNUSED(argv);
+
+  puts("from collections import namedtuple");
+
+  printf("\n__version__ = %d, %d, %d\n", EVENT_VERSION_MAJOR,
+         EVENT_VERSION_MEDIAN, EVENT_VERSION_MINOR);
+
+  puts("\n# Description of an event kind.");
+  puts("KindDesc = namedtuple('KindDesc', 'name code doc')");
+
+  puts("\n# Namespace containing a KindDesc for every kind.");
+  puts("class Kind:");
+#define ENUM(X, NAME, DOC)                                      \
+  printf("    " #NAME " = KindDesc('" #NAME "', %d, '%s')\n",   \
+         EventKind ## NAME, DOC);
+  EventKindENUM(ENUM, X);
+#undef ENUM
+
+  puts("\n# Mapping from kind number to KindDesc.");
+  puts("KIND = {");
+#define ENUM(X, NAME, DOC) \
+  printf("    %d: Kind." #NAME ",\n", EventKind ## NAME);
+  EventKindENUM(ENUM, X);
+#undef ENUM
+  puts("}");
+
+  puts("\n# Description of a parameter of an event.");
+  puts("EventParam = namedtuple('EventParam', 'sort name doc')");
+
+  puts("\n# Description of the parameters of an event.");
+  puts("EventDesc = namedtuple('EventDesc', "
+       "'name code used kind params maxsize format')");
+
+  puts("\n# Namespace containing an EventDesc for every event.");
+  puts("class Event:");
+#define PAD_TO(OFFSET)                                  \
+  BEGIN {                                               \
+    size_t offset = (OFFSET);                           \
+    if (prev_sort != 'S' && prev_offset < offset)       \
+      printf("%ux", (unsigned)(offset - prev_offset));  \
+    prev_offset = offset;                               \
+  } END
+#define EVENT_PARAM(X, INDEX, SORT, IDENT, DOC)                         \
+  puts("        EventParam('" #SORT "', '" #IDENT "', \"" DOC "\"),");  \
+  prev_sort = #SORT[0];
+#define EVENT_FORMAT(NAME, INDEX, SORT, IDENT, DOC)     \
+  PAD_TO(offsetof(Event##NAME##Struct, f##INDEX));      \
+  format(sizeof(EventF##SORT), #SORT);                  \
+  prev_offset += sizeof(EventF##SORT);
+#define EVENT_DEFINE(X, NAME, CODE, USED, KIND)                         \
+  printf("    " #NAME " = EventDesc('" #NAME "', %d, %s, Kind." #KIND ", [\n", \
+         CODE, USED ? "True" : "False");                                \
+  EVENT_ ## NAME ## _PARAMS(EVENT_PARAM, X);                            \
+  size = sizeof(Event##NAME##Struct) - sizeof(EventAnyStruct);          \
+  printf("    ], %u, '%s", (unsigned)size, BYTE_ORDER);                 \
+  prev_offset = sizeof(EventAnyStruct);                                 \
+  EVENT_ ## NAME ## _PARAMS(EVENT_FORMAT, NAME);                        \
+  PAD_TO(sizeof(Event##NAME##Struct));                                  \
+  puts("')");
+  EVENT_LIST(EVENT_DEFINE, 0);
+#undef EVENT_DEFINE
+#undef EVENT_PARAM
+#undef EVENT_FORMAT
+
+  puts("\n# Mapping from event number to EventDesc.");
+  puts("EVENT = {");
+#define EVENT_ITEM(X, NAME, CODE, USED, KIND) \
+  printf("    %d: Event." #NAME ",\n", CODE);
+  EVENT_LIST(EVENT_ITEM, 0);
+#undef EVENT_ITEM
+  puts("}");
+
+  puts("\n# Description of an event header.");
+  printf("HeaderDesc = namedtuple('HeaderDesc', '");
+#define EVENT_FIELD(TYPE, NAME, DOC) printf("%s ", #NAME);
+  EVENT_ANY_FIELDS(EVENT_FIELD)
+#undef EVENT_FIELD
+  puts("')\nHeaderDesc.__doc__ = '''");
+#define EVENT_FIELD(TYPE, NAME, DOC) printf("%s -- %s\n", #NAME, DOC);
+  EVENT_ANY_FIELDS(EVENT_FIELD)
+#undef EVENT_FIELD
+  puts("'''");
+
+  puts("\n# Size of event header in bytes.");
+  printf("HEADER_SIZE = %u\n", (unsigned)sizeof(EventAnyStruct));
+
+  puts("\n# Struct format for event header.");
+  printf("HEADER_FORMAT = '%s", BYTE_ORDER);
+  prev_offset = 0;
+#define EVENT_FIELD(TYPE, NAME, DOC)            \
+  PAD_TO(offsetof(EventAnyStruct, NAME));       \
+  format(sizeof(TYPE), "?");                    \
+  prev_offset += sizeof(TYPE);
+  EVENT_ANY_FIELDS(EVENT_FIELD)
+#undef EVENT_FIELD
+  PAD_TO(sizeof(EventAnyStruct));
+  puts("'");
+
+  puts("\n# Mapping from access mode to its name.");
+  puts("ACCESS_MODE = {");
+  printf("    %u: \"READ\",\n", (unsigned)AccessREAD);
+  printf("    %u: \"WRITE\",\n", (unsigned)AccessWRITE);
+  printf("    %u: \"READ/WRITE\",\n",
+         (unsigned)BS_UNION(AccessREAD, AccessWRITE));
+  puts("}");
+
+  puts("\n# Mapping from rank to its name.");
+  puts("RANK = {");
+#define X(RANK) printf("    %u: \"%s\",\n", (unsigned)Rank ## RANK, #RANK);
+  RANK_LIST(X)
+#undef X
+  puts("}");
+
+  puts("\n# Mapping from trace start reason to its short description.");
+  puts("TRACE_START_WHY = {");
+#define X(WHY, SHORT, LONG) \
+  printf("    %u: \"%s\",\n", (unsigned)TraceStartWhy ## WHY, SHORT);
+  TRACE_START_WHY_LIST(X)
+#undef X
+  puts("}");
+
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2016-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/eventsql.c

@@ -0,0 +1,997 @@
+/* eventsql.c: event log to SQLite importer.
+ *
+ * $Id$
+ *
+ * Copyright (c) 2012-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * This is a command-line tool that imports events from a text-format
+ * MPS telemetry file into a SQLite database file.
+ *
+ * The default MPS library will write a binary-format telemetry file
+ * which can be converted into a text-format file using the eventcnv
+ * program (q.v.).
+ *
+ * Each event type gets its own table in the database.  These tables
+ * are created from the definitions in eventdef.h if they don't
+ * already exist.  Each event becomes a single row in the appropriate
+ * table, which has a column for each event parameter, a time column
+ * for the event time field, and a log_serial column to identify the
+ * source log file.  Because the database schema depends on the event
+ * definitions in eventdef.h, eventsql has to be compiled using the
+ * same event header files as those used to compile the MPS and
+ * eventcnv which generated and processed the telemetry output.
+ *
+ * The program also creates several other tables: three 'glue' tables
+ * containing event metadata - event_kind (one row per kind),
+ * event_type (one row per type), and event_param (one row per
+ * parameter), all derived from eventdef.h - and the event_log table
+ * which has one row per log file imported (the log_serial column in
+ * the event tables is a primary key to this event_log table).
+ *
+ * No tables are created if they already exist, unless the -r
+ * (rebuild) switch is given.
+ *
+ * Options:
+ *
+ * -v (verbose): Increase verbosity.  eventsql logs to stderr.  By
+ *  default, it doesn't log much; it can be made more and more
+ *  loquacious by adding more -v switches.
+ *
+ * -p (progress): Show progress with a series of dots written to
+ * standard output (one dot per 100,000 events processed).  Defaults
+ * on if -v specified, off otherwise.
+ *
+ * -t (test):  Run unit tests on parts of eventsql.  There aren't many
+ * of these.  TODO: write more unit tests.
+ *
+ * -d (delete): Delete the SQL file before importing.
+ *
+ * -f (force): Import the events to SQL even if the SQL database
+ * already includes a record of importing a matching log file.
+ *
+ * -r (rebuild): Drop the glue tables from SQL, which will force them
+ * to be recreated.  Important if you change event types or kinds in
+ * eventdef.h.
+ *
+ * -i <logfile>: Import events from the named logfile.  Defaults to
+ * standard input.  If the specified file (matched by size and
+ * modtime) has previously been imported to the same database, it will
+ * not be imported again unless -f is specified.
+ *
+ * -o <database>: Import events to the named database file.  If not
+ * specified, eventsql will use the MPS_TELEMETRY_DATABASE environment
+ * variable, and default to "mpsevent.db".
+ *
+ * $Id$
+ */
+
+#include "misc.h"
+#include "config.h"
+#include "eventdef.h"
+#include "eventcom.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/stat.h>
+
+/* on Windows, we build SQLite locally from the amalgamated sources */
+#ifdef MPS_BUILD_MV
+#include "sqlite3.h"
+#else
+#include <sqlite3.h>
+#endif
+
+#define DATABASE_NAME_ENVAR   "MPS_TELEMETRY_DATABASE"
+#define DEFAULT_DATABASE_NAME "mpsevent.db"
+
+#ifdef MPS_BUILD_MV
+#define strtoll _strtoi64
+#endif
+
+
+typedef sqlite3_int64 int64;
+
+/* At non-zero verbosity levels we output rows of dots.  One dot per
+ * SMALL_TICK events, BIG_TICK dots per row. */
+
+#define SMALL_TICK 100000
+#define BIG_TICK   50
+
+/* Utility code for logging to stderr with multiple log levels,
+ * and for reporting errors.
+ */
+
+static unsigned int verbosity = 0;
+
+#define LOG_ALWAYS    0
+#define LOG_OFTEN     1
+#define LOG_SOMETIMES 2
+#define LOG_SELDOM    3
+#define LOG_RARELY    4
+
+ATTRIBUTE_FORMAT((printf, 2, 0))
+static void vlog(unsigned int level, const char *format, va_list args)
+{
+  if (level <= verbosity) {
+    fflush(stderr); /* sync */
+    fprintf(stderr, "log %d: ", level);
+    vfprintf(stderr, format, args);
+    fprintf(stderr, "\n");
+  }
+}
+
+ATTRIBUTE_FORMAT((printf, 2, 3))
+static void evlog(unsigned int level, const char *format, ...)
+{
+  va_list args;
+  va_start(args, format);
+  vlog(level, format, args);
+  va_end(args);
+}
+
+ATTRIBUTE_FORMAT((printf, 1, 2))
+static void error(const char *format, ...)
+{
+  va_list args;
+  fprintf(stderr, "Fatal error: ");
+  va_start(args, format);
+  vlog(LOG_ALWAYS, format, args);
+  va_end(args);
+  exit(1);
+}
+
+static void sqlite_error(int res, sqlite3 *db, const char *format, ...)
+{
+  va_list args;
+  evlog(LOG_ALWAYS, "Fatal SQL error %d", res);
+  va_start(args, format);
+  vlog(LOG_ALWAYS, format, args);
+  va_end(args);
+  evlog(LOG_ALWAYS, "SQLite message: %s\n", sqlite3_errmsg(db));
+  exit(1);
+}
+
+/* global control variables set by command-line parameters. */
+
+static const char *prog; /* program name */
+static int rebuild = FALSE;
+static int deleteDatabase = FALSE;
+static int runTests = FALSE;
+static int force = FALSE;
+static int progress = FALSE;
+static const char *databaseName = NULL;
+static const char *logFileName = NULL;
+
+static void usage(void)
+{
+  fprintf(stderr,
+          "Usage: %s [-rfdvt] [-i <logfile>] [-o <database>]\n"
+          "    -h (help)    : this message.\n"
+          "    -r (rebuild) : re-create glue tables.\n"
+          "    -f (force)   : ignore previous import of same logfile.\n"
+          "    -d (delete)  : delete and recreate database file.\n"
+          "    -v (verbose) : increase logging to stderr.\n"
+          "    -p (progress): show progress with dots to stdout.\n"
+          "    -t (test)    : run self-tests.\n"
+          "    -i <logfile> : read logfile (defaults to stdin)\n"
+          "    -o <database>: write database (defaults to\n"
+          "                   "
+          DATABASE_NAME_ENVAR " or " DEFAULT_DATABASE_NAME ").\n",
+          prog);
+}
+
+static void usageError(void)
+{
+  usage();
+  error("Bad usage");
+}
+
+/* parseArgs -- parse command line arguments */
+
+static void parseArgs(int argc, char *argv[])
+{
+  int i = 1;
+
+  if (argc >= 1)
+    prog = argv[0];
+  else
+    prog = "unknown";
+
+  while(i < argc) { /* consider argument i */
+    if (argv[i][0] == '-') { /* it's an option argument */
+      char *p = argv[i] + 1;
+      while(*p) {
+        switch (*p) {
+        case 'v': /* verbosity */
+          ++ verbosity;
+          break;
+        case 'p': /* progress */
+          progress = TRUE;
+          break;
+        case 'r': /* rebuild */
+          rebuild = TRUE;
+          break;
+        case 'd': /* rebuild */
+          deleteDatabase = TRUE;
+          break;
+        case 'f': /* force */
+          force = TRUE;
+          break;
+        case 't': /* run tests */
+          runTests = TRUE;
+          break;
+        case 'i': /* input (log file) name */
+          if (p[1] == '\0') { /* last character in this arg; name is next arg */
+            logFileName = argv[i+1];
+            ++ i;
+          } else { /* not last character in arg; name is rest of arg */
+            logFileName = p+1;
+          }
+          goto next_i;
+        case 'o': /* output (database file) name */
+          if (p[1] == '\0') { /* last character in this arg; name is next arg */
+            databaseName = argv[i+1];
+            ++ i;
+          } else { /* not last character in arg; name is rest of arg */
+            databaseName = p+1;
+          }
+          goto next_i;
+        case 'h':
+          usage();
+          exit(EXIT_SUCCESS);
+        default:
+          usageError();
+        }
+        ++ p;
+      }
+    } else { /* not an option argument */
+      usageError();
+    }
+  next_i:
+    ++ i;
+  }
+  if (verbosity > LOG_ALWAYS)
+    progress = TRUE;
+}
+
+/* openDatabase(p) opens the database file and returns a SQLite 3
+ * database connection object. */
+
+static sqlite3 *openDatabase(void)
+{
+  sqlite3 *db;
+  int res;
+
+  if (!databaseName) {
+    databaseName = getenv(DATABASE_NAME_ENVAR);
+    if(!databaseName)
+      databaseName = DEFAULT_DATABASE_NAME;
+  }
+
+  if (deleteDatabase) {
+    res = remove(databaseName);
+    if (res)
+      evlog(LOG_ALWAYS, "Could not remove database file %s", databaseName);
+    else
+      evlog(LOG_OFTEN, "Removed database file %s", databaseName);
+  }
+
+  res = sqlite3_open_v2(databaseName,
+                        &db,
+                        SQLITE_OPEN_READWRITE | SQLITE_OPEN_CREATE,
+                        NULL); /* use default sqlite_vfs object */
+
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "Opening %s failed", databaseName);
+
+  evlog(LOG_OFTEN, "Writing to %s.",databaseName);
+
+  return db;
+}
+
+/* closeDatabase(db) closes the database opened by openDatabase(). */
+
+static void closeDatabase(sqlite3 *db)
+{
+  int res = sqlite3_close(db);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "Closing database failed");
+  evlog(LOG_SOMETIMES, "Closed %s.", databaseName);
+}
+
+/* Utility functions for SQLite statements. */
+
+static sqlite3_stmt *prepareStatement(sqlite3 *db,
+                                      const char *sql)
+{
+  int res;
+  sqlite3_stmt *statement;
+  evlog(LOG_SELDOM, "Preparing statement %s", sql);
+  res = sqlite3_prepare_v2(db, sql,
+                           -1, /* prepare whole string as statement */
+                           &statement,
+                           NULL);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "statement preparation failed: %s", sql);
+  return statement;
+}
+
+static void finalizeStatement(sqlite3 *db,
+                              sqlite3_stmt *statement)
+{
+  int res;
+  res = sqlite3_finalize(statement);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "statement finalize failed");
+}
+
+static void runStatement(sqlite3 *db,
+                         const char *sql,
+                         const char *description)
+{
+  int res;
+  evlog(LOG_SELDOM, "%s: %s", description, sql);
+  res = sqlite3_exec(db,
+                     sql,
+                     NULL, /* No callback */
+                     NULL, /* No callback closure */
+                     NULL); /* error messages handled by sqlite_error */
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "%s failed - statement %s", description, sql);
+}
+
+/* Test for the existence of a table using sqlite_master table.
+ */
+
+static int tableExists(sqlite3* db, const char *tableName)
+{
+  int res;
+  int exists = 0;
+  sqlite3_stmt *statement = NULL;
+
+  statement = prepareStatement(db,
+                               "SELECT 1 FROM sqlite_master WHERE type='table' AND name=?");
+  res = sqlite3_bind_text(statement, 1, tableName, -1, SQLITE_STATIC);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "table existence bind of name failed.");
+  res = sqlite3_step(statement);
+  switch(res) {
+  case SQLITE_DONE:
+    exists = 0;
+    break;
+  case SQLITE_ROW:
+    exists = 1;
+    break;
+  default:
+    sqlite_error(res, db, "select from sqlite_master failed.");
+  }
+  finalizeStatement(db, statement);
+  return exists;
+}
+
+/* Unit test for tableExists() */
+
+static struct {
+  const char* name;
+  int exists;
+} tableTests[] = {
+  {"event_kind", TRUE},
+  {"spong", FALSE},
+  {"EVENT_SegSplit", TRUE}
+};
+
+static void testTableExists(sqlite3 *db)
+{
+  size_t i;
+  int defects = 0;
+  int tests = 0;
+  for (i=0; i < NELEMS(tableTests); ++i) {
+    const char *name = tableTests[i].name;
+    int exists = tableExists(db, name);
+    if (exists)
+      evlog(LOG_OFTEN, "Table exists: %s", name);
+    else
+      evlog(LOG_OFTEN, "Table does not exist: %s", name);
+    if (exists != tableTests[i].exists) {
+      evlog(LOG_ALWAYS, "tableExists test failed on table %s", name);
+      ++ defects;
+    }
+    ++ tests;
+  }
+  evlog(LOG_ALWAYS, "%d tests, %d defects found.", tests, defects);
+}
+
+/* Every time we put events from a log file into a database file, we
+ * add the log file to the event_log table, and get a serial number
+ * from SQL which is then attached to all event rows from that log.
+ * We use this to record overall SQL activity, to deter mistaken
+ * attempts to add the same log file twice, and to allow events from
+ * several different log files to share the same SQL file.
+ *
+ * When reading events from stdin, we can't so easily avoid the
+ * duplication (unless we, e.g., take a hash of the event set); we
+ * have to assume that the user is smart enough not to do that.
+ */
+
+static int64 logSerial = 0;
+
+static void registerLogFile(sqlite3 *db,
+                            const char *filename)
+{
+  sqlite3_stmt *statement;
+  int res;
+  const unsigned char *name;
+  int64 completed;
+  int64 file_size;
+  int64 file_modtime;
+
+  if (filename) {
+    struct stat st;
+    res = stat(filename, &st);
+    if (res != 0)
+      error("Couldn't stat() %s", filename);
+    file_size = st.st_size;
+    file_modtime = st.st_mtime;
+
+    statement = prepareStatement(db,
+                                 "SELECT name, serial, completed FROM event_log"
+                                 " WHERE size = ? AND modtime = ?");
+    res = sqlite3_bind_int64(statement, 1, file_size);
+    if (res != SQLITE_OK)
+      sqlite_error(res, db, "event_log bind of size failed.");
+    res = sqlite3_bind_int64(statement, 2, file_modtime);
+    if (res != SQLITE_OK)
+      sqlite_error(res, db, "event_log bind of modtime failed.");
+    res = sqlite3_step(statement);
+    switch(res) {
+    case SQLITE_DONE:
+      evlog(LOG_SOMETIMES, "No log file matching '%s' found in database.", filename);
+      break;
+    case SQLITE_ROW:
+      name = sqlite3_column_text(statement, 0);
+      logSerial = sqlite3_column_int64(statement, 1);
+      completed = sqlite3_column_int64(statement, 2);
+      evlog(force ? LOG_OFTEN : LOG_ALWAYS, "Log file matching '%s' already in event_log, named \"%s\" (serial %llu, completed %llu).",
+            filename, name, logSerial, completed);
+      if (force) {
+        evlog(LOG_OFTEN, "Continuing anyway because -f specified.");
+      } else {
+        evlog(LOG_ALWAYS, "Exiting.  Specify -f to force events into SQL anyway.");
+        exit(0);
+      }
+      break;
+    default:
+      sqlite_error(res, db, "select from event_log failed.");
+    }
+    finalizeStatement(db, statement);
+  } else { /* stdin */
+    filename = "<stdin>";
+    file_size = 0;
+    file_modtime = 0;
+  }
+  statement = prepareStatement(db,
+                               "INSERT into event_log (name, size, modtime, completed)"
+                               " VALUES (?, ?, ?, 0)");
+  res = sqlite3_bind_text(statement, 1, filename, -1, SQLITE_STATIC);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event_log insert bind of name failed.");
+  res = sqlite3_bind_int64(statement, 2, file_size);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event_log insert bind of size failed.");
+  res = sqlite3_bind_int64(statement, 3, file_modtime);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event_log insert bind of modtime failed.");
+  res = sqlite3_step(statement);
+  if (res != SQLITE_DONE)
+    sqlite_error(res, db, "insert into event_log failed.");
+  logSerial = sqlite3_last_insert_rowid(db);
+  evlog(LOG_SOMETIMES, "Log file %s added to event_log with serial %llu",
+        filename, logSerial);
+  finalizeStatement(db, statement);
+}
+
+static void logFileCompleted(sqlite3 *db,
+                             int64 completed)
+{
+  sqlite3_stmt *statement;
+  int res;
+
+  statement = prepareStatement(db,
+                               "UPDATE event_log SET completed=? WHERE serial=?");
+  res = sqlite3_bind_int64(statement, 2, logSerial);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event_log update bind of serial failed.");
+  res = sqlite3_bind_int64(statement, 1, completed);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event_log update bind of completed failed.");
+  res = sqlite3_step(statement);
+  if (res != SQLITE_DONE)
+    sqlite_error(res, db, "insert into event_log failed.");
+  evlog(LOG_SOMETIMES, "Marked in event_log: %llu events", completed);
+  finalizeStatement(db, statement);
+}
+
+/* Macro magic to make a CREATE TABLE statement for each event type. */
+
+#define EVENT_PARAM_SQL_TYPE_A "INTEGER"
+#define EVENT_PARAM_SQL_TYPE_P "INTEGER"
+#define EVENT_PARAM_SQL_TYPE_U "INTEGER"
+#define EVENT_PARAM_SQL_TYPE_W "INTEGER"
+#define EVENT_PARAM_SQL_TYPE_D "REAL   "
+#define EVENT_PARAM_SQL_TYPE_S "TEXT   "
+#define EVENT_PARAM_SQL_TYPE_B "INTEGER"
+
+#define EVENT_PARAM_SQL_COLUMN(X, index, sort, ident, doc) \
+        "\"" #ident "\" " EVENT_PARAM_SQL_TYPE_##sort ", "
+
+#define EVENT_TABLE_CREATE(X, name, code, used, kind) \
+        "CREATE TABLE IF NOT EXISTS EVENT_" #name " ( " \
+        EVENT_##name##_PARAMS(EVENT_PARAM_SQL_COLUMN, X) \
+        "time INTEGER, " \
+        "log_serial INTEGER)",
+
+/* An array of table-creation statement strings. */
+
+static const char *createStatements[] = {
+  "CREATE TABLE IF NOT EXISTS event_kind (name    TEXT,"
+  "                                       description TEXT,"
+  "                                       enum    INTEGER PRIMARY KEY)",
+
+  "CREATE TABLE IF NOT EXISTS event_type (name    TEXT,"
+  "                                       code    INTEGER PRIMARY KEY,"
+  "                                       used    INTEGER,"
+  "                                       kind    INTEGER,"
+  "  FOREIGN KEY (kind) REFERENCES event_kind(enum));",
+
+  "CREATE TABLE IF NOT EXISTS event_param (type   INTEGER,"
+  "                                        param_index   INTEGER,"
+  "                                        sort    TEXT,"
+  "                                        ident   TEXT,"
+  "                                        doc     TEXT,"
+  "  FOREIGN KEY (type) REFERENCES event_type(code));",
+
+  "CREATE TABLE IF NOT EXISTS event_log (name TEXT,"
+  "                                      size INTEGER,"
+  "                                      modtime INTEGER,"
+  "                                      completed INTEGER,"
+  "                                      serial INTEGER PRIMARY KEY AUTOINCREMENT)",
+
+  EVENT_LIST(EVENT_TABLE_CREATE, X)
+};
+
+/* makeTables makes all the tables. */
+
+static void makeTables(sqlite3 *db)
+{
+  size_t i;
+  evlog(LOG_SOMETIMES, "Creating tables.");
+
+  for (i=0; i < NELEMS(createStatements); ++i) {
+    runStatement(db, createStatements[i], "Table creation");
+  }
+}
+
+static const char *glueTables[] = {
+  "event_kind",
+  "event_type",
+  "event_param",
+};
+
+static void dropGlueTables(sqlite3 *db)
+{
+  size_t i;
+  int res;
+  char sql[1024];
+
+  evlog(LOG_ALWAYS, "Dropping glue tables so they are rebuilt.");
+
+  for (i=0; i < NELEMS(glueTables); ++i) {
+    evlog(LOG_SOMETIMES, "Dropping table %s", glueTables[i]);
+    sprintf(sql, "DROP TABLE %s", glueTables[i]);
+    res = sqlite3_exec(db,
+                       sql,
+                       NULL, /* No callback */
+                       NULL, /* No callback closure */
+                       NULL); /* error messages handled by sqlite_error */
+    /* Don't check for errors. */
+    (void)res;
+  }
+}
+
+/* Populate the metadata "glue" tables event_kind, event_type, and
+ * event_param. */
+
+#define EVENT_KIND_DO_INSERT(X, name, description)    \
+        res = sqlite3_bind_text(statement, 1, #name, -1, SQLITE_STATIC); \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_kind bind of name \"" #name "\" failed."); \
+        res = sqlite3_bind_text(statement, 2, description, -1, SQLITE_STATIC); \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_kind bind of description \"" description "\" failed."); \
+        res = sqlite3_bind_int(statement, 3, i);                        \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_kind bind of enum %d failed.", i); \
+        ++i;                                                            \
+        res = sqlite3_step(statement);                                  \
+        if (res != SQLITE_DONE)                                         \
+                sqlite_error(res, db, "event_kind insert of name \"" #name "\" failed."); \
+        if (sqlite3_changes(db) != 0)                                   \
+                evlog(LOG_SOMETIMES, "Insert of event_kind row for \"" #name "\" affected %d rows.", sqlite3_changes(db)); \
+        res = sqlite3_reset(statement);                                 \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "Couldn't reset event_kind insert statement.");
+
+#define EVENT_TYPE_DO_INSERT(X, name, code, used, kind)                 \
+        res = sqlite3_bind_text(statement, 1, #name, -1, SQLITE_STATIC); \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of name \"" #name "\" failed."); \
+        res = sqlite3_bind_int(statement, 2, code);                     \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of code %d failed.", code); \
+        res = sqlite3_bind_int(statement, 3, used);                     \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of used for name \"" #name "\" failed."); \
+        res = sqlite3_bind_int(statement, 4, EventKind##kind);          \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of kind for name \"" #name "\" failed."); \
+        res = sqlite3_step(statement);                                  \
+        if (res != SQLITE_DONE)                                         \
+                sqlite_error(res, db, "event_type insert of name \"" #name "\" failed."); \
+        if (sqlite3_changes(db) != 0)                                   \
+                evlog(LOG_SOMETIMES, "Insert of event_type row for \"" #name "\" affected %d rows.", sqlite3_changes(db)); \
+        res = sqlite3_reset(statement);                                 \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "Couldn't reset event_type insert statement.");
+
+#define EVENT_PARAM_DO_INSERT(code, index, sort, ident, doc)   \
+        res = sqlite3_bind_int(statement, 1, code);                     \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_param bind of code %d failed.", code); \
+        res = sqlite3_bind_int(statement, 2, index);                     \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_param bind of index %d failed.", index); \
+        res = sqlite3_bind_text(statement, 3, #sort, -1, SQLITE_STATIC); \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of sort \"" #sort "\" failed."); \
+        res = sqlite3_bind_text(statement, 4, #ident, -1, SQLITE_STATIC); \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of ident \"" #ident "\" failed."); \
+        res = sqlite3_bind_text(statement, 5, doc, -1, SQLITE_STATIC); \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "event_type bind of doc \"" doc "\" failed."); \
+        res = sqlite3_step(statement);                                  \
+        if (res != SQLITE_DONE)                                         \
+                sqlite_error(res, db, "event_param insert of \"" #ident "\" for code %d failed.", code); \
+        if (sqlite3_changes(db) != 0)                                   \
+                evlog(LOG_SOMETIMES, "Insert of event_param row for code %d,  ident \"" #ident "\" affected %d rows.", code, sqlite3_changes(db)); \
+        res = sqlite3_reset(statement);                                 \
+        if (res != SQLITE_OK)                                           \
+                sqlite_error(res, db, "Couldn't reset event_param insert statement.");
+
+#define EVENT_TYPE_INSERT_PARAMS(X, name, code, used, kind) \
+        EVENT_##name##_PARAMS(EVENT_PARAM_DO_INSERT, code)
+
+static void fillGlueTables(sqlite3 *db)
+{
+  int i;
+  sqlite3_stmt *statement;
+  int res;
+
+  statement = prepareStatement(db,
+                               "INSERT OR IGNORE INTO event_kind (name, description, enum)"
+                               "VALUES (?, ?, ?)");
+
+  i = 0;
+  EventKindENUM(EVENT_KIND_DO_INSERT, X);
+
+  finalizeStatement(db, statement);
+
+  statement = prepareStatement(db,
+                               "INSERT OR IGNORE INTO event_type (name, code, used, kind)"
+                               "VALUES (?, ?, ?, ?)");
+  EVENT_LIST(EVENT_TYPE_DO_INSERT, X);
+
+  finalizeStatement(db, statement);
+
+  statement = prepareStatement(db,
+                               "INSERT OR IGNORE INTO event_param (type, param_index, sort, ident, doc)"
+                               "VALUES (?, ?, ?, ?, ?)");
+  EVENT_LIST(EVENT_TYPE_INSERT_PARAMS, X);
+
+  finalizeStatement(db, statement);
+}
+
+/* Populate the actual event tables. */
+
+#define EVENT_TYPE_DECLARE_STATEMENT(X, name, code, used, kind) \
+        sqlite3_stmt *stmt_##name;
+
+#define EVENT_PARAM_PREPARE_IDENT(X, index, sort, ident, doc) "\"" #ident "\", "
+
+#define EVENT_PARAM_PREPARE_PLACE(X, index, sort, ident, doc) "?, "
+
+#define EVENT_TYPE_PREPARE_STATEMENT(X, name, code, used, kind) \
+        stmt_##name = \
+            prepareStatement(db, \
+                             "INSERT INTO EVENT_" #name " (" \
+                             EVENT_##name##_PARAMS(EVENT_PARAM_PREPARE_IDENT, X)        \
+                             "log_serial, time) VALUES (" \
+                             EVENT_##name##_PARAMS(EVENT_PARAM_PREPARE_PLACE,X) \
+                             "?, ?)");
+
+#define EVENT_TYPE_FINALIZE_STATEMENT(X, name, code, used, kind) \
+        finalizeStatement(db, stmt_##name);
+
+#define EVENT_PARAM_BIND_A bind_int
+#define EVENT_PARAM_BIND_P bind_int
+#define EVENT_PARAM_BIND_U bind_int
+#define EVENT_PARAM_BIND_W bind_int
+#define EVENT_PARAM_BIND_D bind_real
+#define EVENT_PARAM_BIND_S bind_text
+#define EVENT_PARAM_BIND_B bind_int
+
+#define EVENT_PARAM_BIND(X, index, sort, ident, doc) \
+        p = EVENT_PARAM_BIND_##sort (db, statement, eventCount, index+1, p); \
+        last_index = index+1;
+
+#define EVENT_TYPE_WRITE_SQL(X, name, code, used, kind) \
+        case code: \
+                statement = stmt_##name; \
+                /* bind all the parameters of this particular event with macro magic. */ \
+                EVENT_##name##_PARAMS(EVENT_PARAM_BIND, X) \
+                break;
+
+static char *bind_int(sqlite3 *db, sqlite3_stmt *stmt, int64 count, int field, char *p)
+{
+  char *q;
+  long long val;
+  int res;
+
+  while(*p == ' ')
+    ++p;
+
+  val = strtoll(p, &q, 16);
+  if (q == p)
+    error("event %llu field %d not an integer: %s",
+          count, field, p);
+
+  res = sqlite3_bind_int64(stmt, field, val);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event %llu field %d bind failed", count, field);
+  return q;
+}
+
+static char *bind_real(sqlite3 *db, sqlite3_stmt *stmt, int64 count, int field, char *p)
+{
+  char *q;
+  double val;
+  int res;
+
+  while(*p == ' ')
+    ++p;
+
+  val = strtod(p, &q);
+  if (q == p)
+    error("event %llu field %d not a floating-point value: %s",
+          count, field, p);
+
+  res = sqlite3_bind_double(stmt, field, val);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event %llu field %d bind failed", count, field);
+  return q;
+}
+
+static char *bind_text(sqlite3 *db, sqlite3_stmt *stmt, int64 count, int field, char *p)
+{
+  char *q;
+  int res;
+
+  while(*p == ' ')
+    ++p;
+
+  q = p;
+  while((*q != '\n') && (*q != '\0')) {
+    ++ q;
+  }
+  if ((q == p) || (q[-1] != '"'))
+    error("event %llu string field %d has no closing quote mark.",
+          count, field);
+
+  res = sqlite3_bind_text(stmt, field, p, (int)(q-p-1), SQLITE_STATIC);
+  if (res != SQLITE_OK)
+    sqlite_error(res, db, "event %llu field %d bind failed", count, field);
+  return q;
+}
+
+/* this is overkill, at present. */
+
+#define MAX_LOG_LINE_LENGTH 1024
+
+/* readLog -- read and parse log.  Returns the number of events written.
+ */
+
+static int64 readLog(FILE *input,
+                     sqlite3 *db)
+{
+  int64 eventCount = 0;
+
+  /* declare statements for every event type */
+  EVENT_LIST(EVENT_TYPE_DECLARE_STATEMENT, X);
+
+  /* prepare statements for every event type */
+  EVENT_LIST(EVENT_TYPE_PREPARE_STATEMENT, X);
+
+  runStatement(db, "BEGIN", "Transaction start");
+
+  while (TRUE) { /* loop for each event */
+    char line[MAX_LOG_LINE_LENGTH];
+    char *p;
+    char *q;
+    int last_index=0;
+    sqlite3_stmt *statement = NULL;
+    int res;
+    int64 clock_field;
+    long code;
+
+    p = fgets(line, MAX_LOG_LINE_LENGTH, input);
+    if (!p) {
+      if (feof(input))
+        break;
+      else
+        error("Couldn't read line after event %llu", eventCount);
+    }
+
+    eventCount++;
+
+    clock_field = strtoll(p, &q, 16);
+
+    if (q == p)
+      error("event %llu clock field not a hex integer: %s",
+            eventCount, p);
+
+    if (*q != ' ')
+      error("event %llu code field not preceded by ' ': %s",
+            eventCount, q);
+    while(*q == ' ')
+      ++q;
+
+    p = q;
+    code = strtol(p, &q, 16);
+    if (q == p)
+      error("event %llu code field not an integer: %s",
+            eventCount, p);
+    p = q;
+
+    /* Write event to SQLite. */
+    switch (code) {
+      /* this macro sets statement and last_index */
+      EVENT_LIST(EVENT_TYPE_WRITE_SQL, X);
+    default:
+      error("Event %llu has Unknown event code %ld", eventCount, code);
+    }
+    /* bind the fields we store for every event */ \
+    res = sqlite3_bind_int64(statement, last_index+1, logSerial);
+    if (res != SQLITE_OK)
+      sqlite_error(res, db, "Event %llu bind of log_serial failed.", eventCount);
+    res = sqlite3_bind_int64(statement, last_index+2, clock_field);
+    if (res != SQLITE_OK)
+      sqlite_error(res, db, "Event %llu bind of clock failed.", eventCount);
+    res = sqlite3_step(statement);
+    if (res != SQLITE_DONE)
+      sqlite_error(res, db, "insert of event %llu failed.", eventCount);
+    res = sqlite3_reset(statement);
+    if (res != SQLITE_OK)
+      sqlite_error(res, db, "Couldn't reset insert statement of event %llu", eventCount);
+
+    if (progress) {
+      if ((eventCount % SMALL_TICK) == 0) {
+        printf(".");
+        fflush(stdout);
+        if (((eventCount / SMALL_TICK) % BIG_TICK) == 0) {
+          printf("\n");
+          fflush(stdout);
+          evlog(LOG_SOMETIMES, "%lu events.", (unsigned long)eventCount);
+        }
+      }
+    }
+  }
+  if (progress) {
+    printf("\n");
+    fflush(stdout);
+  }
+  runStatement(db, "COMMIT", "Transaction finish");
+  logFileCompleted(db, eventCount);
+
+  /* finalize all the statements */
+  EVENT_LIST(EVENT_TYPE_FINALIZE_STATEMENT, X);
+
+  return eventCount;
+}
+
+/* openLog -- open the log file doors, HAL */
+
+static FILE *openLog(sqlite3 *db)
+{
+  FILE *input;
+
+  registerLogFile(db, logFileName);
+  if (!logFileName) {
+    input = stdin;
+    logFileName = "<stdin>";
+  } else {
+    input = fopen(logFileName, "r");
+    if (input == NULL)
+      error("unable to open %s", logFileName);
+  }
+
+  evlog(LOG_OFTEN, "Reading %s.", logFileName ? logFileName : "standard input");
+
+  return input;
+}
+
+static int64 writeEventsToSQL(sqlite3 *db)
+{
+  FILE *input;
+  int64 count;
+  input = openLog(db);
+  count = readLog(input, db);
+  (void)fclose(input);
+  return count;
+}
+
+
+int main(int argc, char *argv[])
+{
+  sqlite3 *db;
+  int64 count;
+
+  parseArgs(argc, argv);
+
+  db = openDatabase();
+  if (rebuild) {
+    dropGlueTables(db);
+  }
+  makeTables(db);
+  fillGlueTables(db);
+  count = writeEventsToSQL(db);
+  evlog(LOG_ALWAYS, "Imported %llu events from %s to %s, serial %llu.",
+        count, logFileName, databaseName, logSerial);
+
+  if (runTests) {
+    /* TODO: more unit tests in here */
+    testTableExists(db);
+  }
+
+  closeDatabase(db);
+  return 0;
+}
+
+/* COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2012-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/eventtxt.c

@@ -0,0 +1,661 @@
+/* eventtxt.c: event text log to human-friendly format.
+ *
+ * $Id$
+ *
+ * Copyright (c) 2012-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * This is a command-line tool that converts events from a text-format
+ * MPS telemetry file into a more human-readable format.
+ *
+ * The default MPS library will write a binary-format telemetry file
+ * which can be converted into a text-format file using the eventcnv
+ * program (q.v.).
+ *
+ * For efficiency, eventcnv writes all event times, codes, and
+ * parameters (apart from EventFS - strings - and EventFD -
+ * floating-point) as hexadecimal strings, separated by single spaces.
+ * For human-readable purposes, we'd prefer a format in which
+ * parameters are named; event codes are converted to event type
+ * names; integers are in decimal; booleans are 'True ' or 'False';
+ * pointers, addresses, and words are in hex; and labelled addresses
+ * are shown with their label strings.  This program performs that
+ * conversion.
+ *
+ * Options:
+ *
+ * -l <logfile>: Import events from the named logfile.  Defaults to
+ * stdin.
+ *
+ * $Id$
+ */
+
+#include "check.h"
+#include "config.h"
+#include "eventcom.h"
+#include "eventdef.h"
+#include "mps.h"
+#include "mpsavm.h"
+#include "mpscmvff.h"
+#include "table.h"
+#include "testlib.h" /* for ulongest_t and associated print formats */
+
+#include <assert.h>
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h> /* exit, EXIT_FAILURE, EXIT_SUCCESS */
+#include <string.h> /* strcpy, strerror, strlen */
+
+static const char *prog; /* program name */
+static const char *logFileName = NULL;
+
+/* everror -- error signalling */
+
+ATTRIBUTE_FORMAT((printf, 1, 2))
+static void everror(const char *format, ...)
+{
+  va_list args;
+
+  (void)fflush(stdout); /* sync */
+  (void)fprintf(stderr, "%s: ", prog);
+  va_start(args, format);
+  (void)vfprintf(stderr, format, args);
+  (void)fprintf(stderr, "\n");
+  va_end(args);
+  exit(EXIT_FAILURE);
+}
+
+static void usage(void)
+{
+  (void)fprintf(stderr, "Usage: %s [-l <logfile>]\n", prog);
+}
+
+static void usageError(void)
+{
+  usage();
+  everror("Bad usage");
+}
+
+/* parseArgs -- parse command line arguments */
+
+static void parseArgs(int argc, char *argv[])
+{
+  int i = 1;
+
+  if (argc >= 1)
+    prog = argv[0];
+  else
+    prog = "unknown";
+
+  while (i < argc) { /* consider argument i */
+    if (argv[i][0] == '-') { /* it's an option argument */
+      switch (argv[i][1]) {
+      case 'l': /* log file name */
+        ++ i;
+        if (i == argc)
+          usageError();
+        else
+          logFileName = argv[i];
+        break;
+      case '?': case 'h': /* help */
+        usage();
+        exit(EXIT_SUCCESS);
+      default:
+        usageError();
+      }
+    } /* if option */
+    ++ i;
+  }
+}
+
+/* table methods for a table of interned strings, and another of
+ * labelled addresses. */
+
+static void *tableAlloc(void *closure, size_t size)
+{
+  mps_pool_t pool = closure;
+  mps_addr_t p;
+  mps_res_t res;
+  res = mps_alloc(&p, pool, size);
+  if (res != MPS_RES_OK)
+    everror("allocation failed: %d", res);
+  return p;
+}
+
+static void tableFree(void *closure, void *p, size_t size)
+{
+  mps_pool_t pool = closure;
+  mps_free(pool, p, size);
+}
+
+/* Printing routines */
+
+/* printStr -- print an EventString */
+
+static void printStr(const char *str)
+{
+  size_t i;
+
+  putchar('"');
+  for (i = 0; str[i] != '\0'; ++i) {
+    char c = str[i];
+    if (c == '"' || c == '\\')
+      putchar('\\');
+    putchar(c);
+  }
+  putchar('"');
+}
+
+
+/* Reading clocks, hex numbers, and doubles, and quoted-and-escaped
+ * strings. */
+
+static EventClock parseClock(char **pInOut)
+{
+  EventClock val;
+  int i, l;
+  unsigned long low, high;
+  char *p = *pInOut;
+
+  i = sscanf(p, "%08lX%08lX%n", &high, &low, &l);
+  if (i != 2)
+    everror("Couldn't read a clock from '%s'", p);
+  EVENT_CLOCK_MAKE(val, low, high);
+
+  *pInOut = p + l;
+  return val;
+}
+
+static ulongest_t parseHex(char **pInOut)
+{
+  ulongest_t val;
+  int i, l;
+  char *p = *pInOut;
+
+  i = sscanf(p, "%" SCNXLONGEST "%n", &val, &l);
+  if (i != 1)
+    everror("Couldn't read a hex number from '%s'", p);
+  *pInOut = p + l;
+  return val;
+}
+
+static double parseDouble(char **pInOut)
+{
+  double val;
+  int i, l;
+  char *p = *pInOut;
+
+  i = sscanf(p, "%lg%n", &val, &l);
+  if (i != 1)
+    everror("Couldn't read a float from '%s'", p);
+  *pInOut = p + l;
+  return val;
+}
+
+/* parseString checks string syntax (opening and closing quotation
+ * marks) and takes a copy (stripping escaping backslashes) into a
+ * static buffer (callers must "use it or lose it"; the next
+ * invocation will over-write it).  Probably not bullet-proof. */
+
+#define MAX_STRING_LENGTH 1024
+
+static char strBuf[MAX_STRING_LENGTH];
+
+static char *parseString(char **pInOut)
+{
+  char *p = *pInOut;
+  char *q = strBuf;
+  while(*p == ' ')
+    ++p;
+
+  if (*p != '"')
+    everror("String has no opening quotation mark: '%s'", p);
+  ++p;
+
+  while(1) {
+    if (q - strBuf >= MAX_STRING_LENGTH) {
+      everror("String length exceeds %d", MAX_STRING_LENGTH);
+    }
+    if (*p == '\\') { /* escaped character */
+      ++p;
+      if (*p == '\0')
+        everror("Closing NUL byte escaped by backslash.");
+      *q++ = *p++;
+    } else if (*p == '"') { /* end of string */
+      *q = '\0';
+      ++p;
+      *pInOut = p;
+      return strBuf;
+    } else if (*p == '\0')
+      everror("Unexpected closing NUL byte.");
+    else
+      *q++ = *p++;
+  }
+}
+
+/* Event logs have interned strings (i.e. they construct a partial
+ * function from non-negative integer IDs to strings), and can label
+ * addresses and pointers with intern string IDs (i.e. they construct
+ * a partial function from address or pointer to string ID). We need
+ * three tables to keep track of these. */
+
+static Table internTable;      /* dictionary of intern ids to strings */
+
+static Table labelAddrTable;   /* dictionary of addrs to intern ids */
+
+static Table labelPointerTable; /* dictionary of pointers to intern ids */
+
+static void createTables(mps_pool_t pool)
+{
+  Res res;
+  /* MPS intern IDs are serials from zero up, so we can use -1
+   * and -2 as specials. */
+  res = TableCreate(&internTable,
+                    (size_t)1<<4,
+                    tableAlloc, tableFree, pool,
+                    (TableKey)-1, (TableKey)-2);
+  if (res != ResOK)
+    everror("Couldn't make intern table.");
+
+  /* We assume that 0 and 1 are invalid as Addrs. */
+  res = TableCreate(&labelAddrTable, (size_t)1<<7,
+                    tableAlloc, tableFree, pool,
+                    0, 1);
+  if (res != ResOK)
+    everror("Couldn't make address label table.");
+
+  /* We assume that 0 and 1 are invalid as Pointers. */
+  res = TableCreate(&labelPointerTable, (size_t)1<<7,
+                    tableAlloc, tableFree, pool,
+                    0, 1);
+  if (res != ResOK)
+    everror("Couldn't make pointer label table.");
+}
+
+/* recordIntern -- record an interned string in the table.  a copy of
+* the string from the parsed buffer into a newly-allocated block. */
+
+static void recordIntern(mps_pool_t pool, char *p)
+{
+  ulongest_t stringId;
+  char *string;
+  mps_addr_t copy;
+  size_t len;
+  Res res;
+
+  stringId = parseHex(&p);
+  string = parseString(&p);
+  len = strlen(string);
+  res = mps_alloc(&copy, pool, len + 1);
+  if (res != MPS_RES_OK)
+    everror("Couldn't allocate space for a string.");
+  (void)strcpy(copy, string);
+  res = TableDefine(internTable, (TableKey)stringId, (void *)copy);
+  if (res != ResOK)
+    everror("Couldn't create an intern mapping.");
+}
+
+/* Over time there may be multiple labels associated with an address,
+ * so we keep a list, recording for each label the clock when the
+ * association was made. This means that printAddr can select the
+ * label that was in force at the time of the event.
+ */
+
+typedef struct LabelStruct *Label;
+typedef struct LabelStruct {
+  EventClock clock;             /* clock of this label */
+  ulongest_t id;                /* string id of this label */
+} LabelStruct;
+
+typedef struct LabelListStruct *LabelList;
+typedef struct LabelListStruct {
+  size_t n;                     /* number of labels in array */
+  Label labels;                 /* labels, sorted in order by clock */
+} LabelListStruct;
+
+/* labelFind returns the index of the first entry in list with a clock
+ * value that's greater than 'clock', or list->n if there is no such
+ * label. The list is assumed to be sorted.
+ */
+
+static size_t labelFind(LabelList list, EventClock clock)
+{
+  size_t low = 0, high = list->n;
+  while (low < high) {
+    size_t mid = (low + high) / 2;
+    assert(NONNEGATIVE(mid) && mid < list->n);
+    if (list->labels[mid].clock > clock) {
+      high = mid;
+    } else {
+      low = mid + 1;
+    }
+  }
+  assert(NONNEGATIVE(low) && low <= list->n);
+  assert(low == list->n || list->labels[low].clock > clock);
+  return low;
+}
+
+/* recordLabel records a label: an association (made at the time given
+ * by 'clock') between a client address or an internal pointer and a
+ * string ID. These are encoded as two hexadecimal numbers in the
+ * string pointed to by 'p'.
+ *
+ * Note that the event log may have been generated on a platform with
+ * addresses larger than Word on the current platform. If that happens
+ * then we are scuppered because our Table code uses Word as the key
+ * type: there's nothing we can do except detect this bad case (see
+ * also the EventInit handling and warning code).
+ *
+ * We can and do handle the case where string IDs (which are Words on
+ * the MPS platform) are larger than void* on the current platform.
+ * This is probably in fact the same case, because Word should be the
+ * same size as void*.  In practice, trying to analyse a log from a
+ * wide platform on a narrow one (e.g. - the only case which is likely
+ * to occur this decade - from a 64-bit platform on a 32-bit one) is
+ * probably a bad idea and maybe doomed to failure.
+ */
+
+static void recordLabel(mps_pool_t pool, Table table, EventClock clock, char *p)
+{
+  ulongest_t address;
+  LabelList list;
+  Label newlabels;
+  mps_addr_t tmp;
+  size_t pos;
+  Res res;
+
+  address = parseHex(&p);
+  if (address > (Word)-1) {
+    (void)printf("label address too large!");
+    return;
+  }
+
+  if (TableLookup(&tmp, table, (TableKey)address)) {
+    list = tmp;
+  } else {
+    /* First label for this address */
+    res = mps_alloc(&tmp, pool, sizeof(LabelListStruct));
+    if (res != MPS_RES_OK)
+      everror("Can't allocate space for a label list");
+    list = tmp;
+    list->n = 0;
+    res = TableDefine(table, (TableKey)address, list);
+    if (res != ResOK)
+      everror("Couldn't create a label mapping.");
+  }
+
+  res = mps_alloc(&tmp, pool, sizeof(LabelStruct) * (list->n + 1));
+  if (res != ResOK)
+    everror("Couldn't allocate space for list of labels.");
+  newlabels = tmp;
+
+  pos = labelFind(list, clock);
+  memcpy(newlabels, list->labels, sizeof(LabelStruct) * pos);
+  newlabels[pos].clock = clock;
+  newlabels[pos].id = parseHex(&p);
+  memcpy(newlabels + pos + 1, list->labels + pos,
+         sizeof(LabelStruct) * (list->n - pos));
+  if (list->n > 0)
+    mps_free(pool, list->labels, sizeof(LabelStruct) * list->n);
+  list->labels = newlabels;
+  ++ list->n;
+}
+
+/* output code */
+
+/* hexWordWidth is the number of characters used to output a Word
+ * value in hexadecimal.  Note that what we really care about is the
+ * width of a Word on the source platform, not here.  So when we see
+ * an EventInit event, we update this variable to the necessary
+ * width. */
+
+static int hexWordWidth = (MPS_WORD_WIDTH+3)/4;
+
+/* printLabelled -- output a ulongest_t in hex, with the interned
+ * string if the value is in the table */
+
+static void printLabelled(EventClock clock, ulongest_t value,
+                          const char *ident, Table table)
+{
+  void *tmp;
+
+  printf("%s:%0*" PRIXLONGEST, ident, hexWordWidth, value);
+  if (table != NULL && TableLookup(&tmp, table, (TableKey)value)) {
+    LabelList list = tmp;
+    size_t pos = labelFind(list, clock);
+    if (pos > 0) {
+      ulongest_t id = list->labels[pos - 1].id;
+      putchar('[');
+      if (TableLookup(&tmp, internTable, (TableKey)id))
+        printStr((char *)tmp);
+      else
+        printf("unknown label %" PRIXLONGEST, id);
+      putchar(']');
+    }
+  }
+  putchar(' ');
+}
+
+/* parameter processing.  For each parameter we parse it and then
+ * print it, preceded by its name and a colon and followed by a
+ * space. */
+
+#define processParamA(ident)                                    \
+  val_hex = parseHex(&p);                                       \
+  printLabelled(clock, val_hex, #ident, labelAddrTable);
+
+#define processParamP(ident)                                    \
+  val_hex = parseHex(&p);                                       \
+  printLabelled(clock, val_hex, #ident, labelPointerTable);
+
+#define processParamW(ident)                    \
+  val_hex = parseHex(&p);                       \
+  printLabelled(clock, val_hex, #ident, NULL);
+
+#define processParamU(ident)                    \
+  val_hex = parseHex(&p);                       \
+  printf(#ident ":%" PRIuLONGEST " ", val_hex);
+
+#define processParamD(ident)                    \
+  val_float = parseDouble(&p);                  \
+  printf(#ident ":%#8.3g ", val_float);
+
+#define processParamS(ident)                    \
+  val_string = parseString(&p);                 \
+  printf(#ident ":");                           \
+  printStr(val_string);                         \
+  putchar(' ');
+
+#define processParamB(ident)                            \
+  val_hex = parseHex(&p);                               \
+  printf(#ident ":%s ", val_hex ? "True" : "False");
+
+#define EVENT_PROCESS_PARAM(X, index, sort, ident, doc) \
+  processParam##sort(ident);
+
+#define EVENT_PROCESS(X, name, code, used, kind)        \
+  case code:                                            \
+    EVENT_##name##_PARAMS(EVENT_PROCESS_PARAM, X)       \
+    break;
+
+/* a table of the event names */
+
+static const char *eventName[EventCodeMAX+EventCodeMAX];
+
+#define EVENT_SET_NAME(X, name, code, used, kind) \
+        eventName[code] = #name;
+
+/* this is overkill, at present. */
+
+#define MAX_LOG_LINE_LENGTH 1024
+
+/* readLog -- read and parse log.  Returns the number of events written.  */
+
+static void readLog(mps_pool_t pool, FILE *input)
+{
+  int i;
+
+  for (i=0; i <= EventCodeMAX; ++i)
+    eventName[i] = NULL;
+
+  EVENT_LIST(EVENT_SET_NAME, X);
+
+  while (TRUE) { /* loop for each event */
+    char line[MAX_LOG_LINE_LENGTH];
+    char *p, *q;
+    EventClock clock;
+    int code;
+    ulongest_t val_hex;
+    double val_float;
+    const char *val_string;
+
+    p = fgets(line, MAX_LOG_LINE_LENGTH, input);
+    if (!p) {
+      if (feof(input))
+        break;
+      else
+        everror("Couldn't read line from input.");
+    }
+
+    clock = parseClock(&p);
+    EVENT_CLOCK_PRINT(stdout, clock);
+
+    code = (int)parseHex(&p);
+    printf(" %04X ", code);
+    if (eventName[code])
+      printf("%-19s ", eventName[code]);
+    else
+      printf("%-19s ", "[Unknown]");
+
+    q = p;
+
+    /* for a few particular codes, we do local processing. */
+    if (code == EventInternCode) {
+      recordIntern(pool, q);
+    } else if (code == EventLabelCode) {
+      recordLabel(pool, labelAddrTable, clock, q);
+    } else if (code == EventLabelPointerCode) {
+      recordLabel(pool, labelPointerTable, clock, q);
+    } else if (code == EventEventInitCode) {
+      ulongest_t major, median, minor, maxCode, maxNameLen, wordWidth, clocksPerSec;
+      major = parseHex(&q);  /* EVENT_VERSION_MAJOR */
+      median = parseHex(&q); /* EVENT_VERSION_MEDIAN */
+      minor = parseHex(&q);  /* EVENT_VERSION_MINOR */
+      maxCode = parseHex(&q); /* EventCodeMAX */
+      maxNameLen = parseHex(&q); /* EventNameMAX */
+      wordWidth = parseHex(&q); /* MPS_WORD_WIDTH */
+      clocksPerSec = parseHex(&q); /* mps_clocks_per_sec() */
+      UNUSED(clocksPerSec);
+      UNUSED(maxNameLen);
+
+      if ((major != EVENT_VERSION_MAJOR) ||
+          (median != EVENT_VERSION_MEDIAN) ||
+          (minor != EVENT_VERSION_MINOR)) {
+        (void)fprintf(stderr, "Event log version does not match: "
+                      "%d.%d.%d vs %d.%d.%d\n",
+                      (int)major, (int)median, (int)minor,
+                      EVENT_VERSION_MAJOR,
+                      EVENT_VERSION_MEDIAN,
+                      EVENT_VERSION_MINOR);
+      }
+
+      if (maxCode > EventCodeMAX) {
+        (void)fprintf(stderr, "Event log may contain unknown events "
+                      "with codes from %d to %d\n",
+                      EventCodeMAX+1, (int)maxCode);
+      }
+
+      if (wordWidth > MPS_WORD_WIDTH) {
+        int newHexWordWidth = (int)((wordWidth + 3) / 4);
+        if (newHexWordWidth > hexWordWidth) {
+          (void)fprintf(stderr,
+                        "Event log word width is greater than on current "
+                        "platform; previous values may be printed too "
+                        "narrowly.\n");
+        }
+        hexWordWidth = newHexWordWidth;
+      }
+
+      if (wordWidth > sizeof(ulongest_t) * CHAR_BIT) {
+        everror("Event log word width %d is too wide for the current platform.",
+                (int)wordWidth);
+      }
+    }
+
+    switch(code) {
+      EVENT_LIST(EVENT_PROCESS, X);
+    default:
+      printf("Unknown event.");
+    }
+    putchar('\n');
+
+  }
+}
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  mps_pool_t pool;
+  mps_res_t res;
+  FILE *input;
+
+  parseArgs(argc, argv);
+  if (!logFileName) {
+    input = stdin;
+    logFileName = "<stdin>";
+  } else {
+    input = fopen(logFileName, "r");
+    if (input == NULL)
+      everror("unable to open %s", logFileName);
+  }
+
+  /* Ensure no telemetry output. */
+  res = setenv("MPS_TELEMETRY_CONTROL", "0", 1);
+  if (res != 0)
+    everror("failed to set MPS_TELEMETRY_CONTROL: %s", strerror(errno));
+
+  res = mps_arena_create_k(&arena, mps_arena_class_vm(), mps_args_none);
+  if (res != MPS_RES_OK)
+    everror("failed to create arena: %d", res);
+
+  res = mps_pool_create_k(&pool, arena, mps_class_mvff(), mps_args_none);
+  if (res != MPS_RES_OK)
+    everror("failed to create pool: %d", res);
+
+  createTables(pool);
+  readLog(pool, input);
+
+  mps_pool_destroy(pool);
+  mps_arena_destroy(arena);
+
+  (void)fclose(input);
+  return 0;
+}
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2012-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/extcon.c

@@ -0,0 +1,306 @@
+/* extcon.c: ARENA EXTENDED AND CONTRACTED CALLBACK TEST
+ *
+ * $Id$
+ * Copyright (c) 2022-2023 Ravenbrook Limited.  See end of file for license.
+ *
+ * .overview: This test case allocates a bunch of large objects, of a size 
+ * similar to the size of the arena, to force the arena to extend. It then
+ * discards the base pointers to those objects, and forces a collection.
+ *
+ * .limitations: This test checks that the EXTENDED and CONTRACTED
+ * callbacks were called at least once, and that they are called the
+ * same number of times. It does not check that the extensions and
+ * contractions themselves were performed correctly, nor does it check
+ * that an appropriate number of extensions and contractions took
+ * place, nor does it check that they took place at sensible times.
+ *
+ * .dylan: This test uses Dylan format objects in common with most
+ * other tests for convenience and brevity.
+ */
+
+#include "mps.h"
+#include "testlib.h"
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mpsavm.h"
+#include "mpscamc.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+/* Number of test objects to allocate */
+#define N_TESTOBJ 100
+/* The number of slots determines the size of each object */
+#define N_SLOT_TESTOBJ 10000
+/* The initial arena size is requested to be bigger the test object by
+   this many bytes */
+#define SIZEDIFF 10
+
+/* Set alignment to mps_word_ts */
+#define ALIGNMENT sizeof(mps_word_t)
+
+/* Align size upwards to the next multiple of the word size. */
+#define ALIGN_WORD(size) \
+    (((size) + ALIGNMENT - 1) & ~(ALIGNMENT - 1))
+
+/* Global objects*/
+static mps_arena_t arena;       /* the arena */
+static mps_pool_t obj_pool;     /* pool for test objects */
+static mps_ap_t obj_ap;         /* allocation point used to allocate objects */
+
+/* Count of number of arena contractions and extensions */
+static int n_contract = 0;
+static int n_extend = 0;
+
+/* Callback functions for arena extension and contraction */
+static void arena_extended_cb(mps_arena_t arena_in, mps_addr_t addr, size_t size)
+{
+  testlib_unused(arena_in);
+  testlib_unused(addr);
+  testlib_unused(size);
+  printf("Arena extended by %"PRIuLONGEST" bytes\n", (ulongest_t)size);
+  n_extend++;
+}
+
+static void arena_contracted_cb(mps_arena_t arena_in, mps_addr_t addr, size_t size)
+{
+  testlib_unused(arena_in);
+  testlib_unused(addr);
+  testlib_unused(size);
+  printf("Arena contracted by %"PRIuLONGEST" bytes\n", (ulongest_t)size);
+  n_contract++;
+}
+
+/* Messages for testbench debugging */
+static void print_messages(void)
+{
+  mps_message_type_t type;
+
+  while (mps_message_queue_type(&type, arena)) {
+    mps_message_t message;
+
+    cdie(mps_message_get(&message, arena, type),
+         "get");
+
+    switch(type) {
+      case mps_message_type_gc_start():
+        printf("GC start at %"PRIuLONGEST": %s\n",
+               (ulongest_t)mps_message_clock(arena, message),
+               mps_message_gc_start_why(arena, message));
+        break;
+
+      case mps_message_type_gc():
+        printf("GC end at %"PRIuLONGEST" "
+               "condemned %"PRIuLONGEST" "
+               "not condemned %"PRIuLONGEST" "
+               "live %"PRIuLONGEST"\n",
+               (ulongest_t)mps_message_clock(arena, message),
+               (ulongest_t)mps_message_gc_condemned_size(arena, message),
+               (ulongest_t)mps_message_gc_not_condemned_size(arena, message),
+               (ulongest_t)mps_message_gc_live_size(arena, message));
+        break;
+
+      default:
+        cdie(0, "message type");
+        break;
+    }
+
+    mps_message_discard(arena, message);
+  }
+}
+
+/* Disabling inlining is necessary (but perhaps not sufficient) if using stack roots.
+   See comment below with link to GitHub issue*/
+ATTRIBUTE_NOINLINE
+static void test_main(void *cold_stack_end)
+{
+  mps_fmt_t obj_fmt;
+  mps_thr_t thread;
+  mps_root_t stack_root, testobj_root;
+  size_t arena_size, obj_size;
+  int i;
+  /* In the original version of extcon this was a stack root, but we
+     observed unreliable failures to do with registering the cold end
+     of the stack.  See GitHub issue #210
+     <https://github.com/Ravenbrook/mps/issues/210>.  For now, we
+     declare this as a separate root. */
+  static mps_word_t testobj[N_TESTOBJ];
+
+  /* The testobj array must be below (on all current Posix platforms)
+     the cold end of the stack in order for the MPS to scan it.  We
+     have observed a Heisenbug where GCC will inline test_main into
+     main and lose this condition if the expression below is removed.
+     This is a problem we are analysing in GitHub issue #210
+     <https://github.com/Ravenbrook/mps/issues/210>.  For now, we
+     disable this Insist to allow the test to run with a static
+     testobj array. */
+#if 0
+  Insist((void *)&testobj[N_TESTOBJ] <= cold_stack_end);
+  if ((void *)&testobj[N_TESTOBJ] > cold_stack_end)
+    printf("Cold stack marker invalid!\n");
+  else
+    printf("Cold stack marker probably valid.\n");
+#endif
+
+  /* Make initial arena size slightly bigger than the test object size to force an extension as early as possible */
+  /* See definition of make_dylan_vector() in fmtdytst.c for calculation of vector size */  
+  obj_size = ALIGN_WORD((N_SLOT_TESTOBJ + 2) * sizeof(mps_word_t));
+  arena_size = ALIGN_WORD(obj_size + SIZEDIFF);
+
+  /* Create arena and register callbacks */
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, arena_size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_EXTENDED, (mps_fun_t)&arena_extended_cb);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_CONTRACTED, (mps_fun_t)&arena_contracted_cb);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "mps_arena_create_k");
+  } MPS_ARGS_END(args);
+
+  printf("Initial reservation %"PRIuLONGEST".\n", (ulongest_t)mps_arena_reserved(arena));
+
+  die(dylan_fmt(&obj_fmt, arena), "dylan_fmt()");
+
+  /* Create new pool */
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, obj_fmt);
+    die(mps_pool_create_k(&obj_pool, arena, mps_class_amcz(), args),
+      "mps_pool_create_k");
+  } MPS_ARGS_END(args);
+
+  /* Register thread */
+  die(mps_thread_reg(&thread, arena), "Thread reg");
+
+  /* Register stack roots */
+  /* Since this testbench is currently not using a stack root, #IF 0 this out */
+  testlib_unused(cold_stack_end);
+  testlib_unused(stack_root);
+#if 0
+  die(mps_root_create_thread(&stack_root, arena, thread, cold_stack_end), "Create Stack root");
+#endif
+
+  /* Register ambiguous array of object roots. */
+  die(mps_root_create_area(&testobj_root, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &testobj[0], &testobj[N_TESTOBJ],
+                            mps_scan_area, NULL),
+      "root_create_area(testobj)");
+
+  /* Create allocation point */
+  die(mps_ap_create_k(&obj_ap, obj_pool, mps_args_none), "Create Allocation point");
+
+  mps_message_type_enable(arena, mps_message_type_gc_start());
+  mps_message_type_enable(arena, mps_message_type_gc());
+
+  /* Allocate objects and force arena extension */
+  for (i = 0; i < N_TESTOBJ; i++) {
+
+    die(make_dylan_vector(&testobj[i], obj_ap, N_SLOT_TESTOBJ), "make_dylan_vector"); 
+
+    printf("Object %d committed.  "
+           "Arena reserved: %"PRIuLONGEST".\n",
+           i,
+           (ulongest_t)mps_arena_reserved(arena));
+
+    print_messages();
+  }
+
+  /* overwrite all the references to the objects*/
+  for (i = 0; i < N_TESTOBJ; i++) {
+
+    /* bonus test of mps_addr_object */
+#if 0 /* Comment this out until mps_addr_object becomes available. */
+    mps_addr_t out;
+    Insist(N_TESTOBJ <= N_INT_TESTOBJ);
+
+    /* use "i" to as a convenient way to generate different interior pointers
+       To guarantee the i index will give us an interior pointer the number of test
+       objects must be <= the number of integers in each object */
+    Insist(N_TESTOBJ <= N_INT_TESTOBJ);
+    die(mps_addr_object(&out, arena, &(testobj[i])->int_array[i]), "Address object");
+
+    Insist(out == testobj[i]);
+
+    /* end piggy back testbench */
+#endif
+
+    /* now overwrite the ref */
+    testobj[i] = (mps_word_t)NULL;
+
+    print_messages();
+  }
+
+  /* Collect */
+  mps_arena_collect(arena);
+
+  print_messages();
+
+  /* Clean up */
+  mps_root_destroy(testobj_root);
+  /* mps_root_destroy(stack_root);*/ /*commented out while not using stack root */
+  mps_thread_dereg(thread);
+  mps_ap_destroy(obj_ap);
+  mps_pool_destroy(obj_pool);
+  mps_fmt_destroy(obj_fmt);
+  mps_arena_destroy(arena);
+
+  /* Destroying the arena should cause contraction callbacks on all
+     remaining chunks, even if they had contents. */
+  Insist(n_extend == n_contract);
+
+  printf("Arena extended %d times\n", n_extend);
+  printf("Arena contracted %d times\n", n_contract);
+
+  /* comment out some diagnostics for investigating issue #210 mentioned above */
+#if 0
+  printf("&testobj[N_TESTOBJ] = %p\n", (void *)&testobj[N_TESTOBJ]);
+  printf("cold_stack_end = %p\n", cold_stack_end);
+#endif
+  if (n_extend == 0) 
+    printf("No callbacks received upon arena extended!\n");
+  if (n_contract == 0)
+    printf("No callbacks received upon arena contracted!\n");
+
+  if (n_contract == 0 || n_extend == 0)
+    exit(EXIT_FAILURE);
+}
+
+int main(int argc, char* argv[])
+{
+  void *stack_marker = &stack_marker;
+
+  testlib_init(argc, argv);
+
+  test_main(stack_marker);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2022-2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/failover.c

@@ -0,0 +1,369 @@
+/* failover.c: FAILOVER IMPLEMENTATION
+ *
+ * $Id$
+ * Copyright (c) 2014-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .design: <design/failover>
+ *
+ * .critical: In manual-allocation-bound programs using MVFF, many of
+ * these functions are on the critical paths via mps_alloc (and then
+ * PoolAlloc, MVFFAlloc, failoverFind*) and mps_free (and then
+ * MVFFFree, failoverInsert).
+ */
+
+#include "failover.h"
+#include "mpm.h"
+#include "range.h"
+
+SRCID(failover, "$Id$");
+
+
+ARG_DEFINE_KEY(failover_primary, Pointer);
+ARG_DEFINE_KEY(failover_secondary, Pointer);
+
+
+Bool FailoverCheck(Failover fo)
+{
+  CHECKS(Failover, fo);
+  CHECKD(Land, &fo->landStruct);
+  CHECKD(Land, fo->primary);
+  CHECKD(Land, fo->secondary);
+  return TRUE;
+}
+
+
+static Res failoverInit(Land land, Arena arena, Align alignment, ArgList args)
+{
+  Failover fo;
+  ArgStruct arg;
+  Res res;
+
+  AVER(land != NULL);
+  res = NextMethod(Land, Failover, init)(land, arena, alignment, args);
+  if (res != ResOK)
+    return res;
+  fo = CouldBeA(Failover, land);
+
+  ArgRequire(&arg, args, FailoverPrimary);
+  fo->primary = arg.val.p;
+  ArgRequire(&arg, args, FailoverSecondary);
+  fo->secondary = arg.val.p;
+
+  SetClassOfPoly(land, CLASS(Failover));
+  fo->sig = FailoverSig;
+  AVERC(Failover, fo);
+
+  return ResOK;
+}
+
+
+static void failoverFinish(Inst inst)
+{
+  Land land = MustBeA(Land, inst);
+  Failover fo = MustBeA(Failover, land);
+  fo->sig = SigInvalid;
+  NextMethod(Inst, Failover, finish)(inst);
+}
+
+
+static Size failoverSize(Land land)
+{
+  Failover fo = MustBeA_CRITICAL(Failover, land);
+  return LandSize(fo->primary) + LandSize(fo->secondary);
+}
+
+
+static Res failoverInsert(Range rangeReturn, Land land, Range range)
+{
+  Failover fo = MustBeA_CRITICAL(Failover, land);
+  Res res;
+
+  AVER_CRITICAL(rangeReturn != NULL);
+  AVERT_CRITICAL(Range, range);
+
+  /* Provide more opportunities for coalescence. See
+   * <design/failover#.impl.assume.flush>.
+   */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  res = LandInsert(rangeReturn, fo->primary, range);
+  if (res != ResOK && res != ResFAIL)
+    res = LandInsert(rangeReturn, fo->secondary, range);
+
+  return res;
+}
+
+
+static Res failoverInsertSteal(Range rangeReturn, Land land, Range rangeIO)
+{
+  Failover fo = MustBeA(Failover, land);
+  Res res;
+
+  AVER(rangeReturn != NULL);
+  AVER(rangeReturn != rangeIO);
+  AVERT(Range, rangeIO);
+
+  /* Provide more opportunities for coalescence. See
+   * <design/failover#.impl.assume.flush>.
+   */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  res = LandInsertSteal(rangeReturn, fo->primary, rangeIO);
+  AVER(res == ResOK || res == ResFAIL);
+  return res;
+}
+
+
+static Res failoverDelete(Range rangeReturn, Land land, Range range)
+{
+  Failover fo = MustBeA(Failover, land);
+  Res res;
+  RangeStruct oldRange, dummyRange, left, right;
+
+  AVER(rangeReturn != NULL);
+  AVERT(Range, range);
+
+  /* Prefer efficient search in the primary. See
+   * <design/failover#.impl.assume.flush>.
+   */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  res = LandDelete(&oldRange, fo->primary, range);
+
+  if (res == ResFAIL) {
+    /* Range not found in primary: try secondary. */
+    return LandDelete(rangeReturn, fo->secondary, range);
+  } else if (res != ResOK) {
+    /* Range was found in primary, but couldn't be deleted. The only
+     * case we expect to encounter here is the case where the primary
+     * is out of memory. (In particular, we don't handle the case of a
+     * CBS returning ResLIMIT because its block pool has been
+     * configured not to automatically extend itself.)
+     */
+    AVER(ResIsAllocFailure(res));
+
+    /* Delete the whole of oldRange, and re-insert the fragments
+     * (which might end up in the secondary). See
+     * <design/failover#.impl.assume.delete>.
+     */
+    res = LandDelete(&dummyRange, fo->primary, &oldRange);
+    if (res != ResOK)
+      return res;
+
+    AVER(RangesEqual(&oldRange, &dummyRange));
+    RangeInit(&left, RangeBase(&oldRange), RangeBase(range));
+    if (!RangeIsEmpty(&left)) {
+      /* Don't call LandInsert(..., land, ...) here: that would be
+       * re-entrant and fail the landEnter check. */
+      res = LandInsert(&dummyRange, fo->primary, &left);
+      if (res != ResOK) {
+        /* The range was successful deleted from the primary above. */
+        AVER(res != ResFAIL);
+        res = LandInsert(&dummyRange, fo->secondary, &left);
+        AVER(res == ResOK);
+      }
+    }
+    RangeInit(&right, RangeLimit(range), RangeLimit(&oldRange));
+    if (!RangeIsEmpty(&right)) {
+      res = LandInsert(&dummyRange, fo->primary, &right);
+      if (res != ResOK) {
+        /* The range was successful deleted from the primary above. */
+        AVER(res != ResFAIL);
+        res = LandInsert(&dummyRange, fo->secondary, &right);
+        AVER(res == ResOK);
+      }
+    }
+  }
+  if (res == ResOK) {
+    AVER_CRITICAL(RangesNest(&oldRange, range));
+    RangeCopy(rangeReturn, &oldRange);
+  }
+  return res;
+}
+
+
+static Res failoverDeleteSteal(Range rangeReturn, Land land, Range range)
+{
+  Failover fo = MustBeA(Failover, land);
+  Res res;
+
+  AVER(rangeReturn != NULL);
+  AVERT(Range, range);
+
+  /* Prefer efficient search in the primary. See
+   * <design/failover#.impl.assume.flush>.
+   */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  res = LandDeleteSteal(rangeReturn, fo->primary, range);
+  if (res == ResFAIL)
+    /* Not found in primary: try secondary. */
+    res = LandDeleteSteal(rangeReturn, fo->secondary, range);
+  AVER(res == ResOK || res == ResFAIL);
+  return res;
+}
+
+
+static Bool failoverIterate(Land land, LandVisitor visitor, void *closure)
+{
+  Failover fo = MustBeA(Failover, land);
+
+  AVER(visitor != NULL);
+
+  return LandIterate(fo->primary, visitor, closure)
+    && LandIterate(fo->secondary, visitor, closure);
+}
+
+
+static Bool failoverFindFirst(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  Failover fo = MustBeA_CRITICAL(Failover, land);
+
+  AVER_CRITICAL(rangeReturn != NULL);
+  AVER_CRITICAL(oldRangeReturn != NULL);
+  AVERT_CRITICAL(FindDelete, findDelete);
+
+  /* <design/failover#.impl.assume.flush>. */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  return LandFindFirst(rangeReturn, oldRangeReturn, fo->primary, size, findDelete)
+    || LandFindFirst(rangeReturn, oldRangeReturn, fo->secondary, size, findDelete);
+}
+
+
+static Bool failoverFindLast(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  Failover fo = MustBeA_CRITICAL(Failover, land);
+
+  AVER_CRITICAL(rangeReturn != NULL);
+  AVER_CRITICAL(oldRangeReturn != NULL);
+  AVERT_CRITICAL(FindDelete, findDelete);
+
+  /* <design/failover#.impl.assume.flush>. */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  return LandFindLast(rangeReturn, oldRangeReturn, fo->primary, size, findDelete)
+    || LandFindLast(rangeReturn, oldRangeReturn, fo->secondary, size, findDelete);
+}
+
+
+static Bool failoverFindLargest(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  Failover fo = MustBeA_CRITICAL(Failover, land);
+
+  AVER_CRITICAL(rangeReturn != NULL);
+  AVER_CRITICAL(oldRangeReturn != NULL);
+  AVERT_CRITICAL(FindDelete, findDelete);
+
+  /* <design/failover#.impl.assume.flush>. */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  return LandFindLargest(rangeReturn, oldRangeReturn, fo->primary, size, findDelete)
+    || LandFindLargest(rangeReturn, oldRangeReturn, fo->secondary, size, findDelete);
+}
+
+
+static Bool failoverFindInZones(Bool *foundReturn, Range rangeReturn, Range oldRangeReturn, Land land, Size size, ZoneSet zoneSet, Bool high)
+{
+  Failover fo = MustBeA_CRITICAL(Failover, land);
+  Bool found = FALSE;
+  Res res;
+
+  AVER_CRITICAL(FALSE); /* TODO: this code is completely untested! */
+  AVER_CRITICAL(foundReturn != NULL);
+  AVER_CRITICAL(rangeReturn != NULL);
+  AVER_CRITICAL(oldRangeReturn != NULL);
+  /* AVERT_CRITICAL(ZoneSet, zoneSet); */
+  AVERT_CRITICAL(Bool, high);
+
+  /* <design/failover#.impl.assume.flush>. */
+  (void)LandFlush(fo->primary, fo->secondary);
+
+  res = LandFindInZones(&found, rangeReturn, oldRangeReturn, fo->primary, size, zoneSet, high);
+  if (res != ResOK || !found)
+    res = LandFindInZones(&found, rangeReturn, oldRangeReturn, fo->secondary, size, zoneSet, high);
+
+  *foundReturn = found;
+  return res;
+}
+
+
+static Res failoverDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
+{
+  Land land = CouldBeA(Land, inst);
+  Failover fo = CouldBeA(Failover, land);
+  LandClass primaryClass, secondaryClass;
+  Res res;
+
+  if (!TESTC(Failover, fo))
+    return ResPARAM;
+  if (stream == NULL)
+    return ResPARAM;
+
+  res = NextMethod(Inst, Failover, describe)(inst, stream, depth);
+  if (res != ResOK)
+    return res;
+
+  primaryClass = ClassOfPoly(Land, fo->primary);
+  secondaryClass = ClassOfPoly(Land, fo->secondary);
+
+  return WriteF(stream, depth + 2,
+                "primary = $P ($S)\n",
+                (WriteFP)fo->primary,
+                (WriteFS)ClassName(primaryClass),
+                "secondary = $P ($S)\n",
+                (WriteFP)fo->secondary,
+                (WriteFS)ClassName(secondaryClass),
+                NULL);
+}
+
+
+DEFINE_CLASS(Land, Failover, klass)
+{
+  INHERIT_CLASS(klass, Failover, Land);
+  klass->instClassStruct.describe = failoverDescribe;
+  klass->instClassStruct.finish = failoverFinish;
+  klass->size = sizeof(FailoverStruct);
+  klass->init = failoverInit;
+  klass->sizeMethod = failoverSize;
+  klass->insert = failoverInsert;
+  klass->insertSteal = failoverInsertSteal;
+  klass->delete = failoverDelete;
+  klass->deleteSteal = failoverDeleteSteal;
+  klass->iterate = failoverIterate;
+  klass->findFirst = failoverFindFirst;
+  klass->findLast = failoverFindLast;
+  klass->findLargest = failoverFindLargest;
+  klass->findInZones = failoverFindInZones;
+  AVERT(LandClass, klass);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2014-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/failover.h

@@ -0,0 +1,61 @@
+/* failover.h: FAILOVER ALLOCATOR INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2014-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/failover>.
+ */
+
+#ifndef failover_h
+#define failover_h
+
+#include "mpmtypes.h"
+#include "mpm.h"
+#include "protocol.h"
+
+typedef struct FailoverStruct *Failover;
+
+#define FailoverLand(fo) (&(fo)->landStruct)
+
+extern Bool FailoverCheck(Failover failover);
+
+DECLARE_CLASS(Land, Failover, Land);
+
+extern const struct mps_key_s _mps_key_failover_primary;
+#define FailoverPrimary (&_mps_key_failover_primary)
+#define FailoverPrimary_FIELD p
+extern const struct mps_key_s _mps_key_failover_secondary;
+#define FailoverSecondary (&_mps_key_failover_secondary)
+#define FailoverSecondary_FIELD p
+
+#endif /* failover.h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2014-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/finalcv.c

@@ -0,0 +1,278 @@
+/* finalcv.c: FINALIZATION COVERAGE TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ *
+ * DESIGN
+ *
+ * <design/poolmrg#.test>.
+ *
+ * DEPENDENCIES
+ *
+ * This test uses the dylan object format, but the reliance on this
+ * particular format is not great and could be removed.
+ *
+ * NOTES
+ *
+ * This code was created by first copying <code/weakcv.c>
+ */
+
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mpm.h"
+#include "mps.h"
+#include "mpsavm.h"
+#include "mpscamc.h"
+#include "mpscams.h"
+#include "mpscawl.h"
+#include "mpsclo.h"
+#include "mpslib.h"
+#include "mpstd.h"
+#include "testlib.h"
+
+#include <stdio.h> /* printf */
+
+
+#define testArenaSIZE   ((size_t)16<<20)
+#define rootCOUNT 20
+#define churnFACTOR 10
+#define finalizationRATE 6
+#define gcINTERVAL ((size_t)150 * 1024)
+#define collectionCOUNT 3
+#define finalizationCOUNT 3
+
+/* 3 words:  wrapper  |  vector-len  |  first-slot */
+#define vectorSIZE (3*sizeof(mps_word_t))
+#define vectorSLOT 2
+
+#define genCOUNT 2
+
+/* testChain -- generation parameters for the test */
+
+static mps_gen_param_s testChain[genCOUNT] = {
+  { 150, 0.85 }, { 170, 0.45 } };
+
+
+/* tags an integer according to dylan format */
+static mps_word_t dylan_int(mps_word_t x)
+{
+  return (x << 2)|1;
+}
+
+
+/* converts a dylan format int to an int (untags) */
+static mps_word_t dylan_int_int(mps_word_t x)
+{
+  return x >> 2;
+}
+
+
+/* note: static, so auto-initialised to NULL */
+static void *root[rootCOUNT];
+
+
+/* churn -- allocate a lot of stuff (unreachable garbage, so it will */
+/* probably only ever cause a minor collection). */
+static void churn(mps_ap_t ap)
+{
+  int i;
+  mps_addr_t p;
+  mps_res_t e;
+
+  for (i = 0; i < churnFACTOR; ++i) {
+    do {
+      MPS_RESERVE_BLOCK(e, p, ap, 4096);
+      die(e, "MPS_RESERVE_BLOCK");
+      die(dylan_init(p, 4096, root, 1), "dylan_init");
+    } while (!mps_commit(ap, p, 4096));
+  }
+  p = NULL;
+}
+
+
+enum {
+  rootSTATE,
+  deadSTATE,
+  finalizableSTATE,
+  finalizedSTATE
+};
+
+
+static void test(mps_arena_t arena, mps_pool_class_t pool_class)
+{
+  size_t i;                     /* index */
+  mps_ap_t ap;
+  mps_fmt_t fmt;
+  mps_chain_t chain;
+  mps_pool_t pool;
+  mps_res_t e;
+  mps_root_t mps_root[2];
+  mps_addr_t nullref = NULL;
+  int state[rootCOUNT];
+  size_t finalizations = 0;
+  size_t collections = 0;
+  void *p;
+
+  printf("---- finalcv: pool class %s ----\n", ClassName(pool_class));
+
+  die(mps_fmt_create_A(&fmt, arena, dylan_fmt_A()), "fmt_create\n");
+  die(mps_chain_create(&chain, arena, genCOUNT, testChain), "chain_create");
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, fmt);
+    die(mps_pool_create_k(&pool, arena, pool_class, args), "pool_create\n");
+  } MPS_ARGS_END(args);
+  die(mps_root_create_table(&mps_root[0], arena, mps_rank_exact(), (mps_rm_t)0,
+                            root, (size_t)rootCOUNT),
+      "root_create\n");
+  die(mps_root_create_table(&mps_root[1], arena, mps_rank_exact(), (mps_rm_t)0,
+                            &p, (size_t)1),
+      "root_create\n");
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "ap_create\n");
+
+  /* Make registered-for-finalization objects. */
+  /* <design/poolmrg#.test.promise.ut.alloc> */
+  for(i = 0; i < rootCOUNT; ++i) {
+    do {
+      MPS_RESERVE_BLOCK(e, p, ap, vectorSIZE);
+      die(e, "MPS_RES_OK");
+      die(dylan_init(p, vectorSIZE, &nullref, 1), "dylan_init");
+    } while (!mps_commit(ap, p, vectorSIZE));
+
+    /* store index in vector's slot */
+    ((mps_word_t *)p)[vectorSLOT] = dylan_int(i);
+
+    /* mps_definalize fails when there have been no calls to mps_finalize
+       yet, or for an address that was not registered for finalization. */
+    Insist(mps_definalize(arena, &p) == MPS_RES_FAIL);
+
+    die(mps_finalize(arena, &p), "finalize\n");
+    root[i] = p; state[i] = rootSTATE;
+  }
+  p = NULL;
+
+  mps_message_type_enable(arena, mps_message_type_finalization());
+  mps_message_type_enable(arena, mps_message_type_gc());
+
+  /* <design/poolmrg#.test.promise.ut.churn> */
+  while (finalizations < finalizationCOUNT && collections < collectionCOUNT) {
+    mps_message_type_t type;
+
+    /* Perhaps cause (minor) collection */
+    churn(ap);
+
+    /* Maybe make some objects ready-to-finalize */
+    /* <design/poolmrg#.test.promise.ut.drop> */
+    for (i = 0; i < rootCOUNT; ++i) {
+      if (root[i] != NULL && state[i] == rootSTATE) {
+        if (rnd() % finalizationRATE == 0) {
+          /* for this object, either... */
+          if (rnd() % 2 == 0) {
+            /* ...definalize it, or */
+            die(mps_definalize(arena, &root[i]), "definalize\n");
+            state[i] = deadSTATE;
+          } else {
+            /* ...expect it to be finalized soon */
+            state[i] = finalizableSTATE;
+          }
+          /* Drop the root reference to it; this makes it */
+          /* non-E-reachable: so either dead, or ready-to-finalize. */
+          root[i] = NULL;
+        }
+      }
+    }
+
+    while (mps_message_queue_type(&type, arena)) {
+      mps_message_t message;
+      cdie(mps_message_get(&message, arena, type), "message_get");
+      if (type == mps_message_type_finalization()) {
+        /* Check finalized object, and perhaps resurrect it. */
+        mps_word_t *obj;
+        mps_word_t objind;
+        mps_addr_t objaddr;
+
+        /* <design/poolmrg#.test.promise.ut.message> */
+        cdie(0 == mps_message_clock(arena, message),
+             "message clock should be 0 (unset) for finalization messages");
+        mps_message_finalization_ref(&objaddr, arena, message);
+        obj = objaddr;
+        objind = dylan_int_int(obj[vectorSLOT]);
+        printf("Finalizing: object %"PRIuLONGEST" at %p\n",
+               (ulongest_t)objind, objaddr);
+        /* <design/poolmrg#.test.promise.ut.final.check> */
+        cdie(root[objind] == NULL, "finalized live");
+        cdie(state[objind] == finalizableSTATE, "finalized dead");
+        state[objind] = finalizedSTATE;
+        /* sometimes resurrect */
+        if (rnd() % 2 == 0)
+          root[objind] = objaddr;
+        ++ finalizations;
+      } else if (type == mps_message_type_gc()) {
+        ++ collections;
+      } else {
+        error("Unexpected message type %lu.", (unsigned long)type);
+      }
+      mps_message_discard(arena, message);
+    }
+  }
+
+  mps_ap_destroy(ap);
+  mps_root_destroy(mps_root[1]);
+  mps_root_destroy(mps_root[0]);
+  mps_pool_destroy(pool);
+  mps_chain_destroy(chain);
+  mps_fmt_destroy(fmt);
+}
+
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+
+  testlib_init(argc, argv);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "arena_create\n");
+
+  test(arena, mps_class_amc());
+  test(arena, mps_class_amcz());
+  test(arena, mps_class_awl());
+  test(arena, mps_class_ams());
+  test(arena, mps_class_lo());
+
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/finaltest.c

@@ -0,0 +1,350 @@
+/* finaltest.c: LARGE-SCALE FINALIZATION TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ *
+ * DESIGN
+ *
+ * .mode: This test has two modes.
+ *
+ * .mode.park: In this mode, we use the arena's default generation
+ * chain, leave the arena parked and call mps_arena_collect. This
+ * tests that the default generation chain works and that all segments
+ * get condemned via TraceStartCollectAll. (See job003771 item 4.)
+ *
+ * .mode.poll: In this mode, we use our own generation chain (with
+ * small generations), allocate into generation 1, unclamp the arena,
+ * and provoke collection by allocating. This tests that custom
+ * generation chains work, and that segments get condemned via
+ * TracePoll even if there is no allocation into generation 0 of the
+ * chain. (See job003771 item 5.)
+ *
+ * DEPENDENCIES
+ *
+ * This test uses the dylan object format, but the reliance on this
+ * particular format is not great and could be removed.
+ *
+ * NOTES
+ *
+ * This code was created by first copying <code/finalcv.c>
+ */
+
+#include "mpm.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include "mps.h"
+#include "mpscamc.h"
+#include "mpscams.h"
+#include "mpscawl.h"
+#include "mpsclo.h"
+#include "mpsavm.h"
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mpstd.h"
+
+#include <math.h> /* HUGE_VAL */
+#include <stdio.h> /* fflush, printf, stdout */
+
+enum {
+  ModePARK,                     /* .mode.park */
+  ModePOLL                      /* .mode.poll */
+};
+
+
+#define testArenaSIZE   ((size_t)16<<20)
+#define rootCOUNT 20
+#define maxtreeDEPTH 9
+#define collectionCOUNT 10
+
+
+/* global object counter */
+
+static mps_word_t object_count = 0;
+
+static mps_word_t make_numbered_cons(mps_word_t car, mps_word_t cdr,
+                                     mps_ap_t ap)
+{
+    mps_word_t cons;
+    die(make_dylan_vector(&cons, ap, 3), "make_dylan_vector");
+    DYLAN_VECTOR_SLOT(cons, 0) = car;
+    DYLAN_VECTOR_SLOT(cons, 1) = cdr;
+    DYLAN_VECTOR_SLOT(cons, 2) = DYLAN_INT(object_count);
+    ++ object_count;
+    return cons;
+}
+
+static mps_word_t make_numbered_tree(mps_word_t depth,
+                                     mps_ap_t ap)
+{
+    mps_word_t left, right;
+    if (depth < 2) {
+        left = DYLAN_INT(object_count);
+        right = DYLAN_INT(object_count);
+    } else {
+        left = make_numbered_tree(depth-1, ap);
+        right = make_numbered_tree(depth-1, ap);
+    }
+    return make_numbered_cons(left, right, ap);
+}
+
+static void register_numbered_tree(mps_word_t tree, mps_arena_t arena)
+{
+    /* don't finalize ints */
+    if ((tree & 1) == 0) {
+        mps_addr_t tree_ref = (mps_addr_t)tree;
+        die(mps_finalize(arena, &tree_ref), "mps_finalize");
+        register_numbered_tree(DYLAN_VECTOR_SLOT(tree, 0), arena);
+        register_numbered_tree(DYLAN_VECTOR_SLOT(tree, 1), arena);
+    }
+}
+
+static mps_word_t make_indirect_cons(mps_word_t car, mps_word_t cdr,
+                                     mps_ap_t ap)
+{
+    mps_word_t cons, indirect;
+    die(make_dylan_vector(&indirect, ap, 1), "make_dylan_vector");
+    DYLAN_VECTOR_SLOT(indirect, 0) = DYLAN_INT(object_count);
+    die(make_dylan_vector(&cons, ap, 3), "make_dylan_vector");
+    DYLAN_VECTOR_SLOT(cons, 0) = car;
+    DYLAN_VECTOR_SLOT(cons, 1) = cdr;
+    DYLAN_VECTOR_SLOT(cons, 2) = indirect;
+    ++ object_count;
+    return cons;
+}
+
+static mps_word_t make_indirect_tree(mps_word_t depth,
+                                     mps_ap_t ap)
+{
+    mps_word_t left, right;
+    if (depth < 2) {
+        left = DYLAN_INT(object_count);
+        right = DYLAN_INT(object_count);
+    } else {
+        left = make_indirect_tree(depth-1, ap);
+        right = make_indirect_tree(depth-1, ap);
+    }
+    return make_indirect_cons(left, right, ap);
+}
+
+static void register_indirect_tree(mps_word_t tree, mps_arena_t arena)
+{
+    /* don't finalize ints */
+    if ((tree & 1) == 0) {
+        mps_word_t indirect = DYLAN_VECTOR_SLOT(tree,2);
+        mps_addr_t indirect_ref = (mps_addr_t)indirect;
+        die(mps_finalize(arena, &indirect_ref), "mps_finalize");
+        register_indirect_tree(DYLAN_VECTOR_SLOT(tree, 0), arena);
+        register_indirect_tree(DYLAN_VECTOR_SLOT(tree, 1), arena);
+    }
+}
+
+static void *root[rootCOUNT];
+
+static void test_trees(int mode, const char *name, mps_arena_t arena,
+                       mps_pool_t pool, mps_ap_t ap,
+                       mps_word_t (*make)(mps_word_t, mps_ap_t),
+                       void (*reg)(mps_word_t, mps_arena_t))
+{
+  size_t collections = 0;
+  size_t finals = 0;
+  size_t i;
+  int object_alloc;
+  PoolClass klass = ClassOfPoly(Pool, pool);
+
+  object_count = 0;
+
+  printf("---- Mode %s, pool class %s, %s trees ----\n",
+         mode == ModePARK ? "PARK" : "POLL",
+         ClassName(klass), name);
+  mps_arena_park(arena);
+  mps_message_type_enable(arena, mps_message_type_gc());
+
+  /* make some trees */
+  for(i = 0; i < rootCOUNT; ++i) {
+    root[i] = (void *)(*make)(maxtreeDEPTH, ap);
+    (*reg)((mps_word_t)root[i], arena);
+  }
+
+  /* clean out the roots */
+  for(i = 0; i < rootCOUNT; ++i) {
+    root[i] = 0;
+  }
+
+  while (finals < object_count && collections < collectionCOUNT) {
+    mps_message_type_t type;
+    mps_word_t final_this_time = 0;
+    switch (mode) {
+    default:
+    case ModePARK:
+      printf("Collecting...");
+      (void)fflush(stdout);
+      die(mps_arena_collect(arena), "collect");
+      printf(" Done.\n");
+      break;
+    case ModePOLL:
+      mps_arena_release(arena);
+      printf("Allocating...");
+      (void)fflush(stdout);
+      object_alloc = 0;
+      while (object_alloc < 1000 && !mps_message_poll(arena))
+        (void)DYLAN_INT(object_alloc++);
+      printf(" Done.\n");
+      break;
+    }
+    {
+      size_t live_size = (object_count - finals) * sizeof(void *) * 3;
+      size_t total_size = mps_pool_total_size(pool);
+      size_t free_size = mps_pool_free_size(pool);
+      Insist(free_size <= total_size);
+      Insist(free_size + live_size <= total_size);
+    }
+    while (mps_message_queue_type(&type, arena)) {
+      mps_message_t message;
+      cdie(mps_message_get(&message, arena, type), "message_get");
+      if (type == mps_message_type_finalization()) {
+        mps_addr_t objaddr;
+        mps_message_finalization_ref(&objaddr, arena, message);
+        ++ final_this_time;
+      } else if (type == mps_message_type_gc()) {
+        ++ collections;
+      } else {
+        error("Unexpected message type %lu.", (unsigned long)type);
+      }
+      mps_message_discard(arena, message);
+    }
+    finals += final_this_time;
+    printf("%"PRIuLONGEST" objects finalized: total %"PRIuLONGEST
+           " of %"PRIuLONGEST"\n", (ulongest_t)final_this_time,
+           (ulongest_t)finals, (ulongest_t)object_count);
+  }
+
+  if (finals != object_count) {
+    PoolClass poolClass = ClassOfPoly(Pool, BufferOfAP(ap)->pool);
+    error("Not all objects were finalized for %s in mode %s.",
+          ClassName(poolClass),
+          mode == ModePOLL ? "POLL" : "PARK");
+  }
+
+  if (collections > collectionCOUNT)
+    error("Expected no more than %lu collections but got %lu.",
+          (unsigned long)collectionCOUNT, (unsigned long)collections);
+}
+
+static void test_pool(int mode, mps_arena_t arena, mps_chain_t chain,
+                      mps_pool_class_t pool_class)
+{
+  mps_ap_t ap;
+  mps_fmt_t fmt;
+  mps_pool_t pool;
+  mps_root_t mps_root;
+
+  die(mps_fmt_create_A(&fmt, arena, dylan_fmt_A()), "fmt_create\n");
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, fmt);
+    if (mode == ModePOLL) {
+      MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
+      MPS_ARGS_ADD(args, MPS_KEY_GEN, 1);
+    }
+    die(mps_pool_create_k(&pool, arena, pool_class, args),
+        "pool_create\n");
+  } MPS_ARGS_END(args);
+  die(mps_root_create_table(&mps_root, arena, mps_rank_exact(), (mps_rm_t)0,
+                            root, (size_t)rootCOUNT),
+      "root_create\n");
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "ap_create\n");
+
+  test_trees(mode, "numbered", arena, pool, ap, make_numbered_tree,
+             register_numbered_tree);
+  test_trees(mode, "indirect", arena, pool, ap, make_indirect_tree,
+             register_indirect_tree);
+
+  mps_ap_destroy(ap);
+  mps_root_destroy(mps_root);
+  mps_pool_destroy(pool);
+  mps_fmt_destroy(fmt);
+}
+
+
+static void test_mode(int mode, mps_arena_t arena, mps_chain_t chain)
+{
+  test_pool(mode, arena, chain, mps_class_amc());
+  test_pool(mode, arena, chain, mps_class_amcz());
+  test_pool(mode, arena, chain, mps_class_ams());
+  test_pool(mode, arena, chain, mps_class_awl());
+  test_pool(mode, arena, chain, mps_class_lo());
+}
+
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  mps_thr_t thread;
+  mps_chain_t chain;
+  mps_gen_param_s params[2];
+  size_t gens = 2;
+  size_t i;
+
+  testlib_init(argc, argv);
+
+  MPS_ARGS_BEGIN(args) {
+    /* Randomize pause time as a regression test for job004007. */
+    double t = rnd_double();
+    if (t == 0.0)
+      t = HUGE_VAL; /* Would prefer to use INFINITY but it's not in C89. */
+    else
+      t = 1 / t - 1;
+    MPS_ARGS_ADD(args, MPS_KEY_PAUSE_TIME, t);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, testArenaSIZE);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args),
+        "arena_create\n");
+  } MPS_ARGS_END(args);
+  mps_message_type_enable(arena, mps_message_type_finalization());
+  die(mps_thread_reg(&thread, arena), "thread_reg\n");
+  for (i = 0; i < gens; ++i) {
+    params[i].mps_capacity = 1;
+    params[i].mps_mortality = 0.5;
+  }
+  die(mps_chain_create(&chain, arena, gens, params), "chain_create\n");
+
+  test_mode(ModePOLL, arena, chain);
+  test_mode(ModePARK, arena, NULL);
+
+  mps_arena_park(arena);
+  mps_chain_destroy(chain);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtdy.c

@@ -0,0 +1,886 @@
+/* fmtdy.c: DYLAN OBJECT FORMAT IMPLEMENTATION
+ *
+ *  $Id$
+ *  Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *  Portions copyright (c) 2002 Global Graphics Software.
+ *
+ * .readership: MPS developers, Dylan developers
+ *
+ *  .layouts:
+ *
+ *  All objects, B:
+ *
+ *  B           W               pointer to wrapper
+ *  B+1         object body
+ *
+ *  Forwarded (or padding) one-word objects, B:
+ *
+ *  B           N | 0b01        new address | 1
+ *
+ *  Forwarded (or padding) multi-word objects, B:
+ *
+ *  B           N | 0b10        new address | 2
+ *  B+1         L               limit of object (addr of end + 1)
+ *
+ *  Wrappers, W:
+ *
+ *  W           WW              pointer to wrapper wrapper
+ *  W+1         class           DylanWorks class pointer (traceable)
+ *  W+2         subtype_mask    DylanWorks subtype_mask (untraceable)
+ *  W+3         (FL << 2) | FF  fixed part length and format
+ *  W+4         (VS << 3) | VF  variable part format and element size
+ *  W+5         (WT << 2) | 1   tagged pattern vector length
+ *  W+6         pattern 0       patterns for fixed part fields
+ *  W+6+WT-1    pattern WT-1
+ *
+ *  The wrapper wrapper, WW:
+ *
+ *  WW          WW              WW is it's own wrapper
+ *  WW+1        class           DylanWorks class of wrappers
+ *  WW+2        subtype_mask    DylanWorks subtype_mask for WW
+ *  WW+3        (4 << 2) | 2    wrappers have four patterned fields
+ *  WW+4        (0 << 3) | 0    wrappers have a non-traceable vector
+ *  WW+5        (1 << 2) | 1    one pattern word follows
+ *  WW+6        0b001           only field 0 is traceable
+ *
+ *  .improve.abstract.access: There are severe common subexpression
+ *  problems.  In particular, code for accessing subfields in the
+ *  fh and vh words is repeated.  It should be abstracted into
+ *  macros (or functions).  This is particularly bad for the vh
+ *  word which has 4 subfields (version, vb, es, vf).
+ */
+
+
+#include "fmtdy.h"
+#include "fmtno.h"
+#include "mps.h"
+#include <assert.h>
+#include <string.h>
+#include <stdlib.h>
+#include <limits.h>
+
+
+#define notreached()    assert(0)
+#define unused(param)   ((void)param)
+
+
+#ifdef _MSC_VER
+
+/* MPS_END causes "constant conditional" warnings. */
+#pragma warning(disable: 4127)
+
+#endif /* _MSC_VER */
+
+
+#define ALIGN           sizeof(mps_word_t)
+
+#define FMTDY_WORD_WIDTH (sizeof(mps_word_t) * CHAR_BIT)
+#define FMTDY_WORD_SHIFT (FMTDY_WORD_WIDTH == 64 ? 6 : 5)
+/* FMTDY_WORD_SHIFT is a bit hacky, but good enough for tests. */
+
+#ifdef FMTDY_COUNTING
+#define FMTDY_COUNT(x) x
+#define FMTDY_FL_LIMIT 16
+static unsigned long dylan_vff_counts[4*8];
+static unsigned long dylan_fl_counts[FMTDY_FL_LIMIT];
+static unsigned long dylan_fl_oversize_count;
+static unsigned long dylan_fw_counts[2];
+#else
+#define FMTDY_COUNT(x)
+#endif /* FMTDY_COUNTING */
+
+
+int dylan_wrapper_check(mps_word_t *w)
+{
+  mps_word_t *ww;
+  mps_word_t vh;
+  mps_word_t version;
+  mps_word_t reserved;
+  mps_word_t klass;
+  mps_word_t fh, fl, ff;
+  mps_word_t vb, es, vf;
+  mps_word_t vt, t;
+
+  assert(w != NULL);
+  assert(((mps_word_t)w & 3) == 0);
+
+  /* The first word of the wrapper is a pointer to a wrapper wrapper, */
+  /* which always has the same contents.  Check it. */
+
+  /* .improve.unique.wrapper: When this becomes part of the Dylan
+   * run-time, it would be possible to know the address of a unique
+   * wrapper wrapper and check that instead. */
+
+  assert(w[WW] != 0);
+  assert((w[WW] & 3) == 0);          /* wrapper wrapper is aligned */
+  ww = (mps_word_t *)w[WW];
+  assert(ww[WW] == w[WW]);           /* wrapper wrapper is own wrapper */
+  assert(ww[WC] != 0);               /* wrapper class exists */
+  assert((ww[WC] & 3) == 0);         /* wrapper class is aligned */
+  assert(ww[WF] == (((WS - 1) << 2) | 2));  /* fields with patterns */
+  assert((ww[WV] & 0x00ffffff) == 0);/* non-traceable vector */
+  /* Code in this file only works for version 2 */
+  assert(((ww[WV] >> (FMTDY_WORD_WIDTH - 8)) & 0xff) == 2);
+  assert(ww[WS] == ((1 << 2) | 1));  /* one pattern word in wrapper wrapper */
+  /* The first field is traceable, the second field can be traced, */
+  /* but doesn't need to be. */
+  assert((ww[WP] == 1) || (ww[WP] == 3));
+  unused(ww);
+
+  /* Unpack the wrapper. */
+
+  klass = w[WC];         /* class */
+  unused(klass);
+  fh = w[WF];            /* fixed part header word */
+  fl = fh >> 2;         /* fixed part length */
+  ff = fh & 3;          /* fixed part format code */
+  vh = w[WV];            /* variable part header */
+  version = (vh >> (FMTDY_WORD_WIDTH - 8)) & 0xff;
+  assert(version == 2); /* Code in this file only works for version 2 */
+  unused(version);
+  reserved = (vh >> 8) & 0xff;
+  assert(reserved == 0);
+  unused(reserved);
+  vb = (vh >> 16) & 0xff;
+  unused(vb);
+  es = (vh & 0xff) >> 3;/* element size */
+  vf = vh & 7;          /* variable part format code */
+  vt = w[WS];            /* vector total word (Dylan-tagged) */
+  t = vt >> 2;          /* vector total length */
+  unused(t);
+
+  /* The second word is the class of the wrapped object. */
+  /* It would be good to check which pool this is in. */
+
+  assert(klass != 0);                   /* class exists */
+  assert((klass & 3) == 0);             /* class is aligned */
+
+  /* The third word contains the fixed part format and length. */
+  /* The only illegal format is 3.  Anything else is possible, although */
+  /* we could do some bound checking on the length if we knew more about */
+  /* the surroundings of the object. */
+
+  /* Fixed part format 3 is reserved. */
+  assert(ff != 3);
+  unused(ff);
+
+  /* Zero length fixed part is only legal in format 0. */
+  /* Current Dylan run-time does not honour this so I remove it for now */
+  /* We probably want this check as then we can scan without having to */
+  /* check for 0 fixed length fields as a special case */
+  /* assert(ff == 0 || fl != 0); */
+  unused(fl);
+  /* The fourth word contains the variable part format and element */
+  /* size.  This assumes that DylanWorks is only going to use byte */
+  /* vectors in the non-word case. */
+
+  /* Variable part format 6 is reserved. */
+  assert(vf != 6);
+  unused(vf);
+
+  /* There should be no shift in word vector formats. */
+  assert((vf & 6) == 4 || es == 0);
+  unused(es);
+
+  /* The fifth word is the number of patterns in the pattern */
+  /* vector.  This can be calculated from the fixed part length. */
+  /* The word is also tagged like a DylanWorks integer. */
+
+  assert((vt & 3) == 1);
+
+  /* The pattern vector in the wrapper should be of non-zero length */
+  /* only if there is a patterned fixed part. */
+  assert(ff == 2 || t == 0);
+
+  /* The number of patterns is (fixed fields+31)/32. */
+  assert(ff != 2 || t == ((fl + FMTDY_WORD_WIDTH - 1) / FMTDY_WORD_WIDTH));
+
+  /* The patterns are random bits, so we can't check them.  However, */
+  /* the left-over bits in the last pattern should be zero. */
+
+  assert(ff != 2 || (w[WS+t] >> ((fh>>2) & (FMTDY_WORD_WIDTH-1))) == 0);
+
+  return 1;
+}
+
+
+/* Scan a contiguous array of references in [base, limit). */
+/* This code has been hand-optimised and examined using Metrowerks */
+/* Codewarrior on a 68K and also Microsoft Visual C on a 486.  The */
+/* variables in the loop allocate nicely into registers.  Alter with */
+/* care. */
+
+static mps_res_t dylan_scan_contig(mps_ss_t mps_ss,
+                                   mps_addr_t *base, mps_addr_t *limit)
+{
+  mps_res_t res;
+  mps_addr_t *p;        /* reference cursor */
+  mps_addr_t r;         /* reference to be fixed */
+
+  MPS_SCAN_BEGIN(mps_ss) {
+          p = base;
+    loop: if(p >= limit) goto out;
+          r = *p++;
+          if(((mps_word_t)r&3) != 0) /* pointers tagged with 0 */
+            goto loop;             /* not a pointer */
+          if(!MPS_FIX1(mps_ss, r)) goto loop;
+          res = MPS_FIX2(mps_ss, p-1);
+          if(res == MPS_RES_OK) goto loop;
+          return res;
+    out:  assert(p == limit);
+  } MPS_SCAN_END(mps_ss);
+
+  return MPS_RES_OK;
+}
+
+/* dylan_weak_dependent -- returns the linked object, if any.
+ */
+
+mps_addr_t dylan_weak_dependent(mps_addr_t parent)
+{
+  mps_word_t *object;
+  mps_word_t *wrapper;
+  mps_word_t fword;
+  mps_word_t fl;
+  mps_word_t ff;
+
+  assert(parent != NULL);
+  object = (mps_word_t *)parent;
+  wrapper = (mps_word_t *)object[0];
+  assert(dylan_wrapper_check(wrapper));
+  fword = wrapper[3];
+  ff = fword & 3;
+  /* traceable fixed part */
+  assert(ff == 1);
+  unused(ff);
+  fl = fword & ~(mps_word_t)3;
+  /* at least one fixed field */
+  assert(fl >= 1);
+  unused(fl);
+  return (mps_addr_t) object[1];
+}
+
+
+/* Scan weakly a contiguous array of references in [base, limit). */
+/* Only required to scan vectors for Dylan Weak Tables. */
+/* Depends on the vector length field being scannable (ie a tagged */
+/* integer). */
+/* When a reference that has been fixed to NULL is detected the */
+/* corresponding reference in the associated table (pointed to be the */
+/* assoc variable) will be deleted. */
+
+static mps_res_t
+dylan_scan_contig_weak(mps_ss_t mps_ss,
+                       mps_addr_t *base, mps_addr_t *limit,
+                       mps_addr_t *objectBase, mps_addr_t *assoc)
+{
+  mps_addr_t *p;
+  mps_res_t res;
+  mps_addr_t r;
+
+  MPS_SCAN_BEGIN(mps_ss) {
+    p = base;
+    goto skip_inc;
+  loop:
+    ++p;
+  skip_inc:
+    if(p >= limit)
+      goto out;
+    r = *p;
+    if(((mps_word_t)r & 3) != 0) /* non-pointer */
+      goto loop;
+    if(!MPS_FIX1(mps_ss, r))
+      goto loop;
+    res = MPS_FIX2(mps_ss, p);
+    if(res == MPS_RES_OK) {
+      if(*p == 0 && r != 0) {
+        if(assoc != NULL) {
+          assoc[p-objectBase] = 0;      /* delete corresponding entry */
+        }
+      }
+      goto loop;
+    }
+    return res;
+  out:
+    assert(p == limit);
+  } MPS_SCAN_END(mps_ss);
+
+  return MPS_RES_OK;
+}
+
+
+/* dylan_scan_pat -- scan according to pattern */
+
+/* Scan an array of words in [base, limit) using the patterns at pats */
+/* to determine which words can be fixed. */
+/* This code has been hand-optimised and examined using Metrowerks */
+/* Codewarrior on a 68K and also Microsoft Visual C on a 486.  The */
+/* variables in the loop allocate nicely into registers.  Alter with */
+/* care. */
+
+static mps_res_t dylan_scan_pat(mps_ss_t mps_ss,
+                                mps_addr_t *base, mps_addr_t *limit,
+                                mps_word_t *pats, mps_word_t nr_pats)
+{
+  mps_res_t res;
+  mps_word_t *pc = pats;/* pattern cursor */
+  mps_word_t pat;       /* pattern register */
+  mps_addr_t *p;        /* reference cursor */
+  mps_addr_t *pp;       /* inner loop cursor */
+  int b;                /* bit */
+  mps_addr_t r;         /* reference to be fixed */
+
+  unused(nr_pats);
+
+  MPS_SCAN_BEGIN(mps_ss) {
+          p = base;
+          goto in;
+    pat:  p += FMTDY_WORD_WIDTH;
+          if(p >= limit) goto out;
+    in:   pp = p;
+          pat = *pc++;
+    loop: if(pat == 0) goto pat;
+          ++pp;
+          b = (int)(pat & 1);
+          pat >>= 1;
+          if(b == 0) goto loop;
+          r = *(pp-1);
+          if(((mps_word_t)r&3) != 0) /* pointers tagged with 0 */
+            goto loop;             /* not a pointer */
+          if(!MPS_FIX1(mps_ss, r)) goto loop;
+          res = MPS_FIX2(mps_ss, pp-1);
+          if(res == MPS_RES_OK) goto loop;
+          return res;
+    out:  assert(p < limit + FMTDY_WORD_WIDTH);
+          assert(pc == pats + nr_pats);
+  } MPS_SCAN_END(mps_ss);
+
+  return MPS_RES_OK;
+}
+
+
+#define NONWORD_LENGTH(_vt, _es) \
+  ((_es) < FMTDY_WORD_SHIFT ? \
+   ((_vt) + ((mps_word_t)1 << (FMTDY_WORD_SHIFT - (_es))) - 1) >> \
+     (FMTDY_WORD_SHIFT - (_es)) : \
+   (_vt) << ((_es) - FMTDY_WORD_SHIFT))
+
+
+mps_res_t dylan_scan1(mps_ss_t mps_ss, mps_addr_t *object_io)
+{
+  mps_addr_t *p;        /* cursor in object */
+  mps_addr_t *q;        /* cursor limit for loops */
+  mps_word_t h;         /* header word */
+  mps_word_t *w;        /* pointer to wrapper */
+  mps_word_t fh;        /* fixed part header word */
+  mps_word_t fl;        /* fixed part length, in words */
+  mps_word_t vh;        /* variable part header */
+  mps_word_t vf;        /* variable part format */
+  mps_word_t vl;        /* variable part actual length */
+  unsigned vb;          /* vector bias */
+  unsigned es;          /* variable part element size (log2 of bits) */
+  mps_word_t vt;        /* total vector length */
+  mps_res_t res;
+
+  assert(object_io != NULL);
+
+  p = (mps_addr_t *)*object_io;
+  assert(p != NULL);
+
+  h = (mps_word_t)p[0];         /* load the header word */
+
+  /* If the object is forwarded, simply skip it. */
+  if(h & 3) {
+    mps_addr_t l;
+
+    if((h & 3) == 1) {
+      /* single-word */
+      l = (mps_addr_t)(p + 1);
+      FMTDY_COUNT(++dylan_fw_counts[0]);
+    } else {                      /* multi-word */
+      assert((h & 3) == 2);
+      l = (mps_addr_t)p[1];
+      FMTDY_COUNT(++dylan_fw_counts[1]);
+    }
+
+    *object_io = l;
+    return MPS_RES_OK;
+  }
+
+  MPS_SCAN_BEGIN(mps_ss) {
+    res = MPS_FIX12(mps_ss, p); /* fix the wrapper */
+  } MPS_SCAN_END(mps_ss);
+  if (res != MPS_RES_OK)
+    return res;
+  w = (mps_word_t *)p[0];       /* wrapper is header word */
+  assert(dylan_wrapper_check(w));
+
+  ++p;                          /* skip header */
+
+  /* Fixed Part */
+
+  fh = w[WF];
+  fl = fh >> 2;                 /* get the fixed part length */
+
+  /* It might be worth inlining common cases here, for example, */
+  /* pairs.  This can be done by examining fh as a whole. */
+
+  FMTDY_COUNT(fl < FMTDY_FL_LIMIT ? ++dylan_fl_counts[fl] :
+                                       ++dylan_fl_oversize_count);
+  if(fl > 0) {
+    q = p + fl;                 /* set q to end of fixed part */
+    switch(fh & 3) {            /* switch on the fixed format */
+      case 0:                   /* all non-traceable fields */
+      p = q;
+      break;
+
+      case 1:                   /* all traceable fields */
+      res = dylan_scan_contig(mps_ss, p, q);
+      if(res) return res;
+      break;
+
+      case 2:                   /* patterns */
+      res = dylan_scan_pat(mps_ss, p, q, &w[WP], w[WS]>>2);
+      if(res) return res;
+      break;
+
+      default:
+      notreached();
+      break;
+    }
+    p = q;
+  }
+
+  /* Variable Part */
+  vh = w[WV];
+  vf = vh & 7;                  /* get variable part format */
+  FMTDY_COUNT(++dylan_vff_counts[(vf << 2)|(fh&3)]);
+  if(vf != 7)
+  {
+    vt = *(mps_word_t *)p;      /* total vector length */
+    assert((vt & 3) == 1);      /* check Dylan integer tag */
+    vt >>= 2;                   /* untag it */
+    ++p;
+
+    switch(vf)
+    {
+      case 0:                   /* non-stretchy non-traceable */
+      p += vt;
+      break;
+
+      case 1:                   /* stretchy non-traceable */
+      p += vt + 1;
+      notreached();             /* Not used by DylanWorks yet */
+      break;
+
+      case 2:                   /* non-stretchy traceable */
+      q = p + vt;
+      res = dylan_scan_contig(mps_ss, p, q);
+      if(res) return res;
+      p = q;
+      break;
+
+      case 3:                   /* stretchy traceable */
+      vl = *(mps_word_t *)p;    /* vector length */
+      assert((vl & 3) == 1);    /* check Dylan integer tag */
+      vl >>= 2;                 /* untag it */
+      ++p;
+      res = dylan_scan_contig(mps_ss, p, p + vl);
+      if(res) return res;
+      p += vt;                  /* skip to end of whole vector */
+      notreached();             /* DW doesn't create them yet */
+      break;
+
+      case 4:                   /* non-word */
+      es = (unsigned)(vh & 0xff) >> 3;
+      vb = (unsigned)((vh >> 16) & 0xff);
+      vt += vb;
+      p += NONWORD_LENGTH(vt, es);
+      break;
+
+      case 5:                   /* stretchy non-word */
+      es = (unsigned)(vh & 0xff) >> 3;
+      vb = (unsigned)((vh >> 16) & 0xff);
+      vt += vb;
+      p += NONWORD_LENGTH(vt, es) + 1;
+      notreached();             /* DW doesn't create them yet */
+      break;
+
+      default:
+      notreached();
+      break;
+    }
+  }
+
+  *object_io = (mps_addr_t)p;
+  return MPS_RES_OK;
+}
+
+static mps_res_t dylan_scan(mps_ss_t mps_ss,
+                            mps_addr_t base, mps_addr_t limit)
+{
+  mps_res_t res;
+  mps_addr_t prev = base;
+
+  while(base < limit) {
+    prev = base;
+    res = dylan_scan1(mps_ss, &base);
+    if(res) return res;
+    assert(prev < base);
+  }
+
+  assert(base == limit);
+
+  return MPS_RES_OK;
+}
+
+/* dylan_class -- return pointer indicating class of object
+ *
+ * Return wrapper pointer, except for broken hearts or padding
+ */
+
+static mps_addr_t dylan_class(mps_addr_t obj)
+{
+  mps_word_t first_word = ((mps_word_t *)obj)[0];
+
+  if((first_word & 3) != 0) /* broken heart or padding */
+    return NULL;
+  else
+    return (mps_addr_t)first_word;
+}
+
+mps_res_t dylan_scan1_weak(mps_ss_t mps_ss, mps_addr_t *object_io)
+{
+  mps_addr_t *assoc;
+  mps_addr_t *base;
+  mps_addr_t *p, q;
+  mps_res_t res;
+  mps_word_t *w;
+  mps_word_t fword, ff, fl;
+  mps_word_t h;
+  mps_word_t vword, vf, vl;
+
+  assert(object_io != NULL);
+  base = (mps_addr_t *)*object_io;
+  assert(base != NULL);
+  p = base;
+
+  h = (mps_word_t)p[0];
+  /* object should not be forwarded (as there is no forwarding method) */
+  assert((h & 3) == 0);
+  unused(h);
+
+  MPS_SCAN_BEGIN(mps_ss) {
+    res = MPS_FIX12(mps_ss, p);
+  } MPS_SCAN_END(mps_ss);
+  if (res != MPS_RES_OK)
+    return res;
+
+  /* w points to wrapper */
+  w = (mps_word_t *)p[0];
+
+  assert(dylan_wrapper_check(w));
+
+  ++p;                  /* skip header */
+
+  fword = w[WF];
+  fl = fword >> 2;
+  /* weak vectors should have at least one fixed field */
+  /* (for assoc field) */
+  assert(fl >= 1);
+
+  ff = fword & 3;
+
+  /* weak vectors should have traceable fixed format */
+  assert(ff == 1);
+  unused(ff);
+
+  assoc = (mps_addr_t *)p[0];
+
+  vword = w[WV];
+  vf = vword & 7;
+  vl = (mps_word_t)p[fl] >> 2;
+
+  /* weak vectors should be non-stretchy traceable */
+  assert(vf == 2);
+  unused(vf);
+
+  /* q is end of the object.  There are fl fixed fields, vl variable */
+  /* fields and another slot that contains the vector length */
+  q = p + fl + vl + 1;
+
+  res = dylan_scan_contig_weak(mps_ss, p, q, base, assoc);
+  if(res != MPS_RES_OK) {
+    return res;
+  }
+
+  *object_io = q;
+  return MPS_RES_OK;
+}
+
+
+static mps_res_t dylan_scan_weak(mps_ss_t mps_ss,
+                                 mps_addr_t base, mps_addr_t limit)
+{
+  mps_res_t res;
+
+  while(base < limit) {
+    res = dylan_scan1_weak(mps_ss, &base);
+    if(res) return res;
+  }
+
+  assert(base == limit);
+
+  return MPS_RES_OK;
+}
+
+mps_addr_t dylan_skip(mps_addr_t object)
+{
+  mps_addr_t *p;        /* cursor in object */
+  mps_word_t *w;        /* wrapper cursor */
+  mps_word_t h;         /* header word */
+  mps_word_t vh;        /* variable part header */
+  mps_word_t vf;        /* variable part format */
+  mps_word_t vt;        /* total vector length */
+  unsigned vb;          /* vector bias */
+  unsigned es;          /* variable part element size (log2 of bits) */
+
+  p = (mps_addr_t *)object;
+  assert(p != NULL);
+
+  h = (mps_word_t)p[0];         /* load the header word */
+
+  /* If the object is forwarded, simply skip it. */
+  if(h & 3) {
+    mps_addr_t l;
+
+    if((h & 3) == 1)            /* single-word */
+      l = (mps_addr_t)(p + 1);
+    else {                      /* multi-word */
+      assert((h & 3) == 2);
+      l = (mps_addr_t)p[1];
+    }
+
+    return l;
+  }
+
+  w = (mps_word_t *)h;          /* load the fixed wrapper */
+  assert(dylan_wrapper_check(w));
+  ++p;
+
+  p += w[WF] >> 2;               /* skip fixed part fields */
+
+  vh = w[WV];
+  vf = vh & 7;                  /* get variable part format */
+  if(vf != 7)
+  {
+    vt = *(mps_word_t *)p;
+    assert((vt & 3) == 1);      /* check Dylan integer tag */
+    vt = vt >> 2;               /* total length */
+    ++p;
+
+    p += vf & 1;                /* stretchy vectors have an extra word */
+
+    if((vf & 6) == 4)           /* non-word */
+    {
+      es = (unsigned)(vh & 0xff) >> 3;
+      vb = (unsigned)((vh >> 16) & 0xff);
+      vt += vb;
+      p += NONWORD_LENGTH(vt, es);
+    }
+    else
+      p += vt;
+  }
+
+  return (mps_addr_t)p;
+}
+
+static void dylan_copy(mps_addr_t old, mps_addr_t new)
+{
+  char *base = (char *)old;
+  char *limit = (char *)dylan_skip(old);
+  size_t length;
+  assert(base < limit);
+  length = (size_t)(limit - base);
+  assert(dylan_wrapper_check(*(mps_word_t **)old));
+  /* .improve.memcpy: Can do better here as we know that new and old
+     will be aligned (to MPS_PF_ALIGN) */
+  (void)memcpy(new, old, length);
+}
+
+static mps_addr_t dylan_isfwd(mps_addr_t object)
+{
+  mps_word_t h, tag;
+
+  h = *(mps_word_t *)object;
+  tag = h & 3;
+  if(tag != 0)
+    return (mps_addr_t)(h - tag);
+  else
+    return NULL;
+}
+
+static void dylan_fwd(mps_addr_t old, mps_addr_t new)
+{
+  mps_word_t *p;
+  mps_addr_t limit;
+
+  assert(dylan_isfwd(old) == NULL);
+  assert((*(mps_word_t *)old & 3) == 0); /* mustn't forward padding objects */
+  assert(((mps_word_t)new & 3) == 0);
+
+  p = (mps_word_t *)old;
+  limit = dylan_skip(old);
+  if(limit == &p[1])    /* single-word object? */
+    p[0] = (mps_word_t)new | 1;
+  else {
+    p[0] = (mps_word_t)new | 2;
+    p[1] = (mps_word_t)limit;
+  }
+}
+
+void dylan_pad(mps_addr_t addr, size_t size)
+{
+  mps_word_t *p;
+
+  p = (mps_word_t *)addr;
+  if(size == sizeof(mps_word_t))        /* single-word object? */
+    p[0] = 1;
+  else {
+    p[0] = 2;
+    p[1] = (mps_word_t)((char *)addr + size);
+  }
+}
+
+mps_bool_t dylan_ispad(mps_addr_t addr)
+{
+  mps_word_t *p;
+
+  p = (mps_word_t *)addr;
+  return p[0] == 1 || p[0] == 2;
+}
+
+
+/* The dylan format structures */
+
+static struct mps_fmt_A_s dylan_fmt_A_s =
+{
+  ALIGN,
+  dylan_scan,
+  dylan_skip,
+  dylan_copy,
+  dylan_fwd,
+  dylan_isfwd,
+  dylan_pad
+};
+
+static struct mps_fmt_B_s dylan_fmt_B_s =
+{
+  ALIGN,
+  dylan_scan,
+  dylan_skip,
+  dylan_copy,
+  dylan_fwd,
+  dylan_isfwd,
+  dylan_pad,
+  dylan_class
+};
+
+/* Functions returning the dylan format structures */
+
+mps_fmt_A_s *dylan_fmt_A(void)
+{
+  return &dylan_fmt_A_s;
+}
+
+mps_fmt_B_s *dylan_fmt_B(void)
+{
+  return &dylan_fmt_B_s;
+}
+
+/* Format variety-independent version that picks the right format
+ * variety and creates it.  */
+
+mps_res_t dylan_fmt(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
+{
+  return mps_fmt_create_B(mps_fmt_o, arena, dylan_fmt_B());
+}
+
+/* The weak format structures */
+
+static struct mps_fmt_A_s dylan_fmt_A_weak_s =
+{
+  ALIGN,
+  dylan_scan_weak,
+  dylan_skip,
+  no_copy,
+  no_fwd,
+  no_isfwd,
+  no_pad
+};
+
+static struct mps_fmt_B_s dylan_fmt_B_weak_s =
+{
+  ALIGN,
+  dylan_scan_weak,
+  dylan_skip,
+  no_copy,
+  no_fwd,
+  no_isfwd,
+  no_pad,
+  dylan_class
+};
+
+/* Functions returning the weak format structures */
+
+mps_fmt_A_s *dylan_fmt_A_weak(void)
+{
+  return &dylan_fmt_A_weak_s;
+}
+
+
+mps_fmt_B_s *dylan_fmt_B_weak(void)
+{
+  return &dylan_fmt_B_weak_s;
+}
+
+
+/* Format variety-independent version that picks the right format
+ * variety and creates it.  */
+
+mps_res_t dylan_fmt_weak(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
+{
+  return mps_fmt_create_B(mps_fmt_o, arena, dylan_fmt_B_weak());
+}
+
+
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtdy.h

@@ -0,0 +1,75 @@
+/* fmtdy.h: DYLAN OBJECT FORMAT
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+#ifndef fmtdy_h
+#define fmtdy_h
+
+#include "mps.h"
+
+/* Low-level routines, exposed here so that the with-header format
+ * can use common code. */
+extern mps_res_t dylan_scan1(mps_ss_t, mps_addr_t *);
+extern mps_res_t dylan_scan1_weak(mps_ss_t, mps_addr_t *);
+
+/* Format */
+extern mps_fmt_A_s *dylan_fmt_A(void);
+extern mps_fmt_A_s *dylan_fmt_A_weak(void);
+extern mps_fmt_B_s *dylan_fmt_B(void);
+extern mps_fmt_B_s *dylan_fmt_B_weak(void);
+extern mps_res_t dylan_fmt(mps_fmt_t *, mps_arena_t);
+extern mps_res_t dylan_fmt_weak(mps_fmt_t *, mps_arena_t);
+
+extern mps_addr_t dylan_weak_dependent(mps_addr_t);
+
+extern mps_addr_t dylan_skip(mps_addr_t);
+extern void dylan_pad(mps_addr_t, size_t);
+extern mps_bool_t dylan_ispad(mps_addr_t);
+extern int dylan_wrapper_check(mps_word_t *);
+
+/* Constants describing wrappers. Used only for debugging / testing */
+#define WW 0    /* offset of Wrapper-Wrapper */
+#define WC 1    /* offset of Class pointer*/
+#define WM 2    /* offset of subtype Mask */
+#define WF 3    /* offset of Fixed part descriptor */
+#define WV 4    /* offset of Vector part descriptor */
+#define WS 5    /* offset of Size field for pattern vector */
+#define WP 6    /* offset of Pattern 0, if present */
+
+#define BASIC_WRAPPER_SIZE (WS + 1) /* size of wrapper with no patterns */
+
+#define ALIGN sizeof(mps_word_t)    /* alignment for Dylan format */
+
+#endif /* fmtdy_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtdytst.c

@@ -0,0 +1,248 @@
+/* fmtdytst.c: DYLAN FORMAT TEST CODE
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .readership: MPS developers, Dylan developers.
+ */
+
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mps.h"
+#include "testlib.h"
+#include "mpslib.h"
+#include <assert.h>
+#include <string.h>
+#include <stdlib.h>
+
+#define unused(param)   ((void)param)
+
+
+static mps_word_t *ww = NULL;
+static mps_word_t *tvw;
+
+
+static mps_word_t dylan_make_WV(mps_word_t version, mps_word_t vb,
+                                mps_word_t es, mps_word_t vf)
+{
+  assert((version & ((1 << 8) - 1)) == version);
+  assert((vb & ((1 << 8) - 1)) == vb);
+  assert((es & ((1 << 5) - 1)) == es);
+  assert((vf & ((1 << 3) - 1)) == vf);
+
+  /* VERSION- ... VB------ reserved ES---VF- */
+  return((version << (MPS_WORD_WIDTH - 8)) |
+         (vb << 16) |
+         (es << 3) |
+         vf);
+}
+
+mps_res_t dylan_make_wrappers(void)
+{
+  if(ww == NULL) {
+    ww = malloc(sizeof(mps_word_t) * (BASIC_WRAPPER_SIZE + 1));
+    if(ww == NULL) return MPS_RES_MEMORY;
+    tvw = malloc(sizeof(mps_word_t) * BASIC_WRAPPER_SIZE);
+    if(tvw == NULL) {
+      free(ww);
+      return MPS_RES_MEMORY;
+    }
+
+    /* Build a wrapper wrapper. */
+    ww[WW] = (mps_word_t)ww;
+    ww[WC] = (mps_word_t)ww;     /* dummy class */
+    ww[WM] = (1 << 2) | 1;       /* dummy subtype_mask */
+    ww[WF] = ((WS - 1) << 2) | 2;
+    ww[WV] = dylan_make_WV(2, 0, 0, 0);
+    ww[WS] = (1 << 2) | 1;
+    ww[WP] = 1;
+
+    /* Build a wrapper for traceable vectors. */
+    tvw[WW] = (mps_word_t)ww;
+    tvw[WC] = (mps_word_t)ww;    /* dummy class */
+    tvw[WM] = (1 << 2) | 1;      /* dummy subtype_mask */
+    tvw[WF] = 0;                 /* no fixed part */
+    tvw[WV] = dylan_make_WV(2, 0, 0, 2); /* traceable variable part */
+    tvw[WS] = 1;                 /* no patterns */
+  }
+  return MPS_RES_OK;
+}
+
+/* dylan_init -- turn raw memory into initialised dylan-vector (or pad)
+ *
+ * If the raw memory is large enough, initialises it to a dylan-vector,
+ * whose slots are initialised to either dylan-ints, or valid refs, at
+ * random.
+ *
+ * Caller must supply an array of valid refs to copy, via the "refs"
+ * and "nr_refs" arguments. If "nr_refs" is 0, all slots are
+ * initialized to dylan-ints: this may be useful for making leaf
+ * objects.
+ *
+ * (Makes a pad if the raw memory is too small to hold a dylan-vector)
+ */
+
+mps_res_t dylan_init(mps_addr_t addr, size_t size,
+                     mps_addr_t *refs, size_t nr_refs)
+{
+  mps_res_t res;
+  /* Make sure the size is aligned. */
+  assert((size & (ALIGN-1)) == 0);
+
+  res = dylan_make_wrappers();
+  if (res != MPS_RES_OK)
+    return res;
+
+  /* If there is enough room, make a vector, otherwise just */
+  /* make a padding object. */
+  if(size >= sizeof(mps_word_t) * 2) {
+    mps_word_t *p = (mps_word_t *)addr;
+    mps_word_t i, t = (size / sizeof(mps_word_t)) - 2;
+
+    p[0] = (mps_word_t)tvw;     /* install vector wrapper */
+    p[1] = (t << 2) | 1;        /* tag the vector length */
+    for(i = 0; i < t; ++i) {
+      mps_word_t r = rnd();
+
+      if(nr_refs == 0 || (r & 1))
+        p[2+i] = ((r & ~(mps_word_t)3) | 1); /* random int */
+      else
+        p[2+i] = (mps_word_t)refs[(r >> 1) % nr_refs]; /* random ptr */
+    }
+  } else {
+    dylan_pad(addr, size);
+  }
+
+  return MPS_RES_OK;
+}
+
+mps_res_t make_dylan_vector(mps_word_t *v, mps_ap_t ap, size_t slots)
+{
+  mps_res_t res;
+  mps_addr_t addr;
+  mps_word_t *p;
+  size_t size;
+  size_t i;
+
+  res = dylan_make_wrappers();
+  if (res != MPS_RES_OK)
+    return res;
+
+  size = (slots + 2) * sizeof(mps_word_t);
+
+  do {
+    MPS_RESERVE_BLOCK(res, addr, ap, size);
+    if (res != MPS_RES_OK)
+      return res;
+
+    p = (mps_word_t *)addr;
+    p[0] = (mps_word_t)tvw;     /* install vector wrapper */
+    p[1] = (slots << 2) | 1;    /* tag the vector length */
+    /* fill all slots with zero ints. */
+    for (i=0; i<slots; ++i) {
+      DYLAN_VECTOR_SLOT(p, i) = DYLAN_INT(0);
+    }
+  } while (!mps_commit(ap, addr, size));
+
+  *v = (mps_word_t)p;
+  return MPS_RES_OK;
+}
+
+
+void dylan_write(mps_addr_t addr, mps_addr_t *refs, size_t nr_refs)
+{
+  mps_word_t *p = (mps_word_t *)addr;
+  mps_word_t t = p[1] >> 2;
+
+  /* If the object is a vector, update a random entry. */
+  if(p[0] == (mps_word_t)tvw && t > 0) {
+    mps_word_t r = rnd();
+    size_t i = 2 + (rnd() % t);
+
+    if(r & 1)
+      p[i] = ((r & ~(mps_word_t)3) | 1); /* random int */
+    else
+      p[i] = (mps_word_t)refs[(r >> 1) % nr_refs]; /* random ptr */
+  }
+}
+
+/*  Writes to a dylan object.
+    Currently just swaps two refs if it can.
+    This is only used in a certain way by certain tests, it doesn't have
+    to be very general. */
+void dylan_mutate(mps_addr_t addr)
+{
+  mps_word_t *p = (mps_word_t *)addr;
+
+  if(p[0] == (mps_word_t)tvw) {
+    mps_word_t t = p[1] >> 2;
+
+    if(t > 0) {
+      mps_word_t tmp;
+      size_t i, j;
+
+      i = 2 + (rnd() % t);
+      j = 2 + (rnd() % t);
+
+      tmp = p[i];
+      p[i] = p[j];
+      p[j] = tmp;
+    }
+  }
+  return;
+}
+
+mps_addr_t dylan_read(mps_addr_t addr)
+{
+  mps_word_t *p = (mps_word_t *)addr;
+
+  /* If the object is a vector, return a random entry. */
+  if(p[0] == (mps_word_t)tvw) {
+    mps_word_t t = p[1] >> 2;
+    if(t > 0)
+      return (mps_addr_t)p[2 + (rnd() % t)];
+  }
+
+  return addr;
+}
+
+mps_bool_t dylan_check(mps_addr_t addr)
+{
+  assert(addr != 0);
+  assert(((mps_word_t)addr & (ALIGN-1)) == 0);
+  assert(dylan_wrapper_check((mps_word_t *)((mps_word_t *)addr)[0]));
+  /* .assert.unused: Asserts throw away their conditions */
+  /* in hot varieties, so UNUSED is needed. */
+  unused(addr);
+  return 1;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtdytst.h

@@ -0,0 +1,70 @@
+/* fmtdytst.h: DYLAN OBJECT FORMAT TESTING
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+#ifndef fmtdytst_h
+#define fmtdytst_h
+
+#include "mps.h"
+#include "testlib.h"
+
+extern mps_res_t dylan_init(mps_addr_t addr, size_t size,
+                            mps_addr_t *refs, size_t nr_refs);
+extern void dylan_write(mps_addr_t addr,
+                        mps_addr_t *refs, size_t nr_refs);
+extern void dylan_mutate(mps_addr_t addr);
+extern mps_addr_t dylan_read(mps_addr_t addr);
+extern mps_bool_t dylan_check(mps_addr_t addr);
+extern void dylan_pad(mps_addr_t addr, size_t size);
+extern int dylan_wrapper_check(mps_word_t *w);
+extern mps_res_t dylan_make_wrappers(void);
+
+extern mps_res_t make_dylan_vector(mps_word_t *v, mps_ap_t ap, size_t slots);
+
+#define DYLAN_VECTOR_SLOT(o,n) (((mps_word_t *) (o))[(n)+2])
+
+#define DYLAN_INT(n) (((mps_word_t)(n) << 2) | 1)
+
+#define INT_DYI(n)  ( (n) <= DYLAN_UINT_MAX ? DYLAN_INT(n) : (mps_word_t)fail() )
+
+
+#define DYLAN_INT_INT(d)  ((mps_word_t)(d) >> 2)
+
+#define DYI_INT(d)  ( ((d) & 0x3) == 0x1 ? DYLAN_INT_INT(d) : (mps_word_t)fail() )
+
+#define DYLAN_UINT_MAX  ((mps_word_t)-1 >> 2)
+#define DYLAN_UINT_MASK  DYLAN_UINT_MAX
+
+#endif /* fmtdy_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmthe.c

@@ -0,0 +1,229 @@
+/* fmthe.c: DYLAN-LIKE OBJECT FORMAT WITH HEADERS
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (c) 2002 Global Graphics Software.
+ *
+ * Uses <code/fmtdy.c> for the actual Dylan format, and just adds
+ * a thin layer to handle the object headers themselves.
+ */
+
+#include "fmtdy.h"
+#include "fmtno.h"
+#include "fmthe.h"
+#include "mps.h"
+
+#include <string.h>
+#include <stdlib.h>
+
+#include "testlib.h"
+
+
+#define assert(cond) Insist(cond)
+#define notreached()    assert(0)
+
+#define AddHeader(p) ((mps_addr_t)((char*)(p) + headerSIZE))
+
+static mps_fmt_A_s *dylan_format;
+
+static mps_res_t dylan_header_scan(mps_ss_t mps_ss,
+                                   mps_addr_t base, mps_addr_t limit)
+{
+  mps_res_t res;
+  mps_addr_t p = base;
+
+  while(p < limit) {
+      mps_word_t header = (mps_word_t)*(int*)((char*)p - headerSIZE);
+      switch(headerType(header)) {
+      case realTYPE:
+          assert(header == realHeader);
+          break;
+      case padTYPE:
+          p = (mps_addr_t)((char*)p + headerPadSize(header));
+          continue;
+      default:
+          notreached();
+          break;
+      }
+      res = dylan_scan1(mps_ss, &p);
+      if(res) return res;
+      p = AddHeader(p);
+  }
+
+  assert(p <= AddHeader(limit));
+
+  return MPS_RES_OK;
+}
+
+
+static mps_res_t dylan_header_scan_weak(mps_ss_t mps_ss,
+                                        mps_addr_t base,
+                                        mps_addr_t limit)
+{
+  mps_res_t res;
+
+  while(base < limit) {
+      mps_word_t header;
+      header = (mps_word_t)*(int*)((char*)base - headerSIZE);
+      switch(headerType(header)) {
+      case realTYPE:
+          assert(header == realHeader);
+          break;
+      case padTYPE:
+          base = (mps_addr_t)((char*)base + headerPadSize(header));
+          continue;
+      default:
+          notreached();
+          break;
+      }
+
+      res = dylan_scan1_weak(mps_ss, &base);
+      if(res) return res;
+      base = AddHeader(base);
+  }
+
+  assert(base <= AddHeader(limit));
+
+  return MPS_RES_OK;
+}
+
+static mps_addr_t dylan_header_skip(mps_addr_t object)
+{
+  mps_addr_t *p;        /* cursor in object */
+  mps_word_t header;
+  header = (mps_word_t)*(int*)((char*)object - headerSIZE);
+  switch(headerType(header)) {
+  case realTYPE:
+      assert(header == realHeader);
+      break;
+  case padTYPE:
+      return (mps_addr_t)((char*)object + headerPadSize(header));
+  default:
+      notreached();
+      break;
+  }
+
+  p = dylan_format->skip(object);
+  p = AddHeader(p);
+  return p;
+}
+
+
+static mps_addr_t dylan_header_isfwd(mps_addr_t object)
+{
+  mps_word_t header;
+
+  header = (mps_word_t)*(int*)((char*)object - headerSIZE);
+  if (headerType(header) != realTYPE)
+    return NULL;
+
+  assert(header == realHeader);
+
+  return dylan_format->isfwd(object);
+}
+
+
+static void dylan_header_pad(mps_addr_t addr, size_t fullSize)
+{
+  *(int*)addr = (int)padHeader(fullSize);
+}
+
+
+/* HeaderFormat -- format descriptor for this format */
+
+static struct mps_fmt_auto_header_s HeaderFormat =
+{
+  ALIGN,
+  dylan_header_scan,
+  dylan_header_skip,
+  NULL, /* later overwritten by dylan format forward method */
+  dylan_header_isfwd,
+  dylan_header_pad,
+  (size_t)headerSIZE
+};
+
+
+/* HeaderWeakFormat -- format descriptor for this format */
+
+static struct mps_fmt_auto_header_s HeaderWeakFormat =
+{
+  ALIGN,
+  dylan_header_scan_weak,
+  dylan_header_skip,
+  no_fwd,
+  no_isfwd,
+  no_pad,
+  (size_t)headerSIZE
+};
+
+
+/* EnsureHeaderFormat -- create a format object for this format */
+
+mps_res_t EnsureHeaderFormat(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
+{
+    dylan_format = dylan_fmt_A();
+    HeaderFormat.fwd = dylan_format->fwd;
+    return mps_fmt_create_auto_header(mps_fmt_o, arena, &HeaderFormat);
+}
+
+
+/* EnsureHeaderWeakFormat -- create a format object for the weak format */
+
+mps_res_t EnsureHeaderWeakFormat(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
+{
+    dylan_format = dylan_fmt_A();
+    return mps_fmt_create_auto_header(mps_fmt_o, arena, &HeaderWeakFormat);
+}
+
+
+/* HeaderFormatCheck -- check an object in this format */
+
+mps_res_t HeaderFormatCheck(mps_addr_t addr)
+{
+    if (addr != 0 && ((mps_word_t)addr & (ALIGN-1)) == 0
+        && dylan_wrapper_check((mps_word_t *)((mps_word_t *)addr)[0]))
+        return MPS_RES_OK;
+    else
+        return MPS_RES_FAIL;
+}
+
+/* HeaderWeakFormatCheck -- check an object in this format */
+
+mps_res_t HeaderWeakFormatCheck(mps_addr_t addr)
+{
+    if (addr != 0 && ((mps_word_t)addr & (ALIGN-1)) == 0
+        && dylan_wrapper_check((mps_word_t *)((mps_word_t *)addr)[0]))
+        return MPS_RES_OK;
+    else
+        return MPS_RES_FAIL;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmthe.h

@@ -0,0 +1,58 @@
+/* fmthe.h: HEADERS FOR DYLAN-LIKE OBJECT FORMATS
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ */
+
+#ifndef fmthe_h
+#define fmthe_h
+
+#include "mps.h"
+
+/* Formats */
+extern mps_res_t EnsureHeaderFormat(mps_fmt_t *, mps_arena_t);
+extern mps_res_t EnsureHeaderWeakFormat(mps_fmt_t *, mps_arena_t);
+extern mps_res_t HeaderFormatCheck(mps_addr_t addr);
+extern mps_res_t HeaderWeakFormatCheck(mps_addr_t addr);
+
+#define headerSIZE (32)
+#define headerTypeBits 8
+#define realTYPE 0x33
+#define realHeader (realTYPE + 0x12345600)
+#define padTYPE  0xaa
+#define headerType(header) ((header) & (((mps_word_t)1 << headerTypeBits) - 1))
+#define headerPadSize(header) ((header) >> headerTypeBits)
+#define padHeader(size) ((size << headerTypeBits) | padTYPE)
+
+#endif /* fmthe_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtno.c

@@ -0,0 +1,149 @@
+/* fmtno.c: NULL OBJECT FORMAT IMPLEMENTATION
+ *
+ *  $Id$
+ *  Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .readership: MPS developers
+ */
+
+
+#include "fmtno.h"
+#include "mps.h"
+#include <assert.h>
+#include <string.h>
+#include <stdlib.h>
+
+
+#define notreached()    assert(0)
+#define unused(param)   ((void)param)
+
+
+#define ALIGN           sizeof(mps_word_t)
+
+/* Functions for the null format. */
+
+mps_res_t no_scan(mps_ss_t mps_ss,
+                  mps_addr_t base,
+                  mps_addr_t limit)
+{
+    unused(mps_ss); unused(base); unused(limit);
+    notreached();
+    return 0;
+}
+
+mps_addr_t no_skip(mps_addr_t object)
+{
+    unused(object);
+    notreached();
+    return 0;
+}
+
+void no_copy(mps_addr_t old,
+             mps_addr_t new)
+{
+    unused(old); unused(new);
+    notreached();
+}
+
+void no_fwd(mps_addr_t old,
+            mps_addr_t new)
+{
+    unused(old); unused(new);
+    notreached();
+}
+
+mps_addr_t no_isfwd(mps_addr_t object)
+{
+    unused(object);
+    notreached();
+    return 0;
+}
+
+void no_pad(mps_addr_t addr,
+            size_t size)
+{
+    unused(addr); unused(size);
+    notreached();
+}
+
+mps_addr_t no_class(mps_addr_t obj)
+{
+    unused(obj);
+    notreached();
+    return 0;
+}
+
+/* The null format structures */
+
+static struct mps_fmt_A_s no_fmt_A_s =
+{
+    ALIGN,
+    no_scan,
+    no_skip,
+    no_copy,
+    no_fwd,
+    no_isfwd,
+    no_pad
+};
+
+static struct mps_fmt_B_s no_fmt_B_s =
+{
+    ALIGN,
+    no_scan,
+    no_skip,
+    no_copy,
+    no_fwd,
+    no_isfwd,
+    no_pad,
+    no_class
+};
+
+/* Functions returning the null format structures. */
+
+mps_fmt_A_s *no_fmt_A(void)
+{
+    return &no_fmt_A_s;
+}
+
+mps_fmt_B_s *no_fmt_B(void)
+{
+    return &no_fmt_B_s;
+}
+
+/* Format variety-independent version that picks the right format
+ * variety and creates it.  */
+
+mps_res_t no_fmt(mps_fmt_t *mps_fmt_o, mps_arena_t arena)
+{
+    return mps_fmt_create_B(mps_fmt_o, arena, no_fmt_B());
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtno.h

@@ -0,0 +1,54 @@
+/* fmtdy.h: NULL OBJECT FORMAT
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+#ifndef fmtno_h
+#define fmtno_h
+
+#include "mps.h"
+
+extern mps_res_t no_scan(mps_ss_t, mps_addr_t, mps_addr_t);
+extern mps_addr_t no_skip(mps_addr_t);
+extern void no_copy(mps_addr_t, mps_addr_t);
+extern void no_fwd(mps_addr_t, mps_addr_t);
+extern mps_addr_t no_isfwd(mps_addr_t);
+extern void no_pad(mps_addr_t, size_t);
+extern mps_addr_t no_class(mps_addr_t);
+
+extern mps_fmt_A_s *no_fmt_A(void);
+extern mps_fmt_B_s *no_fmt_B(void);
+extern mps_res_t no_fmt(mps_fmt_t *, mps_arena_t);
+
+#endif /* fmtno_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtscheme.c

@@ -0,0 +1,488 @@
+/* fmtscheme.c: SCHEME OBJECT FORMAT IMPLEMENTATION
+ *
+ *  $Id$
+ *  Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+#include <string.h>
+
+#include "fmtscheme.h"
+#include "testlib.h"
+
+
+/* special objects */
+
+static obj_t obj_true;          /* #t, boolean true */
+static obj_t obj_false;         /* #f, boolean false */
+
+
+/* MPS globals */
+
+mps_arena_t scheme_arena; /* the arena */
+mps_pool_t obj_pool;     /* pool for ordinary Scheme objects */
+mps_ap_t obj_ap;         /* allocation point used to allocate objects */
+
+
+/* make_* -- object constructors */
+
+#define ALIGNMENT sizeof(mps_word_t)
+
+/* Align size upwards to the next multiple of the word size. */
+#define ALIGN_WORD(size) \
+  (((size) + ALIGNMENT - 1) & ~(ALIGNMENT - 1))
+
+/* Align size upwards to the next multiple of the word size, and
+ * additionally ensure that it's big enough to store a forwarding
+ * pointer. Evaluates its argument twice. */
+#define ALIGN_OBJ(size)                                \
+  (ALIGN_WORD(size) >= ALIGN_WORD(sizeof(fwd_s))       \
+   ? ALIGN_WORD(size)                                  \
+   : ALIGN_WORD(sizeof(fwd_s)))
+
+obj_t scheme_make_bool(int condition)
+{
+  return condition ? obj_true : obj_false;
+}
+
+obj_t scheme_make_pair(mps_ap_t ap, obj_t car, obj_t cdr)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(sizeof(pair_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_pair");
+    obj = addr;
+    obj->pair.type = TYPE_PAIR;
+    CAR(obj) = car;
+    CDR(obj) = cdr;
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_integer(mps_ap_t ap, long integer)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(sizeof(integer_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_integer");
+    obj = addr;
+    obj->integer.type = TYPE_INTEGER;
+    obj->integer.integer = integer;
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_symbol(mps_ap_t ap, size_t length, char string[])
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(offsetof(symbol_s, string) + length+1);
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_symbol");
+    obj = addr;
+    obj->symbol.type = TYPE_SYMBOL;
+    obj->symbol.length = length;
+    memcpy(obj->symbol.string, string, length+1);
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_string(mps_ap_t ap, size_t length, char string[])
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(offsetof(string_s, string) + length+1);
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_string");
+    obj = addr;
+    obj->string.type = TYPE_STRING;
+    obj->string.length = length;
+    if (string) memcpy(obj->string.string, string, length+1);
+    else memset(obj->string.string, 0, length+1);
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_special(mps_ap_t ap, char *string)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(sizeof(special_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_special");
+    obj = addr;
+    obj->special.type = TYPE_SPECIAL;
+    obj->special.name = string;
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_operator(mps_ap_t ap, char *name,
+                           entry_t entry, obj_t arguments,
+                           obj_t body, obj_t env, obj_t op_env)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(sizeof(operator_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_operator");
+    obj = addr;
+    obj->operator.type = TYPE_OPERATOR;
+    obj->operator.name = name;
+    obj->operator.entry = entry;
+    obj->operator.arguments = arguments;
+    obj->operator.body = body;
+    obj->operator.env = env;
+    obj->operator.op_env = op_env;
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_port(mps_ap_t ap, obj_t name, FILE *stream)
+{
+  mps_addr_t port_ref;
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(sizeof(port_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_port");
+    obj = addr;
+    obj->port.type = TYPE_PORT;
+    obj->port.name = name;
+    obj->port.stream = stream;
+  } while(!mps_commit(ap, addr, size));
+  port_ref = obj;
+  mps_finalize(scheme_arena, &port_ref);
+  return obj;
+}
+
+obj_t scheme_make_character(mps_ap_t ap, char c)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(sizeof(character_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_character");
+    obj = addr;
+    obj->character.type = TYPE_CHARACTER;
+    obj->character.c = c;
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_vector(mps_ap_t ap, size_t length, obj_t fill)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(offsetof(vector_s, vector) + length * sizeof(obj_t));
+  do {
+    size_t i;
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_vector");
+    obj = addr;
+    obj->vector.type = TYPE_VECTOR;
+    obj->vector.length = length;
+    for(i = 0; i < length; ++i)
+      obj->vector.vector[i] = fill;
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_buckets(mps_ap_t ap, size_t length)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t size = ALIGN_OBJ(offsetof(buckets_s, bucket) + length * sizeof(obj->buckets.bucket[0]));
+  do {
+    size_t i;
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_buckets");
+    obj = addr;
+    obj->buckets.type = TYPE_BUCKETS;
+    obj->buckets.length = length;
+    obj->buckets.used = 0;
+    obj->buckets.deleted = 0;
+    for(i = 0; i < length; ++i) {
+      obj->buckets.bucket[i].key = NULL;
+      obj->buckets.bucket[i].value = NULL;
+    }
+  } while(!mps_commit(ap, addr, size));
+  return obj;
+}
+
+obj_t scheme_make_table(mps_ap_t ap, size_t length, hash_t hashf, cmp_t cmpf)
+{
+  obj_t obj;
+  mps_addr_t addr;
+  size_t l, size = ALIGN_OBJ(sizeof(table_s));
+  do {
+    mps_res_t res = mps_reserve(&addr, ap, size);
+    if (res != MPS_RES_OK) error("out of memory in make_table");
+    obj = addr;
+    obj->table.type = TYPE_TABLE;
+    obj->table.buckets = NULL;
+  } while(!mps_commit(ap, addr, size));
+  obj->table.hash = hashf;
+  obj->table.cmp = cmpf;
+  /* round up to next power of 2 */
+  for(l = 1; l < length; l *= 2);
+  obj->table.buckets = scheme_make_buckets(ap, l);
+  mps_ld_reset(&obj->table.ld, scheme_arena);
+  return obj;
+}
+
+
+/* MPS Format */
+
+static mps_res_t obj_scan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit)
+{
+#define FIX(ref) \
+  do { \
+    mps_addr_t _addr = (ref); /* copy to local to avoid type pun */ \
+    mps_res_t res = MPS_FIX12(ss, &_addr); \
+    if (res != MPS_RES_OK) return res; \
+    (ref) = _addr; \
+  } while(0)
+
+  MPS_SCAN_BEGIN(ss) {
+    while (base < limit) {
+      obj_t obj = base;
+      switch (TYPE(obj)) {
+      case TYPE_PAIR:
+      case TYPE_PROMISE:
+        FIX(CAR(obj));
+        FIX(CDR(obj));
+        base = (char *)base + ALIGN_OBJ(sizeof(pair_s));
+        break;
+      case TYPE_INTEGER:
+        base = (char *)base + ALIGN_OBJ(sizeof(integer_s));
+        break;
+      case TYPE_SYMBOL:
+        base = (char *)base +
+               ALIGN_OBJ(offsetof(symbol_s, string) + obj->symbol.length + 1);
+        break;
+      case TYPE_SPECIAL:
+        base = (char *)base + ALIGN_OBJ(sizeof(special_s));
+        break;
+      case TYPE_OPERATOR:
+        FIX(obj->operator.arguments);
+        FIX(obj->operator.body);
+        FIX(obj->operator.env);
+        FIX(obj->operator.op_env);
+        base = (char *)base + ALIGN_OBJ(sizeof(operator_s));
+        break;
+      case TYPE_STRING:
+        base = (char *)base +
+               ALIGN_OBJ(offsetof(string_s, string) + obj->string.length + 1);
+        break;
+      case TYPE_PORT:
+        FIX(obj->port.name);
+        base = (char *)base + ALIGN_OBJ(sizeof(port_s));
+        break;
+      case TYPE_CHARACTER:
+        base = (char *)base + ALIGN_OBJ(sizeof(character_s));
+        break;
+      case TYPE_VECTOR:
+        {
+          size_t i;
+          for (i = 0; i < obj->vector.length; ++i)
+            FIX(obj->vector.vector[i]);
+        }
+        base = (char *)base +
+          ALIGN_OBJ(offsetof(vector_s, vector) +
+                    obj->vector.length * sizeof(obj->vector.vector[0]));
+        break;
+      case TYPE_BUCKETS:
+        {
+          size_t i;
+          for (i = 0; i < obj->buckets.length; ++i) {
+            FIX(obj->buckets.bucket[i].key);
+            FIX(obj->buckets.bucket[i].value);
+          }
+        }
+        base = (char *)base +
+          ALIGN_OBJ(offsetof(buckets_s, bucket) +
+                    obj->buckets.length * sizeof(obj->buckets.bucket[0]));
+        break;
+      case TYPE_TABLE:
+        FIX(obj->table.buckets);
+        base = (char *)base + ALIGN_OBJ(sizeof(table_s));
+        break;
+      case TYPE_FWD2:
+        base = (char *)base + ALIGN_WORD(sizeof(fwd2_s));
+        break;
+      case TYPE_FWD:
+        base = (char *)base + ALIGN_WORD(obj->fwd.size);
+        break;
+      case TYPE_PAD1:
+        base = (char *)base + ALIGN_WORD(sizeof(pad1_s));
+        break;
+      case TYPE_PAD:
+        base = (char *)base + ALIGN_WORD(obj->pad.size);
+        break;
+      default:
+        error("Unexpected object on the heap\n");
+        return MPS_RES_FAIL;
+      }
+    }
+  } MPS_SCAN_END(ss);
+  return MPS_RES_OK;
+}
+
+static mps_addr_t obj_skip(mps_addr_t base)
+{
+  obj_t obj = base;
+  switch (TYPE(obj)) {
+  case TYPE_PAIR:
+  case TYPE_PROMISE:
+    base = (char *)base + ALIGN_OBJ(sizeof(pair_s));
+    break;
+  case TYPE_INTEGER:
+    base = (char *)base + ALIGN_OBJ(sizeof(integer_s));
+    break;
+  case TYPE_SYMBOL:
+    base = (char *)base +
+      ALIGN_OBJ(offsetof(symbol_s, string) + obj->symbol.length + 1);
+    break;
+  case TYPE_SPECIAL:
+    base = (char *)base + ALIGN_OBJ(sizeof(special_s));
+    break;
+  case TYPE_OPERATOR:
+    base = (char *)base + ALIGN_OBJ(sizeof(operator_s));
+    break;
+  case TYPE_STRING:
+    base = (char *)base +
+      ALIGN_OBJ(offsetof(string_s, string) + obj->string.length + 1);
+    break;
+  case TYPE_PORT:
+    base = (char *)base + ALIGN_OBJ(sizeof(port_s));
+    break;
+  case TYPE_CHARACTER:
+    base = (char *)base + ALIGN_OBJ(sizeof(character_s));
+    break;
+  case TYPE_VECTOR:
+    base = (char *)base +
+      ALIGN_OBJ(offsetof(vector_s, vector) +
+                obj->vector.length * sizeof(obj->vector.vector[0]));
+    break;
+  case TYPE_BUCKETS:
+    base = (char *)base +
+      ALIGN_OBJ(offsetof(buckets_s, bucket) +
+                obj->buckets.length * sizeof(obj->buckets.bucket[0]));
+    break;
+  case TYPE_TABLE:
+    base = (char *)base + ALIGN_OBJ(sizeof(table_s));
+    break;
+  case TYPE_FWD2:
+    base = (char *)base + ALIGN_WORD(sizeof(fwd2_s));
+    break;
+  case TYPE_FWD:
+    base = (char *)base + ALIGN_WORD(obj->fwd.size);
+    break;
+  case TYPE_PAD:
+    base = (char *)base + ALIGN_WORD(obj->pad.size);
+    break;
+  case TYPE_PAD1:
+    base = (char *)base + ALIGN_WORD(sizeof(pad1_s));
+    break;
+  default:
+    error("Unexpected object on the heap\n");
+    return NULL;
+  }
+  return base;
+}
+
+static mps_addr_t obj_isfwd(mps_addr_t addr)
+{
+  obj_t obj = addr;
+  switch (TYPE(obj)) {
+  case TYPE_FWD2:
+    return obj->fwd2.fwd;
+  case TYPE_FWD:
+    return obj->fwd.fwd;
+  default:
+    return NULL;
+  }
+}
+
+static void obj_fwd(mps_addr_t old, mps_addr_t new)
+{
+  obj_t obj = old;
+  mps_addr_t limit = obj_skip(old);
+  size_t size = (size_t)((char *)limit - (char *)old);
+  cdie(size >= ALIGN_WORD(sizeof(fwd2_s)), "bad size in obj_fwd");
+  if (size == ALIGN_WORD(sizeof(fwd2_s))) {
+    TYPE(obj) = TYPE_FWD2;
+    obj->fwd2.fwd = new;
+  } else {
+    TYPE(obj) = TYPE_FWD;
+    obj->fwd.fwd = new;
+    obj->fwd.size = size;
+  }
+}
+
+static void obj_pad(mps_addr_t addr, size_t size)
+{
+  obj_t obj = addr;
+  cdie(size >= ALIGN_WORD(sizeof(pad1_s)), "bad size in obj_pad");
+  if (size == ALIGN_WORD(sizeof(pad1_s))) {
+    TYPE(obj) = TYPE_PAD1;
+  } else {
+    TYPE(obj) = TYPE_PAD;
+    obj->pad.size = size;
+  }
+}
+
+void scheme_fmt(mps_fmt_t *fmt)
+{
+  mps_res_t res;
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_ALIGN, ALIGNMENT);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_SCAN, obj_scan);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_SKIP, obj_skip);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_FWD, obj_fwd);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_ISFWD, obj_isfwd);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_PAD, obj_pad);
+    res = mps_fmt_create_k(fmt, scheme_arena, args);
+  } MPS_ARGS_END(args);
+  if (res != MPS_RES_OK) error("Couldn't create obj format");
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fmtscheme.h

@@ -0,0 +1,221 @@
+/* fmtscheme.h: SCHEME OBJECT FORMAT INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ */
+
+#ifndef fmtscheme_h
+#define fmtscheme_h
+
+#include <stdio.h>
+#include "mps.h"
+
+typedef union obj_u *obj_t;
+typedef obj_t (*entry_t)(obj_t env, obj_t op_env, obj_t operator, obj_t rands);
+typedef unsigned long (*hash_t)(obj_t obj, mps_ld_t ld);
+typedef int (*cmp_t)(obj_t obj1, obj_t obj2);
+
+typedef int type_t;
+enum {
+  TYPE_PAIR,
+  TYPE_INTEGER,
+  TYPE_SYMBOL,
+  TYPE_SPECIAL,
+  TYPE_OPERATOR,
+  TYPE_STRING,
+  TYPE_PORT,
+  TYPE_PROMISE,
+  TYPE_CHARACTER,
+  TYPE_VECTOR,
+  TYPE_TABLE,
+  TYPE_BUCKETS,
+  TYPE_FWD2,            /* two-word forwarding object */
+  TYPE_FWD,             /* three words and up forwarding object */
+  TYPE_PAD1,            /* one-word padding object */
+  TYPE_PAD              /* two words and up padding object */
+};
+
+typedef struct type_s {
+  type_t type;
+} type_s;
+
+typedef struct pair_s {
+  type_t type;                  /* TYPE_PAIR */
+  obj_t car, cdr;               /* first and second projections */
+} pair_s;
+
+typedef struct symbol_s {
+  type_t type;                  /* TYPE_SYMBOL */
+  size_t length;                /* length of symbol string (excl. NUL) */
+  char string[1];               /* symbol string, NUL terminated */
+} symbol_s;
+
+typedef struct integer_s {
+  type_t type;                  /* TYPE_INTEGER */
+  long integer;                 /* the integer */
+} integer_s;
+
+typedef struct special_s {
+  type_t type;                  /* TYPE_SPECIAL */
+  char *name;                   /* printed representation, NUL terminated */
+} special_s;
+
+typedef struct operator_s {
+  type_t type;                  /* TYPE_OPERATOR */
+  char *name;                   /* printed name, NUL terminated */
+  entry_t entry;                /* entry point -- see eval() */
+  obj_t arguments, body;        /* function arguments and code */
+  obj_t env, op_env;            /* closure environments */
+} operator_s;
+
+typedef struct string_s {
+  type_t type;                  /* TYPE_STRING */
+  size_t length;                /* number of chars in string */
+  char string[1];               /* string, NUL terminated */
+} string_s;
+
+typedef struct port_s {
+  type_t type;                  /* TYPE_PORT */
+  obj_t name;                   /* name of stream */
+  FILE *stream;
+} port_s;
+
+typedef struct character_s {
+  type_t type;                  /* TYPE_CHARACTER */
+  char c;                       /* the character */
+} character_s;
+
+typedef struct vector_s {
+  type_t type;                  /* TYPE_VECTOR */
+  size_t length;                /* number of elements */
+  obj_t vector[1];              /* vector elements */
+} vector_s;
+
+typedef struct table_s {
+  type_t type;                  /* TYPE_TABLE */
+  hash_t hash;                  /* hash function */
+  cmp_t cmp;                    /* comparison function */
+  mps_ld_s ld;                  /* location dependency */
+  obj_t buckets;                /* hash buckets */
+} table_s;
+
+typedef struct buckets_s {
+  type_t type;                  /* TYPE_BUCKETS */
+  size_t length;                /* number of buckets */
+  size_t used;                  /* number of buckets in use */
+  size_t deleted;               /* number of deleted buckets */
+  struct bucket_s {
+    obj_t key, value;
+  } bucket[1];                  /* hash buckets */
+} buckets_s;
+
+
+/* fwd2, fwd, pad1, pad -- MPS forwarding and padding objects */
+
+typedef struct fwd2_s {
+  type_t type;                  /* TYPE_FWD2 */
+  obj_t fwd;                    /* forwarded object */
+} fwd2_s;
+
+typedef struct fwd_s {
+  type_t type;                  /* TYPE_FWD */
+  obj_t fwd;                    /* forwarded object */
+  size_t size;                  /* total size of this object */
+} fwd_s;
+
+typedef struct pad1_s {
+  type_t type;                  /* TYPE_PAD1 */
+} pad1_s;
+
+typedef struct pad_s {
+  type_t type;                  /* TYPE_PAD */
+  size_t size;                  /* total size of this object */
+} pad_s;
+
+
+typedef union obj_u {
+  type_s type;                  /* one of TYPE_* */
+  pair_s pair;
+  symbol_s symbol;
+  integer_s integer;
+  special_s special;
+  operator_s operator;
+  string_s string;
+  port_s port;
+  character_s character;
+  vector_s vector;
+  table_s table;
+  buckets_s buckets;
+  fwd2_s fwd2;
+  fwd_s fwd;
+  pad_s pad;
+} obj_s;
+
+
+/* structure macros */
+
+#define TYPE(obj)       ((obj)->type.type)
+#define CAR(obj)        ((obj)->pair.car)
+#define CDR(obj)        ((obj)->pair.cdr)
+#define CAAR(obj)       CAR(CAR(obj))
+#define CADR(obj)       CAR(CDR(obj))
+#define CDAR(obj)       CDR(CAR(obj))
+#define CDDR(obj)       CDR(CDR(obj))
+#define CADDR(obj)      CAR(CDDR(obj))
+#define CDDDR(obj)      CDR(CDDR(obj))
+#define CDDAR(obj)      CDR(CDAR(obj))
+#define CADAR(obj)      CAR(CDAR(obj))
+
+
+extern obj_t scheme_make_bool(int condition);
+extern obj_t scheme_make_pair(mps_ap_t ap, obj_t car, obj_t cdr);
+extern obj_t scheme_make_integer(mps_ap_t ap, long integer);
+extern obj_t scheme_make_symbol(mps_ap_t ap, size_t length, char string[]);
+extern obj_t scheme_make_string(mps_ap_t ap, size_t length, char string[]);
+extern obj_t scheme_make_special(mps_ap_t ap, char *string);
+extern obj_t scheme_make_operator(mps_ap_t ap, char *name, entry_t entry,
+                                  obj_t arguments, obj_t body, obj_t env,
+                                  obj_t op_env);
+extern obj_t scheme_make_port(mps_ap_t ap, obj_t name, FILE *stream);
+extern obj_t scheme_make_character(mps_ap_t ap, char c);
+extern obj_t scheme_make_vector(mps_ap_t ap, size_t length, obj_t fill);
+extern obj_t scheme_make_buckets(mps_ap_t ap, size_t length);
+extern obj_t scheme_make_table(mps_ap_t ap, size_t length, hash_t hashf,
+                               cmp_t cmpf);
+extern void scheme_fmt(mps_fmt_t *fmt);
+
+extern mps_arena_t scheme_arena;
+extern mps_pool_t obj_pool;
+extern mps_ap_t obj_ap;
+
+#endif /* fmtscheme_h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/forktest.c

@@ -0,0 +1,219 @@
+/* forktest.c: FORK SAFETY TEST
+ *
+ * $Id: //info.ravenbrook.com/project/mps/branch/2018-06-13/fork/code/tagtest.c#1 $
+ * Copyright (c) 2018-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .overview: This test case is a regression test for job004062. It
+ * checks that the MPS correctly runs in the child process after a
+ * fork() on FreeBSD, Linux or macOS.
+ *
+ * .format: This test case uses a trivial object format in which each
+ * object contains a single reference.
+ */
+
+#include <stdio.h>
+#include <sys/wait.h>
+#include <unistd.h>
+
+#include "mps.h"
+#include "mpsavm.h"
+#include "mpscamc.h"
+#include "testlib.h"
+
+enum {
+  TYPE_REF,
+  TYPE_FWD,
+  TYPE_PAD
+};
+
+typedef struct obj_s {
+  unsigned type;                /* One of the TYPE_ enums */
+  union {
+    struct obj_s *ref;          /* TYPE_REF */
+    mps_addr_t fwd;             /* TYPE_FWD */
+    size_t pad;                 /* TYPE_PAD */
+  } u;
+} obj_s, *obj_t;
+
+static void obj_fwd(mps_addr_t old, mps_addr_t new)
+{
+  obj_t obj = old;
+  obj->type = TYPE_FWD;
+  obj->u.fwd = new;
+}
+
+static mps_addr_t obj_isfwd(mps_addr_t addr)
+{
+  obj_t obj = addr;
+  if (obj->type == TYPE_FWD) {
+    return obj->u.fwd;
+  } else {
+    return NULL;
+  }
+}
+
+static void obj_pad(mps_addr_t addr, size_t size)
+{
+  obj_t obj = addr;
+  obj->type = TYPE_PAD;
+  obj->u.pad = size;
+}
+
+static mps_addr_t obj_skip(mps_addr_t addr)
+{
+  obj_t obj = addr;
+  size_t size;
+  if (obj->type == TYPE_PAD) {
+    size = obj->u.pad;
+  } else {
+    size = sizeof(obj_s);
+  }
+  return (char *)addr + size;
+}
+
+static mps_res_t obj_scan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit)
+{
+  MPS_SCAN_BEGIN(ss) {
+    while (base < limit) {
+      obj_t obj = base;
+      if (obj->type == TYPE_REF) {
+        mps_addr_t p = obj->u.ref;
+        mps_res_t res = MPS_FIX12(ss, &p);
+        if (res != MPS_RES_OK) {
+          return res;
+        }
+        obj->u.ref = p;
+      }
+      base = obj_skip(base);
+    }
+  } MPS_SCAN_END(ss);
+  return MPS_RES_OK;
+}
+
+int main(int argc, char *argv[])
+{
+  void *marker = &marker;
+  int pid;
+  mps_arena_t arena;
+  mps_fmt_t obj_fmt;
+  mps_pool_t pool;
+  mps_thr_t thread;
+  mps_root_t stack_root;
+  mps_ap_t obj_ap;
+  size_t i;
+  obj_t obj, first;
+
+  testlib_init(argc, argv);
+
+  /* Set the pause time to be very small so that the incremental
+     collector (when it runs) will have to leave a read barrier in
+     place for us to hit. */
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_PAUSE_TIME, 0.0);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args),
+        "mps_arena_create");
+  } MPS_ARGS_END(args);
+  mps_arena_park(arena);
+
+  die(mps_thread_reg(&thread, arena), "Couldn't register thread");
+  die(mps_root_create_thread(&stack_root, arena, thread, marker),
+      "Couldn't create thread root");
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_ALIGN, sizeof(obj_s));
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_SCAN, obj_scan);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_SKIP, obj_skip);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_FWD, obj_fwd);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_ISFWD, obj_isfwd);
+    MPS_ARGS_ADD(args, MPS_KEY_FMT_PAD, obj_pad);
+    die(mps_fmt_create_k(&obj_fmt, arena, args), "Couldn't create obj format");
+  } MPS_ARGS_END(args);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, obj_fmt);
+    die(mps_pool_create_k(&pool, arena, mps_class_amc(), args),
+        "Couldn't create pool");
+  } MPS_ARGS_END(args);
+
+  die(mps_ap_create_k(&obj_ap, pool, mps_args_none),
+      "Couldn't create obj allocation point");
+
+  /* Create a linked list of objects. */
+  first = NULL;
+  for (i = 0; i < 100000; ++i) {
+    size_t size = sizeof(obj_s);
+    mps_addr_t addr;
+    do {
+      die(mps_reserve(&addr, obj_ap, size), "Couldn't allocate.");
+      obj = addr;
+      obj->type = TYPE_REF;
+      obj->u.ref = NULL;
+    } while (!mps_commit(obj_ap, addr, size));
+    obj->u.ref = first;
+    first = obj;
+  }
+
+  pid = fork();
+  cdie(pid >= 0, "fork failed");
+
+  /* Allow a collection to start, which will cause a read barrier to
+     be applied to any segment containing live objects that was
+     scanned. */
+  mps_arena_release(arena);
+
+  /* Read all the objects, so that if there is read barrier in place
+     we will hit it. */
+  for (obj = first; obj != NULL; obj = obj->u.ref) {
+    Insist(obj->type == TYPE_REF);
+  }
+
+  mps_arena_park(arena);
+
+  if (pid != 0) {
+    /* Parent: wait for child and check that its exit status is zero. */
+    int stat;
+    cdie(pid == waitpid(pid, &stat, 0), "waitpid failed");
+    cdie(WIFEXITED(stat), "child did not exit normally");
+    cdie(WEXITSTATUS(stat) == 0, "child exited with nonzero status");
+    printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  }
+
+  mps_ap_destroy(obj_ap);
+  mps_pool_destroy(pool);
+  mps_fmt_destroy(obj_fmt);
+  mps_root_destroy(stack_root);
+  mps_thread_dereg(thread);
+  mps_arena_destroy(arena);
+
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2018-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/format.c

@@ -0,0 +1,247 @@
+/* format.c: OBJECT FORMATS
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (c) 2002 Global Graphics Software.
+ *
+ * DESIGN
+ *
+ * See protocol.mps.format.
+ */
+
+#include "mpm.h"
+
+SRCID(format, "$Id$");
+
+
+/* FormatCheck -- check a format */
+
+Bool FormatCheck(Format format)
+{
+  CHECKS(Format, format);
+  CHECKU(Arena, format->arena);
+  CHECKL(format->serial < format->arena->formatSerial);
+  CHECKD_NOSIG(Ring, &format->arenaRing);
+  CHECKL(AlignCheck(format->alignment));
+  /* TODO: Define the concept of the maximum alignment it is possible to
+     request from the MPS, document and provide an interface to it, and then
+     check that this alignment is not greater than that, as well as all other
+     alignments. */
+  CHECKL(FUNCHECK(format->scan));
+  CHECKL(FUNCHECK(format->skip));
+  CHECKL(FUNCHECK(format->move));
+  CHECKL(FUNCHECK(format->isMoved));
+  CHECKL(FUNCHECK(format->pad));
+  CHECKL(FUNCHECK(format->klass));
+
+  return TRUE;
+}
+
+
+/* FormatNo methods -- default values for format keyword arguments */
+
+mps_res_t FormatNoScan(mps_ss_t mps_ss, mps_addr_t base, mps_addr_t limit)
+{
+    UNUSED(mps_ss);
+    UNUSED(base);
+    UNUSED(limit);
+    NOTREACHED;
+    return ResFAIL;
+}
+
+static mps_addr_t FormatNoSkip(mps_addr_t object)
+{
+    UNUSED(object);
+    NOTREACHED;
+    return NULL;
+}
+
+static void FormatNoMove(mps_addr_t old, mps_addr_t new)
+{
+    UNUSED(old);
+    UNUSED(new);
+    NOTREACHED;
+}
+
+static mps_addr_t FormatNoIsMoved(mps_addr_t object)
+{
+    UNUSED(object);
+    NOTREACHED;
+    return NULL;
+}
+
+static void FormatNoPad(mps_addr_t addr, size_t size)
+{
+    UNUSED(addr);
+    UNUSED(size);
+    NOTREACHED;
+}
+
+static mps_addr_t FormatDefaultClass(mps_addr_t object)
+{
+  AVER(object != NULL);
+
+  return ((mps_addr_t *)object)[0];
+}
+
+
+/* FormatCreate -- create a format */
+
+ARG_DEFINE_KEY(FMT_ALIGN, Align);
+ARG_DEFINE_KEY(FMT_SCAN, Fun);
+ARG_DEFINE_KEY(FMT_SKIP, Fun);
+ARG_DEFINE_KEY(FMT_FWD, Fun);
+ARG_DEFINE_KEY(FMT_ISFWD, Fun);
+ARG_DEFINE_KEY(FMT_PAD, Fun);
+ARG_DEFINE_KEY(FMT_HEADER_SIZE, Size);
+ARG_DEFINE_KEY(FMT_CLASS, Fun);
+
+Res FormatCreate(Format *formatReturn, Arena arena, ArgList args)
+{
+  ArgStruct arg;
+  Format format;
+  Res res;
+  void *p;
+  Align fmtAlign = FMT_ALIGN_DEFAULT;
+  Size fmtHeaderSize = FMT_HEADER_SIZE_DEFAULT;
+  mps_fmt_scan_t fmtScan = FMT_SCAN_DEFAULT;
+  mps_fmt_skip_t fmtSkip = FMT_SKIP_DEFAULT;
+  mps_fmt_fwd_t fmtFwd = FMT_FWD_DEFAULT;
+  mps_fmt_isfwd_t fmtIsfwd = FMT_ISFWD_DEFAULT;
+  mps_fmt_pad_t fmtPad = FMT_PAD_DEFAULT;
+  mps_fmt_class_t fmtClass = FMT_CLASS_DEFAULT;
+
+  AVER(formatReturn != NULL);
+  AVERT(Arena, arena);
+  AVERT(ArgList, args);
+
+  if (ArgPick(&arg, args, MPS_KEY_FMT_ALIGN))
+    fmtAlign = arg.val.align;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_HEADER_SIZE))
+    fmtHeaderSize = arg.val.size;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_SCAN))
+    fmtScan = arg.val.fmt_scan;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_SKIP))
+    fmtSkip = arg.val.fmt_skip;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_FWD))
+    fmtFwd = arg.val.fmt_fwd;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_ISFWD))
+    fmtIsfwd = arg.val.fmt_isfwd;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_PAD))
+    fmtPad = arg.val.fmt_pad;
+  if (ArgPick(&arg, args, MPS_KEY_FMT_CLASS))
+    fmtClass = arg.val.fmt_class;
+
+  res = ControlAlloc(&p, arena, sizeof(FormatStruct));
+  if(res != ResOK)
+    return res;
+  format = (Format)p; /* avoid pun */
+
+  format->arena = arena;
+  RingInit(&format->arenaRing);
+  format->poolCount = 0;
+  format->alignment = fmtAlign;
+  format->headerSize = fmtHeaderSize;
+  format->scan = fmtScan;
+  format->skip = fmtSkip;
+  format->move = fmtFwd;
+  format->isMoved = fmtIsfwd;
+  format->pad = fmtPad;
+  format->klass = fmtClass;
+
+  format->sig = FormatSig;
+  format->serial = arena->formatSerial;
+  ++arena->formatSerial;
+
+  AVERT(Format, format);
+
+  RingAppend(&arena->formatRing, &format->arenaRing);
+
+  *formatReturn = format;
+  return ResOK;
+}
+
+
+/* FormatDestroy -- destroy a format */
+
+void FormatDestroy(Format format)
+{
+  AVERT(Format, format);
+  AVER(format->poolCount == 0); /* <design/check/#.common> */
+
+  RingRemove(&format->arenaRing);
+
+  format->sig = SigInvalid;
+
+  RingFinish(&format->arenaRing);
+
+  ControlFree(format->arena, format, sizeof(FormatStruct));
+}
+
+
+/* FormatArena -- find the arena of a format
+ *
+ * Must be thread-safe. <design/interface-c#.check.testt>. */
+
+Arena FormatArena(Format format)
+{
+  AVER(TESTT(Format, format));
+  return format->arena;
+}
+
+
+/* FormatDescribe -- describe a format */
+
+Res FormatDescribe(Format format, mps_lib_FILE *stream, Count depth)
+{
+  Res res;
+
+  res = WriteF(stream, depth,
+               "Format $P ($U) {\n", (WriteFP)format, (WriteFU)format->serial,
+               "  arena $P ($U)\n",
+               (WriteFP)format->arena, (WriteFU)format->arena->serial,
+               "  poolCount $U\n", (WriteFU)format->poolCount,
+               "  alignment $W\n", (WriteFW)format->alignment,
+               "  scan $F\n", (WriteFF)format->scan,
+               "  skip $F\n", (WriteFF)format->skip,
+               "  move $F\n", (WriteFF)format->move,
+               "  isMoved $F\n", (WriteFF)format->isMoved,
+               "  pad $F\n", (WriteFF)format->pad,
+               "  headerSize $W\n", (WriteFW)format->headerSize,
+               "} Format $P ($U)\n", (WriteFP)format, (WriteFU)format->serial,
+               NULL);
+  if (res != ResOK)
+    return res;
+
+  return ResOK;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fotest.c

@@ -0,0 +1,250 @@
+/* fotest.c: FAIL-OVER TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ * Portions copyright (C) 2002 Global Graphics Software.
+ *
+ * This tests fail-over behaviour in low memory situations. The MVFF
+ * and MVT pool classes normally maintain their list of free blocks in
+ * a Coalescing Block Structure (CBS), but if the CBS cannot handle a
+ * request due to running out of memory, they fall back to a Freelist
+ * (which has zero memory overhead, at some cost in performance).
+ *
+ * This is a white box test: it monkey-patches the MFS pool's alloc
+ * method with a method that always returns a memory error code.
+ */
+
+
+#include "mpscmvff.h"
+#include "mpscmvt.h"
+#include "mpsavm.h"
+
+#include "testlib.h"
+
+#include "cbs.h"
+#include "mpm.h"
+#include "mpmst.h"
+#include "mpmtypes.h"
+#include "poolmfs.h"
+
+#include <stdio.h> /* printf */
+
+
+#define testArenaSIZE   ((((size_t)3)<<24) - 4)
+#define testSetSIZE 200 /* TODO: 10 * arena grain size / sizeof cbs_struct */
+#define testLOOPS 10
+
+
+/* make -- allocate one object */
+
+static mps_res_t make(mps_addr_t *p, mps_ap_t ap, size_t size)
+{
+  mps_res_t res;
+
+  do {
+    MPS_RESERVE_BLOCK(res, *p, ap, size);
+    if(res != MPS_RES_OK)
+      return res;
+  } while(!mps_commit(ap, *p, size));
+
+  return MPS_RES_OK;
+}
+
+
+/* The original alloc method on the MFS pool. */
+static PoolAllocMethod mfs_alloc;
+
+
+/* Are we currently in a part of the test that is allowed to fail in the case
+ * where we run out of memory? This controls the behaviour of oomAlloc. */
+static Bool simulate_allocation_failure = FALSE;
+
+/* How many times has oomAlloc failed on purpose. */
+static unsigned long failure_count = 0;
+
+/* oomAlloc -- allocation function that reliably fails
+ *
+ * Returns a randomly chosen memory error code (and increments
+ * `failure_count`) if `simulate_allocation_failure`. The point is to verify
+ * that none of these errors affects the caller. */
+
+static Res oomAlloc(Addr *pReturn, Pool pool, Size size)
+{
+  if (simulate_allocation_failure) {
+    /* Simulate a single failure in order to enforce the fail-over behaviour. */
+    ++ failure_count;
+    simulate_allocation_failure = 0;
+    switch (rnd() % 3) {
+    case 0:
+      return ResRESOURCE;
+    case 1:
+      return ResMEMORY;
+    default:
+      return ResCOMMIT_LIMIT;
+    }
+  } else {
+    /* Failure here is allowed, so attempt allocation as normal.
+     * (see job004041 and job004104). */
+    return mfs_alloc(pReturn, pool, size);
+  }
+}
+
+
+/* stress -- create an allocation point and allocate in it */
+
+static mps_res_t stress(size_t (*size)(unsigned long, mps_align_t),
+                        mps_align_t alignment, mps_pool_t pool)
+{
+  mps_res_t res = MPS_RES_OK;
+  mps_ap_t ap;
+  unsigned long i, k;
+  int *ps[testSetSIZE];
+  size_t ss[testSetSIZE];
+
+  die(mps_ap_create(&ap, pool, mps_rank_exact()), "BufferCreate");
+
+  /* allocate a load of objects */
+  for (i=0; i<testSetSIZE; ++i) {
+    mps_addr_t obj;
+    ss[i] = (*size)(i, alignment);
+    res = make(&obj, ap, ss[i]);
+    if (res != MPS_RES_OK)
+      goto allocFail;
+    ps[i] = obj;
+    if (ss[i] >= sizeof(ps[i]))
+      *ps[i] = 1; /* Write something, so it gets swap. */
+  }
+
+  failure_count = 0;
+
+  for (k=0; k<testLOOPS; ++k) {
+    /* Use oomAlloc for the first iteration and then with 0.5 probability. */
+    CLASS_STATIC(MFSPool).alloc = (k>0 && rnd() % 2) ? mfs_alloc : oomAlloc;
+
+    /* shuffle all the objects */
+    for (i=0; i<testSetSIZE; ++i) {
+      unsigned long j = i + rnd()%(testSetSIZE-i);
+      void *tp;
+      size_t ts;
+
+      tp = ps[j]; ts = ss[j];
+      ps[j] = ps[i]; ss[j] = ss[i];
+      ps[i] = tp; ss[i] = ts;
+    }
+
+    /* free half of the objects */
+    /* upper half, as when allocating them again we want smaller objects */
+    /* see randomSize() */
+    for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
+      simulate_allocation_failure = TRUE;
+      mps_free(pool, (mps_addr_t)ps[i], ss[i]);
+      simulate_allocation_failure = FALSE;
+      /* if (i == testSetSIZE/2) */
+      /*   PoolDescribe((Pool)pool, mps_lib_stdout); */
+    }
+
+    /* allocate some new objects */
+    for (i=testSetSIZE/2; i<testSetSIZE; ++i) {
+      mps_addr_t obj;
+      ss[i] = (*size)(i, alignment);
+      res = make(&obj, ap, ss[i]);
+      if (res != MPS_RES_OK)
+        goto allocFail;
+      ps[i] = obj;
+    }
+  }
+  CLASS_STATIC(MFSPool).alloc = mfs_alloc;
+
+  Insist(failure_count > 0);
+
+allocFail:
+  mps_ap_destroy(ap);
+
+  return res;
+}
+
+
+/* randomSizeAligned -- produce sizes both large and small,
+ * aligned by platform alignment */
+
+static size_t randomSizeAligned(unsigned long i, mps_align_t alignment)
+{
+  size_t maxSize = 2 * 160 * 0x2000;
+  /* Reduce by a factor of 2 every 10 cycles.  Total allocation about 40 MB. */
+  return alignUp(rnd() % max((maxSize >> (i / 10)), 2) + 1, alignment);
+}
+
+int main(int argc, char *argv[])
+{
+  mps_arena_t arena;
+  mps_pool_t pool;
+  mps_align_t alignment;
+
+  testlib_init(argc, argv);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "mps_arena_create");
+  mfs_alloc = CLASS_STATIC(MFSPool).alloc;
+  alignment = sizeof(void *) << (rnd() % 4);
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_EXTEND_BY, (64 + rnd() % 64) * 1024);
+    MPS_ARGS_ADD(args, MPS_KEY_MEAN_SIZE, (1 + rnd() % 8) * 8);
+    MPS_ARGS_ADD(args, MPS_KEY_ALIGN, alignment);
+    MPS_ARGS_ADD(args, MPS_KEY_MVFF_ARENA_HIGH, rnd() % 2);
+    MPS_ARGS_ADD(args, MPS_KEY_MVFF_SLOT_HIGH, rnd() % 2);
+    MPS_ARGS_ADD(args, MPS_KEY_MVFF_FIRST_FIT, rnd() % 2);
+    die(mps_pool_create_k(&pool, arena, mps_class_mvff(), args), "create MVFF");
+  } MPS_ARGS_END(args);
+  die(stress(randomSizeAligned, alignment, pool), "stress MVFF");
+  mps_pool_destroy(pool);
+  mps_arena_destroy(arena);
+
+  die(mps_arena_create(&arena, mps_arena_class_vm(), testArenaSIZE),
+      "mps_arena_create");
+  alignment = sizeof(void *) << (rnd() % 4);
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ALIGN, alignment);
+    MPS_ARGS_ADD(args, MPS_KEY_MIN_SIZE, (1 + rnd() % 4) * 4);
+    MPS_ARGS_ADD(args, MPS_KEY_MEAN_SIZE, (1 + rnd() % 8) * 16);
+    MPS_ARGS_ADD(args, MPS_KEY_MAX_SIZE, (1 + rnd() % 4) * 1024);
+    MPS_ARGS_ADD(args, MPS_KEY_MVT_RESERVE_DEPTH, (1 + rnd() % 64) * 16);
+    MPS_ARGS_ADD(args, MPS_KEY_MVT_FRAG_LIMIT, (rnd() % 101) / 100.0);
+    die(mps_pool_create_k(&pool, arena, mps_class_mvt(), args), "create MVT");
+  } MPS_ARGS_END(args);
+  die(stress(randomSizeAligned, alignment, pool), "stress MVT");
+  mps_pool_destroy(pool);
+  mps_arena_destroy(arena);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/freelist.c

@@ -0,0 +1,830 @@
+/* freelist.c: FREE LIST ALLOCATOR IMPLEMENTATION
+ *
+ * $Id$
+ * Copyright (c) 2013-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .sources: <design/freelist>.
+ */
+
+#include "freelist.h"
+#include "mpm.h"
+#include "range.h"
+
+SRCID(freelist, "$Id$");
+
+
+#define freelistAlignment(fl) LandAlignment(FreelistLand(fl))
+
+
+typedef union FreelistBlockUnion {
+  struct FreelistBlockSmall {
+    FreelistBlock next;    /* tagged with low bit 1 */
+    /* limit is (char *)this + freelistAlignment(fl) */
+  } small;
+  struct FreelistBlockLarge {
+    FreelistBlock next;    /* not tagged (low bit 0) */
+    Addr limit;
+  } large;
+} FreelistBlockUnion;
+
+
+/* freelistEND -- the end of a list
+ *
+ * The end of a list should not be represented with NULL, as this is
+ * ambiguous. However, freelistEND is in fact a null pointer, for
+ * performance. To check whether you have it right, try temporarily
+ * defining freelistEND as ((FreelistBlock)2) or similar (it must be
+ * an even number because of the use of a tag).
+ */
+
+#define freelistEND ((FreelistBlock)0)
+
+
+/* freelistTag -- return the tag of word */
+
+#define freelistTag(word) ((word) & 1)
+
+
+/* freelistTagSet -- return word updated with the tag set */
+
+#define freelistTagSet(word) ((FreelistBlock)((Word)(word) | 1))
+
+
+/* freelistTagReset -- return word updated with the tag reset */
+
+#define freelistTagReset(word) ((FreelistBlock)((Word)(word) & ~(Word)1))
+
+
+/* freelistTagCopy -- return 'to' updated to have the same tag as 'from' */
+
+#define freelistTagCopy(to, from) ((FreelistBlock)((Word)(to) | freelistTag((Word)(from))))
+
+
+/* freelistBlockIsSmall -- return true if block is small, false if large */
+
+#define freelistBlockIsSmall(block) freelistTag((Word)((block)->small.next))
+
+
+/* freelistBlockBase -- return the base of a block. */
+
+#define freelistBlockBase(block) ((Addr)(block))
+
+
+/* freelistBlockNext -- return the next block in the list, or
+ * freelistEND if there are no more blocks.
+ */
+
+#define freelistBlockNext(block) freelistTagReset((block)->small.next)
+
+
+/* freelistBlockLimit -- return the limit of a block. */
+
+static Addr freelistBlockLimit(Freelist fl, FreelistBlock block)
+{
+  AVERT(Freelist, fl);
+  if (freelistBlockIsSmall(block)) {
+    return AddrAdd(freelistBlockBase(block), freelistAlignment(fl));
+  } else {
+    return block->large.limit;
+  }
+}
+
+
+/* FreelistBlockCheck -- check a block. */
+
+ATTRIBUTE_UNUSED
+static Bool FreelistBlockCheck(FreelistBlock block)
+{
+  CHECKL(block != NULL);
+  /* block list is address-ordered */
+  CHECKL(freelistBlockNext(block) == freelistEND
+         || block < freelistBlockNext(block));
+  CHECKL(freelistBlockIsSmall(block) || (Addr)block < block->large.limit);
+  /* Would like to CHECKL(!freelistBlockIsSmall(block) ||
+   * freelistBlockSize(fl, block) == freelistAlignment(fl)) but we
+   * don't have 'fl' here. This is checked in freelistBlockSetLimit. */
+
+  return TRUE;
+}
+
+
+/* freelistBlockSize -- return the size of a block. */
+
+#define freelistBlockSize(fl, block) \
+  AddrOffset(freelistBlockBase(block), freelistBlockLimit(fl, block))
+
+
+/* freelistBlockSetNext -- update the next block in the list */
+
+static void freelistBlockSetNext(FreelistBlock block, FreelistBlock next)
+{
+  AVERT(FreelistBlock, block);
+  block->small.next = freelistTagCopy(next, block->small.next);
+}
+
+
+/* freelistBlockSetLimit -- update the limit of a block */
+
+static void freelistBlockSetLimit(Freelist fl, FreelistBlock block, Addr limit)
+{
+  Size size;
+
+  AVERT(Freelist, fl);
+  AVERT(FreelistBlock, block);
+  AVER(AddrIsAligned(limit, freelistAlignment(fl)));
+  AVER(freelistBlockBase(block) < limit);
+
+  size = AddrOffset(block, limit);
+  if (size >= sizeof(block->large)) {
+    block->large.next = freelistTagReset(block->large.next);
+    block->large.limit = limit;
+  } else {
+    AVER(size >= sizeof(block->small));
+    block->small.next = freelistTagSet(block->small.next);
+    AVER(freelistBlockSize(fl, block) == freelistAlignment(fl));
+  }
+  AVER(freelistBlockLimit(fl, block) == limit);
+}
+
+
+/* freelistBlockInit -- initialize block storing the range [base, limit). */
+
+static FreelistBlock freelistBlockInit(Freelist fl, Addr base, Addr limit)
+{
+  FreelistBlock block;
+
+  AVERT(Freelist, fl);
+  AVER(base != NULL);
+  AVER(AddrIsAligned(base, freelistAlignment(fl)));
+  AVER(base < limit);
+  AVER(AddrIsAligned(limit, freelistAlignment(fl)));
+
+  block = (FreelistBlock)base;
+  block->small.next = freelistTagSet(freelistEND);
+  freelistBlockSetLimit(fl, block, limit);
+  AVERT(FreelistBlock, block);
+  return block;
+}
+
+
+Bool FreelistCheck(Freelist fl)
+{
+  Land land;
+  CHECKS(Freelist, fl);
+  land = FreelistLand(fl);
+  CHECKD(Land, land);
+  CHECKL(AlignCheck(FreelistMinimumAlignment));
+  CHECKL(sizeof(struct FreelistBlockSmall) < sizeof(struct FreelistBlockLarge));
+  CHECKL(sizeof(struct FreelistBlockSmall) <= freelistAlignment(fl));
+  /* <design/freelist#.impl.grain.align> */
+  CHECKL(AlignIsAligned(freelistAlignment(fl), FreelistMinimumAlignment));
+  CHECKL((fl->list == freelistEND) == (fl->listSize == 0));
+  CHECKL((fl->list == freelistEND) == (fl->size == 0));
+  CHECKL(SizeIsAligned(fl->size, freelistAlignment(fl)));
+
+  return TRUE;
+}
+
+
+static Res freelistInit(Land land, Arena arena, Align alignment, ArgList args)
+{
+  Freelist fl;
+  Res res;
+
+  AVER(land != NULL);
+  res = NextMethod(Land, Freelist, init)(land, arena, alignment, args);
+  if (res != ResOK)
+    return res;
+  fl = CouldBeA(Freelist, land);
+
+  /* <design/freelist#.impl.grain> */
+  AVER(AlignIsAligned(LandAlignment(land), FreelistMinimumAlignment));
+
+  fl->list = freelistEND;
+  fl->listSize = 0;
+  fl->size = 0;
+
+  SetClassOfPoly(land, CLASS(Freelist));
+  fl->sig = FreelistSig;
+  AVERC(Freelist, fl);
+
+  return ResOK;
+}
+
+
+static void freelistFinish(Inst inst)
+{
+  Land land = MustBeA(Land, inst);
+  Freelist fl = MustBeA(Freelist, land);
+  fl->sig = SigInvalid;
+  fl->list = freelistEND;
+  NextMethod(Inst, Freelist, finish)(inst);
+}
+
+
+static Size freelistSize(Land land)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  return fl->size;
+}
+
+
+/* freelistBlockSetPrevNext -- update list of blocks
+ *
+ * If prev and next are both freelistEND, make the block list empty.
+ * Otherwise, if prev is freelistEND, make next the first block in the list.
+ * Otherwise, if next is freelistEND, make prev the last block in the list.
+ * Otherwise, make next follow prev in the list.
+ * Update the count of blocks by 'delta'.
+ *
+ * It is tempting to try to simplify this code by putting a
+ * FreelistBlockUnion into the FreelistStruct and so avoiding the
+ * special case on prev. But the problem with that idea is that we
+ * can't guarantee that such a sentinel would respect the isolated
+ * range invariant (it would have to be at a lower address than the
+ * first block in the free list, which the MPS has no mechanism to
+ * enforce), and so it would still have to be special-cased.
+ */
+
+static void freelistBlockSetPrevNext(Freelist fl, FreelistBlock prev,
+                                     FreelistBlock next, int delta)
+{
+  AVERT(Freelist, fl);
+
+  if (prev == freelistEND) {
+    fl->list = next;
+  } else {
+    /* Isolated range invariant <design/freelist#.impl.invariant>. */
+    AVER(next == freelistEND
+         || freelistBlockLimit(fl, prev) < freelistBlockBase(next));
+    freelistBlockSetNext(prev, next);
+  }
+  if (delta < 0) {
+    AVER(fl->listSize >= (Count)-delta);
+    fl->listSize -= (Count)-delta;
+  } else {
+    fl->listSize += (Count)delta;
+  }
+}
+
+
+static Res freelistInsert(Range rangeReturn, Land land, Range range)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  FreelistBlock prev, cur, next, new;
+  Addr base, limit;
+  Bool coalesceLeft, coalesceRight;
+
+  AVER(rangeReturn != NULL);
+  AVERT(Range, range);
+  AVER(RangeIsAligned(range, freelistAlignment(fl)));
+
+  base = RangeBase(range);
+  limit = RangeLimit(range);
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    if (base < freelistBlockLimit(fl, cur) && freelistBlockBase(cur) < limit)
+      return ResFAIL; /* range overlaps with cur */
+    if (limit <= freelistBlockBase(cur))
+      break;
+    next = freelistBlockNext(cur);
+    if (next != freelistEND)
+      /* Isolated range invariant <design/freelist#.impl.invariant>. */
+      AVER(freelistBlockLimit(fl, cur) < freelistBlockBase(next));
+    prev = cur;
+    cur = next;
+  }
+
+  /* Now we know that range does not overlap with any block, and if it
+   * coalesces then it does so with prev on the left, and cur on the
+   * right.
+   */
+  coalesceLeft = (prev != freelistEND && base == freelistBlockLimit(fl, prev));
+  coalesceRight = (cur != freelistEND && limit == freelistBlockBase(cur));
+
+  if (coalesceLeft && coalesceRight) {
+    base = freelistBlockBase(prev);
+    limit = freelistBlockLimit(fl, cur);
+    freelistBlockSetLimit(fl, prev, limit);
+    freelistBlockSetPrevNext(fl, prev, freelistBlockNext(cur), -1);
+
+  } else if (coalesceLeft) {
+    base = freelistBlockBase(prev);
+    freelistBlockSetLimit(fl, prev, limit);
+
+  } else if (coalesceRight) {
+    next = freelistBlockNext(cur);
+    limit = freelistBlockLimit(fl, cur);
+    cur = freelistBlockInit(fl, base, limit);
+    freelistBlockSetNext(cur, next);
+    freelistBlockSetPrevNext(fl, prev, cur, 0);
+
+  } else {
+    /* failed to coalesce: add new block */
+    new = freelistBlockInit(fl, base, limit);
+    freelistBlockSetNext(new, cur);
+    freelistBlockSetPrevNext(fl, prev, new, +1);
+  }
+
+  fl->size += RangeSize(range);
+  RangeInit(rangeReturn, base, limit);
+  return ResOK;
+}
+
+
+/* freelistDeleteFromBlock -- delete range from block
+ *
+ * range must be a subset of block. Update rangeReturn to be the
+ * original range of block and update the block list accordingly: prev
+ * is on the list just before block, or freelistEND if block is the
+ * first block on the list.
+ */
+
+static void freelistDeleteFromBlock(Range rangeReturn, Freelist fl,
+                                    Range range, FreelistBlock prev,
+                                    FreelistBlock block)
+{
+  FreelistBlock next, new;
+  Addr base, limit, blockBase, blockLimit;
+
+  AVER(rangeReturn != NULL);
+  AVERT(Freelist, fl);
+  AVERT(Range, range);
+  AVER(RangeIsAligned(range, freelistAlignment(fl)));
+  AVER(prev == freelistEND || freelistBlockNext(prev) == block);
+  AVERT(FreelistBlock, block);
+  AVER(freelistBlockBase(block) <= RangeBase(range));
+  AVER(RangeLimit(range) <= freelistBlockLimit(fl, block));
+
+  base = RangeBase(range);
+  limit = RangeLimit(range);
+  blockBase = freelistBlockBase(block);
+  blockLimit = freelistBlockLimit(fl, block);
+  next = freelistBlockNext(block);
+
+  if (base == blockBase && limit == blockLimit) {
+    /* No fragment at left; no fragment at right. */
+    freelistBlockSetPrevNext(fl, prev, next, -1);
+
+  } else if (base == blockBase) {
+    /* No fragment at left; block at right. */
+    block = freelistBlockInit(fl, limit, blockLimit);
+    freelistBlockSetNext(block, next);
+    freelistBlockSetPrevNext(fl, prev, block, 0);
+
+  } else if (limit == blockLimit) {
+    /* Block at left; no fragment at right. */
+    freelistBlockSetLimit(fl, block, base);
+
+  } else {
+    /* Block at left; block at right. */
+    freelistBlockSetLimit(fl, block, base);
+    new = freelistBlockInit(fl, limit, blockLimit);
+    freelistBlockSetNext(new, next);
+    freelistBlockSetPrevNext(fl, block, new, +1);
+  }
+
+  AVER(fl->size >= RangeSize(range));
+  fl->size -= RangeSize(range);
+  RangeInit(rangeReturn, blockBase, blockLimit);
+}
+
+
+static Res freelistDelete(Range rangeReturn, Land land, Range range)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  FreelistBlock prev, cur, next;
+  Addr base, limit;
+
+  AVER(rangeReturn != NULL);
+  AVERT(Range, range);
+
+  base = RangeBase(range);
+  limit = RangeLimit(range);
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    Addr blockBase, blockLimit;
+    blockBase = freelistBlockBase(cur);
+    blockLimit = freelistBlockLimit(fl, cur);
+
+    if (limit <= blockBase)
+      return ResFAIL; /* not found */
+    if (base <= blockLimit) {
+      if (base < blockBase || blockLimit < limit)
+        return ResFAIL; /* partially overlapping */
+      freelistDeleteFromBlock(rangeReturn, fl, range, prev, cur);
+      return ResOK;
+    }
+
+    next = freelistBlockNext(cur);
+    prev = cur;
+    cur = next;
+  }
+
+  /* Range not found in block list. */
+  return ResFAIL;
+}
+
+
+static Bool freelistIterate(Land land, LandVisitor visitor,
+                            void *closure)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  FreelistBlock cur, next;
+
+  AVER(FUNCHECK(visitor));
+  /* closure arbitrary */
+
+  for (cur = fl->list; cur != freelistEND; cur = next) {
+    RangeStruct range;
+    Bool cont;
+    /* .next.first: Take next before calling the visitor, in case the
+     * visitor touches the block. */
+    next = freelistBlockNext(cur);
+    RangeInit(&range, freelistBlockBase(cur), freelistBlockLimit(fl, cur));
+    cont = (*visitor)(land, &range, closure);
+    if (!cont)
+      return FALSE;
+  }
+  return TRUE;
+}
+
+
+static Bool freelistIterateAndDelete(Land land, LandDeleteVisitor visitor,
+                                     void *closure)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  FreelistBlock prev, cur, next;
+
+  AVER(FUNCHECK(visitor));
+  /* closure arbitrary */
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    Bool delete = FALSE;
+    RangeStruct range;
+    Bool cont;
+    Size size;
+    next = freelistBlockNext(cur); /* See .next.first. */
+    size = freelistBlockSize(fl, cur);
+    RangeInit(&range, freelistBlockBase(cur), freelistBlockLimit(fl, cur));
+    cont = (*visitor)(&delete, land, &range, closure);
+    if (delete) {
+      freelistBlockSetPrevNext(fl, prev, next, -1);
+      AVER(fl->size >= size);
+      fl->size -= size;
+    } else {
+      prev = cur;
+    }
+    if (!cont)
+      return FALSE;
+    cur = next;
+  }
+  return TRUE;
+}
+
+
+/* freelistFindDeleteFromBlock -- delete size bytes from block
+ *
+ * Find a chunk of size bytes in block (which is known to be at least
+ * that big) and possibly delete that chunk according to the
+ * instruction in findDelete. Return the range of that chunk in
+ * rangeReturn. Return the original range of the block in
+ * oldRangeReturn. Update the block list accordingly, using prev,
+ * which is previous in list or freelistEND if block is the first
+ * block in the list.
+ */
+
+static void freelistFindDeleteFromBlock(Range rangeReturn, Range oldRangeReturn,
+                                        Freelist fl, Size size,
+                                        FindDelete findDelete,
+                                        FreelistBlock prev, FreelistBlock block)
+{
+  Bool callDelete = TRUE;
+  Addr base, limit;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERT(Freelist, fl);
+  AVER(SizeIsAligned(size, freelistAlignment(fl)));
+  AVERT(FindDelete, findDelete);
+  AVER(prev == freelistEND || freelistBlockNext(prev) == block);
+  AVERT(FreelistBlock, block);
+  AVER(freelistBlockSize(fl, block) >= size);
+
+  base = freelistBlockBase(block);
+  limit = freelistBlockLimit(fl, block);
+
+  switch (findDelete) {
+  case FindDeleteNONE:
+    callDelete = FALSE;
+    break;
+
+  case FindDeleteLOW:
+    limit = AddrAdd(base, size);
+    break;
+
+  case FindDeleteHIGH:
+    base = AddrSub(limit, size);
+    break;
+
+  case FindDeleteENTIRE:
+    /* do nothing */
+    break;
+
+  default:
+    NOTREACHED;
+    break;
+  }
+
+  RangeInit(rangeReturn, base, limit);
+  if (callDelete) {
+    freelistDeleteFromBlock(oldRangeReturn, fl, rangeReturn, prev, block);
+  } else {
+    RangeInit(oldRangeReturn, base, limit);
+  }
+}
+
+
+static Bool freelistFindFirst(Range rangeReturn, Range oldRangeReturn,
+                              Land land, Size size, FindDelete findDelete)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  FreelistBlock prev, cur, next;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVER(SizeIsAligned(size, freelistAlignment(fl)));
+  AVERT(FindDelete, findDelete);
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    if (freelistBlockSize(fl, cur) >= size) {
+      freelistFindDeleteFromBlock(rangeReturn, oldRangeReturn, fl, size,
+                                  findDelete, prev, cur);
+      return TRUE;
+    }
+    next = freelistBlockNext(cur);
+    prev = cur;
+    cur = next;
+  }
+
+  return FALSE;
+}
+
+
+static Bool freelistFindLast(Range rangeReturn, Range oldRangeReturn,
+                             Land land, Size size, FindDelete findDelete)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  Bool found = FALSE;
+  FreelistBlock prev, cur, next;
+  FreelistBlock foundPrev = freelistEND, foundCur = freelistEND;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVER(SizeIsAligned(size, freelistAlignment(fl)));
+  AVERT(FindDelete, findDelete);
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    if (freelistBlockSize(fl, cur) >= size) {
+      found = TRUE;
+      foundPrev = prev;
+      foundCur = cur;
+    }
+    next = freelistBlockNext(cur);
+    prev = cur;
+    cur = next;
+  }
+
+  if (found)
+    freelistFindDeleteFromBlock(rangeReturn, oldRangeReturn, fl, size,
+                                findDelete, foundPrev, foundCur);
+
+  return found;
+}
+
+
+static Bool freelistFindLargest(Range rangeReturn, Range oldRangeReturn,
+                                Land land, Size size, FindDelete findDelete)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  Bool found = FALSE;
+  FreelistBlock prev, cur, next;
+  FreelistBlock bestPrev = freelistEND, bestCur = freelistEND;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERT(FindDelete, findDelete);
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    if (freelistBlockSize(fl, cur) >= size) {
+      found = TRUE;
+      size = freelistBlockSize(fl, cur);
+      bestPrev = prev;
+      bestCur = cur;
+    }
+    next = freelistBlockNext(cur);
+    prev = cur;
+    cur = next;
+  }
+
+  if (found)
+    freelistFindDeleteFromBlock(rangeReturn, oldRangeReturn, fl, size,
+                                findDelete, bestPrev, bestCur);
+
+  return found;
+}
+
+
+static Res freelistFindInZones(Bool *foundReturn, Range rangeReturn,
+                               Range oldRangeReturn, Land land, Size size,
+                               ZoneSet zoneSet, Bool high)
+{
+  Freelist fl = MustBeA(Freelist, land);
+  LandFindMethod landFind;
+  RangeInZoneSet search;
+  Bool found = FALSE;
+  FreelistBlock prev, cur, next;
+  FreelistBlock foundPrev = freelistEND, foundCur = freelistEND;
+  RangeStruct foundRange;
+
+  AVER(FALSE); /* TODO: this code is completely untested! */
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  /* AVERT(ZoneSet, zoneSet); */
+  AVERT(Bool, high);
+
+  landFind = high ? freelistFindLast : freelistFindFirst;
+  search = high ? RangeInZoneSetLast : RangeInZoneSetFirst;
+
+  if (zoneSet == ZoneSetEMPTY)
+    goto fail;
+  if (zoneSet == ZoneSetUNIV) {
+    FindDelete fd = high ? FindDeleteHIGH : FindDeleteLOW;
+    *foundReturn = (*landFind)(rangeReturn, oldRangeReturn, land, size, fd);
+    return ResOK;
+  }
+  if (ZoneSetIsSingle(zoneSet) && size > ArenaStripeSize(LandArena(land)))
+    goto fail;
+
+  prev = freelistEND;
+  cur = fl->list;
+  while (cur != freelistEND) {
+    Addr base, limit;
+    if ((*search)(&base, &limit, freelistBlockBase(cur),
+                  freelistBlockLimit(fl, cur),
+                  LandArena(land), zoneSet, size))
+    {
+      found = TRUE;
+      foundPrev = prev;
+      foundCur = cur;
+      RangeInit(&foundRange, base, limit);
+      if (!high)
+        break;
+    }
+    next = freelistBlockNext(cur);
+    prev = cur;
+    cur = next;
+  }
+
+  if (!found)
+    goto fail;
+
+  freelistDeleteFromBlock(oldRangeReturn, fl, &foundRange, foundPrev, foundCur);
+  RangeCopy(rangeReturn, &foundRange);
+  *foundReturn = TRUE;
+  return ResOK;
+
+fail:
+  *foundReturn = FALSE;
+  return ResOK;
+}
+
+
+/* freelistDescribeVisitor -- visitor method for freelistDescribe
+ *
+ * Writes a description of the range into the stream pointed to by
+ * closure.
+ */
+
+typedef struct FreelistDescribeClosureStruct {
+  mps_lib_FILE *stream;
+  Count depth;
+} FreelistDescribeClosureStruct, *FreelistDescribeClosure;
+
+static Bool freelistDescribeVisitor(Land land, Range range,
+                                    void *closure)
+{
+  Res res;
+  FreelistDescribeClosure my = closure;
+
+  if (!TESTT(Land, land))
+    return FALSE;
+  if (!RangeCheck(range))
+    return FALSE;
+  if (my->stream == NULL)
+    return FALSE;
+
+  res = WriteF(my->stream, my->depth,
+               "[$P,", (WriteFP)RangeBase(range),
+               "$P)", (WriteFP)RangeLimit(range),
+               " {$U}\n", (WriteFU)RangeSize(range),
+               NULL);
+
+  return res == ResOK;
+}
+
+
+static Res freelistDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
+{
+  Land land = CouldBeA(Land, inst);
+  Freelist fl = CouldBeA(Freelist, land);
+  Res res;
+  Bool b;
+  FreelistDescribeClosureStruct closure;
+
+  if (!TESTC(Freelist, fl))
+    return ResPARAM;
+  if (stream == NULL)
+    return ResPARAM;
+
+  res = NextMethod(Inst, Freelist, describe)(inst, stream, depth);
+  if (res != ResOK)
+    return res;
+
+  res = WriteF(stream, depth + 2,
+               "listSize $U\n", (WriteFU)fl->listSize,
+               "size     $U\n", (WriteFU)fl->size,
+               NULL);
+
+  closure.stream = stream;
+  closure.depth = depth + 2;
+  b = LandIterate(land, freelistDescribeVisitor, &closure);
+  if (!b)
+    return ResFAIL;
+
+  return res;
+}
+
+
+DEFINE_CLASS(Land, Freelist, klass)
+{
+  INHERIT_CLASS(klass, Freelist, Land);
+  klass->instClassStruct.describe = freelistDescribe;
+  klass->instClassStruct.finish = freelistFinish;
+  klass->size = sizeof(FreelistStruct);
+  klass->init = freelistInit;
+  klass->sizeMethod = freelistSize;
+  klass->insert = freelistInsert;
+  klass->insertSteal = freelistInsert; /* doesn't need to allocate */
+  klass->delete = freelistDelete;
+  klass->deleteSteal = freelistDelete; /* doesn't need to allocate */
+  klass->iterate = freelistIterate;
+  klass->iterateAndDelete = freelistIterateAndDelete;
+  klass->findFirst = freelistFindFirst;
+  klass->findLast = freelistFindLast;
+  klass->findLargest = freelistFindLargest;
+  klass->findInZones = freelistFindInZones;
+  AVERT(LandClass, klass);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2013-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/freelist.h

@@ -0,0 +1,57 @@
+/* freelist.h: FREE LIST ALLOCATOR INTERFACE
+ *
+ * $Id$
+ * Copyright (c) 2013-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .source: <design/freelist>.
+ */
+
+#ifndef freelist_h
+#define freelist_h
+
+#include "mpmtypes.h"
+#include "mpm.h"
+#include "protocol.h"
+
+typedef struct FreelistStruct *Freelist;
+
+#define FreelistLand(fl) (&(fl)->landStruct)
+
+extern Bool FreelistCheck(Freelist freelist);
+
+/* <design/freelist#.impl.grain.align> */
+#define FreelistMinimumAlignment ((Align)sizeof(FreelistBlock))
+
+DECLARE_CLASS(Land, Freelist, Land);
+
+#endif /* freelist.h */
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2013-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/fri3gc.gmk

@@ -0,0 +1,61 @@
+# -*- makefile -*-
+#
+# fri3gc.gmk: BUILD FOR FreeBSD/i386/GCC PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = fri3gc
+
+MPMPF = \
+    lockix.c \
+    prmcanan.c \
+    prmcfri3.c \
+    prmcix.c \
+    protix.c \
+    protsgix.c \
+    pthrdext.c \
+    span.c \
+    thix.c \
+    vmix.c
+
+LIBS = -lm -pthread
+
+include gc.gmk
+
+# For SQLite3.
+LINKFLAGS += -L/usr/local/lib
+CFLAGSCOMPILER += -I/usr/local/include
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+
+

mps/code/fri3ll.gmk

@@ -0,0 +1,61 @@
+# -*- makefile -*-
+#
+# fri3ll.gmk: BUILD FOR FreeBSD/i386/GCC PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = fri3ll
+
+MPMPF = \
+    lockix.c \
+    prmcanan.c \
+    prmcfri3.c \
+    prmcix.c \
+    protix.c \
+    protsgix.c \
+    pthrdext.c \
+    span.c \
+    thix.c \
+    vmix.c
+
+LIBS = -lm -pthread
+
+include ll.gmk
+
+# For SQLite3.
+LINKFLAGS += -L/usr/local/lib
+CFLAGSCOMPILER += -I/usr/local/include
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+
+

mps/code/fri6gc.gmk

@@ -0,0 +1,61 @@
+# -*- makefile -*-
+#
+# fri6gc.gmk: BUILD FOR FreeBSD/x86-64/GCC PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = fri6gc
+
+MPMPF = \
+    lockix.c \
+    prmcanan.c \
+    prmcfri6.c \
+    prmcix.c \
+    protix.c \
+    protsgix.c \
+    pthrdext.c \
+    span.c \
+    thix.c \
+    vmix.c
+
+LIBS = -lm -pthread
+
+include gc.gmk
+
+# For SQLite3.
+LINKFLAGS += -L/usr/local/lib
+CFLAGSCOMPILER += -I/usr/local/include
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+
+

mps/code/fri6ll.gmk

@@ -0,0 +1,61 @@
+# -*- makefile -*-
+#
+# fri6ll.gmk: BUILD FOR FreeBSD/x86-64/Clang PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+
+PFM = fri6ll
+
+MPMPF = \
+    lockix.c \
+    prmcanan.c \
+    prmcfri6.c \
+    prmcix.c \
+    protix.c \
+    protsgix.c \
+    pthrdext.c \
+    span.c \
+    thix.c \
+    vmix.c
+
+LIBS = -lm -pthread
+
+include ll.gmk
+
+# For SQLite3.
+LINKFLAGS += -L/usr/local/lib
+CFLAGSCOMPILER += -I/usr/local/include
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+
+

mps/code/gc.gmk

@@ -0,0 +1,79 @@
+# -*- makefile -*-
+#
+# gc.gmk: GNUMAKEFILE FRAGMENT FOR GNU CC
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+#
+# This file is included by platform makefiles that use the GNU CC
+# compiler.  It defines the compiler-specific variables that the
+# common makefile fragment (<code/comm.gmk>) requires.
+
+CC = gcc
+CFLAGSDEBUG = -O -g3
+CFLAGSOPT = -O2 -g3
+
+# Warnings that might be enabled by clients <design/config/#.warning.impl>.
+CFLAGSCOMPILER := \
+-Waggregate-return \
+-Wall \
+-Wcast-qual \
+-Werror \
+-Wextra \
+-Winline \
+-Wmissing-prototypes \
+-Wnested-externs \
+-Wpointer-arith \
+-Wshadow \
+-Wstrict-aliasing=2 \
+-Wstrict-prototypes \
+-Wswitch-default \
+-Wwrite-strings
+CFLAGSCOMPILERSTRICT := -std=c89 -pedantic
+
+# A different set of compiler flags for less strict compilation, for
+# instance when we need to #include a third-party header file that
+# won't fly with -ansi -pedantic.  Use sparingly!
+CFLAGSCOMPILERLAX :=
+
+# gcc -MM generates a dependency line of the form:
+#   thing.o : thing.c ...
+# The sed line converts this into:
+#   <pfm>/<variety>/thing.o <pfm>/<variety>/thing.d : thing.c ...
+# If interrupted, this is liable to leave a zero-length file behind.
+
+define gendep
+$(SHELL) -ec "$(CC) $(CFLAGSSTRICT) -MM $< | \
+	sed '/:/s!$*.o!$(@D)/& $(@D)/$*.d!' > $@"
+[ -s $@ ] || rm -f $@
+endef
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/gcbench.c

@@ -0,0 +1,526 @@
+/* gcbench.c -- "GC" Benchmark on ANSI C library
+ *
+ * $Id$
+ * Copyright (c) 2014-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * This is an allocation stress benchmark test for gc pools
+ */
+
+#include "mps.c"
+#include "testlib.h"
+#include "testthr.h"
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mpm.h"
+
+#ifdef MPS_OS_W3
+#include "getopt.h"
+#else
+#include <getopt.h>
+#endif
+
+#include <stdio.h> /* fprintf, printf, putchars, sscanf, stderr, stdout */
+#include <stdlib.h> /* alloca, exit, EXIT_FAILURE, EXIT_SUCCESS, strtoul */
+#include <time.h> /* clock, CLOCKS_PER_SEC */
+
+#define RESMUST(expr) \
+  do { \
+    mps_res_t res = (expr); \
+    if (res != MPS_RES_OK) { \
+      fprintf(stderr, #expr " returned %d\n", res); \
+      exit(EXIT_FAILURE); \
+    } \
+  } while(0)
+
+static mps_arena_t arena;
+static mps_pool_t pool;
+static mps_fmt_t format;
+static mps_chain_t chain;
+
+/* objNULL needs to be odd so that it's ignored in exactRoots. */
+#define objNULL           ((obj_t)MPS_WORD_CONST(0xDECEA5ED))
+#define genLIMIT  100
+
+static rnd_state_t seed = 0;      /* random number seed */
+static unsigned nthreads = 1;     /* threads */
+static unsigned niter = 5;        /* iterations */
+static unsigned npass = 10;       /* passes over tree */
+static size_t width = 2;          /* width of tree nodes */
+static unsigned depth = 20;       /* depth of tree */
+static double preuse = 0.2;       /* probability of reuse */
+static double pupdate = 0.1;      /* probability of update */
+static unsigned ngen = 0;         /* number of generations specified */
+static mps_gen_param_s gen[genLIMIT]; /* generation parameters */
+static size_t arena_size = 256ul * 1024 * 1024; /* arena size */
+static size_t arena_grain_size = 1; /* arena grain size */
+static unsigned pinleaf = FALSE;  /* are leaf objects pinned at start */
+static mps_bool_t zoned = TRUE;   /* arena allocates using zones */
+static double pause_time = ARENA_DEFAULT_PAUSE_TIME; /* maximum pause time */
+static double spare = ARENA_SPARE_DEFAULT; /* spare commit fraction */
+
+typedef struct gcthread_s *gcthread_t;
+
+typedef void *(*gcthread_fn_t)(gcthread_t thread);
+
+struct gcthread_s {
+    testthr_t thread;
+    mps_thr_t mps_thread;
+    mps_root_t reg_root;
+    mps_ap_t ap;
+    gcthread_fn_t fn;
+};
+
+typedef mps_word_t obj_t;
+
+static obj_t mkvector(mps_ap_t ap, size_t n)
+{
+  mps_word_t v;
+  RESMUST(make_dylan_vector(&v, ap, n));
+  return v;
+}
+
+static obj_t aref(obj_t v, size_t i)
+{
+  return DYLAN_VECTOR_SLOT(v, i);
+}
+
+static void aset(obj_t v, size_t i, obj_t val)
+{
+  DYLAN_VECTOR_SLOT(v, i) = val;
+}
+
+/* mktree - make a tree of nodes with depth d. */
+static obj_t mktree(mps_ap_t ap, unsigned d, obj_t leaf)
+{
+  obj_t tree;
+  size_t i;
+  if (d <= 0)
+    return leaf;
+  tree = mkvector(ap, width);
+  for (i = 0; i < width; ++i) {
+    aset(tree, i, mktree(ap, d - 1, leaf));
+  }
+  return tree;
+}
+
+static obj_t random_subtree(obj_t tree, unsigned levels)
+{
+  while(tree != objNULL && levels > 0) {
+    tree = aref(tree, rnd() % width);
+    --levels;
+  }
+  return tree;
+}
+
+/* new_tree - Make a new tree from an old tree.
+ * The new tree is the same depth as the old tree and
+ * reuses old nodes with probability preuse.
+ * NOTE: If a new node is reused multiple times, the total size
+ * will be smaller.
+ * NOTE: Changing preuse will dramatically change how much work
+ * is done.  In particular, if preuse==1, the old tree is returned
+ * unchanged. */
+static obj_t new_tree(mps_ap_t ap, obj_t oldtree, unsigned d)
+{
+  obj_t subtree;
+  size_t i;
+  if (rnd_double() < preuse) {
+    subtree = random_subtree(oldtree, depth - d);
+  } else {
+    if (d == 0)
+      return objNULL;
+    subtree = mkvector(ap, width);
+    for (i = 0; i < width; ++i) {
+      aset(subtree, i, new_tree(ap, oldtree, d - 1));
+    }
+  }
+  return subtree;
+}
+
+/* Update tree to be identical tree but with nodes reallocated
+ * with probability pupdate.  This avoids writing to vector slots
+ * if unnecessary. */
+static obj_t update_tree(mps_ap_t ap, obj_t oldtree, unsigned d)
+{
+  obj_t tree;
+  size_t i;
+  if (oldtree == objNULL || d == 0)
+    return oldtree;
+  if (rnd_double() < pupdate) {
+    tree = mkvector(ap, width);
+    for (i = 0; i < width; ++i) {
+      aset(tree, i, update_tree(ap, aref(oldtree, i), d - 1));
+    }
+  } else {
+    tree = oldtree;
+    for (i = 0; i < width; ++i) {
+      obj_t oldsubtree = aref(oldtree, i);
+      obj_t subtree = update_tree(ap, oldsubtree, d - 1);
+      if (subtree != oldsubtree) {
+        aset(tree, i, subtree);
+      }
+    }
+  }
+  return tree;
+}
+
+static void *gc_tree(gcthread_t thread)
+{
+  unsigned i, j;
+  mps_ap_t ap = thread->ap;
+  obj_t leaf = pinleaf ? mktree(ap, 1, objNULL) : objNULL;
+  for (i = 0; i < niter; ++i) {
+    obj_t tree = mktree(ap, depth, leaf);
+    for (j = 0 ; j < npass; ++j) {
+      if (preuse < 1.0)
+        tree = new_tree(ap, tree, depth);
+      if (pupdate > 0.0)
+        tree = update_tree(ap, tree, depth);
+    }
+  }
+  return NULL;
+}
+
+/* start -- start routine for each thread */
+static void *start(void *p)
+{
+  gcthread_t thread = p;
+  void *marker;
+  RESMUST(mps_thread_reg(&thread->mps_thread, arena));
+  RESMUST(mps_root_create_thread(&thread->reg_root, arena,
+                                 thread->mps_thread, &marker));
+  RESMUST(mps_ap_create_k(&thread->ap, pool, mps_args_none));
+  thread->fn(thread);
+  mps_ap_destroy(thread->ap);
+  mps_root_destroy(thread->reg_root);
+  mps_thread_dereg(thread->mps_thread);
+  return NULL;
+}
+
+static void weave(gcthread_fn_t fn)
+{
+  gcthread_t threads = alloca(sizeof(threads[0]) * nthreads);
+  unsigned t;
+
+  for (t = 0; t < nthreads; ++t) {
+    gcthread_t thread = &threads[t];
+    thread->fn = fn;
+    testthr_create(&thread->thread, start, thread);
+  }
+
+  for (t = 0; t < nthreads; ++t)
+    testthr_join(&threads[t].thread, NULL);
+}
+
+static void weave1(gcthread_fn_t fn)
+{
+  gcthread_t thread = alloca(sizeof(thread[0]));
+
+  thread->fn = fn;
+  start(thread);
+}
+
+
+static void watch(gcthread_fn_t fn, const char *name)
+{
+  clock_t begin, end;
+
+  begin = clock();
+  if (nthreads == 1)
+    weave1(fn);
+  else
+    weave(fn);
+  end = clock();
+
+  printf("%s: %g\n", name, (double)(end - begin) / CLOCKS_PER_SEC);
+}
+
+
+/* Setup MPS arena and call benchmark. */
+
+static void arena_setup(gcthread_fn_t fn,
+                        mps_pool_class_t pool_class,
+                        const char *name)
+{
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, arena_size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_GRAIN_SIZE, arena_grain_size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_ZONED, zoned);
+    MPS_ARGS_ADD(args, MPS_KEY_PAUSE_TIME, pause_time);
+    MPS_ARGS_ADD(args, MPS_KEY_SPARE, spare);
+    RESMUST(mps_arena_create_k(&arena, mps_arena_class_vm(), args));
+  } MPS_ARGS_END(args);
+  RESMUST(dylan_fmt(&format, arena));
+  /* Make wrappers now to avoid race condition. */
+  /* dylan_make_wrappers() uses malloc. */
+  RESMUST(dylan_make_wrappers());
+  if (ngen > 0)
+    RESMUST(mps_chain_create(&chain, arena, ngen, gen));
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, format);
+    if (ngen > 0)
+      MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
+    RESMUST(mps_pool_create_k(&pool, arena, pool_class, args));
+  } MPS_ARGS_END(args);
+  watch(fn, name);
+  mps_arena_park(arena);
+  mps_pool_destroy(pool);
+  mps_fmt_destroy(format);
+  if (ngen > 0)
+    mps_chain_destroy(chain);
+  mps_arena_destroy(arena);
+}
+
+
+/* Command-line options definitions.  See getopt_long(3). */
+
+static struct option longopts[] = {
+  {"help",             no_argument,       NULL, 'h'},
+  {"nthreads",         required_argument, NULL, 't'},
+  {"niter",            required_argument, NULL, 'i'},
+  {"npass",            required_argument, NULL, 'p'},
+  {"gen",              required_argument, NULL, 'g'},
+  {"arena-size",       required_argument, NULL, 'm'},
+  {"arena-grain-size", required_argument, NULL, 'a'},
+  {"width",            required_argument, NULL, 'w'},
+  {"depth",            required_argument, NULL, 'd'},
+  {"preuse",           required_argument, NULL, 'r'},
+  {"pupdate",          required_argument, NULL, 'u'},
+  {"pin-leaf",         no_argument,       NULL, 'l'},
+  {"seed",             required_argument, NULL, 'x'},
+  {"arena-unzoned",    no_argument,       NULL, 'z'},
+  {"pause-time",       required_argument, NULL, 'P'},
+  {"spare",            required_argument, NULL, 'S'},
+  {NULL,               0,                 NULL, 0  }
+};
+
+
+static struct {
+  const char *name;
+  gcthread_fn_t fn;
+  mps_pool_class_t (*pool_class)(void);
+} pools[] = {
+  {"amc", gc_tree, mps_class_amc},
+  {"ams", gc_tree, mps_class_ams},
+  {"awl", gc_tree, mps_class_awl},
+};
+
+
+/* Command-line driver */
+
+int main(int argc, char *argv[])
+{
+  int ch;
+  unsigned i;
+  mps_bool_t seed_specified = FALSE;
+
+  seed = rnd_seed();
+
+  while ((ch = getopt_long(argc, argv, "ht:i:p:g:m:a:w:d:r:u:lx:zP:S:",
+                           longopts, NULL)) != -1)
+    switch (ch) {
+    case 't':
+      nthreads = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'i':
+      niter = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'p':
+      npass = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'g':
+      if (ngen >= genLIMIT) {
+        fprintf(stderr, "exceeded genLIMIT\n");
+          return EXIT_FAILURE;
+      }
+      {
+        char *p;
+        size_t cap = 0;
+        double mort = 0.0;
+        cap = (size_t)strtoul(optarg, &p, 10);
+        switch(toupper(*p)) {
+        case 'G': cap <<= 20; p++; break;
+        case 'M': cap <<= 10; p++; break;
+        case 'K': p++; break;
+        default: cap = 0; break;
+        }
+        if (sscanf(p, ",%lg", &mort) != 1 || cap == 0) {
+          fprintf(stderr, "Bad gen format '%s'\n"
+          "Each gen option has format --gen=capacity[KMG],mortality\n"
+          "where capacity is a size specified in kilobytes, megabytes or gigabytes\n"
+          "and mortality is a number between 0 and 1\n"
+          "e.g.: --gen=500K,0.85 --gen=20M,0.45\n", optarg);
+            return EXIT_FAILURE;
+        }
+        gen[ngen].mps_capacity = cap;
+        gen[ngen].mps_mortality = mort;
+        ngen++;
+      }
+      break;
+    case 'm': {
+        char *p;
+        arena_size = (unsigned)strtoul(optarg, &p, 10);
+        switch(toupper(*p)) {
+        case 'G': arena_size <<= 30; break;
+        case 'M': arena_size <<= 20; break;
+        case 'K': arena_size <<= 10; break;
+        case '\0': break;
+        default:
+          fprintf(stderr, "Bad arena size %s\n", optarg);
+          return EXIT_FAILURE;
+        }
+      }
+      break;
+    case 'a': {
+        char *p;
+        arena_grain_size = (unsigned)strtoul(optarg, &p, 10);
+        switch(toupper(*p)) {
+        case 'G': arena_grain_size <<= 30; break;
+        case 'M': arena_grain_size <<= 20; break;
+        case 'K': arena_grain_size <<= 10; break;
+        case '\0': break;
+        default:
+          fprintf(stderr, "Bad arena grain size %s\n", optarg);
+          return EXIT_FAILURE;
+        }
+      }
+      break;
+    case 'w':
+      width = (size_t)strtoul(optarg, NULL, 10);
+      break;
+    case 'd':
+      depth = (unsigned)strtoul(optarg, NULL, 10);
+      break;
+    case 'r':
+      preuse = strtod(optarg, NULL);
+      break;
+    case 'u':
+      pupdate = strtod(optarg, NULL);
+      break;
+    case 'l':
+      pinleaf = TRUE;
+      break;
+    case 'x':
+      seed = strtoul(optarg, NULL, 10);
+      seed_specified = TRUE;
+      break;
+    case 'z':
+      zoned = FALSE;
+      break;
+    case 'P':
+      pause_time = strtod(optarg, NULL);
+      break;
+    case 'S':
+      spare = strtod(optarg, NULL);
+      break;
+    default:
+      /* This is printed in parts to keep within the 509 character
+         limit for string literals in portable standard C. */
+      fprintf(stderr,
+              "Usage: %s [option...] [test...]\n"
+              "Options:\n"
+              "  -m n, --arena-size=n[KMG]?\n"
+              "    Initial size of arena (default %lu)\n"
+              "  -a n, --arena-grain-size=n[KMG]?\n"
+              "    Arena grain size (default %lu)\n"
+              "  -t n, --nthreads=n\n"
+              "    Launch n threads each running the test (default %u)\n"
+              "  -i n, --niter=n\n"
+              "    Iterate each test n times (default %u)\n"
+              "  -p n, --npass=n\n"
+              "    Pass over the tree n times (default %u)\n",
+              argv[0],
+              (unsigned long)arena_size,
+              (unsigned long)arena_grain_size,
+              nthreads,
+              niter,
+              npass);
+      fprintf(stderr,
+              "  -g c,m, --gen=c[KMG],m\n"
+              "    Generation with capacity c (in Kb) and mortality m\n"
+              "    Use multiple times for multiple generations\n"
+              "  -w n, --width=n\n"
+              "    Width of tree nodes made (default %lu)\n"
+              "  -d n, --depth=n\n"
+              "    Depth of tree made (default %u)\n"
+              "  -r p, --preuse=p\n"
+              "    Probability of reusing a node (default %g)\n"
+              "  -u p, --pupdate=p\n"
+              "    Probability of updating a node (default %g)\n"
+              "  -l --pin-leaf\n"
+              "    Make a pinned object to use for leaves\n"
+              "  -x n, --seed=n\n"
+              "    Random number seed (default from entropy)\n",
+              (unsigned long)width,
+              depth,
+              preuse,
+              pupdate);
+      fprintf(stderr,
+              "  -z, --arena-unzoned\n"
+              "    Disable zoned allocation in the arena\n"
+              "  -P t, --pause-time\n"
+              "    Maximum pause time in seconds (default %f)\n"
+              "  -S f, --spare\n"
+              "    Maximum spare committed fraction (default %f)\n"
+              "Tests:\n"
+              "  amc   pool class AMC\n"
+              "  ams   pool class AMS\n"
+              "  awl   pool class AWL\n",
+              pause_time,
+              spare);
+      return EXIT_FAILURE;
+    }
+  argc -= optind;
+  argv += optind;
+
+  if (!seed_specified) {
+    printf("seed: %lu\n", seed);
+    (void)fflush(stdout);
+  }
+
+  while (argc > 0) {
+    for (i = 0; i < NELEMS(pools); ++i)
+      if (strcmp(argv[0], pools[i].name) == 0)
+        goto found;
+    fprintf(stderr, "unknown pool test \"%s\"\n", argv[0]);
+    return EXIT_FAILURE;
+  found:
+    (void)mps_lib_assert_fail_install(assert_die);
+    rnd_state_set(seed);
+    arena_setup(pools[i].fn, pools[i].pool_class(), pools[i].name);
+    --argc;
+    ++argv;
+  }
+
+  return EXIT_SUCCESS;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2014-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/getopt.h

@@ -0,0 +1,89 @@
+/* getopt.h -- get options from command-line argument list
+ *
+ * $Id$
+ *
+ * Adapted from FreeBSD getopt_long(3) to ensure cross-platform availability
+ * in the Memory Pool System test programs.
+ */
+
+/*      $NetBSD: getopt.h,v 1.4 2000/07/07 10:43:54 ad Exp $    */
+/*      $FreeBSD: src/include/getopt.h,v 1.6.30.1.8.1 2012/03/03 06:15:13 kensmith Exp $ */
+
+/*-
+ * Copyright (c) 2000 The NetBSD Foundation, Inc.
+ * All rights reserved.
+ *
+ * This code is derived from software contributed to The NetBSD Foundation
+ * by Dieter Baron and Thomas Klausner.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. All advertising materials mentioning features or use of this software
+ *    must display the following acknowledgement:
+ *        This product includes software developed by the NetBSD
+ *        Foundation, Inc. and its contributors.
+ * 4. Neither the name of The NetBSD Foundation nor the names of its
+ *    contributors may be used to endorse or promote products derived
+ *    from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. 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 FOUNDATION 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.
+ */
+
+#ifndef _GETOPT_H_
+#define _GETOPT_H_
+
+/*
+ * GNU-like getopt_long()/getopt_long_only() with 4.4BSD optreset extension.
+ * getopt() is declared here too for GNU programs.
+ */
+#define no_argument        0
+#define required_argument  1
+#define optional_argument  2
+
+struct option {
+        /* name of long option */
+        const char *name;
+        /*
+         * one of no_argument, required_argument, and optional_argument:
+         * whether option takes an argument
+         */
+        int has_arg;
+        /* if not NULL, set *flag to val when option found */
+        int *flag;
+        /* if flag not NULL, value to set *flag to; else return value */
+        int val;
+};
+
+int     getopt_long(int, char * const *, const char *,
+        const struct option *, int *);
+int     getopt_long_only(int, char * const *, const char *,
+        const struct option *, int *);
+#ifndef _GETOPT_DECLARED
+#define _GETOPT_DECLARED
+int      getopt(int, char * const [], const char *);
+
+extern char *optarg;                    /* getopt(3) external variables */
+extern int optind, opterr, optopt;
+#endif
+#ifndef _OPTRESET_DECLARED
+#define _OPTRESET_DECLARED
+extern int optreset;                    /* getopt(3) external variable */
+#endif
+ 
+#endif /* !_GETOPT_H_ */

mps/code/getoptl.c

@@ -0,0 +1,635 @@
+/* getoptl.c -- get long options from command line argument list
+ *
+ * $Id$
+ *
+ * Adapted from FreeBSD getopt_long(3) to ensure cross-platform availability
+ * in the Memory Pool System test programs.
+ */
+
+/*      $OpenBSD: getopt_long.c,v 1.21 2006/09/22 17:22:05 millert Exp $        */
+/*      $NetBSD: getopt_long.c,v 1.15 2002/01/31 22:43:40 tv Exp $      */
+
+/*
+ * Copyright (c) 2002 Todd C. Miller <Todd.Miller@courtesan.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ * Sponsored in part by the Defense Advanced Research Projects
+ * Agency (DARPA) and Air Force Research Laboratory, Air Force
+ * Materiel Command, USAF, under agreement number F39502-99-1-0512.
+ */
+/*-
+ * Copyright (c) 2000 The NetBSD Foundation, Inc.
+ * All rights reserved.
+ *
+ * This code is derived from software contributed to The NetBSD Foundation
+ * by Dieter Baron and Thomas Klausner.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. All advertising materials mentioning features or use of this software
+ *    must display the following acknowledgement:
+ *        This product includes software developed by the NetBSD
+ *        Foundation, Inc. and its contributors.
+ * 4. Neither the name of The NetBSD Foundation nor the names of its
+ *    contributors may be used to endorse or promote products derived
+ *    from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. 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 FOUNDATION 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.
+ */
+
+#include "getopt.h"
+
+#include <errno.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <stdio.h>
+#include <stdarg.h>
+
+#define GNU_COMPATIBLE          /* Be more compatible, configure's use us! */
+
+int     opterr = 1;             /* if error message should be printed */
+int     optind = 1;             /* index into parent argv vector */
+int     optopt = '?';           /* character checked for validity */
+int     optreset;               /* reset getopt */
+char    *optarg;                /* argument associated with option */
+
+#define PRINT_ERROR     ((opterr) && (*options != ':'))
+
+#define FLAG_PERMUTE    0x01    /* permute non-options to the end of argv */
+#define FLAG_ALLARGS    0x02    /* treat non-options as args to option "-1" */
+#define FLAG_LONGONLY   0x04    /* operate as getopt_long_only */
+
+/* return values */
+#define BADCH           (int)'?'
+#define BADARG          ((*options == ':') ? (int)':' : (int)'?')
+#define INORDER         (int)1
+
+#define EMSG            ""
+
+#ifdef GNU_COMPATIBLE
+#define NO_PREFIX       (-1)
+#define D_PREFIX        0
+#define DD_PREFIX       1
+#define W_PREFIX        2
+#endif
+
+static int getopt_internal(int, char * const *, const char *,
+                           const struct option *, int *, int);
+static int parse_long_options(char * const *, const char *,
+                              const struct option *, int *, int, int);
+static int gcd(int, int);
+static void permute_args(int, int, int, char * const *);
+
+static char emsg[] = EMSG;
+static char *place = emsg; /* option letter processing */
+
+/* XXX: set optreset to 1 rather than these two */
+static int nonopt_start = -1; /* first non option argument (for permute) */
+static int nonopt_end = -1;   /* first option after non options (for permute) */
+
+/* Error messages */
+static const char recargchar[] = "option requires an argument -- %c";
+static const char illoptchar[] = "illegal option -- %c"; /* From P1003.2 */
+#ifdef GNU_COMPATIBLE
+static int dash_prefix = NO_PREFIX;
+static const char gnuoptchar[] = "invalid option -- %c";
+
+static const char recargstring[] = "option `%s%s' requires an argument";
+static const char ambig[] = "option `%s%.*s' is ambiguous";
+static const char noarg[] = "option `%s%.*s' doesn't allow an argument";
+static const char illoptstring[] = "unrecognized option `%s%s'";
+#else
+static const char recargstring[] = "option requires an argument -- %s";
+static const char ambig[] = "ambiguous option -- %.*s";
+static const char noarg[] = "option doesn't take an argument -- %.*s";
+static const char illoptstring[] = "unknown option -- %s";
+#endif
+
+static void
+warnx(const char *fmt, ...)
+{
+        va_list varargs;
+        va_start(varargs, fmt);
+        vfprintf(stderr, fmt, varargs);
+        fputc('\n', stderr);
+        va_end(varargs);
+}
+
+/*
+ * Compute the greatest common divisor of a and b.
+ */
+static int
+gcd(int a, int b)
+{
+        int c;
+
+        c = a % b;
+        while (c != 0) {
+                a = b;
+                b = c;
+                c = a % b;
+        }
+
+        return (b);
+}
+
+/*
+ * Exchange the block from nonopt_start to nonopt_end with the block
+ * from nonopt_end to opt_end (keeping the same order of arguments
+ * in each block).
+ */
+static void
+permute_args(int panonopt_start, int panonopt_end, int opt_end,
+        char * const *nargv)
+{
+        int cstart, cyclelen, i, j, ncycle, nnonopts, nopts, pos;
+        char *swap;
+
+        /*
+         * compute lengths of blocks and number and size of cycles
+         */
+        nnonopts = panonopt_end - panonopt_start;
+        nopts = opt_end - panonopt_end;
+        ncycle = gcd(nnonopts, nopts);
+        cyclelen = (opt_end - panonopt_start) / ncycle;
+
+        for (i = 0; i < ncycle; i++) {
+                cstart = panonopt_end+i;
+                pos = cstart;
+                for (j = 0; j < cyclelen; j++) {
+                        if (pos >= panonopt_end)
+                                pos -= nnonopts;
+                        else
+                                pos += nopts;
+                        swap = nargv[pos];
+                        /* LINTED const cast */
+                        ((char **) nargv)[pos] = nargv[cstart];
+                        /* LINTED const cast */
+                        ((char **)nargv)[cstart] = swap;
+                }
+        }
+}
+
+/*
+ * parse_long_options --
+ *      Parse long options in argc/argv argument vector.
+ * Returns -1 if short_too is set and the option does not match long_options.
+ */
+static int
+parse_long_options(char * const *nargv, const char *options,
+        const struct option *long_options, int *idx, int short_too, int flags)
+{
+        char *current_argv, *has_equal;
+#ifdef GNU_COMPATIBLE
+        const char *current_dash;
+#endif
+        size_t current_argv_len;
+        int i, match, exact_match, second_partial_match;
+
+        current_argv = place;
+#ifdef GNU_COMPATIBLE
+        switch (dash_prefix) {
+                case D_PREFIX:
+                        current_dash = "-";
+                        break;
+                case DD_PREFIX:
+                        current_dash = "--";
+                        break;
+                case W_PREFIX:
+                        current_dash = "-W ";
+                        break;
+                default:
+                        current_dash = "";
+                        break;
+        }
+#endif
+        match = -1;
+        exact_match = 0;
+        second_partial_match = 0;
+
+        optind++;
+
+        if ((has_equal = strchr(current_argv, '=')) != NULL) {
+                /* argument found (--option=arg) */
+                assert(has_equal > current_argv);
+                current_argv_len = (size_t)(has_equal - current_argv);
+                has_equal++;
+        } else
+                current_argv_len = strlen(current_argv);
+
+        for (i = 0; long_options[i].name; i++) {
+                /* find matching long option */
+                if (strncmp(current_argv, long_options[i].name,
+                    current_argv_len))
+                        continue;
+
+                if (strlen(long_options[i].name) == current_argv_len) {
+                        /* exact match */
+                        match = i;
+                        exact_match = 1;
+                        break;
+                }
+                /*
+                 * If this is a known short option, don't allow
+                 * a partial match of a single character.
+                 */
+                if (short_too && current_argv_len == 1)
+                        continue;
+
+                if (match == -1)        /* first partial match */
+                        match = i;
+                else if ((flags & FLAG_LONGONLY) ||
+                         long_options[i].has_arg !=
+                             long_options[match].has_arg ||
+                         long_options[i].flag != long_options[match].flag ||
+                         long_options[i].val != long_options[match].val)
+                        second_partial_match = 1;
+        }
+        if (!exact_match && second_partial_match) {
+                /* ambiguous abbreviation */
+                if (PRINT_ERROR)
+                        fprintf(stderr,
+                                ambig,
+#ifdef GNU_COMPATIBLE
+                             current_dash,
+#endif
+                             (int)current_argv_len,
+                             current_argv);
+                optopt = 0;
+                return (BADCH);
+        }
+        if (match != -1) {              /* option found */
+                if (long_options[match].has_arg == no_argument
+                    && has_equal) {
+                        if (PRINT_ERROR)
+                                warnx(noarg,
+#ifdef GNU_COMPATIBLE
+                                     current_dash,
+#endif
+                                     (int)current_argv_len,
+                                     current_argv);
+                        /*
+                         * XXX: GNU sets optopt to val regardless of flag
+                         */
+                        if (long_options[match].flag == NULL)
+                                optopt = long_options[match].val;
+                        else
+                                optopt = 0;
+#ifdef GNU_COMPATIBLE
+                        return (BADCH);
+#else
+                        return (BADARG);
+#endif
+                }
+                if (long_options[match].has_arg == required_argument ||
+                    long_options[match].has_arg == optional_argument) {
+                        if (has_equal)
+                                optarg = has_equal;
+                        else if (long_options[match].has_arg ==
+                            required_argument) {
+                                /*
+                                 * optional argument doesn't use next nargv
+                                 */
+                                optarg = nargv[optind++];
+                        }
+                }
+                if ((long_options[match].has_arg == required_argument)
+                    && (optarg == NULL)) {
+                        /*
+                         * Missing argument; leading ':' indicates no error
+                         * should be generated.
+                         */
+                        if (PRINT_ERROR)
+                                warnx(recargstring,
+#ifdef GNU_COMPATIBLE
+                                    current_dash,
+#endif
+                                    current_argv);
+                        /*
+                         * XXX: GNU sets optopt to val regardless of flag
+                         */
+                        if (long_options[match].flag == NULL)
+                                optopt = long_options[match].val;
+                        else
+                                optopt = 0;
+                        --optind;
+                        return (BADARG);
+                }
+        } else {                        /* unknown option */
+                if (short_too) {
+                        --optind;
+                        return (-1);
+                }
+                if (PRINT_ERROR)
+                        warnx(illoptstring,
+#ifdef GNU_COMPATIBLE
+                              current_dash,
+#endif
+                              current_argv);
+                optopt = 0;
+                return (BADCH);
+        }
+        if (idx)
+                *idx = match;
+        if (long_options[match].flag) {
+                *long_options[match].flag = long_options[match].val;
+                return (0);
+        } else
+                return (long_options[match].val);
+}
+
+/*
+ * getopt_internal --
+ *      Parse argc/argv argument vector.  Called by user level routines.
+ */
+static int
+getopt_internal(int nargc, char * const *nargv, const char *options,
+        const struct option *long_options, int *idx, int flags)
+{
+        char *oli;                              /* option letter list index */
+        int optchar, short_too;
+        int posixly_correct;    /* no static, can be changed on the fly */
+
+        if (options == NULL)
+                return (-1);
+
+        /*
+         * Disable GNU extensions if POSIXLY_CORRECT is set or options
+         * string begins with a '+'.
+         */
+        posixly_correct = (getenv("POSIXLY_CORRECT") != NULL);
+#ifdef GNU_COMPATIBLE
+        if (*options == '-')
+                flags |= FLAG_ALLARGS;
+        else if (posixly_correct || *options == '+')
+                flags &= ~FLAG_PERMUTE;
+#else
+        if (posixly_correct || *options == '+')
+                flags &= ~FLAG_PERMUTE;
+        else if (*options == '-')
+                flags |= FLAG_ALLARGS;
+#endif
+        if (*options == '+' || *options == '-')
+                options++;
+
+        /*
+         * XXX Some GNU programs (like cvs) set optind to 0 instead of
+         * XXX using optreset.  Work around this braindamage.
+         */
+        if (optind == 0)
+                optind = optreset = 1;
+
+        optarg = NULL;
+        if (optreset)
+                nonopt_start = nonopt_end = -1;
+start:
+        if (optreset || !*place) {              /* update scanning pointer */
+                optreset = 0;
+                if (optind >= nargc) {          /* end of argument vector */
+                        place = emsg;
+                        if (nonopt_end != -1) {
+                                /* do permutation, if we have to */
+                                permute_args(nonopt_start, nonopt_end,
+                                    optind, nargv);
+                                optind -= nonopt_end - nonopt_start;
+                        }
+                        else if (nonopt_start != -1) {
+                                /*
+                                 * If we skipped non-options, set optind
+                                 * to the first of them.
+                                 */
+                                optind = nonopt_start;
+                        }
+                        nonopt_start = nonopt_end = -1;
+                        return (-1);
+                }
+                if (*(place = nargv[optind]) != '-' ||
+#ifdef GNU_COMPATIBLE
+                    place[1] == '\0') {
+#else
+                    (place[1] == '\0' && strchr(options, '-') == NULL)) {
+#endif
+                        place = emsg;           /* found non-option */
+                        if (flags & FLAG_ALLARGS) {
+                                /*
+                                 * GNU extension:
+                                 * return non-option as argument to option 1
+                                 */
+                                optarg = nargv[optind++];
+                                return (INORDER);
+                        }
+                        if (!(flags & FLAG_PERMUTE)) {
+                                /*
+                                 * If no permutation wanted, stop parsing
+                                 * at first non-option.
+                                 */
+                                return (-1);
+                        }
+                        /* do permutation */
+                        if (nonopt_start == -1)
+                                nonopt_start = optind;
+                        else if (nonopt_end != -1) {
+                                permute_args(nonopt_start, nonopt_end,
+                                    optind, nargv);
+                                nonopt_start = optind -
+                                    (nonopt_end - nonopt_start);
+                                nonopt_end = -1;
+                        }
+                        optind++;
+                        /* process next argument */
+                        goto start;
+                }
+                if (nonopt_start != -1 && nonopt_end == -1)
+                        nonopt_end = optind;
+
+                /*
+                 * If we have "-" do nothing, if "--" we are done.
+                 */
+                if (place[1] != '\0' && *++place == '-' && place[1] == '\0') {
+                        optind++;
+                        place = emsg;
+                        /*
+                         * We found an option (--), so if we skipped
+                         * non-options, we have to permute.
+                         */
+                        if (nonopt_end != -1) {
+                                permute_args(nonopt_start, nonopt_end,
+                                    optind, nargv);
+                                optind -= nonopt_end - nonopt_start;
+                        }
+                        nonopt_start = nonopt_end = -1;
+                        return (-1);
+                }
+        }
+
+        /*
+         * Check long options if:
+         *  1) we were passed some
+         *  2) the arg is not just "-"
+         *  3) either the arg starts with -- we are getopt_long_only()
+         */
+        if (long_options != NULL && place != nargv[optind] &&
+            (*place == '-' || (flags & FLAG_LONGONLY))) {
+                short_too = 0;
+#ifdef GNU_COMPATIBLE
+                dash_prefix = D_PREFIX;
+#endif
+                if (*place == '-') {
+                        place++;                /* --foo long option */
+#ifdef GNU_COMPATIBLE
+                        dash_prefix = DD_PREFIX;
+#endif
+                } else if (*place != ':' && strchr(options, *place) != NULL)
+                        short_too = 1;          /* could be short option too */
+
+                optchar = parse_long_options(nargv, options, long_options,
+                    idx, short_too, flags);
+                if (optchar != -1) {
+                        place = emsg;
+                        return (optchar);
+                }
+        }
+
+        if ((optchar = (int)*place++) == (int)':' ||
+            (optchar == (int)'-' && *place != '\0') ||
+            (oli = strchr(options, optchar)) == NULL) {
+                /*
+                 * If the user specified "-" and  '-' isn't listed in
+                 * options, return -1 (non-option) as per POSIX.
+                 * Otherwise, it is an unknown option character (or ':').
+                 */
+                if (optchar == (int)'-' && *place == '\0')
+                        return (-1);
+                if (!*place)
+                        ++optind;
+#ifdef GNU_COMPATIBLE
+                if (PRINT_ERROR)
+                        warnx(posixly_correct ? illoptchar : gnuoptchar,
+                              optchar);
+#else
+                if (PRINT_ERROR)
+                        warnx(illoptchar, optchar);
+#endif
+                optopt = optchar;
+                return (BADCH);
+        }
+        if (long_options != NULL && optchar == 'W' && oli[1] == ';') {
+                /* -W long-option */
+                if (*place)                     /* no space */
+                        /* NOTHING */;
+                else if (++optind >= nargc) {   /* no arg */
+                        place = emsg;
+                        if (PRINT_ERROR)
+                                warnx(recargchar, optchar);
+                        optopt = optchar;
+                        return (BADARG);
+                } else                          /* white space */
+                        place = nargv[optind];
+#ifdef GNU_COMPATIBLE
+                dash_prefix = W_PREFIX;
+#endif
+                optchar = parse_long_options(nargv, options, long_options,
+                    idx, 0, flags);
+                place = emsg;
+                return (optchar);
+        }
+        if (*++oli != ':') {                    /* doesn't take argument */
+                if (!*place)
+                        ++optind;
+        } else {                                /* takes (optional) argument */
+                optarg = NULL;
+                if (*place)                     /* no white space */
+                        optarg = place;
+                else if (oli[1] != ':') {       /* arg not optional */
+                        if (++optind >= nargc) {        /* no arg */
+                                place = emsg;
+                                if (PRINT_ERROR)
+                                        warnx(recargchar, optchar);
+                                optopt = optchar;
+                                return (BADARG);
+                        } else
+                                optarg = nargv[optind];
+                }
+                place = emsg;
+                ++optind;
+        }
+        /* dump back option letter */
+        return (optchar);
+}
+
+#ifdef REPLACE_GETOPT
+/*
+ * getopt --
+ *      Parse argc/argv argument vector.
+ *
+ * [eventually this will replace the BSD getopt]
+ */
+int
+getopt(int nargc, char * const *nargv, const char *options)
+{
+
+        /*
+         * We don't pass FLAG_PERMUTE to getopt_internal() since
+         * the BSD getopt(3) (unlike GNU) has never done this.
+         *
+         * Furthermore, since many privileged programs call getopt()
+         * before dropping privileges it makes sense to keep things
+         * as simple (and bug-free) as possible.
+         */
+        return (getopt_internal(nargc, nargv, options, NULL, NULL, 0));
+}
+#endif /* REPLACE_GETOPT */
+
+/*
+ * getopt_long --
+ *      Parse argc/argv argument vector.
+ */
+int
+getopt_long(int nargc, char * const *nargv, const char *options,
+        const struct option *long_options, int *idx)
+{
+
+        return (getopt_internal(nargc, nargv, options, long_options, idx,
+            FLAG_PERMUTE));
+}
+
+/*
+ * getopt_long_only --
+ *      Parse argc/argv argument vector.
+ */
+int
+getopt_long_only(int nargc, char * const *nargv, const char *options,
+        const struct option *long_options, int *idx)
+{
+
+        return (getopt_internal(nargc, nargv, options, long_options, idx,
+            FLAG_PERMUTE|FLAG_LONGONLY));
+}

mps/code/gp.gmk

@@ -0,0 +1,63 @@
+# -*- makefile -*-
+#
+# gp.gmk: GNUMAKEFILE FRAGMENT FOR GNU CC/GPROF
+#
+# $Id$
+# Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+#
+# This file is included by platform makefiles that use the GNU CC
+# compiler with gprof.  It defines the compiler specific variables
+# that the common makefile fragment (<code/comm.gmk>) requires.
+
+
+CC = gcc
+CFLAGSCOMPILER = \
+	-ansi -pedantic -Wall -Wextra -Werror -Wpointer-arith \
+	-Wstrict-prototypes -Wmissing-prototypes \
+	-Winline -Waggregate-return -Wnested-externs \
+	-Wcast-qual -Wshadow -Wwrite-strings -pg
+CFLAGSDEBUG = -g -ggdb3
+CFLAGSOPT = -O -g -ggdb3
+
+# gcc -MM generates a dependency line of the form:
+#   thing.o : thing.c ...
+# The sed line converts this into:
+#   <pfm>/<variety>/thing.o <pfm>/<variety>/thing.d : thing.c ...
+# @@ This sequence is vulnerable to interrupts (for some reason)
+
+define gendep
+	$(SHELL) -ec "gcc -c $(CFLAGS) -MM $< | \
+		sed '/:/s!$*.o!$(@D)/& $(@D)/$*.d!' > $@"
+endef
+
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/land.c

@@ -0,0 +1,646 @@
+/* land.c: LAND (COLLECTION OF ADDRESS RANGES) IMPLEMENTATION
+ *
+ * $Id$
+ * Copyright (c) 2014-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .design: <design/land>
+ *
+ * .critical.macros: In manual-allocation-bound programs using MVFF,
+ * the Land generic functions are on the critical path via mps_free.
+ * In non-checking varieties we provide macro alternatives (in mpm.h)
+ * to these functions that call the underlying methods directly,
+ * giving a few percent improvement in performance but skipping the
+ * re-entrancy checking provided by landEnter and landLeave.
+ */
+
+#include "mpm.h"
+#include "range.h"
+
+SRCID(land, "$Id$");
+
+
+/* Forward declarations */
+
+static Res landNoInsert(Range rangeReturn, Land land, Range range);
+static Res landNoDelete(Range rangeReturn, Land land, Range range);
+
+
+/* FindDeleteCheck -- check method for a FindDelete value */
+
+Bool FindDeleteCheck(FindDelete findDelete)
+{
+  CHECKL(findDelete == FindDeleteNONE
+         || findDelete == FindDeleteLOW
+         || findDelete == FindDeleteHIGH
+         || findDelete == FindDeleteENTIRE);
+  UNUSED(findDelete); /* <code/mpm.c#check.unused> */
+
+  return TRUE;
+}
+
+
+/* landEnter, landLeave -- Avoid re-entrance
+ *
+ * .enter-leave: The visitor functions passed to LandIterate and
+ * LandIterateAndDelete are not allowed to call methods of that land.
+ * These functions enforce this.
+ *
+ * .enter-leave.simple: Some simple queries are fine to call from
+ * visitor functions. These are marked with the tag of this comment.
+ */
+
+static void landEnter(Land land)
+{
+  /* Don't need to check as always called from interface function. */
+  AVER(!land->inLand);
+  land->inLand = TRUE;
+}
+
+static void landLeave(Land land)
+{
+  /* Don't need to check as always called from interface function. */
+  AVER(land->inLand);
+  land->inLand = FALSE;
+}
+
+
+/* LandCheck -- check land */
+
+Bool LandCheck(Land land)
+{
+  LandClass klass;
+  /* .enter-leave.simple */
+  CHECKS(Land, land);
+  CHECKC(Land, land);
+  klass = ClassOfPoly(Land, land);
+  CHECKD(LandClass, klass);
+  CHECKU(Arena, land->arena);
+  CHECKL(AlignCheck(land->alignment));
+  CHECKL(BoolCheck(land->inLand));
+  return TRUE;
+}
+
+static Res LandAbsInit(Land land, Arena arena, Align alignment, ArgList args)
+{
+  AVER(land != NULL);
+  AVERT(Arena, arena);
+  AVERT(Align, alignment);
+  UNUSED(args);
+
+  /* Superclass init */
+  InstInit(CouldBeA(Inst, land));
+
+  land->inLand = TRUE;
+  land->alignment = alignment;
+  land->arena = arena;
+
+  SetClassOfPoly(land, CLASS(Land));
+  land->sig = LandSig;
+  AVERC(Land, land);
+
+  return ResOK;
+}
+
+static void LandAbsFinish(Inst inst)
+{
+  Land land = MustBeA(Land, inst);
+  AVERC(Land, land);
+  land->sig = SigInvalid;
+  NextMethod(Inst, Land, finish)(inst);
+}
+
+
+/* LandInit -- initialize land
+ *
+ * <design/land#.function.init>
+ */
+
+Res LandInit(Land land, LandClass klass, Arena arena, Align alignment, void *owner, ArgList args)
+{
+  Res res;
+
+  AVER(land != NULL);
+  AVERT(LandClass, klass);
+  AVERT(Align, alignment);
+
+  res = klass->init(land, arena, alignment, args);
+  if (res != ResOK)
+    return res;
+
+  EVENT2(LandInit, land, owner);
+  landLeave(land);
+  return ResOK;
+}
+
+
+/* LandFinish -- finish land
+ *
+ * <design/land#.function.finish>
+ */
+
+void LandFinish(Land land)
+{
+  AVERC(Land, land);
+  landEnter(land);
+
+  Method(Inst, land, finish)(MustBeA(Inst, land));
+}
+
+
+/* LandSize -- return the total size of ranges in land
+ *
+ * <design/land#.function.size>
+ */
+
+Size (LandSize)(Land land)
+{
+  /* .enter-leave.simple */
+  AVERC(Land, land);
+
+  return LandSizeMacro(land);
+}
+
+
+/* LandInsert -- insert range of addresses into land
+ *
+ * <design/land#.function.insert>
+ */
+
+Res (LandInsert)(Range rangeReturn, Land land, Range range)
+{
+  Res res;
+
+  AVER(rangeReturn != NULL);
+  AVERC(Land, land);
+  AVERT(Range, range);
+  AVER(RangeIsAligned(range, land->alignment));
+  AVER(!RangeIsEmpty(range));
+  landEnter(land);
+
+  res = LandInsertMacro(rangeReturn, land, range);
+
+  landLeave(land);
+  return res;
+}
+
+
+/* LandInsertSteal -- insert range of addresses into land, possibly
+ * stealing some of the inserted memory to allocate internal data
+ * structures.
+ *
+ * <design/land#.function.insert-steal>
+ */
+
+Res LandInsertSteal(Range rangeReturn, Land land, Range rangeIO)
+{
+  Res res;
+
+  AVER(rangeReturn != NULL);
+  AVERC(Land, land);
+  AVER(rangeReturn != rangeIO);
+  AVERT(Range, rangeIO);
+  AVER(RangeIsAligned(rangeIO, land->alignment));
+  AVER(!RangeIsEmpty(rangeIO));
+
+  landEnter(land);
+
+  res = Method(Land, land, insertSteal)(rangeReturn, land, rangeIO);
+
+  landLeave(land);
+  return res;
+}
+
+
+/* LandDelete -- delete range of addresses from land
+ *
+ * <design/land#.function.delete>
+ */
+
+Res (LandDelete)(Range rangeReturn, Land land, Range range)
+{
+  Res res;
+
+  AVER(rangeReturn != NULL);
+  AVERC(Land, land);
+  AVERT(Range, range);
+  AVER(!RangeIsEmpty(range));
+  AVER(RangeIsAligned(range, land->alignment));
+  landEnter(land);
+
+  res = LandDeleteMacro(rangeReturn, land, range);
+
+  landLeave(land);
+  return res;
+}
+
+
+/* LandDeleteSteal -- delete range of addresses from land, possibly
+ * stealing some memory from the land to allocate internal data
+ * structures.
+ *
+ * <design/land#.function.delete-steal>
+ */
+
+Res LandDeleteSteal(Range rangeReturn, Land land, Range range)
+{
+  Res res;
+
+  AVER(rangeReturn != NULL);
+  AVERC(Land, land);
+  AVERT(Range, range);
+  AVER(!RangeIsEmpty(range));
+  AVER(RangeIsAligned(range, land->alignment));
+  landEnter(land);
+
+  res = Method(Land, land, deleteSteal)(rangeReturn, land, range);
+
+  landLeave(land);
+  return res;
+}
+
+
+/* LandIterate -- iterate over isolated ranges of addresses in land
+ *
+ * <design/land#.function.iterate>
+ */
+
+Bool (LandIterate)(Land land, LandVisitor visitor, void *closure)
+{
+  Bool b;
+  AVERC(Land, land);
+  AVER(FUNCHECK(visitor));
+  landEnter(land);
+
+  b = LandIterateMacro(land, visitor, closure);
+
+  landLeave(land);
+  return b;
+}
+
+
+/* LandIterateAndDelete -- iterate over isolated ranges of addresses
+ * in land, deleting some of them
+ *
+ * <design/land#.function.iterate.and.delete>
+ */
+
+Bool (LandIterateAndDelete)(Land land, LandDeleteVisitor visitor, void *closure)
+{
+  Bool b;
+  AVERC(Land, land);
+  AVER(FUNCHECK(visitor));
+  landEnter(land);
+
+  b = LandIterateAndDeleteMacro(land, visitor, closure);
+
+  landLeave(land);
+  return b;
+}
+
+
+/* LandFindFirst -- find first range of given size
+ *
+ * <design/land#.function.find.first>
+ */
+
+Bool (LandFindFirst)(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  Bool b;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERC(Land, land);
+  AVER(SizeIsAligned(size, land->alignment));
+  AVERT(FindDelete, findDelete);
+  landEnter(land);
+
+  b = LandFindFirstMacro(rangeReturn, oldRangeReturn, land, size, findDelete);
+
+  landLeave(land);
+  return b;
+}
+
+
+/* LandFindLast -- find last range of given size
+ *
+ * <design/land#.function.find.last>
+ */
+
+Bool (LandFindLast)(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  Bool b;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERC(Land, land);
+  AVER(SizeIsAligned(size, land->alignment));
+  AVERT(FindDelete, findDelete);
+  landEnter(land);
+
+  b = LandFindLastMacro(rangeReturn, oldRangeReturn, land, size, findDelete);
+
+  landLeave(land);
+  return b;
+}
+
+
+/* LandFindLargest -- find largest range of at least given size
+ *
+ * <design/land#.function.find.largest>
+ */
+
+Bool (LandFindLargest)(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  Bool b;
+
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERC(Land, land);
+  AVER(SizeIsAligned(size, land->alignment));
+  AVERT(FindDelete, findDelete);
+  landEnter(land);
+
+  b = LandFindLargestMacro(rangeReturn, oldRangeReturn, land, size, findDelete);
+
+  landLeave(land);
+  return b;
+}
+
+
+/* LandFindInSize -- find range of given size in set of zones
+ *
+ * <design/land#.function.find.zones>
+ */
+
+Res (LandFindInZones)(Bool *foundReturn, Range rangeReturn, Range oldRangeReturn, Land land, Size size, ZoneSet zoneSet, Bool high)
+{
+  Res res;
+
+  AVER(foundReturn != NULL);
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERC(Land, land);
+  AVER(SizeIsAligned(size, land->alignment));
+  /* AVER(ZoneSet, zoneSet); */
+  AVERT(Bool, high);
+  landEnter(land);
+
+  res = LandFindInZonesMacro(foundReturn, rangeReturn, oldRangeReturn,
+                             land, size, zoneSet, high);
+
+  landLeave(land);
+  return res;
+}
+
+
+/* LandDescribe -- describe land for debugging
+ *
+ * <design/land#.function.describe>
+ */
+
+Res LandDescribe(Land land, mps_lib_FILE *stream, Count depth)
+{
+  return Method(Inst, land, describe)(MustBeA(Inst, land), stream, depth);
+}
+
+
+/* landFlushVisitor -- visitor for LandFlush.
+ *
+ * closure argument is the destination Land. Attempt to insert the
+ * range into the destination.
+ *
+ * .flush.critical: In manual-allocation-bound programs using MVFF
+ * this is on the critical paths via mps_alloc (and then PoolAlloc,
+ * MVFFAlloc, failoverFind*, LandFlush) and mps_free (and then
+ * MVFFFree, failoverInsert, LandFlush).
+ */
+Bool LandFlushVisitor(Bool *deleteReturn, Land land, Range range,
+                      void *closure)
+{
+  Res res;
+  RangeStruct newRange;
+  Land dest;
+
+  AVER_CRITICAL(deleteReturn != NULL);
+  AVERC_CRITICAL(Land, land);
+  AVERT_CRITICAL(Range, range);
+  AVER_CRITICAL(closure != NULL);
+
+  dest = MustBeA_CRITICAL(Land, closure);
+  res = LandInsert(&newRange, dest, range);
+  if (res == ResOK) {
+    *deleteReturn = TRUE;
+    return TRUE;
+  } else {
+    *deleteReturn = FALSE;
+    return FALSE;
+  }
+}
+
+
+/* LandFlush -- move ranges from src to dest
+ *
+ * <design/land#.function.flush>
+ */
+
+Bool (LandFlush)(Land dest, Land src)
+{
+  AVERC(Land, dest);
+  AVERC(Land, src);
+
+  return LandFlushMacro(dest, src);
+}
+
+
+/* LandClassCheck -- check land class */
+
+Bool LandClassCheck(LandClass klass)
+{
+  CHECKL(InstClassCheck(&klass->instClassStruct));
+  CHECKL(klass->size >= sizeof(LandStruct));
+  CHECKL(FUNCHECK(klass->init));
+  CHECKL(FUNCHECK(klass->insert));
+  CHECKL(FUNCHECK(klass->delete));
+  CHECKL(FUNCHECK(klass->findFirst));
+  CHECKL(FUNCHECK(klass->findLast));
+  CHECKL(FUNCHECK(klass->findLargest));
+  CHECKL(FUNCHECK(klass->findInZones));
+
+  /* Check that land classes override sets of related methods. */
+  CHECKL((klass->init == LandAbsInit)
+         == (klass->instClassStruct.finish == LandAbsFinish));
+  CHECKL((klass->insert == landNoInsert) == (klass->delete == landNoDelete));
+
+  CHECKS(LandClass, klass);
+  return TRUE;
+}
+
+
+static Size landNoSize(Land land)
+{
+  UNUSED(land);
+  NOTREACHED;
+  return 0;
+}
+
+/* LandSlowSize -- generic size method but slow */
+
+static Bool landSizeVisitor(Land land, Range range,
+                            void *closure)
+{
+  Size *size;
+
+  AVERC(Land, land);
+  AVERT(Range, range);
+  AVER(closure != NULL);
+
+  size = closure;
+  *size += RangeSize(range);
+
+  return TRUE;
+}
+
+Size LandSlowSize(Land land)
+{
+  Size size = 0;
+  Bool b = LandIterate(land, landSizeVisitor, &size);
+  AVER(b);
+  return size;
+}
+
+static Res landNoInsert(Range rangeReturn, Land land, Range range)
+{
+  AVER(rangeReturn != NULL);
+  AVERC(Land, land);
+  AVERT(Range, range);
+  return ResUNIMPL;
+}
+
+static Res landNoDelete(Range rangeReturn, Land land, Range range)
+{
+  AVER(rangeReturn != NULL);
+  AVERC(Land, land);
+  AVERT(Range, range);
+  return ResUNIMPL;
+}
+
+static Bool landNoIterate(Land land, LandVisitor visitor, void *closure)
+{
+  AVERC(Land, land);
+  AVER(visitor != NULL);
+  UNUSED(closure);
+  return FALSE;
+}
+
+static Bool landNoIterateAndDelete(Land land, LandDeleteVisitor visitor, void *closure)
+{
+  AVERC(Land, land);
+  AVER(visitor != NULL);
+  UNUSED(closure);
+  return FALSE;
+}
+
+static Bool landNoFind(Range rangeReturn, Range oldRangeReturn, Land land, Size size, FindDelete findDelete)
+{
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERC(Land, land);
+  UNUSED(size);
+  AVERT(FindDelete, findDelete);
+  return ResUNIMPL;
+}
+
+static Res landNoFindInZones(Bool *foundReturn, Range rangeReturn, Range oldRangeReturn, Land land, Size size, ZoneSet zoneSet, Bool high)
+{
+  AVER(foundReturn != NULL);
+  AVER(rangeReturn != NULL);
+  AVER(oldRangeReturn != NULL);
+  AVERC(Land, land);
+  UNUSED(size);
+  UNUSED(zoneSet);
+  AVERT(Bool, high);
+  return ResUNIMPL;
+}
+
+static Res LandAbsDescribe(Inst inst, mps_lib_FILE *stream, Count depth)
+{
+  Land land = CouldBeA(Land, inst);
+  LandClass klass;
+  Res res;
+
+  if (!TESTC(Land, land))
+    return ResPARAM;
+  if (stream == NULL)
+    return ResPARAM;
+
+  res = NextMethod(Inst, Land, describe)(inst, stream, depth);
+  if (res != ResOK)
+    return res;
+
+  klass = ClassOfPoly(Land, land);
+  return WriteF(stream, depth + 2,
+                "class $P (\"$S\")\n",
+                (WriteFP)klass, (WriteFS)ClassName(klass),
+                "arena  $P\n", (WriteFP)land->arena,
+                "align  $U\n", (WriteFU)land->alignment,
+                "inLand $S\n", WriteFYesNo(land->inLand),
+                NULL);
+}
+
+DEFINE_CLASS(Inst, LandClass, klass)
+{
+  INHERIT_CLASS(klass, LandClass, InstClass);
+  AVERT(InstClass, klass);
+}
+
+DEFINE_CLASS(Land, Land, klass)
+{
+  INHERIT_CLASS(&klass->instClassStruct, Land, Inst);
+  klass->instClassStruct.describe = LandAbsDescribe;
+  klass->instClassStruct.finish = LandAbsFinish;
+  klass->size = sizeof(LandStruct);
+  klass->init = LandAbsInit;
+  klass->sizeMethod = landNoSize;
+  klass->insert = landNoInsert;
+  klass->insertSteal = landNoInsert;
+  klass->delete = landNoDelete;
+  klass->deleteSteal = landNoDelete;
+  klass->iterate = landNoIterate;
+  klass->iterateAndDelete = landNoIterateAndDelete;
+  klass->findFirst = landNoFind;
+  klass->findLast = landNoFind;
+  klass->findLargest = landNoFind;
+  klass->findInZones = landNoFindInZones;
+  klass->sig = LandClassSig;
+  AVERT(LandClass, klass);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2014-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/landtest.c

@@ -0,0 +1,680 @@
+/* landtest.c: LAND TEST
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * Test all three Land implementations against duplicate operations on
+ * a bit-table.
+ *
+ * Test the "steal" operations on a CBS.
+ */
+
+#include "cbs.h"
+#include "failover.h"
+#include "freelist.h"
+#include "mpm.h"
+#include "mps.h"
+#include "mpsavm.h"
+#include "mpstd.h"
+#include "poolmfs.h"
+#include "testlib.h"
+
+#include <stdio.h> /* printf */
+
+SRCID(landtest, "$Id$");
+
+
+#define ArraySize ((Size)123456)
+
+/* CBS is much faster than Freelist, so we apply more operations to
+ * the former. */
+#define nCBSOperations ((Size)125000)
+#define nFLOperations ((Size)12500)
+#define nFOOperations ((Size)12500)
+
+static Count NAllocateTried, NAllocateSucceeded, NDeallocateTried,
+  NDeallocateSucceeded;
+
+static int verbose = 0;
+
+typedef struct TestStateStruct {
+  Align align;
+  BT allocTable;
+  Addr block;
+  Size size;
+  Land land;
+} TestStateStruct, *TestState;
+
+typedef struct CheckTestClosureStruct {
+  TestState state;
+  Addr limit;
+  Addr oldLimit;
+} CheckTestClosureStruct, *CheckTestClosure;
+
+
+static Addr (addrOfIndex)(TestState state, Index i)
+{
+  return AddrAdd(state->block, (i * state->align));
+}
+
+
+static Index (indexOfAddr)(TestState state, Addr a)
+{
+  return (Index)(AddrOffset(state->block, a) / state->align);
+}
+
+
+static void describe(TestState state)
+{
+  die(LandDescribe(state->land, mps_lib_get_stdout(), 0), "LandDescribe");
+}
+
+
+static Bool checkVisitor(Land land, Range range, void *closure)
+{
+  Addr base, limit;
+  CheckTestClosure cl = closure;
+
+  testlib_unused(land);
+  Insist(cl != NULL);
+
+  base = RangeBase(range);
+  limit = RangeLimit(range);
+
+  if (base > cl->oldLimit) {
+    Insist(BTIsSetRange(cl->state->allocTable,
+                        indexOfAddr(cl->state, cl->oldLimit),
+                        indexOfAddr(cl->state, base)));
+  } else { /* must be at start of table */
+    Insist(base == cl->oldLimit);
+    Insist(cl->oldLimit == cl->state->block);
+  }
+
+  Insist(BTIsResRange(cl->state->allocTable,
+                      indexOfAddr(cl->state, base),
+                      indexOfAddr(cl->state, limit)));
+
+  cl->oldLimit = limit;
+
+  return TRUE;
+}
+
+static void check(TestState state)
+{
+  CheckTestClosureStruct closure;
+  Bool b;
+
+  closure.state = state;
+  closure.limit = addrOfIndex(state, state->size);
+  closure.oldLimit = state->block;
+
+  b = LandIterate(state->land, checkVisitor, &closure);
+  Insist(b);
+
+  if (closure.oldLimit == state->block)
+    Insist(BTIsSetRange(state->allocTable, 0,
+                        indexOfAddr(state, closure.limit)));
+  else if (closure.limit > closure.oldLimit)
+    Insist(BTIsSetRange(state->allocTable,
+                        indexOfAddr(state, closure.oldLimit),
+                        indexOfAddr(state, closure.limit)));
+  else
+    Insist(closure.oldLimit == closure.limit);
+}
+
+
+static Word fbmRnd(Word limit)
+{
+  /* Not very uniform, but never mind. */
+  return (Word)rnd() % limit;
+}
+
+
+/* nextEdge -- Finds the next transition in the bit table
+ *
+ * Returns the index greater than <base> such that the
+ * range [<base>, <return>) has the same value in the bit table,
+ * and <return> has a different value or does not exist.
+ */
+
+static Index nextEdge(BT bt, Size size, Index base)
+{
+  Index end;
+  Bool baseValue;
+
+  Insist(bt != NULL);
+  Insist(base < size);
+
+  baseValue = BTGet(bt, base);
+
+  for(end = base + 1; end < size && BTGet(bt, end) == baseValue; end++)
+    NOOP;
+
+  return end;
+}
+
+
+/* lastEdge -- Finds the previous transition in the bit table
+ *
+ * Returns the index less than <base> such that the range
+ * [<return>, <base>] has the same value in the bit table,
+ * and <return>-1 has a different value or does not exist.
+ */
+
+static Index lastEdge(BT bt, Size size, Index base)
+{
+  Index end;
+  Bool baseValue;
+
+  Insist(bt != NULL);
+  Insist(base < size);
+
+  baseValue = BTGet(bt, base);
+
+  for(end = base; end > (Index)0 && BTGet(bt, end - 1) == baseValue; end--)
+    NOOP;
+
+  return end;
+}
+
+
+/* randomRange -- picks random range within table
+ *
+ * The function first picks a uniformly distributed <base> within the table.
+ *
+ * It then scans forward a binary exponentially distributed number of
+ * "edges" in the table (that is, transitions between set and reset)
+ * to get <end>. Note that there is a 50% chance that <end> will be
+ * the next edge, a 25% chance it will be the edge after, etc., until
+ * the end of the table.
+ *
+ * Finally it picks a <limit> uniformly distributed in the range
+ * [base+1, limit].
+ *
+ * Hence there is a somewhat better than 50% chance that the range will be
+ * all either set or reset.
+ */
+
+static void randomRange(Addr *baseReturn, Addr *limitReturn, TestState state)
+{
+  Index base;   /* the start of our range */
+  Index end;    /* an edge (i.e. different from its predecessor) */
+                /* after base */
+  Index limit;  /* a randomly chosen value in (base, limit]. */
+
+  base = fbmRnd(state->size);
+
+  do {
+    end = nextEdge(state->allocTable, state->size, base);
+  } while (end < state->size && fbmRnd(2) == 0); /* p=0.5 exponential */
+
+  Insist(end > base);
+
+  limit = base + 1 + fbmRnd(end - base);
+
+  *baseReturn = addrOfIndex(state, base);
+  *limitReturn = addrOfIndex(state, limit);
+}
+
+
+static void allocate(TestState state, Addr base, Addr limit)
+{
+  Res res;
+  Index ib, il;                  /* Indexed for base and limit */
+  Bool isFree;
+  RangeStruct range, oldRange;
+  Addr outerBase, outerLimit;    /* interval containing [ib, il) */
+
+  ib = indexOfAddr(state, base);
+  il = indexOfAddr(state, limit);
+
+  isFree = BTIsResRange(state->allocTable, ib, il);
+
+  NAllocateTried++;
+
+  if (isFree) {
+    outerBase =
+      addrOfIndex(state, lastEdge(state->allocTable, state->size, ib));
+    outerLimit =
+      addrOfIndex(state, nextEdge(state->allocTable, state->size, il - 1));
+  } else {
+    outerBase = outerLimit = NULL;
+  }
+
+  RangeInit(&range, base, limit);
+  res = LandDelete(&oldRange, state->land, &range);
+
+  if (verbose) {
+    printf("allocate: [%p,%p) -- %s\n",
+           (void *)base, (void *)limit, isFree ? "succeed" : "fail");
+    describe(state);
+  }
+
+  if (!isFree) {
+    die_expect((mps_res_t)res, MPS_RES_FAIL,
+               "Succeeded in deleting allocated block");
+  } else { /* isFree */
+    die_expect((mps_res_t)res, MPS_RES_OK,
+               "failed to delete free block");
+    Insist(RangeBase(&oldRange) == outerBase);
+    Insist(RangeLimit(&oldRange) == outerLimit);
+    NAllocateSucceeded++;
+    BTSetRange(state->allocTable, ib, il);
+  }
+}
+
+
+static void deallocate(TestState state, Addr base, Addr limit)
+{
+  Res res;
+  Index ib, il;
+  Bool isAllocated;
+  Addr outerBase = base, outerLimit = limit; /* interval containing [ib, il) */
+  RangeStruct range, freeRange; /* interval returned by the manager */
+
+  ib = indexOfAddr(state, base);
+  il = indexOfAddr(state, limit);
+
+  isAllocated = BTIsSetRange(state->allocTable, ib, il);
+
+  NDeallocateTried++;
+
+  if (isAllocated) {
+    /* Find the free blocks adjacent to the allocated block */
+    if (ib > 0 && !BTGet(state->allocTable, ib - 1)) {
+      outerBase =
+        addrOfIndex(state, lastEdge(state->allocTable, state->size, ib - 1));
+    } else {
+      outerBase = base;
+     }
+
+    if (il < state->size && !BTGet(state->allocTable, il)) {
+      outerLimit =
+        addrOfIndex(state, nextEdge(state->allocTable, state->size, il));
+    } else {
+      outerLimit = limit;
+    }
+  }
+
+  RangeInit(&range, base, limit);
+  res = LandInsert(&freeRange, state->land, &range);
+
+  if (verbose) {
+    printf("deallocate: [%p,%p) -- %s\n",
+           (void *)base, (void *)limit, isAllocated ? "succeed" : "fail");
+    describe(state);
+  }
+
+  if (!isAllocated) {
+    die_expect((mps_res_t)res, MPS_RES_FAIL,
+               "succeeded in inserting non-allocated block");
+  } else { /* isAllocated */
+    die_expect((mps_res_t)res, MPS_RES_OK,
+               "failed to insert allocated block");
+
+    NDeallocateSucceeded++;
+    BTResRange(state->allocTable, ib, il);
+    Insist(RangeBase(&freeRange) == outerBase);
+    Insist(RangeLimit(&freeRange) == outerLimit);
+  }
+}
+
+
+static void find(TestState state, Size size, Bool high, FindDelete findDelete)
+{
+  Bool expected, found;
+  Index expectedBase, expectedLimit;
+  RangeStruct foundRange, oldRange;
+  Addr origBase, origLimit;
+
+  origBase = origLimit = NULL;
+  expected = (high ? BTFindLongResRangeHigh : BTFindLongResRange)
+               (&expectedBase, &expectedLimit, state->allocTable,
+                (Index)0, (Index)state->size, (Count)size);
+
+  if (expected) {
+    origBase = addrOfIndex(state, expectedBase);
+    origLimit = addrOfIndex(state, expectedLimit);
+
+    switch(findDelete) {
+    case FindDeleteNONE:
+      /* do nothing */
+      break;
+    case FindDeleteENTIRE:
+      break;
+    case FindDeleteLOW:
+      expectedLimit = expectedBase + size;
+      break;
+    case FindDeleteHIGH:
+      expectedBase = expectedLimit - size;
+      break;
+    default:
+      cdie(0, "invalid findDelete");
+      break;
+    }
+  }
+
+  found = (high ? LandFindLast : LandFindFirst)
+    (&foundRange, &oldRange, state->land, size * state->align, findDelete);
+
+  if (verbose) {
+    printf("find %s %lu: ", high ? "last" : "first",
+           (unsigned long)(size * state->align));
+    if (expected) {
+      printf("expecting [%p,%p)\n",
+             (void *)addrOfIndex(state, expectedBase),
+             (void *)addrOfIndex(state, expectedLimit));
+    } else {
+      printf("expecting this not to be found\n");
+    }
+    if (found) {
+      printf("  found [%p,%p)\n", (void *)RangeBase(&foundRange),
+             (void *)RangeLimit(&foundRange));
+    } else {
+      printf("  not found\n");
+    }
+  }
+
+  Insist(found == expected);
+
+  if (found) {
+    Insist(expectedBase == indexOfAddr(state, RangeBase(&foundRange)));
+    Insist(expectedLimit == indexOfAddr(state, RangeLimit(&foundRange)));
+
+    if (findDelete != FindDeleteNONE) {
+      Insist(RangeBase(&oldRange) == origBase);
+      Insist(RangeLimit(&oldRange) == origLimit);
+      BTSetRange(state->allocTable, expectedBase, expectedLimit);
+    }
+  }
+}
+
+static void test(TestState state, unsigned n, unsigned operations)
+{
+  Addr base, limit;
+  unsigned i;
+  Size size;
+  Bool high;
+  FindDelete findDelete = FindDeleteNONE;
+
+  BTSetRange(state->allocTable, 0, state->size); /* Initially all allocated */
+  check(state);
+  for(i = 0; i < n; i++) {
+    switch (fbmRnd(operations)) {
+    case 0:
+      randomRange(&base, &limit, state);
+      allocate(state, base, limit);
+      break;
+    case 1:
+      randomRange(&base, &limit, state);
+      deallocate(state, base, limit);
+      break;
+    case 2:
+      size = fbmRnd(state->size / 10) + 1;
+      high = fbmRnd(2) ? TRUE : FALSE;
+      switch(fbmRnd(6)) {
+      default: findDelete = FindDeleteNONE; break;
+      case 3: findDelete = FindDeleteLOW; break;
+      case 4: findDelete = FindDeleteHIGH; break;
+      case 5: findDelete = FindDeleteENTIRE; break;
+      }
+      find(state, size, high, findDelete);
+      break;
+    default:
+      cdie(0, "invalid operation");
+      return;
+    }
+    if ((i + 1) % 1000 == 0)
+      check(state);
+  }
+}
+
+#define testArenaSIZE   (((size_t)4)<<20)
+
+static void test_land(void)
+{
+  static const struct {
+    LandClass (*klass)(void);
+    unsigned operations;
+  } cbsConfig[] = {
+    {CBSClassGet, 2},
+    {CBSFastClassGet, 3},
+    {CBSZonedClassGet, 3},
+  };
+  mps_arena_t mpsArena;
+  Arena arena;
+  TestStateStruct state;
+  void *p;
+  MFSStruct blockPool;
+  CBSStruct cbsStruct;
+  FreelistStruct flStruct;
+  FailoverStruct foStruct;
+  Land cbs = CBSLand(&cbsStruct);
+  Land fl = FreelistLand(&flStruct);
+  Land fo = FailoverLand(&foStruct);
+  Pool mfs = MFSPool(&blockPool);
+  size_t i;
+
+  state.size = ArraySize;
+  state.align = (1 << rnd() % 4) * MPS_PF_ALIGN;
+
+  NAllocateTried = NAllocateSucceeded = NDeallocateTried =
+    NDeallocateSucceeded = 0;
+
+  die(mps_arena_create(&mpsArena, mps_arena_class_vm(), testArenaSIZE),
+      "mps_arena_create");
+  arena = (Arena)mpsArena; /* avoid pun */
+
+  die((mps_res_t)BTCreate(&state.allocTable, arena, state.size),
+      "failed to create alloc table");
+
+  die((mps_res_t)ControlAlloc(&p, arena, (state.size + 1) * state.align),
+      "failed to allocate block");
+  state.block = AddrAlignUp(p, state.align);
+
+  if (verbose) {
+    printf("Allocated block [%p,%p)\n", (void *)state.block,
+           (void *)AddrAdd(state.block, state.size));
+  }
+
+  /* 1. Test CBS */
+
+  for (i = 0; i < NELEMS(cbsConfig); ++i) {
+    MPS_ARGS_BEGIN(args) {
+      die((mps_res_t)LandInit(cbs, cbsConfig[i].klass(), arena, state.align,
+                              NULL, args),
+          "failed to initialise CBS");
+    } MPS_ARGS_END(args);
+    state.land = cbs;
+    test(&state, nCBSOperations, cbsConfig[i].operations);
+    LandFinish(cbs);
+  }
+
+  /* 2. Test Freelist */
+
+  die((mps_res_t)LandInit(fl, CLASS(Freelist), arena, state.align,
+                          NULL, mps_args_none),
+      "failed to initialise Freelist");
+  state.land = fl;
+  test(&state, nFLOperations, 3);
+  LandFinish(fl);
+
+  /* 3. Test CBS-failing-over-to-Freelist (always failing over on
+   * first iteration, never failing over on second; see fotest.c for a
+   * test case that randomly switches fail-over on and off)
+   */
+
+  for (i = 0; i < 2; ++i) {
+      MPS_ARGS_BEGIN(piArgs) {
+        MPS_ARGS_ADD(piArgs, MPS_KEY_MFS_UNIT_SIZE, sizeof(CBSFastBlockStruct));
+        MPS_ARGS_ADD(piArgs, MPS_KEY_EXTEND_BY, ArenaGrainSize(arena));
+        MPS_ARGS_ADD(piArgs, MFSExtendSelf, i != 0);
+        die(PoolInit(mfs, arena, PoolClassMFS(), piArgs), "PoolInit");
+      } MPS_ARGS_END(piArgs);
+
+      MPS_ARGS_BEGIN(args) {
+        MPS_ARGS_ADD(args, CBSBlockPool, mfs);
+        die((mps_res_t)LandInit(cbs, CLASS(CBSFast), arena, state.align,
+                                NULL, args),
+            "failed to initialise CBS");
+      } MPS_ARGS_END(args);
+
+      die((mps_res_t)LandInit(fl, CLASS(Freelist), arena, state.align,
+                              NULL, mps_args_none),
+          "failed to initialise Freelist");
+      MPS_ARGS_BEGIN(args) {
+        MPS_ARGS_ADD(args, FailoverPrimary, cbs);
+        MPS_ARGS_ADD(args, FailoverSecondary, fl);
+        die((mps_res_t)LandInit(fo, CLASS(Failover), arena, state.align,
+                                NULL, args),
+            "failed to initialise Failover");
+      } MPS_ARGS_END(args);
+
+      state.land = fo;
+      test(&state, nFOOperations, 3);
+      LandFinish(fo);
+      LandFinish(fl);
+      LandFinish(cbs);
+      PoolFinish(mfs);
+  }
+
+  ControlFree(arena, p, (state.size + 1) * state.align);
+  mps_arena_destroy(arena);
+
+  printf("Number of allocations attempted: %"PRIuLONGEST"\n",
+         (ulongest_t)NAllocateTried);
+  printf("Number of allocations succeeded: %"PRIuLONGEST"\n",
+         (ulongest_t)NAllocateSucceeded);
+  printf("Number of deallocations attempted: %"PRIuLONGEST"\n",
+         (ulongest_t)NDeallocateTried);
+  printf("Number of deallocations succeeded: %"PRIuLONGEST"\n",
+         (ulongest_t)NDeallocateSucceeded);
+}
+
+static void shuffle(Addr *addr, size_t n)
+{
+  size_t i;
+  for (i = 0; i < n; ++i) {
+    size_t j = rnd() % (n - i);
+    Addr tmp = addr[j];
+    addr[j] = addr[i];
+    addr[i] = tmp;
+  }
+}
+
+static void test_steal(void)
+{
+  mps_arena_t mpsArena;
+  Arena arena;
+  MFSStruct mfs;                /* stores blocks for the CBS */
+  Pool pool = MFSPool(&mfs);
+  CBSStruct cbs;                /* allocated memory land */
+  Land land = CBSLand(&cbs);
+  Addr base;
+  Addr addr[4096];
+  Size grainSize;
+  size_t i, n = NELEMS(addr), stolenInsert = 0, missingDelete = 0;
+
+  MPS_ARGS_BEGIN(args) {
+    die(mps_arena_create_k(&mpsArena, mps_arena_class_vm(), args), "arena");
+  } MPS_ARGS_END(args);
+  arena = (Arena)mpsArena; /* avoid pun */
+  grainSize = ArenaGrainSize(arena);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_MFS_UNIT_SIZE, sizeof(RangeTreeStruct));
+    MPS_ARGS_ADD(args, MPS_KEY_EXTEND_BY, grainSize);
+    MPS_ARGS_ADD(args, MFSExtendSelf, FALSE);
+    die(PoolInit(pool, arena, CLASS(MFSPool), args), "pool");
+  } MPS_ARGS_END(args);
+
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, CBSBlockPool, pool);
+    die(LandInit(land, CLASS(CBS), arena, grainSize, NULL, args),
+        "land");
+  } MPS_ARGS_END(args);
+
+  /* Allocate a range of grains. */
+  die(ArenaAlloc(&base, LocusPrefDefault(), grainSize * n, pool), "alloc");
+  for (i = 0; i < n; ++i)
+    addr[i] = AddrAdd(base, i * grainSize);
+
+  /* Shuffle the grains. */
+  shuffle(addr, n);
+
+  /* Insert grains into the land in shuffled order. */
+  for (i = 0; i < n; ++i) {
+    RangeStruct range, origRange, containingRange;
+    RangeInitSize(&range, addr[i], grainSize);
+    RangeCopy(&origRange, &range);
+    die(LandInsertSteal(&containingRange, land, &range), "steal");
+    if (!RangesEqual(&origRange, &range))
+      ++ stolenInsert;
+  }
+
+  /* Shuffle grains again. */
+  shuffle(addr, n);
+
+  /* Delete unstolen grains from the land in shuffled order. */
+  for (i = 0; i < n; ++i) {
+    RangeStruct range, containingRange;
+    Res res;
+    RangeInitSize(&range, addr[i], grainSize);
+    res = LandDeleteSteal(&containingRange, land, &range);
+    if (res == ResOK) {
+      ArenaFree(addr[i], grainSize, pool);
+    } else {
+      Insist(res == ResFAIL);     /* grain was stolen */
+      ++ missingDelete;
+    }
+  }
+
+  Insist(LandSize(land) == 0);
+  LandFinish(land);
+  Insist(PoolFreeSize(pool) == PoolTotalSize(pool));
+  PoolFinish(pool);
+  mps_arena_destroy(arena);
+  Insist(stolenInsert <= missingDelete);
+  Insist(missingDelete < n);
+  printf("Stolen on insert: %"PRIuLONGEST"\n", (ulongest_t)stolenInsert);
+  printf("Missing on delete: %"PRIuLONGEST"\n", (ulongest_t)missingDelete);
+}
+
+int main(int argc, char *argv[])
+{
+  testlib_init(argc, argv);
+  test_land();
+  test_steal();
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/ld.c

@@ -0,0 +1,352 @@
+/* ld.c: LOCATION DEPENDENCY IMPLEMENTATION
+ *
+ * $Id$
+ * Copyright (c) 2001-2020 Ravenbrook Limited.  See end of file for license.
+ *
+ * .def: A location dependency records the fact that the bit-patterns
+ * of some references will be used directly (most likely for
+ * hashing), and provides a protocol for finding out whether that
+ * dependency has become stale because a reference has been changed (by
+ * a moving memory manager).
+ *
+ * .rationale: The client may build hash-tables using pointer hashing.
+ * The collector may change the values of the pointers transparently,
+ * by fixing them and moving the objects.  The hash function will no
+ * longer return the same value, and the object can't be found in
+ * the expected bucket.  When the client can't find an object in a
+ * hashtable it must check to see if any of the references in the table
+ * have moved, and rehash if they have.  Location dependency provides
+ * a reasonably accurate way of determining whether this has happened.
+ *
+ * .impl: A location dependency consists of an epoch (monotonically
+ * increasing notion of time) and a reference set.  The epoch records
+ * when the location dependency started, and the reference set
+ * accumulates an approximation to the set of references which are
+ * depended on.  The client can check to see if any of these
+ * references have moved since the epoch.
+ *
+ * .history: The current epoch, and a history of object movement
+ * are recorded in the arena.  Each slot in the history contains a
+ * summary of all the movement since an earlier epoch (maintained by
+ * LDAge).  To see if a dependency has become stale all that
+ * is needed is to see whether its reference set intersects with the
+ * movement since its epoch.
+ *
+ * .mod: LDHistoryLENGTH is used as a modulus to calculate the offset
+ * of an epoch in the history, so it's best if this is a power of two.
+ * <code/mpmconf.h>
+ *
+ * .epoch-size: The epoch should probably be a longer integer to avoid
+ * the possibility of overflow.
+ * (32 bits only gives 50 days at 1ms frequency)
+ *
+ * .ld.access: Accesses (reads and writes) to the ld structure must be
+ * "wrapped" with an ShieldExpose/Cover pair if and only if the access
+ * is taking place inside the arena.  Currently this is only the case for
+ * LDReset.
+ */
+
+#include "mpm.h"
+
+SRCID(ld, "$Id$");
+
+
+void HistoryInit(History history)
+{
+  Index i;
+
+  AVER(history != NULL);
+
+  history->epoch = 0;
+  history->prehistory = RefSetEMPTY;
+  for (i = 0; i < LDHistoryLENGTH; ++i)
+    history->history[i] = RefSetEMPTY;
+
+  history->sig = HistorySig;
+  AVERT(History, history);
+}
+
+Bool HistoryCheck(History history)
+{
+  Index i;
+  RefSet rs;
+
+  CHECKS(History, history);
+
+  /* check that each history entry is a subset of the next oldest */
+  rs = RefSetEMPTY;
+  /* note this loop starts from 1; there is no history age 0 */
+  for (i = 1; i <= LDHistoryLENGTH; ++i) {
+    /* check history age 'i'; 'j' is the history index. */
+    Index j = (history->epoch + LDHistoryLENGTH - i) % LDHistoryLENGTH;
+    CHECKL(RefSetSub(rs, history->history[j]));
+    rs = history->history[j];
+  }
+  /* the oldest history entry must be a subset of the prehistory */
+  CHECKL(RefSetSub(rs, history->prehistory));
+
+  return TRUE;
+}
+
+void HistoryFinish(History history)
+{
+  AVERT(History, history);
+  history->sig = SigInvalid;
+}
+
+Res HistoryDescribe(History history, mps_lib_FILE *stream, Count depth)
+{
+  Res res;
+  Index i;
+
+  if (!TESTT(History, history))
+    return ResPARAM;
+  if (stream == NULL)
+    return ResPARAM;
+
+  res = WriteF(stream, depth,
+               "History $P {\n",      (WriteFP)history,
+               "  epoch      = $U\n", (WriteFU)history->epoch,
+               "  prehistory = $B\n", (WriteFB)history->prehistory,
+               "  history {\n",
+               "    [note: indices are raw, not rotated]\n",
+               NULL);
+  if (res != ResOK)
+    return res;
+
+  for (i = 0; i < LDHistoryLENGTH; ++i) {
+    res = WriteF(stream, depth + 4,
+                 "[$U] = $B\n", (WriteFU)i, (WriteFB)history->history[i],
+                 NULL);
+    if (res != ResOK)
+      return res;
+  }
+
+  res = WriteF(stream, depth,
+               "  }\n",
+               "} History $P\n", (WriteFP)history,
+               NULL);
+  if (res != ResOK)
+    return res;
+
+  return ResOK;
+}
+
+
+/* LDReset -- reset a dependency to empty
+ *
+ * .reset.sync: This does not need to be synchronized with LDAge
+ * because if the epoch advances after it is read the dependency
+ * will simply include movement for more time than necessary.
+ */
+void LDReset(mps_ld_t ld, Arena arena)
+{
+  Bool b;
+  Seg seg;
+
+  AVER(ld != NULL);
+  AVERT(Arena, arena);
+
+  b = SegOfAddr(&seg, arena, (Addr)ld);
+  if (b)
+    ShieldExpose(arena, seg);   /* .ld.access */
+  ld->_epoch = ArenaHistory(arena)->epoch;
+  ld->_rs = RefSetEMPTY;
+  if (b)
+    ShieldCover(arena, seg);
+}
+
+
+/* LDAdd -- add a reference to a dependency
+ *
+ * .add.lock-free:  This function is thread safe with respect to the
+ * (rest of the) mps.  It is unnecessary to claim locks before calling
+ * this function.
+ *
+ * .add.user-serial:
+ * However, this function is _not_ thread safe with respect to itself.
+ * Users should ensure that calls to LDAdd operating on the same LD are
+ * serialized.
+ *
+ * .add.sync: Add must take place _before_ the location of the reference
+ * is depended on.  If the reference changes between adding and
+ * depending it will show up as moved because the movement will have
+ * occurred since the epoch recorded in the dependency.  If the location
+ * were used first only the new location of the reference would end up
+ * in the set.
+ *
+ * .add.no-arena-check: Add does not check that the address belongs to
+ * the arena because this would require taking the arena lock. We
+ * would rather that this function be lock-free even if some errors
+ * are not detected.
+ *
+ * .add.no-align-check: Add does not check that the address is
+ * aligned, for the same reason as .add.check: it can't find out which
+ * pool the address belongs to without taking the lock.
+ */
+void LDAdd(mps_ld_t ld, Arena arena, Addr addr)
+{
+  AVER(ld != NULL);
+  AVER(TESTT(Arena, arena)); /* see .add.lock-free */
+  AVER(ld->_epoch <= ArenaHistory(arena)->epoch);
+
+  ld->_rs = RefSetAdd(arena, ld->_rs, addr);
+}
+
+
+/* LDIsStaleAny -- check whether any dependency is stale
+ *
+ * .stale.thread-safe: This function is thread safe.  It will return a
+ * correct (but possibly conservative) answer regardless of the number
+ * of calls to LDAge anywhere during the function. Update with care.
+ *
+ * .stale.current: If the dependency's epoch is the current epoch,
+ * nothing can have moved since it was initialized.
+ *
+ * .stale.recent: If the dependency is recent, see if it intersects
+ * with everything which has moved since it was initialized.
+ *
+ * .stale.recent.conservative: The refset from the history table is
+ * loaded before we check whether ld->_epoch is "recent" with respect to
+ * the current epoch.  This means that we may (conservatively) decide
+ * to use the prehistory instead.
+ *
+ * .stale.old: Otherwise, if the dependency is older than the length
+ * of the history, check it against all movement that has ever occurred.
+ */
+Bool LDIsStaleAny(mps_ld_t ld, Arena arena)
+{
+  History history;
+  RefSet rs;
+
+  AVER(ld != NULL);
+  AVER(TESTT(Arena, arena)); /* .stale.thread-safe */
+  history = ArenaHistory(arena);
+  AVER(ld->_epoch <= history->epoch);
+
+  if (history->epoch == ld->_epoch) /* .stale.current */
+    return FALSE;
+
+  /* Load the history refset, _then_ check to see if it's recent.
+   * This may in fact load an okay refset, which we decide to throw
+   * away and use the pre-history instead. */
+  rs = history->history[ld->_epoch % LDHistoryLENGTH];
+  /* .stale.recent */
+  /* .stale.recent.conservative */
+  if (history->epoch - ld->_epoch > LDHistoryLENGTH) {
+    rs = history->prehistory;     /* .stale.old */
+  }
+
+  return RefSetInter(ld->_rs, rs) != RefSetEMPTY;
+}
+
+
+/* LDIsStale -- check whether a particular dependency is stale
+ *
+ * .stale.conservative: In fact we just ignore the address and test if
+ * any dependency is stale. This is conservatively correct (no false
+ * negatives) but provides a hook for future improvement.
+ *
+ * .stale.no-arena-check: See .add.no-arena-check.
+ *
+ * .stale.no-align-check: See .add.no-align-check.
+ */
+Bool LDIsStale(mps_ld_t ld, Arena arena, Addr addr)
+{
+  UNUSED(addr);
+  return LDIsStaleAny(ld, arena);
+}
+
+
+/* LDAge -- age the arena by adding a moved set
+ *
+ * This stores the fact that a set of references has changed in
+ * the history in the arena structure, and increments the epoch.
+ *
+ * This is only called during a 'flip', because it must be atomic
+ * w.r.t. the mutator (and therefore w.r.t. LdIsStale). This is
+ * because it updates the notion of the 'current' and 'oldest' history
+ * entries.
+ */
+void LDAge(Arena arena, RefSet rs)
+{
+  History history;
+  Size i;
+
+  AVERT(Arena, arena);
+  history = ArenaHistory(arena);
+  AVER(rs != RefSetEMPTY);
+
+  /* Replace the entry for epoch - LDHistoryLENGTH by an empty */
+  /* set which will become the set which has moved since the */
+  /* current epoch. */
+  history->history[history->epoch % LDHistoryLENGTH] = RefSetEMPTY;
+
+  /* Record the fact that the moved set has moved, by adding it */
+  /* to all the sets in the history, including the set for the */
+  /* current epoch. */
+  for(i = 0; i < LDHistoryLENGTH; ++i)
+    history->history[i] = RefSetUnion(history->history[i], rs);
+
+  /* This is the union of all movement since time zero. */
+  history->prehistory = RefSetUnion(history->prehistory, rs);
+
+  /* Advance the epoch by one. */
+  ++history->epoch;
+  AVER(history->epoch != 0);      /* .epoch-size */
+}
+
+
+/* LDMerge -- merge two location dependencies
+ *
+ * .merge.lock-free:  This function is thread-safe with respect to the
+ * (rest of the) MPS.  It is unnecessary to claim locks before calling
+ * this function.
+ */
+void LDMerge(mps_ld_t ld, Arena arena, mps_ld_t from)
+{
+  AVER(ld != NULL);
+  AVER(TESTT(Arena, arena)); /* .merge.lock-free */
+  AVER(ld->_epoch <= ArenaHistory(arena)->epoch);
+  AVER(from != NULL);
+  AVER(from->_epoch <= ArenaHistory(arena)->epoch);
+
+  /* If a reference has been added since epoch e1 then I've */
+  /* certainly added since epoch e0 where e0 < e1.  Therefore */
+  /* the epoch of the merged ld is the minimum. */
+  if (from->_epoch < ld->_epoch)
+    ld->_epoch = from->_epoch;
+
+  /* The set of references added is the union of the two. */
+  ld->_rs = RefSetUnion(ld->_rs, from->_rs);
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. 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.
+ */

mps/code/lia6gc.gmk

@@ -0,0 +1,55 @@
+# -*- makefile -*-
+#
+# lia6gc.gmk: BUILD FOR LINUX/ARM64/GCC PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2021 Ravenbrook Limited.  See end of file for license.
+
+PFM = lia6gc
+
+MPMPF = \
+    lockix.c \
+    prmcanan.c \
+    prmcix.c \
+    prmclia6.c \
+    protix.c \
+    protsgix.c \
+    pthrdext.c \
+    span.c \
+    thix.c \
+    vmix.c
+
+LIBS = -lm -lpthread
+
+include gc.gmk
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2021 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+

mps/code/lia6ll.gmk

@@ -0,0 +1,55 @@
+# -*- makefile -*-
+#
+# lia6ll.gmk: BUILD FOR LINUX/ARM64/Clang PLATFORM
+#
+# $Id$
+# Copyright (c) 2001-2021 Ravenbrook Limited.  See end of file for license.
+
+PFM = lia6ll
+
+MPMPF = \
+    lockix.c \
+    prmcanan.c \
+    prmcix.c \
+    prmclia6.c \
+    protix.c \
+    protsgix.c \
+    pthrdext.c \
+    span.c \
+    thix.c \
+    vmix.c
+
+LIBS = -lm -lpthread
+
+include ll.gmk
+include comm.gmk
+
+
+# C. COPYRIGHT AND LICENSE
+#
+# Copyright (C) 2001-2021 Ravenbrook Limited <https://www.ravenbrook.com/>.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions and the following disclaimer.
+#
+# 2. 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.
+