commit 6e3afa5896f5a80f29d74571264b3c9181af478d
parent 4f47e5195fd5a10f3630ea9f8ade52bcbaf3b7b8
Author: James Eversole <james@eversole.co>
Date: Sat, 24 Oct 2026 15:00:36 -0500
Add compact Haskell core embedding and accept native GHC 9.14.1
Share the reducer boundary between core/full hosts. Link PIC Haskell archives with a C-only export map and section GC for a 1.87-MiB core package. Retain dynamic baseline, lifecycle/ownership/codec controls and paired linkage smokes.
Native GHC upgrade uses three narrow dependency-bound adjustments and an upstream sandwich completion-race backport, retaining tests. Validated flake checks, native embedding/bindings, both consumer demos, storage and registry acceptance, and development-shell compiler. Browser/WASM and static-musl toolchain selections remain independent.
Diffstat:
22 files changed, 998 insertions(+), 301 deletions(-)
diff --git a/docs/build-and-run.md b/docs/build-and-run.md
@@ -4,7 +4,11 @@ Run these commands from the extracted tricu directory. You need [Nix](https://ni
with flakes enabled. Native development uses the Haskell host; builds and tests
run through Nix. The [native Haskell C interface](../ext/haskell/README.md)
provides embedding through C, Python, [native JavaScript](../ext/js/README.md),
-and [PHP](../ext/php/README.md). The [Zig runtime and owned-handle C ABI](../ext/zig/README.md)
+and [PHP](../ext/php/README.md). A [core-only C prototype](../ext/haskell/README.md#core-only-prototype)
+provides lazy tree reduction and value codecs for applications with their own IO:
+`nix build .#tricu-core-archive --no-link`. This x86-64 Linux variant links PIC
+Haskell archives into the shared object; `tricu-core` retains the dynamic-library
+baseline. The [Zig runtime and owned-handle C ABI](../ext/zig/README.md)
have their own Nix validation targets. The
[cross-runtime reproduction workflow](compiler-rebuilding.md.html#isolated-cross-runtime-fixed-point-reproduction)
verifies identical compiler generations on Haskell and Zig.
diff --git a/ext/haskell/BoundaryTests.hs b/ext/haskell/BoundaryTests.hs
@@ -1,11 +1,18 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- Inject bottoms through the Haskell-side registry, never a production C hook.
module Main where
-import qualified Embedding as E
+import qualified EmbeddingCore as E
+#ifndef CORE_ONLY
+import qualified Embedding as Host
+#endif
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent
-import Runtime (T(..), ofString, ofNumber)
+import Runtime.Tree (T(..))
+#ifndef CORE_ONLY
+import Runtime.Value (ofString, ofNumber)
+#endif
import Foreign
import Data.Word
import Control.Exception (evaluate)
@@ -35,16 +42,19 @@ main = alloca $ \ctxOut -> alloca $ \out -> do
value <- peek out
E.toU64 ctx value out >>= assert . (== 0)
peek out >>= assert . (== (0 :: Word64))
+
+#ifndef CORE_ONLY
-- Terminal task diagnostics remain opaque across the native boundary.
E.withContext ctx (E.publish out
(Fork (ofString "tricuIO") (Fork (ofNumber 2)
(Fork (ofNumber 2) (error "opaque diagnostic"))))) >>= assert . (== 0)
program <- peek out
alloca $ \tag -> alloca $ \reason -> alloca $ \cleanup -> do
- E.runIO ctx program tag reason cleanup >>= assert . (== 0)
+ Host.runIO ctx program tag reason cleanup >>= assert . (== 0)
peek tag >>= assert . (== 1)
failed <- peek reason
E.reduce ctx failed out >>= assert . (== 5)
+#endif
-- An interrupted call restores the context lock and contains its exception.
entered <- newEmptyMVar
done <- newEmptyMVar
diff --git a/ext/haskell/README.md b/ext/haskell/README.md
@@ -34,12 +34,120 @@ compiled copier, failure cleanup and transferred-resource cancellation in all
three languages.
Native embedding is validated on x86-64 Linux with the pinned Nix/GHC toolchain.
+The native CLI, embedding and development compiler select GHC 9.14.1;
+the static-musl and browser/WASM targets retain their separate toolchain selections.
The artifact installs `lib/libtricu-haskell.so`, `include/tricu.h`, and
`share/tricu/tricu.py`. On Linux its Haskell shared-library dependencies are
installed beside it; native dependencies retain their Nix runtime paths. Keep the
complete Nix closure available. Copying just the main `.so` is insufficient.
Other native targets and browser/WASM embedding require their own acceptance.
+## Core-only prototype
+
+`tricu-core` provides the common C surface in
+[`include/tricu-core.h`](include/tricu-core.h): contexts, owned handles, tree
+constructors, lazy application/reduction, constructor inspection, number/boolean/
+byte/UTF-8 codecs, and boundary diagnostics. Application and observation have the
+same demand behavior as the full host. The host application supplies its own IO;
+this artifact has neither bundle loading nor a tricu IO entrypoint.
+
+```sh
+nix build .#tricu-core .#tricu-core-archive .#tricu-haskell-ffi --no-link
+CORE=$(nix path-info .#tricu-core)
+ARCHIVE=$(nix path-info .#tricu-core-archive)
+EMBED=$(nix path-info .#tricu-haskell-ffi)
+python3 ext/haskell/footprint.py --core "$CORE" --host "$EMBED" \
+ --archive "$ARCHIVE" --output /tmp/tricu-runtime-footprint.json
+```
+
+Both core artifacts install `lib/libtricu-core.so` and `include/tricu-core.h`.
+`tricu-core` includes its dynamic Haskell dependencies alongside it.
+`tricu-core-archive` incorporates the required Haskell code and threaded RTS into
+one shared object, exporting the documented C API. It uses PIC archives from a
+GHC build configured with `enableRelocatedStaticLibs`, an ELF export map and
+unused-section collection. Native system libraries remain dynamic. Its first
+build requires a source build of GHC and its bundled libraries; profiling-library
+and documentation variants are omitted from that build. Normal compilation
+remains `-O2`, using the same reducer and complete core interface.
+
+These are C-only prototypes; the existing Python/JS/PHP bindings target the full
+host. `tricu.h` includes the common header and adds bundle/IO declarations.
+Choose **one artifact per process**: all variants provide the same common symbol
+names and own the same process-wide GHC initialization contract. Handles are not transferable between library instances.
+All lifecycle, pointer, ownership, serialization and resource-limit rules below
+apply to both variants.
+
+The split is a source/build dependency boundary. `EmbeddingCore` imports
+`Runtime.Tree` and `Runtime.Value` directly; the full `Embedding` module extends
+that same boundary with the bundle verifier and IO driver. Both use the exact
+same reducer, registry, codecs and initialization code. The core build compiles
+only these three Haskell modules. `src/core.exports` keeps the archive-linked
+artifact's public surface at the common C API. GHC 9.14 archive linkage explicitly
+roots `init_ghc_hs_iface`, matching GHC's executable-link startup interface rule.
+The linker checks both position independence and complete symbol resolution.
+
+The footprint script reports main-library bytes, installed package file/NAR
+sizes, full runtime closure NAR size, package tar.gz size, and gzip-compressed
+Nix closure export size. Compression uses level 6. The package archive requires
+the external runtime paths to remain available; it is not a standalone portable
+archive. The closure export includes entire transitive native packages and is a
+Nix distribution, not a universal native installer. Shared dependencies can
+already exist on a consumer's system, so closure totals are not necessarily
+incremental installation costs. None of these measurements describes resident
+memory. Sizes depend on the pinned platform/toolchain and dependency graph.
+
+All three artifacts run the same linked C ownership, codec and reduction-rule checks,
+Haskell bottom/discard/exception/concurrency controls, and installed-header/client
+checks. Linux builds also test repeated dlopen/dlclose. Fresh-process symbol checks
+require bundle/IO exports only in the host; the trimmed archive artifact also
+checks its complete exported symbol set. `nix flake check` includes the dynamic
+core and full host. The archive build and its comparison smoke are opt-in; the
+full host additionally retains its installed Python and IO tests.
+
+```sh
+nix build .#tricu-core-linkage-smoke --no-link
+SMOKE=$(nix path-info .#tricu-core-linkage-smoke)
+cat "$SMOKE/summary.json"
+```
+
+The comparison calls the same public C API in separate processes. Each workload
+creates fresh constant/distribution application chains, releases temporary roots,
+demands the result, and checks the complete result is `Leaf`. Graph-construction
+and weak-head-demand times are separate; one warmup precedes seven measured
+rounds at each size. Timings and peak RSS are observations without speed
+thresholds. These two finite workloads are performance smokes, not general
+application benchmarks. Installed `share/tricu/build.json` records GHC version
+and linkage for each artifact.
+
+### Archive-link readiness probe (x86-64 Linux)
+
+A shared library linked from Haskell archives requires position-independent
+objects throughout its Haskell dependency graph, including the threaded RTS.
+The diagnostic target exercises the ordinary non-PIC compiler's prerequisite
+failure with the same core sources,
+C interface and ordinary `-O2` settings:
+
+```sh
+nix build .#tricu-core-archive-probe --no-link
+PROBE=$(nix path-info .#tricu-core-archive-probe)
+cat "$PROBE/report.json"
+gzip -dc "$PROBE/link.log.gz" | head -40
+```
+
+The report distinguishes a successful link from recognized non-PIC archive
+failures; unrelated compiler/linker errors fail the diagnostic build. It records
+the exact command and affected archive names. Its output is diagnostic evidence,
+not an installable or accepted runtime. A link success additionally runs the C
+client and export checks; installed packaging, lifecycle, and performance
+acceptance are separate requirements. A blocked link has no size or performance
+measurement.
+
+Nixpkgs' `enableRelocatedStaticLibs` GHC build option supplies PIC compilation for
+static libraries. Using it requires rebuilding the compiler's bundled libraries
+and RTS, plus PIC-compatible archives for any separately built dependencies.
+Passing `-fPIC` when compiling tricu itself changes only tricu's objects; it does
+not change prebuilt package archives.
+
## Python example
The library artifact installs `share/tricu/tricu.py`. The `tricu-python` Nix
@@ -190,7 +298,11 @@ authenticates the receipt, requires byte-identical program bundles, and executes
the result as `41` through the library.
Reports include small-call and bulk-codec timings and fresh-process compiler-job
-timings. These are correctness smokes with measurements, not speed thresholds or
+timings. The supervised compiler comparison sets `MALLOC_ARENA_MAX=2` for both
+subprocesses so glibc's per-thread arena reservations fit alongside GHC/Python
+under the FFI child's 1-GiB address-space limit. The CPU/time limits remain 120
+seconds. The allocator setting is process-local to these test jobs. These are
+correctness smokes with measurements, not speed thresholds or
isolated reducer comparisons: the CLI also imports packaged compiler data and
packages its program bundle. Nix may reuse reports; rerun the tracked Python
scripts against built artifacts for fresh observations. The compiler probe is an
diff --git a/ext/haskell/archive-probe.nix b/ext/haskell/archive-probe.nix
@@ -0,0 +1,16 @@
+# Diagnostic output, not an accepted embedding artifact. Run through Nix only.
+{ pkgs, source, haskellPackages ? pkgs.haskellPackages }:
+let
+ ghc = haskellPackages.ghcWithPackages (p: [ p.mtl ]);
+in pkgs.runCommand "tricu-core-archive-probe" {
+ nativeBuildInputs = [ ghc pkgs.python3 pkgs.stdenv.cc ];
+ meta.platforms = [ "x86_64-linux" ];
+} ''
+ mkdir -p ext/haskell objects $out
+ cp -r ${source}/src .
+ cp -r ${source}/ext/haskell/src ${source}/ext/haskell/include ext/haskell/
+ cp ${source}/ext/haskell/tests.c ${source}/ext/haskell/test_exports.py ext/haskell/
+ chmod -R u+w src ext
+ export PYTHONDONTWRITEBYTECODE=1
+ timeout 120s python3 ${./archive_probe.py} --output $out
+''
diff --git a/ext/haskell/archive_probe.py b/ext/haskell/archive_probe.py
@@ -0,0 +1,106 @@
+#!/usr/bin/env python3
+"""Probe the pinned archives' readiness for a C-loadable core shared library.
+
+Invoked by archive-probe.nix with the same reducer/API sources and ordinary -O2
+settings as build.nix. A recognized non-PIC link failure is diagnostic data;
+unrelated build errors fail the derivation. A successful link is not installed
+or presented as an accepted runtime: packaging/lifecycle/performance acceptance
+remains separate.
+"""
+import argparse
+from collections import Counter
+import gzip
+import json
+from pathlib import Path
+import re
+import subprocess
+import sys
+
+
+def classify(returncode, log):
+ if returncode == 0:
+ return 'link-succeeded'
+ errors = [line for line in log.splitlines() if 'error:' in line]
+ def known_error(line):
+ return bool(re.search(r'error: .*\.a\(.*(?:recompile with -fPIC|unsupported reloc \d+ against global symbol)', line)
+ or re.search(r'collect2: error: ld returned \d+ exit status', line))
+ if (re.search(r'error: .*\.a\([^\n]+recompile with -fPIC', log)
+ and all(known_error(line) for line in errors)):
+ return 'blocked-non-pic-archives'
+ raise RuntimeError('Archive probe failed for an unclassified reason; inspect its build log')
+
+
+def main():
+ # Reject ordinary compile failures and mixed-cause link failures rather than
+ # misreporting every unsuccessful build as a known toolchain limitation.
+ assert classify(0, '') == 'link-succeeded'
+ example = 'ld.gold: error: /tmp/libHSx.a(X.o): recompile with -fPIC'
+ assert classify(1, example) == 'blocked-non-pic-archives'
+ for bad in ('Main.hs: error: missing name', example + '\nld: error: undefined symbol'):
+ try:
+ classify(1, bad)
+ except RuntimeError:
+ pass
+ else:
+ raise AssertionError('unrelated failure accepted')
+ parser = argparse.ArgumentParser(description=__doc__)
+ parser.add_argument('--output', required=True, type=Path)
+ args = parser.parse_args()
+ args.output.mkdir(parents=True, exist_ok=True)
+ command = [
+ 'ghc', '-O2', '-static', '-shared', '-fPIC', '-flink-rts', '-threaded',
+ '-optl-Wl,-z,nodelete',
+ '-XOverloadedStrings', '-XScopedTypeVariables', '-XMultiWayIf', '-XLambdaCase',
+ '-Wall', '-isrc', '-iext/haskell/src', '-outputdir', 'objects',
+ '-optc-Iext/haskell/include',
+ 'ext/haskell/src/EmbeddingCore.hs', 'ext/haskell/src/init.c',
+ '-o', 'libtricu-core.so',
+ ]
+ ghc_version = subprocess.check_output(['ghc', '--numeric-version'], text=True).strip()
+ if tuple(map(int, ghc_version.split('.')[:2])) >= (9, 14):
+ command.insert(1, '-optl-Wl,-u,init_ghc_hs_iface')
+ result = subprocess.run(command, stdout=subprocess.PIPE, stderr=subprocess.STDOUT)
+ log = result.stdout.decode('utf-8', errors='replace')
+ # Keep full diagnostics compressed rather than filling the console with tens
+ # of thousands of repeated relocation errors. They are not runtime data.
+ with gzip.GzipFile(args.output / 'link.log.gz', 'wb', mtime=1) as stream:
+ stream.write(result.stdout)
+ try:
+ status = classify(result.returncode, log)
+ except RuntimeError:
+ print(log[-16000:], file=sys.stderr)
+ raise
+ errors = [line for line in log.splitlines() if 'error:' in line and 'recompile with -fPIC' in line]
+ archives = Counter(name for line in errors for name in re.findall(r'/([^/ ]+\.a)\(', line))
+ report = {
+ 'schema': 'tricu.core-archive-probe.v1',
+ 'ghc_version': ghc_version,
+ 'link_status': status,
+ 'link_exit_code': result.returncode,
+ 'command': command,
+ 'non_pic_archives': dict(sorted(archives.items())),
+ 'relocation_examples': [re.sub(r'/nix/store/[^ ]+?/(libHS[^ ]+\.a|bin/ld.gold)', r'\1', line)
+ for line in errors[:3]],
+ 'runtime_artifact_accepted': False,
+ 'size_and_performance_measured': False,
+ }
+ if status == 'link-succeeded':
+ # Immediate ABI sanity checks; full installed-runtime and timing checks
+ # are deliberately not inferred from a successful linker invocation.
+ subprocess.run([
+ 'cc', '-Wall', '-Wextra', '-Werror', 'ext/haskell/tests.c',
+ '-Iext/haskell/include', '-L.', '-ltricu-core',
+ '-Wl,-rpath,' + str(Path.cwd()), '-o', 'core-client',
+ ], check=True)
+ subprocess.run(['./core-client'], check=True)
+ subprocess.run([sys.executable, 'ext/haskell/test_exports.py',
+ './libtricu-core.so', 'core'], check=True)
+ report['c_client_and_exports'] = 'passed'
+ else:
+ report['c_client_and_exports'] = 'not-run-link-blocked'
+ (args.output / 'report.json').write_text(json.dumps(report, indent=2) + '\n')
+ print(json.dumps(report, indent=2))
+
+
+if __name__ == '__main__':
+ main()
diff --git a/ext/haskell/build.nix b/ext/haskell/build.nix
@@ -1,11 +1,15 @@
-{ pkgs, source }:
+{ pkgs, source, coreOnly ? false, haskellPackages ? pkgs.haskellPackages, archiveHaskell ? false, trimArchive ? archiveHaskell }:
+assert !archiveHaskell || coreOnly;
+assert !trimArchive || archiveHaskell;
let
- ghc = pkgs.haskellPackages.ghcWithPackages (p: [
+ libraryName = if coreOnly then "tricu-core" else "tricu-haskell";
+ entryModule = if coreOnly then "EmbeddingCore" else "Embedding";
+ ghc = haskellPackages.ghcWithPackages (p: if coreOnly then [ p.mtl ] else [
p.aeson p.base16-bytestring p.cryptonite p.memory p.vector
p.network p.stm p.temporary p.mtl
]);
in pkgs.stdenv.mkDerivation {
- pname = "tricu-haskell-embedding";
+ pname = "${libraryName}${pkgs.lib.optionalString archiveHaskell "-archive"}-embedding";
version = "2026.10.24";
src = source;
nativeBuildInputs = [ ghc pkgs.python3 ]
@@ -13,54 +17,80 @@ in pkgs.stdenv.mkDerivation {
buildPhase = ''
runHook preBuild
mkdir -p objects
- ghc -O2 -dynamic -shared -fPIC -flink-rts -threaded \
+ # GHC 9.14's executable linker roots the RTS-to-Haskell startup interface;
+ # shared archive linkage needs the same root to resolve the archive cycle.
+ ghc -O2 ${if archiveHaskell then "-static" else "-dynamic"} -shared -fPIC -flink-rts -threaded \
${pkgs.lib.optionalString pkgs.stdenv.hostPlatform.isLinux "-optl-Wl,-z,nodelete"} \
+ ${pkgs.lib.optionalString archiveHaskell "-optl-Wl,-z,text -optl-Wl,-z,defs"} \
+ ${pkgs.lib.optionalString trimArchive "-optl-Wl,--version-script=ext/haskell/src/core.exports -optl-Wl,--gc-sections"} \
+ ${pkgs.lib.optionalString (archiveHaskell && pkgs.lib.versionAtLeast haskellPackages.ghc.version "9.14") "-optl-Wl,-u,init_ghc_hs_iface"} \
-XOverloadedStrings -XScopedTypeVariables -XMultiWayIf -XLambdaCase \
-Wall -isrc -iext/haskell/src -outputdir objects \
-optc-Iext/haskell/include \
- ext/haskell/src/Embedding.hs ext/haskell/src/init.c \
- -o libtricu-haskell${pkgs.stdenv.hostPlatform.extensions.sharedLibrary}
+ ext/haskell/src/${entryModule}.hs ext/haskell/src/init.c \
+ -o lib${libraryName}${pkgs.stdenv.hostPlatform.extensions.sharedLibrary}
runHook postBuild
'';
+ meta = pkgs.lib.optionalAttrs archiveHaskell { platforms = [ "x86_64-linux" ]; };
doCheck = true;
checkPhase = ''
runHook preCheck
- ghc -O2 -dynamic -threaded \
+ ghc -O2 ${if archiveHaskell then "-static" else "-dynamic"} -fPIC -threaded ${pkgs.lib.optionalString coreOnly "-DCORE_ONLY"} \
-XOverloadedStrings -XScopedTypeVariables -XMultiWayIf -XLambdaCase \
-isrc -iext/haskell/src -outputdir boundary-objects \
ext/haskell/BoundaryTests.hs -o boundary-tests
timeout 30s ./boundary-tests
$CC -Wall -Wextra -Werror ext/haskell/tests.c -Iext/haskell/include \
- -L. -ltricu-haskell -Wl,-rpath,$PWD -o c-embedding-tests
+ -L. -l${libraryName} -Wl,-rpath,$PWD -o c-embedding-tests
GHCRTS=--tricu-test-invalid timeout 30s ./c-embedding-tests
${pkgs.lib.optionalString pkgs.stdenv.hostPlatform.isLinux ''
$CC -Wall -Wextra -Werror ext/haskell/reload.c -Iext/haskell/include -ldl -o reload-tests
- timeout 30s ./reload-tests "$PWD/libtricu-haskell.so"
+ timeout 30s ./reload-tests "$PWD/lib${libraryName}.so"
''}
+ python3 ext/haskell/test_exports.py ./lib${libraryName}${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} ${if coreOnly then "core" else "host"} ${pkgs.lib.optionalString trimArchive "public-only"}
+ ${pkgs.lib.optionalString (!coreOnly) ''
PYTHONDONTWRITEBYTECODE=1 PYTHONPATH=ext/haskell/python timeout 60s python3 ext/haskell/test_embedding.py \
- ./libtricu-haskell${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} test/fixtures > embedding-report.json
+ ./lib${libraryName}${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} test/fixtures > embedding-report.json
cat embedding-report.json
PYTHONDONTWRITEBYTECODE=1 PYTHONPATH=ext/haskell/python timeout 30s python3 \
- ext/haskell/test_scopes.py ./libtricu-haskell${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} test/fixtures
+ ext/haskell/test_scopes.py ./lib${libraryName}${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} test/fixtures
+ ''}
runHook postCheck
'';
installPhase = ''
runHook preInstall
mkdir -p $out/lib $out/include $out/share/tricu
- cp libtricu-haskell* $out/lib/
- cp ext/haskell/include/tricu.h $out/include/
+ cp lib${libraryName}* $out/lib/
+ cp ext/haskell/include/tricu-core.h $out/include/
+ printf '{"ghc_version":"%s","haskell_linkage":"${if archiveHaskell then "archive" else "dynamic"}","core_only":${if coreOnly then "true" else "false"},"public_symbols_only":${if trimArchive then "true" else "false"}}\n' \
+ "$(ghc --numeric-version)" > $out/share/tricu/build.json
+ ${pkgs.lib.optionalString (!coreOnly) ''
+ cp ext/haskell/include/tricu.h $out/include/''}
+ ${pkgs.lib.optionalString (!coreOnly) ''
cp ext/haskell/python/tricu.py $out/share/tricu/
- cp embedding-report.json $out/share/tricu/
+ cp embedding-report.json $out/share/tricu/''}
${pkgs.lib.optionalString pkgs.stdenv.hostPlatform.isLinux ''
- python3 ext/haskell/package_runtime.py $out/lib/libtricu-haskell.so
+ python3 ext/haskell/package_runtime.py $out/lib/lib${libraryName}.so
''}
runHook postInstall
'';
# Verify the installed runtime paths in a fresh foreign process, too.
doInstallCheck = true;
installCheckPhase = ''
+ ${pkgs.lib.optionalString archiveHaskell ''
+ if ldd $out/lib/lib${libraryName}.so | grep -q libHS; then
+ echo "archive-linked library retained Haskell shared dependencies" >&2
+ exit 1
+ fi
+ ''}
+ $CC -Wall -Wextra -Werror ext/haskell/tests.c -I$out/include \
+ -L$out/lib -l${libraryName} -Wl,-rpath,$out/lib -o installed-core-tests
+ GHCRTS=--tricu-test-invalid timeout 30s ./installed-core-tests
+ python3 ext/haskell/test_exports.py $out/lib/lib${libraryName}${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} ${if coreOnly then "core" else "host"} ${pkgs.lib.optionalString trimArchive "public-only"}
+ ${pkgs.lib.optionalString (!coreOnly) ''
PYTHONDONTWRITEBYTECODE=1 PYTHONPATH=$out/share/tricu timeout 60s python3 \
ext/haskell/test_embedding.py \
- $out/lib/libtricu-haskell${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} test/fixtures
+ $out/lib/lib${libraryName}${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} test/fixtures
+ ''}
'';
}
diff --git a/ext/haskell/compiler_probe.py b/ext/haskell/compiler_probe.py
@@ -7,6 +7,7 @@ also imports packaged compiler data and packages the application bundle.
import argparse
import hashlib
import json
+import os
from pathlib import Path
import re
import resource
@@ -71,7 +72,7 @@ def main():
ffi_store, cli_store = directory/'ffi-store', directory/'cli-store'
ffi_store.mkdir()
cli_bundle, ffi_bundle = directory/'cli.arboricx', directory/'ffi.arboricx'
- reports = {}
+ reports = {'allocator': 'MALLOC_ARENA_MAX=2 for both subprocesses; FFI RLIMIT_AS=1 GiB, RLIMIT_CPU=120 seconds'}
for name in ('cli', 'ffi'):
start = time.perf_counter()
if name == 'cli':
@@ -81,10 +82,16 @@ def main():
else:
command = [sys.executable, Path(__file__).resolve(), args.library, args.compiler,
'--child', '--source', source, '--store', ffi_store]
+ # Bound glibc's per-thread arena reservations in this supervised job;
+ # GHC and Python share the child's unchanged 1-GiB address-space limit.
+ environment = dict(os.environ, MALLOC_ARENA_MAX='2')
completed = subprocess.run(list(map(str, command)), text=True,
stdout=subprocess.PIPE, stderr=subprocess.PIPE,
- timeout=120, check=True)
+ timeout=120, check=False, env=environment)
(directory/(name+'.log')).write_text(completed.stdout+completed.stderr)
+ if completed.returncode:
+ print(f'{name} compiler subprocess failed:\n{completed.stdout}{completed.stderr}', file=sys.stderr)
+ completed.check_returncode()
reports[name] = dict(process_seconds=time.perf_counter()-start)
if name == 'ffi':
reports[name].update(json.loads(completed.stdout))
diff --git a/ext/haskell/core_bench.c b/ext/haskell/core_bench.c
@@ -0,0 +1,74 @@
+#define _POSIX_C_SOURCE 200809L
+/* Same public C calls for both linkages. Fresh suspensions each round; timing
+ * separates ABI/graph construction from demanding the completed reduction. */
+#include "tricu-core.h"
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <sys/resource.h>
+
+static double now(void) {
+ struct timespec ts;
+ assert(clock_gettime(CLOCK_MONOTONIC, &ts) == 0);
+ return (double)ts.tv_sec + (double)ts.tv_nsec / 1e9;
+}
+static tricu_handle node(tricu_context ctx, tricu_handle a, tricu_handle b) {
+ tricu_handle out;
+ assert(tricu_fork(ctx, a, b, &out) == TRICU_OK);
+ return out;
+}
+static void drop(tricu_context ctx, tricu_handle h) {
+ assert(tricu_release(ctx, h) == TRICU_OK);
+}
+int main(int argc, char **argv) {
+ assert(argc == 3);
+ const int distribution = strcmp(argv[1], "distribution") == 0;
+ assert(distribution || strcmp(argv[1], "constant") == 0);
+ const unsigned long n = strtoul(argv[2], NULL, 10);
+ assert(n > 0 && n <= 1048576);
+ tricu_init();
+ /* Warm up once; all seven measured rounds create independent graphs. */
+ for (int round = -1; round < 7; ++round) {
+ tricu_context ctx;
+ tricu_handle leaf, term;
+ assert(tricu_context_new(&ctx) == TRICU_OK);
+ assert(tricu_leaf(ctx, &leaf) == TRICU_OK);
+ assert(tricu_retain(ctx, leaf, &term) == TRICU_OK);
+ const double begin = now();
+ for (unsigned long i = 0; i < n; ++i) {
+ tricu_handle k = node(ctx, leaf, term), fn = k, next;
+ if (distribution) {
+ /* S (K (K previous)) t t = previous. Exercises distribution
+ * while retaining a known complete result without a codec. */
+ tricu_handle kk = node(ctx, leaf, k), skk;
+ assert(tricu_stem(ctx, kk, &skk) == TRICU_OK);
+ fn = node(ctx, skk, leaf);
+ drop(ctx, kk);
+ drop(ctx, skk);
+ }
+ assert(tricu_apply(ctx, fn, leaf, &next) == TRICU_OK);
+ if (distribution) drop(ctx, fn);
+ drop(ctx, k);
+ drop(ctx, term);
+ term = next;
+ }
+ const double built = now();
+ tricu_handle reduced;
+ assert(tricu_reduce(ctx, term, &reduced) == TRICU_OK);
+ const double demanded = now();
+ uint32_t kind = 987;
+ assert(tricu_kind(ctx, reduced, &kind) == TRICU_OK && kind == TRICU_LEAF);
+ drop(ctx, reduced);
+ drop(ctx, term);
+ drop(ctx, leaf);
+ assert(tricu_context_free(ctx) == TRICU_OK);
+ struct rusage usage;
+ assert(getrusage(RUSAGE_SELF, &usage) == 0);
+ if (round >= 0) printf("{\"kind\":\"%s\",\"size\":%lu,\"round\":%d,"
+ "\"build_seconds\":%.9f,\"reduce_seconds\":%.9f,\"peak_rss_kib\":%ld}\n",
+ argv[1], n, round, built-begin, demanded-built, usage.ru_maxrss);
+ }
+ return 0;
+}
diff --git a/ext/haskell/core_bench.py b/ext/haskell/core_bench.py
@@ -0,0 +1,36 @@
+#!/usr/bin/env python3
+"""Fresh-process C ABI linkage smoke; timings are observations, not thresholds."""
+import argparse
+import json
+from pathlib import Path
+import statistics
+import subprocess
+
+parser = argparse.ArgumentParser(description=__doc__)
+parser.add_argument('--dynamic', required=True)
+parser.add_argument('--archive', required=True)
+parser.add_argument('--output', required=True, type=Path)
+args = parser.parse_args()
+rows = []
+summary = []
+for index, (kind, size) in enumerate((kind, size) for kind in ('constant', 'distribution')
+ for size in (4096, 65536)):
+ roles = ('dynamic', 'archive') if index % 2 == 0 else ('archive', 'dynamic')
+ for role in roles:
+ result = subprocess.run([getattr(args, role), kind, str(size)], check=True,
+ text=True, capture_output=True, timeout=180)
+ assert not result.stderr, result.stderr
+ observed = [json.loads(line) for line in result.stdout.splitlines()]
+ assert len(observed) == 7
+ assert [row['round'] for row in observed] == list(range(7))
+ assert all(row['kind'] == kind and row['size'] == size for row in observed)
+ rows.extend(dict(role=role, **row) for row in observed)
+ summary.append(dict(role=role, kind=kind, size=size,
+ build_median_seconds=statistics.median(row['build_seconds'] for row in observed),
+ reduce_median_seconds=statistics.median(row['reduce_seconds'] for row in observed),
+ peak_rss_kib=max(row['peak_rss_kib'] for row in observed)))
+args.output.write_text(json.dumps(dict(
+ schema='tricu.core-linkage-smoke.v1',
+ scope='Same public C API, fresh graphs, separate graph-build and WHNF-demand timings; no speed threshold',
+ samples=rows, summary=summary), indent=2) + '\n')
+print(json.dumps(summary, indent=2))
diff --git a/ext/haskell/footprint.py b/ext/haskell/footprint.py
@@ -0,0 +1,76 @@
+#!/usr/bin/env python3
+"""Compare installed Linux artifacts; Nix and tar are measurement-time tools only."""
+import argparse
+import json
+from pathlib import Path
+import subprocess
+import tempfile
+import zlib
+
+
+def compressed_bytes(command):
+ """Count a gzip level-6 stream without retaining/exporting the archive."""
+ compressor = zlib.compressobj(level=6, wbits=31)
+ size = 0
+ with tempfile.TemporaryFile() as errors:
+ with subprocess.Popen(command, stdout=subprocess.PIPE, stderr=errors) as process:
+ while chunk := process.stdout.read(1024 * 1024):
+ size += len(compressor.compress(chunk))
+ size += len(compressor.flush())
+ if process.wait():
+ errors.seek(0)
+ raise RuntimeError(errors.read().decode('utf-8', errors='replace'))
+ return size
+
+
+def measure(path, name):
+ path = path.resolve(strict=True)
+ library = path / 'lib' / name
+ assert library.is_file(), library
+ closure = json.loads(subprocess.check_output(
+ ['nix', 'path-info', '--json', '--json-format', '1', '--recursive', str(path)], text=True))
+ if isinstance(closure, list):
+ closure = {row['path']: row for row in closure}
+ haskell = sorted((path / 'lib').glob('libHS*.so'))
+ return {
+ 'store_path': str(path),
+ 'build': json.loads((path / 'share/tricu/build.json').read_text()) if (path / 'share/tricu/build.json').exists() else None,
+ 'main_library_bytes': library.stat().st_size,
+ 'package_file_bytes': sum(p.stat().st_size for p in path.rglob('*') if p.is_file()),
+ 'package_nar_bytes': closure[str(path)]['narSize'],
+ 'closure_nar_bytes': sum(row['narSize'] for row in closure.values()),
+ 'package_tar_gzip6_bytes': compressed_bytes([
+ 'tar', '--sort=name', '--mtime=@1', '--owner=0', '--group=0',
+ '--numeric-owner', '-C', str(path), '-cf', '-', '.']),
+ 'closure_nix_export_gzip6_bytes': compressed_bytes([
+ 'nix-store', '--export', *sorted(closure)]),
+ 'haskell_libraries': {p.name: p.stat().st_size for p in haskell},
+ 'native_closure': {p: row['narSize'] for p, row in closure.items() if p != str(path)},
+ }
+
+
+def main():
+ parser = argparse.ArgumentParser(description=__doc__)
+ parser.add_argument('--core', required=True, type=Path)
+ parser.add_argument('--host', required=True, type=Path)
+ parser.add_argument('--archive', type=Path)
+ parser.add_argument('--output', required=True, type=Path)
+ args = parser.parse_args()
+ report = {
+ 'method': 'installed files; Nix NAR sizes; deterministic tar and Nix export gzip level 6',
+ 'core': measure(args.core, 'libtricu-core.so'),
+ 'host': measure(args.host, 'libtricu-haskell.so'),
+ }
+ if args.archive:
+ report['archive'] = measure(args.archive, 'libtricu-core.so')
+ args.output.write_text(json.dumps(report, indent=2, sort_keys=True) + '\n')
+ for role in ('core', 'host', *(['archive'] if args.archive else [])):
+ row = report[role]
+ print(role + ': ' + ', '.join(
+ f'{key}={row[key] / 1048576:.2f} MiB' for key in (
+ 'main_library_bytes', 'package_nar_bytes', 'closure_nar_bytes',
+ 'package_tar_gzip6_bytes', 'closure_nix_export_gzip6_bytes')))
+
+
+if __name__ == '__main__':
+ main()
diff --git a/ext/haskell/include/tricu-core.h b/ext/haskell/include/tricu-core.h
@@ -0,0 +1,58 @@
+#ifndef TRICU_CORE_H
+#define TRICU_CORE_H
+#include <stddef.h>
+#include <stdint.h>
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Common C surface for the core and full host artifacts; choose one per process.
+ * Core Haskell embedding ABI 1. See ext/haskell/README.md for lifecycle,
+ * demand, concurrency and resource limits. Every output is unchanged on failure.
+ * All pointers must be valid; distinct output parameters must not overlap.
+ * Input buffers are borrowed for the call; NULL is allowed only at length zero.
+ * Every successful handle output owns one root; inputs are borrowed. */
+typedef uint64_t tricu_context;
+typedef uint64_t tricu_handle;
+typedef uint32_t tricu_status;
+enum {
+ TRICU_OK = 0, TRICU_INVALID_CONTEXT = 1, TRICU_INVALID_HANDLE = 2,
+ TRICU_INVALID_DATA = 3, TRICU_TYPE_ERROR = 4,
+ TRICU_EXCEPTION = 5, TRICU_ID_EXHAUSTED = 6
+};
+enum { TRICU_LEAF = 0, TRICU_STEM = 1, TRICU_FORK = 2 };
+
+/* Call once before other entrypoints; repeated calls are harmless. Owns RTS
+ * initialization: use in a process that has not already initialized GHC.
+ * Keep the library loaded until process exit. No shutdown entrypoint. */
+void tricu_init(void);
+uint32_t tricu_abi_version(void);
+tricu_status tricu_context_new(tricu_context *out);
+tricu_status tricu_context_free(tricu_context ctx);
+tricu_status tricu_retain(tricu_context ctx, tricu_handle value, tricu_handle *out);
+tricu_status tricu_release(tricu_context ctx, tricu_handle value);
+tricu_status tricu_leaf(tricu_context ctx, tricu_handle *out);
+tricu_status tricu_stem(tricu_context ctx, tricu_handle child, tricu_handle *out);
+tricu_status tricu_fork(tricu_context ctx, tricu_handle left, tricu_handle right, tricu_handle *out);
+/* Application constructs a suspension; reduce demands only its outer constructor.
+ * Inspection and decoding also demand the portions they observe. */
+tricu_status tricu_apply(tricu_context ctx, tricu_handle fn, tricu_handle arg, tricu_handle *out);
+tricu_status tricu_reduce(tricu_context ctx, tricu_handle value, tricu_handle *out);
+tricu_status tricu_kind(tricu_context ctx, tricu_handle value, uint32_t *out);
+tricu_status tricu_child(tricu_context ctx, tricu_handle value, uint32_t index, tricu_handle *out);
+tricu_status tricu_from_u64(tricu_context ctx, uint64_t value, tricu_handle *out);
+tricu_status tricu_to_bool(tricu_context ctx, tricu_handle value, uint32_t *out);
+tricu_status tricu_to_u64(tricu_context ctx, tricu_handle value, uint64_t *out);
+tricu_status tricu_from_bytes(tricu_context ctx, const uint8_t *bytes, size_t len, tricu_handle *out);
+tricu_status tricu_from_utf8(tricu_context ctx, const uint8_t *bytes, size_t len, tricu_handle *out);
+tricu_status tricu_to_bytes(tricu_context ctx, tricu_handle value, uint8_t **out, size_t *len);
+tricu_status tricu_to_utf8(tricu_context ctx, tricu_handle value, uint8_t **out, size_t *len);
+/* Last boundary error, retained across successes. UTF-8, length-delimited.
+ * Empty initially. Returned buffers are independent of contexts and must be freed
+ * exactly once with tricu_buffer_free, including empty buffers. */
+tricu_status tricu_last_error(tricu_context ctx, uint8_t **out, size_t *len);
+void tricu_buffer_free(uint8_t *buffer);
+#ifdef __cplusplus
+}
+#endif
+#endif
diff --git a/ext/haskell/include/tricu.h b/ext/haskell/include/tricu.h
@@ -1,52 +1,12 @@
#ifndef TRICU_H
#define TRICU_H
-#include <stddef.h>
-#include <stdint.h>
+#include "tricu-core.h"
#ifdef __cplusplus
extern "C" {
#endif
-/* Native Haskell embedding ABI 1. See ext/haskell/README.md for lifecycle,
- * demand, concurrency and resource limits. Every output is unchanged on failure.
- * All pointers must be valid; distinct output parameters must not overlap.
- * Input buffers are borrowed for the call; NULL is allowed only at length zero.
- * Every successful handle output owns one root; inputs are borrowed. */
-typedef uint64_t tricu_context;
-typedef uint64_t tricu_handle;
-typedef uint32_t tricu_status;
-enum {
- TRICU_OK = 0, TRICU_INVALID_CONTEXT = 1, TRICU_INVALID_HANDLE = 2,
- TRICU_INVALID_DATA = 3, TRICU_TYPE_ERROR = 4,
- TRICU_EXCEPTION = 5, TRICU_ID_EXHAUSTED = 6
-};
-enum { TRICU_LEAF = 0, TRICU_STEM = 1, TRICU_FORK = 2 };
enum { TRICU_COMPLETED = 0, TRICU_FAILED = 1, TRICU_CANCELLED = 2 };
-/* Call once before other entrypoints; repeated calls are harmless. Owns RTS
- * initialization: use in a process that has not already initialized GHC.
- * Keep the library loaded until process exit. No shutdown entrypoint. */
-void tricu_init(void);
-uint32_t tricu_abi_version(void);
-tricu_status tricu_context_new(tricu_context *out);
-tricu_status tricu_context_free(tricu_context ctx);
-tricu_status tricu_retain(tricu_context ctx, tricu_handle value, tricu_handle *out);
-tricu_status tricu_release(tricu_context ctx, tricu_handle value);
-tricu_status tricu_leaf(tricu_context ctx, tricu_handle *out);
-tricu_status tricu_stem(tricu_context ctx, tricu_handle child, tricu_handle *out);
-tricu_status tricu_fork(tricu_context ctx, tricu_handle left, tricu_handle right, tricu_handle *out);
-/* Application constructs a suspension; reduce demands only its outer constructor.
- * Inspection and decoding also demand the portions they observe. */
-tricu_status tricu_apply(tricu_context ctx, tricu_handle fn, tricu_handle arg, tricu_handle *out);
-tricu_status tricu_reduce(tricu_context ctx, tricu_handle value, tricu_handle *out);
-tricu_status tricu_kind(tricu_context ctx, tricu_handle value, uint32_t *out);
-tricu_status tricu_child(tricu_context ctx, tricu_handle value, uint32_t index, tricu_handle *out);
-tricu_status tricu_from_u64(tricu_context ctx, uint64_t value, tricu_handle *out);
-tricu_status tricu_to_bool(tricu_context ctx, tricu_handle value, uint32_t *out);
-tricu_status tricu_to_u64(tricu_context ctx, tricu_handle value, uint64_t *out);
-tricu_status tricu_from_bytes(tricu_context ctx, const uint8_t *bytes, size_t len, tricu_handle *out);
-tricu_status tricu_from_utf8(tricu_context ctx, const uint8_t *bytes, size_t len, tricu_handle *out);
-tricu_status tricu_to_bytes(tricu_context ctx, tricu_handle value, uint8_t **out, size_t *len);
-tricu_status tricu_to_utf8(tricu_context ctx, tricu_handle value, uint8_t **out, size_t *len);
/* Verified Arboricx bundle; explicit UTF-8 export name, no implicit selection. */
tricu_status tricu_load_bundle(tricu_context ctx, const uint8_t *bytes, size_t len,
const uint8_t *name, size_t name_len, tricu_handle *out);
@@ -55,11 +15,6 @@ tricu_status tricu_load_bundle(tricu_context ctx, const uint8_t *bytes, size_t l
* cleanup is a list of IO-v2 problems. All three outputs publish atomically. */
tricu_status tricu_run_io(tricu_context ctx, tricu_handle program,
uint32_t *outcome, tricu_handle *value, tricu_handle *cleanup);
-/* Last boundary error, retained across successes. UTF-8, length-delimited.
- * Empty initially. Returned buffers are independent of contexts and must be freed
- * exactly once with tricu_buffer_free, including empty buffers. */
-tricu_status tricu_last_error(tricu_context ctx, uint8_t **out, size_t *len);
-void tricu_buffer_free(uint8_t *buffer);
#ifdef __cplusplus
}
#endif
diff --git a/ext/haskell/patches/sandwich-introduce-with-completion.patch b/ext/haskell/patches/sandwich-introduce-with-completion.patch
@@ -0,0 +1,19 @@
+Backport the introduceWith completion-order fix present in sandwich 0.3.1.0.
+The inner exception handler settles child context failures; the outer runner
+publishes the parent's final annotated result after handling the exception.
+This keeps waitForTree from observing the intermediate, unannotated failure.
+Upstream tests, including the diagnostic-message assertion, remain unchanged.
+
+https://hackage.haskell.org/package/sandwich-0.3.1.0/changelog
+https://hackage-content.haskell.org/package/sandwich-0.3.1.0/src/src/Test/Sandwich/Interpreters/StartTree.hs
+
+--- a/src/Test/Sandwich/Interpreters/StartTree.hs
++++ b/src/Test/Sandwich/Interpreters/StartTree.hs
+@@ -129,7 +129,5 @@
+ let handler e = do
+- recordExceptionInStatus runTreeStatus e
+-
+ liftIO (readIORef didAllocateVar) >>= \case
+ False -> do
+ -- We didn't successfully allocate, so mark the children below this point as failed due to a
+ -- context issue.
diff --git a/ext/haskell/reload.c b/ext/haskell/reload.c
@@ -1,4 +1,4 @@
-#include "tricu.h"
+#include "tricu-core.h"
#include <assert.h>
#include <dlfcn.h>
#include <stdint.h>
diff --git a/ext/haskell/src/Embedding.hs b/ext/haskell/src/Embedding.hs
@@ -1,211 +1,21 @@
{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE ScopedTypeVariables #-}
--- Native boundary only: evaluation and IO live in the existing host modules.
-module Embedding where
+{-# LANGUAGE OverloadedStrings #-}
+-- Host extension to the shared core boundary; both artifacts use one reducer.
+module Embedding (module Embedding, module EmbeddingCore) where
-import Control.Concurrent.MVar
-import Control.Exception
-import Control.Monad (unless)
+import EmbeddingCore
import Control.Monad.State.Strict
-import Data.IORef
-import qualified Data.Map.Strict as M
import qualified Data.Map.Lazy as L
-import qualified Data.ByteString as BS
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
import qualified Data.Vector as V
import Data.Word
-import Foreign hiding (void, toBool)
+import Foreign
import Foreign.C.Types
-import System.IO.Unsafe (unsafePerformIO)
-import Runtime hiding (toBytes)
-import qualified Runtime.Value as Value
+import Runtime.Value (ofList)
import qualified Wire
import qualified IODriver
import qualified IOV2.Driver as IO
import qualified IOV2.Protocol as Protocol
--- A process-wide nonreusing namespace covers contexts AND roots. No raw stable
--- pointer crosses the boundary; released, foreign and stale IDs are map misses.
-{-# NOINLINE identities #-}
-identities :: IORef Integer
-identities = unsafePerformIO (newIORef 1)
-{-# NOINLINE contexts #-}
-contexts :: MVar (M.Map Word64 (MVar (Maybe Context)))
-contexts = unsafePerformIO (newMVar M.empty)
--- Force map updates while keeping their tree values lazy: release removes the
--- root now, and application publication never forces the suspended computation.
-data Context = Context { roots :: !(L.Map Word64 T), lastError :: !BS.ByteString }
-data Fault = Fault Word32 String deriving Show
-instance Exception Fault
-
-boundaryStatus :: SomeException -> IO Word32
-boundaryStatus e = pure $ case fromException e of
- Just (Fault code _) -> code
- Nothing -> 5
-
-type Call = StateT Context IO
-fault :: Word32 -> String -> IO a
-fault code message = throwIO (Fault code message)
-require :: Bool -> String -> IO ()
-require condition message = unless condition (fault 3 message)
-newIdentity :: IO Word64
-newIdentity = do
- n <- atomicModifyIORef' identities (\n -> (n+1,n))
- if n > toInteger (maxBound :: Word64) then fault 6 "identity namespace exhausted"
- else pure (fromInteger n)
-
--- Context locking serializes lazy evaluation as well as registry changes.
--- Destroy marks the cell closed before removing its name; racing lookups cannot
--- resurrect it. Exceptions roll back root-table publication, not IO effects or
--- evaluation already performed on shared Haskell thunks.
-withContext :: Word64 -> Call (IO ()) -> IO Word32
-withContext identity action = handle boundaryStatus $ mask $ \restore -> do
- found <- withMVar contexts (pure . M.lookup identity)
- case found of
- Nothing -> pure 1
- Just cell -> modifyMVar cell $ \current -> case current of
- Nothing -> pure (Nothing, 1)
- Just context -> do
- result <- try $ do
- (commit, updated) <- restore (runStateT action context)
- commit
- pure updated
- case result of
- Right updated -> pure (Just updated, 0)
- Left (e :: SomeException) -> do
- let (code, message) = case fromException e of
- Just (Fault c m) -> (c,m)
- Nothing -> (5, displayException e)
- -- Force bounded diagnostic bytes inside the exception handler.
- let bytes = Text.encodeUtf8 (Text.pack (take 4096 message))
- _ <- evaluate (BS.length bytes)
- pure (Just context {lastError = bytes}, code)
-
-lookupRoot :: Word64 -> Call T
-lookupRoot identity = do
- table <- gets roots
- maybe (liftIO (fault 2 "invalid or foreign handle")) pure (L.lookup identity table)
-publish :: Ptr Word64 -> T -> Call (IO ())
-publish out tree = do
- liftIO (require (out /= nullPtr) "null output")
- identity <- liftIO newIdentity
- modify' (\c -> c { roots = L.insert identity tree (roots c) })
- pure (poke out identity)
-readBytes :: Ptr Word8 -> CSize -> IO BS.ByteString
-readBytes ptr len = do
- require (toInteger len <= toInteger (maxBound :: Int)) "buffer too large"
- require (ptr /= nullPtr || len == 0) "null input buffer"
- if len == 0 then pure BS.empty else BS.packCStringLen (castPtr ptr, fromIntegral len)
-checked :: Word32 -> Either String a -> IO a
-checked code = either (fault code) pure
-readText :: Ptr Word8 -> CSize -> IO Text.Text
-readText ptr len = readBytes ptr len >>= checked 3 . either (Left . show) Right . Text.decodeUtf8'
-outputBuffer :: Ptr (Ptr Word8) -> Ptr CSize -> BS.ByteString -> IO ()
-outputBuffer out len bytes = do
- require (out /= nullPtr && len /= nullPtr && castPtr out /= len) "invalid buffer outputs"
- -- Allocate even for empty output, giving every successful buffer one owner.
- bracketOnError (mallocBytes (max 1 (BS.length bytes))) free $ \ptr -> do
- BS.useAsCStringLen bytes $ \(source,n) -> copyBytes ptr (castPtr source) n
- poke out ptr
- poke len (fromIntegral (BS.length bytes))
-
-abiVersion :: IO Word32
-abiVersion = pure 1
-contextNew :: Ptr Word64 -> IO Word32
-contextNew out = handle boundaryStatus $ mask_ $ do
- if out == nullPtr then pure 3 else do
- identity <- newIdentity
- cell <- newMVar (Just (Context L.empty BS.empty))
- modifyMVar_ contexts (pure . M.insert identity cell)
- poke out identity
- pure 0
-contextFree :: Word64 -> IO Word32
-contextFree identity = handle boundaryStatus $ mask_ $ do
- found <- withMVar contexts (pure . M.lookup identity)
- case found of
- Nothing -> pure 1
- Just cell -> do
- status <- modifyMVar cell $ \current -> pure (Nothing, maybe 1 (const 0) current)
- modifyMVar_ contexts (pure . M.delete identity)
- pure status
-retain :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-retain ctx value out = withContext ctx (lookupRoot value >>= publish out)
-release :: Word64 -> Word64 -> IO Word32
-release ctx value = withContext ctx $ do
- _ <- lookupRoot value
- modify' (\c -> c {roots = L.delete value (roots c)})
- pure (pure ())
-leaf :: Word64 -> Ptr Word64 -> IO Word32
-leaf ctx out = withContext ctx (publish out Leaf)
-stem :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-stem ctx value out = withContext ctx (lookupRoot value >>= publish out . Stem)
-binary :: (T -> T -> T) -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
-binary constructor ctx left right out = withContext ctx $ do
- a <- lookupRoot left
- b <- lookupRoot right
- publish out (constructor a b)
-fork, application :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
-fork = binary Fork
-application = binary apply
-reduce :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-reduce ctx value out = withContext ctx $ do
- liftIO (require (out /= nullPtr) "null output")
- tree <- lookupRoot value >>= liftIO . evaluate
- publish out tree
-kind :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
-kind ctx value out = withContext ctx $ do
- liftIO (require (out /= nullPtr) "null output")
- tree <- lookupRoot value
- tag <- liftIO $ evaluate $ case tree of Leaf -> 0; Stem _ -> 1; Fork _ _ -> 2
- pure (poke out tag)
-child :: Word64 -> Word64 -> Word32 -> Ptr Word64 -> IO Word32
-child ctx value index out = withContext ctx $ do
- tree <- lookupRoot value
- case (tree,index) of
- (Stem a,0) -> publish out a
- (Fork a _,0) -> publish out a
- (Fork _ b,1) -> publish out b
- _ -> liftIO (fault 4 "constructor has no such child")
-fromU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-fromU64 ctx n out = withContext ctx (publish out (ofNumber (toInteger n)))
-toBool :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
-toBool ctx value out = withContext ctx $ do
- liftIO (require (out /= nullPtr) "null output")
- tree <- lookupRoot value
- tag <- case tree of
- Leaf -> pure 0
- Stem Leaf -> pure 1
- _ -> liftIO (fault 4 "invalid boolean")
- pure (poke out tag)
-toU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-toU64 ctx value out = withContext ctx $ do
- liftIO (require (out /= nullPtr) "null output")
- tree <- lookupRoot value
- n <- liftIO (checked 4 (toNumber tree))
- liftIO $ do
- require (n <= toInteger (maxBound :: Word64)) "number exceeds uint64"
- pure (poke out (fromInteger n))
-fromBytes, fromUtf8 :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
-fromBytes ctx ptr len out = withContext ctx $ do
- bytes <- liftIO (readBytes ptr len)
- publish out (ofBytes bytes)
-fromUtf8 ctx ptr len out = withContext ctx $ do
- text <- liftIO (readText ptr len)
- publish out (ofString (Text.unpack text))
-toBytes, toUtf8 :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
-toBytes ctx value out len = withContext ctx $ do
- tree <- lookupRoot value
- bytes <- liftIO (checked 4 (toBytesValue tree))
- _ <- liftIO (evaluate (BS.length bytes))
- pure (outputBuffer out len bytes)
- where toBytesValue = Value.toBytes
-toUtf8 ctx value out len = withContext ctx $ do
- tree <- lookupRoot value
- text <- liftIO (checked 4 (toString tree))
- let bytes = Text.encodeUtf8 (Text.pack text)
- _ <- liftIO (evaluate (BS.length bytes))
- pure (outputBuffer out len bytes)
loadBundle :: Word64 -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
loadBundle ctx ptr len namePtr nameLen out = withContext ctx $ do
bytes <- liftIO (readBytes ptr len)
@@ -236,30 +46,5 @@ runIO ctx program outcome out cleanup = withContext ctx $ do
modify' (\c -> c {roots = L.insert valueId value $
L.insert cleanupId (ofList (map Protocol.problemTree problems)) (roots c)})
pure (poke outcome tag >> poke out valueId >> poke cleanup cleanupId)
-lastErrorBytes :: Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
-lastErrorBytes ctx out len = withContext ctx $ do
- bytes <- gets lastError
- pure (outputBuffer out len bytes)
-
-foreign export ccall "tricu_abi_version" abiVersion :: IO Word32
-foreign export ccall "tricu_context_new" contextNew :: Ptr Word64 -> IO Word32
-foreign export ccall "tricu_context_free" contextFree :: Word64 -> IO Word32
-foreign export ccall "tricu_retain" retain :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_release" release :: Word64 -> Word64 -> IO Word32
-foreign export ccall "tricu_leaf" leaf :: Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_stem" stem :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_fork" fork :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_apply" application :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_reduce" reduce :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_kind" kind :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
-foreign export ccall "tricu_child" child :: Word64 -> Word64 -> Word32 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_from_u64" fromU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_to_bool" toBool :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
-foreign export ccall "tricu_to_u64" toU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_from_bytes" fromBytes :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_from_utf8" fromUtf8 :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_to_bytes" toBytes :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
-foreign export ccall "tricu_to_utf8" toUtf8 :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
foreign export ccall "tricu_load_bundle" loadBundle :: Word64 -> Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
foreign export ccall "tricu_run_io" runIO :: Word64 -> Word64 -> Ptr Word32 -> Ptr Word64 -> Ptr Word64 -> IO Word32
-foreign export ccall "tricu_last_error" lastErrorBytes :: Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
diff --git a/ext/haskell/src/EmbeddingCore.hs b/ext/haskell/src/EmbeddingCore.hs
@@ -0,0 +1,229 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- Shared core boundary. Imports only the reducer, value codecs and registry dependencies.
+module EmbeddingCore where
+
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad (unless)
+import Control.Monad.State.Strict
+import Data.IORef
+import qualified Data.Map.Strict as M
+import qualified Data.Map.Lazy as L
+import qualified Data.ByteString as BS
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Word
+import Foreign hiding (void, toBool)
+import Foreign.C.Types
+import System.IO.Unsafe (unsafePerformIO)
+import Runtime.Tree
+import Runtime.Value hiding (toBytes)
+import qualified Runtime.Value as Value
+
+-- A process-wide nonreusing namespace covers contexts AND roots. No raw stable
+-- pointer crosses the boundary; released, foreign and stale IDs are map misses.
+{-# NOINLINE identities #-}
+identities :: IORef Integer
+identities = unsafePerformIO (newIORef 1)
+{-# NOINLINE contexts #-}
+contexts :: MVar (M.Map Word64 (MVar (Maybe Context)))
+contexts = unsafePerformIO (newMVar M.empty)
+-- Force map updates while keeping their tree values lazy: release removes the
+-- root now, and application publication never forces the suspended computation.
+data Context = Context { roots :: !(L.Map Word64 T), lastError :: !BS.ByteString }
+data Fault = Fault Word32 String deriving Show
+instance Exception Fault
+
+boundaryStatus :: SomeException -> IO Word32
+boundaryStatus e = pure $ case fromException e of
+ Just (Fault code _) -> code
+ Nothing -> 5
+
+type Call = StateT Context IO
+fault :: Word32 -> String -> IO a
+fault code message = throwIO (Fault code message)
+require :: Bool -> String -> IO ()
+require condition message = unless condition (fault 3 message)
+newIdentity :: IO Word64
+newIdentity = do
+ n <- atomicModifyIORef' identities (\n -> (n+1,n))
+ if n > toInteger (maxBound :: Word64) then fault 6 "identity namespace exhausted"
+ else pure (fromInteger n)
+
+-- Context locking serializes lazy evaluation as well as registry changes.
+-- Destroy marks the cell closed before removing its name; racing lookups cannot
+-- resurrect it. Exceptions roll back root-table publication, not IO effects or
+-- evaluation already performed on shared Haskell thunks.
+withContext :: Word64 -> Call (IO ()) -> IO Word32
+withContext identity action = handle boundaryStatus $ mask $ \restore -> do
+ found <- withMVar contexts (pure . M.lookup identity)
+ case found of
+ Nothing -> pure 1
+ Just cell -> modifyMVar cell $ \current -> case current of
+ Nothing -> pure (Nothing, 1)
+ Just context -> do
+ result <- try $ do
+ (commit, updated) <- restore (runStateT action context)
+ commit
+ pure updated
+ case result of
+ Right updated -> pure (Just updated, 0)
+ Left (e :: SomeException) -> do
+ let (code, message) = case fromException e of
+ Just (Fault c m) -> (c,m)
+ Nothing -> (5, displayException e)
+ -- Force bounded diagnostic bytes inside the exception handler.
+ let bytes = Text.encodeUtf8 (Text.pack (take 4096 message))
+ _ <- evaluate (BS.length bytes)
+ pure (Just context {lastError = bytes}, code)
+
+lookupRoot :: Word64 -> Call T
+lookupRoot identity = do
+ table <- gets roots
+ maybe (liftIO (fault 2 "invalid or foreign handle")) pure (L.lookup identity table)
+publish :: Ptr Word64 -> T -> Call (IO ())
+publish out tree = do
+ liftIO (require (out /= nullPtr) "null output")
+ identity <- liftIO newIdentity
+ modify' (\c -> c { roots = L.insert identity tree (roots c) })
+ pure (poke out identity)
+readBytes :: Ptr Word8 -> CSize -> IO BS.ByteString
+readBytes ptr len = do
+ require (toInteger len <= toInteger (maxBound :: Int)) "buffer too large"
+ require (ptr /= nullPtr || len == 0) "null input buffer"
+ if len == 0 then pure BS.empty else BS.packCStringLen (castPtr ptr, fromIntegral len)
+checked :: Word32 -> Either String a -> IO a
+checked code = either (fault code) pure
+readText :: Ptr Word8 -> CSize -> IO Text.Text
+readText ptr len = readBytes ptr len >>= checked 3 . either (Left . show) Right . Text.decodeUtf8'
+outputBuffer :: Ptr (Ptr Word8) -> Ptr CSize -> BS.ByteString -> IO ()
+outputBuffer out len bytes = do
+ require (out /= nullPtr && len /= nullPtr && castPtr out /= len) "invalid buffer outputs"
+ -- Allocate even for empty output, giving every successful buffer one owner.
+ bracketOnError (mallocBytes (max 1 (BS.length bytes))) free $ \ptr -> do
+ BS.useAsCStringLen bytes $ \(source,n) -> copyBytes ptr (castPtr source) n
+ poke out ptr
+ poke len (fromIntegral (BS.length bytes))
+
+abiVersion :: IO Word32
+abiVersion = pure 1
+contextNew :: Ptr Word64 -> IO Word32
+contextNew out = handle boundaryStatus $ mask_ $ do
+ if out == nullPtr then pure 3 else do
+ identity <- newIdentity
+ cell <- newMVar (Just (Context L.empty BS.empty))
+ modifyMVar_ contexts (pure . M.insert identity cell)
+ poke out identity
+ pure 0
+contextFree :: Word64 -> IO Word32
+contextFree identity = handle boundaryStatus $ mask_ $ do
+ found <- withMVar contexts (pure . M.lookup identity)
+ case found of
+ Nothing -> pure 1
+ Just cell -> do
+ status <- modifyMVar cell $ \current -> pure (Nothing, maybe 1 (const 0) current)
+ modifyMVar_ contexts (pure . M.delete identity)
+ pure status
+retain :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+retain ctx value out = withContext ctx (lookupRoot value >>= publish out)
+release :: Word64 -> Word64 -> IO Word32
+release ctx value = withContext ctx $ do
+ _ <- lookupRoot value
+ modify' (\c -> c {roots = L.delete value (roots c)})
+ pure (pure ())
+leaf :: Word64 -> Ptr Word64 -> IO Word32
+leaf ctx out = withContext ctx (publish out Leaf)
+stem :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+stem ctx value out = withContext ctx (lookupRoot value >>= publish out . Stem)
+binary :: (T -> T -> T) -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
+binary constructor ctx left right out = withContext ctx $ do
+ a <- lookupRoot left
+ b <- lookupRoot right
+ publish out (constructor a b)
+fork, application :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
+fork = binary Fork
+application = binary apply
+reduce :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+reduce ctx value out = withContext ctx $ do
+ liftIO (require (out /= nullPtr) "null output")
+ tree <- lookupRoot value >>= liftIO . evaluate
+ publish out tree
+kind :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
+kind ctx value out = withContext ctx $ do
+ liftIO (require (out /= nullPtr) "null output")
+ tree <- lookupRoot value
+ tag <- liftIO $ evaluate $ case tree of Leaf -> 0; Stem _ -> 1; Fork _ _ -> 2
+ pure (poke out tag)
+child :: Word64 -> Word64 -> Word32 -> Ptr Word64 -> IO Word32
+child ctx value index out = withContext ctx $ do
+ tree <- lookupRoot value
+ case (tree,index) of
+ (Stem a,0) -> publish out a
+ (Fork a _,0) -> publish out a
+ (Fork _ b,1) -> publish out b
+ _ -> liftIO (fault 4 "constructor has no such child")
+fromU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+fromU64 ctx n out = withContext ctx (publish out (ofNumber (toInteger n)))
+toBool :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
+toBool ctx value out = withContext ctx $ do
+ liftIO (require (out /= nullPtr) "null output")
+ tree <- lookupRoot value
+ tag <- case tree of
+ Leaf -> pure 0
+ Stem Leaf -> pure 1
+ _ -> liftIO (fault 4 "invalid boolean")
+ pure (poke out tag)
+toU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+toU64 ctx value out = withContext ctx $ do
+ liftIO (require (out /= nullPtr) "null output")
+ tree <- lookupRoot value
+ n <- liftIO (checked 4 (toNumber tree))
+ liftIO $ do
+ require (n <= toInteger (maxBound :: Word64)) "number exceeds uint64"
+ pure (poke out (fromInteger n))
+fromBytes, fromUtf8 :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
+fromBytes ctx ptr len out = withContext ctx $ do
+ bytes <- liftIO (readBytes ptr len)
+ publish out (ofBytes bytes)
+fromUtf8 ctx ptr len out = withContext ctx $ do
+ text <- liftIO (readText ptr len)
+ publish out (ofString (Text.unpack text))
+toBytes, toUtf8 :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
+toBytes ctx value out len = withContext ctx $ do
+ tree <- lookupRoot value
+ bytes <- liftIO (checked 4 (toBytesValue tree))
+ _ <- liftIO (evaluate (BS.length bytes))
+ pure (outputBuffer out len bytes)
+ where toBytesValue = Value.toBytes
+toUtf8 ctx value out len = withContext ctx $ do
+ tree <- lookupRoot value
+ text <- liftIO (checked 4 (toString tree))
+ let bytes = Text.encodeUtf8 (Text.pack text)
+ _ <- liftIO (evaluate (BS.length bytes))
+ pure (outputBuffer out len bytes)
+lastErrorBytes :: Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
+lastErrorBytes ctx out len = withContext ctx $ do
+ bytes <- gets lastError
+ pure (outputBuffer out len bytes)
+
+foreign export ccall "tricu_abi_version" abiVersion :: IO Word32
+foreign export ccall "tricu_context_new" contextNew :: Ptr Word64 -> IO Word32
+foreign export ccall "tricu_context_free" contextFree :: Word64 -> IO Word32
+foreign export ccall "tricu_retain" retain :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_release" release :: Word64 -> Word64 -> IO Word32
+foreign export ccall "tricu_leaf" leaf :: Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_stem" stem :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_fork" fork :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_apply" application :: Word64 -> Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_reduce" reduce :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_kind" kind :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
+foreign export ccall "tricu_child" child :: Word64 -> Word64 -> Word32 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_from_u64" fromU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_to_bool" toBool :: Word64 -> Word64 -> Ptr Word32 -> IO Word32
+foreign export ccall "tricu_to_u64" toU64 :: Word64 -> Word64 -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_from_bytes" fromBytes :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_from_utf8" fromUtf8 :: Word64 -> Ptr Word8 -> CSize -> Ptr Word64 -> IO Word32
+foreign export ccall "tricu_to_bytes" toBytes :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
+foreign export ccall "tricu_to_utf8" toUtf8 :: Word64 -> Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
+foreign export ccall "tricu_last_error" lastErrorBytes :: Word64 -> Ptr (Ptr Word8) -> Ptr CSize -> IO Word32
diff --git a/ext/haskell/src/core.exports b/ext/haskell/src/core.exports
@@ -0,0 +1,4 @@
+{
+ global: tricu_*;
+ local: *;
+};
diff --git a/ext/haskell/src/init.c b/ext/haskell/src/init.c
@@ -1,7 +1,7 @@
#include <Rts.h>
#include <pthread.h>
#include <stdlib.h>
-#include "tricu.h"
+#include "tricu-core.h"
static pthread_once_t initialized = PTHREAD_ONCE_INIT;
static void initialize(void) {
diff --git a/ext/haskell/test_exports.py b/ext/haskell/test_exports.py
@@ -0,0 +1,18 @@
+"""Fresh-process checks of the common C surface and host-only extension."""
+import ctypes
+import sys
+import subprocess
+
+library = ctypes.CDLL(sys.argv[1])
+core_names = ('init', 'abi_version', 'context_new', 'context_free', 'retain',
+ 'release', 'leaf', 'stem', 'fork', 'apply', 'reduce', 'kind', 'child',
+ 'from_u64', 'to_u64', 'to_bool', 'from_bytes', 'to_bytes',
+ 'from_utf8', 'to_utf8', 'last_error', 'buffer_free')
+for name in core_names:
+ assert getattr(library, 'tricu_' + name)
+for name in ('load_bundle', 'run_io'):
+ assert hasattr(library, 'tricu_' + name) == (sys.argv[2] == 'host')
+
+if len(sys.argv) > 3 and sys.argv[3] == 'public-only':
+ symbols = subprocess.check_output(['nm', '-D', '--defined-only', sys.argv[1]], text=True)
+ assert {line.split()[-1] for line in symbols.splitlines()} == {'tricu_' + name for name in core_names}
diff --git a/ext/haskell/tests.c b/ext/haskell/tests.c
@@ -1,9 +1,91 @@
-#include "tricu.h"
+#include "tricu-core.h"
#include <assert.h>
#include <string.h>
#include <signal.h>
static volatile sig_atomic_t observed_signal;
static void host_signal(int sig) { observed_signal = sig; }
+
+/* Independent constructor-level oracles for all reduction rules. */
+static tricu_handle stem(tricu_context ctx, tricu_handle x) {
+ tricu_handle out;
+ assert(tricu_stem(ctx, x, &out) == TRICU_OK);
+ return out;
+}
+static tricu_handle make_fork(tricu_context ctx, tricu_handle a, tricu_handle b) {
+ tricu_handle out;
+ assert(tricu_fork(ctx, a, b, &out) == TRICU_OK);
+ return out;
+}
+static tricu_handle app(tricu_context ctx, tricu_handle a, tricu_handle b) {
+ tricu_handle out;
+ assert(tricu_apply(ctx, a, b, &out) == TRICU_OK);
+ return out;
+}
+static void same(tricu_context ctx, tricu_handle a, tricu_handle b) {
+ uint32_t ka, kb;
+ assert(tricu_kind(ctx, a, &ka) == TRICU_OK);
+ assert(tricu_kind(ctx, b, &kb) == TRICU_OK);
+ assert(ka == kb);
+ for (uint32_t i = 0; i < ka; ++i) {
+ tricu_handle ca, cb;
+ assert(tricu_child(ctx, a, i, &ca) == TRICU_OK);
+ assert(tricu_child(ctx, b, i, &cb) == TRICU_OK);
+ same(ctx, ca, cb);
+ assert(tricu_release(ctx, ca) == TRICU_OK);
+ assert(tricu_release(ctx, cb) == TRICU_OK);
+ }
+}
+static void core_rules(tricu_context ctx) {
+ tricu_handle t;
+ assert(tricu_leaf(ctx, &t) == TRICU_OK);
+ tricu_handle tt = stem(ctx, t), k = make_fork(ctx, t, t);
+ same(ctx, app(ctx, t, tt), stem(ctx, tt));
+ same(ctx, app(ctx, tt, k), make_fork(ctx, t, k));
+ same(ctx, app(ctx, make_fork(ctx, t, tt), k), tt);
+ /* S (K t) t (t t) = t (t (t t)) */
+ same(ctx, app(ctx, make_fork(ctx, stem(ctx, k), t), tt), stem(ctx, stem(ctx, tt)));
+ tricu_handle triage = make_fork(ctx, make_fork(ctx, tt, k), k);
+ same(ctx, app(ctx, triage, t), tt);
+ same(ctx, app(ctx, triage, stem(ctx, tt)), t);
+ same(ctx, app(ctx, triage, make_fork(ctx, t, tt)), stem(ctx, tt));
+ tricu_handle marker = 987;
+ assert(tricu_child(ctx, t, 0, &marker) == TRICU_TYPE_ERROR && marker == 987);
+ tricu_context other;
+ assert(tricu_context_new(&other) == TRICU_OK);
+ assert(tricu_retain(other, t, &marker) == TRICU_INVALID_HANDLE && marker == 987);
+ assert(tricu_retain(ctx, other, &marker) == TRICU_INVALID_HANDLE && marker == 987);
+ assert(tricu_context_free(other) == TRICU_OK);
+ assert(tricu_leaf(other, &marker) == TRICU_INVALID_CONTEXT && marker == 987);
+ const uint8_t bad_utf8[] = {0xc0, 0x80};
+ assert(tricu_from_utf8(ctx, bad_utf8, 2, &marker) == TRICU_INVALID_DATA && marker == 987);
+ uint8_t input[256], *output;
+ size_t length;
+ for (size_t i = 0; i < sizeof input; ++i) input[i] = (uint8_t)i;
+ assert(tricu_from_bytes(ctx, input, sizeof input, &marker) == TRICU_OK);
+ assert(tricu_to_bytes(ctx, marker, &output, &length) == TRICU_OK);
+ assert(length == sizeof input && memcmp(input, output, length) == 0);
+ tricu_buffer_free(output);
+ const uint8_t unicode[] = {'x', 0, 0xc3, 0xa9, 0xf0, 0x9f, 0x8c, 0xb3, 0xef, 0xbb, 0xbf};
+ assert(tricu_from_utf8(ctx, unicode, sizeof unicode, &marker) == TRICU_OK);
+ assert(tricu_to_utf8(ctx, marker, &output, &length) == TRICU_OK);
+ assert(length == sizeof unicode && memcmp(unicode, output, length) == 0);
+ tricu_buffer_free(output);
+ tricu_handle invalid;
+ assert(tricu_from_u64(ctx, 256, &invalid) == TRICU_OK);
+ invalid = make_fork(ctx, invalid, t);
+ uint8_t sentinel, *unchanged = &sentinel;
+ size_t unchanged_length = 987;
+ assert(tricu_to_bytes(ctx, invalid, &unchanged, &unchanged_length) == TRICU_TYPE_ERROR);
+ assert(unchanged == &sentinel && unchanged_length == 987);
+ assert(tricu_from_u64(ctx, 0xd800, &invalid) == TRICU_OK);
+ invalid = make_fork(ctx, invalid, t);
+ assert(tricu_to_utf8(ctx, invalid, &unchanged, &unchanged_length) == TRICU_TYPE_ERROR);
+ assert(unchanged == &sentinel && unchanged_length == 987);
+ assert(tricu_from_bytes(ctx, NULL, 0, &marker) == TRICU_OK);
+ assert(tricu_to_bytes(ctx, marker, &output, &length) == TRICU_OK && length == 0);
+ tricu_buffer_free(output);
+}
+
int main(void) {
signal(SIGINT, host_signal);
signal(SIGPIPE, host_signal);
@@ -17,6 +99,7 @@ int main(void) {
tricu_context ctx;
tricu_handle value, alias, result;
assert(tricu_context_new(&ctx) == TRICU_OK);
+ core_rules(ctx);
assert(tricu_from_u64(ctx, UINT64_MAX, &value) == TRICU_OK);
assert(tricu_retain(ctx, value, &alias) == TRICU_OK);
assert(value != alias);
diff --git a/ext/php/src/ffi.php b/ext/php/src/ffi.php
@@ -40,10 +40,15 @@ final class Library
}
if (self::$native === null) {
$header = false;
- foreach ([__DIR__.'/../tricu.h', __DIR__.'/../../haskell/include/tricu.h'] as $candidate) {
- if (is_file($candidate)) { $header = file_get_contents($candidate); break; }
+ foreach ([__DIR__.'/..', __DIR__.'/../../haskell/include'] as $directory) {
+ if (is_file($directory.'/tricu.h') && is_file($directory.'/tricu-core.h')) {
+ $core = file_get_contents($directory.'/tricu-core.h');
+ $host = file_get_contents($directory.'/tricu.h');
+ if ($core !== false && $host !== false) $header = $core."\n".$host;
+ break;
+ }
}
- if ($header === false) throw new \RuntimeException('Cannot read tricu.h');
+ if ($header === false) throw new \RuntimeException('Cannot read tricu headers');
$header = preg_replace('/^#.*$/m', '', $header);
$header = preg_replace('/extern\s+"C"\s*\{/', '', $header);
$header = preg_replace('/^\}\s*$/m', '', $header);
diff --git a/flake.nix b/flake.nix
@@ -34,7 +34,42 @@
# check below rejects reintroducing retired frontend files into inputs.
runtimeSource = tricuSource;
- haskellPackages = pkgs.haskellPackages;
+ # Narrow GHC 9.14 compatibility changes; upstream test suites stay enabled.
+ nativeHaskellOverrides = final: previous: {
+ # The upstream completion-order fix preserves the diagnostic-message test.
+ sandwich = hsLib.overrideCabal previous.sandwich (old: {
+ patches = (old.patches or []) ++ [ ./ext/haskell/patches/sandwich-introduce-with-completion.patch ];
+ });
+ string-interpolate = hsLib.overrideCabal previous.string-interpolate (old: {
+ postPatch = (old.postPatch or "") + ''
+ substituteInPlace string-interpolate.cabal \
+ --replace-fail 'template-haskell <2.24' 'template-haskell <2.25'
+ '';
+ });
+ brick = hsLib.overrideCabal previous.brick (old: {
+ postPatch = (old.postPatch or "") + ''
+ substituteInPlace brick.cabal \
+ --replace-fail 'base >= 4.9.0.0 && < 4.22.0.0' 'base >= 4.9.0.0 && < 4.23.0.0'
+ '';
+ });
+ config-ini = hsLib.overrideCabal previous.config-ini (old: {
+ postPatch = (old.postPatch or "") + ''
+ substituteInPlace config-ini.cabal \
+ --replace-fail 'containers >=0.5 && <0.8' 'containers >=0.5 && <0.9'
+ '';
+ });
+ };
+ haskellPackages = pkgs.haskell.packages.ghc914.override {
+ overrides = nativeHaskellOverrides;
+ };
+ picHaskellPackages = haskellPackages.override {
+ ghc = haskellPackages.ghc.override {
+ enableRelocatedStaticLibs = true;
+ # These build-only variants are unused by the embedding experiment.
+ enableProfiledLibs = false;
+ enableDocs = false;
+ };
+ };
hsLib = pkgs.haskell.lib;
staticPkgs = pkgs.pkgsStatic;
@@ -326,8 +361,20 @@
};
tricuHaskell = import ./ext/haskell/build.nix {
+ inherit pkgs haskellPackages;
+ source = tricuSource;
+ };
+ tricuCore = import ./ext/haskell/build.nix {
+ inherit pkgs haskellPackages;
+ source = tricuSource;
+ coreOnly = true;
+ };
+ tricuCoreArchive = import ./ext/haskell/build.nix {
inherit pkgs;
source = tricuSource;
+ haskellPackages = picHaskellPackages;
+ coreOnly = true;
+ archiveHaskell = true;
};
tricuPython = pkgs.python3Packages.buildPythonPackage {
pname = "tricu-runtime";
@@ -411,7 +458,7 @@
installPhase = ''
mkdir -p $out/share/tricu-php $out/bin
cp -r src public run.php $out/share/tricu-php/
- cp ${tricuHaskell}/include/tricu.h $out/share/tricu-php/
+ cp ${tricuHaskell}/include/tricu*.h $out/share/tricu-php/
ln -s ${tricuHaskell}/lib/libtricu-haskell${pkgs.stdenv.hostPlatform.extensions.sharedLibrary} $out/share/tricu-php/
makeWrapper ${phpWithFfi}/bin/php $out/bin/tricu-php \
--add-flags "$out/share/tricu-php/run.php" \
@@ -489,6 +536,27 @@
packages.${packageName} = tricuPackage;
packages.default = tricuPackage;
packages.tricu-haskell-ffi = tricuHaskell;
+ packages.tricu-core = tricuCore;
+ packages.tricu-core-archive = tricuCoreArchive;
+ packages.tricu-core-linkage-smoke = pkgs.runCommand "tricu-core-linkage-smoke" {
+ nativeBuildInputs = [ pkgs.python3 pkgs.stdenv.cc ];
+ meta.platforms = [ "x86_64-linux" ];
+ } ''
+ mkdir -p $out/bin
+ $CC -O2 -Wall -Wextra -Werror ${tricuSource}/ext/haskell/core_bench.c \
+ -I${tricuCore}/include -L${tricuCore}/lib -ltricu-core \
+ -Wl,-rpath,${tricuCore}/lib -o $out/bin/dynamic-core-bench
+ $CC -O2 -Wall -Wextra -Werror ${tricuSource}/ext/haskell/core_bench.c \
+ -I${tricuCoreArchive}/include -L${tricuCoreArchive}/lib -ltricu-core \
+ -Wl,-rpath,${tricuCoreArchive}/lib -o $out/bin/archive-core-bench
+ PYTHONDONTWRITEBYTECODE=1 python3 ${tricuSource}/ext/haskell/core_bench.py \
+ --dynamic $out/bin/dynamic-core-bench --archive $out/bin/archive-core-bench \
+ --output $out/report.json > $out/summary.json
+ '';
+ packages.tricu-core-archive-probe = import ./ext/haskell/archive-probe.nix {
+ inherit pkgs haskellPackages;
+ source = tricuSource;
+ };
packages.tricu-python = tricuPython;
packages.tricu-python-tests = tricuPythonTests;
packages.tricu-workflow-demo = tricuWorkflow;
@@ -689,6 +757,7 @@
checks.${packageName} = tricuPackageTests;
checks.default = tricuPackageTests;
checks.haskellEmbedding = tricuHaskell;
+ checks.haskellCore = tricuCore;
checks.pythonBinding = tricuPythonTests;
checks.jsBinding = tricuJsTests;
checks.phpBinding = tricuPhpTests;
@@ -745,9 +814,10 @@
devShells.default = pkgs.mkShell {
buildInputs = with pkgs; [
- haskellPackages.cabal-install
- haskellPackages.ghc-events
- haskellPackages.ghcid
+ # These tools are separate executables, not libraries linked into tricu.
+ pkgs.cabal-install
+ pkgs.haskellPackages.ghc-events
+ pkgs.ghcid
haskellPackages.ghc
upx
gcc
