diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..69b2b33 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,38 @@ +name: CI + +on: + push: + branches: [master] + pull_request: + +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + + - uses: actions/setup-node@v1 + with: + node-version: "22" + + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@v12 + - uses: DeterminateSystems/magic-nix-cache-action@main + + - name: Setup PureScript dependencies + run: npm i --global purescript@0.15.10 spago@next purescm@latest + + - name: Build source + run: spago build + + - name: Cache PureScript dependencies + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-spago-${{ hashFiles('**/spago.yaml') }} + path: | + .spago + output + + - name: Run tests + run: | + nix-shell --run "purescm run --main Test.Chez.Main" diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..cf3485f --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ + +bower_components/ +node_modules/ +.pulp-cache/ +output/ +output-es/ +generated-docs/ +.psc-package/ +.psc* +.purs* +.psa* +.spago +.envrc +.direnv diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..f081090 --- /dev/null +++ b/flake.lock @@ -0,0 +1,104 @@ +{ + "nodes": { + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-compat_2": { + "flake": false, + "locked": { + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1720181791, + "narHash": "sha256-i4vJL12/AdyuQuviMMd1Hk2tsGt02hDNhA0Zj1m16N8=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "4284c2b73c8bce4b46a6adf23e16d9e2ec8da4bb", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "purescript-overlay": { + "inputs": { + "flake-compat": "flake-compat_2", + "nixpkgs": [ + "nixpkgs" + ], + "slimlock": "slimlock" + }, + "locked": { + "lastModified": 1719849006, + "narHash": "sha256-0HpRwEdvAlbSka5tFLwokz2bEV+QgoGqRZ0BR/ghB6w=", + "owner": "thomashoneyman", + "repo": "purescript-overlay", + "rev": "6a00f4a8fbb42e0494a57c5da99b1375721a6c4b", + "type": "github" + }, + "original": { + "owner": "thomashoneyman", + "repo": "purescript-overlay", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-compat": "flake-compat", + "nixpkgs": "nixpkgs", + "purescript-overlay": "purescript-overlay" + } + }, + "slimlock": { + "inputs": { + "nixpkgs": [ + "purescript-overlay", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1688756706, + "narHash": "sha256-xzkkMv3neJJJ89zo3o2ojp7nFeaZc2G0fYwNXNJRFlo=", + "owner": "thomashoneyman", + "repo": "slimlock", + "rev": "cf72723f59e2340d24881fd7bf61cb113b4c407c", + "type": "github" + }, + "original": { + "owner": "thomashoneyman", + "repo": "slimlock", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..135e36f --- /dev/null +++ b/flake.nix @@ -0,0 +1,53 @@ +{ + description = "PureScript core packages CI setup"; + + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; + + flake-compat = { + url = "github:edolstra/flake-compat"; + flake = false; + }; + + purescript-overlay.url = "github:thomashoneyman/purescript-overlay"; + purescript-overlay.inputs.nixpkgs.follows = "nixpkgs"; + }; + + outputs = { self, nixpkgs, ... }@inputs: + let + supportedSystems = [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" ]; + + forAllSystems = nixpkgs.lib.genAttrs supportedSystems; + + nixpkgsFor = forAllSystems (system: import nixpkgs { + inherit system; + overlays = builtins.attrValues self.overlays; + }); + in + { + overlays = { + purescript = inputs.purescript-overlay.overlays.default; + }; + + devShells = forAllSystems (system: + let pkgs = nixpkgsFor.${system}; + chez = pkgs.chez.overrideAttrs (final: prev: { + postFixup = if pkgs.stdenv.isDarwin then '' + install_name_tool -add_rpath ${pkgs.pcre2.out}/lib $out/bin/scheme + '' + else '' + patchelf $out/bin/scheme --add-rpath ${pkgs.pcre2.out}/lib + ''; + }); + in { + default = pkgs.mkShell { + name = "purescm"; + packages = with pkgs; [ + chez + ]; + }; + }); + + formatter = forAllSystems (system: nixpkgsFor.${system}.nixpkgs-fmt); + }; +} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..9d8d79e --- /dev/null +++ b/shell.nix @@ -0,0 +1,13 @@ +# A compatibility file that allows non-flakes users to still get a development +# shell with `nix-shell`. +(import + ( + let lock = builtins.fromJSON (builtins.readFile ./flake.lock); + in fetchTarball { + url = + "https://github.com/edolstra/flake-compat/archive/${lock.nodes.flake-compat.locked.rev}.tar.gz"; + sha256 = lock.nodes.flake-compat.locked.narHash; + } + ) + { src = ./.; }).shellNix + diff --git a/spago.lock b/spago.lock new file mode 100644 index 0000000..66fb378 --- /dev/null +++ b/spago.lock @@ -0,0 +1,607 @@ +workspace: + packages: + chez-stdlib: + path: ./ + dependencies: + - arrays + - console + - datetime + - effect + - foldable-traversable + - integers + - prelude + - refs + - unsafe-coerce + test_dependencies: + - assert + build_plan: + - arrays + - assert + - bifunctors + - console + - const + - contravariant + - control + - datetime + - distributive + - effect + - either + - enums + - exists + - foldable-traversable + - functions + - functors + - gen + - identity + - integers + - invariant + - lazy + - lists + - maybe + - newtype + - nonempty + - numbers + - ordered-collections + - orders + - partial + - prelude + - profunctor + - refs + - safe-coerce + - st + - tailrec + - tuples + - type-equality + - unfoldable + - unsafe-coerce + package_set: + address: + url: https://raw.githubusercontent.com/purescm/purescm/e891f4292630cae4d0ff1143a1594f600fc58512/package-sets/1.0.0.json + compiler: ">=0.15.10 <0.16.0" + content: + arrays: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: arrays + assert: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: assert + bifunctors: 6.0.0 + catenable-lists: 7.0.0 + console: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: console + const: 6.0.0 + contravariant: 6.0.0 + control: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: control + datetime: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: datetime + distributive: 6.0.0 + effect: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: effect + either: 6.1.0 + enums: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: enums + exceptions: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: exceptions + exists: 6.0.0 + filterable: 5.0.0 + foldable-traversable: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: foldable-traversable + foreign-object: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: foreign-object + free: 7.1.0 + functions: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: functions + dependencies: + - prelude + functors: 5.0.0 + gen: 4.0.0 + identity: 6.0.0 + integers: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: integers + invariant: 6.0.0 + json: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: json + lazy: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: lazy + lcg: 4.0.0 + lists: + git: https://github.com/purescm/purescript-lists.git + ref: 71502a132567cf7f32c2242d57b1cba2c77ebc15 + maybe: 6.0.0 + minibench: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: minibench + newtype: 5.0.0 + nonempty: 7.0.0 + numbers: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: numbers + ordered-collections: 3.1.1 + orders: 6.0.0 + parallel: 7.0.0 + partial: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: partial + dependencies: [] + prelude: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: prelude + profunctor: 6.0.0 + quickcheck: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: quickcheck + random: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: random + record: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: record + refs: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: refs + safe-coerce: 2.0.0 + semirings: 7.0.0 + st: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: st + strings: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: strings + tailrec: 6.1.0 + transformers: 6.0.0 + tuples: 7.0.0 + type-equality: 4.0.1 + typelevel-prelude: 7.0.0 + unfoldable: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: unfoldable + unsafe-coerce: + git: https://github.com/purescm/purescript-core.git + ref: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: unsafe-coerce + dependencies: [] + validation: 6.0.0 + extra_packages: {} +packages: + arrays: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: arrays + dependencies: + - bifunctors + - control + - foldable-traversable + - functions + - maybe + - nonempty + - partial + - prelude + - safe-coerce + - st + - tailrec + - tuples + - unfoldable + - unsafe-coerce + assert: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: assert + dependencies: + - console + - effect + - prelude + bifunctors: + type: registry + version: 6.0.0 + integrity: sha256-/gZwC9YhNxZNQpnHa5BIYerCGM2jeX9ukZiEvYxm5Nw= + dependencies: + - const + - either + - newtype + - prelude + - tuples + console: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: console + dependencies: + - effect + - prelude + const: + type: registry + version: 6.0.0 + integrity: sha256-tNrxDW8D8H4jdHE2HiPzpLy08zkzJMmGHdRqt5BQuTc= + dependencies: + - invariant + - newtype + - prelude + contravariant: + type: registry + version: 6.0.0 + integrity: sha256-TP+ooAp3vvmdjfQsQJSichF5B4BPDHp3wAJoWchip6c= + dependencies: + - const + - either + - newtype + - prelude + - tuples + control: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: control + dependencies: + - newtype + - prelude + datetime: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: datetime + dependencies: + - bifunctors + - control + - either + - enums + - foldable-traversable + - functions + - gen + - integers + - lists + - maybe + - newtype + - numbers + - ordered-collections + - partial + - prelude + - tuples + distributive: + type: registry + version: 6.0.0 + integrity: sha256-HTDdmEnzigMl+02SJB88j+gAXDx9VKsbvR4MJGDPbOQ= + dependencies: + - identity + - newtype + - prelude + - tuples + - type-equality + effect: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: effect + dependencies: + - prelude + either: + type: registry + version: 6.1.0 + integrity: sha256-6hgTPisnMWVwQivOu2PKYcH8uqjEOOqDyaDQVUchTpY= + dependencies: + - control + - invariant + - maybe + - prelude + enums: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: enums + dependencies: + - control + - either + - gen + - maybe + - newtype + - nonempty + - partial + - prelude + - tuples + - unfoldable + exists: + type: registry + version: 6.0.0 + integrity: sha256-A0JQHpTfo1dNOj9U5/Fd3xndlRSE0g2IQWOGor2yXn8= + dependencies: + - unsafe-coerce + foldable-traversable: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: foldable-traversable + dependencies: + - bifunctors + - const + - control + - either + - functors + - identity + - maybe + - newtype + - orders + - prelude + - tuples + functions: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: functions + dependencies: + - prelude + functors: + type: registry + version: 5.0.0 + integrity: sha256-zfPWWYisbD84MqwpJSZFlvM6v86McM68ob8p9s27ywU= + dependencies: + - bifunctors + - const + - contravariant + - control + - distributive + - either + - invariant + - maybe + - newtype + - prelude + - profunctor + - tuples + - unsafe-coerce + gen: + type: registry + version: 4.0.0 + integrity: sha256-f7yzAXWwr+xnaqEOcvyO3ezKdoes8+WXWdXIHDBCAPI= + dependencies: + - either + - foldable-traversable + - identity + - maybe + - newtype + - nonempty + - prelude + - tailrec + - tuples + - unfoldable + identity: + type: registry + version: 6.0.0 + integrity: sha256-4wY0XZbAksjY6UAg99WkuKyJlQlWAfTi2ssadH0wVMY= + dependencies: + - control + - invariant + - newtype + - prelude + integers: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: integers + dependencies: + - maybe + - numbers + - prelude + invariant: + type: registry + version: 6.0.0 + integrity: sha256-RGWWyYrz0Hs1KjPDA+87Kia67ZFBhfJ5lMGOMCEFoLo= + dependencies: + - control + - prelude + lazy: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: lazy + dependencies: + - control + - foldable-traversable + - invariant + - prelude + lists: + type: git + url: https://github.com/purescm/purescript-lists.git + rev: 71502a132567cf7f32c2242d57b1cba2c77ebc15 + dependencies: + - bifunctors + - control + - foldable-traversable + - lazy + - maybe + - newtype + - nonempty + - partial + - prelude + - tailrec + - tuples + - unfoldable + maybe: + type: registry + version: 6.0.0 + integrity: sha256-5cCIb0wPwbat2PRkQhUeZO0jcAmf8jCt2qE0wbC3v2Q= + dependencies: + - control + - invariant + - newtype + - prelude + newtype: + type: registry + version: 5.0.0 + integrity: sha256-gdrQu8oGe9eZE6L3wOI8ql/igOg+zEGB5ITh2g+uttw= + dependencies: + - prelude + - safe-coerce + nonempty: + type: registry + version: 7.0.0 + integrity: sha256-54ablJZUHGvvlTJzi3oXyPCuvY6zsrWJuH/dMJ/MFLs= + dependencies: + - control + - foldable-traversable + - maybe + - prelude + - tuples + - unfoldable + numbers: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: numbers + dependencies: + - functions + - maybe + - prelude + ordered-collections: + type: registry + version: 3.1.1 + integrity: sha256-boSYHmlz4aSbwsNN4VxiwCStc0t+y1F7BXmBS+1JNtI= + dependencies: + - arrays + - foldable-traversable + - gen + - lists + - maybe + - partial + - prelude + - st + - tailrec + - tuples + - unfoldable + orders: + type: registry + version: 6.0.0 + integrity: sha256-nBA0g3/ai0euH8q9pSbGqk53W2q6agm/dECZTHcoink= + dependencies: + - newtype + - prelude + partial: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: partial + dependencies: [] + prelude: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: prelude + dependencies: [] + profunctor: + type: registry + version: 6.0.0 + integrity: sha256-99NzxFgTr4CGlCSRYG1kShL+JhYbihhHtbOk1/0R5zI= + dependencies: + - control + - distributive + - either + - exists + - invariant + - newtype + - prelude + - tuples + refs: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: refs + dependencies: + - effect + - prelude + safe-coerce: + type: registry + version: 2.0.0 + integrity: sha256-a1ibQkiUcbODbLE/WAq7Ttbbh9ex+x33VCQ7GngKudU= + dependencies: + - unsafe-coerce + st: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: st + dependencies: + - effect + - partial + - prelude + - tailrec + - unsafe-coerce + tailrec: + type: registry + version: 6.1.0 + integrity: sha256-Xx19ECVDRrDWpz9D2GxQHHV89vd61dnXxQm0IcYQHGk= + dependencies: + - bifunctors + - effect + - either + - identity + - maybe + - partial + - prelude + - refs + tuples: + type: registry + version: 7.0.0 + integrity: sha256-1rXgTomes9105BjgXqIw0FL6Fz1lqqUTLWOumhWec1M= + dependencies: + - control + - invariant + - prelude + type-equality: + type: registry + version: 4.0.1 + integrity: sha256-Hs9D6Y71zFi/b+qu5NSbuadUQXe5iv5iWx0226vOHUw= + dependencies: [] + unfoldable: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: unfoldable + dependencies: + - foldable-traversable + - maybe + - partial + - prelude + - tuples + unsafe-coerce: + type: git + url: https://github.com/purescm/purescript-core.git + rev: 98f12cc76d4941f979f2530da94f5b46ce9551cd + subdir: unsafe-coerce + dependencies: [] diff --git a/spago.yaml b/spago.yaml new file mode 100644 index 0000000..7606378 --- /dev/null +++ b/spago.yaml @@ -0,0 +1,24 @@ +package: + name: chez-stdlib + dependencies: + - arrays + - console + - datetime + - effect + - foldable-traversable + - integers + - prelude + - refs + - unsafe-coerce + test: + main: Test.Chez.Main + dependencies: + - assert +workspace: + backend: + cmd: purescm + args: + - build + packageSet: + url: https://raw.githubusercontent.com/purescm/purescm/e891f4292630cae4d0ff1143a1594f600fc58512/package-sets/1.0.0.json + extraPackages: {} diff --git a/src/Chez/Thread.purs b/src/Chez/Thread.purs new file mode 100644 index 0000000..f8b4280 --- /dev/null +++ b/src/Chez/Thread.purs @@ -0,0 +1,90 @@ +-- | This module provides a simple interface to the Chez Scheme thread API. +-- | See Chapter 15 of the Chez Scheme User's Guide for more information: +-- | https://cisco.github.io/ChezScheme/csug10.0/threads.html +module Chez.Thread + ( Thread + , ThreadId + , Mutex + , Condition + , fork + , join + , threadIdToInt + , makeMutex + , withMutex + , makeCondition + , conditionWait + , conditionSignal + , sleep + ) where + +import Prelude + +import Data.Int as Int +import Data.Time.Duration (class Duration, Milliseconds(..)) +import Data.Time.Duration as Duration +import Effect (Effect) +import Effect.Uncurried (EffectFn1, EffectFn2) +import Effect.Uncurried as Uncurried +import Unsafe.Coerce (unsafeCoerce) + +-------------------------------------------------------------------------------- +-- Thread creation/termination + +foreign import data ThreadId :: Type + +threadIdToInt :: ThreadId -> Int +threadIdToInt = unsafeCoerce + +foreign import data Thread :: Type + +foreign import forkThreadImpl :: EffectFn1 (EffectFn1 ThreadId Unit) Thread + +fork :: (ThreadId -> Effect Unit) -> Effect Thread +fork fn = Uncurried.runEffectFn1 forkThreadImpl (Uncurried.mkEffectFn1 fn) + +foreign import joinThreadImpl :: EffectFn1 Thread Unit + +join :: Thread -> Effect Unit +join = Uncurried.runEffectFn1 joinThreadImpl + +-------------------------------------------------------------------------------- +-- Thread syncronisation - mutexes + +data Mutex + +foreign import makeMutex :: Effect Mutex + +foreign import withMutexImpl :: EffectFn2 Mutex (Effect Unit) Unit + +withMutex :: Mutex -> Effect Unit -> Effect Unit +withMutex mutex fn = Uncurried.runEffectFn2 withMutexImpl mutex fn + +-------------------------------------------------------------------------------- +-- Thread syncronisation - conditions (aka semaphores) + +data Condition + +foreign import makeCondition :: Effect Condition + +foreign import conditionWaitImpl :: EffectFn2 Condition Mutex Unit + +conditionWait :: Condition -> Mutex -> Effect Unit +conditionWait condition mutex = Uncurried.runEffectFn2 conditionWaitImpl condition mutex + +foreign import conditionSignalImpl :: EffectFn1 Condition Unit + +conditionSignal :: Condition -> Effect Unit +conditionSignal condition = Uncurried.runEffectFn1 conditionSignalImpl condition + +-------------------------------------------------------------------------------- +-- Thread sleep + +foreign import sleepImpl :: EffectFn2 Int Int Unit + +sleep :: forall a. Duration a => a -> Effect Unit +sleep duration = do + let + (Milliseconds millis) = Duration.fromDuration duration + seconds = Int.floor (millis / 1000.0) + nanoseconds = Int.floor ((millis - Int.toNumber (seconds * 1000)) * 1000000.0) + Uncurried.runEffectFn2 sleepImpl nanoseconds seconds diff --git a/src/Chez/Thread.ss b/src/Chez/Thread.ss new file mode 100644 index 0000000..c1d0dba --- /dev/null +++ b/src/Chez/Thread.ss @@ -0,0 +1,36 @@ +(library (Chez.Thread foreign) + (export + forkThreadImpl + joinThreadImpl + makeMutex + withMutexImpl + mutexNameImpl + makeCondition + conditionWaitImpl + conditionSignalImpl + sleepImpl) + (import (chezscheme)) + + (define forkThreadImpl + (lambda (threadFn) + (fork-thread + (lambda () + (threadFn (get-thread-id)))))) + + (define joinThreadImpl (lambda (thread) (thread-join thread))) + + (define makeMutex (lambda () (make-mutex))) + + (define withMutexImpl (lambda (mutex thunk) (with-mutex mutex (thunk)))) + + (define mutexNameImpl (lambda (mutex) (mutex-name mutex))) + + (define makeCondition (lambda () (make-condition))) + + (define conditionWaitImpl (lambda (condition mutex) (condition-wait condition mutex))) + + (define conditionSignalImpl (lambda (condition) (condition-signal condition))) + + ;; TODO: make-time shoud probably be in a Chez.Time module + (define sleepImpl (lambda (nanoseconds seconds) (sleep (make-time 'time-duration nanoseconds seconds)))) + ) diff --git a/test/Test/Main.purs b/test/Test/Main.purs new file mode 100644 index 0000000..221ab1a --- /dev/null +++ b/test/Test/Main.purs @@ -0,0 +1,35 @@ +module Test.Chez.Main where + +import Prelude + +import Chez.Thread as Thread +import Data.Array as Array +import Data.Time.Duration (Milliseconds(..)) +import Data.Traversable (for, for_) +import Effect (Effect) +import Effect.Ref as Ref +import Effect.Unsafe (unsafePerformEffect) +import Test.Assert (assertEqual) + +main :: Effect Unit +main = do + counter <- Ref.new 0 + + let + modifyFn :: Int -> Int + modifyFn x = unsafePerformEffect do + Thread.sleep (Milliseconds 10.0) + pure (x + 1) + + threadFn _threadId = do + for_ (Array.range 0 9) \_ -> do + newCounter <- Ref.modify modifyFn counter + -- log $ "Thread " <> show (Thread.threadIdToInt threadId) <> ": new counter is " <> show newCounter + pure newCounter + + threads <- for (Array.range 0 9) \_ -> Thread.fork threadFn + + for_ threads Thread.join + + finalCount <- Ref.read counter + assertEqual { actual: finalCount, expected: 100 }