mirror of
https://github.com/tweag/asterius.git
synced 2024-09-11 08:55:32 +03:00
Move to GHC 8.10, plus misc other fixes (#860)
This commit is contained in:
parent
e7b823c874
commit
9c75ad777d
@ -1 +0,0 @@
|
||||
steps: []
|
@ -1,17 +0,0 @@
|
||||
#!/bin/bash
|
||||
|
||||
set -euo pipefail
|
||||
|
||||
export CPUS=$(getconf _NPROCESSORS_ONLN 2>/dev/null)
|
||||
export MAKEFLAGS=-j$CPUS
|
||||
|
||||
stack update
|
||||
stack build --test --no-run-tests \
|
||||
asterius \
|
||||
ghc-toolkit \
|
||||
wasm-toolkit
|
||||
|
||||
. .envrc
|
||||
ahc-boot
|
||||
|
||||
direnv allow .envrc
|
@ -1,37 +0,0 @@
|
||||
{
|
||||
"name": "asterius",
|
||||
"image": "terrorjack/asterius:dev",
|
||||
"forwardPorts": [3000],
|
||||
"postCreateCommand": [".devcontainer/build.sh"],
|
||||
"extensions": [
|
||||
"justusadam.language-haskell",
|
||||
"hoovercj.haskell-linter",
|
||||
"maxgabriel.brittany",
|
||||
"sjurmillidahl.ormolu-vscode",
|
||||
"esbenp.prettier-vscode",
|
||||
"stkb.rewrap"
|
||||
],
|
||||
"settings": {
|
||||
"editor.tabSize": 2,
|
||||
"files.eol": "\n",
|
||||
"files.encoding": "utf8",
|
||||
"files.trimFinalNewlines": true,
|
||||
"files.trimTrailingWhitespace": true,
|
||||
"files.insertFinalNewline": true,
|
||||
"[haskell]": {
|
||||
"editor.defaultFormatter": "sjurmillidahl.ormolu-vscode"
|
||||
},
|
||||
"[javascript]": {
|
||||
"editor.defaultFormatter": "esbenp.prettier-vscode"
|
||||
},
|
||||
"[json]": {
|
||||
"editor.defaultFormatter": "esbenp.prettier-vscode"
|
||||
},
|
||||
"[jsonc]": {
|
||||
"editor.defaultFormatter": "esbenp.prettier-vscode"
|
||||
},
|
||||
"[typescript]": {
|
||||
"editor.defaultFormatter": "esbenp.prettier-vscode"
|
||||
}
|
||||
}
|
||||
}
|
@ -1,5 +0,0 @@
|
||||
**/.git
|
||||
**/.stack-work
|
||||
**/stack.yaml.lock
|
||||
|
||||
/lib
|
12
.github/workflows/boot.sh
vendored
12
.github/workflows/boot.sh
vendored
@ -1,12 +0,0 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -eu
|
||||
|
||||
stack update
|
||||
|
||||
stack -j2 build --test --no-run-tests \
|
||||
asterius
|
||||
|
||||
. ./.envrc
|
||||
|
||||
ahc-boot
|
312
.github/workflows/pipeline.yml
vendored
312
.github/workflows/pipeline.yml
vendored
@ -6,329 +6,19 @@ on:
|
||||
|
||||
jobs:
|
||||
|
||||
boot:
|
||||
name: boot
|
||||
runs-on: ubuntu-20.04
|
||||
steps:
|
||||
|
||||
- name: setup-haskell
|
||||
uses: actions/setup-haskell@v1
|
||||
with:
|
||||
ghc-version: 8.8.4
|
||||
cabal-version: 3.2.0.0
|
||||
stack-version: 2.5.1
|
||||
enable-stack: true
|
||||
|
||||
- name: setup-node-15
|
||||
uses: actions/setup-node@v2-beta
|
||||
with:
|
||||
node-version: 15.6.0
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- name: materialize
|
||||
run: |
|
||||
mkdir lib
|
||||
|
||||
pushd lib
|
||||
|
||||
mkdir ~/.stack
|
||||
echo "system-ghc: true" > ~/.stack/config.yaml
|
||||
../utils/make-packages.py
|
||||
rm -rf ghc
|
||||
|
||||
popd
|
||||
|
||||
- name: upload-artifact
|
||||
uses: actions/upload-artifact@v2
|
||||
with:
|
||||
name: lib
|
||||
path: lib
|
||||
|
||||
- name: setup-deps
|
||||
run: |
|
||||
.github/workflows/setup-deps.sh
|
||||
|
||||
- name: boot
|
||||
run: |
|
||||
.github/workflows/boot.sh
|
||||
|
||||
- name: upload-cache
|
||||
uses: actions/cache@v2
|
||||
with:
|
||||
key: cache-${{ github.sha }}
|
||||
path: |
|
||||
~/.stack
|
||||
**/.stack-work
|
||||
lib
|
||||
|
||||
test:
|
||||
name: test-${{ matrix.with-pic }}
|
||||
needs: boot
|
||||
runs-on: ubuntu-20.04
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
with-pic:
|
||||
- "--pic"
|
||||
- ""
|
||||
env:
|
||||
ASTERIUS_WITH_PIC: ${{ matrix.with-pic }}
|
||||
steps:
|
||||
|
||||
- name: setup-haskell
|
||||
uses: actions/setup-haskell@v1
|
||||
with:
|
||||
ghc-version: 8.8.4
|
||||
cabal-version: 3.2.0.0
|
||||
stack-version: 2.5.1
|
||||
enable-stack: true
|
||||
|
||||
- name: setup-node-15
|
||||
uses: actions/setup-node@v2-beta
|
||||
with:
|
||||
node-version: 15.6.0
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- name: download-cache
|
||||
uses: actions/cache@v2
|
||||
with:
|
||||
key: cache-${{ github.sha }}
|
||||
path: |
|
||||
~/.stack
|
||||
**/.stack-work
|
||||
lib
|
||||
|
||||
- name: setup-deps
|
||||
run: |
|
||||
.github/workflows/setup-deps.sh
|
||||
|
||||
- name: setup-wasm-deps
|
||||
run: |
|
||||
. ./.envrc
|
||||
ahc-cabal v1-update
|
||||
pushd ghc-toolkit/boot-libs
|
||||
ahc-cabal v1-install -j2 \
|
||||
wai-middleware-caching
|
||||
popd
|
||||
|
||||
- name: test
|
||||
run: |
|
||||
export WASI_SDK_PATH=/opt/wasi-sdk
|
||||
|
||||
stack test asterius:fib --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:jsffi --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:array --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:stableptr --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:rtsapi --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:teletype --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:bytearray --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:bigint --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:todomvc --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:cloudflare --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:cloudflare-new --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:exception --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:regression60 --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:sizeof_md5context --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
stack test asterius:largenum --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
|
||||
stack test asterius:bytearray --test-arguments="--yolo $ASTERIUS_WITH_PIC"
|
||||
stack test asterius:bytearray --test-arguments="--gc-threshold=128 $ASTERIUS_WITH_PIC"
|
||||
stack test asterius:fib --test-arguments="--no-gc-sections $ASTERIUS_WITH_PIC"
|
||||
|
||||
stack test asterius:fib --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:jsffi --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:array --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:stableptr --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:rtsapi --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:teletype --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
# stack test asterius:bytearray --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:bigint --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
stack test asterius:exception --test-arguments="--debug $ASTERIUS_WITH_PIC" &> /dev/null
|
||||
|
||||
stack test asterius:fib --test-arguments="--tail-calls $ASTERIUS_WITH_PIC"
|
||||
stack test asterius:fib --test-arguments="--tail-calls --no-gc-sections $ASTERIUS_WITH_PIC"
|
||||
|
||||
# stack test asterius:nomain --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
# stack test asterius:nomain --test-arguments="--tail-calls $ASTERIUS_WITH_PIC"
|
||||
|
||||
stack test asterius:th --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
|
||||
stack test asterius:primitive --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
|
||||
stack test asterius:argv --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
|
||||
stack test asterius:endianness --test-arguments="$ASTERIUS_WITH_PIC"
|
||||
|
||||
ghc-testsuite:
|
||||
name: ghc-testsuite
|
||||
needs: boot
|
||||
runs-on: ubuntu-20.04
|
||||
steps:
|
||||
|
||||
- name: setup-haskell
|
||||
uses: actions/setup-haskell@v1
|
||||
with:
|
||||
ghc-version: 8.8.4
|
||||
cabal-version: 3.2.0.0
|
||||
stack-version: 2.5.1
|
||||
enable-stack: true
|
||||
|
||||
- name: setup-node-15
|
||||
uses: actions/setup-node@v2-beta
|
||||
with:
|
||||
node-version: 15.6.0
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- name: download-cache
|
||||
uses: actions/cache@v2
|
||||
with:
|
||||
key: cache-${{ github.sha }}
|
||||
path: |
|
||||
~/.stack
|
||||
**/.stack-work
|
||||
lib
|
||||
|
||||
- name: setup-deps
|
||||
run: |
|
||||
.github/workflows/setup-deps.sh
|
||||
|
||||
- name: ghc-testsuite
|
||||
run: |
|
||||
export WASI_SDK_PATH=/opt/wasi-sdk
|
||||
export GHCRTS=-N2
|
||||
stack test asterius:ghc-testsuite --test-arguments="-j2 --timeout=300s" || true
|
||||
|
||||
- name: upload-artifact
|
||||
uses: actions/upload-artifact@v2
|
||||
with:
|
||||
name: test-report.csv
|
||||
path: asterius/test-report.csv
|
||||
|
||||
test-cabal:
|
||||
name: test-cabal
|
||||
needs: boot
|
||||
runs-on: ubuntu-20.04
|
||||
steps:
|
||||
|
||||
- name: setup-haskell
|
||||
uses: actions/setup-haskell@v1
|
||||
with:
|
||||
ghc-version: 8.8.4
|
||||
cabal-version: 3.2.0.0
|
||||
stack-version: 2.5.1
|
||||
enable-stack: true
|
||||
|
||||
- name: setup-node-15
|
||||
uses: actions/setup-node@v2-beta
|
||||
with:
|
||||
node-version: 15.6.0
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- name: download-cache
|
||||
uses: actions/cache@v2
|
||||
with:
|
||||
key: cache-${{ github.sha }}
|
||||
path: |
|
||||
~/.stack
|
||||
**/.stack-work
|
||||
lib
|
||||
|
||||
- name: setup-deps
|
||||
run: |
|
||||
.github/workflows/setup-deps.sh
|
||||
|
||||
- name: test-cabal
|
||||
run: |
|
||||
export WASI_SDK_PATH=/opt/wasi-sdk
|
||||
|
||||
. ./.envrc
|
||||
pushd ghc-toolkit/boot-libs
|
||||
|
||||
ahc-cabal update
|
||||
|
||||
pushd $(mktemp -d)
|
||||
ahc-cabal v2-install --installdir . hello
|
||||
ahc-dist --input-exe hello --run
|
||||
popd
|
||||
|
||||
export ASTERIUS_AHC_LD_IGNORE=1
|
||||
ahc-cabal v1-install --ghc-option=-j2 \
|
||||
Cabal
|
||||
ahc-cabal v1-install -j2 \
|
||||
diagrams \
|
||||
hlint \
|
||||
miso
|
||||
|
||||
popd
|
||||
|
||||
image:
|
||||
name: image-${{ matrix.image }}
|
||||
runs-on: ubuntu-20.04
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
image:
|
||||
- base
|
||||
- dev
|
||||
- dev.rootless
|
||||
env:
|
||||
ASTERIUS_IMAGE: ${{ matrix.image }}
|
||||
steps:
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- name: build
|
||||
run: |
|
||||
podman build \
|
||||
--file $ASTERIUS_IMAGE.Dockerfile \
|
||||
--label "gitrev=$(git rev-parse HEAD)" \
|
||||
--squash \
|
||||
--tag terrorjack/asterius:$ASTERIUS_IMAGE \
|
||||
.
|
||||
|
||||
podman push terrorjack/asterius:$ASTERIUS_IMAGE docker-daemon:terrorjack/asterius:$ASTERIUS_IMAGE
|
||||
docker save terrorjack/asterius:$ASTERIUS_IMAGE | zstd -T2 -12 -o image-$ASTERIUS_IMAGE.tar.zst
|
||||
|
||||
- name: upload-artifact
|
||||
uses: actions/upload-artifact@v2
|
||||
with:
|
||||
name: image-${{ matrix.image }}
|
||||
path: image-${{ matrix.image }}.tar.zst
|
||||
|
||||
docs:
|
||||
name: docs
|
||||
runs-on: ubuntu-20.04
|
||||
runs-on: ubuntu-latest
|
||||
env:
|
||||
NETLIFY_AUTH_TOKEN: ${{ secrets.NETLIFY_AUTH_TOKEN }}
|
||||
NETLIFY_SITE_ID: ${{ secrets.NETLIFY_SITE_ID }}
|
||||
steps:
|
||||
|
||||
- name: setup-python
|
||||
uses: actions/setup-python@v2
|
||||
with:
|
||||
python-version: 3.9.1
|
||||
|
||||
- name: setup-node-15
|
||||
uses: actions/setup-node@v2-beta
|
||||
with:
|
||||
node-version: 15.6.0
|
||||
|
||||
- name: setup-deps
|
||||
run: |
|
||||
pip install \
|
||||
recommonmark \
|
||||
sphinx
|
||||
npm install -g \
|
||||
netlify-cli
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
|
23
.github/workflows/setup-deps.sh
vendored
23
.github/workflows/setup-deps.sh
vendored
@ -1,23 +0,0 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -eu
|
||||
|
||||
npm install -g \
|
||||
@cloudflare/wrangler \
|
||||
webpack \
|
||||
webpack-cli
|
||||
|
||||
sudo apt install -y \
|
||||
alex \
|
||||
c2hs \
|
||||
cpphs \
|
||||
happy
|
||||
|
||||
curl \
|
||||
-o /tmp/binaryen.deb \
|
||||
http://deb.debian.org/debian/pool/main/b/binaryen/binaryen_99-2_amd64.deb
|
||||
sudo dpkg -i /tmp/binaryen.deb
|
||||
rm /tmp/binaryen.deb
|
||||
|
||||
sudo mkdir -p /opt/wasi-sdk
|
||||
curl -L https://github.com/TerrorJack/wasi-sdk/releases/download/210113/wasi-sdk-12.1g41fa3294474c-linux.tar.gz | sudo tar xz -C /opt/wasi-sdk --strip-components=1
|
43
.github/workflows/shell.yml
vendored
Normal file
43
.github/workflows/shell.yml
vendored
Normal file
@ -0,0 +1,43 @@
|
||||
name: shell
|
||||
|
||||
on:
|
||||
- push
|
||||
- pull_request
|
||||
|
||||
jobs:
|
||||
|
||||
shell:
|
||||
name: shell-${{ matrix.os }}
|
||||
runs-on: ${{ matrix.os }}
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
os:
|
||||
- ubuntu-latest
|
||||
steps:
|
||||
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
with:
|
||||
submodules: recursive
|
||||
|
||||
- name: setup-nix
|
||||
uses: cachix/install-nix-action@v14.1
|
||||
with:
|
||||
extra_nix_config: |
|
||||
substituters = https://cache.nixos.org https://hydra.iohk.io
|
||||
trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
|
||||
|
||||
- name: setup-cachix
|
||||
uses: cachix/cachix-action@v10
|
||||
with:
|
||||
name: asterius
|
||||
signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}'
|
||||
|
||||
- name: cachix-watch-store
|
||||
run: |
|
||||
cachix watch-store -c9 asterius &
|
||||
|
||||
- name: shell
|
||||
run: |
|
||||
nix-shell --keep-going --run "cabal build asterius && asterius/boot.sh"
|
5
.gitignore
vendored
5
.gitignore
vendored
@ -22,3 +22,8 @@ package-lock.json
|
||||
/test
|
||||
|
||||
/lib
|
||||
|
||||
cabal.project.local
|
||||
.vscode
|
||||
|
||||
sysroot
|
||||
|
@ -1,12 +0,0 @@
|
||||
import Asterius.Boot
|
||||
import Asterius.FixEnv
|
||||
import System.Environment.Blank
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
fixEnv
|
||||
conf_opts <- getEnvDefault "ASTERIUS_CONFIGURE_OPTIONS" ""
|
||||
boot
|
||||
defaultBootArgs
|
||||
{ configureOptions = configureOptions defaultBootArgs <> " " <> conf_opts
|
||||
}
|
@ -1,12 +1,9 @@
|
||||
import Asterius.BuildInfo
|
||||
import Asterius.FixEnv
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import qualified Paths_asterius
|
||||
import qualified Asterius.Sysroot as A
|
||||
import System.Directory
|
||||
import System.Environment.Blank
|
||||
import System.FilePath
|
||||
import System.Process (callProcess)
|
||||
import System.FilePath
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@ -14,19 +11,8 @@ main = do
|
||||
ahc_cabal_root <- getAppUserDataDirectory "ahc-cabal"
|
||||
createDirectoryIfMissing True ahc_cabal_root
|
||||
let ahc_cabal_config_path = ahc_cabal_root </> "config"
|
||||
ahc_cabal_config <-
|
||||
readFile
|
||||
=<< Paths_asterius.getDataFileName ("cabal" </> "config")
|
||||
writeFile ahc_cabal_config_path $
|
||||
"install-dirs global\n prefix: "
|
||||
<> ahcLibDir
|
||||
<> "\nprogram-default-options\n hsc2hs-options: --cross-compile"
|
||||
<> "\nwith-compiler: "
|
||||
<> ahc
|
||||
<> "\nwith-hc-pkg: "
|
||||
<> ahcPkg
|
||||
<> "\n"
|
||||
<> ahc_cabal_config
|
||||
ahc_cabal_config <- readFile $ A.srcDir </> "asterius" </> "cabal" </> "config"
|
||||
writeFile ahc_cabal_config_path ahc_cabal_config
|
||||
unsetEnv "CABAL_CONFIG"
|
||||
setEnv "CABAL_DIR" ahc_cabal_root True
|
||||
args <- getArgs
|
||||
|
@ -1,10 +0,0 @@
|
||||
#!/bin/sh -e
|
||||
|
||||
rm -rf $ASTERIUS_TMP_DIR $ASTERIUS_LIB_DIR
|
||||
mkdir -p $ASTERIUS_TMP_DIR
|
||||
mkdir -p $ASTERIUS_LIB_DIR
|
||||
cp -r $ASTERIUS_SANDBOX_GHC_LIBDIR/. $ASTERIUS_LIB_DIR
|
||||
mkdir $ASTERIUS_LIB_DIR/package.conf.d
|
||||
cp $ASTERIUS_BOOT_LIBS_DIR/rts/rts.conf $ASTERIUS_LIB_DIR/package.conf.d/
|
||||
$ASTERIUS_AHCPKG --package-db=$ASTERIUS_LIB_DIR/package.conf.d recache
|
||||
mkdir $ASTERIUS_LIB_DIR/rts
|
121
asterius/boot.sh
121
asterius/boot.sh
@ -1,86 +1,119 @@
|
||||
#!/bin/bash
|
||||
#!/usr/bin/env bash
|
||||
|
||||
set -euo pipefail
|
||||
set -euox pipefail
|
||||
|
||||
cp -r $ASTERIUS_BOOT_LIBS_DIR .
|
||||
pushd boot-libs
|
||||
AHC_TMPDIR=$(mktemp -d)
|
||||
export AHC_TMPDIR
|
||||
|
||||
cp -r "$AHC_SRCDIR"/ghc-toolkit/boot-libs/* "$GHC_ASTERIUS_BOOT"/* "$AHC_TMPDIR"
|
||||
chmod u+w -R "$AHC_TMPDIR"
|
||||
|
||||
rm -rf "$AHC_LIBDIR"
|
||||
mkdir -p "$AHC_LIBDIR"
|
||||
|
||||
cp -r \
|
||||
"$GHC_ASTERIUS"/ghc-asterius/autogen \
|
||||
"$AHC_LIBDIR"/include
|
||||
cp \
|
||||
"$GHC_ASTERIUS_BOOT"/llvm-passes \
|
||||
"$GHC_ASTERIUS_BOOT"/llvm-targets \
|
||||
"$GHC_ASTERIUS_BOOT"/platformConstants \
|
||||
"$GHC_ASTERIUS_BOOT"/settings \
|
||||
"$GHC_ASTERIUS_BOOT"/template-hsc.h \
|
||||
"$AHC_LIBDIR"
|
||||
chmod u+w -R "$AHC_LIBDIR"
|
||||
|
||||
mkdir "$AHC_LIBDIR"/package.conf.d
|
||||
cp "$AHC_SRCDIR"/ghc-toolkit/boot-libs/rts/rts.conf "$AHC_LIBDIR"/package.conf.d
|
||||
ahc-pkg --global recache
|
||||
|
||||
mkdir "$AHC_LIBDIR"/rts
|
||||
find "$AHC_TMPDIR"/rts -name '*.cmm' -exec sh -c 'ahc -c -O2 -dcmm-lint -I"$AHC_LIBDIR"/include -this-unit-id rts -o "$AHC_TMPDIR"/rts/$(basename "$0" .cmm).o "$0"' {} \;
|
||||
ar qDS "$AHC_LIBDIR"/rts/libHSrts.a "$AHC_TMPDIR"/rts/*.o
|
||||
|
||||
pushd "$AHC_TMPDIR"
|
||||
|
||||
ASTERIUS_CONFIGURE_OPTIONS="--disable-shared --disable-profiling --disable-debug-info --disable-library-for-ghci --disable-split-objs --disable-split-sections --disable-library-stripping --disable-relocatable -O2 --prefix=$AHC_LIBDIR --global --ipid=\$pkg --with-compiler=ahc --with-hc-pkg=ahc-pkg --hsc2hs-option=--cross-safe --ghc-option=-v1 --ghc-option=-dsuppress-ticks"
|
||||
|
||||
pushd ghc-prim
|
||||
$ASTERIUS_SETUP_GHC_PRIM configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim $ASTERIUS_CONFIGURE_OPTIONS
|
||||
$ASTERIUS_SETUP_GHC_PRIM build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim
|
||||
$ASTERIUS_SETUP_GHC_PRIM install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-prim
|
||||
Setup-ghc-prim configure $ASTERIUS_CONFIGURE_OPTIONS
|
||||
Setup-ghc-prim build -j
|
||||
Setup-ghc-prim install
|
||||
popd
|
||||
|
||||
pushd integer-simple
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/integer-simple
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
pushd base
|
||||
autoreconf -i
|
||||
ahc-cabal act-as-setup --build-type=Configure -- configure --builddir=$ASTERIUS_TMP_DIR/dist/base -finteger-simple $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Configure -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/base
|
||||
ahc-cabal act-as-setup --build-type=Configure -- install --builddir=$ASTERIUS_TMP_DIR/dist/base
|
||||
CFLAGS=-I$AHC_TMPDIR/base ahc-cabal act-as-setup --build-type=Configure -- configure -finteger-simple $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Configure -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Configure -- install
|
||||
popd
|
||||
|
||||
pushd ghc-heap
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-heap
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
pushd ghc-boot-th
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot-th
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
ahc-cabal v1-update || true
|
||||
ahc-cabal update || true
|
||||
|
||||
ahc-cabal v1-install --only-dependencies $ASTERIUS_CONFIGURE_OPTIONS \
|
||||
unix
|
||||
ahc-cabal v1-install --allow-newer $ASTERIUS_CONFIGURE_OPTIONS array-0.5.4.0
|
||||
|
||||
ahc-cabal v1-install $ASTERIUS_CONFIGURE_OPTIONS \
|
||||
bytestring-0.10.12.0 \
|
||||
deepseq-1.4.5.0 \
|
||||
time-1.9.3
|
||||
|
||||
pushd $(mktemp -d)
|
||||
ahc-cabal get unix-2.7.2.2
|
||||
cd unix-2.7.2.2
|
||||
ahc-cabal act-as-setup --build-type=Configure -- configure --builddir=$ASTERIUS_TMP_DIR/dist/unix --ghc-option=-this-unit-id=unix $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Configure -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/unix
|
||||
ahc-cabal act-as-setup --build-type=Configure -- install --builddir=$ASTERIUS_TMP_DIR/dist/unix
|
||||
ahc-cabal act-as-setup --build-type=Configure -- configure --ghc-option=-this-unit-id=unix $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Configure -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Configure -- install
|
||||
popd
|
||||
|
||||
ahc-cabal v1-install $ASTERIUS_CONFIGURE_OPTIONS \
|
||||
binary \
|
||||
directory \
|
||||
mtl \
|
||||
pretty
|
||||
binary-0.8.8.0 \
|
||||
directory-1.3.6.0 \
|
||||
mtl-2.2.2 \
|
||||
pretty-1.1.3.6
|
||||
|
||||
pushd ghc-boot
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghc-boot
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
pushd template-haskell
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/template-haskell
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
pushd ghci
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/ghci -fghci --ghc-option=-this-unit-id=ghci $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/ghci
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/ghci
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure -fghci --ghc-option=-this-unit-id=ghci $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
ahc-cabal v1-install $ASTERIUS_CONFIGURE_OPTIONS \
|
||||
aeson \
|
||||
parsec
|
||||
aeson-1.5.6.0 \
|
||||
parsec-3.1.14.0
|
||||
|
||||
pushd asterius-prelude
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude --ghc-option=-this-unit-id=asterius-prelude $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install --builddir=$ASTERIUS_TMP_DIR/dist/asterius-prelude
|
||||
ahc-cabal act-as-setup --build-type=Simple -- configure --ghc-option=-this-unit-id=asterius-prelude $ASTERIUS_CONFIGURE_OPTIONS
|
||||
ahc-cabal act-as-setup --build-type=Simple -- build -j
|
||||
ahc-cabal act-as-setup --build-type=Simple -- install
|
||||
popd
|
||||
|
||||
popd
|
||||
|
@ -1,5 +1,5 @@
|
||||
repository hackage.fpcomplete.com
|
||||
url: https://s3.amazonaws.com/hackage.fpcomplete.com/
|
||||
repository hackage.haskell.org
|
||||
url: https://hackage.haskell.org/
|
||||
secure: True
|
||||
root-keys:
|
||||
0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d
|
||||
@ -33,3 +33,9 @@ write-ghc-environment-files: never
|
||||
documentation: False
|
||||
minimize-conflict-set: True
|
||||
jobs: $ncpus
|
||||
|
||||
program-default-options
|
||||
hsc2hs-options: --cross-compile
|
||||
|
||||
with-compiler: ahc
|
||||
with-hc-pkg: ahc-pkg
|
||||
|
@ -1,75 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards, LambdaCase #-}
|
||||
module GHCi.Leak
|
||||
( LeakIndicators
|
||||
, getLeakIndicators
|
||||
, checkLeakIndicators
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Bits
|
||||
import DynFlags ( sTargetPlatform )
|
||||
import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
|
||||
import GHC
|
||||
import GHC.Ptr (Ptr (..))
|
||||
import GHCi.Util
|
||||
import HscTypes
|
||||
import Outputable
|
||||
import Platform (target32Bit)
|
||||
import Prelude
|
||||
import System.Mem
|
||||
import System.Mem.Weak
|
||||
import UniqDFM
|
||||
|
||||
-- Checking for space leaks in GHCi. See #15111, and the
|
||||
-- -fghci-leak-check flag.
|
||||
|
||||
data LeakIndicators = LeakIndicators [LeakModIndicators]
|
||||
|
||||
data LeakModIndicators = LeakModIndicators
|
||||
{ leakMod :: Weak HomeModInfo
|
||||
, leakIface :: Weak ModIface
|
||||
, leakDetails :: Weak ModDetails
|
||||
, leakLinkable :: Maybe (Weak Linkable)
|
||||
}
|
||||
|
||||
-- | Grab weak references to some of the data structures representing
|
||||
-- the currently loaded modules.
|
||||
getLeakIndicators :: HscEnv -> IO LeakIndicators
|
||||
getLeakIndicators HscEnv{..} =
|
||||
fmap LeakIndicators $
|
||||
forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do
|
||||
leakMod <- mkWeakPtr hmi Nothing
|
||||
leakIface <- mkWeakPtr hm_iface Nothing
|
||||
leakDetails <- mkWeakPtr hm_details Nothing
|
||||
leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable
|
||||
return $ LeakModIndicators{..}
|
||||
|
||||
-- | Look at the LeakIndicators collected by an earlier call to
|
||||
-- `getLeakIndicators`, and print messasges if any of them are still
|
||||
-- alive.
|
||||
checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()
|
||||
checkLeakIndicators dflags (LeakIndicators leakmods) = do
|
||||
performGC
|
||||
forM_ leakmods $ \LeakModIndicators{..} -> do
|
||||
deRefWeak leakMod >>= \case
|
||||
Nothing -> return ()
|
||||
Just hmi ->
|
||||
report ("HomeModInfo for " ++
|
||||
showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
|
||||
deRefWeak leakIface >>= report "ModIface"
|
||||
deRefWeak leakDetails >>= report "ModDetails"
|
||||
forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
|
||||
where
|
||||
report :: String -> Maybe a -> IO ()
|
||||
report _ Nothing = return ()
|
||||
report msg (Just a) = do
|
||||
addr <- anyToPtr a
|
||||
putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++
|
||||
show (maskTagBits addr))
|
||||
|
||||
tagBits
|
||||
| target32Bit (sTargetPlatform (settings dflags)) = 2
|
||||
| otherwise = 3
|
||||
|
||||
maskTagBits :: Ptr a -> Ptr a
|
||||
maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
|
File diff suppressed because it is too large
Load Diff
@ -1,379 +0,0 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- | Get information on modules, expressions, and identifiers
|
||||
module GHCi.UI.Info
|
||||
( ModInfo(..)
|
||||
, SpanInfo(..)
|
||||
, spanInfoFromRealSrcSpan
|
||||
, collectInfo
|
||||
, findLoc
|
||||
, findNameUses
|
||||
, findType
|
||||
, getModInfo
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Data
|
||||
import Data.Function
|
||||
import Data.List
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Data.Time
|
||||
import Prelude hiding (mod,(<>))
|
||||
import System.Directory
|
||||
|
||||
import qualified CoreUtils
|
||||
import Desugar
|
||||
import DynFlags (HasDynFlags(..))
|
||||
import FastString
|
||||
import GHC
|
||||
import GhcMonad
|
||||
import Name
|
||||
import NameSet
|
||||
import Outputable
|
||||
import SrcLoc
|
||||
import TcHsSyn
|
||||
import Var
|
||||
|
||||
-- | Info about a module. This information is generated every time a
|
||||
-- module is loaded.
|
||||
data ModInfo = ModInfo
|
||||
{ modinfoSummary :: !ModSummary
|
||||
-- ^ Summary generated by GHC. Can be used to access more
|
||||
-- information about the module.
|
||||
, modinfoSpans :: [SpanInfo]
|
||||
-- ^ Generated set of information about all spans in the
|
||||
-- module that correspond to some kind of identifier for
|
||||
-- which there will be type info and/or location info.
|
||||
, modinfoInfo :: !ModuleInfo
|
||||
-- ^ Again, useful from GHC for accessing information
|
||||
-- (exports, instances, scope) from a module.
|
||||
, modinfoLastUpdate :: !UTCTime
|
||||
-- ^ The timestamp of the file used to generate this record.
|
||||
}
|
||||
|
||||
-- | Type of some span of source code. Most of these fields are
|
||||
-- unboxed but Haddock doesn't show that.
|
||||
data SpanInfo = SpanInfo
|
||||
{ spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan
|
||||
-- ^ The span we associate information with
|
||||
, spaninfoType :: !(Maybe Type)
|
||||
-- ^ The 'Type' associated with the span
|
||||
, spaninfoVar :: !(Maybe Id)
|
||||
-- ^ The actual 'Var' associated with the span, if
|
||||
-- any. This can be useful for accessing a variety of
|
||||
-- information about the identifier such as module,
|
||||
-- locality, definition location, etc.
|
||||
}
|
||||
|
||||
-- | Test whether second span is contained in (or equal to) first span.
|
||||
-- This is basically 'containsSpan' for 'SpanInfo'
|
||||
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
|
||||
containsSpanInfo = containsSpan `on` spaninfoSrcSpan
|
||||
|
||||
-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
|
||||
spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
|
||||
spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
|
||||
|
||||
-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
|
||||
-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
|
||||
-- respectively)
|
||||
spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
|
||||
spanInfoFromRealSrcSpan spn mty mvar =
|
||||
SpanInfo spn mty mvar
|
||||
|
||||
-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
|
||||
-- only a 'RealSrcSpan'
|
||||
spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
|
||||
spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
|
||||
|
||||
-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
|
||||
srcSpanFilePath :: RealSrcSpan -> FilePath
|
||||
srcSpanFilePath = unpackFS . srcSpanFile
|
||||
|
||||
-- | Try to find the location of the given identifier at the given
|
||||
-- position in the module.
|
||||
findLoc :: GhcMonad m
|
||||
=> Map ModuleName ModInfo
|
||||
-> RealSrcSpan
|
||||
-> String
|
||||
-> ExceptT SDoc m (ModInfo,Name,SrcSpan)
|
||||
findLoc infos span0 string = do
|
||||
name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
|
||||
guessModule infos (srcSpanFilePath span0)
|
||||
|
||||
info <- maybeToExceptT "No module info for current file! Try loading it?" $
|
||||
MaybeT $ pure $ M.lookup name infos
|
||||
|
||||
name' <- findName infos span0 info string
|
||||
|
||||
case getSrcSpan name' of
|
||||
UnhelpfulSpan{} -> do
|
||||
throwE ("Found a name, but no location information." <+>
|
||||
"The module is:" <+>
|
||||
maybe "<unknown>" (ppr . moduleName)
|
||||
(nameModule_maybe name'))
|
||||
|
||||
span' -> return (info,name',span')
|
||||
|
||||
-- | Find any uses of the given identifier in the codebase.
|
||||
findNameUses :: (GhcMonad m)
|
||||
=> Map ModuleName ModInfo
|
||||
-> RealSrcSpan
|
||||
-> String
|
||||
-> ExceptT SDoc m [SrcSpan]
|
||||
findNameUses infos span0 string =
|
||||
locToSpans <$> findLoc infos span0 string
|
||||
where
|
||||
locToSpans (modinfo,name',span') =
|
||||
stripSurrounding (span' : map toSrcSpan spans)
|
||||
where
|
||||
toSrcSpan = RealSrcSpan . spaninfoSrcSpan
|
||||
spans = filter ((== Just name') . fmap getName . spaninfoVar)
|
||||
(modinfoSpans modinfo)
|
||||
|
||||
-- | Filter out redundant spans which surround/contain other spans.
|
||||
stripSurrounding :: [SrcSpan] -> [SrcSpan]
|
||||
stripSurrounding xs = filter (not . isRedundant) xs
|
||||
where
|
||||
isRedundant x = any (x `strictlyContains`) xs
|
||||
|
||||
(RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
|
||||
= s1 /= s2 && s1 `containsSpan` s2
|
||||
_ `strictlyContains` _ = False
|
||||
|
||||
-- | Try to resolve the name located at the given position, or
|
||||
-- otherwise resolve based on the current module's scope.
|
||||
findName :: GhcMonad m
|
||||
=> Map ModuleName ModInfo
|
||||
-> RealSrcSpan
|
||||
-> ModInfo
|
||||
-> String
|
||||
-> ExceptT SDoc m Name
|
||||
findName infos span0 mi string =
|
||||
case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
|
||||
Nothing -> tryExternalModuleResolution
|
||||
Just name ->
|
||||
case getSrcSpan name of
|
||||
UnhelpfulSpan {} -> tryExternalModuleResolution
|
||||
RealSrcSpan {} -> return (getName name)
|
||||
where
|
||||
tryExternalModuleResolution =
|
||||
case find (matchName $ mkFastString string)
|
||||
(fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
|
||||
Nothing -> throwE "Couldn't resolve to any modules."
|
||||
Just imported -> resolveNameFromModule infos imported
|
||||
|
||||
matchName :: FastString -> Name -> Bool
|
||||
matchName str name =
|
||||
str ==
|
||||
occNameFS (getOccName name)
|
||||
|
||||
-- | Try to resolve the name from another (loaded) module's exports.
|
||||
resolveNameFromModule :: GhcMonad m
|
||||
=> Map ModuleName ModInfo
|
||||
-> Name
|
||||
-> ExceptT SDoc m Name
|
||||
resolveNameFromModule infos name = do
|
||||
modL <- maybe (throwE $ "No module for" <+> ppr name) return $
|
||||
nameModule_maybe name
|
||||
|
||||
info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
|
||||
ppr modL)) return $
|
||||
M.lookup (moduleName modL) infos
|
||||
|
||||
maybe (throwE "No matching export in any local modules.") return $
|
||||
find (matchName name) (modInfoExports (modinfoInfo info))
|
||||
where
|
||||
matchName :: Name -> Name -> Bool
|
||||
matchName x y = occNameFS (getOccName x) ==
|
||||
occNameFS (getOccName y)
|
||||
|
||||
-- | Try to resolve the type display from the given span.
|
||||
resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
|
||||
resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
|
||||
reverse spans' `spaninfosWithin` si
|
||||
|
||||
-- | Try to find the type of the given span.
|
||||
findType :: GhcMonad m
|
||||
=> Map ModuleName ModInfo
|
||||
-> RealSrcSpan
|
||||
-> String
|
||||
-> ExceptT SDoc m (ModInfo, Type)
|
||||
findType infos span0 string = do
|
||||
name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
|
||||
guessModule infos (srcSpanFilePath span0)
|
||||
|
||||
info <- maybeToExceptT "No module info for current file! Try loading it?" $
|
||||
MaybeT $ pure $ M.lookup name infos
|
||||
|
||||
case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
|
||||
Nothing -> (,) info <$> lift (exprType TM_Inst string)
|
||||
Just ty -> return (info, ty)
|
||||
where
|
||||
-- | Try to resolve the type display from the given span.
|
||||
resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
|
||||
resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
|
||||
reverse spans' `spaninfosWithin` si
|
||||
|
||||
-- | Guess a module name from a file path.
|
||||
guessModule :: GhcMonad m
|
||||
=> Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
|
||||
guessModule infos fp = do
|
||||
target <- lift $ guessTarget fp Nothing
|
||||
case targetId target of
|
||||
TargetModule mn -> return mn
|
||||
TargetFile fp' _ -> guessModule' fp'
|
||||
where
|
||||
guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
|
||||
guessModule' fp' = case findModByFp fp' of
|
||||
Just mn -> return mn
|
||||
Nothing -> do
|
||||
fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
|
||||
|
||||
target' <- lift $ guessTarget fp'' Nothing
|
||||
case targetId target' of
|
||||
TargetModule mn -> return mn
|
||||
_ -> MaybeT . pure $ findModByFp fp''
|
||||
|
||||
findModByFp :: FilePath -> Maybe ModuleName
|
||||
findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
|
||||
where
|
||||
mifp :: (ModuleName, ModInfo) -> Maybe FilePath
|
||||
mifp = ml_hs_file . ms_location . modinfoSummary . snd
|
||||
|
||||
|
||||
-- | Collect type info data for the loaded modules.
|
||||
collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
|
||||
-> m (Map ModuleName ModInfo)
|
||||
collectInfo ms loaded = do
|
||||
df <- getDynFlags
|
||||
liftIO (filterM cacheInvalid loaded) >>= \case
|
||||
[] -> return ms
|
||||
invalidated -> do
|
||||
liftIO (putStrLn ("Collecting type info for " ++
|
||||
show (length invalidated) ++
|
||||
" module(s) ... "))
|
||||
|
||||
foldM (go df) ms invalidated
|
||||
where
|
||||
go df m name = do { info <- getModInfo name; return (M.insert name info m) }
|
||||
`gcatch`
|
||||
(\(e :: SomeException) -> do
|
||||
liftIO $ putStrLn
|
||||
$ showSDocForUser df alwaysQualify
|
||||
$ "Error while getting type info from" <+>
|
||||
ppr name <> ":" <+> text (show e)
|
||||
return m)
|
||||
|
||||
cacheInvalid name = case M.lookup name ms of
|
||||
Nothing -> return True
|
||||
Just mi -> do
|
||||
let fp = srcFilePath (modinfoSummary mi)
|
||||
last' = modinfoLastUpdate mi
|
||||
current <- getModificationTime fp
|
||||
exists <- doesFileExist fp
|
||||
if exists
|
||||
then return $ current /= last'
|
||||
else return True
|
||||
|
||||
-- | Get the source file path from a ModSummary.
|
||||
-- If the .hs file is missing, and the .o file exists,
|
||||
-- we return the .o file path.
|
||||
srcFilePath :: ModSummary -> FilePath
|
||||
srcFilePath modSum = fromMaybe obj_fp src_fp
|
||||
where
|
||||
src_fp = ml_hs_file ms_loc
|
||||
obj_fp = ml_obj_file ms_loc
|
||||
ms_loc = ms_location modSum
|
||||
|
||||
-- | Get info about the module: summary, types, etc.
|
||||
getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
|
||||
getModInfo name = do
|
||||
m <- getModSummary name
|
||||
p <- parseModule m
|
||||
typechecked <- typecheckModule p
|
||||
allTypes <- processAllTypeCheckedModule typechecked
|
||||
let i = tm_checked_module_info typechecked
|
||||
ts <- liftIO $ getModificationTime $ srcFilePath m
|
||||
return (ModInfo m allTypes i ts)
|
||||
|
||||
-- | Get ALL source spans in the module.
|
||||
processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
|
||||
-> m [SpanInfo]
|
||||
processAllTypeCheckedModule tcm = do
|
||||
bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
|
||||
ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
|
||||
pts <- mapM getTypeLPat $ listifyAllSpans tcs
|
||||
return $ mapMaybe toSpanInfo
|
||||
$ sortBy cmpSpan
|
||||
$ catMaybes (bts ++ ets ++ pts)
|
||||
where
|
||||
tcs = tm_typechecked_source tcm
|
||||
|
||||
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
|
||||
getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
|
||||
getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
|
||||
= pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
|
||||
getTypeLHsBind _ = pure Nothing
|
||||
|
||||
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
|
||||
getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
|
||||
getTypeLHsExpr e = do
|
||||
hs_env <- getSession
|
||||
(_,mbe) <- liftIO $ deSugarExpr hs_env e
|
||||
return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
|
||||
where
|
||||
mid :: Maybe Id
|
||||
mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i
|
||||
| otherwise = Nothing
|
||||
|
||||
unwrapVar (HsWrap _ _ var) = var
|
||||
unwrapVar e' = e'
|
||||
|
||||
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
|
||||
getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
|
||||
getTypeLPat (dL->L spn pat) =
|
||||
pure (Just (getMaybeId pat,spn,hsPatType pat))
|
||||
where
|
||||
getMaybeId (VarPat _ (dL->L _ vid)) = Just vid
|
||||
getMaybeId _ = Nothing
|
||||
|
||||
-- | Get ALL source spans in the source.
|
||||
listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
|
||||
listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
|
||||
where
|
||||
p (dL->L spn _) = isGoodSrcSpan spn
|
||||
|
||||
-- | Variant of @syb@'s @everything@ (which summarises all nodes
|
||||
-- in top-down, left-to-right order) with a stop-condition on 'NameSet's
|
||||
everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
|
||||
everythingAllSpans k z f x
|
||||
| (False `mkQ` (const True :: NameSet -> Bool)) x = z
|
||||
| otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
|
||||
|
||||
cmpSpan (_,a,_) (_,b,_)
|
||||
| a `isSubspanOf` b = LT
|
||||
| b `isSubspanOf` a = GT
|
||||
| otherwise = EQ
|
||||
|
||||
-- | Pretty print the types into a 'SpanInfo'.
|
||||
toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
|
||||
toSpanInfo (n,RealSrcSpan spn,typ)
|
||||
= Just $ spanInfoFromRealSrcSpan spn (Just typ) n
|
||||
toSpanInfo _ = Nothing
|
||||
|
||||
-- helper stolen from @syb@ package
|
||||
type GenericQ r = forall a. Data a => a -> r
|
||||
|
||||
mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
|
||||
(r `mkQ` br) a = maybe r br (cast a)
|
@ -1,533 +0,0 @@
|
||||
{-# LANGUAGE CPP, FlexibleInstances #-}
|
||||
{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
|
||||
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
--
|
||||
-- Monadery code used in InteractiveUI
|
||||
--
|
||||
-- (c) The GHC Team 2005-2006
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GHCi.UI.Monad (
|
||||
GHCi(..), startGHCi,
|
||||
GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
|
||||
GHCiOption(..), isOptionSet, setOption, unsetOption,
|
||||
Command(..), CommandResult(..), cmdSuccess,
|
||||
PromptFunction,
|
||||
BreakLocation(..),
|
||||
TickArray,
|
||||
getDynFlags,
|
||||
|
||||
runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
|
||||
ActionStats(..), runAndPrintStats, runWithStats, printStats,
|
||||
|
||||
printForUserNeverQualify, printForUserModInfo,
|
||||
printForUser, printForUserPartWay, prettyLocations,
|
||||
|
||||
compileGHCiExpr,
|
||||
initInterpBuffering,
|
||||
turnOffBuffering, turnOffBuffering_,
|
||||
flushInterpBuffers,
|
||||
mkEvalWrapper
|
||||
) where
|
||||
|
||||
#include "HsVersions.h"
|
||||
|
||||
import GHCi.UI.Info (ModInfo)
|
||||
import qualified GHC
|
||||
import GhcMonad hiding (liftIO)
|
||||
import Outputable hiding (printForUser, printForUserPartWay)
|
||||
import qualified Outputable
|
||||
import OccName
|
||||
import DynFlags
|
||||
import FastString
|
||||
import HscTypes
|
||||
import SrcLoc
|
||||
import Module
|
||||
import RdrName (mkOrig)
|
||||
import PrelNames (gHC_GHCI_HELPERS)
|
||||
import GHCi
|
||||
import GHCi.RemoteTypes
|
||||
import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
|
||||
import HsUtils
|
||||
import Util
|
||||
|
||||
import Exception
|
||||
import Numeric
|
||||
import Data.Array
|
||||
import Data.IORef
|
||||
import Data.Time
|
||||
import System.Environment
|
||||
import System.IO
|
||||
import Control.Monad
|
||||
import Prelude hiding ((<>))
|
||||
|
||||
import System.Console.Haskeline (CompletionFunc, InputT)
|
||||
import qualified System.Console.Haskeline as Haskeline
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified GHC.LanguageExtensions as LangExt
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- GHCi monad
|
||||
|
||||
data GHCiState = GHCiState
|
||||
{
|
||||
progname :: String,
|
||||
args :: [String],
|
||||
evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@
|
||||
prompt :: PromptFunction,
|
||||
prompt_cont :: PromptFunction,
|
||||
editor :: String,
|
||||
stop :: String,
|
||||
options :: [GHCiOption],
|
||||
line_number :: !Int, -- ^ input line
|
||||
break_ctr :: !Int,
|
||||
breaks :: ![(Int, BreakLocation)],
|
||||
tickarrays :: ModuleEnv TickArray,
|
||||
-- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
|
||||
-- so that we don't rebuild it each time the user sets
|
||||
-- a breakpoint.
|
||||
ghci_commands :: [Command],
|
||||
-- ^ available ghci commands
|
||||
ghci_macros :: [Command],
|
||||
-- ^ user-defined macros
|
||||
last_command :: Maybe Command,
|
||||
-- ^ @:@ at the GHCi prompt repeats the last command, so we
|
||||
-- remember it here
|
||||
cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),
|
||||
-- ^ The command wrapper is run for each command or statement.
|
||||
-- The 'Bool' value denotes whether the command is successful and
|
||||
-- 'Nothing' means to exit GHCi.
|
||||
cmdqueue :: [String],
|
||||
|
||||
remembered_ctx :: [InteractiveImport],
|
||||
-- ^ The imports that the user has asked for, via import
|
||||
-- declarations and :module commands. This list is
|
||||
-- persistent over :reloads (but any imports for modules
|
||||
-- that are not loaded are temporarily ignored). After a
|
||||
-- :load, all the home-package imports are stripped from
|
||||
-- this list.
|
||||
--
|
||||
-- See bugs #2049, #1873, #1360
|
||||
|
||||
transient_ctx :: [InteractiveImport],
|
||||
-- ^ An import added automatically after a :load, usually of
|
||||
-- the most recently compiled module. May be empty if
|
||||
-- there are no modules loaded. This list is replaced by
|
||||
-- :load, :reload, and :add. In between it may be modified
|
||||
-- by :module.
|
||||
|
||||
extra_imports :: [ImportDecl GhcPs],
|
||||
-- ^ These are "always-on" imports, added to the
|
||||
-- context regardless of what other imports we have.
|
||||
-- This is useful for adding imports that are required
|
||||
-- by setGHCiMonad. Be careful adding things here:
|
||||
-- you can create ambiguities if these imports overlap
|
||||
-- with other things in scope.
|
||||
--
|
||||
-- NB. although this is not currently used by GHCi itself,
|
||||
-- it was added to support other front-ends that are based
|
||||
-- on the GHCi code. Potentially we could also expose
|
||||
-- this functionality via GHCi commands.
|
||||
|
||||
prelude_imports :: [ImportDecl GhcPs],
|
||||
-- ^ These imports are added to the context when
|
||||
-- -XImplicitPrelude is on and we don't have a *-module
|
||||
-- in the context. They can also be overridden by another
|
||||
-- import for the same module, e.g.
|
||||
-- "import Prelude hiding (map)"
|
||||
|
||||
ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)
|
||||
|
||||
short_help :: String,
|
||||
-- ^ help text to display to a user
|
||||
long_help :: String,
|
||||
lastErrorLocations :: IORef [(FastString, Int)],
|
||||
|
||||
mod_infos :: !(Map ModuleName ModInfo),
|
||||
|
||||
flushStdHandles :: ForeignHValue,
|
||||
-- ^ @hFlush stdout; hFlush stderr@ in the interpreter
|
||||
noBuffering :: ForeignHValue
|
||||
-- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
|
||||
}
|
||||
|
||||
type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
|
||||
|
||||
-- | A GHCi command
|
||||
data Command
|
||||
= Command
|
||||
{ cmdName :: String
|
||||
-- ^ Name of GHCi command (e.g. "exit")
|
||||
, cmdAction :: String -> InputT GHCi Bool
|
||||
-- ^ The 'Bool' value denotes whether to exit GHCi
|
||||
, cmdHidden :: Bool
|
||||
-- ^ Commands which are excluded from default completion
|
||||
-- and @:help@ summary. This is usually set for commands not
|
||||
-- useful for interactive use but rather for IDEs.
|
||||
, cmdCompletionFunc :: CompletionFunc GHCi
|
||||
-- ^ 'CompletionFunc' for arguments
|
||||
}
|
||||
|
||||
data CommandResult
|
||||
= CommandComplete
|
||||
{ cmdInput :: String
|
||||
, cmdResult :: Either SomeException (Maybe Bool)
|
||||
, cmdStats :: ActionStats
|
||||
}
|
||||
| CommandIncomplete
|
||||
-- ^ Unterminated multiline command
|
||||
deriving Show
|
||||
|
||||
cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)
|
||||
cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e
|
||||
cmdSuccess CommandComplete{ cmdResult = Right r } = return r
|
||||
cmdSuccess CommandIncomplete = return $ Just True
|
||||
|
||||
type PromptFunction = [String]
|
||||
-> Int
|
||||
-> GHCi SDoc
|
||||
|
||||
data GHCiOption
|
||||
= ShowTiming -- show time/allocs after evaluation
|
||||
| ShowType -- show the type of expressions
|
||||
| RevertCAFs -- revert CAFs after every evaluation
|
||||
| Multiline -- use multiline commands
|
||||
| CollectInfo -- collect and cache information about
|
||||
-- modules after load
|
||||
deriving Eq
|
||||
|
||||
data BreakLocation
|
||||
= BreakLocation
|
||||
{ breakModule :: !GHC.Module
|
||||
, breakLoc :: !SrcSpan
|
||||
, breakTick :: {-# UNPACK #-} !Int
|
||||
, onBreakCmd :: String
|
||||
}
|
||||
|
||||
instance Eq BreakLocation where
|
||||
loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
|
||||
breakTick loc1 == breakTick loc2
|
||||
|
||||
prettyLocations :: [(Int, BreakLocation)] -> SDoc
|
||||
prettyLocations [] = text "No active breakpoints."
|
||||
prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
|
||||
|
||||
instance Outputable BreakLocation where
|
||||
ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
|
||||
if null (onBreakCmd loc)
|
||||
then Outputable.empty
|
||||
else doubleQuotes (text (onBreakCmd loc))
|
||||
|
||||
recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
|
||||
recordBreak brkLoc = do
|
||||
st <- getGHCiState
|
||||
let oldActiveBreaks = breaks st
|
||||
-- don't store the same break point twice
|
||||
case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
|
||||
(nm:_) -> return (True, nm)
|
||||
[] -> do
|
||||
let oldCounter = break_ctr st
|
||||
newCounter = oldCounter + 1
|
||||
setGHCiState $ st { break_ctr = newCounter,
|
||||
breaks = (oldCounter, brkLoc) : oldActiveBreaks
|
||||
}
|
||||
return (False, oldCounter)
|
||||
|
||||
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
|
||||
|
||||
reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
|
||||
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
|
||||
|
||||
reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
|
||||
reifyGHCi f = GHCi f'
|
||||
where
|
||||
-- f' :: IORef GHCiState -> Ghc a
|
||||
f' gs = reifyGhc (f'' gs)
|
||||
-- f'' :: IORef GHCiState -> Session -> IO a
|
||||
f'' gs s = f (s, gs)
|
||||
|
||||
startGHCi :: GHCi a -> GHCiState -> Ghc a
|
||||
startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
|
||||
|
||||
instance Functor GHCi where
|
||||
fmap = liftM
|
||||
|
||||
instance Applicative GHCi where
|
||||
pure a = GHCi $ \_ -> pure a
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad GHCi where
|
||||
(GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
|
||||
|
||||
class HasGhciState m where
|
||||
getGHCiState :: m GHCiState
|
||||
setGHCiState :: GHCiState -> m ()
|
||||
modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
|
||||
|
||||
instance HasGhciState GHCi where
|
||||
getGHCiState = GHCi $ \r -> liftIO $ readIORef r
|
||||
setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
|
||||
modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
|
||||
|
||||
instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where
|
||||
getGHCiState = lift getGHCiState
|
||||
setGHCiState = lift . setGHCiState
|
||||
modifyGHCiState = lift . modifyGHCiState
|
||||
|
||||
liftGhc :: Ghc a -> GHCi a
|
||||
liftGhc m = GHCi $ \_ -> m
|
||||
|
||||
instance MonadIO GHCi where
|
||||
liftIO = liftGhc . liftIO
|
||||
|
||||
instance HasDynFlags GHCi where
|
||||
getDynFlags = getSessionDynFlags
|
||||
|
||||
instance GhcMonad GHCi where
|
||||
setSession s' = liftGhc $ setSession s'
|
||||
getSession = liftGhc $ getSession
|
||||
|
||||
instance HasDynFlags (InputT GHCi) where
|
||||
getDynFlags = lift getDynFlags
|
||||
|
||||
instance GhcMonad (InputT GHCi) where
|
||||
setSession = lift . setSession
|
||||
getSession = lift getSession
|
||||
|
||||
instance ExceptionMonad GHCi where
|
||||
gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
|
||||
gmask f =
|
||||
GHCi $ \s -> gmask $ \io_restore ->
|
||||
let
|
||||
g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
|
||||
in
|
||||
unGHCi (f g_restore) s
|
||||
|
||||
instance Haskeline.MonadException Ghc where
|
||||
controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
|
||||
run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
|
||||
in fmap (flip unGhc s) $ f run'
|
||||
|
||||
instance Haskeline.MonadException GHCi where
|
||||
controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
|
||||
run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
|
||||
in fmap (flip unGHCi s) $ f run'
|
||||
|
||||
instance ExceptionMonad (InputT GHCi) where
|
||||
gcatch = Haskeline.catch
|
||||
gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
|
||||
|
||||
isOptionSet :: GHCiOption -> GHCi Bool
|
||||
isOptionSet opt
|
||||
= do st <- getGHCiState
|
||||
return (opt `elem` options st)
|
||||
|
||||
setOption :: GHCiOption -> GHCi ()
|
||||
setOption opt
|
||||
= do st <- getGHCiState
|
||||
setGHCiState (st{ options = opt : filter (/= opt) (options st) })
|
||||
|
||||
unsetOption :: GHCiOption -> GHCi ()
|
||||
unsetOption opt
|
||||
= do st <- getGHCiState
|
||||
setGHCiState (st{ options = filter (/= opt) (options st) })
|
||||
|
||||
printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
|
||||
printForUserNeverQualify doc = do
|
||||
dflags <- getDynFlags
|
||||
liftIO $ Outputable.printForUser dflags stdout neverQualify doc
|
||||
|
||||
printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
|
||||
printForUserModInfo info doc = do
|
||||
dflags <- getDynFlags
|
||||
mUnqual <- GHC.mkPrintUnqualifiedForModule info
|
||||
unqual <- maybe GHC.getPrintUnqual return mUnqual
|
||||
liftIO $ Outputable.printForUser dflags stdout unqual doc
|
||||
|
||||
printForUser :: GhcMonad m => SDoc -> m ()
|
||||
printForUser doc = do
|
||||
unqual <- GHC.getPrintUnqual
|
||||
dflags <- getDynFlags
|
||||
liftIO $ Outputable.printForUser dflags stdout unqual doc
|
||||
|
||||
printForUserPartWay :: SDoc -> GHCi ()
|
||||
printForUserPartWay doc = do
|
||||
unqual <- GHC.getPrintUnqual
|
||||
dflags <- getDynFlags
|
||||
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
|
||||
|
||||
-- | Run a single Haskell expression
|
||||
runStmt :: GhciLStmt GhcPs -> String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
|
||||
runStmt stmt stmt_text step = do
|
||||
st <- getGHCiState
|
||||
GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
|
||||
let opts = GHC.execOptions
|
||||
{ GHC.execSourceFile = progname st
|
||||
, GHC.execLineNumber = line_number st
|
||||
, GHC.execSingleStep = step
|
||||
, GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
|
||||
(EvalThis fhv) }
|
||||
Just <$> GHC.execStmt' stmt stmt_text opts
|
||||
|
||||
runDecls :: String -> GHCi (Maybe [GHC.Name])
|
||||
runDecls decls = do
|
||||
st <- getGHCiState
|
||||
reifyGHCi $ \x ->
|
||||
withProgName (progname st) $
|
||||
withArgs (args st) $
|
||||
reflectGHCi x $ do
|
||||
GHC.handleSourceError (\e -> do GHC.printException e;
|
||||
return Nothing) $ do
|
||||
r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
|
||||
return (Just r)
|
||||
|
||||
runDecls' :: [LHsDecl GhcPs] -> GHCi (Maybe [GHC.Name])
|
||||
runDecls' decls = do
|
||||
st <- getGHCiState
|
||||
reifyGHCi $ \x ->
|
||||
withProgName (progname st) $
|
||||
withArgs (args st) $
|
||||
reflectGHCi x $
|
||||
GHC.handleSourceError
|
||||
(\e -> do GHC.printException e;
|
||||
return Nothing)
|
||||
(Just <$> GHC.runParsedDecls decls)
|
||||
|
||||
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
|
||||
resume canLogSpan step = do
|
||||
st <- getGHCiState
|
||||
reifyGHCi $ \x ->
|
||||
withProgName (progname st) $
|
||||
withArgs (args st) $
|
||||
reflectGHCi x $ do
|
||||
GHC.resumeExec canLogSpan step
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- timing & statistics
|
||||
|
||||
data ActionStats = ActionStats
|
||||
{ actionAllocs :: Maybe Integer
|
||||
, actionElapsedTime :: Double
|
||||
} deriving Show
|
||||
|
||||
runAndPrintStats
|
||||
:: (a -> Maybe Integer)
|
||||
-> InputT GHCi a
|
||||
-> InputT GHCi (ActionStats, Either SomeException a)
|
||||
runAndPrintStats getAllocs action = do
|
||||
result <- runWithStats getAllocs action
|
||||
case result of
|
||||
(stats, Right{}) -> do
|
||||
showTiming <- lift $ isOptionSet ShowTiming
|
||||
when showTiming $ do
|
||||
dflags <- getDynFlags
|
||||
liftIO $ printStats dflags stats
|
||||
_ -> return ()
|
||||
return result
|
||||
|
||||
runWithStats
|
||||
:: ExceptionMonad m
|
||||
=> (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
|
||||
runWithStats getAllocs action = do
|
||||
t0 <- liftIO getCurrentTime
|
||||
result <- gtry action
|
||||
let allocs = either (const Nothing) getAllocs result
|
||||
t1 <- liftIO getCurrentTime
|
||||
let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
|
||||
return (ActionStats allocs elapsedTime, result)
|
||||
|
||||
printStats :: DynFlags -> ActionStats -> IO ()
|
||||
printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
|
||||
= do let secs_str = showFFloat (Just 2) secs
|
||||
putStrLn (showSDoc dflags (
|
||||
parens (text (secs_str "") <+> text "secs" <> comma <+>
|
||||
case mallocs of
|
||||
Nothing -> empty
|
||||
Just allocs ->
|
||||
text (separateThousands allocs) <+> text "bytes")))
|
||||
where
|
||||
separateThousands n = reverse . sep . reverse . show $ n
|
||||
where sep n'
|
||||
| n' `lengthAtMost` 3 = n'
|
||||
| otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- reverting CAFs
|
||||
|
||||
revertCAFs :: GHCi ()
|
||||
revertCAFs = do
|
||||
liftIO rts_revertCAFs
|
||||
s <- getGHCiState
|
||||
when (not (ghc_e s)) turnOffBuffering
|
||||
-- Have to turn off buffering again, because we just
|
||||
-- reverted stdout, stderr & stdin to their defaults.
|
||||
|
||||
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
|
||||
-- Make it "safe", just in case
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- To flush buffers for the *interpreted* computation we need
|
||||
-- to refer to *its* stdout/stderr handles
|
||||
|
||||
-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
|
||||
initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
|
||||
initInterpBuffering = do
|
||||
let mkHelperExpr :: OccName -> Ghc ForeignHValue
|
||||
mkHelperExpr occ =
|
||||
GHC.compileParsedExprRemote
|
||||
$ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ
|
||||
nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"
|
||||
flush <- mkHelperExpr $ mkVarOcc "flushAll"
|
||||
return (nobuf, flush)
|
||||
|
||||
-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
|
||||
flushInterpBuffers :: GHCi ()
|
||||
flushInterpBuffers = do
|
||||
st <- getGHCiState
|
||||
hsc_env <- GHC.getSession
|
||||
liftIO $ evalIO hsc_env (flushStdHandles st)
|
||||
|
||||
-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
|
||||
turnOffBuffering :: GHCi ()
|
||||
turnOffBuffering = do
|
||||
st <- getGHCiState
|
||||
turnOffBuffering_ (noBuffering st)
|
||||
|
||||
turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
|
||||
turnOffBuffering_ fhv = do
|
||||
hsc_env <- getSession
|
||||
liftIO $ evalIO hsc_env fhv
|
||||
|
||||
mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
|
||||
mkEvalWrapper progname args =
|
||||
runInternal $ GHC.compileParsedExprRemote
|
||||
$ evalWrapper `GHC.mkHsApp` nlHsString progname
|
||||
`GHC.mkHsApp` nlList (map nlHsString args)
|
||||
where
|
||||
nlHsString = nlHsLit . mkHsString
|
||||
evalWrapper =
|
||||
GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")
|
||||
|
||||
-- | Run a 'GhcMonad' action to compile an expression for internal usage.
|
||||
runInternal :: GhcMonad m => m a -> m a
|
||||
runInternal =
|
||||
withTempSession mkTempSession
|
||||
where
|
||||
mkTempSession hsc_env = hsc_env
|
||||
{ hsc_dflags = (hsc_dflags hsc_env)
|
||||
-- RebindableSyntax can wreak havoc with GHCi in several ways
|
||||
-- (see #13385 and #14342 for examples), so we take care to disable it
|
||||
-- for the duration of running expressions that are internal to GHCi.
|
||||
`xopt_unset` LangExt.RebindableSyntax
|
||||
-- We heavily depend on -fimplicit-import-qualified to compile expr
|
||||
-- with fully qualified names without imports.
|
||||
`gopt_set` Opt_ImplicitImportQualified
|
||||
}
|
||||
|
||||
compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
|
||||
compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
|
@ -1,216 +0,0 @@
|
||||
-----------------------------------------------------------------------------
|
||||
--
|
||||
-- GHCi's :ctags and :etags commands
|
||||
--
|
||||
-- (c) The GHC Team 2005-2007
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
module GHCi.UI.Tags (
|
||||
createCTagsWithLineNumbersCmd,
|
||||
createCTagsWithRegExesCmd,
|
||||
createETagsFileCmd
|
||||
) where
|
||||
|
||||
import Exception
|
||||
import GHC
|
||||
import GHCi.UI.Monad
|
||||
import Outputable
|
||||
|
||||
-- ToDo: figure out whether we need these, and put something appropriate
|
||||
-- into the GHC API instead
|
||||
import Name (nameOccName)
|
||||
import OccName (pprOccName)
|
||||
import ConLike
|
||||
import MonadUtils
|
||||
|
||||
import Control.Monad
|
||||
import Data.Function
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Ord
|
||||
import DriverPhases
|
||||
import Panic
|
||||
import Prelude
|
||||
import System.Directory
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- create tags file for currently loaded modules.
|
||||
|
||||
createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
|
||||
createETagsFileCmd :: String -> GHCi ()
|
||||
|
||||
createCTagsWithLineNumbersCmd "" =
|
||||
ghciCreateTagsFile CTagsWithLineNumbers "tags"
|
||||
createCTagsWithLineNumbersCmd file =
|
||||
ghciCreateTagsFile CTagsWithLineNumbers file
|
||||
|
||||
createCTagsWithRegExesCmd "" =
|
||||
ghciCreateTagsFile CTagsWithRegExes "tags"
|
||||
createCTagsWithRegExesCmd file =
|
||||
ghciCreateTagsFile CTagsWithRegExes file
|
||||
|
||||
createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
|
||||
createETagsFileCmd file = ghciCreateTagsFile ETags file
|
||||
|
||||
data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
|
||||
|
||||
ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
|
||||
ghciCreateTagsFile kind file = do
|
||||
createTagsFile kind file
|
||||
|
||||
-- ToDo:
|
||||
-- - remove restriction that all modules must be interpreted
|
||||
-- (problem: we don't know source locations for entities unless
|
||||
-- we compiled the module.
|
||||
--
|
||||
-- - extract createTagsFile so it can be used from the command-line
|
||||
-- (probably need to fix first problem before this is useful).
|
||||
--
|
||||
createTagsFile :: TagsKind -> FilePath -> GHCi ()
|
||||
createTagsFile tagskind tagsFile = do
|
||||
graph <- GHC.getModuleGraph
|
||||
mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)
|
||||
either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
|
||||
case either_res of
|
||||
Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
|
||||
Right _ -> return ()
|
||||
|
||||
|
||||
listModuleTags :: GHC.Module -> GHCi [TagInfo]
|
||||
listModuleTags m = do
|
||||
is_interpreted <- GHC.moduleIsInterpreted m
|
||||
-- should we just skip these?
|
||||
when (not is_interpreted) $
|
||||
let mName = GHC.moduleNameString (GHC.moduleName m) in
|
||||
throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
|
||||
mbModInfo <- GHC.getModuleInfo m
|
||||
case mbModInfo of
|
||||
Nothing -> return []
|
||||
Just mInfo -> do
|
||||
dflags <- getDynFlags
|
||||
mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
|
||||
let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
|
||||
let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
|
||||
let localNames = filter ((m==) . nameModule) names
|
||||
mbTyThings <- mapM GHC.lookupName localNames
|
||||
return $! [ tagInfo dflags unqual exported kind name realLoc
|
||||
| tyThing <- catMaybes mbTyThings
|
||||
, let name = getName tyThing
|
||||
, let exported = GHC.modInfoIsExportedName mInfo name
|
||||
, let kind = tyThing2TagKind tyThing
|
||||
, let loc = srcSpanStart (nameSrcSpan name)
|
||||
, RealSrcLoc realLoc <- [loc]
|
||||
]
|
||||
|
||||
where
|
||||
tyThing2TagKind (AnId _) = 'v'
|
||||
tyThing2TagKind (AConLike RealDataCon{}) = 'd'
|
||||
tyThing2TagKind (AConLike PatSynCon{}) = 'p'
|
||||
tyThing2TagKind (ATyCon _) = 't'
|
||||
tyThing2TagKind (ACoAxiom _) = 'x'
|
||||
|
||||
|
||||
data TagInfo = TagInfo
|
||||
{ tagExported :: Bool -- is tag exported
|
||||
, tagKind :: Char -- tag kind
|
||||
, tagName :: String -- tag name
|
||||
, tagFile :: String -- file name
|
||||
, tagLine :: Int -- line number
|
||||
, tagCol :: Int -- column number
|
||||
, tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset
|
||||
}
|
||||
|
||||
|
||||
-- get tag info, for later translation into Vim or Emacs style
|
||||
tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
|
||||
-> TagInfo
|
||||
tagInfo dflags unqual exported kind name loc
|
||||
= TagInfo exported kind
|
||||
(showSDocForUser dflags unqual $ pprOccName (nameOccName name))
|
||||
(showSDocForUser dflags unqual $ ftext (srcLocFile loc))
|
||||
(srcLocLine loc) (srcLocCol loc) Nothing
|
||||
|
||||
-- throw an exception when someone tries to overwrite existing source file (fix for #10989)
|
||||
writeTagsSafely :: FilePath -> String -> IO ()
|
||||
writeTagsSafely file str = do
|
||||
dfe <- doesFileExist file
|
||||
if dfe && isSourceFilename file
|
||||
then throwGhcException (CmdLineError (file ++ " is existing source file. " ++
|
||||
"Please specify another file name to store tags data"))
|
||||
else writeFile file str
|
||||
|
||||
collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
|
||||
-- ctags style with the Ex expression being just the line number, Vim et al
|
||||
collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
|
||||
let tags = unlines $ sort $ map showCTag tagInfos
|
||||
tryIO (writeTagsSafely file tags)
|
||||
|
||||
-- ctags style with the Ex expression being a regex searching the line, Vim et al
|
||||
collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
|
||||
tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
|
||||
let tags = unlines $ sort $ map showCTag $concat tagInfoGroups
|
||||
tryIO (writeTagsSafely file tags)
|
||||
|
||||
collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
|
||||
tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
|
||||
let tagGroups = map processGroup tagInfoGroups
|
||||
tryIO (writeTagsSafely file $ concat tagGroups)
|
||||
|
||||
where
|
||||
processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
|
||||
processGroup group@(tagInfo:_) =
|
||||
let tags = unlines $ map showETag group in
|
||||
"\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
|
||||
|
||||
|
||||
makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
|
||||
makeTagGroupsWithSrcInfo tagInfos = do
|
||||
let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
|
||||
mapM addTagSrcInfo groups
|
||||
|
||||
where
|
||||
addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
|
||||
addTagSrcInfo group@(tagInfo:_) = do
|
||||
file <- readFile $tagFile tagInfo
|
||||
let sortedGroup = sortBy (comparing tagLine) group
|
||||
return $ perFile sortedGroup 1 0 $ lines file
|
||||
|
||||
perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
|
||||
| tagLine tag > cnt =
|
||||
perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
|
||||
| tagLine tag == cnt =
|
||||
tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
|
||||
perFile _ _ _ _ = []
|
||||
|
||||
|
||||
-- ctags format, for Vim et al
|
||||
showCTag :: TagInfo -> String
|
||||
showCTag ti =
|
||||
tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
|
||||
tagKind ti : ( if tagExported ti then "" else "\tfile:" )
|
||||
|
||||
where
|
||||
tagCmd =
|
||||
case tagSrcInfo ti of
|
||||
Nothing -> show $tagLine ti
|
||||
Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
|
||||
|
||||
where
|
||||
escapeSlashes '/' r = '\\' : '/' : r
|
||||
escapeSlashes '\\' r = '\\' : '\\' : r
|
||||
escapeSlashes c r = c : r
|
||||
|
||||
|
||||
-- etags format, for Emacs/XEmacs
|
||||
showETag :: TagInfo -> String
|
||||
showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
|
||||
tagSrcInfo = Just (srcLine,charPos) }
|
||||
= take (colNo - 1) srcLine ++ tag
|
||||
++ "\x7f" ++ tag
|
||||
++ "\x01" ++ show lineNo
|
||||
++ "," ++ show charPos
|
||||
showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
|
@ -1,16 +0,0 @@
|
||||
{-# LANGUAGE MagicHash, UnboxedTuples #-}
|
||||
|
||||
-- | Utilities for GHCi.
|
||||
module GHCi.Util where
|
||||
|
||||
-- NOTE: Avoid importing GHC modules here, because the primary purpose
|
||||
-- of this module is to not use UnboxedTuples in a module that imports
|
||||
-- lots of other modules. See issue#13101 for more info.
|
||||
|
||||
import GHC.Exts
|
||||
import GHC.Types
|
||||
|
||||
anyToPtr :: a -> IO (Ptr ())
|
||||
anyToPtr x =
|
||||
IO (\s -> case anyToAddr# x s of
|
||||
(# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
|
@ -1,984 +1,5 @@
|
||||
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
--
|
||||
-- GHC Driver program
|
||||
--
|
||||
-- (c) The University of Glasgow 2005
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Main (main) where
|
||||
|
||||
-- The official GHC API
|
||||
import qualified GHC
|
||||
import GHC ( -- DynFlags(..), HscTarget(..),
|
||||
-- GhcMode(..), GhcLink(..),
|
||||
Ghc, GhcMonad(..),
|
||||
LoadHowMuch(..) )
|
||||
import CmdLineParser
|
||||
|
||||
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
|
||||
import LoadIface ( showIface )
|
||||
import HscMain ( newHscEnv )
|
||||
import DriverPipeline ( oneShot, compileFile )
|
||||
import DriverMkDepend ( doMkDependHS )
|
||||
import DriverBkp ( doBackpack )
|
||||
#if defined(GHCI)
|
||||
import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
|
||||
#endif
|
||||
|
||||
-- Frontend plugins
|
||||
#if defined(GHCI)
|
||||
import DynamicLoading ( loadFrontendPlugin )
|
||||
import Plugins
|
||||
#else
|
||||
import DynamicLoading ( pluginError )
|
||||
#endif
|
||||
import Module ( ModuleName )
|
||||
|
||||
|
||||
-- Various other random stuff that we need
|
||||
import GHC.HandleEncoding
|
||||
import Config
|
||||
import Constants
|
||||
import HscTypes
|
||||
import Packages ( pprPackages, pprPackagesSimple )
|
||||
import DriverPhases
|
||||
import BasicTypes ( failed )
|
||||
import DynFlags hiding (WarnReason(..))
|
||||
import ErrUtils
|
||||
import FastString
|
||||
import Outputable
|
||||
import SrcLoc
|
||||
import Util
|
||||
import Panic
|
||||
import UniqSupply
|
||||
import MonadUtils ( liftIO )
|
||||
import DynamicLoading ( initializePlugins )
|
||||
|
||||
-- Imports for --abi-hash
|
||||
import LoadIface ( loadUserInterface )
|
||||
import Module ( mkModuleName )
|
||||
import Finder ( findImportedModule, cannotFindModule )
|
||||
import TcRnMonad ( initIfaceCheck )
|
||||
import Binary ( openBinMem, put_ )
|
||||
import BinFingerprint ( fingerprintBinMem )
|
||||
|
||||
-- Standard Haskell libraries
|
||||
import System.IO
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import Control.Monad
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Prelude
|
||||
|
||||
import qualified Asterius.BuildInfo as A
|
||||
import qualified Asterius.FrontendPlugin as A
|
||||
import Control.Exception
|
||||
import System.Process
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- ToDo:
|
||||
|
||||
-- time commands when run with -v
|
||||
-- user ways
|
||||
-- Win32 support: proper signal handling
|
||||
-- reading the package configuration file is too slow
|
||||
-- -K<size>
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- GHC's command-line interface
|
||||
import qualified GHC.Frontend.Ghc as GHC
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
initGCStatistics -- See Note [-Bsymbolic and hooks]
|
||||
hSetBuffering stdout LineBuffering
|
||||
hSetBuffering stderr LineBuffering
|
||||
|
||||
configureHandleEncoding
|
||||
GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
|
||||
-- 1. extract the -B flag from the args
|
||||
argv0 <- getArgs
|
||||
|
||||
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
|
||||
mbMinusB | null minusB_args = Just A.ahcLibDir
|
||||
| otherwise = Just (drop 2 (last minusB_args))
|
||||
|
||||
let argv2 = map (mkGeneralLocated "on the commandline") argv1
|
||||
|
||||
-- 2. Parse the "mode" flags (--make, --interactive etc.)
|
||||
(mode, argv3, flagWarnings) <- parseModeFlags argv2
|
||||
|
||||
-- If all we want to do is something like showing the version number
|
||||
-- then do it now, before we start a GHC session etc. This makes
|
||||
-- getting basic information much more resilient.
|
||||
|
||||
-- In particular, if we wait until later before giving the version
|
||||
-- number then bootstrapping gets confused, as it tries to find out
|
||||
-- what version of GHC it's using before package.conf exists, so
|
||||
-- starting the session fails.
|
||||
case mode of
|
||||
Left preStartupMode ->
|
||||
do case preStartupMode of
|
||||
ShowSupportedExtensions -> showSupportedExtensions
|
||||
ShowVersion -> showVersion
|
||||
ShowNumVersion -> putStrLn cProjectVersion
|
||||
ShowOptions isInteractive -> showOptions isInteractive
|
||||
Right postStartupMode ->
|
||||
-- start our GHC session
|
||||
GHC.runGhc mbMinusB $ do
|
||||
|
||||
dflags <- GHC.getSessionDynFlags
|
||||
|
||||
case postStartupMode of
|
||||
Left preLoadMode ->
|
||||
liftIO $ do
|
||||
case preLoadMode of
|
||||
ShowInfo -> showInfo dflags
|
||||
ShowGhcUsage -> showGhcUsage dflags
|
||||
ShowGhciUsage -> showGhciUsage dflags
|
||||
PrintWithDynFlags f -> putStrLn (f dflags)
|
||||
Right postLoadMode ->
|
||||
main' postLoadMode dflags argv3 flagWarnings
|
||||
|
||||
main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
|
||||
-> Ghc ()
|
||||
main' postLoadMode dflags0 args flagWarnings = do
|
||||
-- set the default GhcMode, HscTarget and GhcLink. The HscTarget
|
||||
-- can be further adjusted on a module by module basis, using only
|
||||
-- the -fvia-C and -fasm flags. If the default HscTarget is not
|
||||
-- HscC or HscAsm, -fvia-C and -fasm have no effect.
|
||||
let dflt_target = hscTarget dflags0
|
||||
(mode, lang, link)
|
||||
= case postLoadMode of
|
||||
DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)
|
||||
DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)
|
||||
DoMake -> (CompManager, dflt_target, LinkBinary)
|
||||
DoBackpack -> (CompManager, dflt_target, LinkBinary)
|
||||
DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)
|
||||
DoAbiHash -> (OneShot, dflt_target, LinkBinary)
|
||||
_ -> (OneShot, dflt_target, LinkBinary)
|
||||
|
||||
let dflags1 = dflags0{ ghcMode = mode,
|
||||
hscTarget = lang,
|
||||
ghcLink = link,
|
||||
verbosity = case postLoadMode of
|
||||
DoEval _ -> 0
|
||||
_other -> 1
|
||||
}
|
||||
|
||||
-- turn on -fimplicit-import-qualified for GHCi now, so that it
|
||||
-- can be overriden from the command-line
|
||||
-- XXX: this should really be in the interactive DynFlags, but
|
||||
-- we don't set that until later in interactiveUI
|
||||
-- We also set -fignore-optim-changes and -fignore-hpc-changes,
|
||||
-- which are program-level options. Again, this doesn't really
|
||||
-- feel like the right place to handle this, but we don't have
|
||||
-- a great story for the moment.
|
||||
dflags2 | DoInteractive <- postLoadMode = def_ghci_flags
|
||||
| DoEval _ <- postLoadMode = def_ghci_flags
|
||||
| otherwise = dflags1
|
||||
where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified
|
||||
`gopt_set` Opt_IgnoreOptimChanges
|
||||
`gopt_set` Opt_IgnoreHpcChanges
|
||||
|
||||
-- The rest of the arguments are "dynamic"
|
||||
-- Leftover ones are presumably files
|
||||
(dflags3, fileish_args, dynamicFlagWarnings) <-
|
||||
GHC.parseDynamicFlags dflags2 args
|
||||
|
||||
let dflags4 = case lang of
|
||||
HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
|
||||
let platform = targetPlatform dflags3
|
||||
dflags3a = updateWays $ dflags3 { ways = interpWays }
|
||||
dflags3b = foldl gopt_set dflags3a
|
||||
$ concatMap (wayGeneralFlags platform)
|
||||
interpWays
|
||||
dflags3c = foldl gopt_unset dflags3b
|
||||
$ concatMap (wayUnsetGeneralFlags platform)
|
||||
interpWays
|
||||
in dflags3c
|
||||
_ ->
|
||||
dflags3
|
||||
|
||||
GHC.prettyPrintGhcErrors dflags4 $ do
|
||||
|
||||
let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
|
||||
|
||||
handleSourceError (\e -> do
|
||||
GHC.printException e
|
||||
liftIO $ exitWith (ExitFailure 1)) $ do
|
||||
liftIO $ handleFlagWarnings dflags4 flagWarnings'
|
||||
|
||||
liftIO $ showBanner postLoadMode dflags4
|
||||
|
||||
let
|
||||
-- To simplify the handling of filepaths, we normalise all filepaths right
|
||||
-- away. Note the asymmetry of FilePath.normalise:
|
||||
-- Linux: p/q -> p/q; p\q -> p\q
|
||||
-- Windows: p/q -> p\q; p\q -> p\q
|
||||
-- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
|
||||
-- to -foo.hs. We have to re-prepend the current directory.
|
||||
normalise_hyp fp
|
||||
| strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
|
||||
| otherwise = nfp
|
||||
where
|
||||
#if defined(mingw32_HOST_OS)
|
||||
strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
|
||||
#else
|
||||
strt_dot_sl = "./" `isPrefixOf` fp
|
||||
#endif
|
||||
cur_dir = '.' : [pathSeparator]
|
||||
nfp = normalise fp
|
||||
normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
|
||||
(srcs, objs) = partition_args normal_fileish_paths [] []
|
||||
|
||||
dflags5 = dflags4 { ldInputs = map (FileOption "") objs
|
||||
++ ldInputs dflags4 }
|
||||
|
||||
-- we've finished manipulating the DynFlags, update the session
|
||||
_ <- GHC.setSessionDynFlags dflags5
|
||||
|
||||
A.frontendPlugin
|
||||
|
||||
dflags6 <- GHC.getSessionDynFlags
|
||||
hsc_env <- GHC.getSession
|
||||
|
||||
---------------- Display configuration -----------
|
||||
case verbosity dflags6 of
|
||||
v | v == 4 -> liftIO $ dumpPackagesSimple dflags6
|
||||
| v >= 5 -> liftIO $ dumpPackages dflags6
|
||||
| otherwise -> return ()
|
||||
|
||||
liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
|
||||
---------------- Final sanity checking -----------
|
||||
liftIO $ checkOptions postLoadMode dflags6 srcs objs
|
||||
|
||||
liftIO $ case (normal_fileish_paths, outputFile dflags6) of
|
||||
([src], Just p) | (('s' : 'e' : 't' : 'u' : 'p' : _) : "setup" : "dist" : _) <- reverse (splitDirectories p) -> do
|
||||
catch
|
||||
(callProcess "ghc" ["--make", "-threaded", "-rtsopts", "-o", p, src])
|
||||
( \(_ :: IOError) -> do
|
||||
writeFile src "import Distribution.Simple\nmain = defaultMain\n"
|
||||
callProcess "ghc" ["--make", "-threaded", "-rtsopts", "-o", p, src]
|
||||
)
|
||||
exitSuccess
|
||||
_ -> pure ()
|
||||
|
||||
---------------- Do the business -----------
|
||||
handleSourceError (\e -> do
|
||||
GHC.printException e
|
||||
liftIO $ exitWith (ExitFailure 1)) $ do
|
||||
case postLoadMode of
|
||||
ShowInterface f -> liftIO $ doShowIface dflags6 f
|
||||
DoMake -> doMake srcs
|
||||
DoMkDependHS -> doMkDependHS (map fst srcs)
|
||||
StopBefore p -> liftIO (oneShot hsc_env p srcs)
|
||||
DoInteractive -> ghciUI hsc_env dflags6 srcs Nothing
|
||||
DoEval exprs -> ghciUI hsc_env dflags6 srcs $ Just $
|
||||
reverse exprs
|
||||
DoAbiHash -> abiHash (map fst srcs)
|
||||
ShowPackages -> liftIO $ showPackages dflags6
|
||||
DoFrontend f -> doFrontend f srcs
|
||||
DoBackpack -> doBackpack (map fst srcs)
|
||||
|
||||
liftIO $ dumpFinalStats dflags6
|
||||
|
||||
ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
|
||||
-> Ghc ()
|
||||
#if !defined(GHCI)
|
||||
ghciUI _ _ _ _ =
|
||||
throwGhcException (CmdLineError "not built for interactive use")
|
||||
#else
|
||||
ghciUI hsc_env dflags0 srcs maybe_expr = do
|
||||
dflags1 <- liftIO (initializePlugins hsc_env dflags0)
|
||||
_ <- GHC.setSessionDynFlags dflags1
|
||||
interactiveUI defaultGhciSettings srcs maybe_expr
|
||||
#endif
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Splitting arguments into source files and object files. This is where we
|
||||
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
|
||||
-- file indicating the phase specified by the -x option in force, if any.
|
||||
|
||||
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
|
||||
-> ([(String, Maybe Phase)], [String])
|
||||
partition_args [] srcs objs = (reverse srcs, reverse objs)
|
||||
partition_args ("-x":suff:args) srcs objs
|
||||
| "none" <- suff = partition_args args srcs objs
|
||||
| StopLn <- phase = partition_args args srcs (slurp ++ objs)
|
||||
| otherwise = partition_args rest (these_srcs ++ srcs) objs
|
||||
where phase = startPhase suff
|
||||
(slurp,rest) = break (== "-x") args
|
||||
these_srcs = zip slurp (repeat (Just phase))
|
||||
partition_args (arg:args) srcs objs
|
||||
| looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
|
||||
| otherwise = partition_args args srcs (arg:objs)
|
||||
|
||||
{-
|
||||
We split out the object files (.o, .dll) and add them
|
||||
to ldInputs for use by the linker.
|
||||
|
||||
The following things should be considered compilation manager inputs:
|
||||
|
||||
- haskell source files (strings ending in .hs, .lhs or other
|
||||
haskellish extension),
|
||||
|
||||
- module names (not forgetting hierarchical module names),
|
||||
|
||||
- things beginning with '-' are flags that were not recognised by
|
||||
the flag parser, and we want them to generate errors later in
|
||||
checkOptions, so we class them as source files (#5921)
|
||||
|
||||
- and finally we consider everything without an extension to be
|
||||
a comp manager input, as shorthand for a .hs or .lhs filename.
|
||||
|
||||
Everything else is considered to be a linker object, and passed
|
||||
straight through to the linker.
|
||||
-}
|
||||
looks_like_an_input :: String -> Bool
|
||||
looks_like_an_input m = isSourceFilename m
|
||||
|| looksLikeModuleName m
|
||||
|| "-" `isPrefixOf` m
|
||||
|| not (hasExtension m)
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Option sanity checks
|
||||
|
||||
-- | Ensure sanity of options.
|
||||
--
|
||||
-- Throws 'UsageError' or 'CmdLineError' if not.
|
||||
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
|
||||
-- Final sanity checking before kicking off a compilation (pipeline).
|
||||
checkOptions mode dflags srcs objs = do
|
||||
-- Complain about any unknown flags
|
||||
let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
|
||||
when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
|
||||
|
||||
when (notNull (filter wayRTSOnly (ways dflags))
|
||||
&& isInterpretiveMode mode) $
|
||||
hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
|
||||
|
||||
-- -prof and --interactive are not a good combination
|
||||
when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
|
||||
&& isInterpretiveMode mode
|
||||
&& not (gopt Opt_ExternalInterpreter dflags)) $
|
||||
do throwGhcException (UsageError
|
||||
"-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
|
||||
-- -ohi sanity check
|
||||
if (isJust (outputHi dflags) &&
|
||||
(isCompManagerMode mode || srcs `lengthExceeds` 1))
|
||||
then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
|
||||
else do
|
||||
|
||||
-- -o sanity checking
|
||||
if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
|
||||
&& not (isLinkMode mode))
|
||||
then throwGhcException (UsageError "can't apply -o to multiple source files")
|
||||
else do
|
||||
|
||||
let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
|
||||
|
||||
when (not_linking && not (null objs)) $
|
||||
hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
|
||||
|
||||
-- Check that there are some input files
|
||||
-- (except in the interactive case)
|
||||
if null srcs && (null objs || not_linking) && needsInputsMode mode
|
||||
then throwGhcException (UsageError "no input files")
|
||||
else do
|
||||
|
||||
case mode of
|
||||
StopBefore HCc | hscTarget dflags /= HscC
|
||||
-> throwGhcException $ UsageError $
|
||||
"the option -C is only available with an unregisterised GHC"
|
||||
_ -> return ()
|
||||
|
||||
-- Verify that output files point somewhere sensible.
|
||||
verifyOutputFiles dflags
|
||||
|
||||
-- Compiler output options
|
||||
|
||||
-- Called to verify that the output files point somewhere valid.
|
||||
--
|
||||
-- The assumption is that the directory portion of these output
|
||||
-- options will have to exist by the time 'verifyOutputFiles'
|
||||
-- is invoked.
|
||||
--
|
||||
-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
|
||||
-- they don't exist, so don't check for those here (#2278).
|
||||
verifyOutputFiles :: DynFlags -> IO ()
|
||||
verifyOutputFiles dflags = do
|
||||
let ofile = outputFile dflags
|
||||
when (isJust ofile) $ do
|
||||
let fn = fromJust ofile
|
||||
flg <- doesDirNameExist fn
|
||||
when (not flg) (nonExistentDir "-o" fn)
|
||||
let ohi = outputHi dflags
|
||||
when (isJust ohi) $ do
|
||||
let hi = fromJust ohi
|
||||
flg <- doesDirNameExist hi
|
||||
when (not flg) (nonExistentDir "-ohi" hi)
|
||||
where
|
||||
nonExistentDir flg dir =
|
||||
throwGhcException (CmdLineError ("error: directory portion of " ++
|
||||
show dir ++ " does not exist (used with " ++
|
||||
show flg ++ " option.)"))
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- GHC modes of operation
|
||||
|
||||
type Mode = Either PreStartupMode PostStartupMode
|
||||
type PostStartupMode = Either PreLoadMode PostLoadMode
|
||||
|
||||
data PreStartupMode
|
||||
= ShowVersion -- ghc -V/--version
|
||||
| ShowNumVersion -- ghc --numeric-version
|
||||
| ShowSupportedExtensions -- ghc --supported-extensions
|
||||
| ShowOptions Bool {- isInteractive -} -- ghc --show-options
|
||||
|
||||
showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
|
||||
showVersionMode = mkPreStartupMode ShowVersion
|
||||
showNumVersionMode = mkPreStartupMode ShowNumVersion
|
||||
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
|
||||
showOptionsMode = mkPreStartupMode (ShowOptions False)
|
||||
|
||||
mkPreStartupMode :: PreStartupMode -> Mode
|
||||
mkPreStartupMode = Left
|
||||
|
||||
isShowVersionMode :: Mode -> Bool
|
||||
isShowVersionMode (Left ShowVersion) = True
|
||||
isShowVersionMode _ = False
|
||||
|
||||
isShowNumVersionMode :: Mode -> Bool
|
||||
isShowNumVersionMode (Left ShowNumVersion) = True
|
||||
isShowNumVersionMode _ = False
|
||||
|
||||
data PreLoadMode
|
||||
= ShowGhcUsage -- ghc -?
|
||||
| ShowGhciUsage -- ghci -?
|
||||
| ShowInfo -- ghc --info
|
||||
| PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
|
||||
|
||||
showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
|
||||
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
|
||||
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
|
||||
showInfoMode = mkPreLoadMode ShowInfo
|
||||
|
||||
printSetting :: String -> Mode
|
||||
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
|
||||
where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
|
||||
$ lookup k (compilerInfo dflags)
|
||||
|
||||
mkPreLoadMode :: PreLoadMode -> Mode
|
||||
mkPreLoadMode = Right . Left
|
||||
|
||||
isShowGhcUsageMode :: Mode -> Bool
|
||||
isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
|
||||
isShowGhcUsageMode _ = False
|
||||
|
||||
isShowGhciUsageMode :: Mode -> Bool
|
||||
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
|
||||
isShowGhciUsageMode _ = False
|
||||
|
||||
data PostLoadMode
|
||||
= ShowInterface FilePath -- ghc --show-iface
|
||||
| DoMkDependHS -- ghc -M
|
||||
| StopBefore Phase -- ghc -E | -C | -S
|
||||
-- StopBefore StopLn is the default
|
||||
| DoMake -- ghc --make
|
||||
| DoBackpack -- ghc --backpack foo.bkp
|
||||
| DoInteractive -- ghc --interactive
|
||||
| DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
|
||||
| DoAbiHash -- ghc --abi-hash
|
||||
| ShowPackages -- ghc --show-packages
|
||||
| DoFrontend ModuleName -- ghc --frontend Plugin.Module
|
||||
|
||||
doMkDependHSMode, doMakeMode, doInteractiveMode,
|
||||
doAbiHashMode, showPackagesMode :: Mode
|
||||
doMkDependHSMode = mkPostLoadMode DoMkDependHS
|
||||
doMakeMode = mkPostLoadMode DoMake
|
||||
doInteractiveMode = mkPostLoadMode DoInteractive
|
||||
doAbiHashMode = mkPostLoadMode DoAbiHash
|
||||
showPackagesMode = mkPostLoadMode ShowPackages
|
||||
|
||||
showInterfaceMode :: FilePath -> Mode
|
||||
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
|
||||
|
||||
stopBeforeMode :: Phase -> Mode
|
||||
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
|
||||
|
||||
doEvalMode :: String -> Mode
|
||||
doEvalMode str = mkPostLoadMode (DoEval [str])
|
||||
|
||||
doFrontendMode :: String -> Mode
|
||||
doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
|
||||
|
||||
doBackpackMode :: Mode
|
||||
doBackpackMode = mkPostLoadMode DoBackpack
|
||||
|
||||
mkPostLoadMode :: PostLoadMode -> Mode
|
||||
mkPostLoadMode = Right . Right
|
||||
|
||||
isDoInteractiveMode :: Mode -> Bool
|
||||
isDoInteractiveMode (Right (Right DoInteractive)) = True
|
||||
isDoInteractiveMode _ = False
|
||||
|
||||
isStopLnMode :: Mode -> Bool
|
||||
isStopLnMode (Right (Right (StopBefore StopLn))) = True
|
||||
isStopLnMode _ = False
|
||||
|
||||
isDoMakeMode :: Mode -> Bool
|
||||
isDoMakeMode (Right (Right DoMake)) = True
|
||||
isDoMakeMode _ = False
|
||||
|
||||
isDoEvalMode :: Mode -> Bool
|
||||
isDoEvalMode (Right (Right (DoEval _))) = True
|
||||
isDoEvalMode _ = False
|
||||
|
||||
#if defined(GHCI)
|
||||
isInteractiveMode :: PostLoadMode -> Bool
|
||||
isInteractiveMode DoInteractive = True
|
||||
isInteractiveMode _ = False
|
||||
#endif
|
||||
|
||||
-- isInterpretiveMode: byte-code compiler involved
|
||||
isInterpretiveMode :: PostLoadMode -> Bool
|
||||
isInterpretiveMode DoInteractive = True
|
||||
isInterpretiveMode (DoEval _) = True
|
||||
isInterpretiveMode _ = False
|
||||
|
||||
needsInputsMode :: PostLoadMode -> Bool
|
||||
needsInputsMode DoMkDependHS = True
|
||||
needsInputsMode (StopBefore _) = True
|
||||
needsInputsMode DoMake = True
|
||||
needsInputsMode _ = False
|
||||
|
||||
-- True if we are going to attempt to link in this mode.
|
||||
-- (we might not actually link, depending on the GhcLink flag)
|
||||
isLinkMode :: PostLoadMode -> Bool
|
||||
isLinkMode (StopBefore StopLn) = True
|
||||
isLinkMode DoMake = True
|
||||
isLinkMode DoInteractive = True
|
||||
isLinkMode (DoEval _) = True
|
||||
isLinkMode _ = False
|
||||
|
||||
isCompManagerMode :: PostLoadMode -> Bool
|
||||
isCompManagerMode DoMake = True
|
||||
isCompManagerMode DoInteractive = True
|
||||
isCompManagerMode (DoEval _) = True
|
||||
isCompManagerMode _ = False
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Parsing the mode flag
|
||||
|
||||
parseModeFlags :: [Located String]
|
||||
-> IO (Mode,
|
||||
[Located String],
|
||||
[Warn])
|
||||
parseModeFlags args = do
|
||||
let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
|
||||
runCmdLine (processArgs mode_flags args)
|
||||
(Nothing, [], [])
|
||||
mode = case mModeFlag of
|
||||
Nothing -> doMakeMode
|
||||
Just (m, _) -> m
|
||||
|
||||
-- See Note [Handling errors when parsing commandline flags]
|
||||
unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
|
||||
map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
|
||||
|
||||
return (mode, flags' ++ leftover, warns)
|
||||
|
||||
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
|
||||
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
|
||||
-- so we collect the new ones and return them.
|
||||
|
||||
mode_flags :: [Flag ModeM]
|
||||
mode_flags =
|
||||
[ ------- help / version ----------------------------------------------
|
||||
defFlag "?" (PassFlag (setMode showGhcUsageMode))
|
||||
, defFlag "-help" (PassFlag (setMode showGhcUsageMode))
|
||||
, defFlag "V" (PassFlag (setMode showVersionMode))
|
||||
, defFlag "-version" (PassFlag (setMode showVersionMode))
|
||||
, defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
|
||||
, defFlag "-info" (PassFlag (setMode showInfoMode))
|
||||
, defFlag "-show-options" (PassFlag (setMode showOptionsMode))
|
||||
, defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
, defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
, defFlag "-show-packages" (PassFlag (setMode showPackagesMode))
|
||||
] ++
|
||||
[ defFlag k' (PassFlag (setMode (printSetting k)))
|
||||
| k <- ["Project version",
|
||||
"Project Git commit id",
|
||||
"Booter version",
|
||||
"Stage",
|
||||
"Build platform",
|
||||
"Host platform",
|
||||
"Target platform",
|
||||
"Have interpreter",
|
||||
"Object splitting supported",
|
||||
"Have native code generator",
|
||||
"Support SMP",
|
||||
"Unregisterised",
|
||||
"Tables next to code",
|
||||
"RTS ways",
|
||||
"Leading underscore",
|
||||
"Debug on",
|
||||
"LibDir",
|
||||
"Global Package DB",
|
||||
"C compiler flags",
|
||||
"C compiler link flags",
|
||||
"ld flags"],
|
||||
let k' = "-print-" ++ map (replaceSpace . toLower) k
|
||||
replaceSpace ' ' = '-'
|
||||
replaceSpace c = c
|
||||
] ++
|
||||
------- interfaces ----------------------------------------------------
|
||||
[ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
|
||||
"--show-iface"))
|
||||
|
||||
------- primary modes ------------------------------------------------
|
||||
, defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
|
||||
addFlag "-no-link" f))
|
||||
, defFlag "M" (PassFlag (setMode doMkDependHSMode))
|
||||
, defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
|
||||
, defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))
|
||||
, defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))
|
||||
, defFlag "-make" (PassFlag (setMode doMakeMode))
|
||||
, defFlag "-backpack" (PassFlag (setMode doBackpackMode))
|
||||
, defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
|
||||
, defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
|
||||
, defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
|
||||
, defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))
|
||||
]
|
||||
|
||||
setMode :: Mode -> String -> EwM ModeM ()
|
||||
setMode newMode newFlag = liftEwM $ do
|
||||
(mModeFlag, errs, flags') <- getCmdLineState
|
||||
let (modeFlag', errs') =
|
||||
case mModeFlag of
|
||||
Nothing -> ((newMode, newFlag), errs)
|
||||
Just (oldMode, oldFlag) ->
|
||||
case (oldMode, newMode) of
|
||||
-- -c/--make are allowed together, and mean --make -no-link
|
||||
_ | isStopLnMode oldMode && isDoMakeMode newMode
|
||||
|| isStopLnMode newMode && isDoMakeMode oldMode ->
|
||||
((doMakeMode, "--make"), [])
|
||||
|
||||
-- If we have both --help and --interactive then we
|
||||
-- want showGhciUsage
|
||||
_ | isShowGhcUsageMode oldMode &&
|
||||
isDoInteractiveMode newMode ->
|
||||
((showGhciUsageMode, oldFlag), [])
|
||||
| isShowGhcUsageMode newMode &&
|
||||
isDoInteractiveMode oldMode ->
|
||||
((showGhciUsageMode, newFlag), [])
|
||||
|
||||
-- If we have both -e and --interactive then -e always wins
|
||||
_ | isDoEvalMode oldMode &&
|
||||
isDoInteractiveMode newMode ->
|
||||
((oldMode, oldFlag), [])
|
||||
| isDoEvalMode newMode &&
|
||||
isDoInteractiveMode oldMode ->
|
||||
((newMode, newFlag), [])
|
||||
|
||||
-- Otherwise, --help/--version/--numeric-version always win
|
||||
| isDominantFlag oldMode -> ((oldMode, oldFlag), [])
|
||||
| isDominantFlag newMode -> ((newMode, newFlag), [])
|
||||
-- We need to accumulate eval flags like "-e foo -e bar"
|
||||
(Right (Right (DoEval esOld)),
|
||||
Right (Right (DoEval [eNew]))) ->
|
||||
((Right (Right (DoEval (eNew : esOld))), oldFlag),
|
||||
errs)
|
||||
-- Saying e.g. --interactive --interactive is OK
|
||||
_ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
|
||||
|
||||
-- --interactive and --show-options are used together
|
||||
(Right (Right DoInteractive), Left (ShowOptions _)) ->
|
||||
((Left (ShowOptions True),
|
||||
"--interactive --show-options"), errs)
|
||||
(Left (ShowOptions _), (Right (Right DoInteractive))) ->
|
||||
((Left (ShowOptions True),
|
||||
"--show-options --interactive"), errs)
|
||||
-- Otherwise, complain
|
||||
_ -> let err = flagMismatchErr oldFlag newFlag
|
||||
in ((oldMode, oldFlag), err : errs)
|
||||
putCmdLineState (Just modeFlag', errs', flags')
|
||||
where isDominantFlag f = isShowGhcUsageMode f ||
|
||||
isShowGhciUsageMode f ||
|
||||
isShowVersionMode f ||
|
||||
isShowNumVersionMode f
|
||||
|
||||
flagMismatchErr :: String -> String -> String
|
||||
flagMismatchErr oldFlag newFlag
|
||||
= "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
|
||||
|
||||
addFlag :: String -> String -> EwM ModeM ()
|
||||
addFlag s flag = liftEwM $ do
|
||||
(m, e, flags') <- getCmdLineState
|
||||
putCmdLineState (m, e, mkGeneralLocated loc s : flags')
|
||||
where loc = "addFlag by " ++ flag ++ " on the commandline"
|
||||
|
||||
-- ----------------------------------------------------------------------------
|
||||
-- Run --make mode
|
||||
|
||||
doMake :: [(String,Maybe Phase)] -> Ghc ()
|
||||
doMake srcs = do
|
||||
let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
|
||||
|
||||
hsc_env <- GHC.getSession
|
||||
|
||||
-- if we have no haskell sources from which to do a dependency
|
||||
-- analysis, then just do one-shot compilation and/or linking.
|
||||
-- This means that "ghc Foo.o Bar.o -o baz" links the program as
|
||||
-- we expect.
|
||||
if (null hs_srcs)
|
||||
then liftIO (oneShot hsc_env StopLn srcs)
|
||||
else do
|
||||
|
||||
o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
|
||||
non_hs_srcs
|
||||
dflags <- GHC.getSessionDynFlags
|
||||
let dflags' = dflags { ldInputs = map (FileOption "") o_files
|
||||
++ ldInputs dflags }
|
||||
_ <- GHC.setSessionDynFlags dflags'
|
||||
|
||||
targets <- mapM (uncurry GHC.guessTarget) hs_srcs
|
||||
GHC.setTargets targets
|
||||
ok_flag <- GHC.load LoadAllTargets
|
||||
|
||||
when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
|
||||
return ()
|
||||
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- --show-iface mode
|
||||
|
||||
doShowIface :: DynFlags -> FilePath -> IO ()
|
||||
doShowIface dflags file = do
|
||||
hsc_env <- newHscEnv dflags
|
||||
showIface hsc_env file
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Various banners and verbosity output.
|
||||
|
||||
showBanner :: PostLoadMode -> DynFlags -> IO ()
|
||||
showBanner _postLoadMode dflags = do
|
||||
let verb = verbosity dflags
|
||||
|
||||
#if defined(GHCI)
|
||||
-- Show the GHCi banner
|
||||
when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
|
||||
#endif
|
||||
|
||||
-- Display details of the configuration in verbose mode
|
||||
when (verb >= 2) $
|
||||
do hPutStr stderr "Glasgow Haskell Compiler, Version "
|
||||
hPutStr stderr cProjectVersion
|
||||
hPutStr stderr ", stage "
|
||||
hPutStr stderr cStage
|
||||
hPutStr stderr " booted by GHC version "
|
||||
hPutStrLn stderr cBooterVersion
|
||||
|
||||
-- We print out a Read-friendly string, but a prettier one than the
|
||||
-- Show instance gives us
|
||||
showInfo :: DynFlags -> IO ()
|
||||
showInfo dflags = do
|
||||
let sq x = " [" ++ x ++ "\n ]"
|
||||
putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
|
||||
|
||||
showSupportedExtensions :: IO ()
|
||||
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
|
||||
|
||||
showVersion :: IO ()
|
||||
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
|
||||
|
||||
showOptions :: Bool -> IO ()
|
||||
showOptions isInteractive = putStr (unlines availableOptions)
|
||||
where
|
||||
availableOptions = concat [
|
||||
flagsForCompletion isInteractive,
|
||||
map ('-':) (getFlagNames mode_flags)
|
||||
]
|
||||
getFlagNames opts = map flagName opts
|
||||
|
||||
showGhcUsage :: DynFlags -> IO ()
|
||||
showGhcUsage = showUsage False
|
||||
|
||||
showGhciUsage :: DynFlags -> IO ()
|
||||
showGhciUsage = showUsage True
|
||||
|
||||
showUsage :: Bool -> DynFlags -> IO ()
|
||||
showUsage ghci dflags = do
|
||||
let usage_path = if ghci then ghciUsagePath dflags
|
||||
else ghcUsagePath dflags
|
||||
usage <- readFile usage_path
|
||||
dump usage
|
||||
where
|
||||
dump "" = return ()
|
||||
dump ('$':'$':s) = putStr progName >> dump s
|
||||
dump (c:s) = putChar c >> dump s
|
||||
|
||||
dumpFinalStats :: DynFlags -> IO ()
|
||||
dumpFinalStats dflags =
|
||||
when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
|
||||
|
||||
dumpFastStringStats :: DynFlags -> IO ()
|
||||
dumpFastStringStats dflags = do
|
||||
segments <- getFastStringTable
|
||||
let buckets = concat segments
|
||||
bucketsPerSegment = map length segments
|
||||
entriesPerBucket = map length buckets
|
||||
entries = sum entriesPerBucket
|
||||
hasZ = sum $ map (length . filter hasZEncoding) buckets
|
||||
msg = text "FastString stats:" $$ nest 4 (vcat
|
||||
[ text "segments: " <+> int (length segments)
|
||||
, text "buckets: " <+> int (sum bucketsPerSegment)
|
||||
, text "entries: " <+> int entries
|
||||
, text "largest segment: " <+> int (maximum bucketsPerSegment)
|
||||
, text "smallest segment: " <+> int (minimum bucketsPerSegment)
|
||||
, text "longest bucket: " <+> int (maximum entriesPerBucket)
|
||||
, text "has z-encoding: " <+> (hasZ `pcntOf` entries)
|
||||
])
|
||||
-- we usually get more "has z-encoding" than "z-encoded", because
|
||||
-- when we z-encode a string it might hash to the exact same string,
|
||||
-- which is not counted as "z-encoded". Only strings whose
|
||||
-- Z-encoding is different from the original string are counted in
|
||||
-- the "z-encoded" total.
|
||||
putMsg dflags msg
|
||||
where
|
||||
x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
|
||||
|
||||
showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
|
||||
showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))
|
||||
dumpPackages dflags = putMsg dflags (pprPackages dflags)
|
||||
dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Frontend plugin support
|
||||
|
||||
doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
|
||||
#if !defined(GHCI)
|
||||
doFrontend modname _ = pluginError [modname]
|
||||
#else
|
||||
doFrontend modname srcs = do
|
||||
hsc_env <- getSession
|
||||
frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
|
||||
frontend frontend_plugin
|
||||
(reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
|
||||
#endif
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- ABI hash support
|
||||
|
||||
{-
|
||||
ghc --abi-hash Data.Foo System.Bar
|
||||
|
||||
Generates a combined hash of the ABI for modules Data.Foo and
|
||||
System.Bar. The modules must already be compiled, and appropriate -i
|
||||
options may be necessary in order to find the .hi files.
|
||||
|
||||
This is used by Cabal for generating the ComponentId for a
|
||||
package. The ComponentId must change when the visible ABI of
|
||||
the package chagnes, so during registration Cabal calls ghc --abi-hash
|
||||
to get a hash of the package's ABI.
|
||||
-}
|
||||
|
||||
-- | Print ABI hash of input modules.
|
||||
--
|
||||
-- The resulting hash is the MD5 of the GHC version used (Trac #5328,
|
||||
-- see 'hiVersion') and of the existing ABI hash from each module (see
|
||||
-- 'mi_mod_hash').
|
||||
abiHash :: [String] -- ^ List of module names
|
||||
-> Ghc ()
|
||||
abiHash strs = do
|
||||
hsc_env <- getSession
|
||||
let dflags = hsc_dflags hsc_env
|
||||
|
||||
liftIO $ do
|
||||
|
||||
let find_it str = do
|
||||
let modname = mkModuleName str
|
||||
r <- findImportedModule hsc_env modname Nothing
|
||||
case r of
|
||||
Found _ m -> return m
|
||||
_error -> throwGhcException $ CmdLineError $ showSDoc dflags $
|
||||
cannotFindModule dflags modname r
|
||||
|
||||
mods <- mapM find_it strs
|
||||
|
||||
let get_iface modl = loadUserInterface False (text "abiHash") modl
|
||||
ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods
|
||||
|
||||
bh <- openBinMem (3*1024) -- just less than a block
|
||||
put_ bh hiVersion
|
||||
-- package hashes change when the compiler version changes (for now)
|
||||
-- see #5328
|
||||
mapM_ (put_ bh . mi_mod_hash) ifaces
|
||||
f <- fingerprintBinMem bh
|
||||
|
||||
putStrLn (showPpr dflags f)
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Util
|
||||
|
||||
unknownFlagsErr :: [String] -> a
|
||||
unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
|
||||
where
|
||||
oneError f =
|
||||
"unrecognised flag: " ++ f ++ "\n" ++
|
||||
(case match f (nubSort allNonDeprecatedFlags) of
|
||||
[] -> ""
|
||||
suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
|
||||
-- fixes #11789
|
||||
-- If the flag contains '=',
|
||||
-- this uses both the whole and the left side of '=' for comparing.
|
||||
match f allFlags
|
||||
| elem '=' f =
|
||||
let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags
|
||||
fName = takeWhile (/= '=') f
|
||||
in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)
|
||||
| otherwise = fuzzyMatch f allFlags
|
||||
|
||||
{- Note [-Bsymbolic and hooks]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
-Bsymbolic is a flag that prevents the binding of references to global
|
||||
symbols to symbols outside the shared library being compiled (see `man
|
||||
ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
|
||||
package: that is because we want hooks to be overridden by the user,
|
||||
we don't want to constrain them to the RTS package.
|
||||
|
||||
Unfortunately this seems to have broken somehow on OS X: as a result,
|
||||
defaultHooks (in hschooks.c) is not called, which does not initialize
|
||||
the GC stats. As a result, this breaks things like `:set +s` in GHCi
|
||||
(#8754). As a hacky workaround, we instead call 'defaultHooks'
|
||||
directly to initalize the flags in the RTS.
|
||||
|
||||
A byproduct of this, I believe, is that hooks are likely broken on OS
|
||||
X when dynamically linking. But this probably doesn't affect most
|
||||
people since we're linking GHC dynamically, but most things themselves
|
||||
link statically.
|
||||
-}
|
||||
|
||||
-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then
|
||||
-- running it causes an error like this:
|
||||
--
|
||||
-- Loading temp shared object failed:
|
||||
-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics
|
||||
--
|
||||
-- Skipping the foreign call fixes this problem, and the outer GHCi
|
||||
-- should have already made this call anyway.
|
||||
#if defined(GHC_LOADED_INTO_GHCI)
|
||||
initGCStatistics :: IO ()
|
||||
initGCStatistics = return ()
|
||||
#else
|
||||
foreign import ccall safe "initGCStatistics"
|
||||
initGCStatistics :: IO ()
|
||||
#endif
|
||||
main = GHC.main A.frontendPlugin
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -1,5 +0,0 @@
|
||||
module Version where
|
||||
version, targetOS, targetARCH :: String
|
||||
version = "8.8.4"
|
||||
targetOS = "linux"
|
||||
targetARCH = "x86_64"
|
@ -1,54 +0,0 @@
|
||||
/*
|
||||
Copyright Johan Tibell 2011
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Johan Tibell nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
*/
|
||||
|
||||
/* FNV-1 hash
|
||||
*
|
||||
* The FNV-1 hash description: http://isthe.com/chongo/tech/comp/fnv/
|
||||
* The FNV-1 hash is public domain: http://isthe.com/chongo/tech/comp/fnv/#public_domain
|
||||
*/
|
||||
long hashable_fnv_hash(const unsigned char* str, long len, long salt) {
|
||||
|
||||
unsigned long hash = salt;
|
||||
while (len--) {
|
||||
hash = (hash * 16777619) ^ *str++;
|
||||
}
|
||||
|
||||
return hash;
|
||||
}
|
||||
|
||||
/* Used for ByteArray#s. We can't treat them like pointers in
|
||||
native Haskell, but we can in unsafe FFI calls.
|
||||
*/
|
||||
long hashable_fnv_hash_offset(const unsigned char* str, long offset, long len, long salt) {
|
||||
return hashable_fnv_hash(str + offset, len, salt);
|
||||
}
|
@ -1,90 +0,0 @@
|
||||
/*
|
||||
* Copyright (c) 2003 David Roundy
|
||||
* Copyright (c) 2005-6 Don Stewart
|
||||
*
|
||||
* All rights reserved.
|
||||
*
|
||||
* Redistribution and use in source and binary forms, with or without
|
||||
* modification, are permitted provided that the following conditions
|
||||
* are met:
|
||||
* 1. Redistributions of source code must retain the above copyright
|
||||
* notice, this list of conditions and the following disclaimer.
|
||||
* 2. Redistributions in binary form must reproduce the above copyright
|
||||
* notice, this list of conditions and the following disclaimer in the
|
||||
* documentation and/or other materials provided with the distribution.
|
||||
* 3. Neither the names of the authors or the names of any contributors
|
||||
* may be used to endorse or promote products derived from this software
|
||||
* without specific prior written permission.
|
||||
*
|
||||
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
|
||||
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
|
||||
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
* SUCH DAMAGE.
|
||||
*/
|
||||
|
||||
#include "fpstring.h"
|
||||
|
||||
/* copy a string in reverse */
|
||||
void fps_reverse(unsigned char *q, unsigned char *p, unsigned long n) {
|
||||
p += n-1;
|
||||
while (n-- != 0)
|
||||
*q++ = *p--;
|
||||
}
|
||||
|
||||
/* duplicate a string, interspersing the character through the elements
|
||||
of the duplicated string */
|
||||
void fps_intersperse(unsigned char *q,
|
||||
unsigned char *p,
|
||||
unsigned long n,
|
||||
unsigned char c) {
|
||||
|
||||
while (n > 1) {
|
||||
*q++ = *p++;
|
||||
*q++ = c;
|
||||
n--;
|
||||
}
|
||||
if (n == 1)
|
||||
*q = *p;
|
||||
}
|
||||
|
||||
/* find maximum char in a packed string */
|
||||
unsigned char fps_maximum(unsigned char *p, unsigned long len) {
|
||||
unsigned char *q, c = *p;
|
||||
for (q = p; q < p + len; q++)
|
||||
if (*q > c)
|
||||
c = *q;
|
||||
return c;
|
||||
}
|
||||
|
||||
/* find minimum char in a packed string */
|
||||
unsigned char fps_minimum(unsigned char *p, unsigned long len) {
|
||||
unsigned char *q, c = *p;
|
||||
for (q = p; q < p + len; q++)
|
||||
if (*q < c)
|
||||
c = *q;
|
||||
return c;
|
||||
}
|
||||
|
||||
/* count the number of occurences of a char in a string */
|
||||
unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w) {
|
||||
unsigned long c;
|
||||
for (c = 0; len-- != 0; ++p)
|
||||
if (*p == w)
|
||||
++c;
|
||||
return c;
|
||||
}
|
||||
|
||||
/* This wrapper is here so that we can copy a sub-range of a ByteArray#.
|
||||
We cannot construct a pointer to the interior of an unpinned ByteArray#,
|
||||
except by doing an unsafe ffi call, and adjusting the pointer C-side. */
|
||||
void * fps_memcpy_offsets(void *dst, unsigned long dst_off,
|
||||
const void *src, unsigned long src_off, size_t n) {
|
||||
return memcpy(dst + dst_off, src + src_off, n);
|
||||
}
|
@ -1,9 +0,0 @@
|
||||
|
||||
#include <string.h>
|
||||
|
||||
void fps_reverse(unsigned char *dest, unsigned char *from, unsigned long len);
|
||||
void fps_intersperse(unsigned char *dest, unsigned char *from, unsigned long len, unsigned char c);
|
||||
unsigned char fps_maximum(unsigned char *p, unsigned long len);
|
||||
unsigned char fps_minimum(unsigned char *p, unsigned long len);
|
||||
unsigned long fps_count(unsigned char *p, unsigned long len, unsigned char w);
|
||||
|
@ -1,93 +0,0 @@
|
||||
/*
|
||||
Copyright Bryan O'Sullivan 2012
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Johan Tibell nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
*/
|
||||
|
||||
#include "MachDeps.h"
|
||||
|
||||
int hashable_getRandomBytes(unsigned char *dest, int nbytes);
|
||||
|
||||
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
|
||||
|
||||
#include <windows.h>
|
||||
#include <wincrypt.h>
|
||||
|
||||
int hashable_getRandomBytes(unsigned char *dest, int nbytes)
|
||||
{
|
||||
HCRYPTPROV hCryptProv;
|
||||
int ret;
|
||||
|
||||
if (!CryptAcquireContextA(&hCryptProv, NULL, NULL, PROV_RSA_FULL,
|
||||
CRYPT_VERIFYCONTEXT))
|
||||
return -1;
|
||||
|
||||
ret = CryptGenRandom(hCryptProv, (DWORD) nbytes, (BYTE *) dest) ? nbytes : -1;
|
||||
|
||||
CryptReleaseContext(hCryptProv, 0);
|
||||
|
||||
bail:
|
||||
return ret;
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
#include <fcntl.h>
|
||||
#include <sys/types.h>
|
||||
#include <unistd.h>
|
||||
|
||||
/* Assumptions: /dev/urandom exists and does something sane, and does
|
||||
not block. */
|
||||
|
||||
int hashable_getRandomBytes(unsigned char *dest, int nbytes)
|
||||
{
|
||||
ssize_t off, nread;
|
||||
int fd;
|
||||
|
||||
fd = open("/dev/urandom", O_RDONLY);
|
||||
if (fd == -1)
|
||||
return -1;
|
||||
|
||||
for (off = 0; nbytes > 0; nbytes -= nread) {
|
||||
nread = read(fd, dest + off, nbytes);
|
||||
off += nread;
|
||||
if (nread == -1) {
|
||||
off = -1;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
bail:
|
||||
close(fd);
|
||||
|
||||
return off;
|
||||
}
|
||||
|
||||
#endif
|
@ -1,215 +0,0 @@
|
||||
///////////////////////////////////////////////////////////////
|
||||
// Encoding numbers using ASCII characters //
|
||||
// //
|
||||
// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html //
|
||||
///////////////////////////////////////////////////////////////
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
// Decimal Encoding
|
||||
///////////////////
|
||||
|
||||
static const char* digits = "0123456789abcdef";
|
||||
|
||||
// signed integers
|
||||
char* _hs_bytestring_int_dec (int x, char* buf)
|
||||
{
|
||||
char c, *ptr = buf, *next_free;
|
||||
int x_tmp;
|
||||
|
||||
// we cannot negate directly as 0 - (minBound :: Int) = minBound
|
||||
if (x < 0) {
|
||||
*ptr++ = '-';
|
||||
buf++;
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*ptr++ = digits[x * 10 - x_tmp];
|
||||
if (x == 0)
|
||||
return ptr;
|
||||
else
|
||||
x = -x;
|
||||
}
|
||||
|
||||
// encode positive number as little-endian decimal
|
||||
do {
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*ptr++ = digits[x_tmp - x * 10];
|
||||
} while ( x );
|
||||
|
||||
// reverse written digits
|
||||
next_free = ptr--;
|
||||
while (buf < ptr) {
|
||||
c = *ptr;
|
||||
*ptr-- = *buf;
|
||||
*buf++ = c;
|
||||
}
|
||||
return next_free;
|
||||
}
|
||||
|
||||
// signed long long ints (64 bit integers)
|
||||
char* _hs_bytestring_long_long_int_dec (long long int x, char* buf)
|
||||
{
|
||||
char c, *ptr = buf, *next_free;
|
||||
long long int x_tmp;
|
||||
|
||||
// we cannot negate directly as 0 - (minBound :: Int) = minBound
|
||||
if (x < 0) {
|
||||
*ptr++ = '-';
|
||||
buf++;
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*ptr++ = digits[x * 10 - x_tmp];
|
||||
if (x == 0)
|
||||
return ptr;
|
||||
else
|
||||
x = -x;
|
||||
}
|
||||
|
||||
// encode positive number as little-endian decimal
|
||||
do {
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*ptr++ = digits[x_tmp - x * 10];
|
||||
} while ( x );
|
||||
|
||||
// reverse written digits
|
||||
next_free = ptr--;
|
||||
while (buf < ptr) {
|
||||
c = *ptr;
|
||||
*ptr-- = *buf;
|
||||
*buf++ = c;
|
||||
}
|
||||
return next_free;
|
||||
}
|
||||
|
||||
// unsigned integers
|
||||
char* _hs_bytestring_uint_dec (unsigned int x, char* buf)
|
||||
{
|
||||
char c, *ptr = buf, *next_free;
|
||||
unsigned int x_tmp;
|
||||
|
||||
// encode positive number as little-endian decimal
|
||||
do {
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*ptr++ = digits[x_tmp - x * 10];
|
||||
} while ( x );
|
||||
|
||||
// reverse written digits
|
||||
next_free = ptr--;
|
||||
while (buf < ptr) {
|
||||
c = *ptr;
|
||||
*ptr-- = *buf;
|
||||
*buf++ = c;
|
||||
}
|
||||
return next_free;
|
||||
}
|
||||
|
||||
// unsigned long ints
|
||||
char* _hs_bytestring_long_long_uint_dec (long long unsigned int x, char* buf)
|
||||
{
|
||||
char c, *ptr = buf, *next_free;
|
||||
long long unsigned int x_tmp;
|
||||
|
||||
// encode positive number as little-endian decimal
|
||||
do {
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*ptr++ = digits[x_tmp - x * 10];
|
||||
} while ( x );
|
||||
|
||||
// reverse written digits
|
||||
next_free = ptr--;
|
||||
while (buf < ptr) {
|
||||
c = *ptr;
|
||||
*ptr-- = *buf;
|
||||
*buf++ = c;
|
||||
}
|
||||
return next_free;
|
||||
}
|
||||
|
||||
|
||||
// Padded, decimal, positive integers for the decimal output of bignums
|
||||
///////////////////////////////////////////////////////////////////////
|
||||
|
||||
// Padded (9 digits), decimal, positive int:
|
||||
// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than
|
||||
// 10^9, as "31 * log 2 / log 10 = 9.33"
|
||||
void _hs_bytestring_int_dec_padded9 (int x, char* buf)
|
||||
{
|
||||
const int max_width_int32_dec = 9;
|
||||
char* ptr = buf + max_width_int32_dec;
|
||||
int x_tmp;
|
||||
|
||||
// encode positive number as little-endian decimal
|
||||
do {
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*(--ptr) = digits[x_tmp - x * 10];
|
||||
} while ( x );
|
||||
|
||||
// pad beginning
|
||||
while (buf < ptr) { *(--ptr) = '0'; }
|
||||
}
|
||||
|
||||
// Padded (19 digits), decimal, positive long long int:
|
||||
// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than
|
||||
// 10^18, as "63 * log 2 / log 10 = 18.96"
|
||||
void _hs_bytestring_long_long_int_dec_padded18 (long long int x, char* buf)
|
||||
{
|
||||
const int max_width_int64_dec = 18;
|
||||
char* ptr = buf + max_width_int64_dec;
|
||||
long long int x_tmp;
|
||||
|
||||
// encode positive number as little-endian decimal
|
||||
do {
|
||||
x_tmp = x;
|
||||
x /= 10;
|
||||
*(--ptr) = digits[x_tmp - x * 10];
|
||||
} while ( x );
|
||||
|
||||
// pad beginning
|
||||
while (buf < ptr) { *(--ptr) = '0'; }
|
||||
}
|
||||
|
||||
|
||||
///////////////////////
|
||||
// Hexadecimal encoding
|
||||
///////////////////////
|
||||
|
||||
// unsigned ints (32 bit words)
|
||||
char* _hs_bytestring_uint_hex (unsigned int x, char* buf) {
|
||||
// write hex representation in reverse order
|
||||
char c, *ptr = buf, *next_free;
|
||||
do {
|
||||
*ptr++ = digits[x & 0xf];
|
||||
x >>= 4;
|
||||
} while ( x );
|
||||
// invert written digits
|
||||
next_free = ptr--;
|
||||
while(buf < ptr) {
|
||||
c = *ptr;
|
||||
*ptr-- = *buf;
|
||||
*buf++ = c;
|
||||
}
|
||||
return next_free;
|
||||
};
|
||||
|
||||
// unsigned long ints (64 bit words)
|
||||
char* _hs_bytestring_long_long_uint_hex (long long unsigned int x, char* buf) {
|
||||
// write hex representation in reverse order
|
||||
char c, *ptr = buf, *next_free;
|
||||
do {
|
||||
*ptr++ = digits[x & 0xf];
|
||||
x >>= 4;
|
||||
} while ( x );
|
||||
// invert written digits
|
||||
next_free = ptr--;
|
||||
while(buf < ptr) {
|
||||
c = *ptr;
|
||||
*ptr-- = *buf;
|
||||
*buf++ = c;
|
||||
}
|
||||
return next_free;
|
||||
};
|
@ -1 +0,0 @@
|
||||
int main() { return 0; }
|
@ -1,238 +0,0 @@
|
||||
/*
|
||||
* This code implements the MD5 message-digest algorithm.
|
||||
* The algorithm is due to Ron Rivest. This code was
|
||||
* written by Colin Plumb in 1993, no copyright is claimed.
|
||||
* This code is in the public domain; do with it what you wish.
|
||||
*
|
||||
* Equivalent code is available from RSA Data Security, Inc.
|
||||
* This code has been tested against that, and is equivalent,
|
||||
* except that you don't need to include two pages of legalese
|
||||
* with every copy.
|
||||
*
|
||||
* To compute the message digest of a chunk of bytes, declare an
|
||||
* MD5Context structure, pass it to MD5Init, call MD5Update as
|
||||
* needed on buffers full of bytes, and then call MD5Final, which
|
||||
* will fill a supplied 16-byte array with the digest.
|
||||
*/
|
||||
|
||||
#include "HsFFI.h"
|
||||
#include "md5.h"
|
||||
#include <string.h>
|
||||
|
||||
void __hsbase_MD5Init(struct MD5Context *context);
|
||||
void __hsbase_MD5Update(struct MD5Context *context, byte const *buf, int len);
|
||||
void __hsbase_MD5Final(byte digest[16], struct MD5Context *context);
|
||||
void __hsbase_MD5Transform(word32 buf[4], word32 const in[16]);
|
||||
|
||||
|
||||
/*
|
||||
* Shuffle the bytes into little-endian order within words, as per the
|
||||
* MD5 spec. Note: this code works regardless of the byte order.
|
||||
*/
|
||||
static void
|
||||
byteSwap(word32 *buf, unsigned words)
|
||||
{
|
||||
byte *p = (byte *)buf;
|
||||
|
||||
do {
|
||||
*buf++ = (word32)((unsigned)p[3] << 8 | p[2]) << 16 |
|
||||
((unsigned)p[1] << 8 | p[0]);
|
||||
p += 4;
|
||||
} while (--words);
|
||||
}
|
||||
|
||||
/*
|
||||
* Start MD5 accumulation. Set bit count to 0 and buffer to mysterious
|
||||
* initialization constants.
|
||||
*/
|
||||
void
|
||||
__hsbase_MD5Init(struct MD5Context *ctx)
|
||||
{
|
||||
ctx->buf[0] = 0x67452301;
|
||||
ctx->buf[1] = 0xefcdab89;
|
||||
ctx->buf[2] = 0x98badcfe;
|
||||
ctx->buf[3] = 0x10325476;
|
||||
|
||||
ctx->bytes[0] = 0;
|
||||
ctx->bytes[1] = 0;
|
||||
}
|
||||
|
||||
/*
|
||||
* Update context to reflect the concatenation of another buffer full
|
||||
* of bytes.
|
||||
*/
|
||||
void
|
||||
__hsbase_MD5Update(struct MD5Context *ctx, byte const *buf, int len)
|
||||
{
|
||||
word32 t;
|
||||
|
||||
/* Update byte count */
|
||||
|
||||
t = ctx->bytes[0];
|
||||
if ((ctx->bytes[0] = t + len) < t)
|
||||
ctx->bytes[1]++; /* Carry from low to high */
|
||||
|
||||
t = 64 - (t & 0x3f); /* Space available in ctx->in (at least 1) */
|
||||
if ((unsigned)t > len) {
|
||||
memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, len);
|
||||
return;
|
||||
}
|
||||
/* First chunk is an odd size */
|
||||
memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);
|
||||
byteSwap(ctx->in, 16);
|
||||
__hsbase_MD5Transform(ctx->buf, ctx->in);
|
||||
buf += (unsigned)t;
|
||||
len -= (unsigned)t;
|
||||
|
||||
/* Process data in 64-byte chunks */
|
||||
while (len >= 64) {
|
||||
memcpy(ctx->in, buf, 64);
|
||||
byteSwap(ctx->in, 16);
|
||||
__hsbase_MD5Transform(ctx->buf, ctx->in);
|
||||
buf += 64;
|
||||
len -= 64;
|
||||
}
|
||||
|
||||
/* Handle any remaining bytes of data. */
|
||||
memcpy(ctx->in, buf, len);
|
||||
}
|
||||
|
||||
/*
|
||||
* Final wrapup - pad to 64-byte boundary with the bit pattern
|
||||
* 1 0* (64-bit count of bits processed, MSB-first)
|
||||
*/
|
||||
void
|
||||
__hsbase_MD5Final(byte digest[16], struct MD5Context *ctx)
|
||||
{
|
||||
int count = (int)(ctx->bytes[0] & 0x3f); /* Bytes in ctx->in */
|
||||
byte *p = (byte *)ctx->in + count; /* First unused byte */
|
||||
|
||||
/* Set the first char of padding to 0x80. There is always room. */
|
||||
*p++ = 0x80;
|
||||
|
||||
/* Bytes of padding needed to make 56 bytes (-8..55) */
|
||||
count = 56 - 1 - count;
|
||||
|
||||
if (count < 0) { /* Padding forces an extra block */
|
||||
memset(p, 0, count+8);
|
||||
byteSwap(ctx->in, 16);
|
||||
__hsbase_MD5Transform(ctx->buf, ctx->in);
|
||||
p = (byte *)ctx->in;
|
||||
count = 56;
|
||||
}
|
||||
memset(p, 0, count+8);
|
||||
byteSwap(ctx->in, 14);
|
||||
|
||||
/* Append length in bits and transform */
|
||||
ctx->in[14] = ctx->bytes[0] << 3;
|
||||
ctx->in[15] = ctx->bytes[1] << 3 | ctx->bytes[0] >> 29;
|
||||
__hsbase_MD5Transform(ctx->buf, ctx->in);
|
||||
|
||||
byteSwap(ctx->buf, 4);
|
||||
memcpy(digest, ctx->buf, 16);
|
||||
memset(ctx, 0, sizeof(*ctx));
|
||||
}
|
||||
|
||||
|
||||
/* The four core functions - F1 is optimized somewhat */
|
||||
|
||||
/* #define F1(x, y, z) (x & y | ~x & z) */
|
||||
#define F1(x, y, z) (z ^ (x & (y ^ z)))
|
||||
#define F2(x, y, z) F1(z, x, y)
|
||||
#define F3(x, y, z) (x ^ y ^ z)
|
||||
#define F4(x, y, z) (y ^ (x | ~z))
|
||||
|
||||
/* This is the central step in the MD5 algorithm. */
|
||||
#define MD5STEP(f,w,x,y,z,in,s) \
|
||||
(w += f(x,y,z) + in, w = (w<<s | w>>(32-s)) + x)
|
||||
|
||||
/*
|
||||
* The core of the MD5 algorithm, this alters an existing MD5 hash to
|
||||
* reflect the addition of 16 longwords of new data. MD5Update blocks
|
||||
* the data and converts bytes into longwords for this routine.
|
||||
*/
|
||||
|
||||
void
|
||||
__hsbase_MD5Transform(word32 buf[4], word32 const in[16])
|
||||
{
|
||||
register word32 a, b, c, d;
|
||||
|
||||
a = buf[0];
|
||||
b = buf[1];
|
||||
c = buf[2];
|
||||
d = buf[3];
|
||||
|
||||
MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);
|
||||
MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);
|
||||
MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);
|
||||
MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);
|
||||
MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);
|
||||
MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);
|
||||
MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);
|
||||
MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);
|
||||
MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);
|
||||
MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);
|
||||
MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);
|
||||
MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);
|
||||
MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);
|
||||
MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);
|
||||
MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);
|
||||
MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);
|
||||
|
||||
MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);
|
||||
MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);
|
||||
MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);
|
||||
MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);
|
||||
MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);
|
||||
MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);
|
||||
MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);
|
||||
MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);
|
||||
MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);
|
||||
MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);
|
||||
MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);
|
||||
MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);
|
||||
MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);
|
||||
MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);
|
||||
MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);
|
||||
MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);
|
||||
|
||||
MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);
|
||||
MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);
|
||||
MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);
|
||||
MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);
|
||||
MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);
|
||||
MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);
|
||||
MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);
|
||||
MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);
|
||||
MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);
|
||||
MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);
|
||||
MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);
|
||||
MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);
|
||||
MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);
|
||||
MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);
|
||||
MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);
|
||||
MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);
|
||||
|
||||
MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);
|
||||
MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);
|
||||
MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);
|
||||
MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);
|
||||
MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);
|
||||
MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);
|
||||
MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);
|
||||
MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);
|
||||
MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);
|
||||
MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);
|
||||
MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);
|
||||
MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);
|
||||
MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);
|
||||
MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);
|
||||
MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);
|
||||
MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);
|
||||
|
||||
buf[0] += a;
|
||||
buf[1] += b;
|
||||
buf[2] += c;
|
||||
buf[3] += d;
|
||||
}
|
||||
|
@ -1,18 +0,0 @@
|
||||
/* MD5 message digest */
|
||||
#pragma once
|
||||
|
||||
#include "HsFFI.h"
|
||||
|
||||
typedef HsWord32 word32;
|
||||
typedef HsWord8 byte;
|
||||
|
||||
struct MD5Context {
|
||||
word32 buf[4];
|
||||
word32 bytes[2];
|
||||
word32 in[16];
|
||||
};
|
||||
|
||||
void __hsbase_MD5Init(struct MD5Context *context);
|
||||
void __hsbase_MD5Update(struct MD5Context *context, byte const *buf, int len);
|
||||
void __hsbase_MD5Final(byte digest[16], struct MD5Context *context);
|
||||
void __hsbase_MD5Transform(word32 buf[4], word32 const in[16]);
|
@ -1,306 +0,0 @@
|
||||
/*
|
||||
* Copyright (c) 2011 Bryan O'Sullivan <bos@serpentine.com>.
|
||||
*
|
||||
* Portions copyright (c) 2008-2010 Björn Höhrmann <bjoern@hoehrmann.de>.
|
||||
*
|
||||
* See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include "text_cbits.h"
|
||||
|
||||
void _hs_text_memcpy(void *dest, size_t doff, const void *src, size_t soff,
|
||||
size_t n)
|
||||
{
|
||||
memcpy(dest + (doff<<1), src + (soff<<1), n<<1);
|
||||
}
|
||||
|
||||
int _hs_text_memcmp(const void *a, size_t aoff, const void *b, size_t boff,
|
||||
size_t n)
|
||||
{
|
||||
return memcmp(a + (aoff<<1), b + (boff<<1), n<<1);
|
||||
}
|
||||
|
||||
#define UTF8_ACCEPT 0
|
||||
#define UTF8_REJECT 12
|
||||
|
||||
static const uint8_t utf8d[] = {
|
||||
/*
|
||||
* The first part of the table maps bytes to character classes that
|
||||
* to reduce the size of the transition table and create bitmasks.
|
||||
*/
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
|
||||
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
|
||||
8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
|
||||
10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
|
||||
|
||||
/*
|
||||
* The second part is a transition table that maps a combination of
|
||||
* a state of the automaton and a character class to a state.
|
||||
*/
|
||||
0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
|
||||
12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
|
||||
12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
|
||||
12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
|
||||
12,36,12,12,12,12,12,12,12,12,12,12,
|
||||
};
|
||||
|
||||
static inline uint32_t
|
||||
decode(uint32_t *state, uint32_t* codep, uint32_t byte) {
|
||||
uint32_t type = utf8d[byte];
|
||||
|
||||
*codep = (*state != UTF8_ACCEPT) ?
|
||||
(byte & 0x3fu) | (*codep << 6) :
|
||||
(0xff >> type) & (byte);
|
||||
|
||||
return *state = utf8d[256 + *state + type];
|
||||
}
|
||||
|
||||
/*
|
||||
* The ISO 8859-1 (aka latin-1) code points correspond exactly to the first 256 unicode
|
||||
* code-points, therefore we can trivially convert from a latin-1 encoded bytestring to
|
||||
* an UTF16 array
|
||||
*/
|
||||
void
|
||||
_hs_text_decode_latin1(uint16_t *dest, const uint8_t *src,
|
||||
const uint8_t *srcend)
|
||||
{
|
||||
const uint8_t *p = src;
|
||||
|
||||
#if defined(__i386__) || defined(__x86_64__)
|
||||
/* This optimization works on a little-endian systems by using
|
||||
(aligned) 32-bit loads instead of 8-bit loads
|
||||
*/
|
||||
|
||||
/* consume unaligned prefix */
|
||||
while (p != srcend && (uintptr_t)p & 0x3)
|
||||
*dest++ = *p++;
|
||||
|
||||
/* iterate over 32-bit aligned loads */
|
||||
while (p < srcend - 3) {
|
||||
const uint32_t w = *((const uint32_t *)p);
|
||||
|
||||
*dest++ = w & 0xff;
|
||||
*dest++ = (w >> 8) & 0xff;
|
||||
*dest++ = (w >> 16) & 0xff;
|
||||
*dest++ = (w >> 24) & 0xff;
|
||||
|
||||
p += 4;
|
||||
}
|
||||
#endif
|
||||
|
||||
/* handle unaligned suffix */
|
||||
while (p != srcend)
|
||||
*dest++ = *p++;
|
||||
}
|
||||
|
||||
/*
|
||||
* A best-effort decoder. Runs until it hits either end of input or
|
||||
* the start of an invalid byte sequence.
|
||||
*
|
||||
* At exit, we update *destoff with the next offset to write to, *src
|
||||
* with the next source location past the last one successfully
|
||||
* decoded, and return the next source location to read from.
|
||||
*
|
||||
* Moreover, we expose the internal decoder state (state0 and
|
||||
* codepoint0), allowing one to restart the decoder after it
|
||||
* terminates (say, due to a partial codepoint).
|
||||
*
|
||||
* In particular, there are a few possible outcomes,
|
||||
*
|
||||
* 1) We decoded the buffer entirely:
|
||||
* In this case we return srcend
|
||||
* state0 == UTF8_ACCEPT
|
||||
*
|
||||
* 2) We met an invalid encoding
|
||||
* In this case we return the address of the first invalid byte
|
||||
* state0 == UTF8_REJECT
|
||||
*
|
||||
* 3) We reached the end of the buffer while decoding a codepoint
|
||||
* In this case we return a pointer to the first byte of the partial codepoint
|
||||
* state0 != UTF8_ACCEPT, UTF8_REJECT
|
||||
*
|
||||
*/
|
||||
#if defined(__GNUC__) || defined(__clang__)
|
||||
static inline uint8_t const *
|
||||
_hs_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,
|
||||
const uint8_t **src, const uint8_t *srcend,
|
||||
uint32_t *codepoint0, uint32_t *state0)
|
||||
__attribute((always_inline));
|
||||
#endif
|
||||
|
||||
static inline uint8_t const *
|
||||
_hs_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,
|
||||
const uint8_t **src, const uint8_t *srcend,
|
||||
uint32_t *codepoint0, uint32_t *state0)
|
||||
{
|
||||
uint16_t *d = dest + *destoff;
|
||||
const uint8_t *s = *src, *last = *src;
|
||||
uint32_t state = *state0;
|
||||
uint32_t codepoint = *codepoint0;
|
||||
|
||||
while (s < srcend) {
|
||||
#if defined(__i386__) || defined(__x86_64__)
|
||||
/*
|
||||
* This code will only work on a little-endian system that
|
||||
* supports unaligned loads.
|
||||
*
|
||||
* It gives a substantial speed win on data that is purely or
|
||||
* partly ASCII (e.g. HTML), at only a slight cost on purely
|
||||
* non-ASCII text.
|
||||
*/
|
||||
|
||||
if (state == UTF8_ACCEPT) {
|
||||
while (s < srcend - 4) {
|
||||
codepoint = *((uint32_t *) s);
|
||||
if ((codepoint & 0x80808080) != 0)
|
||||
break;
|
||||
s += 4;
|
||||
|
||||
/*
|
||||
* Tried 32-bit stores here, but the extra bit-twiddling
|
||||
* slowed the code down.
|
||||
*/
|
||||
|
||||
*d++ = (uint16_t) (codepoint & 0xff);
|
||||
*d++ = (uint16_t) ((codepoint >> 8) & 0xff);
|
||||
*d++ = (uint16_t) ((codepoint >> 16) & 0xff);
|
||||
*d++ = (uint16_t) ((codepoint >> 24) & 0xff);
|
||||
}
|
||||
last = s;
|
||||
}
|
||||
#endif
|
||||
|
||||
if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {
|
||||
if (state != UTF8_REJECT)
|
||||
continue;
|
||||
break;
|
||||
}
|
||||
|
||||
if (codepoint <= 0xffff)
|
||||
*d++ = (uint16_t) codepoint;
|
||||
else {
|
||||
*d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));
|
||||
*d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));
|
||||
}
|
||||
last = s;
|
||||
}
|
||||
|
||||
*destoff = d - dest;
|
||||
*codepoint0 = codepoint;
|
||||
*state0 = state;
|
||||
*src = last;
|
||||
|
||||
return s;
|
||||
}
|
||||
|
||||
uint8_t const *
|
||||
_hs_text_decode_utf8_state(uint16_t *const dest, size_t *destoff,
|
||||
const uint8_t **src,
|
||||
const uint8_t *srcend,
|
||||
uint32_t *codepoint0, uint32_t *state0)
|
||||
{
|
||||
_hs_text_decode_utf8_int(dest, destoff, src, srcend, codepoint0, state0);
|
||||
|
||||
return *src;
|
||||
}
|
||||
|
||||
/*
|
||||
* Helper to decode buffer and discard final decoder state
|
||||
*/
|
||||
const uint8_t *
|
||||
_hs_text_decode_utf8(uint16_t *const dest, size_t *destoff,
|
||||
const uint8_t *src, const uint8_t *const srcend)
|
||||
{
|
||||
uint32_t codepoint;
|
||||
uint32_t state = UTF8_ACCEPT;
|
||||
_hs_text_decode_utf8_int(dest, destoff, &src, srcend,
|
||||
&codepoint, &state);
|
||||
return src;
|
||||
}
|
||||
|
||||
void
|
||||
_hs_text_encode_utf8(uint8_t **destp, const uint16_t *src, size_t srcoff,
|
||||
size_t srclen)
|
||||
{
|
||||
const uint16_t *srcend;
|
||||
uint8_t *dest = *destp;
|
||||
|
||||
src += srcoff;
|
||||
srcend = src + srclen;
|
||||
|
||||
ascii:
|
||||
#if defined(__x86_64__)
|
||||
while (srcend - src >= 4) {
|
||||
uint64_t w = *((uint64_t *) src);
|
||||
|
||||
if (w & 0xFF80FF80FF80FF80ULL) {
|
||||
if (!(w & 0x000000000000FF80ULL)) {
|
||||
*dest++ = w & 0xFFFF;
|
||||
src++;
|
||||
if (!(w & 0x00000000FF800000ULL)) {
|
||||
*dest++ = (w >> 16) & 0xFFFF;
|
||||
src++;
|
||||
if (!(w & 0x0000FF8000000000ULL)) {
|
||||
*dest++ = (w >> 32) & 0xFFFF;
|
||||
src++;
|
||||
}
|
||||
}
|
||||
}
|
||||
break;
|
||||
}
|
||||
*dest++ = w & 0xFFFF;
|
||||
*dest++ = (w >> 16) & 0xFFFF;
|
||||
*dest++ = (w >> 32) & 0xFFFF;
|
||||
*dest++ = w >> 48;
|
||||
src += 4;
|
||||
}
|
||||
#endif
|
||||
|
||||
#if defined(__i386__)
|
||||
while (srcend - src >= 2) {
|
||||
uint32_t w = *((uint32_t *) src);
|
||||
|
||||
if (w & 0xFF80FF80)
|
||||
break;
|
||||
*dest++ = w & 0xFFFF;
|
||||
*dest++ = w >> 16;
|
||||
src += 2;
|
||||
}
|
||||
#endif
|
||||
|
||||
while (src < srcend) {
|
||||
uint16_t w = *src++;
|
||||
|
||||
if (w <= 0x7F) {
|
||||
*dest++ = w;
|
||||
/* An ASCII byte is likely to begin a run of ASCII bytes.
|
||||
Falling back into the fast path really helps performance. */
|
||||
goto ascii;
|
||||
}
|
||||
else if (w <= 0x7FF) {
|
||||
*dest++ = (w >> 6) | 0xC0;
|
||||
*dest++ = (w & 0x3f) | 0x80;
|
||||
}
|
||||
else if (w < 0xD800 || w > 0xDBFF) {
|
||||
*dest++ = (w >> 12) | 0xE0;
|
||||
*dest++ = ((w >> 6) & 0x3F) | 0x80;
|
||||
*dest++ = (w & 0x3F) | 0x80;
|
||||
} else {
|
||||
uint32_t c = ((((uint32_t) w) - 0xD800) << 10) +
|
||||
(((uint32_t) *src++) - 0xDC00) + 0x10000;
|
||||
*dest++ = (c >> 18) | 0xF0;
|
||||
*dest++ = ((c >> 12) & 0x3F) | 0x80;
|
||||
*dest++ = ((c >> 6) & 0x3F) | 0x80;
|
||||
*dest++ = (c & 0x3F) | 0x80;
|
||||
}
|
||||
}
|
||||
|
||||
*destp = dest;
|
||||
}
|
@ -1,11 +0,0 @@
|
||||
/*
|
||||
* Copyright (c) 2013 Bryan O'Sullivan <bos@serpentine.com>.
|
||||
*/
|
||||
|
||||
#ifndef _text_cbits_h
|
||||
#define _text_cbits_h
|
||||
|
||||
#define UTF8_ACCEPT 0
|
||||
#define UTF8_REJECT 12
|
||||
|
||||
#endif
|
@ -1,149 +0,0 @@
|
||||
// Copyright (c) 2008-2009 Bjoern Hoehrmann
|
||||
// Copyright (c) 2015, Ondrej Palkovsky
|
||||
// Copyright (c) 2016, Winterland
|
||||
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
#include <stdint.h>
|
||||
|
||||
|
||||
#define UTF8_ACCEPT 0
|
||||
#define UTF8_REJECT 12
|
||||
|
||||
static const uint8_t utf8d[] = {
|
||||
// The first part of the table maps bytes to character classes that
|
||||
// to reduce the size of the transition table and create bitmasks.
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
||||
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
|
||||
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
|
||||
8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
|
||||
10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
|
||||
|
||||
// The second part is a transition table that maps a combination
|
||||
// of a state of the automaton and a character class to a state.
|
||||
0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
|
||||
12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
|
||||
12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
|
||||
12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
|
||||
12,36,12,12,12,12,12,12,12,12,12,12,
|
||||
};
|
||||
|
||||
static inline uint32_t decode(uint32_t* state, uint32_t* codep, uint32_t byte) {
|
||||
uint32_t type = utf8d[byte];
|
||||
|
||||
*codep = (*state != UTF8_ACCEPT) ?
|
||||
(byte & 0x3fu) | (*codep << 6) :
|
||||
(0xff >> type) & (byte);
|
||||
|
||||
*state = utf8d[256 + *state + type];
|
||||
return *state;
|
||||
}
|
||||
|
||||
static inline uint16_t decode_hex(uint32_t c)
|
||||
{
|
||||
if (c >= '0' && c <= '9') return c - '0';
|
||||
else if (c >= 'a' && c <= 'f') return c - 'a' + 10;
|
||||
else if (c >= 'A' && c <= 'F') return c - 'A' + 10;
|
||||
return 0xFFFF; // Should not happen
|
||||
}
|
||||
|
||||
// Decode, return non-zero value on error
|
||||
int _js_decode_string(uint16_t *const dest, size_t *destoff,
|
||||
const uint8_t *s, const uint8_t *const srcend)
|
||||
{
|
||||
uint16_t *d = dest + *destoff;
|
||||
uint32_t state = 0;
|
||||
uint32_t codepoint;
|
||||
|
||||
uint8_t surrogate = 0;
|
||||
uint16_t temp_hex = 0;
|
||||
uint16_t unidata;
|
||||
|
||||
// Optimized version of dispatch when just an ASCII char is expected
|
||||
#define DISPATCH_ASCII(label) {\
|
||||
if (s >= srcend) {\
|
||||
return -1;\
|
||||
}\
|
||||
codepoint = *s++;\
|
||||
goto label;\
|
||||
}
|
||||
|
||||
standard:
|
||||
// Test end of stream
|
||||
while (s < srcend) {
|
||||
if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {
|
||||
if (state == UTF8_REJECT) { return -1; }
|
||||
continue;
|
||||
}
|
||||
|
||||
if (codepoint == '\\')
|
||||
DISPATCH_ASCII(backslash)
|
||||
else if (codepoint <= 0xffff)
|
||||
*d++ = (uint16_t) codepoint;
|
||||
else {
|
||||
*d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));
|
||||
*d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));
|
||||
}
|
||||
}
|
||||
*destoff = d - dest;
|
||||
// Exit point
|
||||
return (state != UTF8_ACCEPT);
|
||||
backslash:
|
||||
switch (codepoint) {
|
||||
case '"':
|
||||
case '\\':
|
||||
case '/':
|
||||
*d++ = (uint16_t) codepoint;
|
||||
goto standard;
|
||||
break;
|
||||
case 'b': *d++ = '\b';goto standard;
|
||||
case 'f': *d++ = '\f';goto standard;
|
||||
case 'n': *d++ = '\n';goto standard;
|
||||
case 'r': *d++ = '\r';goto standard;
|
||||
case 't': *d++ = '\t';goto standard;
|
||||
case 'u': DISPATCH_ASCII(unicode1);;break;
|
||||
default:
|
||||
return -1;
|
||||
}
|
||||
unicode1:
|
||||
temp_hex = decode_hex(codepoint);
|
||||
if (temp_hex == 0xFFFF) { return -1; }
|
||||
else unidata = temp_hex << 12;
|
||||
DISPATCH_ASCII(unicode2);
|
||||
unicode2:
|
||||
temp_hex = decode_hex(codepoint);
|
||||
if (temp_hex == 0xFFFF) { return -1; }
|
||||
else unidata |= temp_hex << 8;
|
||||
DISPATCH_ASCII(unicode3);
|
||||
unicode3:
|
||||
temp_hex = decode_hex(codepoint);
|
||||
if (temp_hex == 0xFFFF) { return -1; }
|
||||
else unidata |= temp_hex << 4;
|
||||
DISPATCH_ASCII(unicode4);
|
||||
unicode4:
|
||||
temp_hex = decode_hex(codepoint);
|
||||
if (temp_hex == 0xFFFF) { return -1; }
|
||||
else unidata |= temp_hex;
|
||||
*d++ = (uint16_t) unidata;
|
||||
|
||||
if (surrogate) {
|
||||
if (unidata < 0xDC00 || unidata > 0xDFFF) // is not low surrogate
|
||||
return -1;
|
||||
surrogate = 0;
|
||||
} else if (unidata >= 0xD800 && unidata <= 0xDBFF ) { // is high surrogate
|
||||
surrogate = 1;
|
||||
DISPATCH_ASCII(surrogate1);
|
||||
} else if (unidata >= 0xDC00 && unidata <= 0xDFFF) { // is low surrogate
|
||||
return -1;
|
||||
}
|
||||
goto standard;
|
||||
surrogate1:
|
||||
if (codepoint != '\\') { return -1; }
|
||||
DISPATCH_ASCII(surrogate2)
|
||||
surrogate2:
|
||||
if (codepoint != 'u') { return -1; }
|
||||
DISPATCH_ASCII(unicode1)
|
||||
}
|
@ -42,13 +42,6 @@ extra-source-files:
|
||||
- test/argv/**/*.hs
|
||||
- test/endianness/**/*.hs
|
||||
|
||||
data-files:
|
||||
- cabal/**
|
||||
- libc/**
|
||||
- rts/**/*.mjs
|
||||
- boot-init.sh
|
||||
- boot.sh
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
_exe-ghc-options: &exe-ghc-options
|
||||
@ -69,7 +62,6 @@ dependencies:
|
||||
- ghc-toolkit
|
||||
- ghci-asterius
|
||||
- inline-js-core
|
||||
- libiserv
|
||||
- mtl
|
||||
- process
|
||||
- transformers
|
||||
@ -78,13 +70,11 @@ dependencies:
|
||||
internal-libraries:
|
||||
asterius-types:
|
||||
source-dirs: src-types
|
||||
generated-other-modules: Paths_asterius
|
||||
dependencies:
|
||||
- template-haskell
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
generated-other-modules: Paths_asterius
|
||||
dependencies:
|
||||
- asterius-types
|
||||
- binaryen
|
||||
@ -96,29 +86,9 @@ executables:
|
||||
c-sources:
|
||||
- ghc-bin-asterius/hschooks.c
|
||||
main: Main.hs
|
||||
default-extensions:
|
||||
- NoImplicitPrelude
|
||||
cpp-options:
|
||||
- -DGHCI
|
||||
ghc-options:
|
||||
- -threaded -fno-warn-name-shadowing -Wnoncanonical-monad-instances -Wnoncanonical-monoid-instances -no-hs-main
|
||||
dependencies:
|
||||
- array
|
||||
- asterius
|
||||
- haskeline
|
||||
- time
|
||||
- unix
|
||||
|
||||
ahc-pkg:
|
||||
source-dirs: ghc-pkg-asterius
|
||||
main: Main.hs
|
||||
cpp-options:
|
||||
- -DWITH_TERMINFO
|
||||
ghc-options: *exe-ghc-options
|
||||
ghc-options: -no-hs-main -threaded -rtsopts "-with-rtsopts=-H512m -I0 -qg"
|
||||
dependencies:
|
||||
- asterius
|
||||
- terminfo
|
||||
- unix
|
||||
|
||||
Setup-ghc-prim:
|
||||
source-dirs: app
|
||||
@ -127,13 +97,6 @@ executables:
|
||||
dependencies:
|
||||
- asterius
|
||||
|
||||
ahc-boot:
|
||||
source-dirs: app
|
||||
main: ahc-boot.hs
|
||||
ghc-options: *exe-ghc-options
|
||||
dependencies:
|
||||
- asterius
|
||||
|
||||
ahc-link:
|
||||
source-dirs: app
|
||||
main: ahc-link.hs
|
||||
|
@ -262,7 +262,7 @@ export class GC {
|
||||
// The closure is either pinned or static, and has
|
||||
// already been enqueued for scavenging: just return it
|
||||
return c;
|
||||
} else if (!this.memory.heapAlloced(untagged_c)) {
|
||||
} else if (!this.components.exports.__ahc_HEAP_ALLOCED(untagged_c)) {
|
||||
// Object in the static part of the memory:
|
||||
// it won't be copied ...
|
||||
this.nonMovedObjects.add(untagged_c);
|
||||
|
@ -13,12 +13,8 @@ import * as rtsConstants from "./rts.constants.mjs";
|
||||
* {@link https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/block-alloc}.
|
||||
*/
|
||||
export class HeapAlloc {
|
||||
constructor(memory) {
|
||||
/**
|
||||
* @type Memory
|
||||
* @name HeapAlloc#memory
|
||||
*/
|
||||
this.memory = memory;
|
||||
constructor(components) {
|
||||
this.components = components;
|
||||
/**
|
||||
* An array with two entries:
|
||||
* 1. The unpinned pool, i.e. the address of the
|
||||
@ -101,12 +97,12 @@ export class HeapAlloc {
|
||||
pinned = pinned || b >= rtsConstants.block_size;
|
||||
let pool = this.currentPools[Number(pinned)],
|
||||
current_start = Number(
|
||||
this.memory.i64Load(pool + rtsConstants.offset_bdescr_start)
|
||||
this.components.memory.i64Load(pool + rtsConstants.offset_bdescr_start)
|
||||
),
|
||||
current_free = Number(
|
||||
this.memory.i64Load(pool + rtsConstants.offset_bdescr_free)
|
||||
this.components.memory.i64Load(pool + rtsConstants.offset_bdescr_free)
|
||||
);
|
||||
const current_blocks = this.memory.i32Load(
|
||||
const current_blocks = this.components.memory.i32Load(
|
||||
pool + rtsConstants.offset_bdescr_blocks
|
||||
),
|
||||
current_limit = current_start + rtsConstants.block_size * current_blocks,
|
||||
@ -114,7 +110,7 @@ export class HeapAlloc {
|
||||
|
||||
if (new_free <= current_limit) {
|
||||
// if the pool has enough space
|
||||
this.memory.i64Store(
|
||||
this.components.memory.i64Store(
|
||||
pool + rtsConstants.offset_bdescr_free,
|
||||
new_free
|
||||
);
|
||||
@ -125,17 +121,17 @@ export class HeapAlloc {
|
||||
pool = this.hpAlloc(b, true);
|
||||
this.currentPools[1] = pool;
|
||||
} else {
|
||||
const gen_no = this.memory.i16Load(pool + rtsConstants.offset_bdescr_gen_no);
|
||||
const gen_no = this.components.memory.i16Load(pool + rtsConstants.offset_bdescr_gen_no);
|
||||
pool = this.hpAlloc(b, false, gen_no);
|
||||
this.currentPools[0] = pool;
|
||||
this.generations[gen_no] = pool;
|
||||
}
|
||||
current_free = Number(
|
||||
this.memory.i64Load(
|
||||
this.components.memory.i64Load(
|
||||
pool + rtsConstants.offset_bdescr_free
|
||||
)
|
||||
);
|
||||
this.memory.i64Store(
|
||||
this.components.memory.i64Store(
|
||||
pool + rtsConstants.offset_bdescr_free,
|
||||
current_free + b
|
||||
);
|
||||
@ -163,19 +159,19 @@ export class HeapAlloc {
|
||||
const req_blocks =
|
||||
(rtsConstants.mblock_size * n - rtsConstants.offset_first_block) /
|
||||
rtsConstants.block_size,
|
||||
mblock = this.memory.getMBlocks(n),
|
||||
mblock = this.components.exports.getMBlocks(n),
|
||||
bd = mblock + rtsConstants.offset_first_bdescr,
|
||||
block_addr = mblock + rtsConstants.offset_first_block;
|
||||
this.memory.i64Store(bd + rtsConstants.offset_bdescr_start, block_addr);
|
||||
this.memory.i64Store(bd + rtsConstants.offset_bdescr_free, block_addr);
|
||||
this.memory.i64Store(bd + rtsConstants.offset_bdescr_link, 0);
|
||||
this.memory.i16Store(bd + rtsConstants.offset_bdescr_node, n);
|
||||
this.memory.i32Store(bd + rtsConstants.offset_bdescr_blocks, req_blocks);
|
||||
this.memory.i16Store(
|
||||
this.components.memory.i64Store(bd + rtsConstants.offset_bdescr_start, block_addr);
|
||||
this.components.memory.i64Store(bd + rtsConstants.offset_bdescr_free, block_addr);
|
||||
this.components.memory.i64Store(bd + rtsConstants.offset_bdescr_link, 0);
|
||||
this.components.memory.i16Store(bd + rtsConstants.offset_bdescr_node, n);
|
||||
this.components.memory.i32Store(bd + rtsConstants.offset_bdescr_blocks, req_blocks);
|
||||
this.components.memory.i16Store(
|
||||
bd + rtsConstants.offset_bdescr_flags,
|
||||
pinned ? rtsConstants.BF_PINNED : 0
|
||||
);
|
||||
this.memory.i16Store(bd + rtsConstants.offset_bdescr_gen_no, gen_no);
|
||||
this.components.memory.i16Store(bd + rtsConstants.offset_bdescr_gen_no, gen_no);
|
||||
this.mgroups.add(bd);
|
||||
return bd;
|
||||
}
|
||||
@ -205,16 +201,16 @@ export class HeapAlloc {
|
||||
}
|
||||
this.mgroups.delete(bd);
|
||||
const p = bd - rtsConstants.offset_first_bdescr;
|
||||
this.memory.freeMBlocks(p);
|
||||
this.components.memory.freeMBlocks(p, 1);
|
||||
}
|
||||
|
||||
// Free unreachable MBlocks
|
||||
for (const bd of Array.from(this.mgroups)) {
|
||||
if (!live_mblocks.has(bd)) {
|
||||
const
|
||||
gen_no = this.memory.i16Load(bd + rtsConstants.offset_bdescr_gen_no),
|
||||
gen_no = this.components.memory.i16Load(bd + rtsConstants.offset_bdescr_gen_no),
|
||||
pinned = Boolean(
|
||||
this.memory.i16Load(bd + rtsConstants.offset_bdescr_flags) & rtsConstants.BF_PINNED
|
||||
this.components.memory.i16Load(bd + rtsConstants.offset_bdescr_flags) & rtsConstants.BF_PINNED
|
||||
);
|
||||
// Note: not all unreachable MBlocks can be
|
||||
// freed during a minor collection. This is because
|
||||
@ -224,8 +220,8 @@ export class HeapAlloc {
|
||||
if(major || (!pinned && gen_no == 0)) {
|
||||
this.mgroups.delete(bd);
|
||||
const p = bd - rtsConstants.offset_first_bdescr,
|
||||
n = this.memory.i16Load(bd + rtsConstants.offset_bdescr_node);
|
||||
this.memory.freeMBlocks(p, n);
|
||||
n = this.components.memory.i16Load(bd + rtsConstants.offset_bdescr_node);
|
||||
this.components.memory.freeMBlocks(p, n);
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -249,7 +245,7 @@ export class HeapAlloc {
|
||||
liveSize() {
|
||||
let acc = 0;
|
||||
for (const bd of this.mgroups) {
|
||||
acc += this.memory.i16Load(bd + rtsConstants.offset_bdescr_node);
|
||||
acc += this.components.memory.i16Load(bd + rtsConstants.offset_bdescr_node);
|
||||
}
|
||||
return acc;
|
||||
}
|
||||
|
@ -1,19 +1,9 @@
|
||||
import * as rtsConstants from "./rts.constants.mjs";
|
||||
|
||||
function checkNullAndTag(p) {
|
||||
if (!p) {
|
||||
throw new WebAssembly.RuntimeError(`Allocator returned NULL`);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
/**
|
||||
* Class acting as the low-level interface to Wasm memory.
|
||||
* It mainly provides methods to load/store data in memory
|
||||
* (e.g. {@link Memory#i64Load}, {@link Memory#i64Store}),
|
||||
* static methods to handle pointer tagging (e.g.
|
||||
* {@link Memory#getDynTag}), and a MBlock allocator
|
||||
* ({@link Memory#getMBlocks} and {@link Memory#freeMBlocks}).
|
||||
* {@link Memory#getDynTag}).
|
||||
*/
|
||||
export class Memory {
|
||||
constructor(components) {
|
||||
@ -24,16 +14,6 @@ export class Memory {
|
||||
* @name Memory#memory
|
||||
*/
|
||||
this.memory = undefined;
|
||||
/**
|
||||
* The number of MBlock slots reserved for
|
||||
* the static part of memory (vs the dynamic part
|
||||
* where heap objects are allocated at runtime).
|
||||
* The static MBlocks contain the initial compiled
|
||||
* Wasm code plus auxiliary static data structures
|
||||
* like info tables.
|
||||
* @name Memory#staticMBlocks
|
||||
*/
|
||||
this.staticMBlocks = undefined;
|
||||
/**
|
||||
* Low-level interfaces for reading/writing the contents
|
||||
* of {@link Memory#memory}.
|
||||
@ -54,9 +34,8 @@ export class Memory {
|
||||
/**
|
||||
* Initializes the {@link Memory} object.
|
||||
*/
|
||||
init(memory, static_mblocks) {
|
||||
init(memory) {
|
||||
this.memory = memory;
|
||||
this.staticMBlocks = static_mblocks;
|
||||
}
|
||||
|
||||
static unDynTag(p) {
|
||||
@ -153,40 +132,6 @@ export class Memory {
|
||||
return BigInt(this.dataView.getUint16(p, true));
|
||||
}
|
||||
|
||||
/**
|
||||
* Checks whether the object at address {@param p} is
|
||||
* heap-allocated, i.e. whether it resides in the dynamic
|
||||
* part of the memory. Used during garbage collection
|
||||
* (in {@link GC#evacuateClosure}) to avoid evacuating
|
||||
* objects in the static MBlocks.
|
||||
*/
|
||||
heapAlloced(p) {
|
||||
return (
|
||||
p >= this.staticMBlocks << rtsConstants.mblock_size_log2
|
||||
);
|
||||
}
|
||||
|
||||
/**
|
||||
* Obtains {@param n} MBlocks from {@link Memory#memory}.
|
||||
* @returns The memory address at the beginning of the
|
||||
* requested free memory area.
|
||||
*/
|
||||
getMBlocks(n) {
|
||||
return checkNullAndTag(
|
||||
this.components.exports.aligned_alloc(
|
||||
rtsConstants.mblock_size,
|
||||
rtsConstants.mblock_size * n
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
/**
|
||||
* Frees MBlocks starting at address {@param p}.
|
||||
*/
|
||||
freeMBlocks(p) {
|
||||
this.components.exports.free(p);
|
||||
}
|
||||
|
||||
expose(p, len, t) {
|
||||
return new t(this.memory.buffer, p, len);
|
||||
}
|
||||
|
@ -33,7 +33,7 @@ export async function newAsteriusInstance(req) {
|
||||
),
|
||||
__asterius_memory_base = new WebAssembly.Global(
|
||||
{ value: "i32", mutable: false },
|
||||
req.defaultMemoryBase // TODO: make dynamic.
|
||||
req.memoryBase // TODO: make dynamic.
|
||||
);
|
||||
|
||||
let mkSptEntries = function (spt_offset_entries) {
|
||||
@ -74,10 +74,6 @@ export async function newAsteriusInstance(req) {
|
||||
__asterius_fs = new FS(__asterius_components),
|
||||
__asterius_logger = new EventLogManager(),
|
||||
__asterius_tracer = new Tracer(__asterius_logger, __asterius_symbol_table),
|
||||
__asterius_static_mblocks = Math.ceil(
|
||||
(__asterius_memory_base.value + req.staticBytes) /
|
||||
rtsConstants.mblock_size
|
||||
),
|
||||
__asterius_memory = new Memory(__asterius_components),
|
||||
__asterius_memory_trap = new MemoryTrap(
|
||||
__asterius_logger,
|
||||
@ -85,7 +81,7 @@ export async function newAsteriusInstance(req) {
|
||||
__asterius_memory
|
||||
),
|
||||
__asterius_heapalloc = new HeapAlloc(
|
||||
__asterius_memory
|
||||
__asterius_components
|
||||
),
|
||||
__asterius_jsval_manager = new JSValManager(__asterius_components),
|
||||
__asterius_stableptr_manager = new StablePtrManager(),
|
||||
@ -233,7 +229,7 @@ export async function newAsteriusInstance(req) {
|
||||
|
||||
Object.assign(__asterius_exports, i.exports);
|
||||
|
||||
__asterius_memory.init(i.exports.memory, __asterius_static_mblocks);
|
||||
__asterius_memory.init(i.exports.memory);
|
||||
__asterius_heapalloc.init();
|
||||
__asterius_scheduler.setGC(__asterius_gc);
|
||||
|
||||
|
File diff suppressed because one or more lines are too long
@ -570,8 +570,7 @@ data Module
|
||||
globalExports :: [GlobalExport],
|
||||
globalMap :: SymbolMap Global,
|
||||
memorySegments :: [DataSegment],
|
||||
memoryImport :: Maybe MemoryImport,
|
||||
memoryMBlocks :: Int
|
||||
memoryImport :: Maybe MemoryImport
|
||||
}
|
||||
deriving (Show, Data)
|
||||
|
||||
|
@ -30,7 +30,7 @@ instance NFData EntitySymbol where
|
||||
-- | Convert an 'EntitySymbol' to a 'BS.ByteString'.
|
||||
{-# INLINE entityName #-}
|
||||
entityName :: EntitySymbol -> BS.ByteString
|
||||
entityName (EntitySymbol k) = GHC.fastStringToByteString k
|
||||
entityName (EntitySymbol k) = GHC.bytesFS k
|
||||
|
||||
-- | Create an 'EntitySymbol' from a 'BS.ByteString'.
|
||||
{-# INLINE mkEntitySymbol #-}
|
||||
|
@ -24,13 +24,11 @@ module Asterius.Backends.Binaryen
|
||||
where
|
||||
|
||||
import Asterius.Backends.Binaryen.CheckOverlapDataSegment
|
||||
import Asterius.Builtins
|
||||
import Asterius.EDSL (mkDynamicDataAddress, mkDynamicFunctionAddress)
|
||||
import qualified Asterius.Internals.Arena as A
|
||||
import Asterius.Internals.Barf
|
||||
import Asterius.Internals.MagicNumber
|
||||
import Asterius.Internals.Marshal
|
||||
import Asterius.JSGen.LibC
|
||||
import Asterius.Passes.CCall
|
||||
import Asterius.Types
|
||||
import qualified Asterius.Types.SymbolMap as SM
|
||||
@ -55,7 +53,6 @@ import Control.Monad
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as CBS
|
||||
import qualified Data.ByteString.Unsafe as BS
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
@ -69,7 +66,7 @@ import Foreign hiding
|
||||
)
|
||||
import Foreign.C
|
||||
import GHC.Exts
|
||||
import Language.Haskell.GHC.Toolkit.Constants
|
||||
import Asterius.JSGen.Wizer
|
||||
|
||||
newtype MarshalError
|
||||
= UnsupportedExpression Expression
|
||||
@ -267,6 +264,7 @@ data MarshalEnv = MarshalEnv
|
||||
envStaticsOffsetMap :: SM.SymbolMap Word32,
|
||||
-- | The offset map for the current module (functions).
|
||||
envFunctionsOffsetMap :: SM.SymbolMap Word32,
|
||||
envMemoryBase :: Word32,
|
||||
-- | The current module reference.
|
||||
envModuleRef :: Binaryen.Module
|
||||
}
|
||||
@ -297,6 +295,9 @@ askStaticsOffsetMap = reader envStaticsOffsetMap
|
||||
askFunctionsOffsetMap :: CodeGen (SM.SymbolMap Word32)
|
||||
askFunctionsOffsetMap = reader envFunctionsOffsetMap
|
||||
|
||||
askMemoryBase :: CodeGen Word32
|
||||
askMemoryBase = reader envMemoryBase
|
||||
|
||||
-- | Retrieve the reference to the current module.
|
||||
askModuleRef :: CodeGen Binaryen.Module
|
||||
askModuleRef = reader envModuleRef
|
||||
@ -531,12 +532,13 @@ marshalExpression e' = do
|
||||
verbose_err <- isVerboseErrOn
|
||||
ss_off_map <- askStaticsOffsetMap
|
||||
fn_off_map <- askFunctionsOffsetMap
|
||||
memory_base <- askMemoryBase
|
||||
m <- askModuleRef
|
||||
if | Just off <- SM.lookup unresolvedSymbol ss_off_map ->
|
||||
marshalExpression $
|
||||
if pic_is_on
|
||||
then mkDynamicDataAddress $ off + fromIntegral symbolOffset
|
||||
else ConstI64 $ mkStaticDataAddress $ off + fromIntegral symbolOffset
|
||||
else ConstI64 $ mkStaticDataAddress memory_base $ off + fromIntegral symbolOffset
|
||||
| Just off <- SM.lookup unresolvedSymbol fn_off_map ->
|
||||
marshalExpression $
|
||||
if pic_is_on
|
||||
@ -613,8 +615,8 @@ marshalFunctionTable m tbl_slots FunctionTable {..} = do
|
||||
(fromIntegral fnl)
|
||||
o
|
||||
|
||||
marshalMemorySegments :: Int -> [DataSegment] -> CodeGen ()
|
||||
marshalMemorySegments mbs segs = do
|
||||
marshalMemorySegments :: [DataSegment] -> CodeGen ()
|
||||
marshalMemorySegments segs = do
|
||||
env <- ask
|
||||
m <- askModuleRef
|
||||
a <- askArena
|
||||
@ -630,9 +632,10 @@ marshalMemorySegments mbs segs = do
|
||||
flip runReaderT env $ marshalExpression offset
|
||||
)
|
||||
(seg_sizes, _) <- marshalV a $ map (fromIntegral . BS.length . content) segs
|
||||
i <- c_BinaryenGetMemoryInitial m
|
||||
Binaryen.setMemory
|
||||
m
|
||||
(fromIntegral $ mbs * (mblock_size `quot` wasmPageSize))
|
||||
i
|
||||
(-1)
|
||||
nullPtr
|
||||
seg_bufs
|
||||
@ -691,26 +694,21 @@ marshalGlobal k Global {..} = do
|
||||
Binaryen.addGlobal m ptr ty mut e
|
||||
|
||||
marshalModule ::
|
||||
Int ->
|
||||
Bool ->
|
||||
Bool ->
|
||||
Bool ->
|
||||
SM.SymbolMap Word32 ->
|
||||
SM.SymbolMap Word32 ->
|
||||
[String] ->
|
||||
Word32 ->
|
||||
Module ->
|
||||
IO Binaryen.Module
|
||||
marshalModule static_bytes pic_on verbose_err tail_calls ss_off_map fn_off_map used_ccalls hs_mod@Module {..} = do
|
||||
let exports_keep = exports defLibCOpts
|
||||
m <- do
|
||||
bs <-
|
||||
genLibC
|
||||
defLibCOpts
|
||||
{ globalBase = (fromIntegral defaultMemoryBase + static_bytes) `roundup` 0x400,
|
||||
exports = exports_keep <> used_ccalls
|
||||
}
|
||||
BS.unsafeUseAsCStringLen bs $
|
||||
marshalModule pic_on verbose_err tail_calls ss_off_map fn_off_map last_data_offset hs_mod@Module {..} = do
|
||||
(m, memory_base) <- do
|
||||
(bs, memory_base) <- wizer last_data_offset
|
||||
BS.writeFile "wizer.output.wasm" bs
|
||||
m <- BS.unsafeUseAsCStringLen bs $
|
||||
\(p, l) -> Binaryen.Module.read p (fromIntegral l)
|
||||
pure (m, memory_base)
|
||||
checkOverlapDataSegment m
|
||||
Binaryen.setFeatures m
|
||||
$ foldl1' (.|.)
|
||||
@ -720,7 +718,7 @@ marshalModule static_bytes pic_on verbose_err tail_calls ss_off_map fn_off_map u
|
||||
libc_func_names <- binaryenModuleExportNames m
|
||||
for_ libc_func_names $
|
||||
\(_, ext_name) ->
|
||||
unless (CBS.unpack ext_name `elem` exports_keep) $ do
|
||||
when (ext_name `elem` ["_initialize"]) $ do
|
||||
p <- marshalBS a ext_name
|
||||
Binaryen.removeExport m p
|
||||
libc_func_info <- fmap M.fromList $ for libc_func_names $ \(in_name, ext_name) -> (ext_name,) . (in_name,) <$> binaryenFunctionType m in_name
|
||||
@ -734,6 +732,7 @@ marshalModule static_bytes pic_on verbose_err tail_calls ss_off_map fn_off_map u
|
||||
envAreTailCallsOn = tail_calls,
|
||||
envStaticsOffsetMap = ss_off_map,
|
||||
envFunctionsOffsetMap = fn_off_map,
|
||||
envMemoryBase = memory_base,
|
||||
envModuleRef = m
|
||||
}
|
||||
fts = generateWasmFunctionTypeSet hs_mod
|
||||
@ -754,7 +753,7 @@ marshalModule static_bytes pic_on verbose_err tail_calls ss_off_map fn_off_map u
|
||||
case tableImport of
|
||||
Just tbl_import -> marshalTableImport m tbl_import
|
||||
_ -> pure ()
|
||||
marshalMemorySegments memoryMBlocks memorySegments
|
||||
marshalMemorySegments memorySegments
|
||||
unless pic_on $ lift $ checkOverlapDataSegment m
|
||||
case memoryImport of
|
||||
Just mem_import -> marshalMemoryImport m mem_import
|
||||
@ -868,3 +867,5 @@ binaryenModuleExportNames m = do
|
||||
ext_name <- BS.packCString =<< Binaryen.Export.getName e
|
||||
pure $ Just (in_name, ext_name)
|
||||
else pure Nothing
|
||||
|
||||
foreign import ccall unsafe "BinaryenGetMemoryInitial" c_BinaryenGetMemoryInitial :: Binaryen.Module -> IO Binaryen.Index
|
||||
|
@ -1,129 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Asterius.Boot
|
||||
( BootArgs (..),
|
||||
defaultBootArgs,
|
||||
boot,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.BuildInfo
|
||||
import Asterius.Builtins
|
||||
import Asterius.Internals
|
||||
import Asterius.Internals.Temp
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Language.Haskell.GHC.Toolkit.BuildInfo
|
||||
( bootLibsPath,
|
||||
sandboxGhcLibDir,
|
||||
)
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
|
||||
data BootArgs = BootArgs
|
||||
{ bootDir :: FilePath,
|
||||
configureOptions :: String,
|
||||
builtinsOptions :: BuiltinsOptions
|
||||
}
|
||||
|
||||
defaultBootArgs :: BootArgs
|
||||
defaultBootArgs =
|
||||
BootArgs
|
||||
{ bootDir = dataDir </> ".boot",
|
||||
configureOptions =
|
||||
unwords
|
||||
[ "--disable-shared",
|
||||
"--disable-profiling",
|
||||
"--disable-debug-info",
|
||||
"--disable-library-for-ghci",
|
||||
"--disable-split-objs",
|
||||
"--disable-split-sections",
|
||||
"--disable-library-stripping",
|
||||
"--enable-relocatable",
|
||||
"-O2",
|
||||
"--prefix="
|
||||
<> (bootDir defaultBootArgs </> "asterius_lib"),
|
||||
"--global",
|
||||
"--ipid=$pkg",
|
||||
"--with-ghc=" <> ahc,
|
||||
"--with-ghc-pkg=" <> ahcPkg,
|
||||
"--hsc2hs-option=--cross-compile",
|
||||
"--ghc-option=-v1",
|
||||
"--ghc-option=-dsuppress-ticks"
|
||||
],
|
||||
builtinsOptions = defaultBuiltinsOptions
|
||||
}
|
||||
|
||||
bootTmpDir :: BootArgs -> FilePath
|
||||
bootTmpDir BootArgs {..} = bootDir </> "dist"
|
||||
|
||||
bootCreateProcess :: BootArgs -> IO CreateProcess
|
||||
bootCreateProcess args@BootArgs {..} = do
|
||||
e <- getEnvironment
|
||||
pure
|
||||
(proc "bash" ["-e", "boot.sh"])
|
||||
{ cwd = Just dataDir,
|
||||
env =
|
||||
Just $
|
||||
kvDedup $
|
||||
("ASTERIUS_BOOT_LIBS_DIR", bootLibsPath) :
|
||||
("ASTERIUS_SANDBOX_GHC_LIBDIR", sandboxGhcLibDir) :
|
||||
("ASTERIUS_LIB_DIR", bootDir </> "asterius_lib") :
|
||||
("ASTERIUS_TMP_DIR", bootTmpDir args) :
|
||||
("ASTERIUS_AHCPKG", ahcPkg) :
|
||||
("ASTERIUS_SETUP_GHC_PRIM", setupGhcPrim) :
|
||||
("ASTERIUS_CONFIGURE_OPTIONS", configureOptions) :
|
||||
[(k, v) | (k, v) <- e, k /= "GHC_PACKAGE_PATH"],
|
||||
delegate_ctlc = True
|
||||
}
|
||||
|
||||
bootRTSCmm :: BootArgs -> IO ()
|
||||
bootRTSCmm BootArgs {..} = do
|
||||
cmm_files <-
|
||||
map (rts_path </>)
|
||||
. filter ((== ".cmm") . takeExtension)
|
||||
<$> listDirectory rts_path
|
||||
withTempDir "ahc-boot" $ \tmpdir -> do
|
||||
for_ cmm_files $ \src ->
|
||||
callProcess
|
||||
ahc
|
||||
[ "-c",
|
||||
"-O2",
|
||||
"-dcmm-lint",
|
||||
"-I" <> obj_topdir </> "include",
|
||||
"-this-unit-id",
|
||||
"rts",
|
||||
"-o",
|
||||
tmpdir </> takeBaseName src <.> "o",
|
||||
src
|
||||
]
|
||||
callProcess "ar" $
|
||||
["qDS", obj_topdir </> "rts" </> "libHSrts.a"]
|
||||
<> [tmpdir </> takeBaseName src <.> "o" | src <- cmm_files]
|
||||
where
|
||||
rts_path = bootLibsPath </> "rts"
|
||||
obj_topdir = bootDir </> "asterius_lib"
|
||||
|
||||
runBootCreateProcess :: CreateProcess -> IO ()
|
||||
runBootCreateProcess = flip withCreateProcess $ \_ _ _ ph -> do
|
||||
ec <- waitForProcess ph
|
||||
case ec of
|
||||
ExitFailure _ -> fail "boot failure"
|
||||
_ -> pure ()
|
||||
|
||||
boot :: BootArgs -> IO ()
|
||||
boot args = do
|
||||
cp_boot <- bootCreateProcess args
|
||||
runBootCreateProcess
|
||||
cp_boot
|
||||
{ cmdspec = RawCommand "sh" ["-e", "boot-init.sh"]
|
||||
}
|
||||
bootRTSCmm args
|
||||
runBootCreateProcess cp_boot
|
||||
is_debug <- isJust <$> lookupEnv "ASTERIUS_DEBUG"
|
||||
unless is_debug $ removePathForcibly $ bootTmpDir args
|
@ -1,55 +0,0 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Asterius.BuildInfo
|
||||
-- Copyright : (c) 2018 EURL Tweag
|
||||
-- License : All rights reserved (see LICENCE file in the distribution).
|
||||
--
|
||||
-- Paths for data and binary files.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Asterius.BuildInfo
|
||||
( ahc,
|
||||
ahcPkg,
|
||||
ahcLd,
|
||||
ahcDist,
|
||||
setupGhcPrim,
|
||||
unlit,
|
||||
dataDir,
|
||||
ahcLibDir,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Paths_asterius
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO.Unsafe
|
||||
|
||||
{-# NOINLINE binDir #-}
|
||||
binDir :: FilePath
|
||||
binDir = unsafePerformIO Paths_asterius.getBinDir
|
||||
|
||||
{-# NOINLINE dataDir #-}
|
||||
dataDir :: FilePath
|
||||
dataDir = unsafePerformIO Paths_asterius.getDataDir
|
||||
|
||||
ahc :: FilePath
|
||||
ahc = binDir </> "ahc" <.> exeExtension
|
||||
|
||||
ahcPkg :: FilePath
|
||||
ahcPkg = binDir </> "ahc-pkg" <.> exeExtension
|
||||
|
||||
ahcLd :: FilePath
|
||||
ahcLd = binDir </> "ahc-ld" <.> exeExtension
|
||||
|
||||
ahcDist :: FilePath
|
||||
ahcDist = binDir </> "ahc-dist" <.> exeExtension
|
||||
|
||||
setupGhcPrim :: FilePath
|
||||
setupGhcPrim = binDir </> "Setup-ghc-prim" <.> exeExtension
|
||||
|
||||
unlit :: FilePath
|
||||
unlit = binDir </> "unlit" <.> exeExtension
|
||||
|
||||
ahcLibDir :: FilePath
|
||||
ahcLibDir = dataDir </> ".boot" </> "asterius_lib"
|
@ -1232,7 +1232,7 @@ threadPausedFunction _ = runEDSL "threadPaused" $ do
|
||||
|
||||
dirtyMutVarFunction :: BuiltinsOptions -> AsteriusModule
|
||||
dirtyMutVarFunction _ = runEDSL "dirty_MUT_VAR" $ do
|
||||
[_, p] <- params [I64, I64]
|
||||
[_, p, _] <- params [I64, I64, I64]
|
||||
if'
|
||||
[]
|
||||
(loadI64 p 0 `eqInt64` symbol "stg_MUT_VAR_CLEAN_info")
|
||||
@ -1241,7 +1241,7 @@ dirtyMutVarFunction _ = runEDSL "dirty_MUT_VAR" $ do
|
||||
|
||||
dirtyMVarFunction :: BuiltinsOptions -> AsteriusModule
|
||||
dirtyMVarFunction _ = runEDSL "dirty_MVAR" $ do
|
||||
[_basereg, _mvar] <- params [I64, I64]
|
||||
[_basereg, _mvar, _] <- params [I64, I64, I64]
|
||||
mempty
|
||||
|
||||
dirtyStackFunction :: BuiltinsOptions -> AsteriusModule
|
||||
|
@ -155,7 +155,7 @@ marshalCmmStatic st = case st of
|
||||
pure $ SymbolStatic sym o
|
||||
_ -> liftIO $ throwIO $ UnsupportedCmmLit $ showBS lit
|
||||
GHC.CmmUninitialised s -> pure $ Uninitialized s
|
||||
GHC.CmmString s -> pure $ Serialized $ BS.pack $ s <> [0]
|
||||
GHC.CmmString s -> pure $ Serialized $ s `BS.snoc` 0
|
||||
|
||||
marshalCmmSectionType :: EntitySymbol -> GHC.Section -> AsteriusStaticsType
|
||||
marshalCmmSectionType _ (GHC.Section GHC.ReadOnlyData16 _) =
|
||||
@ -163,7 +163,7 @@ marshalCmmSectionType _ (GHC.Section GHC.ReadOnlyData16 _) =
|
||||
marshalCmmSectionType sym sec@(GHC.Section _ clbl)
|
||||
| GHC.isGcPtrLabel clbl = Closure
|
||||
| "_info" `BS.isSuffixOf` entityName sym = InfoTable
|
||||
| GHC.isSecConstant sec = ConstBytes
|
||||
| GHC.sectionProtection sec /= GHC.ReadWriteSection = ConstBytes
|
||||
| otherwise = Bytes
|
||||
|
||||
marshalCmmData ::
|
||||
@ -1419,7 +1419,7 @@ marshalCmmUnsafeCall ::
|
||||
[GHC.LocalReg] ->
|
||||
[GHC.CmmExpr] ->
|
||||
CodeGen [Expression]
|
||||
marshalCmmUnsafeCall p@(GHC.CmmLit (GHC.CmmLabel clbl)) f@(GHC.ForeignConvention _ xs_hint rs_hint _) rs xs = do
|
||||
marshalCmmUnsafeCall p@(GHC.CmmLit (GHC.CmmLabel clbl)) f@(GHC.ForeignConvention _ xs_hint rs_hint _ _ _) rs xs = do
|
||||
sym <- marshalCLabel clbl
|
||||
xes <- for xs $ \x -> do
|
||||
(xe, _) <- marshalCmmExpr x
|
||||
|
@ -20,12 +20,13 @@ import DsCCall
|
||||
import DsForeign
|
||||
import DsMonad
|
||||
import ForeignCall
|
||||
import GHC.Hs
|
||||
import GhcPlugins
|
||||
import HsSyn
|
||||
import MkId
|
||||
import OrdList
|
||||
import Pair
|
||||
import PrelNames
|
||||
import RepType
|
||||
import TcEnv
|
||||
import TcRnMonad
|
||||
import TcType
|
||||
@ -47,7 +48,7 @@ asteriusDsForeigns fos = do
|
||||
traceIf (text "fi end" <+> ppr id)
|
||||
return bs
|
||||
do_decl ForeignExport {} = return []
|
||||
do_decl (XForeignDecl _) = panic "asteriusDsForeigns"
|
||||
do_decl (XForeignDecl nec) = noExtCon nec
|
||||
|
||||
asteriusDsFImport :: Id -> Coercion -> ForeignImport -> DsM [Binding]
|
||||
asteriusDsFImport id co (CImport cconv safety mHeader spec (unLoc -> src)) =
|
||||
@ -62,8 +63,11 @@ asteriusDsCImport ::
|
||||
Maybe Header ->
|
||||
SourceText ->
|
||||
DsM [Binding]
|
||||
asteriusDsCImport id co (CFunction target) cconv safety _ _ =
|
||||
asteriusDsFCall id co (CCall (CCallSpec target cconv safety))
|
||||
-- TODO: special treatment for prim call conv?
|
||||
-- TODO: add arg/return primreps?
|
||||
-- see https://github.com/ghc/ghc/commit/ff04eb5973b69fcc60e7d0945a74becd068c1888#diff-c101aeb1e72786c2c6e5035cda85ebc8369c91bbd0daba3abaa21b508d7156f8R103
|
||||
asteriusDsCImport id co (CFunction target) cconv safety _ _ | cconv /= PrimCallConv =
|
||||
asteriusDsFCall id co (CCall (mkCCallSpec target cconv safety (panic "Missing Return PrimRep") (panic "Missing Argument PrimReps")))
|
||||
asteriusDsCImport id co CWrapper JavaScriptCallConv _ _ src =
|
||||
asteriusDsFExportDynamic id co src
|
||||
asteriusDsCImport id co spec cconv safety mHeader _ = do
|
||||
@ -71,7 +75,7 @@ asteriusDsCImport id co spec cconv safety mHeader _ = do
|
||||
pure r
|
||||
|
||||
asteriusDsFCall :: Id -> Coercion -> ForeignCall -> DsM [(Id, Expr TyVar)]
|
||||
asteriusDsFCall fn_id co fcall = do
|
||||
asteriusDsFCall fn_id co (CCall (CCallSpec target cconv safety _ _)) = do
|
||||
let ty = pFst $ coercionKind co
|
||||
(tv_bndrs, rho) = tcSplitForAllVarBndrs ty
|
||||
(arg_tys, io_res_ty) = tcSplitFunTys rho
|
||||
@ -82,20 +86,23 @@ asteriusDsFCall fn_id co fcall = do
|
||||
ccall_uniq <- newUnique
|
||||
work_uniq <- newUnique
|
||||
dflags <- getDynFlags
|
||||
let fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys)
|
||||
fcall' <- case fcall of
|
||||
CCall (CCallSpec (StaticTarget _ cName mUnitId _) CApiConv safety) -> do
|
||||
CCall (CCallSpec (StaticTarget _ cName mUnitId _) CApiConv safety _ _) -> do
|
||||
wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
|
||||
let fcall' =
|
||||
CCall
|
||||
( CCallSpec
|
||||
( mkCCallSpec
|
||||
(StaticTarget NoSourceText wrapperName mUnitId True)
|
||||
CApiConv
|
||||
safety
|
||||
io_res_ty
|
||||
arg_tys
|
||||
)
|
||||
return fcall'
|
||||
_ -> return fcall
|
||||
let worker_ty =
|
||||
mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
|
||||
mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
|
||||
tvs = map binderVar tv_bndrs
|
||||
the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
|
||||
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
|
||||
@ -195,7 +202,7 @@ asteriusBoxResult result_ty
|
||||
(coreAltType the_alt)
|
||||
[the_alt]
|
||||
]
|
||||
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
|
||||
return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
|
||||
asteriusBoxResult result_ty = do
|
||||
res <- asteriusResultWrapper result_ty
|
||||
(ccall_res_ty, the_alt) <- mk_alt return_result res
|
||||
@ -205,7 +212,7 @@ asteriusBoxResult result_ty = do
|
||||
ccall_res_ty
|
||||
(coreAltType the_alt)
|
||||
[the_alt]
|
||||
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
|
||||
return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
|
||||
where
|
||||
return_result _ [ans] = ans
|
||||
return_result _ _ = panic "return_result: expected single result"
|
||||
|
@ -21,8 +21,8 @@ import Data.IORef
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.String
|
||||
import qualified ForeignCall as GHC
|
||||
import qualified GHC.Hs as GHC
|
||||
import qualified GhcPlugins as GHC
|
||||
import qualified HsSyn as GHC
|
||||
import qualified Panic as GHC
|
||||
import qualified PrelNames as GHC
|
||||
import System.IO.Unsafe
|
||||
@ -37,7 +37,7 @@ parseFFIValueType accept_prim norm_sig_ty = case norm_sig_ty of
|
||||
|
||||
parseFFIFunctionType :: Bool -> GHC.Type -> Maybe FFIFunctionType
|
||||
parseFFIFunctionType accept_prim norm_sig_ty = case res_ty of
|
||||
GHC.FunTy norm_t1 norm_t2 -> do
|
||||
GHC.FunTy _ norm_t1 norm_t2 -> do
|
||||
vt <- parseFFIValueType accept_prim norm_t1
|
||||
ft <- parseFFIFunctionType accept_prim norm_t2
|
||||
pure ft {ffiParamTypes = vt : ffiParamTypes ft}
|
||||
@ -164,7 +164,7 @@ processFFIExport hook_state_ref norm_sig_ty export_id (GHC.CExport (GHC.unLoc ->
|
||||
Just r -> r
|
||||
_ -> GHC.panicDoc "processFFIExport" $ GHC.ppr norm_sig_ty
|
||||
new_k =
|
||||
mkEntitySymbol $ GHC.fastStringToByteString lbl
|
||||
mkEntitySymbol $ GHC.bytesFS lbl
|
||||
export_closure = idClosureSymbol dflags export_id
|
||||
new_decl =
|
||||
FFIExportDecl
|
||||
|
@ -15,8 +15,8 @@ import Data.Maybe
|
||||
import DsMonad
|
||||
import ErrUtils
|
||||
import ForeignCall
|
||||
import GHC.Hs
|
||||
import GhcPlugins
|
||||
import HsSyn
|
||||
import Outputable
|
||||
import PrelNames
|
||||
import TcEnv
|
||||
|
@ -7,7 +7,6 @@ module Asterius.FrontendPlugin
|
||||
where
|
||||
|
||||
import Asterius.Binary.File
|
||||
import Asterius.BuildInfo
|
||||
import Asterius.CodeGen
|
||||
import Asterius.Foreign.DsForeign
|
||||
import Asterius.Foreign.TcForeign
|
||||
@ -16,7 +15,6 @@ import Asterius.Internals.PrettyShow
|
||||
import Asterius.JSFFI
|
||||
import Asterius.Types
|
||||
import Asterius.TypesConv
|
||||
import qualified Config as GHC
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
@ -36,6 +34,7 @@ import Language.Haskell.GHC.Toolkit.Orphans.Show
|
||||
import qualified Stream
|
||||
import System.Environment.Blank
|
||||
import System.FilePath
|
||||
import qualified ToolSettings as GHC
|
||||
|
||||
frontendPlugin :: GHC.Ghc ()
|
||||
frontendPlugin = do
|
||||
@ -61,14 +60,13 @@ frontendPlugin = do
|
||||
dflags <- GHC.getSessionDynFlags
|
||||
mySetSessionDynFlags $
|
||||
dflags
|
||||
{ GHC.settings =
|
||||
(GHC.settings dflags)
|
||||
{ GHC.sPgm_L = unlit,
|
||||
GHC.sPgm_l = (ahcLd, []),
|
||||
GHC.sPgm_i = "false"
|
||||
{ GHC.toolSettings =
|
||||
(GHC.toolSettings dflags)
|
||||
{ GHC.toolSettings_pgm_L = "unlit",
|
||||
GHC.toolSettings_pgm_l = ("ahc-ld", []),
|
||||
GHC.toolSettings_pgm_i = "false"
|
||||
}
|
||||
}
|
||||
`GHC.gopt_set` GHC.Opt_EagerBlackHoling
|
||||
`GHC.gopt_set` GHC.Opt_ExternalInterpreter
|
||||
when is_debug $ do
|
||||
dflags <- GHC.getSessionDynFlags
|
||||
@ -116,7 +114,6 @@ frontendPlugin = do
|
||||
mySetSessionDynFlags
|
||||
dflags
|
||||
{ GHC.integerLibrary = GHC.IntegerSimple,
|
||||
GHC.tablesNextToCode = False,
|
||||
GHC.hooks = h'
|
||||
}
|
||||
|
||||
|
@ -134,7 +134,6 @@ newGHCiSession = do
|
||||
{ nodeExtraArgs =
|
||||
[ "--experimental-modules",
|
||||
"--experimental-wasi-unstable-preview1",
|
||||
"--experimental-wasm-bigint",
|
||||
"--experimental-wasm-return-call",
|
||||
"--no-wasm-bounds-checks",
|
||||
"--no-wasm-stack-checks",
|
||||
@ -322,7 +321,7 @@ asteriusWriteIServ hsc_env i a
|
||||
asteriusRunTH
|
||||
i
|
||||
st
|
||||
(fromIntegral (mkStaticDataAddress $ staticsOffsetMap link_report ! sym)) -- TODO: make dynamic.
|
||||
(fromIntegral (mkStaticDataAddress (error "TODO") $ staticsOffsetMap link_report ! sym)) -- TODO: make dynamic.
|
||||
ty
|
||||
loc
|
||||
js_s
|
||||
@ -502,7 +501,8 @@ asteriusHscCompileCoreExpr hsc_env srcspan ds_expr = do
|
||||
asteriusLinkExpr :: GHC.HscEnv -> GHC.SrcSpan -> GHC.CoreExpr -> IO ()
|
||||
asteriusLinkExpr hsc_env srcspan prepd_expr = do
|
||||
GHC.initDynLinker hsc_env
|
||||
GHC.modifyPLS $ \pls0 -> do
|
||||
let dl = GHC.hsc_dynLinker hsc_env
|
||||
GHC.modifyPLS dl $ \pls0 -> do
|
||||
(pls, ok) <-
|
||||
GHC.linkDependencies hsc_env pls0 srcspan $
|
||||
neededModules prepd_expr
|
||||
|
@ -1,7 +1,6 @@
|
||||
module Asterius.Internals.MagicNumber
|
||||
( invalidAddress,
|
||||
defaultTableBase,
|
||||
defaultMemoryBase,
|
||||
mkStaticDataAddress,
|
||||
mkStaticFunctionAddress,
|
||||
)
|
||||
@ -17,13 +16,8 @@ invalidAddress = 0x001fffffffff0000
|
||||
defaultTableBase :: Word32
|
||||
defaultTableBase = 1024
|
||||
|
||||
-- | Base address for data segments. NOTE: leave 1KB empty for the
|
||||
-- @--low-memory-unused@ optimization to work.
|
||||
defaultMemoryBase :: Word32
|
||||
defaultMemoryBase = 1024
|
||||
|
||||
mkStaticDataAddress :: Word32 -> Int64
|
||||
mkStaticDataAddress off = fromIntegral (defaultMemoryBase + off)
|
||||
mkStaticDataAddress :: Word32 -> Word32 -> Int64
|
||||
mkStaticDataAddress memory_base off = fromIntegral (memory_base + off)
|
||||
|
||||
mkStaticFunctionAddress :: Word32 -> Int64
|
||||
mkStaticFunctionAddress off = fromIntegral (defaultTableBase + off)
|
||||
|
@ -3,8 +3,8 @@
|
||||
|
||||
module Asterius.JSGen.Bundle where
|
||||
|
||||
import Asterius.BuildInfo
|
||||
import Asterius.Internals.Temp
|
||||
import qualified Asterius.Sysroot as A
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Foldable
|
||||
import System.Directory
|
||||
@ -38,7 +38,7 @@ bundle BundleTask {..} =
|
||||
|
||||
bundleRTS :: IO BS.ByteString
|
||||
bundleRTS = withTempDir "asterius" $ \tmpdir -> do
|
||||
let rts_dir = dataDir </> "rts"
|
||||
let rts_dir = A.srcDir </> "asterius" </> "rts"
|
||||
rts_browser_dir = rts_dir </> "browser"
|
||||
rts_mjs <- filter ((== ".mjs") . takeExtension) <$> listDirectory rts_dir
|
||||
for_ rts_mjs $ \mjs -> copyFile (rts_dir </> mjs) (tmpdir </> mjs)
|
||||
|
@ -1,91 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Asterius.JSGen.LibC
|
||||
( LibCOpts (..),
|
||||
defLibCOpts,
|
||||
genLibC,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Asterius.BuildInfo as A
|
||||
import Asterius.Internals.Temp
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Traversable
|
||||
import Distribution.Simple.CCompiler
|
||||
import Distribution.Simple.Utils
|
||||
import System.Directory
|
||||
import System.Environment.Blank
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
|
||||
data LibCOpts = LibCOpts
|
||||
{ globalBase :: ~Int,
|
||||
exports :: [String]
|
||||
}
|
||||
|
||||
defLibCOpts :: LibCOpts
|
||||
defLibCOpts =
|
||||
LibCOpts
|
||||
{ globalBase = error "globalBase not set",
|
||||
exports =
|
||||
[ "aligned_alloc",
|
||||
"free",
|
||||
"memchr",
|
||||
"memcpy",
|
||||
"strlen"
|
||||
]
|
||||
}
|
||||
|
||||
genLibC :: LibCOpts -> IO BS.ByteString
|
||||
genLibC LibCOpts {..} = do
|
||||
wasi_sdk <- do
|
||||
mp <- getEnv "WASI_SDK_PATH"
|
||||
case mp of
|
||||
Just p -> pure p
|
||||
_ -> fail "WASI_SDK_PATH not set"
|
||||
let cish_dir = A.dataDir </> "libc"
|
||||
cish <- map (cish_dir </>) <$> listDirectory cish_dir
|
||||
let cbits = filter isC cish
|
||||
cxxbits = filter isCxx cish
|
||||
withTempDir "asterius" $ \tmpdir -> do
|
||||
let common_opts =
|
||||
[ "--sysroot=" <> wasi_sdk </> "share" </> "wasi-sysroot",
|
||||
"-I" <> (A.ahcLibDir </> "include"),
|
||||
"-Oz",
|
||||
"-flto"
|
||||
]
|
||||
c_objs <- for cbits $ \src -> do
|
||||
o <- newTempFile tmpdir "tmp.o"
|
||||
callProcess (wasi_sdk </> "bin" </> "clang") $
|
||||
common_opts
|
||||
<> ["-c", "-o", o, src]
|
||||
pure o
|
||||
cxx_objs <- for cxxbits $ \src -> do
|
||||
o <- newTempFile tmpdir "tmp.o"
|
||||
callProcess (wasi_sdk </> "bin" </> "clang++") $
|
||||
common_opts
|
||||
<> ["-c", "-o", o, src]
|
||||
pure o
|
||||
result_obj <- newTempFile tmpdir "tmp.wasm"
|
||||
callProcess (wasi_sdk </> "bin" </> "clang++") $
|
||||
common_opts
|
||||
<> ["-Wl,--export=" <> f | f <- ordNub exports]
|
||||
<> [ "-Wl,--allow-undefined",
|
||||
"-Wl,--compress-relocations",
|
||||
"-Wl,--export-table",
|
||||
"-Wl,--global-base=" <> show globalBase,
|
||||
"-Wl,--growable-table",
|
||||
"-Wl,--lto-O3",
|
||||
"-Wl,--strip-all"
|
||||
]
|
||||
<> ["-o", result_obj]
|
||||
<> c_objs
|
||||
<> cxx_objs
|
||||
BS.readFile result_obj
|
||||
|
||||
isC :: FilePath -> Bool
|
||||
isC = (== Just (C, True)) . filenameCDialect
|
||||
|
||||
isCxx :: FilePath -> Bool
|
||||
isCxx = (== Just (CPlusPlus, True)) . filenameCDialect
|
40
asterius/src/Asterius/JSGen/Wizer.hs
Normal file
40
asterius/src/Asterius/JSGen/Wizer.hs
Normal file
@ -0,0 +1,40 @@
|
||||
module Asterius.JSGen.Wizer where
|
||||
|
||||
import Asterius.Internals.Temp
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Word
|
||||
import Numeric
|
||||
import System.Environment.Blank
|
||||
import System.FilePath
|
||||
import System.IO.Unsafe
|
||||
import System.Process
|
||||
|
||||
wizer' :: FilePath -> Word32 -> IO (BS.ByteString, Word32)
|
||||
wizer' ahc_rts init_alloc_len = withTempDir "ahc-wizer" $ \d -> do
|
||||
init_stdout <-
|
||||
readProcess
|
||||
"wizer"
|
||||
["--allow-wasi", "-o", d </> "result.wasm", ahc_rts]
|
||||
(show init_alloc_len)
|
||||
init_addr <-
|
||||
case ( do
|
||||
s <- stripPrefix "0x" init_stdout
|
||||
(r, _) <- listToMaybe $ readHex s
|
||||
pure r
|
||||
) of
|
||||
Just r -> pure r
|
||||
_ -> fail $ "wizer returned " <> init_stdout
|
||||
result_wasm_buf <- BS.readFile $ d </> "result.wasm"
|
||||
pure (result_wasm_buf, init_addr)
|
||||
|
||||
wizer :: Word32 -> IO (BS.ByteString, Word32)
|
||||
wizer init_alloc_len = do
|
||||
Just ahc_rts <- getEnv "AHC_RTS"
|
||||
wizer' ahc_rts init_alloc_len
|
||||
|
||||
wizerInitAddr :: Word32 -> Word32
|
||||
wizerInitAddr init_alloc_len = unsafePerformIO $ do
|
||||
(_, init_addr) <- wizer init_alloc_len
|
||||
pure init_addr
|
@ -16,7 +16,6 @@ import qualified Asterius.Backends.Binaryen as Binaryen
|
||||
import qualified Asterius.Backends.Binaryen.RunPass as Binaryen
|
||||
import Asterius.Binary.File
|
||||
import Asterius.Binary.NameCache
|
||||
import Asterius.BuildInfo
|
||||
import Asterius.Foreign.ExportStatic
|
||||
import Asterius.Internals
|
||||
import Asterius.Internals.ByteString
|
||||
@ -29,6 +28,7 @@ import Asterius.JSGen.Wasm
|
||||
import Asterius.Ld (rtsUsedSymbols)
|
||||
import Asterius.Main.Task
|
||||
import Asterius.Resolve
|
||||
import qualified Asterius.Sysroot as A
|
||||
import Asterius.Types
|
||||
( Module,
|
||||
entityName,
|
||||
@ -182,16 +182,14 @@ genReq task LinkReport {..} =
|
||||
genSPT staticsOffsetMap sptEntries,
|
||||
", tableSlots: ",
|
||||
intDec tableSlots,
|
||||
", staticBytes: ",
|
||||
intDec staticBytes,
|
||||
", yolo: ",
|
||||
if yolo task then "true" else "false",
|
||||
", pic: ",
|
||||
if pic task then "true" else "false",
|
||||
", defaultTableBase: ",
|
||||
intHex defaultTableBase,
|
||||
", defaultMemoryBase: ",
|
||||
intHex defaultMemoryBase,
|
||||
", memoryBase: ",
|
||||
intHex memoryBase,
|
||||
", consoleHistory: ",
|
||||
if consoleHistory task then "true" else "false",
|
||||
", gcThreshold: ",
|
||||
@ -255,11 +253,8 @@ ahcLink :: Task -> IO (Asterius.Types.Module, LinkReport)
|
||||
ahcLink task = do
|
||||
ld_output <- temp (takeBaseName (inputHS task))
|
||||
putStrLn $ "[INFO] Compiling " <> inputHS task <> " to WebAssembly"
|
||||
callProcess ahc $
|
||||
[ "--make",
|
||||
"-O2",
|
||||
"-i" <> takeDirectory (inputHS task)
|
||||
]
|
||||
callProcess "ahc" $
|
||||
["--make", "-O2", "-i" <> takeDirectory (inputHS task)]
|
||||
<> concat [["-no-hs-main", "-optl--no-main"] | not $ hasMain task]
|
||||
<> ["-optl--debug" | debug task]
|
||||
<> [ "-optl--extra-root-symbol=" <> c8BS (entityName root_sym)
|
||||
@ -309,13 +304,12 @@ ahcDistMain logger task (final_m, report) = do
|
||||
Binaryen.setLowMemoryUnused 1
|
||||
m_ref <-
|
||||
Binaryen.marshalModule
|
||||
(staticBytes report)
|
||||
(pic task)
|
||||
(verboseErr task)
|
||||
(tailCalls task)
|
||||
(staticsOffsetMap report)
|
||||
(functionOffsetMap report)
|
||||
(usedCCalls report)
|
||||
(lastDataOffset report)
|
||||
final_m
|
||||
when (optimizeLevel task > 0 || shrinkLevel task > 0) $ do
|
||||
logger "[INFO] Running binaryen optimization"
|
||||
@ -351,12 +345,12 @@ ahcDistMain logger task (final_m, report) = do
|
||||
"[INFO] Writing JavaScript runtime modules to "
|
||||
<> show
|
||||
(outputDirectory task)
|
||||
rts_files' <- listDirectory $ dataDir </> "rts"
|
||||
rts_files' <- listDirectory $ A.srcDir </> "asterius" </> "rts"
|
||||
let rts_files = filter (\x -> x /= "browser" && x /= "node") rts_files'
|
||||
for_ rts_files $
|
||||
\f -> copyFile (dataDir </> "rts" </> f) (outputDirectory task </> f)
|
||||
\f -> copyFile (A.srcDir </> "asterius" </> "rts" </> f) (outputDirectory task </> f)
|
||||
let specific_dir =
|
||||
dataDir </> "rts" </> case target task of
|
||||
A.srcDir </> "asterius" </> "rts" </> case target task of
|
||||
Node -> "node"
|
||||
Browser -> "browser"
|
||||
specific_contents <- listDirectory specific_dir
|
||||
@ -394,7 +388,6 @@ ahcDistMain logger task (final_m, report) = do
|
||||
callProcess "node" $
|
||||
[ "--experimental-modules",
|
||||
"--experimental-wasi-unstable-preview1",
|
||||
"--experimental-wasm-bigint",
|
||||
"--experimental-wasm-return-call",
|
||||
"--unhandled-rejections=strict",
|
||||
takeFileName script
|
||||
|
@ -23,6 +23,7 @@ import qualified Data.Set as Set
|
||||
import Data.Tuple
|
||||
import Foreign
|
||||
import Language.Haskell.GHC.Toolkit.Constants
|
||||
import Asterius.JSGen.Wizer
|
||||
|
||||
-- | Segments are 8-bytes aligned.
|
||||
{-# INLINE segAlignment #-}
|
||||
@ -138,9 +139,10 @@ makeStaticSegment ::
|
||||
SM.SymbolMap Word32 ->
|
||||
SM.SymbolMap Word32 ->
|
||||
Word32 ->
|
||||
Word32 ->
|
||||
AsteriusStatic ->
|
||||
(Word32, Bag DataSegment)
|
||||
makeStaticSegment fn_off_map ss_off_map current_off static =
|
||||
makeStaticSegment fn_off_map ss_off_map memory_base current_off static =
|
||||
( current_off + sizeofStatic static,
|
||||
case static of
|
||||
SymbolStatic sym o
|
||||
@ -148,26 +150,26 @@ makeStaticSegment fn_off_map ss_off_map current_off static =
|
||||
unitBag
|
||||
DataSegment
|
||||
{ content = encodeStorable $ mkStaticFunctionAddress (off + fromIntegral o),
|
||||
offset = ConstI32 $ fromIntegral $ defaultMemoryBase + current_off
|
||||
offset = ConstI32 $ fromIntegral $ memory_base + current_off
|
||||
}
|
||||
| Just off <- SM.lookup sym ss_off_map ->
|
||||
unitBag
|
||||
DataSegment
|
||||
{ content = encodeStorable $ mkStaticDataAddress (off + fromIntegral o),
|
||||
offset = ConstI32 $ fromIntegral $ defaultMemoryBase + current_off
|
||||
{ content = encodeStorable $ mkStaticDataAddress memory_base (off + fromIntegral o),
|
||||
offset = ConstI32 $ fromIntegral $ memory_base + current_off
|
||||
}
|
||||
| otherwise ->
|
||||
unitBag
|
||||
DataSegment
|
||||
{ content = encodeStorable invalidAddress,
|
||||
offset = ConstI32 $ fromIntegral $ defaultMemoryBase + current_off
|
||||
offset = ConstI32 $ fromIntegral $ memory_base + current_off
|
||||
}
|
||||
Uninitialized {} -> emptyBag
|
||||
Serialized buf ->
|
||||
unitBag
|
||||
DataSegment
|
||||
{ content = buf,
|
||||
offset = ConstI32 $ fromIntegral $ defaultMemoryBase + current_off
|
||||
offset = ConstI32 $ fromIntegral $ memory_base + current_off
|
||||
}
|
||||
)
|
||||
|
||||
@ -176,8 +178,9 @@ makeStaticMemory ::
|
||||
AsteriusModule ->
|
||||
SM.SymbolMap Word32 ->
|
||||
SM.SymbolMap Word32 ->
|
||||
Word32 ->
|
||||
[DataSegment]
|
||||
makeStaticMemory AsteriusModule {..} fn_off_map ss_off_map =
|
||||
makeStaticMemory AsteriusModule {..} fn_off_map ss_off_map _memory_base =
|
||||
concat
|
||||
$ SM.elems
|
||||
$ flip SM.mapWithKey staticsMap
|
||||
@ -186,7 +189,7 @@ makeStaticMemory AsteriusModule {..} fn_off_map ss_off_map =
|
||||
$ unionManyBags
|
||||
$ snd
|
||||
$ mapAccumL
|
||||
(makeStaticSegment fn_off_map ss_off_map)
|
||||
(makeStaticSegment fn_off_map ss_off_map _memory_base)
|
||||
(ss_off_map SM.! statics_sym)
|
||||
asteriusStatics
|
||||
|
||||
@ -293,20 +296,21 @@ makeMemory ::
|
||||
Bool ->
|
||||
AsteriusModule ->
|
||||
SM.SymbolMap Word32 ->
|
||||
([DataSegment], SM.SymbolMap Word32, Word32, AsteriusModule) -- relocation function implementation
|
||||
([DataSegment], SM.SymbolMap Word32, Word32, Word32, AsteriusModule) -- relocation function implementation
|
||||
makeMemory pic_is_on m_globals_resolved fn_off_map
|
||||
| pic_is_on =
|
||||
let (seg, reloc, new_seg_len, new_seg_offs) = makeDynamicMemory m_globals_resolved fn_off_map _ss_off_map
|
||||
in ( [seg],
|
||||
_ss_off_map <> new_seg_offs,
|
||||
_last_data_offset + new_seg_len,
|
||||
_last_data_offset + new_seg_len, error "TODO",
|
||||
reloc <> m_globals_resolved
|
||||
)
|
||||
| otherwise =
|
||||
( makeStaticMemory m_globals_resolved fn_off_map _ss_off_map,
|
||||
( makeStaticMemory m_globals_resolved fn_off_map _ss_off_map _memory_base,
|
||||
_ss_off_map,
|
||||
_last_data_offset,
|
||||
_memory_base, _last_data_offset,
|
||||
m_globals_resolved
|
||||
)
|
||||
where
|
||||
(_ss_off_map, _last_data_offset) = makeDataOffsetTable m_globals_resolved
|
||||
_memory_base = wizerInitAddr _last_data_offset
|
||||
|
@ -51,11 +51,12 @@ resolveAsteriusModule ::
|
||||
AsteriusModule,
|
||||
SM.SymbolMap Word32,
|
||||
SM.SymbolMap Word32,
|
||||
Int,
|
||||
Word32,
|
||||
Word32,
|
||||
Int
|
||||
)
|
||||
resolveAsteriusModule pic_is_on debug m_globals_resolved =
|
||||
(new_mod, final_m, ss_off_map, fn_off_map, table_slots, initial_bytes)
|
||||
(new_mod, final_m, ss_off_map, fn_off_map, memory_base, last_data_offset, table_slots)
|
||||
where
|
||||
-- Create the function offset table first. A dummy relocation function
|
||||
-- already so the map will be created correctly.
|
||||
@ -65,16 +66,13 @@ resolveAsteriusModule pic_is_on debug m_globals_resolved =
|
||||
-- on), the relocation function must be replaced, and new data segments
|
||||
-- (and corresponding statics) must be added, to hold the offsets needed by
|
||||
-- the relocation function. All this is handled by @makeMemory@.
|
||||
(segs, ss_off_map, last_data_offset, final_m) = makeMemory pic_is_on m_globals_resolved fn_off_map
|
||||
(segs, ss_off_map, memory_base, last_data_offset, final_m) = makeMemory pic_is_on m_globals_resolved fn_off_map
|
||||
func_table = makeFunctionTable fn_off_map
|
||||
table_slots = fromIntegral last_func_offset
|
||||
func_imports =
|
||||
rtsFunctionImports debug <> generateFFIFunctionImports (ffiMarshalState final_m)
|
||||
new_function_map =
|
||||
LM.mapKeys entityName $ SM.toMap $ functionMap final_m
|
||||
initial_bytes = fromIntegral last_data_offset
|
||||
initial_mblocks = -- minimum limit
|
||||
(fromIntegral last_data_offset `roundup` mblock_size) `quot` mblock_size
|
||||
new_mod = Module
|
||||
{ functionMap' = new_function_map,
|
||||
functionImports = func_imports,
|
||||
@ -97,8 +95,7 @@ resolveAsteriusModule pic_is_on debug m_globals_resolved =
|
||||
globalExports = rtsGlobalExports,
|
||||
globalMap = globalsMap final_m, -- Copy as-is.
|
||||
memorySegments = segs,
|
||||
memoryImport = Nothing,
|
||||
memoryMBlocks = initial_mblocks
|
||||
memoryImport = Nothing
|
||||
}
|
||||
|
||||
linkStart ::
|
||||
@ -115,9 +112,10 @@ linkStart pic_on debug gc_sections store root_syms export_funcs =
|
||||
LinkReport
|
||||
{ staticsOffsetMap = ss_off_map,
|
||||
functionOffsetMap = fn_off_map,
|
||||
memoryBase = memory_base,
|
||||
lastDataOffset = last_data_offset,
|
||||
infoTableOffsetSet = makeInfoTableOffsetSet merged_m ss_off_map,
|
||||
Asterius.Types.LinkReport.tableSlots = tbl_slots,
|
||||
staticBytes = static_bytes,
|
||||
sptEntries = sptMap merged_m,
|
||||
bundledFFIMarshalState = ffiMarshalState merged_m,
|
||||
usedCCalls =
|
||||
@ -133,5 +131,5 @@ linkStart pic_on debug gc_sections store root_syms export_funcs =
|
||||
!merged_m1
|
||||
| debug = traceModule $ addMemoryTrap merged_m0_evaluated
|
||||
| otherwise = merged_m0_evaluated
|
||||
(!result_m, !merged_m, !ss_off_map, !fn_off_map, !tbl_slots, !static_bytes) =
|
||||
(!result_m, !merged_m, !ss_off_map, !fn_off_map, !memory_base, !last_data_offset, !tbl_slots) =
|
||||
resolveAsteriusModule pic_on debug merged_m1
|
||||
|
21
asterius/src/Asterius/Sysroot.hs
Normal file
21
asterius/src/Asterius/Sysroot.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Asterius.Sysroot where
|
||||
|
||||
import System.Directory
|
||||
import System.Environment.Blank
|
||||
import System.IO.Unsafe
|
||||
|
||||
{-# NOINLINE srcDir #-}
|
||||
srcDir :: FilePath
|
||||
srcDir = unsafePerformIO $ do
|
||||
mp <- getEnv "AHC_SRCDIR"
|
||||
case mp of
|
||||
Nothing -> fail "AHC_SRCDIR is not set"
|
||||
Just s -> canonicalizePath s
|
||||
|
||||
{-# NOINLINE sysroot #-}
|
||||
sysroot :: FilePath
|
||||
sysroot = unsafePerformIO $ do
|
||||
mp <- getEnv "AHC_LIBDIR"
|
||||
case mp of
|
||||
Nothing -> fail "AHC_LIBDIR is not set"
|
||||
Just s -> canonicalizePath s
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Asterius.Types.LinkReport
|
||||
@ -14,8 +15,9 @@ import Data.Word
|
||||
data LinkReport
|
||||
= LinkReport
|
||||
{ staticsOffsetMap, functionOffsetMap :: SymbolMap Word32,
|
||||
memoryBase, lastDataOffset :: Word32,
|
||||
infoTableOffsetSet :: [Word32],
|
||||
tableSlots, staticBytes :: Int,
|
||||
tableSlots :: Int,
|
||||
sptEntries :: SymbolMap (Word64, Word64),
|
||||
bundledFFIMarshalState :: FFIMarshalState,
|
||||
usedCCalls :: [String]
|
||||
|
@ -11,7 +11,6 @@ main = do
|
||||
"node"
|
||||
[ "--experimental-modules",
|
||||
"--experimental-wasi-unstable-preview1",
|
||||
"--experimental-wasm-bigint",
|
||||
"--experimental-wasm-return-call",
|
||||
"--unhandled-rejections=strict",
|
||||
"argv.mjs",
|
||||
|
@ -139,7 +139,6 @@ runTestCase l_opts tlref TestCase {..} = catch m h
|
||||
{ nodeExtraArgs =
|
||||
[ "--experimental-modules",
|
||||
"--experimental-wasi-unstable-preview1",
|
||||
"--experimental-wasm-bigint",
|
||||
"--experimental-wasm-return-call",
|
||||
"--no-wasm-bounds-checks",
|
||||
"--no-wasm-stack-checks",
|
||||
|
@ -1,90 +0,0 @@
|
||||
FROM debian:sid-slim
|
||||
|
||||
ARG DEBIAN_FRONTEND=noninteractive
|
||||
|
||||
ARG NODE_VER=15.6.0
|
||||
|
||||
ENV \
|
||||
LANG=C.UTF-8 \
|
||||
PATH=/root/.asterius-local-install-root/bin:/root/.asterius-snapshot-install-root/bin:/root/.asterius-compiler-bin:/root/.local/bin:/root/.nvm/versions/node/v${NODE_VER}/bin:${PATH} \
|
||||
WASI_SDK_PATH=/opt/wasi-sdk
|
||||
|
||||
RUN \
|
||||
apt update && \
|
||||
apt full-upgrade -y && \
|
||||
apt install -y \
|
||||
alex \
|
||||
automake \
|
||||
build-essential \
|
||||
binaryen \
|
||||
c2hs \
|
||||
cpphs \
|
||||
curl \
|
||||
gawk \
|
||||
git \
|
||||
happy \
|
||||
libffi-dev \
|
||||
libgmp-dev \
|
||||
libncurses-dev \
|
||||
python3-minimal \
|
||||
zlib1g-dev && \
|
||||
mkdir -p ${WASI_SDK_PATH} && \
|
||||
(curl -L https://github.com/TerrorJack/wasi-sdk/releases/download/210113/wasi-sdk-12.1g41fa3294474c-linux.tar.gz | tar xz -C ${WASI_SDK_PATH} --strip-components=1) && \
|
||||
cp \
|
||||
/etc/skel/.bash_logout \
|
||||
/etc/skel/.bashrc \
|
||||
/etc/skel/.profile \
|
||||
/root
|
||||
|
||||
WORKDIR /root
|
||||
|
||||
COPY . /root/.asterius
|
||||
|
||||
RUN \
|
||||
(curl https://raw.githubusercontent.com/nvm-sh/nvm/v0.37.2/install.sh | bash) && \
|
||||
bash -i -c "nvm install ${NODE_VER}" && \
|
||||
patch ~/.nvm/versions/node/v${NODE_VER}/lib/node_modules/npm/node_modules/@npmcli/promise-spawn/index.js ~/.asterius/utils/promise-spawn.patch && \
|
||||
bash -i -c "npm install -g --unsafe-perm=true --allow-root @cloudflare/wrangler webpack webpack-cli" && \
|
||||
mkdir -p ~/.local/bin && \
|
||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64-bin -o ~/.local/bin/stack && \
|
||||
chmod +x ~/.local/bin/stack && \
|
||||
curl http://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz | tar xJ -C ~/.local/bin --wildcards '*/cabal'
|
||||
|
||||
RUN \
|
||||
cd ~/.asterius && \
|
||||
mkdir lib && \
|
||||
cd lib && \
|
||||
../utils/make-packages.py && \
|
||||
rm -rf ghc && \
|
||||
cd .. && \
|
||||
stack --no-terminal update && \
|
||||
stack --no-terminal build \
|
||||
asterius && \
|
||||
ln -s $(stack path --local-install-root) ~/.asterius-local-install-root && \
|
||||
ln -s $(stack path --snapshot-install-root) ~/.asterius-snapshot-install-root && \
|
||||
ln -s $(stack path --compiler-bin) ~/.asterius-compiler-bin && \
|
||||
ahc-boot
|
||||
|
||||
RUN \
|
||||
apt purge -y \
|
||||
mawk && \
|
||||
apt autoremove --purge -y && \
|
||||
apt clean && \
|
||||
rm -rf -v \
|
||||
/root/.ahc-cabal \
|
||||
/root/.config \
|
||||
/root/.local/bin/stack \
|
||||
/root/.npm \
|
||||
/root/.stack/pantry \
|
||||
/root/.stack/programs/*/*.tar.xz \
|
||||
/tmp/* \
|
||||
/var/lib/apt/lists/* \
|
||||
/var/tmp/*
|
||||
|
||||
RUN \
|
||||
ahc --version && \
|
||||
alex --version && \
|
||||
cabal --version && \
|
||||
node --version && \
|
||||
wasm-opt --version && \
|
||||
${WASI_SDK_PATH}/bin/wasm-ld --version
|
4
cabal.project
Normal file
4
cabal.project
Normal file
@ -0,0 +1,4 @@
|
||||
packages:
|
||||
asterius
|
||||
ghc-toolkit
|
||||
wasm-toolkit
|
33
cabal.project.nix
Normal file
33
cabal.project.nix
Normal file
@ -0,0 +1,33 @@
|
||||
packages:
|
||||
asterius
|
||||
ghc-toolkit
|
||||
wasm-toolkit
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/tweag/inline-js.git
|
||||
tag: 0fc7444c552820e44ea54ae82eb1f8542dd56f36
|
||||
subdir: inline-js-core
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/tweag/ghc-asterius.git
|
||||
tag: 7db476e9d7c28e1bf70391b0f276b657acce6bf0
|
||||
subdir:
|
||||
ahc-bin
|
||||
ahc-pkg
|
||||
ghc-asterius
|
||||
ghc-boot-asterius
|
||||
ghc-boot-th-asterius
|
||||
ghc-heap-asterius
|
||||
ghci-asterius
|
||||
template-haskell-asterius
|
||||
|
||||
package aeson
|
||||
flags: +cffi
|
||||
|
||||
package binaryen
|
||||
flags: +system-binaryen
|
||||
|
||||
package hashable
|
||||
flags: +random-initial-seed
|
@ -1,85 +0,0 @@
|
||||
FROM debian:sid
|
||||
|
||||
ARG DEBIAN_FRONTEND=noninteractive
|
||||
|
||||
ARG NODE_VER=15.6.0
|
||||
|
||||
ENV \
|
||||
BROWSER=echo \
|
||||
LANG=C.UTF-8 \
|
||||
PATH=/root/.local/bin:${PATH} \
|
||||
WASI_SDK_PATH=/opt/wasi-sdk
|
||||
|
||||
RUN \
|
||||
rm /etc/apt/apt.conf.d/docker-clean && \
|
||||
apt update && \
|
||||
apt full-upgrade -y && \
|
||||
apt install -y \
|
||||
alex \
|
||||
automake \
|
||||
bash-completion \
|
||||
binaryen \
|
||||
build-essential \
|
||||
c2hs \
|
||||
cpphs \
|
||||
curl \
|
||||
direnv \
|
||||
gawk \
|
||||
git \
|
||||
happy \
|
||||
hlint \
|
||||
libffi-dev \
|
||||
libgmp-dev \
|
||||
libncurses-dev \
|
||||
openssh-client \
|
||||
python3-pip \
|
||||
ripgrep \
|
||||
wabt \
|
||||
xdg-utils \
|
||||
zlib1g-dev \
|
||||
zstd && \
|
||||
mkdir -p ${WASI_SDK_PATH} && \
|
||||
(curl -L https://github.com/TerrorJack/wasi-sdk/releases/download/210113/wasi-sdk-12.1g41fa3294474c-linux.tar.gz | tar xz -C ${WASI_SDK_PATH} --strip-components=1) && \
|
||||
apt autoremove --purge -y && \
|
||||
apt clean && \
|
||||
rm -rf -v /var/lib/apt/lists/* && \
|
||||
cp \
|
||||
/etc/skel/.bash_logout \
|
||||
/etc/skel/.bashrc \
|
||||
/etc/skel/.profile \
|
||||
/root
|
||||
|
||||
WORKDIR /root
|
||||
|
||||
COPY . /tmp/asterius
|
||||
|
||||
RUN \
|
||||
(curl https://raw.githubusercontent.com/nvm-sh/nvm/v0.37.2/install.sh | bash) && \
|
||||
bash -i -c "nvm install ${NODE_VER}" && \
|
||||
patch ~/.nvm/versions/node/v${NODE_VER}/lib/node_modules/npm/node_modules/@npmcli/promise-spawn/index.js /tmp/asterius/utils/promise-spawn.patch && \
|
||||
bash -i -c "npm install -g --unsafe-perm=true --allow-root @cloudflare/wrangler webpack webpack-cli" && \
|
||||
mkdir -p ~/.local/bin && \
|
||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64-bin -o ~/.local/bin/stack && \
|
||||
chmod +x ~/.local/bin/stack && \
|
||||
curl http://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz | tar xJ -C ~/.local/bin --wildcards '*/cabal' && \
|
||||
echo "eval \"\$(stack --bash-completion-script stack)\"" >> ~/.bashrc && \
|
||||
echo "eval \"\$(direnv hook bash)\"" >> ~/.bashrc && \
|
||||
pip3 install \
|
||||
recommonmark \
|
||||
sphinx
|
||||
|
||||
RUN \
|
||||
stack --no-terminal update && \
|
||||
stack --no-terminal --resolver lts-16.29 install \
|
||||
brittany \
|
||||
ghcid \
|
||||
ormolu \
|
||||
pretty-show \
|
||||
wai-app-static && \
|
||||
cd /root && \
|
||||
rm -rf -v \
|
||||
/root/.npm \
|
||||
/root/.stack/pantry \
|
||||
/root/.stack/programs/*/*.tar.xz \
|
||||
/tmp/* \
|
||||
/var/tmp/*
|
@ -1,113 +0,0 @@
|
||||
ARG DEBIAN_FRONTEND=noninteractive
|
||||
ARG USERNAME=asterius
|
||||
ARG UID=1000
|
||||
|
||||
FROM debian:sid AS rootless
|
||||
|
||||
ARG DEBIAN_FRONTEND
|
||||
ARG USERNAME
|
||||
ARG UID
|
||||
|
||||
RUN \
|
||||
rm /etc/apt/apt.conf.d/docker-clean && \
|
||||
apt update && \
|
||||
apt full-upgrade -y && \
|
||||
apt install -y \
|
||||
sudo && \
|
||||
apt autoremove --purge -y && \
|
||||
apt clean && \
|
||||
rm -rf -v \
|
||||
/tmp/* \
|
||||
/var/lib/apt/lists/* \
|
||||
/var/tmp/* && \
|
||||
useradd \
|
||||
--create-home \
|
||||
--shell /bin/bash \
|
||||
--uid ${UID} \
|
||||
${USERNAME} && \
|
||||
echo "${USERNAME} ALL=(ALL) NOPASSWD:ALL" > /etc/sudoers.d/${USERNAME} && \
|
||||
chmod 0440 /etc/sudoers.d/${USERNAME}
|
||||
|
||||
USER ${USERNAME}
|
||||
|
||||
WORKDIR /home/${USERNAME}
|
||||
|
||||
FROM rootless
|
||||
|
||||
ARG DEBIAN_FRONTEND
|
||||
ARG USERNAME
|
||||
ARG UID
|
||||
|
||||
ARG NODE_VER=15.6.0
|
||||
|
||||
ENV \
|
||||
BROWSER=echo \
|
||||
LANG=C.UTF-8 \
|
||||
PATH=/home/${USERNAME}/.local/bin:${PATH} \
|
||||
WASI_SDK_PATH=/opt/wasi-sdk
|
||||
|
||||
RUN \
|
||||
sudo apt update && \
|
||||
sudo apt full-upgrade -y && \
|
||||
sudo apt install -y \
|
||||
alex \
|
||||
automake \
|
||||
bash-completion \
|
||||
binaryen \
|
||||
build-essential \
|
||||
c2hs \
|
||||
cpphs \
|
||||
curl \
|
||||
direnv \
|
||||
gawk \
|
||||
git \
|
||||
happy \
|
||||
hlint \
|
||||
libffi-dev \
|
||||
libgmp-dev \
|
||||
libncurses-dev \
|
||||
openssh-client \
|
||||
python3-pip \
|
||||
ripgrep \
|
||||
wabt \
|
||||
xdg-utils \
|
||||
zlib1g-dev \
|
||||
zstd && \
|
||||
sudo mkdir -p ${WASI_SDK_PATH} && \
|
||||
(curl -L https://github.com/TerrorJack/wasi-sdk/releases/download/210113/wasi-sdk-12.1g41fa3294474c-linux.tar.gz | sudo tar xz -C ${WASI_SDK_PATH} --strip-components=1) && \
|
||||
sudo apt autoremove --purge -y && \
|
||||
sudo apt clean && \
|
||||
sudo rm -rf -v \
|
||||
/tmp/* \
|
||||
/var/lib/apt/lists/* \
|
||||
/var/tmp/*
|
||||
|
||||
RUN \
|
||||
(curl https://raw.githubusercontent.com/nvm-sh/nvm/v0.37.2/install.sh | bash) && \
|
||||
bash -i -c "nvm install ${NODE_VER}" && \
|
||||
bash -i -c "npm install -g @cloudflare/wrangler webpack webpack-cli" && \
|
||||
mkdir -p ~/.local/bin && \
|
||||
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64-bin -o ~/.local/bin/stack && \
|
||||
chmod +x ~/.local/bin/stack && \
|
||||
curl http://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz | tar xJ -C ~/.local/bin --wildcards '*/cabal' && \
|
||||
echo "eval \"\$(stack --bash-completion-script stack)\"" >> ~/.bashrc && \
|
||||
echo "eval \"\$(direnv hook bash)\"" >> ~/.bashrc && \
|
||||
pip3 install \
|
||||
recommonmark \
|
||||
sphinx
|
||||
|
||||
RUN \
|
||||
stack --no-terminal update && \
|
||||
stack --no-terminal --resolver lts-16.29 install \
|
||||
brittany \
|
||||
ghcid \
|
||||
ormolu \
|
||||
pretty-show \
|
||||
wai-app-static && \
|
||||
cd ~ && \
|
||||
sudo rm -rf -v \
|
||||
~/.npm \
|
||||
~/.stack/pantry \
|
||||
~/.stack/programs/*/*.tar.xz \
|
||||
/tmp/* \
|
||||
/var/tmp/*
|
@ -23,7 +23,7 @@ needed in the local environment:
|
||||
* `node`, `npm` (at least `v12`)
|
||||
* `python3`
|
||||
* `stack`
|
||||
* `wasi-sdk` (the `WASI_SDK_PATH` environment variable must point to the
|
||||
* `wasi-sdk` (the `WASI_SDK_PREFIX` environment variable must point to the
|
||||
installation)
|
||||
|
||||
### Preparing the source tree
|
||||
|
@ -73,6 +73,70 @@ sync and also useful to regular Haskell developers.
|
||||
|
||||
## Quarterly roadmap
|
||||
|
||||
### 2021 Q3
|
||||
|
||||
For the past months before this update, I took a break from the Asterius project
|
||||
and worked on a client project instead. There's a saying "less is more", and I
|
||||
believe my absense in this project for a few months is beneficial in multiple
|
||||
ways:
|
||||
|
||||
- I gained a lot more nix-related knowledge.
|
||||
- Purging the short-term memory on the project and coming back, this gives me
|
||||
some insight on the difficulties of onboarding new contributors.
|
||||
- After all, it was a great mental relief to work on something which I was
|
||||
definitely not a bottleneck of the whole project.
|
||||
|
||||
Before I took the break, Asterius was stuck with a very complex & ad-hoc build
|
||||
system, and it was based on ghc-8.8. The most production-ready major version of
|
||||
ghc is ghc-8.10 today. Therefore, Q3 goals and roadmap has been adjusted
|
||||
accordingly:
|
||||
|
||||
- Upgrade Asterius to use ghc-8.10. The upgrade procedure should be principled &
|
||||
documented, so someone else can repeat this when Asterius upgrades to ghc-9.2
|
||||
in the future.
|
||||
- Use cabal & nix as the primary build system.
|
||||
|
||||
What has been achieved so far:
|
||||
|
||||
- There is a new ghc fork dedicated for asterius at
|
||||
https://github.com/tweag/ghc-asterius. It's based on `ghc-8.10` branch, the
|
||||
previous asterius-specific patches have all been ported, and I implemented
|
||||
nix-based logic to generate cabal-buildable ghc api packages to be used by
|
||||
Asterius, replacing the previous ad-hoc python script.
|
||||
- There is a WIP branch of ghc-8.10 & nix support at
|
||||
https://github.com/tweag/asterius/pull/860. Most build errors in the host
|
||||
compiler have been fixed, and the booting logic will be fixed next.
|
||||
- A wasi-sdk/wasi-libc fork is also maintained in the tweag namespace. It's
|
||||
possible to configure our ghc fork with `wasm32-unknown-wasi` triple now, so
|
||||
that's a good start for future work of proper transition of Asterius to a
|
||||
wasi32 backend of ghc.
|
||||
|
||||
Remaining work of Q3 will be wrapping up #860 and merging it to `master`.
|
||||
|
||||
Beyond Q3, the overall plan is also guided by the "less is more" principle: to
|
||||
reduce code rather than to add, leveraging upstream logic whenever possible,
|
||||
while still maintaing and even improving end-user experience. Many hacks were
|
||||
needed in the past due to various reasons, and after all the lessons learned
|
||||
along the way, there are many things that should be shaved off:
|
||||
|
||||
- The hacks related to 64-bit virtual address space. Reusing host GHC API which
|
||||
targets 64-bit platform for Asterius was the easiest way to get the MVP
|
||||
working, but given we have much better knowledge about how cross-compiling in
|
||||
ghc works, these hacks needs to go away.
|
||||
- Custom object format and linking logic. This was required since Asterius
|
||||
needed to record a lot of Haskell-specific info in the object files: JSFFI
|
||||
imports/exports, static pointer table, etc. However, with runtime support,
|
||||
these custom info can all be replaced by vanilla data sections in the wasm or
|
||||
llvm bitcode object files.
|
||||
- Following the entry above, most of the existing wasm codegen logic. It looks
|
||||
possible to leverage the llvm codegen, only adding specific patches to support
|
||||
features like JSFFI.
|
||||
- Most of the existing JavaScript runtime. They will be gradually replaced by
|
||||
cross-compiled ghc rts for the wasi32 target, component after component. The
|
||||
ultimate goal is to support generating self-contained JavaScript-less wasm
|
||||
modules which work in runtimes beyond browsers/nodejs (that's why we stick to
|
||||
`wasi-sdk` instead of `emscripten` in the first place).
|
||||
|
||||
### 2021 Q1
|
||||
|
||||
In 2020 Q4 we mainly delivered:
|
||||
|
@ -1,12 +0,0 @@
|
||||
Simon Marlow <marlowsd@gmail.com>, simonmar, simonmar@microsoft.com
|
||||
Ross Paterson <ross@soi.city.ac.uk>, ross
|
||||
Sven Panne <sven.panne@aedion.de>, panne
|
||||
Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>, malcolm
|
||||
Simon Peyton Jones <simonpj@microsoft.com>, simonpj
|
||||
Don Stewart <dons@galois.com>, dons
|
||||
Tim Harris <tharris@microsoft.com>, tharris
|
||||
Lennart Augustsson <lennart@augustsson.net>, lennart.augustsson@credit-suisse.com
|
||||
Duncan Coutts <duncan@haskell.org>, duncan.coutts@worc.ox.ac.uk, duncan@well-typed.com
|
||||
Ben Lippmeier <benl@ouroborus.net>, benl@cse.unsw.edu.au, Ben.Lippmeier@anu.edu.au
|
||||
Manuel M T Chakravarty <chak@cse.unsw.edu.au>, chak
|
||||
Jose Pedro Magalhaes <jpm@cs.uu.nl>, jpm@cs.uu.nl
|
22
ghc-toolkit/boot-libs/base/.gitignore
vendored
22
ghc-toolkit/boot-libs/base/.gitignore
vendored
@ -1,22 +0,0 @@
|
||||
*.o
|
||||
*.aux
|
||||
*.hi
|
||||
*.tix
|
||||
*.exe
|
||||
|
||||
# Backup files
|
||||
*~
|
||||
|
||||
# Specific generated files
|
||||
/GNUmakefile
|
||||
/autom4te.cache/
|
||||
/base.buildinfo
|
||||
/config.log
|
||||
/config.status
|
||||
/configure
|
||||
/dist-install/
|
||||
/ghc.mk
|
||||
/include/EventConfig.h
|
||||
/include/HsBaseConfig.h
|
||||
/include/HsBaseConfig.h.in
|
||||
|
@ -1,22 +0,0 @@
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE UnboxedTuples #-}
|
||||
|
||||
module Asterius.Magic
|
||||
( accursedUnutterablePerformIO,
|
||||
unIO,
|
||||
)
|
||||
where
|
||||
|
||||
import GHC.Magic
|
||||
import GHC.Prim
|
||||
import GHC.Types
|
||||
|
||||
{-# INLINE accursedUnutterablePerformIO #-}
|
||||
accursedUnutterablePerformIO :: IO a -> a
|
||||
accursedUnutterablePerformIO (IO m) = case runRW# m of
|
||||
(# _, a #) -> a
|
||||
|
||||
{-# INLINE unIO #-}
|
||||
unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #)
|
||||
unIO (IO m) = m
|
@ -1,41 +0,0 @@
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE UnliftedFFITypes #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.TopHandler
|
||||
( runIO,
|
||||
runNonIO,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Types.JSString
|
||||
import Control.Exception.Base
|
||||
import GHC.Base
|
||||
import GHC.Conc.Sync
|
||||
import GHC.Show
|
||||
import GHC.TopHandler (flushStdHandles)
|
||||
|
||||
runIO :: IO a -> IO a
|
||||
runIO m = flip finally flushStdHandles $ handle topHandler $ do
|
||||
setUncaughtExceptionHandler reportException
|
||||
m
|
||||
|
||||
runNonIO :: a -> IO a
|
||||
runNonIO = runIO . evaluate
|
||||
|
||||
{-# INLINE topHandler #-}
|
||||
topHandler :: SomeException -> IO a
|
||||
topHandler err = do
|
||||
reportException err
|
||||
throwIO err
|
||||
|
||||
reportException :: SomeException -> IO ()
|
||||
reportException err = handle reportException $ do
|
||||
ThreadId tid# <- myThreadId
|
||||
s <- evaluate $ toJSString $ show err
|
||||
c_tsoReportException tid# s
|
||||
|
||||
foreign import ccall unsafe "tsoReportException"
|
||||
c_tsoReportException ::
|
||||
ThreadId# -> JSString -> IO ()
|
@ -1,33 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types
|
||||
( JSVal,
|
||||
freeJSVal,
|
||||
JSArray (..),
|
||||
fromJSArray,
|
||||
toJSArray,
|
||||
JSFunction (..),
|
||||
freeHaskellCallback,
|
||||
JSObject (..),
|
||||
indexJSObject,
|
||||
setJSObject,
|
||||
JSString (..),
|
||||
lengthOfJSString,
|
||||
fromJSString,
|
||||
toJSString,
|
||||
JSUint8Array (..),
|
||||
lengthOfJSUint8Array,
|
||||
fromJSUint8Array,
|
||||
toJSUint8Array,
|
||||
unsafeToJSUint8Array,
|
||||
JSException (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Types.JSArray
|
||||
import Asterius.Types.JSException
|
||||
import Asterius.Types.JSFunction
|
||||
import Asterius.Types.JSObject
|
||||
import Asterius.Types.JSString
|
||||
import Asterius.Types.JSUint8Array
|
||||
import Asterius.Types.JSVal
|
@ -1,57 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types.JSArray
|
||||
( JSArray (..),
|
||||
fromJSArray,
|
||||
toJSArray,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Magic
|
||||
import Asterius.Types.JSString ()
|
||||
import Asterius.Types.JSVal
|
||||
import GHC.Base
|
||||
import GHC.Enum
|
||||
import GHC.Show
|
||||
|
||||
newtype JSArray
|
||||
= JSArray JSVal
|
||||
deriving (Show)
|
||||
|
||||
{-# INLINEABLE fromJSArray #-}
|
||||
fromJSArray :: JSArray -> [JSVal]
|
||||
fromJSArray arr = w 0
|
||||
where
|
||||
len = js_arr_len arr
|
||||
w i
|
||||
| i < len = js_arr_idx arr i : w (succ i)
|
||||
| otherwise = []
|
||||
|
||||
{-# INLINEABLE toJSArray #-}
|
||||
toJSArray :: [JSVal] -> JSArray
|
||||
toJSArray l = accursedUnutterablePerformIO $ do
|
||||
arr <- js_arr_new
|
||||
let w (v : vs) = js_arr_push arr v *> w vs
|
||||
w [] = pure ()
|
||||
in w l
|
||||
pure arr
|
||||
|
||||
instance Eq JSArray where
|
||||
{-# INLINE (==) #-}
|
||||
arr0@(JSArray v0) == arr1@(JSArray v1)
|
||||
| v0 == v1 = True
|
||||
| otherwise = fromJSArray arr0 == fromJSArray arr1
|
||||
|
||||
instance Ord JSArray where
|
||||
{-# INLINE (<=) #-}
|
||||
arr0@(JSArray v0) <= arr1@(JSArray v1)
|
||||
| v0 == v1 = True
|
||||
| otherwise = fromJSArray arr0 <= fromJSArray arr1
|
||||
|
||||
foreign import javascript unsafe "$1.length" js_arr_len :: JSArray -> Int
|
||||
|
||||
foreign import javascript unsafe "$1[$2]" js_arr_idx :: JSArray -> Int -> JSVal
|
||||
|
||||
foreign import javascript unsafe "[]" js_arr_new :: IO JSArray
|
||||
|
||||
foreign import javascript unsafe "$1.push($2)" js_arr_push :: JSArray -> JSVal -> IO ()
|
@ -1,28 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types.JSException
|
||||
( JSException (..),
|
||||
mkJSException,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Types.JSString
|
||||
import Asterius.Types.JSVal
|
||||
import GHC.Base
|
||||
import GHC.Exception.Type
|
||||
import GHC.Show
|
||||
|
||||
data JSException
|
||||
= JSException !JSVal String
|
||||
|
||||
instance Show JSException where
|
||||
show (JSException _ msg) = "JSException " <> show msg
|
||||
|
||||
instance Exception JSException
|
||||
|
||||
mkJSException :: JSVal -> SomeException
|
||||
mkJSException v =
|
||||
toException (JSException v (fromJSString (js_show_err v)))
|
||||
|
||||
foreign import javascript unsafe "$1.stack ? $1.stack : `${$1}`"
|
||||
js_show_err :: JSVal -> JSString
|
@ -1,19 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types.JSFunction
|
||||
( JSFunction (..),
|
||||
freeHaskellCallback,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Types.JSString ()
|
||||
import Asterius.Types.JSVal
|
||||
import GHC.Base
|
||||
import GHC.Show
|
||||
|
||||
newtype JSFunction
|
||||
= JSFunction JSVal
|
||||
deriving (Show)
|
||||
|
||||
foreign import ccall unsafe "freeHaskellCallback"
|
||||
freeHaskellCallback :: JSFunction -> IO ()
|
@ -1,31 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types.JSObject
|
||||
( JSObject (..),
|
||||
indexJSObject,
|
||||
setJSObject,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Types.JSString
|
||||
import Asterius.Types.JSVal
|
||||
import GHC.Base
|
||||
import GHC.Show
|
||||
|
||||
newtype JSObject
|
||||
= JSObject JSVal
|
||||
deriving (Show)
|
||||
|
||||
{-# INLINE indexJSObject #-}
|
||||
indexJSObject :: JSObject -> String -> IO JSVal
|
||||
indexJSObject obj k = js_object_index obj (toJSString k)
|
||||
|
||||
{-# INLINE setJSObject #-}
|
||||
setJSObject :: JSObject -> String -> JSVal -> IO ()
|
||||
setJSObject obj k = js_object_set obj (toJSString k)
|
||||
|
||||
foreign import javascript unsafe "$1[$2]"
|
||||
js_object_index :: JSObject -> JSString -> IO JSVal
|
||||
|
||||
foreign import javascript unsafe "$1[$2] = $3"
|
||||
js_object_set :: JSObject -> JSString -> JSVal -> IO ()
|
@ -1,77 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Asterius.Types.JSString
|
||||
( JSString (..),
|
||||
lengthOfJSString,
|
||||
fromJSString,
|
||||
toJSString,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Magic
|
||||
import Asterius.Types.JSVal
|
||||
import Data.Functor
|
||||
import Data.String
|
||||
import GHC.Base
|
||||
import GHC.Enum
|
||||
import GHC.Read
|
||||
import GHC.Show
|
||||
|
||||
newtype JSString = JSString JSVal
|
||||
deriving (Eq, Ord)
|
||||
|
||||
{-# INLINEABLE fromJSString #-}
|
||||
fromJSString :: JSString -> String
|
||||
fromJSString s = accursedUnutterablePerformIO $ do
|
||||
it <- js_fromJSString_iterator s
|
||||
let w = do
|
||||
c <- js_fromJSString_iterator_next it
|
||||
case c of
|
||||
'\0' -> do
|
||||
freeJSVal it
|
||||
pure []
|
||||
_ -> pure (pred c : accursedUnutterablePerformIO w)
|
||||
in w
|
||||
|
||||
instance Show JSString where
|
||||
{-# INLINE showsPrec #-}
|
||||
showsPrec p = showsPrec p . fromJSString
|
||||
|
||||
instance Show JSVal where
|
||||
{-# INLINE show #-}
|
||||
show = fromJSString . js_showJSVal
|
||||
|
||||
{-# INLINEABLE toJSString #-}
|
||||
toJSString :: String -> JSString
|
||||
toJSString s = accursedUnutterablePerformIO $ do
|
||||
ctx <- js_toJSString_context_new
|
||||
let w (c : cs) = js_toJSString_context_push ctx c *> w cs
|
||||
w [] = pure ()
|
||||
in w s
|
||||
r <- js_toJSString_context_result ctx
|
||||
freeJSVal ctx
|
||||
pure r
|
||||
|
||||
instance IsString JSString where
|
||||
{-# INLINE fromString #-}
|
||||
fromString = toJSString
|
||||
|
||||
instance Read JSString where
|
||||
{-# INLINE readPrec #-}
|
||||
readPrec = fmap toJSString readPrec
|
||||
|
||||
foreign import javascript unsafe "$1.length"
|
||||
lengthOfJSString :: JSString -> Int
|
||||
|
||||
foreign import javascript unsafe "`${$1}`" js_showJSVal :: JSVal -> JSString
|
||||
|
||||
foreign import javascript unsafe "$1[Symbol.iterator]()" js_fromJSString_iterator :: JSString -> IO JSVal
|
||||
|
||||
foreign import javascript unsafe "(() => { const r = $1.next(); return r.done ? 0 : (1 + r.value.codePointAt(0)); })()" js_fromJSString_iterator_next :: JSVal -> IO Char
|
||||
|
||||
foreign import javascript unsafe "['']" js_toJSString_context_new :: IO JSVal
|
||||
|
||||
foreign import javascript unsafe "$1[0] += String.fromCodePoint($2)" js_toJSString_context_push :: JSVal -> Char -> IO ()
|
||||
|
||||
foreign import javascript unsafe "$1[0]" js_toJSString_context_result :: JSVal -> IO JSString
|
@ -1,40 +0,0 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types.JSUint8Array
|
||||
( JSUint8Array (..),
|
||||
lengthOfJSUint8Array,
|
||||
fromJSUint8Array,
|
||||
toJSUint8Array,
|
||||
unsafeToJSUint8Array,
|
||||
)
|
||||
where
|
||||
|
||||
import Asterius.Types.JSString ()
|
||||
import Asterius.Types.JSVal
|
||||
import Foreign.ForeignPtr
|
||||
import GHC.Base
|
||||
import GHC.ForeignPtr
|
||||
import GHC.Ptr
|
||||
import GHC.Show
|
||||
|
||||
newtype JSUint8Array = JSUint8Array JSVal deriving (Show)
|
||||
|
||||
{-# INLINEABLE fromJSUint8Array #-}
|
||||
fromJSUint8Array :: JSUint8Array -> IO (ForeignPtr a)
|
||||
fromJSUint8Array src = do
|
||||
len <- lengthOfJSUint8Array src
|
||||
r <- mallocPlainForeignPtrBytes len
|
||||
withForeignPtr r $ \p -> js_loadUint8Array p len src
|
||||
pure r
|
||||
|
||||
foreign import javascript unsafe "$1.length"
|
||||
lengthOfJSUint8Array :: JSUint8Array -> IO Int
|
||||
|
||||
foreign import javascript unsafe "__asterius_jsffi.exposeMemory($1,$2)"
|
||||
unsafeToJSUint8Array :: Ptr a -> Int -> IO JSUint8Array
|
||||
|
||||
foreign import javascript unsafe "new Uint8Array(__asterius_jsffi.exposeMemory($1,$2))"
|
||||
toJSUint8Array :: Ptr a -> Int -> IO JSUint8Array
|
||||
|
||||
foreign import javascript unsafe "__asterius_jsffi.exposeMemory($1,$2).set($3)"
|
||||
js_loadUint8Array :: Ptr a -> Int -> JSUint8Array -> IO ()
|
@ -1,35 +0,0 @@
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE UnliftedFFITypes #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Asterius.Types.JSVal
|
||||
( JSVal (..),
|
||||
freeJSVal,
|
||||
)
|
||||
where
|
||||
|
||||
import GHC.Base
|
||||
import GHC.Exts
|
||||
|
||||
type JSVal# = StableName# ()
|
||||
|
||||
data JSVal
|
||||
= JSVal JSVal#
|
||||
|
||||
instance Eq JSVal where
|
||||
{-# INLINE (==) #-}
|
||||
(==) = js_eqJSVal
|
||||
|
||||
instance Ord JSVal where
|
||||
{-# INLINE (<=) #-}
|
||||
(<=) = js_leJSVal
|
||||
|
||||
{-# INLINE freeJSVal #-}
|
||||
freeJSVal :: JSVal -> IO ()
|
||||
freeJSVal (JSVal sn) = js_freeJSVal sn
|
||||
|
||||
foreign import javascript unsafe "__asterius_jsffi.freeJSValzh($1)" js_freeJSVal :: JSVal# -> IO ()
|
||||
|
||||
foreign import javascript unsafe "$1 === $2" js_eqJSVal :: JSVal -> JSVal -> Bool
|
||||
|
||||
foreign import javascript unsafe "$1 <= $2" js_leJSVal :: JSVal -> JSVal -> Bool
|
@ -1,145 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Applicative
|
||||
-- Copyright : Conor McBride and Ross Paterson 2005
|
||||
-- License : BSD-style (see the LICENSE file in the distribution)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- This module describes a structure intermediate between a functor and
|
||||
-- a monad (technically, a strong lax monoidal functor). Compared with
|
||||
-- monads, this interface lacks the full power of the binding operation
|
||||
-- '>>=', but
|
||||
--
|
||||
-- * it has more instances.
|
||||
--
|
||||
-- * it is sufficient for many uses, e.g. context-free parsing, or the
|
||||
-- 'Data.Traversable.Traversable' class.
|
||||
--
|
||||
-- * instances can perform analysis of computations before they are
|
||||
-- executed, and thus produce shared optimizations.
|
||||
--
|
||||
-- This interface was introduced for parsers by Niklas Röjemo, because
|
||||
-- it admits more sharing than the monadic interface. The names here are
|
||||
-- mostly based on parsing work by Doaitse Swierstra.
|
||||
--
|
||||
-- For more details, see
|
||||
-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,
|
||||
-- by Conor McBride and Ross Paterson.
|
||||
|
||||
module Control.Applicative (
|
||||
-- * Applicative functors
|
||||
Applicative(..),
|
||||
-- * Alternatives
|
||||
Alternative(..),
|
||||
-- * Instances
|
||||
Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
|
||||
-- * Utility functions
|
||||
(<$>), (<$), (<**>),
|
||||
liftA, liftA3,
|
||||
optional,
|
||||
) where
|
||||
|
||||
import Control.Category hiding ((.), id)
|
||||
import Control.Arrow
|
||||
import Data.Maybe
|
||||
import Data.Tuple
|
||||
import Data.Eq
|
||||
import Data.Ord
|
||||
import Data.Foldable (Foldable(..))
|
||||
import Data.Functor ((<$>))
|
||||
import Data.Functor.Const (Const(..))
|
||||
|
||||
import GHC.Base
|
||||
import GHC.Generics
|
||||
import GHC.List (repeat, zipWith, drop)
|
||||
import GHC.Read (Read)
|
||||
import GHC.Show (Show)
|
||||
|
||||
newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
|
||||
deriving ( Generic -- ^ @since 4.7.0.0
|
||||
, Generic1 -- ^ @since 4.7.0.0
|
||||
, Monad -- ^ @since 4.7.0.0
|
||||
)
|
||||
|
||||
-- | @since 2.01
|
||||
instance Monad m => Functor (WrappedMonad m) where
|
||||
fmap f (WrapMonad v) = WrapMonad (liftM f v)
|
||||
|
||||
-- | @since 2.01
|
||||
instance Monad m => Applicative (WrappedMonad m) where
|
||||
pure = WrapMonad . pure
|
||||
WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
|
||||
liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y)
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadPlus m => Alternative (WrappedMonad m) where
|
||||
empty = WrapMonad mzero
|
||||
WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)
|
||||
|
||||
newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }
|
||||
deriving ( Generic -- ^ @since 4.7.0.0
|
||||
, Generic1 -- ^ @since 4.7.0.0
|
||||
)
|
||||
|
||||
-- | @since 2.01
|
||||
instance Arrow a => Functor (WrappedArrow a b) where
|
||||
fmap f (WrapArrow a) = WrapArrow (a >>> arr f)
|
||||
|
||||
-- | @since 2.01
|
||||
instance Arrow a => Applicative (WrappedArrow a b) where
|
||||
pure x = WrapArrow (arr (const x))
|
||||
liftA2 f (WrapArrow u) (WrapArrow v) =
|
||||
WrapArrow (u &&& v >>> arr (uncurry f))
|
||||
|
||||
-- | @since 2.01
|
||||
instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
|
||||
empty = WrapArrow zeroArrow
|
||||
WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
|
||||
|
||||
-- | Lists, but with an 'Applicative' functor based on zipping.
|
||||
newtype ZipList a = ZipList { getZipList :: [a] }
|
||||
deriving ( Show -- ^ @since 4.7.0.0
|
||||
, Eq -- ^ @since 4.7.0.0
|
||||
, Ord -- ^ @since 4.7.0.0
|
||||
, Read -- ^ @since 4.7.0.0
|
||||
, Functor -- ^ @since 2.01
|
||||
, Foldable -- ^ @since 4.9.0.0
|
||||
, Generic -- ^ @since 4.7.0.0
|
||||
, Generic1 -- ^ @since 4.7.0.0
|
||||
)
|
||||
-- See Data.Traversable for Traversable instance due to import loops
|
||||
|
||||
-- |
|
||||
-- > f <$> ZipList xs1 <*> ... <*> ZipList xsN
|
||||
-- > = ZipList (zipWithN f xs1 ... xsN)
|
||||
--
|
||||
-- where @zipWithN@ refers to the @zipWith@ function of the appropriate arity
|
||||
-- (@zipWith@, @zipWith3@, @zipWith4@, ...). For example:
|
||||
--
|
||||
-- > (\a b c -> stimes c [a, b]) <$> ZipList "abcd" <*> ZipList "567" <*> ZipList [1..]
|
||||
-- > = ZipList (zipWith3 (\a b c -> stimes c [a, b]) "abcd" "567" [1..])
|
||||
-- > = ZipList {getZipList = ["a5","b6b6","c7c7c7"]}
|
||||
--
|
||||
-- @since 2.01
|
||||
instance Applicative ZipList where
|
||||
pure x = ZipList (repeat x)
|
||||
liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)
|
||||
|
||||
-- | @since 4.11.0.0
|
||||
instance Alternative ZipList where
|
||||
empty = ZipList []
|
||||
ZipList xs <|> ZipList ys = ZipList (xs ++ drop (length xs) ys)
|
||||
|
||||
-- extra functions
|
||||
|
||||
-- | One or none.
|
||||
optional :: Alternative f => f a -> f (Maybe a)
|
||||
optional v = Just <$> v <|> pure Nothing
|
@ -1,389 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
|
||||
-- The RULES for the methods of class Arrow may never fire
|
||||
-- e.g. compose/arr; see Trac #10528
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Arrow
|
||||
-- Copyright : (c) Ross Paterson 2002
|
||||
-- License : BSD-style (see the LICENSE file in the distribution)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Basic arrow definitions, based on
|
||||
--
|
||||
-- * /Generalising Monads to Arrows/, by John Hughes,
|
||||
-- /Science of Computer Programming/ 37, pp67-111, May 2000.
|
||||
--
|
||||
-- plus a couple of definitions ('returnA' and 'loop') from
|
||||
--
|
||||
-- * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
|
||||
-- Firenze, Italy, pp229-240.
|
||||
--
|
||||
-- These papers and more information on arrows can be found at
|
||||
-- <http://www.haskell.org/arrows/>.
|
||||
|
||||
module Control.Arrow (
|
||||
-- * Arrows
|
||||
Arrow(..), Kleisli(..),
|
||||
-- ** Derived combinators
|
||||
returnA,
|
||||
(^>>), (>>^),
|
||||
(>>>), (<<<), -- reexported
|
||||
-- ** Right-to-left variants
|
||||
(<<^), (^<<),
|
||||
-- * Monoid operations
|
||||
ArrowZero(..), ArrowPlus(..),
|
||||
-- * Conditionals
|
||||
ArrowChoice(..),
|
||||
-- * Arrow application
|
||||
ArrowApply(..), ArrowMonad(..), leftApp,
|
||||
-- * Feedback
|
||||
ArrowLoop(..)
|
||||
) where
|
||||
|
||||
import Data.Tuple ( fst, snd, uncurry )
|
||||
import Data.Either
|
||||
import Control.Monad.Fix
|
||||
import Control.Category
|
||||
import GHC.Base hiding ( (.), id )
|
||||
|
||||
infixr 5 <+>
|
||||
infixr 3 ***
|
||||
infixr 3 &&&
|
||||
infixr 2 +++
|
||||
infixr 2 |||
|
||||
infixr 1 ^>>, >>^
|
||||
infixr 1 ^<<, <<^
|
||||
|
||||
-- | The basic arrow class.
|
||||
--
|
||||
-- Instances should satisfy the following laws:
|
||||
--
|
||||
-- * @'arr' id = 'id'@
|
||||
--
|
||||
-- * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@
|
||||
--
|
||||
-- * @'first' ('arr' f) = 'arr' ('first' f)@
|
||||
--
|
||||
-- * @'first' (f >>> g) = 'first' f >>> 'first' g@
|
||||
--
|
||||
-- * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@
|
||||
--
|
||||
-- * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@
|
||||
--
|
||||
-- * @'first' ('first' f) >>> 'arr' assoc = 'arr' assoc >>> 'first' f@
|
||||
--
|
||||
-- where
|
||||
--
|
||||
-- > assoc ((a,b),c) = (a,(b,c))
|
||||
--
|
||||
-- The other combinators have sensible default definitions,
|
||||
-- which may be overridden for efficiency.
|
||||
|
||||
class Category a => Arrow a where
|
||||
{-# MINIMAL arr, (first | (***)) #-}
|
||||
|
||||
-- | Lift a function to an arrow.
|
||||
arr :: (b -> c) -> a b c
|
||||
|
||||
-- | Send the first component of the input through the argument
|
||||
-- arrow, and copy the rest unchanged to the output.
|
||||
first :: a b c -> a (b,d) (c,d)
|
||||
first = (*** id)
|
||||
|
||||
-- | A mirror image of 'first'.
|
||||
--
|
||||
-- The default definition may be overridden with a more efficient
|
||||
-- version if desired.
|
||||
second :: a b c -> a (d,b) (d,c)
|
||||
second = (id ***)
|
||||
|
||||
-- | Split the input between the two argument arrows and combine
|
||||
-- their output. Note that this is in general not a functor.
|
||||
--
|
||||
-- The default definition may be overridden with a more efficient
|
||||
-- version if desired.
|
||||
(***) :: a b c -> a b' c' -> a (b,b') (c,c')
|
||||
f *** g = first f >>> arr swap >>> first g >>> arr swap
|
||||
where swap ~(x,y) = (y,x)
|
||||
|
||||
-- | Fanout: send the input to both argument arrows and combine
|
||||
-- their output.
|
||||
--
|
||||
-- The default definition may be overridden with a more efficient
|
||||
-- version if desired.
|
||||
(&&&) :: a b c -> a b c' -> a b (c,c')
|
||||
f &&& g = arr (\b -> (b,b)) >>> f *** g
|
||||
|
||||
{-# RULES
|
||||
"compose/arr" forall f g .
|
||||
(arr f) . (arr g) = arr (f . g)
|
||||
"first/arr" forall f .
|
||||
first (arr f) = arr (first f)
|
||||
"second/arr" forall f .
|
||||
second (arr f) = arr (second f)
|
||||
"product/arr" forall f g .
|
||||
arr f *** arr g = arr (f *** g)
|
||||
"fanout/arr" forall f g .
|
||||
arr f &&& arr g = arr (f &&& g)
|
||||
"compose/first" forall f g .
|
||||
(first f) . (first g) = first (f . g)
|
||||
"compose/second" forall f g .
|
||||
(second f) . (second g) = second (f . g)
|
||||
#-}
|
||||
|
||||
-- Ordinary functions are arrows.
|
||||
|
||||
-- | @since 2.01
|
||||
instance Arrow (->) where
|
||||
arr f = f
|
||||
-- (f *** g) ~(x,y) = (f x, g y)
|
||||
-- sorry, although the above defn is fully H'98, nhc98 can't parse it.
|
||||
(***) f g ~(x,y) = (f x, g y)
|
||||
|
||||
-- | Kleisli arrows of a monad.
|
||||
newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
|
||||
|
||||
-- | @since 3.0
|
||||
instance Monad m => Category (Kleisli m) where
|
||||
id = Kleisli return
|
||||
(Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)
|
||||
|
||||
-- | @since 2.01
|
||||
instance Monad m => Arrow (Kleisli m) where
|
||||
arr f = Kleisli (return . f)
|
||||
first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d))
|
||||
second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))
|
||||
|
||||
-- | The identity arrow, which plays the role of 'return' in arrow notation.
|
||||
returnA :: Arrow a => a b b
|
||||
returnA = arr id
|
||||
|
||||
-- | Precomposition with a pure function.
|
||||
(^>>) :: Arrow a => (b -> c) -> a c d -> a b d
|
||||
f ^>> a = arr f >>> a
|
||||
|
||||
-- | Postcomposition with a pure function.
|
||||
(>>^) :: Arrow a => a b c -> (c -> d) -> a b d
|
||||
a >>^ f = a >>> arr f
|
||||
|
||||
-- | Precomposition with a pure function (right-to-left variant).
|
||||
(<<^) :: Arrow a => a c d -> (b -> c) -> a b d
|
||||
a <<^ f = a <<< arr f
|
||||
|
||||
-- | Postcomposition with a pure function (right-to-left variant).
|
||||
(^<<) :: Arrow a => (c -> d) -> a b c -> a b d
|
||||
f ^<< a = arr f <<< a
|
||||
|
||||
class Arrow a => ArrowZero a where
|
||||
zeroArrow :: a b c
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadPlus m => ArrowZero (Kleisli m) where
|
||||
zeroArrow = Kleisli (\_ -> mzero)
|
||||
|
||||
-- | A monoid on arrows.
|
||||
class ArrowZero a => ArrowPlus a where
|
||||
-- | An associative operation with identity 'zeroArrow'.
|
||||
(<+>) :: a b c -> a b c -> a b c
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadPlus m => ArrowPlus (Kleisli m) where
|
||||
Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)
|
||||
|
||||
-- | Choice, for arrows that support it. This class underlies the
|
||||
-- @if@ and @case@ constructs in arrow notation.
|
||||
--
|
||||
-- Instances should satisfy the following laws:
|
||||
--
|
||||
-- * @'left' ('arr' f) = 'arr' ('left' f)@
|
||||
--
|
||||
-- * @'left' (f >>> g) = 'left' f >>> 'left' g@
|
||||
--
|
||||
-- * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@
|
||||
--
|
||||
-- * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@
|
||||
--
|
||||
-- * @'left' ('left' f) >>> 'arr' assocsum = 'arr' assocsum >>> 'left' f@
|
||||
--
|
||||
-- where
|
||||
--
|
||||
-- > assocsum (Left (Left x)) = Left x
|
||||
-- > assocsum (Left (Right y)) = Right (Left y)
|
||||
-- > assocsum (Right z) = Right (Right z)
|
||||
--
|
||||
-- The other combinators have sensible default definitions, which may
|
||||
-- be overridden for efficiency.
|
||||
|
||||
class Arrow a => ArrowChoice a where
|
||||
{-# MINIMAL (left | (+++)) #-}
|
||||
|
||||
-- | Feed marked inputs through the argument arrow, passing the
|
||||
-- rest through unchanged to the output.
|
||||
left :: a b c -> a (Either b d) (Either c d)
|
||||
left = (+++ id)
|
||||
|
||||
-- | A mirror image of 'left'.
|
||||
--
|
||||
-- The default definition may be overridden with a more efficient
|
||||
-- version if desired.
|
||||
right :: a b c -> a (Either d b) (Either d c)
|
||||
right = (id +++)
|
||||
|
||||
-- | Split the input between the two argument arrows, retagging
|
||||
-- and merging their outputs.
|
||||
-- Note that this is in general not a functor.
|
||||
--
|
||||
-- The default definition may be overridden with a more efficient
|
||||
-- version if desired.
|
||||
(+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')
|
||||
f +++ g = left f >>> arr mirror >>> left g >>> arr mirror
|
||||
where
|
||||
mirror :: Either x y -> Either y x
|
||||
mirror (Left x) = Right x
|
||||
mirror (Right y) = Left y
|
||||
|
||||
-- | Fanin: Split the input between the two argument arrows and
|
||||
-- merge their outputs.
|
||||
--
|
||||
-- The default definition may be overridden with a more efficient
|
||||
-- version if desired.
|
||||
(|||) :: a b d -> a c d -> a (Either b c) d
|
||||
f ||| g = f +++ g >>> arr untag
|
||||
where
|
||||
untag (Left x) = x
|
||||
untag (Right y) = y
|
||||
|
||||
{-# RULES
|
||||
"left/arr" forall f .
|
||||
left (arr f) = arr (left f)
|
||||
"right/arr" forall f .
|
||||
right (arr f) = arr (right f)
|
||||
"sum/arr" forall f g .
|
||||
arr f +++ arr g = arr (f +++ g)
|
||||
"fanin/arr" forall f g .
|
||||
arr f ||| arr g = arr (f ||| g)
|
||||
"compose/left" forall f g .
|
||||
left f . left g = left (f . g)
|
||||
"compose/right" forall f g .
|
||||
right f . right g = right (f . g)
|
||||
#-}
|
||||
|
||||
-- | @since 2.01
|
||||
instance ArrowChoice (->) where
|
||||
left f = f +++ id
|
||||
right f = id +++ f
|
||||
f +++ g = (Left . f) ||| (Right . g)
|
||||
(|||) = either
|
||||
|
||||
-- | @since 2.01
|
||||
instance Monad m => ArrowChoice (Kleisli m) where
|
||||
left f = f +++ arr id
|
||||
right f = arr id +++ f
|
||||
f +++ g = (f >>> arr Left) ||| (g >>> arr Right)
|
||||
Kleisli f ||| Kleisli g = Kleisli (either f g)
|
||||
|
||||
-- | Some arrows allow application of arrow inputs to other inputs.
|
||||
-- Instances should satisfy the following laws:
|
||||
--
|
||||
-- * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@
|
||||
--
|
||||
-- * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@
|
||||
--
|
||||
-- * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@
|
||||
--
|
||||
-- Such arrows are equivalent to monads (see 'ArrowMonad').
|
||||
|
||||
class Arrow a => ArrowApply a where
|
||||
app :: a (a b c, b) c
|
||||
|
||||
-- | @since 2.01
|
||||
instance ArrowApply (->) where
|
||||
app (f,x) = f x
|
||||
|
||||
-- | @since 2.01
|
||||
instance Monad m => ArrowApply (Kleisli m) where
|
||||
app = Kleisli (\(Kleisli f, x) -> f x)
|
||||
|
||||
-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise
|
||||
-- to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.
|
||||
|
||||
newtype ArrowMonad a b = ArrowMonad (a () b)
|
||||
|
||||
-- | @since 4.6.0.0
|
||||
instance Arrow a => Functor (ArrowMonad a) where
|
||||
fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f
|
||||
|
||||
-- | @since 4.6.0.0
|
||||
instance Arrow a => Applicative (ArrowMonad a) where
|
||||
pure x = ArrowMonad (arr (const x))
|
||||
ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
|
||||
|
||||
-- | @since 2.01
|
||||
instance ArrowApply a => Monad (ArrowMonad a) where
|
||||
ArrowMonad m >>= f = ArrowMonad $
|
||||
m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app
|
||||
|
||||
-- | @since 4.6.0.0
|
||||
instance ArrowPlus a => Alternative (ArrowMonad a) where
|
||||
empty = ArrowMonad zeroArrow
|
||||
ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
|
||||
|
||||
-- | @since 4.6.0.0
|
||||
instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a)
|
||||
|
||||
-- | Any instance of 'ArrowApply' can be made into an instance of
|
||||
-- 'ArrowChoice' by defining 'left' = 'leftApp'.
|
||||
|
||||
leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)
|
||||
leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
|
||||
(\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app
|
||||
|
||||
-- | The 'loop' operator expresses computations in which an output value
|
||||
-- is fed back as input, although the computation occurs only once.
|
||||
-- It underlies the @rec@ value recursion construct in arrow notation.
|
||||
-- 'loop' should satisfy the following laws:
|
||||
--
|
||||
-- [/extension/]
|
||||
-- @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@
|
||||
--
|
||||
-- [/left tightening/]
|
||||
-- @'loop' ('first' h >>> f) = h >>> 'loop' f@
|
||||
--
|
||||
-- [/right tightening/]
|
||||
-- @'loop' (f >>> 'first' h) = 'loop' f >>> h@
|
||||
--
|
||||
-- [/sliding/]
|
||||
-- @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@
|
||||
--
|
||||
-- [/vanishing/]
|
||||
-- @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@
|
||||
--
|
||||
-- [/superposing/]
|
||||
-- @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@
|
||||
--
|
||||
-- where
|
||||
--
|
||||
-- > assoc ((a,b),c) = (a,(b,c))
|
||||
-- > unassoc (a,(b,c)) = ((a,b),c)
|
||||
--
|
||||
class Arrow a => ArrowLoop a where
|
||||
loop :: a (b,d) (c,d) -> a b c
|
||||
|
||||
-- | @since 2.01
|
||||
instance ArrowLoop (->) where
|
||||
loop f b = let (c,d) = f (b,d) in c
|
||||
|
||||
-- | Beware that for many monads (those for which the '>>=' operation
|
||||
-- is strict) this instance will /not/ satisfy the right-tightening law
|
||||
-- required by the 'ArrowLoop' class.
|
||||
--
|
||||
-- @since 2.01
|
||||
instance MonadFix m => ArrowLoop (Kleisli m) where
|
||||
loop (Kleisli f) = Kleisli (liftM fst . mfix . f')
|
||||
where f' x y = f (x, snd y)
|
@ -1,79 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
|
||||
-- The RULES for the methods of class Category may never fire
|
||||
-- e.g. identity/left, identity/right, association; see Trac #10528
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Category
|
||||
-- Copyright : (c) Ashley Yakeley 2007
|
||||
-- License : BSD-style (see the LICENSE file in the distribution)
|
||||
--
|
||||
-- Maintainer : ashley@semantic.org
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
|
||||
-- http://ghc.haskell.org/trac/ghc/ticket/1773
|
||||
|
||||
module Control.Category where
|
||||
|
||||
import qualified GHC.Base (id,(.))
|
||||
import Data.Type.Coercion
|
||||
import Data.Type.Equality
|
||||
import GHC.Prim (coerce)
|
||||
|
||||
infixr 9 .
|
||||
infixr 1 >>>, <<<
|
||||
|
||||
-- | A class for categories. Instances should satisfy the laws
|
||||
--
|
||||
-- [Right identity] @f '.' 'id' = f@
|
||||
-- [Left identity] @'id' '.' f = f@
|
||||
-- [Associativity] @f '.' (g '.' h) = (f '.' g) '.' h@
|
||||
--
|
||||
class Category cat where
|
||||
-- | the identity morphism
|
||||
id :: cat a a
|
||||
|
||||
-- | morphism composition
|
||||
(.) :: cat b c -> cat a b -> cat a c
|
||||
|
||||
{-# RULES
|
||||
"identity/left" forall p .
|
||||
id . p = p
|
||||
"identity/right" forall p .
|
||||
p . id = p
|
||||
"association" forall p q r .
|
||||
(p . q) . r = p . (q . r)
|
||||
#-}
|
||||
|
||||
-- | @since 3.0
|
||||
instance Category (->) where
|
||||
id = GHC.Base.id
|
||||
(.) = (GHC.Base..)
|
||||
|
||||
-- | @since 4.7.0.0
|
||||
instance Category (:~:) where
|
||||
id = Refl
|
||||
Refl . Refl = Refl
|
||||
|
||||
-- | @since 4.10.0.0
|
||||
instance Category (:~~:) where
|
||||
id = HRefl
|
||||
HRefl . HRefl = HRefl
|
||||
|
||||
-- | @since 4.7.0.0
|
||||
instance Category Coercion where
|
||||
id = Coercion
|
||||
(.) Coercion = coerce
|
||||
|
||||
-- | Right-to-left composition
|
||||
(<<<) :: Category cat => cat b c -> cat a b -> cat a c
|
||||
(<<<) = (.)
|
||||
|
||||
-- | Left-to-right composition
|
||||
(>>>) :: Category cat => cat a b -> cat b c -> cat a c
|
||||
f >>> g = g . f
|
@ -1,666 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE CPP
|
||||
, MagicHash
|
||||
, UnboxedTuples
|
||||
, ScopedTypeVariables
|
||||
, RankNTypes
|
||||
#-}
|
||||
{-# OPTIONS_GHC -Wno-deprecations #-}
|
||||
-- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN
|
||||
-- and Control.Concurrent.SampleVar imports.
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Concurrent
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (concurrency)
|
||||
--
|
||||
-- A common interface to a collection of useful concurrency
|
||||
-- abstractions.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Concurrent (
|
||||
-- * Concurrent Haskell
|
||||
|
||||
-- $conc_intro
|
||||
|
||||
-- * Basic concurrency operations
|
||||
|
||||
ThreadId,
|
||||
myThreadId,
|
||||
|
||||
forkIO,
|
||||
forkFinally,
|
||||
forkIOWithUnmask,
|
||||
killThread,
|
||||
throwTo,
|
||||
|
||||
-- ** Threads with affinity
|
||||
forkOn,
|
||||
forkOnWithUnmask,
|
||||
getNumCapabilities,
|
||||
setNumCapabilities,
|
||||
threadCapability,
|
||||
|
||||
-- * Scheduling
|
||||
|
||||
-- $conc_scheduling
|
||||
yield,
|
||||
|
||||
-- ** Blocking
|
||||
|
||||
-- $blocking
|
||||
|
||||
-- ** Waiting
|
||||
threadDelay,
|
||||
threadWaitRead,
|
||||
threadWaitWrite,
|
||||
threadWaitReadSTM,
|
||||
threadWaitWriteSTM,
|
||||
|
||||
-- * Communication abstractions
|
||||
|
||||
module Control.Concurrent.MVar,
|
||||
module Control.Concurrent.Chan,
|
||||
module Control.Concurrent.QSem,
|
||||
module Control.Concurrent.QSemN,
|
||||
|
||||
-- * Bound Threads
|
||||
-- $boundthreads
|
||||
rtsSupportsBoundThreads,
|
||||
forkOS,
|
||||
forkOSWithUnmask,
|
||||
isCurrentThreadBound,
|
||||
runInBoundThread,
|
||||
runInUnboundThread,
|
||||
|
||||
-- * Weak references to ThreadIds
|
||||
mkWeakThreadId,
|
||||
|
||||
-- * GHC's implementation of concurrency
|
||||
|
||||
-- |This section describes features specific to GHC's
|
||||
-- implementation of Concurrent Haskell.
|
||||
|
||||
-- ** Haskell threads and Operating System threads
|
||||
|
||||
-- $osthreads
|
||||
|
||||
-- ** Terminating the program
|
||||
|
||||
-- $termination
|
||||
|
||||
-- ** Pre-emption
|
||||
|
||||
-- $preemption
|
||||
|
||||
-- ** Deadlock
|
||||
|
||||
-- $deadlock
|
||||
|
||||
) where
|
||||
|
||||
import Control.Exception.Base as Exception
|
||||
|
||||
import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
|
||||
threadWaitReadSTM, threadWaitWriteSTM)
|
||||
import GHC.IO ( unsafeUnmask, catchException )
|
||||
import GHC.IORef ( newIORef, readIORef, writeIORef )
|
||||
import GHC.Base
|
||||
|
||||
import System.Posix.Types ( Fd )
|
||||
import Foreign.StablePtr
|
||||
import Foreign.C.Types
|
||||
|
||||
#if defined(mingw32_HOST_OS)
|
||||
import Foreign.C
|
||||
import System.IO
|
||||
import Data.Functor ( void )
|
||||
import Data.Int ( Int64 )
|
||||
#else
|
||||
import qualified GHC.Conc
|
||||
#endif
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Concurrent.QSem
|
||||
import Control.Concurrent.QSemN
|
||||
|
||||
{- $conc_intro
|
||||
|
||||
The concurrency extension for Haskell is described in the paper
|
||||
/Concurrent Haskell/
|
||||
<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.
|
||||
|
||||
Concurrency is \"lightweight\", which means that both thread creation
|
||||
and context switching overheads are extremely low. Scheduling of
|
||||
Haskell threads is done internally in the Haskell runtime system, and
|
||||
doesn't make use of any operating system-supplied thread packages.
|
||||
|
||||
However, if you want to interact with a foreign library that expects your
|
||||
program to use the operating system-supplied thread package, you can do so
|
||||
by using 'forkOS' instead of 'forkIO'.
|
||||
|
||||
Haskell threads can communicate via 'MVar's, a kind of synchronised
|
||||
mutable variable (see "Control.Concurrent.MVar"). Several common
|
||||
concurrency abstractions can be built from 'MVar's, and these are
|
||||
provided by the "Control.Concurrent" library.
|
||||
In GHC, threads may also communicate via exceptions.
|
||||
-}
|
||||
|
||||
{- $conc_scheduling
|
||||
|
||||
Scheduling may be either pre-emptive or co-operative,
|
||||
depending on the implementation of Concurrent Haskell (see below
|
||||
for information related to specific compilers). In a co-operative
|
||||
system, context switches only occur when you use one of the
|
||||
primitives defined in this module. This means that programs such
|
||||
as:
|
||||
|
||||
|
||||
> main = forkIO (write 'a') >> write 'b'
|
||||
> where write c = putChar c >> write c
|
||||
|
||||
will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,
|
||||
instead of some random interleaving of @a@s and @b@s. In
|
||||
practice, cooperative multitasking is sufficient for writing
|
||||
simple graphical user interfaces.
|
||||
-}
|
||||
|
||||
{- $blocking
|
||||
Different Haskell implementations have different characteristics with
|
||||
regard to which operations block /all/ threads.
|
||||
|
||||
Using GHC without the @-threaded@ option, all foreign calls will block
|
||||
all other Haskell threads in the system, although I\/O operations will
|
||||
not. With the @-threaded@ option, only foreign calls with the @unsafe@
|
||||
attribute will block all other threads.
|
||||
|
||||
-}
|
||||
|
||||
-- | Fork a thread and call the supplied function when the thread is about
|
||||
-- to terminate, with an exception or a returned value. The function is
|
||||
-- called with asynchronous exceptions masked.
|
||||
--
|
||||
-- > forkFinally action and_then =
|
||||
-- > mask $ \restore ->
|
||||
-- > forkIO $ try (restore action) >>= and_then
|
||||
--
|
||||
-- This function is useful for informing the parent when a child
|
||||
-- terminates, for example.
|
||||
--
|
||||
-- @since 4.6.0.0
|
||||
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
|
||||
forkFinally action and_then =
|
||||
mask $ \restore ->
|
||||
forkIO $ try (restore action) >>= and_then
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Bound Threads
|
||||
|
||||
{- $boundthreads
|
||||
#boundthreads#
|
||||
|
||||
Support for multiple operating system threads and bound threads as described
|
||||
below is currently only available in the GHC runtime system if you use the
|
||||
/-threaded/ option when linking.
|
||||
|
||||
Other Haskell systems do not currently support multiple operating system threads.
|
||||
|
||||
A bound thread is a haskell thread that is /bound/ to an operating system
|
||||
thread. While the bound thread is still scheduled by the Haskell run-time
|
||||
system, the operating system thread takes care of all the foreign calls made
|
||||
by the bound thread.
|
||||
|
||||
To a foreign library, the bound thread will look exactly like an ordinary
|
||||
operating system thread created using OS functions like @pthread_create@
|
||||
or @CreateThread@.
|
||||
|
||||
Bound threads can be created using the 'forkOS' function below. All foreign
|
||||
exported functions are run in a bound thread (bound to the OS thread that
|
||||
called the function). Also, the @main@ action of every Haskell program is
|
||||
run in a bound thread.
|
||||
|
||||
Why do we need this? Because if a foreign library is called from a thread
|
||||
created using 'forkIO', it won't have access to any /thread-local state/ -
|
||||
state variables that have specific values for each OS thread
|
||||
(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some
|
||||
libraries (OpenGL, for example) will not work from a thread created using
|
||||
'forkIO'. They work fine in threads created using 'forkOS' or when called
|
||||
from @main@ or from a @foreign export@.
|
||||
|
||||
In terms of performance, 'forkOS' (aka bound) threads are much more
|
||||
expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'
|
||||
thread is tied to a particular OS thread, whereas a 'forkIO' thread
|
||||
can be run by any OS thread. Context-switching between a 'forkOS'
|
||||
thread and a 'forkIO' thread is many times more expensive than between
|
||||
two 'forkIO' threads.
|
||||
|
||||
Note in particular that the main program thread (the thread running
|
||||
@Main.main@) is always a bound thread, so for good concurrency
|
||||
performance you should ensure that the main thread is not doing
|
||||
repeated communication with other threads in the system. Typically
|
||||
this means forking subthreads to do the work using 'forkIO', and
|
||||
waiting for the results in the main thread.
|
||||
|
||||
-}
|
||||
|
||||
-- | 'True' if bound threads are supported.
|
||||
-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
|
||||
-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
|
||||
-- fail.
|
||||
foreign import ccall unsafe rtsSupportsBoundThreads :: Bool
|
||||
|
||||
|
||||
{- |
|
||||
Like 'forkIO', this sparks off a new thread to run the 'IO'
|
||||
computation passed as the first argument, and returns the 'ThreadId'
|
||||
of the newly created thread.
|
||||
|
||||
However, 'forkOS' creates a /bound/ thread, which is necessary if you
|
||||
need to call foreign (non-Haskell) libraries that make use of
|
||||
thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads").
|
||||
|
||||
Using 'forkOS' instead of 'forkIO' makes no difference at all to the
|
||||
scheduling behaviour of the Haskell runtime system. It is a common
|
||||
misconception that you need to use 'forkOS' instead of 'forkIO' to
|
||||
avoid blocking all the Haskell threads when making a foreign call;
|
||||
this isn't the case. To allow foreign calls to be made without
|
||||
blocking all the Haskell threads (with GHC), it is only necessary to
|
||||
use the @-threaded@ option when linking your program, and to make sure
|
||||
the foreign import is not marked @unsafe@.
|
||||
-}
|
||||
|
||||
forkOS :: IO () -> IO ThreadId
|
||||
|
||||
foreign export ccall forkOS_entry
|
||||
:: StablePtr (IO ()) -> IO ()
|
||||
|
||||
foreign import ccall "forkOS_entry" forkOS_entry_reimported
|
||||
:: StablePtr (IO ()) -> IO ()
|
||||
|
||||
forkOS_entry :: StablePtr (IO ()) -> IO ()
|
||||
forkOS_entry stableAction = do
|
||||
action <- deRefStablePtr stableAction
|
||||
action
|
||||
|
||||
foreign import ccall forkOS_createThread
|
||||
:: StablePtr (IO ()) -> IO CInt
|
||||
|
||||
failNonThreaded :: IO a
|
||||
failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
|
||||
++"(use ghc -threaded when linking)"
|
||||
|
||||
forkOS action0
|
||||
| rtsSupportsBoundThreads = do
|
||||
mv <- newEmptyMVar
|
||||
b <- Exception.getMaskingState
|
||||
let
|
||||
-- async exceptions are masked in the child if they are masked
|
||||
-- in the parent, as for forkIO (see #1048). forkOS_createThread
|
||||
-- creates a thread with exceptions masked by default.
|
||||
action1 = case b of
|
||||
Unmasked -> unsafeUnmask action0
|
||||
MaskedInterruptible -> action0
|
||||
MaskedUninterruptible -> uninterruptibleMask_ action0
|
||||
|
||||
action_plus = catch action1 childHandler
|
||||
|
||||
entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
|
||||
err <- forkOS_createThread entry
|
||||
when (err /= 0) $ fail "Cannot create OS thread."
|
||||
tid <- takeMVar mv
|
||||
freeStablePtr entry
|
||||
return tid
|
||||
| otherwise = failNonThreaded
|
||||
|
||||
-- | Like 'forkIOWithUnmask', but the child thread is a bound thread,
|
||||
-- as with 'forkOS'.
|
||||
forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
|
||||
forkOSWithUnmask io = forkOS (io unsafeUnmask)
|
||||
|
||||
-- | Returns 'True' if the calling thread is /bound/, that is, if it is
|
||||
-- safe to use foreign libraries that rely on thread-local state from the
|
||||
-- calling thread.
|
||||
isCurrentThreadBound :: IO Bool
|
||||
isCurrentThreadBound = IO $ \ s# ->
|
||||
case isCurrentThreadBound# s# of
|
||||
(# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)
|
||||
|
||||
|
||||
{- |
|
||||
Run the 'IO' computation passed as the first argument. If the calling thread
|
||||
is not /bound/, a bound thread is created temporarily. @runInBoundThread@
|
||||
doesn't finish until the 'IO' computation finishes.
|
||||
|
||||
You can wrap a series of foreign function calls that rely on thread-local state
|
||||
with @runInBoundThread@ so that you can use them without knowing whether the
|
||||
current thread is /bound/.
|
||||
-}
|
||||
runInBoundThread :: IO a -> IO a
|
||||
|
||||
runInBoundThread action
|
||||
| rtsSupportsBoundThreads = do
|
||||
bound <- isCurrentThreadBound
|
||||
if bound
|
||||
then action
|
||||
else do
|
||||
ref <- newIORef undefined
|
||||
let action_plus = Exception.try action >>= writeIORef ref
|
||||
bracket (newStablePtr action_plus)
|
||||
freeStablePtr
|
||||
(\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=
|
||||
unsafeResult
|
||||
| otherwise = failNonThreaded
|
||||
|
||||
{- |
|
||||
Run the 'IO' computation passed as the first argument. If the calling thread
|
||||
is /bound/, an unbound thread is created temporarily using 'forkIO'.
|
||||
@runInBoundThread@ doesn't finish until the 'IO' computation finishes.
|
||||
|
||||
Use this function /only/ in the rare case that you have actually observed a
|
||||
performance loss due to the use of bound threads. A program that
|
||||
doesn't need its main thread to be bound and makes /heavy/ use of concurrency
|
||||
(e.g. a web server), might want to wrap its @main@ action in
|
||||
@runInUnboundThread@.
|
||||
|
||||
Note that exceptions which are thrown to the current thread are thrown in turn
|
||||
to the thread that is executing the given computation. This ensures there's
|
||||
always a way of killing the forked thread.
|
||||
-}
|
||||
runInUnboundThread :: IO a -> IO a
|
||||
|
||||
runInUnboundThread action = do
|
||||
bound <- isCurrentThreadBound
|
||||
if bound
|
||||
then do
|
||||
mv <- newEmptyMVar
|
||||
mask $ \restore -> do
|
||||
tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
|
||||
let wait = takeMVar mv `catchException` \(e :: SomeException) ->
|
||||
Exception.throwTo tid e >> wait
|
||||
wait >>= unsafeResult
|
||||
else action
|
||||
|
||||
unsafeResult :: Either SomeException a -> IO a
|
||||
unsafeResult = either Exception.throwIO return
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- threadWaitRead/threadWaitWrite
|
||||
|
||||
-- | Block the current thread until data is available to read on the
|
||||
-- given file descriptor (GHC only).
|
||||
--
|
||||
-- This will throw an 'IOError' if the file descriptor was closed
|
||||
-- while this thread was blocked. To safely close a file descriptor
|
||||
-- that has been used with 'threadWaitRead', use
|
||||
-- 'GHC.Conc.closeFdWith'.
|
||||
threadWaitRead :: Fd -> IO ()
|
||||
threadWaitRead fd
|
||||
#if defined(mingw32_HOST_OS)
|
||||
-- we have no IO manager implementing threadWaitRead on Windows.
|
||||
-- fdReady does the right thing, but we have to call it in a
|
||||
-- separate thread, otherwise threadWaitRead won't be interruptible,
|
||||
-- and this only works with -threaded.
|
||||
| threaded = withThread (waitFd fd False)
|
||||
| otherwise = case fd of
|
||||
0 -> do _ <- hWaitForInput stdin (-1)
|
||||
return ()
|
||||
-- hWaitForInput does work properly, but we can only
|
||||
-- do this for stdin since we know its FD.
|
||||
_ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"
|
||||
#else
|
||||
= GHC.Conc.threadWaitRead fd
|
||||
#endif
|
||||
|
||||
-- | Block the current thread until data can be written to the
|
||||
-- given file descriptor (GHC only).
|
||||
--
|
||||
-- This will throw an 'IOError' if the file descriptor was closed
|
||||
-- while this thread was blocked. To safely close a file descriptor
|
||||
-- that has been used with 'threadWaitWrite', use
|
||||
-- 'GHC.Conc.closeFdWith'.
|
||||
threadWaitWrite :: Fd -> IO ()
|
||||
threadWaitWrite fd
|
||||
#if defined(mingw32_HOST_OS)
|
||||
| threaded = withThread (waitFd fd True)
|
||||
| otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows"
|
||||
#else
|
||||
= GHC.Conc.threadWaitWrite fd
|
||||
#endif
|
||||
|
||||
-- | Returns an STM action that can be used to wait for data
|
||||
-- to read from a file descriptor. The second returned value
|
||||
-- is an IO action that can be used to deregister interest
|
||||
-- in the file descriptor.
|
||||
--
|
||||
-- @since 4.7.0.0
|
||||
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
|
||||
threadWaitReadSTM fd
|
||||
#if defined(mingw32_HOST_OS)
|
||||
| threaded = do v <- newTVarIO Nothing
|
||||
mask_ $ void $ forkIO $ do result <- try (waitFd fd False)
|
||||
atomically (writeTVar v $ Just result)
|
||||
let waitAction = do result <- readTVar v
|
||||
case result of
|
||||
Nothing -> retry
|
||||
Just (Right ()) -> return ()
|
||||
Just (Left e) -> throwSTM (e :: IOException)
|
||||
let killAction = return ()
|
||||
return (waitAction, killAction)
|
||||
| otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows"
|
||||
#else
|
||||
= GHC.Conc.threadWaitReadSTM fd
|
||||
#endif
|
||||
|
||||
-- | Returns an STM action that can be used to wait until data
|
||||
-- can be written to a file descriptor. The second returned value
|
||||
-- is an IO action that can be used to deregister interest
|
||||
-- in the file descriptor.
|
||||
--
|
||||
-- @since 4.7.0.0
|
||||
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
|
||||
threadWaitWriteSTM fd
|
||||
#if defined(mingw32_HOST_OS)
|
||||
| threaded = do v <- newTVarIO Nothing
|
||||
mask_ $ void $ forkIO $ do result <- try (waitFd fd True)
|
||||
atomically (writeTVar v $ Just result)
|
||||
let waitAction = do result <- readTVar v
|
||||
case result of
|
||||
Nothing -> retry
|
||||
Just (Right ()) -> return ()
|
||||
Just (Left e) -> throwSTM (e :: IOException)
|
||||
let killAction = return ()
|
||||
return (waitAction, killAction)
|
||||
| otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows"
|
||||
#else
|
||||
= GHC.Conc.threadWaitWriteSTM fd
|
||||
#endif
|
||||
|
||||
#if defined(mingw32_HOST_OS)
|
||||
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
|
||||
|
||||
withThread :: IO a -> IO a
|
||||
withThread io = do
|
||||
m <- newEmptyMVar
|
||||
_ <- mask_ $ forkIO $ try io >>= putMVar m
|
||||
x <- takeMVar m
|
||||
case x of
|
||||
Right a -> return a
|
||||
Left e -> throwIO (e :: IOException)
|
||||
|
||||
waitFd :: Fd -> Bool -> IO ()
|
||||
waitFd fd write = do
|
||||
throwErrnoIfMinus1_ "fdReady" $
|
||||
fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0
|
||||
|
||||
foreign import ccall safe "fdReady"
|
||||
fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
|
||||
#endif
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- More docs
|
||||
|
||||
{- $osthreads
|
||||
|
||||
#osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and
|
||||
are managed entirely by the GHC runtime. Typically Haskell
|
||||
threads are an order of magnitude or two more efficient (in
|
||||
terms of both time and space) than operating system threads.
|
||||
|
||||
The downside of having lightweight threads is that only one can
|
||||
run at a time, so if one thread blocks in a foreign call, for
|
||||
example, the other threads cannot continue. The GHC runtime
|
||||
works around this by making use of full OS threads where
|
||||
necessary. When the program is built with the @-threaded@
|
||||
option (to link against the multithreaded version of the
|
||||
runtime), a thread making a @safe@ foreign call will not block
|
||||
the other threads in the system; another OS thread will take
|
||||
over running Haskell threads until the original call returns.
|
||||
The runtime maintains a pool of these /worker/ threads so that
|
||||
multiple Haskell threads can be involved in external calls
|
||||
simultaneously.
|
||||
|
||||
The "System.IO" library manages multiplexing in its own way. On
|
||||
Windows systems it uses @safe@ foreign calls to ensure that
|
||||
threads doing I\/O operations don't block the whole runtime,
|
||||
whereas on Unix systems all the currently blocked I\/O requests
|
||||
are managed by a single thread (the /IO manager thread/) using
|
||||
a mechanism such as @epoll@ or @kqueue@, depending on what is
|
||||
provided by the host operating system.
|
||||
|
||||
The runtime will run a Haskell thread using any of the available
|
||||
worker OS threads. If you need control over which particular OS
|
||||
thread is used to run a given Haskell thread, perhaps because
|
||||
you need to call a foreign library that uses OS-thread-local
|
||||
state, then you need bound threads (see "Control.Concurrent#boundthreads").
|
||||
|
||||
If you don't use the @-threaded@ option, then the runtime does
|
||||
not make use of multiple OS threads. Foreign calls will block
|
||||
all other running Haskell threads until the call returns. The
|
||||
"System.IO" library still does multiplexing, so there can be multiple
|
||||
threads doing I\/O, and this is handled internally by the runtime using
|
||||
@select@.
|
||||
-}
|
||||
|
||||
{- $termination
|
||||
|
||||
In a standalone GHC program, only the main thread is
|
||||
required to terminate in order for the process to terminate.
|
||||
Thus all other forked threads will simply terminate at the same
|
||||
time as the main thread (the terminology for this kind of
|
||||
behaviour is \"daemonic threads\").
|
||||
|
||||
If you want the program to wait for child threads to
|
||||
finish before exiting, you need to program this yourself. A
|
||||
simple mechanism is to have each child thread write to an
|
||||
'MVar' when it completes, and have the main
|
||||
thread wait on all the 'MVar's before
|
||||
exiting:
|
||||
|
||||
> myForkIO :: IO () -> IO (MVar ())
|
||||
> myForkIO io = do
|
||||
> mvar <- newEmptyMVar
|
||||
> forkFinally io (\_ -> putMVar mvar ())
|
||||
> return mvar
|
||||
|
||||
Note that we use 'forkFinally' to make sure that the
|
||||
'MVar' is written to even if the thread dies or
|
||||
is killed for some reason.
|
||||
|
||||
A better method is to keep a global list of all child
|
||||
threads which we should wait for at the end of the program:
|
||||
|
||||
> children :: MVar [MVar ()]
|
||||
> children = unsafePerformIO (newMVar [])
|
||||
>
|
||||
> waitForChildren :: IO ()
|
||||
> waitForChildren = do
|
||||
> cs <- takeMVar children
|
||||
> case cs of
|
||||
> [] -> return ()
|
||||
> m:ms -> do
|
||||
> putMVar children ms
|
||||
> takeMVar m
|
||||
> waitForChildren
|
||||
>
|
||||
> forkChild :: IO () -> IO ThreadId
|
||||
> forkChild io = do
|
||||
> mvar <- newEmptyMVar
|
||||
> childs <- takeMVar children
|
||||
> putMVar children (mvar:childs)
|
||||
> forkFinally io (\_ -> putMVar mvar ())
|
||||
>
|
||||
> main =
|
||||
> later waitForChildren $
|
||||
> ...
|
||||
|
||||
The main thread principle also applies to calls to Haskell from
|
||||
outside, using @foreign export@. When the @foreign export@ed
|
||||
function is invoked, it starts a new main thread, and it returns
|
||||
when this main thread terminates. If the call causes new
|
||||
threads to be forked, they may remain in the system after the
|
||||
@foreign export@ed function has returned.
|
||||
-}
|
||||
|
||||
{- $preemption
|
||||
|
||||
GHC implements pre-emptive multitasking: the execution of
|
||||
threads are interleaved in a random fashion. More specifically,
|
||||
a thread may be pre-empted whenever it allocates some memory,
|
||||
which unfortunately means that tight loops which do no
|
||||
allocation tend to lock out other threads (this only seems to
|
||||
happen with pathological benchmark-style code, however).
|
||||
|
||||
The rescheduling timer runs on a 20ms granularity by
|
||||
default, but this may be altered using the
|
||||
@-i\<n\>@ RTS option. After a rescheduling
|
||||
\"tick\" the running thread is pre-empted as soon as
|
||||
possible.
|
||||
|
||||
One final note: the
|
||||
@aaaa@ @bbbb@ example may not
|
||||
work too well on GHC (see Scheduling, above), due
|
||||
to the locking on a 'System.IO.Handle'. Only one thread
|
||||
may hold the lock on a 'System.IO.Handle' at any one
|
||||
time, so if a reschedule happens while a thread is holding the
|
||||
lock, the other thread won't be able to run. The upshot is that
|
||||
the switch from @aaaa@ to
|
||||
@bbbbb@ happens infrequently. It can be
|
||||
improved by lowering the reschedule tick period. We also have a
|
||||
patch that causes a reschedule whenever a thread waiting on a
|
||||
lock is woken up, but haven't found it to be useful for anything
|
||||
other than this example :-)
|
||||
-}
|
||||
|
||||
{- $deadlock
|
||||
|
||||
GHC attempts to detect when threads are deadlocked using the garbage
|
||||
collector. A thread that is not reachable (cannot be found by
|
||||
following pointers from live objects) must be deadlocked, and in this
|
||||
case the thread is sent an exception. The exception is either
|
||||
'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM',
|
||||
'NonTermination', or 'Deadlock', depending on the way in which the
|
||||
thread is deadlocked.
|
||||
|
||||
Note that this feature is intended for debugging, and should not be
|
||||
relied on for the correct operation of your program. There is no
|
||||
guarantee that the garbage collector will be accurate enough to detect
|
||||
your deadlock, and no guarantee that the garbage collector will run in
|
||||
a timely enough manner. Basically, the same caveats as for finalizers
|
||||
apply to deadlock detection.
|
||||
|
||||
There is a subtle interaction between deadlock detection and
|
||||
finalizers (as created by 'Foreign.Concurrent.newForeignPtr' or the
|
||||
functions in "System.Mem.Weak"): if a thread is blocked waiting for a
|
||||
finalizer to run, then the thread will be considered deadlocked and
|
||||
sent an exception. So preferably don't do this, but if you have no
|
||||
alternative then it is possible to prevent the thread from being
|
||||
considered deadlocked by making a 'StablePtr' pointing to it. Don't
|
||||
forget to release the 'StablePtr' later with 'freeStablePtr'.
|
||||
-}
|
@ -1,142 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Concurrent.Chan
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (concurrency)
|
||||
--
|
||||
-- Unbounded channels.
|
||||
--
|
||||
-- The channels are implemented with @MVar@s and therefore inherit all the
|
||||
-- caveats that apply to @MVar@s (possibility of races, deadlocks etc). The
|
||||
-- stm (software transactional memory) library has a more robust implementation
|
||||
-- of channels called @TChan@s.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Concurrent.Chan
|
||||
(
|
||||
-- * The 'Chan' type
|
||||
Chan, -- abstract
|
||||
|
||||
-- * Operations
|
||||
newChan,
|
||||
writeChan,
|
||||
readChan,
|
||||
dupChan,
|
||||
|
||||
-- * Stream interface
|
||||
getChanContents,
|
||||
writeList2Chan,
|
||||
) where
|
||||
|
||||
import System.IO.Unsafe ( unsafeInterleaveIO )
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception (mask_)
|
||||
|
||||
#define _UPK_(x) {-# UNPACK #-} !(x)
|
||||
|
||||
-- A channel is represented by two @MVar@s keeping track of the two ends
|
||||
-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
|
||||
-- are used to handle consumers trying to read from an empty channel.
|
||||
|
||||
-- |'Chan' is an abstract type representing an unbounded FIFO channel.
|
||||
data Chan a
|
||||
= Chan _UPK_(MVar (Stream a))
|
||||
_UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar
|
||||
deriving Eq -- ^ @since 4.4.0.0
|
||||
|
||||
type Stream a = MVar (ChItem a)
|
||||
|
||||
data ChItem a = ChItem a _UPK_(Stream a)
|
||||
-- benchmarks show that unboxing the MVar here is worthwhile, because
|
||||
-- although it leads to higher allocation, the channel data takes up
|
||||
-- less space and is therefore quicker to GC.
|
||||
|
||||
-- See the Concurrent Haskell paper for a diagram explaining the
|
||||
-- how the different channel operations proceed.
|
||||
|
||||
-- @newChan@ sets up the read and write end of a channel by initialising
|
||||
-- these two @MVar@s with an empty @MVar@.
|
||||
|
||||
-- |Build and returns a new instance of 'Chan'.
|
||||
newChan :: IO (Chan a)
|
||||
newChan = do
|
||||
hole <- newEmptyMVar
|
||||
readVar <- newMVar hole
|
||||
writeVar <- newMVar hole
|
||||
return (Chan readVar writeVar)
|
||||
|
||||
-- To put an element on a channel, a new hole at the write end is created.
|
||||
-- What was previously the empty @MVar@ at the back of the channel is then
|
||||
-- filled in with a new stream element holding the entered value and the
|
||||
-- new hole.
|
||||
|
||||
-- |Write a value to a 'Chan'.
|
||||
writeChan :: Chan a -> a -> IO ()
|
||||
writeChan (Chan _ writeVar) val = do
|
||||
new_hole <- newEmptyMVar
|
||||
mask_ $ do
|
||||
old_hole <- takeMVar writeVar
|
||||
putMVar old_hole (ChItem val new_hole)
|
||||
putMVar writeVar new_hole
|
||||
|
||||
-- The reason we don't simply do this:
|
||||
--
|
||||
-- modifyMVar_ writeVar $ \old_hole -> do
|
||||
-- putMVar old_hole (ChItem val new_hole)
|
||||
-- return new_hole
|
||||
--
|
||||
-- is because if an asynchronous exception is received after the 'putMVar'
|
||||
-- completes and before modifyMVar_ installs the new value, it will set the
|
||||
-- Chan's write end to a filled hole.
|
||||
|
||||
-- |Read the next value from the 'Chan'. Blocks when the channel is empty. Since
|
||||
-- the read end of a channel is an 'MVar', this operation inherits fairness
|
||||
-- guarantees of 'MVar's (e.g. threads blocked in this operation are woken up in
|
||||
-- FIFO order).
|
||||
--
|
||||
-- Throws 'Control.Exception.BlockedIndefinitelyOnMVar' when the channel is
|
||||
-- empty and no other thread holds a reference to the channel.
|
||||
readChan :: Chan a -> IO a
|
||||
readChan (Chan readVar _) = do
|
||||
modifyMVar readVar $ \read_end -> do
|
||||
(ChItem val new_read_end) <- readMVar read_end
|
||||
-- Use readMVar here, not takeMVar,
|
||||
-- else dupChan doesn't work
|
||||
return (new_read_end, val)
|
||||
|
||||
-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to
|
||||
-- either channel from then on will be available from both. Hence this creates
|
||||
-- a kind of broadcast channel, where data written by anyone is seen by
|
||||
-- everyone else.
|
||||
--
|
||||
-- (Note that a duplicated channel is not equal to its original.
|
||||
-- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.)
|
||||
dupChan :: Chan a -> IO (Chan a)
|
||||
dupChan (Chan _ writeVar) = do
|
||||
hole <- readMVar writeVar
|
||||
newReadVar <- newMVar hole
|
||||
return (Chan newReadVar writeVar)
|
||||
|
||||
-- Operators for interfacing with functional streams.
|
||||
|
||||
-- |Return a lazy list representing the contents of the supplied
|
||||
-- 'Chan', much like 'System.IO.hGetContents'.
|
||||
getChanContents :: Chan a -> IO [a]
|
||||
getChanContents ch
|
||||
= unsafeInterleaveIO (do
|
||||
x <- readChan ch
|
||||
xs <- getChanContents ch
|
||||
return (x:xs)
|
||||
)
|
||||
|
||||
-- |Write an entire list of items to a 'Chan'.
|
||||
writeList2Chan :: Chan a -> [a] -> IO ()
|
||||
writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
|
@ -1,274 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, MagicHash #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Concurrent.MVar
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (concurrency)
|
||||
--
|
||||
-- An @'MVar' t@ is mutable location that is either empty or contains a
|
||||
-- value of type @t@. It has two fundamental operations: 'putMVar'
|
||||
-- which fills an 'MVar' if it is empty and blocks otherwise, and
|
||||
-- 'takeMVar' which empties an 'MVar' if it is full and blocks
|
||||
-- otherwise. They can be used in multiple different ways:
|
||||
--
|
||||
-- 1. As synchronized mutable variables,
|
||||
--
|
||||
-- 2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and
|
||||
--
|
||||
-- 3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as
|
||||
-- wait and signal.
|
||||
--
|
||||
-- They were introduced in the paper
|
||||
-- <https://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz "Concurrent Haskell">
|
||||
-- by Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne, though
|
||||
-- some details of their implementation have since then changed (in
|
||||
-- particular, a put on a full 'MVar' used to error, but now merely
|
||||
-- blocks.)
|
||||
--
|
||||
-- === Applicability
|
||||
--
|
||||
-- 'MVar's offer more flexibility than 'Data.IORef.IORef's, but less flexibility
|
||||
-- than 'GHC.Conc.STM'. They are appropriate for building synchronization
|
||||
-- primitives and performing simple interthread communication; however
|
||||
-- they are very simple and susceptible to race conditions, deadlocks or
|
||||
-- uncaught exceptions. Do not use them if you need perform larger
|
||||
-- atomic operations such as reading from multiple variables: use 'GHC.Conc.STM'
|
||||
-- instead.
|
||||
--
|
||||
-- In particular, the "bigger" functions in this module ('swapMVar',
|
||||
-- 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply
|
||||
-- the composition of a 'takeMVar' followed by a 'putMVar' with
|
||||
-- exception safety.
|
||||
-- These only have atomicity guarantees if all other threads
|
||||
-- perform a 'takeMVar' before a 'putMVar' as well; otherwise, they may
|
||||
-- block.
|
||||
--
|
||||
-- === Fairness
|
||||
--
|
||||
-- No thread can be blocked indefinitely on an 'MVar' unless another
|
||||
-- thread holds that 'MVar' indefinitely. One usual implementation of
|
||||
-- this fairness guarantee is that threads blocked on an 'MVar' are
|
||||
-- served in a first-in-first-out fashion, but this is not guaranteed
|
||||
-- in the semantics.
|
||||
--
|
||||
-- === Gotchas
|
||||
--
|
||||
-- Like many other Haskell data structures, 'MVar's are lazy. This
|
||||
-- means that if you place an expensive unevaluated thunk inside an
|
||||
-- 'MVar', it will be evaluated by the thread that consumes it, not the
|
||||
-- thread that produced it. Be sure to 'evaluate' values to be placed
|
||||
-- in an 'MVar' to the appropriate normal form, or utilize a strict
|
||||
-- MVar provided by the strict-concurrency package.
|
||||
--
|
||||
-- === Ordering
|
||||
--
|
||||
-- 'MVar' operations are always observed to take place in the order
|
||||
-- they are written in the program, regardless of the memory model of
|
||||
-- the underlying machine. This is in contrast to 'Data.IORef.IORef' operations
|
||||
-- which may appear out-of-order to another thread in some cases.
|
||||
--
|
||||
-- === Example
|
||||
--
|
||||
-- Consider the following concurrent data structure, a skip channel.
|
||||
-- This is a channel for an intermittent source of high bandwidth
|
||||
-- information (for example, mouse movement events.) Writing to the
|
||||
-- channel never blocks, and reading from the channel only returns the
|
||||
-- most recent value, or blocks if there are no new values. Multiple
|
||||
-- readers are supported with a @dupSkipChan@ operation.
|
||||
--
|
||||
-- A skip channel is a pair of 'MVar's. The first 'MVar' contains the
|
||||
-- current value, and a list of semaphores that need to be notified
|
||||
-- when it changes. The second 'MVar' is a semaphore for this particular
|
||||
-- reader: it is full if there is a value in the channel that this
|
||||
-- reader has not read yet, and empty otherwise.
|
||||
--
|
||||
-- @
|
||||
-- data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ())
|
||||
--
|
||||
-- newSkipChan :: IO (SkipChan a)
|
||||
-- newSkipChan = do
|
||||
-- sem <- newEmptyMVar
|
||||
-- main <- newMVar (undefined, [sem])
|
||||
-- return (SkipChan main sem)
|
||||
--
|
||||
-- putSkipChan :: SkipChan a -> a -> IO ()
|
||||
-- putSkipChan (SkipChan main _) v = do
|
||||
-- (_, sems) <- takeMVar main
|
||||
-- putMVar main (v, [])
|
||||
-- mapM_ (\sem -> putMVar sem ()) sems
|
||||
--
|
||||
-- getSkipChan :: SkipChan a -> IO a
|
||||
-- getSkipChan (SkipChan main sem) = do
|
||||
-- takeMVar sem
|
||||
-- (v, sems) <- takeMVar main
|
||||
-- putMVar main (v, sem:sems)
|
||||
-- return v
|
||||
--
|
||||
-- dupSkipChan :: SkipChan a -> IO (SkipChan a)
|
||||
-- dupSkipChan (SkipChan main _) = do
|
||||
-- sem <- newEmptyMVar
|
||||
-- (v, sems) <- takeMVar main
|
||||
-- putMVar main (v, sem:sems)
|
||||
-- return (SkipChan main sem)
|
||||
-- @
|
||||
--
|
||||
-- This example was adapted from the original Concurrent Haskell paper.
|
||||
-- For more examples of 'MVar's being used to build higher-level
|
||||
-- synchronization primitives, see 'Control.Concurrent.Chan' and
|
||||
-- 'Control.Concurrent.QSem'.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Concurrent.MVar
|
||||
(
|
||||
-- * @MVar@s
|
||||
MVar
|
||||
, newEmptyMVar
|
||||
, newMVar
|
||||
, takeMVar
|
||||
, putMVar
|
||||
, readMVar
|
||||
, swapMVar
|
||||
, tryTakeMVar
|
||||
, tryPutMVar
|
||||
, isEmptyMVar
|
||||
, withMVar
|
||||
, withMVarMasked
|
||||
, modifyMVar_
|
||||
, modifyMVar
|
||||
, modifyMVarMasked_
|
||||
, modifyMVarMasked
|
||||
, tryReadMVar
|
||||
, mkWeakMVar
|
||||
, addMVarFinalizer
|
||||
) where
|
||||
|
||||
import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,
|
||||
tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar,
|
||||
tryReadMVar
|
||||
)
|
||||
import qualified GHC.MVar
|
||||
import GHC.Weak
|
||||
import GHC.Base
|
||||
|
||||
import Control.Exception.Base
|
||||
|
||||
{-|
|
||||
Take a value from an 'MVar', put a new value into the 'MVar' and
|
||||
return the value taken. This function is atomic only if there are
|
||||
no other producers for this 'MVar'.
|
||||
-}
|
||||
swapMVar :: MVar a -> a -> IO a
|
||||
swapMVar mvar new =
|
||||
mask_ $ do
|
||||
old <- takeMVar mvar
|
||||
putMVar mvar new
|
||||
return old
|
||||
|
||||
{-|
|
||||
'withMVar' is an exception-safe wrapper for operating on the contents
|
||||
of an 'MVar'. This operation is exception-safe: it will replace the
|
||||
original contents of the 'MVar' if an exception is raised (see
|
||||
"Control.Exception"). However, it is only atomic if there are no
|
||||
other producers for this 'MVar'.
|
||||
-}
|
||||
{-# INLINE withMVar #-}
|
||||
-- inlining has been reported to have dramatic effects; see
|
||||
-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
|
||||
withMVar :: MVar a -> (a -> IO b) -> IO b
|
||||
withMVar m io =
|
||||
mask $ \restore -> do
|
||||
a <- takeMVar m
|
||||
b <- restore (io a) `onException` putMVar m a
|
||||
putMVar m a
|
||||
return b
|
||||
|
||||
{-|
|
||||
Like 'withMVar', but the @IO@ action in the second argument is executed
|
||||
with asynchronous exceptions masked.
|
||||
|
||||
@since 4.7.0.0
|
||||
-}
|
||||
{-# INLINE withMVarMasked #-}
|
||||
withMVarMasked :: MVar a -> (a -> IO b) -> IO b
|
||||
withMVarMasked m io =
|
||||
mask_ $ do
|
||||
a <- takeMVar m
|
||||
b <- io a `onException` putMVar m a
|
||||
putMVar m a
|
||||
return b
|
||||
|
||||
{-|
|
||||
An exception-safe wrapper for modifying the contents of an 'MVar'.
|
||||
Like 'withMVar', 'modifyMVar' will replace the original contents of
|
||||
the 'MVar' if an exception is raised during the operation. This
|
||||
function is only atomic if there are no other producers for this
|
||||
'MVar'.
|
||||
-}
|
||||
{-# INLINE modifyMVar_ #-}
|
||||
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
|
||||
modifyMVar_ m io =
|
||||
mask $ \restore -> do
|
||||
a <- takeMVar m
|
||||
a' <- restore (io a) `onException` putMVar m a
|
||||
putMVar m a'
|
||||
|
||||
{-|
|
||||
A slight variation on 'modifyMVar_' that allows a value to be
|
||||
returned (@b@) in addition to the modified value of the 'MVar'.
|
||||
-}
|
||||
{-# INLINE modifyMVar #-}
|
||||
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
|
||||
modifyMVar m io =
|
||||
mask $ \restore -> do
|
||||
a <- takeMVar m
|
||||
(a',b) <- restore (io a >>= evaluate) `onException` putMVar m a
|
||||
putMVar m a'
|
||||
return b
|
||||
|
||||
{-|
|
||||
Like 'modifyMVar_', but the @IO@ action in the second argument is executed with
|
||||
asynchronous exceptions masked.
|
||||
|
||||
@since 4.6.0.0
|
||||
-}
|
||||
{-# INLINE modifyMVarMasked_ #-}
|
||||
modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()
|
||||
modifyMVarMasked_ m io =
|
||||
mask_ $ do
|
||||
a <- takeMVar m
|
||||
a' <- io a `onException` putMVar m a
|
||||
putMVar m a'
|
||||
|
||||
{-|
|
||||
Like 'modifyMVar', but the @IO@ action in the second argument is executed with
|
||||
asynchronous exceptions masked.
|
||||
|
||||
@since 4.6.0.0
|
||||
-}
|
||||
{-# INLINE modifyMVarMasked #-}
|
||||
modifyMVarMasked :: MVar a -> (a -> IO (a,b)) -> IO b
|
||||
modifyMVarMasked m io =
|
||||
mask_ $ do
|
||||
a <- takeMVar m
|
||||
(a',b) <- (io a >>= evaluate) `onException` putMVar m a
|
||||
putMVar m a'
|
||||
return b
|
||||
|
||||
{-# DEPRECATED addMVarFinalizer "use 'mkWeakMVar' instead" #-} -- deprecated in 7.6
|
||||
addMVarFinalizer :: MVar a -> IO () -> IO ()
|
||||
addMVarFinalizer = GHC.MVar.addMVarFinalizer
|
||||
|
||||
-- | Make a 'Weak' pointer to an 'MVar', using the second argument as
|
||||
-- a finalizer to run when 'MVar' is garbage-collected
|
||||
--
|
||||
-- @since 4.6.0.0
|
||||
mkWeakMVar :: MVar a -> IO () -> IO (Weak (MVar a))
|
||||
mkWeakMVar m@(MVar m#) (IO f) = IO $ \s ->
|
||||
case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)
|
@ -1,129 +0,0 @@
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Concurrent.QSem
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (concurrency)
|
||||
--
|
||||
-- Simple quantity semaphores.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Concurrent.QSem
|
||||
( -- * Simple Quantity Semaphores
|
||||
QSem, -- abstract
|
||||
newQSem, -- :: Int -> IO QSem
|
||||
waitQSem, -- :: QSem -> IO ()
|
||||
signalQSem -- :: QSem -> IO ()
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
|
||||
, putMVar, newMVar, tryPutMVar)
|
||||
import Control.Exception
|
||||
import Data.Maybe
|
||||
|
||||
-- | 'QSem' is a quantity semaphore in which the resource is acquired
|
||||
-- and released in units of one. It provides guaranteed FIFO ordering
|
||||
-- for satisfying blocked `waitQSem` calls.
|
||||
--
|
||||
-- The pattern
|
||||
--
|
||||
-- > bracket_ waitQSem signalQSem (...)
|
||||
--
|
||||
-- is safe; it never loses a unit of the resource.
|
||||
--
|
||||
newtype QSem = QSem (MVar (Int, [MVar ()], [MVar ()]))
|
||||
|
||||
-- The semaphore state (i, xs, ys):
|
||||
--
|
||||
-- i is the current resource value
|
||||
--
|
||||
-- (xs,ys) is the queue of blocked threads, where the queue is
|
||||
-- given by xs ++ reverse ys. We can enqueue new blocked threads
|
||||
-- by consing onto ys, and dequeue by removing from the head of xs.
|
||||
--
|
||||
-- A blocked thread is represented by an empty (MVar ()). To unblock
|
||||
-- the thread, we put () into the MVar.
|
||||
--
|
||||
-- A thread can dequeue itself by also putting () into the MVar, which
|
||||
-- it must do if it receives an exception while blocked in waitQSem.
|
||||
-- This means that when unblocking a thread in signalQSem we must
|
||||
-- first check whether the MVar is already full; the MVar lock on the
|
||||
-- semaphore itself resolves race conditions between signalQSem and a
|
||||
-- thread attempting to dequeue itself.
|
||||
|
||||
-- |Build a new 'QSem' with a supplied initial quantity.
|
||||
-- The initial quantity must be at least 0.
|
||||
newQSem :: Int -> IO QSem
|
||||
newQSem initial
|
||||
| initial < 0 = fail "newQSem: Initial quantity must be non-negative"
|
||||
| otherwise = do
|
||||
sem <- newMVar (initial, [], [])
|
||||
return (QSem sem)
|
||||
|
||||
-- |Wait for a unit to become available
|
||||
waitQSem :: QSem -> IO ()
|
||||
waitQSem (QSem m) =
|
||||
mask_ $ do
|
||||
(i,b1,b2) <- takeMVar m
|
||||
if i == 0
|
||||
then do
|
||||
b <- newEmptyMVar
|
||||
putMVar m (i, b1, b:b2)
|
||||
wait b
|
||||
else do
|
||||
let !z = i-1
|
||||
putMVar m (z, b1, b2)
|
||||
return ()
|
||||
where
|
||||
wait b = takeMVar b `onException` do
|
||||
(uninterruptibleMask_ $ do -- Note [signal uninterruptible]
|
||||
(i,b1,b2) <- takeMVar m
|
||||
r <- tryTakeMVar b
|
||||
r' <- if isJust r
|
||||
then signal (i,b1,b2)
|
||||
else do putMVar b (); return (i,b1,b2)
|
||||
putMVar m r')
|
||||
|
||||
-- |Signal that a unit of the 'QSem' is available
|
||||
signalQSem :: QSem -> IO ()
|
||||
signalQSem (QSem m) =
|
||||
uninterruptibleMask_ $ do -- Note [signal uninterruptible]
|
||||
r <- takeMVar m
|
||||
r' <- signal r
|
||||
putMVar m r'
|
||||
|
||||
-- Note [signal uninterruptible]
|
||||
--
|
||||
-- If we have
|
||||
--
|
||||
-- bracket waitQSem signalQSem (...)
|
||||
--
|
||||
-- and an exception arrives at the signalQSem, then we must not lose
|
||||
-- the resource. The signalQSem is masked by bracket, but taking
|
||||
-- the MVar might block, and so it would be interruptible. Hence we
|
||||
-- need an uninterruptibleMask here.
|
||||
--
|
||||
-- This isn't ideal: during high contention, some threads won't be
|
||||
-- interruptible. The QSemSTM implementation has better behaviour
|
||||
-- here, but it performs much worse than this one in some
|
||||
-- benchmarks.
|
||||
|
||||
signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()])
|
||||
signal (i,a1,a2) =
|
||||
if i == 0
|
||||
then loop a1 a2
|
||||
else let !z = i+1 in return (z, a1, a2)
|
||||
where
|
||||
loop [] [] = return (1, [], [])
|
||||
loop [] b2 = loop (reverse b2) []
|
||||
loop (b:bs) b2 = do
|
||||
r <- tryPutMVar b ()
|
||||
if r then return (0, bs, b2)
|
||||
else loop bs b2
|
@ -1,120 +0,0 @@
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Concurrent.QSemN
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (concurrency)
|
||||
--
|
||||
-- Quantity semaphores in which each thread may wait for an arbitrary
|
||||
-- \"amount\".
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Concurrent.QSemN
|
||||
( -- * General Quantity Semaphores
|
||||
QSemN, -- abstract
|
||||
newQSemN, -- :: Int -> IO QSemN
|
||||
waitQSemN, -- :: QSemN -> Int -> IO ()
|
||||
signalQSemN -- :: QSemN -> Int -> IO ()
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar
|
||||
, putMVar, newMVar
|
||||
, tryPutMVar, isEmptyMVar)
|
||||
import Control.Exception
|
||||
import Data.Maybe
|
||||
|
||||
-- | 'QSemN' is a quantity semaphore in which the resource is acquired
|
||||
-- and released in units of one. It provides guaranteed FIFO ordering
|
||||
-- for satisfying blocked `waitQSemN` calls.
|
||||
--
|
||||
-- The pattern
|
||||
--
|
||||
-- > bracket_ (waitQSemN n) (signalQSemN n) (...)
|
||||
--
|
||||
-- is safe; it never loses any of the resource.
|
||||
--
|
||||
newtype QSemN = QSemN (MVar (Int, [(Int, MVar ())], [(Int, MVar ())]))
|
||||
|
||||
-- The semaphore state (i, xs, ys):
|
||||
--
|
||||
-- i is the current resource value
|
||||
--
|
||||
-- (xs,ys) is the queue of blocked threads, where the queue is
|
||||
-- given by xs ++ reverse ys. We can enqueue new blocked threads
|
||||
-- by consing onto ys, and dequeue by removing from the head of xs.
|
||||
--
|
||||
-- A blocked thread is represented by an empty (MVar ()). To unblock
|
||||
-- the thread, we put () into the MVar.
|
||||
--
|
||||
-- A thread can dequeue itself by also putting () into the MVar, which
|
||||
-- it must do if it receives an exception while blocked in waitQSemN.
|
||||
-- This means that when unblocking a thread in signalQSemN we must
|
||||
-- first check whether the MVar is already full; the MVar lock on the
|
||||
-- semaphore itself resolves race conditions between signalQSemN and a
|
||||
-- thread attempting to dequeue itself.
|
||||
|
||||
-- |Build a new 'QSemN' with a supplied initial quantity.
|
||||
-- The initial quantity must be at least 0.
|
||||
newQSemN :: Int -> IO QSemN
|
||||
newQSemN initial
|
||||
| initial < 0 = fail "newQSemN: Initial quantity must be non-negative"
|
||||
| otherwise = do
|
||||
sem <- newMVar (initial, [], [])
|
||||
return (QSemN sem)
|
||||
|
||||
-- |Wait for the specified quantity to become available
|
||||
waitQSemN :: QSemN -> Int -> IO ()
|
||||
waitQSemN (QSemN m) sz =
|
||||
mask_ $ do
|
||||
(i,b1,b2) <- takeMVar m
|
||||
let z = i-sz
|
||||
if z < 0
|
||||
then do
|
||||
b <- newEmptyMVar
|
||||
putMVar m (i, b1, (sz,b):b2)
|
||||
wait b
|
||||
else do
|
||||
putMVar m (z, b1, b2)
|
||||
return ()
|
||||
where
|
||||
wait b = do
|
||||
takeMVar b `onException`
|
||||
(uninterruptibleMask_ $ do -- Note [signal uninterruptible]
|
||||
(i,b1,b2) <- takeMVar m
|
||||
r <- tryTakeMVar b
|
||||
r' <- if isJust r
|
||||
then signal sz (i,b1,b2)
|
||||
else do putMVar b (); return (i,b1,b2)
|
||||
putMVar m r')
|
||||
|
||||
-- |Signal that a given quantity is now available from the 'QSemN'.
|
||||
signalQSemN :: QSemN -> Int -> IO ()
|
||||
signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do
|
||||
r <- takeMVar m
|
||||
r' <- signal sz r
|
||||
putMVar m r'
|
||||
|
||||
signal :: Int
|
||||
-> (Int,[(Int,MVar ())],[(Int,MVar ())])
|
||||
-> IO (Int,[(Int,MVar ())],[(Int,MVar ())])
|
||||
|
||||
signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2
|
||||
where
|
||||
loop 0 bs b2 = return (0, bs, b2)
|
||||
loop sz [] [] = return (sz, [], [])
|
||||
loop sz [] b2 = loop sz (reverse b2) []
|
||||
loop sz ((j,b):bs) b2
|
||||
| j > sz = do
|
||||
r <- isEmptyMVar b
|
||||
if r then return (sz, (j,b):bs, b2)
|
||||
else loop sz bs b2
|
||||
| otherwise = do
|
||||
r <- tryPutMVar b ()
|
||||
if r then loop (sz-j) bs b2
|
||||
else loop sz bs b2
|
@ -1,398 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Exception
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (extended exceptions)
|
||||
--
|
||||
-- This module provides support for raising and catching both built-in
|
||||
-- and user-defined exceptions.
|
||||
--
|
||||
-- In addition to exceptions thrown by 'IO' operations, exceptions may
|
||||
-- be thrown by pure code (imprecise exceptions) or by external events
|
||||
-- (asynchronous exceptions), but may only be caught in the 'IO' monad.
|
||||
-- For more details, see:
|
||||
--
|
||||
-- * /A semantics for imprecise exceptions/, by Simon Peyton Jones,
|
||||
-- Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,
|
||||
-- in /PLDI'99/.
|
||||
--
|
||||
-- * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton
|
||||
-- Jones, Andy Moran and John Reppy, in /PLDI'01/.
|
||||
--
|
||||
-- * /An Extensible Dynamically-Typed Hierarchy of Exceptions/,
|
||||
-- by Simon Marlow, in /Haskell '06/.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Exception (
|
||||
|
||||
-- * The Exception type
|
||||
SomeException(..),
|
||||
Exception(..), -- class
|
||||
IOException, -- instance Eq, Ord, Show, Typeable, Exception
|
||||
ArithException(..), -- instance Eq, Ord, Show, Typeable, Exception
|
||||
ArrayException(..), -- instance Eq, Ord, Show, Typeable, Exception
|
||||
AssertionFailed(..),
|
||||
SomeAsyncException(..),
|
||||
AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception
|
||||
asyncExceptionToException, asyncExceptionFromException,
|
||||
|
||||
NonTermination(..),
|
||||
NestedAtomically(..),
|
||||
BlockedIndefinitelyOnMVar(..),
|
||||
BlockedIndefinitelyOnSTM(..),
|
||||
AllocationLimitExceeded(..),
|
||||
CompactionFailed(..),
|
||||
Deadlock(..),
|
||||
NoMethodError(..),
|
||||
PatternMatchFail(..),
|
||||
RecConError(..),
|
||||
RecSelError(..),
|
||||
RecUpdError(..),
|
||||
ErrorCall(..),
|
||||
TypeError(..),
|
||||
|
||||
-- * Throwing exceptions
|
||||
throw,
|
||||
throwIO,
|
||||
ioError,
|
||||
throwTo,
|
||||
|
||||
-- * Catching Exceptions
|
||||
|
||||
-- $catching
|
||||
|
||||
-- ** Catching all exceptions
|
||||
|
||||
-- $catchall
|
||||
|
||||
-- ** The @catch@ functions
|
||||
catch,
|
||||
catches, Handler(..),
|
||||
catchJust,
|
||||
|
||||
-- ** The @handle@ functions
|
||||
handle,
|
||||
handleJust,
|
||||
|
||||
-- ** The @try@ functions
|
||||
try,
|
||||
tryJust,
|
||||
|
||||
-- ** The @evaluate@ function
|
||||
evaluate,
|
||||
|
||||
-- ** The @mapException@ function
|
||||
mapException,
|
||||
|
||||
-- * Asynchronous Exceptions
|
||||
|
||||
-- $async
|
||||
|
||||
-- ** Asynchronous exception control
|
||||
|
||||
-- |The following functions allow a thread to control delivery of
|
||||
-- asynchronous exceptions during a critical region.
|
||||
|
||||
mask,
|
||||
mask_,
|
||||
uninterruptibleMask,
|
||||
uninterruptibleMask_,
|
||||
MaskingState(..),
|
||||
getMaskingState,
|
||||
interruptible,
|
||||
allowInterrupt,
|
||||
|
||||
-- *** Applying @mask@ to an exception handler
|
||||
|
||||
-- $block_handler
|
||||
|
||||
-- *** Interruptible operations
|
||||
|
||||
-- $interruptible
|
||||
|
||||
-- * Assertions
|
||||
|
||||
assert,
|
||||
|
||||
-- * Utilities
|
||||
|
||||
bracket,
|
||||
bracket_,
|
||||
bracketOnError,
|
||||
|
||||
finally,
|
||||
onException,
|
||||
|
||||
) where
|
||||
|
||||
import Control.Exception.Base
|
||||
|
||||
import GHC.Base
|
||||
import GHC.IO (interruptible)
|
||||
|
||||
-- | You need this when using 'catches'.
|
||||
data Handler a = forall e . Exception e => Handler (e -> IO a)
|
||||
|
||||
-- | @since 4.6.0.0
|
||||
instance Functor Handler where
|
||||
fmap f (Handler h) = Handler (fmap f . h)
|
||||
|
||||
{- |
|
||||
Sometimes you want to catch two different sorts of exception. You could
|
||||
do something like
|
||||
|
||||
> f = expr `catch` \ (ex :: ArithException) -> handleArith ex
|
||||
> `catch` \ (ex :: IOException) -> handleIO ex
|
||||
|
||||
However, there are a couple of problems with this approach. The first is
|
||||
that having two exception handlers is inefficient. However, the more
|
||||
serious issue is that the second exception handler will catch exceptions
|
||||
in the first, e.g. in the example above, if @handleArith@ throws an
|
||||
@IOException@ then the second exception handler will catch it.
|
||||
|
||||
Instead, we provide a function 'catches', which would be used thus:
|
||||
|
||||
> f = expr `catches` [Handler (\ (ex :: ArithException) -> handleArith ex),
|
||||
> Handler (\ (ex :: IOException) -> handleIO ex)]
|
||||
-}
|
||||
catches :: IO a -> [Handler a] -> IO a
|
||||
catches io handlers = io `catch` catchesHandler handlers
|
||||
|
||||
catchesHandler :: [Handler a] -> SomeException -> IO a
|
||||
catchesHandler handlers e = foldr tryHandler (throw e) handlers
|
||||
where tryHandler (Handler handler) res
|
||||
= case fromException e of
|
||||
Just e' -> handler e'
|
||||
Nothing -> res
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Catching exceptions
|
||||
|
||||
{- $catching
|
||||
|
||||
There are several functions for catching and examining
|
||||
exceptions; all of them may only be used from within the
|
||||
'IO' monad.
|
||||
|
||||
Here's a rule of thumb for deciding which catch-style function to
|
||||
use:
|
||||
|
||||
* If you want to do some cleanup in the event that an exception
|
||||
is raised, use 'finally', 'bracket' or 'onException'.
|
||||
|
||||
* To recover after an exception and do something else, the best
|
||||
choice is to use one of the 'try' family.
|
||||
|
||||
* ... unless you are recovering from an asynchronous exception, in which
|
||||
case use 'catch' or 'catchJust'.
|
||||
|
||||
The difference between using 'try' and 'catch' for recovery is that in
|
||||
'catch' the handler is inside an implicit 'mask' (see \"Asynchronous
|
||||
Exceptions\") which is important when catching asynchronous
|
||||
exceptions, but when catching other kinds of exception it is
|
||||
unnecessary. Furthermore it is possible to accidentally stay inside
|
||||
the implicit 'mask' by tail-calling rather than returning from the
|
||||
handler, which is why we recommend using 'try' rather than 'catch' for
|
||||
ordinary exception recovery.
|
||||
|
||||
A typical use of 'tryJust' for recovery looks like this:
|
||||
|
||||
> do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME"
|
||||
> case r of
|
||||
> Left e -> ...
|
||||
> Right home -> ...
|
||||
|
||||
-}
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Asynchronous exceptions
|
||||
|
||||
-- | When invoked inside 'mask', this function allows a masked
|
||||
-- asynchronous exception to be raised, if one exists. It is
|
||||
-- equivalent to performing an interruptible operation (see
|
||||
-- #interruptible), but does not involve any actual blocking.
|
||||
--
|
||||
-- When called outside 'mask', or inside 'uninterruptibleMask', this
|
||||
-- function has no effect.
|
||||
--
|
||||
-- @since 4.4.0.0
|
||||
allowInterrupt :: IO ()
|
||||
allowInterrupt = interruptible $ return ()
|
||||
|
||||
{- $async
|
||||
|
||||
#AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
|
||||
external influences, and can be raised at any point during execution.
|
||||
'StackOverflow' and 'HeapOverflow' are two examples of
|
||||
system-generated asynchronous exceptions.
|
||||
|
||||
The primary source of asynchronous exceptions, however, is
|
||||
'throwTo':
|
||||
|
||||
> throwTo :: ThreadId -> Exception -> IO ()
|
||||
|
||||
'throwTo' (also 'Control.Concurrent.killThread') allows one
|
||||
running thread to raise an arbitrary exception in another thread. The
|
||||
exception is therefore asynchronous with respect to the target thread,
|
||||
which could be doing anything at the time it receives the exception.
|
||||
Great care should be taken with asynchronous exceptions; it is all too
|
||||
easy to introduce race conditions by the over zealous use of
|
||||
'throwTo'.
|
||||
-}
|
||||
|
||||
{- $block_handler
|
||||
There\'s an implied 'mask' around every exception handler in a call
|
||||
to one of the 'catch' family of functions. This is because that is
|
||||
what you want most of the time - it eliminates a common race condition
|
||||
in starting an exception handler, because there may be no exception
|
||||
handler on the stack to handle another exception if one arrives
|
||||
immediately. If asynchronous exceptions are masked on entering the
|
||||
handler, though, we have time to install a new exception handler
|
||||
before being interrupted. If this weren\'t the default, one would have
|
||||
to write something like
|
||||
|
||||
> mask $ \restore ->
|
||||
> catch (restore (...))
|
||||
> (\e -> handler)
|
||||
|
||||
If you need to unmask asynchronous exceptions again in the exception
|
||||
handler, @restore@ can be used there too.
|
||||
|
||||
Note that 'try' and friends /do not/ have a similar default, because
|
||||
there is no exception handler in this case. Don't use 'try' for
|
||||
recovering from an asynchronous exception.
|
||||
-}
|
||||
|
||||
{- $interruptible
|
||||
|
||||
#interruptible#
|
||||
Some operations are /interruptible/, which means that they can receive
|
||||
asynchronous exceptions even in the scope of a 'mask'. Any function
|
||||
which may itself block is defined as interruptible; this includes
|
||||
'Control.Concurrent.MVar.takeMVar'
|
||||
(but not 'Control.Concurrent.MVar.tryTakeMVar'),
|
||||
and most operations which perform
|
||||
some I\/O with the outside world. The reason for having
|
||||
interruptible operations is so that we can write things like
|
||||
|
||||
> mask $ \restore -> do
|
||||
> a <- takeMVar m
|
||||
> catch (restore (...))
|
||||
> (\e -> ...)
|
||||
|
||||
if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
|
||||
then this particular
|
||||
combination could lead to deadlock, because the thread itself would be
|
||||
blocked in a state where it can\'t receive any asynchronous exceptions.
|
||||
With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
|
||||
safe in the knowledge that the thread can receive exceptions right up
|
||||
until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
|
||||
Similar arguments apply for other interruptible operations like
|
||||
'System.IO.openFile'.
|
||||
|
||||
It is useful to think of 'mask' not as a way to completely prevent
|
||||
asynchronous exceptions, but as a way to switch from asynchronous mode
|
||||
to polling mode. The main difficulty with asynchronous
|
||||
exceptions is that they normally can occur anywhere, but within a
|
||||
'mask' an asynchronous exception is only raised by operations that are
|
||||
interruptible (or call other interruptible operations). In many cases
|
||||
these operations may themselves raise exceptions, such as I\/O errors,
|
||||
so the caller will usually be prepared to handle exceptions arising from the
|
||||
operation anyway. To perform an explicit poll for asynchronous exceptions
|
||||
inside 'mask', use 'allowInterrupt'.
|
||||
|
||||
Sometimes it is too onerous to handle exceptions in the middle of a
|
||||
critical piece of stateful code. There are three ways to handle this
|
||||
kind of situation:
|
||||
|
||||
* Use STM. Since a transaction is always either completely executed
|
||||
or not at all, transactions are a good way to maintain invariants
|
||||
over state in the presence of asynchronous (and indeed synchronous)
|
||||
exceptions.
|
||||
|
||||
* Use 'mask', and avoid interruptible operations. In order to do
|
||||
this, we have to know which operations are interruptible. It is
|
||||
impossible to know for any given library function whether it might
|
||||
invoke an interruptible operation internally; so instead we give a
|
||||
list of guaranteed-not-to-be-interruptible operations below.
|
||||
|
||||
* Use 'uninterruptibleMask'. This is generally not recommended,
|
||||
unless you can guarantee that any interruptible operations invoked
|
||||
during the scope of 'uninterruptibleMask' can only ever block for
|
||||
a short time. Otherwise, 'uninterruptibleMask' is a good way to
|
||||
make your program deadlock and be unresponsive to user interrupts.
|
||||
|
||||
The following operations are guaranteed not to be interruptible:
|
||||
|
||||
* operations on 'Data.IORef.IORef' from "Data.IORef"
|
||||
|
||||
* STM transactions that do not use 'GHC.Conc.retry'
|
||||
|
||||
* everything from the @Foreign@ modules
|
||||
|
||||
* everything from "Control.Exception" except for 'throwTo'
|
||||
|
||||
* 'Control.Concurrent.MVar.tryTakeMVar', 'Control.Concurrent.MVar.tryPutMVar',
|
||||
'Control.Concurrent.MVar.isEmptyMVar'
|
||||
|
||||
* 'Control.Concurrent.MVar.takeMVar' if the 'Control.Concurrent.MVar.MVar' is
|
||||
definitely full, and conversely 'Control.Concurrent.MVar.putMVar' if the
|
||||
'Control.Concurrent.MVar.MVar' is definitely empty
|
||||
|
||||
* 'Control.Concurrent.MVar.newEmptyMVar', 'Control.Concurrent.MVar.newMVar'
|
||||
|
||||
* 'Control.Concurrent.forkIO', 'Control.Concurrent.myThreadId'
|
||||
|
||||
-}
|
||||
|
||||
{- $catchall
|
||||
|
||||
It is possible to catch all exceptions, by using the type 'SomeException':
|
||||
|
||||
> catch f (\e -> ... (e :: SomeException) ...)
|
||||
|
||||
HOWEVER, this is normally not what you want to do!
|
||||
|
||||
For example, suppose you want to read a file, but if it doesn't exist
|
||||
then continue as if it contained \"\". You might be tempted to just
|
||||
catch all exceptions and return \"\" in the handler. However, this has
|
||||
all sorts of undesirable consequences. For example, if the user
|
||||
presses control-C at just the right moment then the 'UserInterrupt'
|
||||
exception will be caught, and the program will continue running under
|
||||
the belief that the file contains \"\". Similarly, if another thread
|
||||
tries to kill the thread reading the file then the 'ThreadKilled'
|
||||
exception will be ignored.
|
||||
|
||||
Instead, you should only catch exactly the exceptions that you really
|
||||
want. In this case, this would likely be more specific than even
|
||||
\"any IO exception\"; a permissions error would likely also want to be
|
||||
handled differently. Instead, you would probably want something like:
|
||||
|
||||
> e <- tryJust (guard . isDoesNotExistError) (readFile f)
|
||||
> let str = either (const "") id e
|
||||
|
||||
There are occasions when you really do need to catch any sort of
|
||||
exception. However, in most cases this is just so you can do some
|
||||
cleaning up; you aren't actually interested in the exception itself.
|
||||
For example, if you open a file then you want to close it again,
|
||||
whether processing the file executes normally or throws an exception.
|
||||
However, in these cases you can use functions like 'bracket', 'finally'
|
||||
and 'onException', which never actually pass you the exception, but
|
||||
just call the cleanup functions at the appropriate points.
|
||||
|
||||
But sometimes you really do need to catch any exception, and actually
|
||||
see what the exception is. One example is at the very top-level of a
|
||||
program, you may wish to catch any exception, print it to a logfile or
|
||||
the screen, and then exit gracefully. For these cases, you can use
|
||||
'catch' (or one of the other exception-catching functions) with the
|
||||
'SomeException' type.
|
||||
-}
|
||||
|
@ -1,404 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Exception.Base
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (extended exceptions)
|
||||
--
|
||||
-- Extensible exceptions, except for multiple handlers.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Exception.Base (
|
||||
|
||||
-- * The Exception type
|
||||
SomeException(..),
|
||||
Exception(..),
|
||||
IOException,
|
||||
ArithException(..),
|
||||
ArrayException(..),
|
||||
AssertionFailed(..),
|
||||
SomeAsyncException(..), AsyncException(..),
|
||||
asyncExceptionToException, asyncExceptionFromException,
|
||||
NonTermination(..),
|
||||
NestedAtomically(..),
|
||||
BlockedIndefinitelyOnMVar(..),
|
||||
FixIOException (..),
|
||||
BlockedIndefinitelyOnSTM(..),
|
||||
AllocationLimitExceeded(..),
|
||||
CompactionFailed(..),
|
||||
Deadlock(..),
|
||||
NoMethodError(..),
|
||||
PatternMatchFail(..),
|
||||
RecConError(..),
|
||||
RecSelError(..),
|
||||
RecUpdError(..),
|
||||
ErrorCall(..),
|
||||
TypeError(..), -- #10284, custom error type for deferred type errors
|
||||
|
||||
-- * Throwing exceptions
|
||||
throwIO,
|
||||
throw,
|
||||
ioError,
|
||||
throwTo,
|
||||
|
||||
-- * Catching Exceptions
|
||||
|
||||
-- ** The @catch@ functions
|
||||
catch,
|
||||
catchJust,
|
||||
|
||||
-- ** The @handle@ functions
|
||||
handle,
|
||||
handleJust,
|
||||
|
||||
-- ** The @try@ functions
|
||||
try,
|
||||
tryJust,
|
||||
onException,
|
||||
|
||||
-- ** The @evaluate@ function
|
||||
evaluate,
|
||||
|
||||
-- ** The @mapException@ function
|
||||
mapException,
|
||||
|
||||
-- * Asynchronous Exceptions
|
||||
|
||||
-- ** Asynchronous exception control
|
||||
mask,
|
||||
mask_,
|
||||
uninterruptibleMask,
|
||||
uninterruptibleMask_,
|
||||
MaskingState(..),
|
||||
getMaskingState,
|
||||
|
||||
-- * Assertions
|
||||
|
||||
assert,
|
||||
|
||||
-- * Utilities
|
||||
|
||||
bracket,
|
||||
bracket_,
|
||||
bracketOnError,
|
||||
|
||||
finally,
|
||||
|
||||
-- * Calls for GHC runtime
|
||||
recSelError, recConError, runtimeError,
|
||||
nonExhaustiveGuardsError, patError, noMethodBindingError,
|
||||
absentError, absentSumFieldError, typeError,
|
||||
nonTermination, nestedAtomically,
|
||||
) where
|
||||
|
||||
import GHC.Base
|
||||
import GHC.IO hiding (bracket,finally,onException)
|
||||
import GHC.IO.Exception
|
||||
import GHC.Exception
|
||||
import GHC.Show
|
||||
-- import GHC.Exception hiding ( Exception )
|
||||
import GHC.Conc.Sync
|
||||
|
||||
import Data.Either
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- Catching exceptions
|
||||
|
||||
-- | The function 'catchJust' is like 'catch', but it takes an extra
|
||||
-- argument which is an /exception predicate/, a function which
|
||||
-- selects which type of exceptions we\'re interested in.
|
||||
--
|
||||
-- > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing)
|
||||
-- > (readFile f)
|
||||
-- > (\_ -> do hPutStrLn stderr ("No such file: " ++ show f)
|
||||
-- > return "")
|
||||
--
|
||||
-- Any other exceptions which are not matched by the predicate
|
||||
-- are re-raised, and may be caught by an enclosing
|
||||
-- 'catch', 'catchJust', etc.
|
||||
catchJust
|
||||
:: Exception e
|
||||
=> (e -> Maybe b) -- ^ Predicate to select exceptions
|
||||
-> IO a -- ^ Computation to run
|
||||
-> (b -> IO a) -- ^ Handler
|
||||
-> IO a
|
||||
catchJust p a handler = catch a handler'
|
||||
where handler' e = case p e of
|
||||
Nothing -> throwIO e
|
||||
Just b -> handler b
|
||||
|
||||
-- | A version of 'catch' with the arguments swapped around; useful in
|
||||
-- situations where the code for the handler is shorter. For example:
|
||||
--
|
||||
-- > do handle (\NonTermination -> exitWith (ExitFailure 1)) $
|
||||
-- > ...
|
||||
handle :: Exception e => (e -> IO a) -> IO a -> IO a
|
||||
handle = flip catch
|
||||
|
||||
-- | A version of 'catchJust' with the arguments swapped around (see
|
||||
-- 'handle').
|
||||
handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
|
||||
handleJust p = flip (catchJust p)
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- 'mapException'
|
||||
|
||||
-- | This function maps one exception into another as proposed in the
|
||||
-- paper \"A semantics for imprecise exceptions\".
|
||||
|
||||
-- Notice that the usage of 'unsafePerformIO' is safe here.
|
||||
|
||||
mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a
|
||||
mapException f v = unsafePerformIO (catch (evaluate v)
|
||||
(\x -> throwIO (f x)))
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- 'try' and variations.
|
||||
|
||||
-- | Similar to 'catch', but returns an 'Either' result which is
|
||||
-- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@
|
||||
-- if an exception of type @e@ was raised and its value is @ex@.
|
||||
-- If any other type of exception is raised than it will be propogated
|
||||
-- up to the next enclosing exception handler.
|
||||
--
|
||||
-- > try a = catch (Right `liftM` a) (return . Left)
|
||||
|
||||
try :: Exception e => IO a -> IO (Either e a)
|
||||
try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
|
||||
|
||||
-- | A variant of 'try' that takes an exception predicate to select
|
||||
-- which exceptions are caught (c.f. 'catchJust'). If the exception
|
||||
-- does not match the predicate, it is re-thrown.
|
||||
tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)
|
||||
tryJust p a = do
|
||||
r <- try a
|
||||
case r of
|
||||
Right v -> return (Right v)
|
||||
Left e -> case p e of
|
||||
Nothing -> throwIO e
|
||||
Just b -> return (Left b)
|
||||
|
||||
-- | Like 'finally', but only performs the final action if there was an
|
||||
-- exception raised by the computation.
|
||||
onException :: IO a -> IO b -> IO a
|
||||
onException io what = io `catch` \e -> do _ <- what
|
||||
throwIO (e :: SomeException)
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- Some Useful Functions
|
||||
|
||||
-- | When you want to acquire a resource, do some work with it, and
|
||||
-- then release the resource, it is a good idea to use 'bracket',
|
||||
-- because 'bracket' will install the necessary exception handler to
|
||||
-- release the resource in the event that an exception is raised
|
||||
-- during the computation. If an exception is raised, then 'bracket' will
|
||||
-- re-raise the exception (after performing the release).
|
||||
--
|
||||
-- A common example is opening a file:
|
||||
--
|
||||
-- > bracket
|
||||
-- > (openFile "filename" ReadMode)
|
||||
-- > (hClose)
|
||||
-- > (\fileHandle -> do { ... })
|
||||
--
|
||||
-- The arguments to 'bracket' are in this order so that we can partially apply
|
||||
-- it, e.g.:
|
||||
--
|
||||
-- > withFile name mode = bracket (openFile name mode) hClose
|
||||
--
|
||||
bracket
|
||||
:: IO a -- ^ computation to run first (\"acquire resource\")
|
||||
-> (a -> IO b) -- ^ computation to run last (\"release resource\")
|
||||
-> (a -> IO c) -- ^ computation to run in-between
|
||||
-> IO c -- returns the value from the in-between computation
|
||||
bracket before after thing =
|
||||
mask $ \restore -> do
|
||||
a <- before
|
||||
r <- restore (thing a) `onException` after a
|
||||
_ <- after a
|
||||
return r
|
||||
|
||||
-- | A specialised variant of 'bracket' with just a computation to run
|
||||
-- afterward.
|
||||
--
|
||||
finally :: IO a -- ^ computation to run first
|
||||
-> IO b -- ^ computation to run afterward (even if an exception
|
||||
-- was raised)
|
||||
-> IO a -- returns the value from the first computation
|
||||
a `finally` sequel =
|
||||
mask $ \restore -> do
|
||||
r <- restore a `onException` sequel
|
||||
_ <- sequel
|
||||
return r
|
||||
|
||||
-- | A variant of 'bracket' where the return value from the first computation
|
||||
-- is not required.
|
||||
bracket_ :: IO a -> IO b -> IO c -> IO c
|
||||
bracket_ before after thing = bracket before (const after) (const thing)
|
||||
|
||||
-- | Like 'bracket', but only performs the final action if there was an
|
||||
-- exception raised by the in-between computation.
|
||||
bracketOnError
|
||||
:: IO a -- ^ computation to run first (\"acquire resource\")
|
||||
-> (a -> IO b) -- ^ computation to run last (\"release resource\")
|
||||
-> (a -> IO c) -- ^ computation to run in-between
|
||||
-> IO c -- returns the value from the in-between computation
|
||||
bracketOnError before after thing =
|
||||
mask $ \restore -> do
|
||||
a <- before
|
||||
restore (thing a) `onException` after a
|
||||
|
||||
-----
|
||||
|
||||
-- |A pattern match failed. The @String@ gives information about the
|
||||
-- source location of the pattern.
|
||||
newtype PatternMatchFail = PatternMatchFail String
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show PatternMatchFail where
|
||||
showsPrec _ (PatternMatchFail err) = showString err
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception PatternMatchFail
|
||||
|
||||
-----
|
||||
|
||||
-- |A record selector was applied to a constructor without the
|
||||
-- appropriate field. This can only happen with a datatype with
|
||||
-- multiple constructors, where some fields are in one constructor
|
||||
-- but not another. The @String@ gives information about the source
|
||||
-- location of the record selector.
|
||||
newtype RecSelError = RecSelError String
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show RecSelError where
|
||||
showsPrec _ (RecSelError err) = showString err
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception RecSelError
|
||||
|
||||
-----
|
||||
|
||||
-- |An uninitialised record field was used. The @String@ gives
|
||||
-- information about the source location where the record was
|
||||
-- constructed.
|
||||
newtype RecConError = RecConError String
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show RecConError where
|
||||
showsPrec _ (RecConError err) = showString err
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception RecConError
|
||||
|
||||
-----
|
||||
|
||||
-- |A record update was performed on a constructor without the
|
||||
-- appropriate field. This can only happen with a datatype with
|
||||
-- multiple constructors, where some fields are in one constructor
|
||||
-- but not another. The @String@ gives information about the source
|
||||
-- location of the record update.
|
||||
newtype RecUpdError = RecUpdError String
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show RecUpdError where
|
||||
showsPrec _ (RecUpdError err) = showString err
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception RecUpdError
|
||||
|
||||
-----
|
||||
|
||||
-- |A class method without a definition (neither a default definition,
|
||||
-- nor a definition in the appropriate instance) was called. The
|
||||
-- @String@ gives information about which method it was.
|
||||
newtype NoMethodError = NoMethodError String
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show NoMethodError where
|
||||
showsPrec _ (NoMethodError err) = showString err
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception NoMethodError
|
||||
|
||||
-----
|
||||
|
||||
-- |An expression that didn't typecheck during compile time was called.
|
||||
-- This is only possible with -fdefer-type-errors. The @String@ gives
|
||||
-- details about the failed type check.
|
||||
--
|
||||
-- @since 4.9.0.0
|
||||
newtype TypeError = TypeError String
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance Show TypeError where
|
||||
showsPrec _ (TypeError err) = showString err
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance Exception TypeError
|
||||
|
||||
-----
|
||||
|
||||
-- |Thrown when the runtime system detects that the computation is
|
||||
-- guaranteed not to terminate. Note that there is no guarantee that
|
||||
-- the runtime system will notice whether any given computation is
|
||||
-- guaranteed to terminate or not.
|
||||
data NonTermination = NonTermination
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show NonTermination where
|
||||
showsPrec _ NonTermination = showString "<<loop>>"
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception NonTermination
|
||||
|
||||
-----
|
||||
|
||||
-- |Thrown when the program attempts to call @atomically@, from the @stm@
|
||||
-- package, inside another call to @atomically@.
|
||||
data NestedAtomically = NestedAtomically
|
||||
|
||||
-- | @since 4.0
|
||||
instance Show NestedAtomically where
|
||||
showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"
|
||||
|
||||
-- | @since 4.0
|
||||
instance Exception NestedAtomically
|
||||
|
||||
-----
|
||||
|
||||
recSelError, recConError, runtimeError,
|
||||
nonExhaustiveGuardsError, patError, noMethodBindingError,
|
||||
absentError, typeError
|
||||
:: Addr# -> a -- All take a UTF8-encoded C string
|
||||
|
||||
recSelError s = throw (RecSelError ("No match in record selector "
|
||||
++ unpackCStringUtf8# s)) -- No location info unfortunately
|
||||
runtimeError s = errorWithoutStackTrace (unpackCStringUtf8# s) -- No location info unfortunately
|
||||
absentError s = errorWithoutStackTrace ("Oops! Entered absent arg " ++ unpackCStringUtf8# s)
|
||||
|
||||
nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
|
||||
recConError s = throw (RecConError (untangle s "Missing field in record construction"))
|
||||
noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
|
||||
patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
|
||||
typeError s = throw (TypeError (unpackCStringUtf8# s))
|
||||
|
||||
-- GHC's RTS calls this
|
||||
nonTermination :: SomeException
|
||||
nonTermination = toException NonTermination
|
||||
|
||||
-- GHC's RTS calls this
|
||||
nestedAtomically :: SomeException
|
||||
nestedAtomically = toException NestedAtomically
|
||||
|
||||
-- Introduced by unarise for unused unboxed sum fields
|
||||
absentSumFieldError :: a
|
||||
absentSumFieldError = absentError " in unboxed sum."#
|
@ -1,360 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Monad
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- The 'Functor', 'Monad' and 'MonadPlus' classes,
|
||||
-- with some useful operations on monads.
|
||||
|
||||
module Control.Monad
|
||||
(
|
||||
-- * Functor and monad classes
|
||||
|
||||
Functor(fmap)
|
||||
, Monad((>>=), (>>), return)
|
||||
, MonadFail(fail)
|
||||
, MonadPlus(mzero, mplus)
|
||||
-- * Functions
|
||||
|
||||
-- ** Naming conventions
|
||||
-- $naming
|
||||
|
||||
-- ** Basic @Monad@ functions
|
||||
|
||||
, mapM
|
||||
, mapM_
|
||||
, forM
|
||||
, forM_
|
||||
, sequence
|
||||
, sequence_
|
||||
, (=<<)
|
||||
, (>=>)
|
||||
, (<=<)
|
||||
, forever
|
||||
, void
|
||||
|
||||
-- ** Generalisations of list functions
|
||||
|
||||
, join
|
||||
, msum
|
||||
, mfilter
|
||||
, filterM
|
||||
, mapAndUnzipM
|
||||
, zipWithM
|
||||
, zipWithM_
|
||||
, foldM
|
||||
, foldM_
|
||||
, replicateM
|
||||
, replicateM_
|
||||
|
||||
-- ** Conditional execution of monadic expressions
|
||||
|
||||
, guard
|
||||
, when
|
||||
, unless
|
||||
|
||||
-- ** Monadic lifting operators
|
||||
|
||||
, liftM
|
||||
, liftM2
|
||||
, liftM3
|
||||
, liftM4
|
||||
, liftM5
|
||||
|
||||
, ap
|
||||
|
||||
-- ** Strict monadic functions
|
||||
|
||||
, (<$!>)
|
||||
) where
|
||||
|
||||
import Control.Monad.Fail ( MonadFail(fail) )
|
||||
import Data.Foldable ( Foldable, sequence_, sequenceA_, msum, mapM_, foldlM, forM_ )
|
||||
import Data.Functor ( void, (<$>) )
|
||||
import Data.Traversable ( forM, mapM, traverse, sequence, sequenceA )
|
||||
|
||||
import GHC.Base hiding ( mapM, sequence )
|
||||
import GHC.List ( zipWith, unzip )
|
||||
import GHC.Num ( (-) )
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Functions mandated by the Prelude
|
||||
|
||||
-- | Conditional failure of 'Alternative' computations. Defined by
|
||||
--
|
||||
-- @
|
||||
-- guard True = 'pure' ()
|
||||
-- guard False = 'empty'
|
||||
-- @
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- Common uses of 'guard' include conditionally signaling an error in
|
||||
-- an error monad and conditionally rejecting the current choice in an
|
||||
-- 'Alternative'-based parser.
|
||||
--
|
||||
-- As an example of signaling an error in the error monad 'Maybe',
|
||||
-- consider a safe division function @safeDiv x y@ that returns
|
||||
-- 'Nothing' when the denominator @y@ is zero and @'Just' (x \`div\`
|
||||
-- y)@ otherwise. For example:
|
||||
--
|
||||
-- @
|
||||
-- >>> safeDiv 4 0
|
||||
-- Nothing
|
||||
-- >>> safeDiv 4 2
|
||||
-- Just 2
|
||||
-- @
|
||||
--
|
||||
-- A definition of @safeDiv@ using guards, but not 'guard':
|
||||
--
|
||||
-- @
|
||||
-- safeDiv :: Int -> Int -> Maybe Int
|
||||
-- safeDiv x y | y /= 0 = Just (x \`div\` y)
|
||||
-- | otherwise = Nothing
|
||||
-- @
|
||||
--
|
||||
-- A definition of @safeDiv@ using 'guard' and 'Monad' @do@-notation:
|
||||
--
|
||||
-- @
|
||||
-- safeDiv :: Int -> Int -> Maybe Int
|
||||
-- safeDiv x y = do
|
||||
-- guard (y /= 0)
|
||||
-- return (x \`div\` y)
|
||||
-- @
|
||||
guard :: (Alternative f) => Bool -> f ()
|
||||
guard True = pure ()
|
||||
guard False = empty
|
||||
|
||||
-- | This generalizes the list-based 'Data.List.filter' function.
|
||||
|
||||
{-# INLINE filterM #-}
|
||||
filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a]
|
||||
filterM p = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x)) (pure [])
|
||||
|
||||
infixr 1 <=<, >=>
|
||||
|
||||
-- | Left-to-right composition of Kleisli arrows.
|
||||
(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
|
||||
f >=> g = \x -> f x >>= g
|
||||
|
||||
-- | Right-to-left composition of Kleisli arrows. @('>=>')@, with the arguments
|
||||
-- flipped.
|
||||
--
|
||||
-- Note how this operator resembles function composition @('.')@:
|
||||
--
|
||||
-- > (.) :: (b -> c) -> (a -> b) -> a -> c
|
||||
-- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c
|
||||
(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
|
||||
(<=<) = flip (>=>)
|
||||
|
||||
-- | Repeat an action indefinitely.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- A common use of 'forever' is to process input from network sockets,
|
||||
-- 'System.IO.Handle's, and channels
|
||||
-- (e.g. 'Control.Concurrent.MVar.MVar' and
|
||||
-- 'Control.Concurrent.Chan.Chan').
|
||||
--
|
||||
-- For example, here is how we might implement an [echo
|
||||
-- server](https://en.wikipedia.org/wiki/Echo_Protocol), using
|
||||
-- 'forever' both to listen for client connections on a network socket
|
||||
-- and to echo client input on client connection handles:
|
||||
--
|
||||
-- @
|
||||
-- echoServer :: Socket -> IO ()
|
||||
-- echoServer socket = 'forever' $ do
|
||||
-- client <- accept socket
|
||||
-- 'Control.Concurrent.forkFinally' (echo client) (\\_ -> hClose client)
|
||||
-- where
|
||||
-- echo :: Handle -> IO ()
|
||||
-- echo client = 'forever' $
|
||||
-- hGetLine client >>= hPutStrLn client
|
||||
-- @
|
||||
forever :: (Applicative f) => f a -> f b
|
||||
{-# INLINE forever #-}
|
||||
forever a = let a' = a *> a' in a'
|
||||
-- Use explicit sharing here, as it prevents a space leak regardless of
|
||||
-- optimizations.
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Other monad functions
|
||||
|
||||
-- | The 'mapAndUnzipM' function maps its first argument over a list, returning
|
||||
-- the result as a pair of lists. This function is mainly used with complicated
|
||||
-- data structures or a state monad.
|
||||
mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
|
||||
{-# INLINE mapAndUnzipM #-}
|
||||
mapAndUnzipM f xs = unzip <$> traverse f xs
|
||||
|
||||
-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary applicative functors.
|
||||
zipWithM :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
|
||||
{-# INLINE zipWithM #-}
|
||||
zipWithM f xs ys = sequenceA (zipWith f xs ys)
|
||||
|
||||
-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.
|
||||
zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m ()
|
||||
{-# INLINE zipWithM_ #-}
|
||||
zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys)
|
||||
|
||||
{- | The 'foldM' function is analogous to 'Data.Foldable.foldl', except that its result is
|
||||
encapsulated in a monad. Note that 'foldM' works from left-to-right over
|
||||
the list arguments. This could be an issue where @('>>')@ and the `folded
|
||||
function' are not commutative.
|
||||
|
||||
|
||||
> foldM f a1 [x1, x2, ..., xm]
|
||||
>
|
||||
> ==
|
||||
>
|
||||
> do
|
||||
> a2 <- f a1 x1
|
||||
> a3 <- f a2 x2
|
||||
> ...
|
||||
> f am xm
|
||||
|
||||
If right-to-left evaluation is required, the input list should be reversed.
|
||||
|
||||
Note: 'foldM' is the same as 'foldlM'
|
||||
-}
|
||||
|
||||
foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
|
||||
{-# INLINABLE foldM #-}
|
||||
{-# SPECIALISE foldM :: (a -> b -> IO a) -> a -> [b] -> IO a #-}
|
||||
{-# SPECIALISE foldM :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a #-}
|
||||
foldM = foldlM
|
||||
|
||||
-- | Like 'foldM', but discards the result.
|
||||
foldM_ :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m ()
|
||||
{-# INLINABLE foldM_ #-}
|
||||
{-# SPECIALISE foldM_ :: (a -> b -> IO a) -> a -> [b] -> IO () #-}
|
||||
{-# SPECIALISE foldM_ :: (a -> b -> Maybe a) -> a -> [b] -> Maybe () #-}
|
||||
foldM_ f a xs = foldlM f a xs >> return ()
|
||||
|
||||
{-
|
||||
Note [Worker/wrapper transform on replicateM/replicateM_]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
The implementations of replicateM and replicateM_ both leverage the
|
||||
worker/wrapper transform. The simpler implementation of replicateM_, as an
|
||||
example, would be:
|
||||
|
||||
replicateM_ 0 _ = pure ()
|
||||
replicateM_ n f = f *> replicateM_ (n - 1) f
|
||||
|
||||
However, the self-recursive nature of this implementation inhibits inlining,
|
||||
which means we never get to specialise to the action (`f` in the code above).
|
||||
By contrast, the implementation below with a local loop makes it possible to
|
||||
inline the entire definition (as happens for foldr, for example) thereby
|
||||
specialising for the particular action.
|
||||
|
||||
For further information, see this Trac comment, which includes side-by-side
|
||||
Core: https://ghc.haskell.org/trac/ghc/ticket/11795#comment:6
|
||||
-}
|
||||
|
||||
-- | @'replicateM' n act@ performs the action @n@ times,
|
||||
-- gathering the results.
|
||||
replicateM :: (Applicative m) => Int -> m a -> m [a]
|
||||
{-# INLINABLE replicateM #-}
|
||||
{-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-}
|
||||
{-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-}
|
||||
replicateM cnt0 f =
|
||||
loop cnt0
|
||||
where
|
||||
loop cnt
|
||||
| cnt <= 0 = pure []
|
||||
| otherwise = liftA2 (:) f (loop (cnt - 1))
|
||||
|
||||
-- | Like 'replicateM', but discards the result.
|
||||
replicateM_ :: (Applicative m) => Int -> m a -> m ()
|
||||
{-# INLINABLE replicateM_ #-}
|
||||
{-# SPECIALISE replicateM_ :: Int -> IO a -> IO () #-}
|
||||
{-# SPECIALISE replicateM_ :: Int -> Maybe a -> Maybe () #-}
|
||||
replicateM_ cnt0 f =
|
||||
loop cnt0
|
||||
where
|
||||
loop cnt
|
||||
| cnt <= 0 = pure ()
|
||||
| otherwise = f *> loop (cnt - 1)
|
||||
|
||||
|
||||
-- | The reverse of 'when'.
|
||||
unless :: (Applicative f) => Bool -> f () -> f ()
|
||||
{-# INLINABLE unless #-}
|
||||
{-# SPECIALISE unless :: Bool -> IO () -> IO () #-}
|
||||
{-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-}
|
||||
unless p s = if p then pure () else s
|
||||
|
||||
infixl 4 <$!>
|
||||
|
||||
-- | Strict version of 'Data.Functor.<$>'.
|
||||
--
|
||||
-- @since 4.8.0.0
|
||||
(<$!>) :: Monad m => (a -> b) -> m a -> m b
|
||||
{-# INLINE (<$!>) #-}
|
||||
f <$!> m = do
|
||||
x <- m
|
||||
let z = f x
|
||||
z `seq` return z
|
||||
|
||||
|
||||
-- -----------------------------------------------------------------------------
|
||||
-- Other MonadPlus functions
|
||||
|
||||
-- | Direct 'MonadPlus' equivalent of 'Data.List.filter'.
|
||||
--
|
||||
-- ==== __Examples__
|
||||
--
|
||||
-- The 'Data.List.filter' function is just 'mfilter' specialized to
|
||||
-- the list monad:
|
||||
--
|
||||
-- @
|
||||
-- 'Data.List.filter' = ( 'mfilter' :: (a -> Bool) -> [a] -> [a] )
|
||||
-- @
|
||||
--
|
||||
-- An example using 'mfilter' with the 'Maybe' monad:
|
||||
--
|
||||
-- @
|
||||
-- >>> mfilter odd (Just 1)
|
||||
-- Just 1
|
||||
-- >>> mfilter odd (Just 2)
|
||||
-- Nothing
|
||||
-- @
|
||||
mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a
|
||||
{-# INLINABLE mfilter #-}
|
||||
mfilter p ma = do
|
||||
a <- ma
|
||||
if p a then return a else mzero
|
||||
|
||||
{- $naming
|
||||
|
||||
The functions in this library use the following naming conventions:
|
||||
|
||||
* A postfix \'@M@\' always stands for a function in the Kleisli category:
|
||||
The monad type constructor @m@ is added to function results
|
||||
(modulo currying) and nowhere else. So, for example,
|
||||
|
||||
> filter :: (a -> Bool) -> [a] -> [a]
|
||||
> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
|
||||
|
||||
* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.
|
||||
Thus, for example:
|
||||
|
||||
> sequence :: Monad m => [m a] -> m [a]
|
||||
> sequence_ :: Monad m => [m a] -> m ()
|
||||
|
||||
* A prefix \'@m@\' generalizes an existing function to a monadic form.
|
||||
Thus, for example:
|
||||
|
||||
> filter :: (a -> Bool) -> [a] -> [a]
|
||||
> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a
|
||||
|
||||
-}
|
@ -1,81 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
-- |
|
||||
-- Module : Control.Monad.Fail
|
||||
-- Copyright : (C) 2015 David Luposchainsky,
|
||||
-- (C) 2015 Herbert Valerio Riedel
|
||||
-- License : BSD-style (see the file LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Transitional module providing the 'MonadFail' class and primitive
|
||||
-- instances.
|
||||
--
|
||||
-- This module can be imported for defining forward compatible
|
||||
-- 'MonadFail' instances:
|
||||
--
|
||||
-- @
|
||||
-- import qualified Control.Monad.Fail as Fail
|
||||
--
|
||||
-- instance Monad Foo where
|
||||
-- (>>=) = {- ...bind impl... -}
|
||||
--
|
||||
-- -- Provide legacy 'fail' implementation for when
|
||||
-- -- new-style MonadFail desugaring is not enabled.
|
||||
-- fail = Fail.fail
|
||||
--
|
||||
-- instance Fail.MonadFail Foo where
|
||||
-- fail = {- ...fail implementation... -}
|
||||
-- @
|
||||
--
|
||||
-- See <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>
|
||||
-- for more details.
|
||||
--
|
||||
-- @since 4.9.0.0
|
||||
--
|
||||
module Control.Monad.Fail ( MonadFail(fail) ) where
|
||||
|
||||
import GHC.Base (String, Monad(), Maybe(Nothing), IO())
|
||||
import {-# SOURCE #-} GHC.IO (failIO)
|
||||
|
||||
-- | When a value is bound in @do@-notation, the pattern on the left
|
||||
-- hand side of @<-@ might not match. In this case, this class
|
||||
-- provides a function to recover.
|
||||
--
|
||||
-- A 'Monad' without a 'MonadFail' instance may only be used in conjunction
|
||||
-- with pattern that always match, such as newtypes, tuples, data types with
|
||||
-- only a single data constructor, and irrefutable patterns (@~pat@).
|
||||
--
|
||||
-- Instances of 'MonadFail' should satisfy the following law: @fail s@ should
|
||||
-- be a left zero for 'Control.Monad.>>=',
|
||||
--
|
||||
-- @
|
||||
-- fail s >>= f = fail s
|
||||
-- @
|
||||
--
|
||||
-- If your 'Monad' is also 'Control.Monad.MonadPlus', a popular definition is
|
||||
--
|
||||
-- @
|
||||
-- fail _ = mzero
|
||||
-- @
|
||||
--
|
||||
-- @since 4.9.0.0
|
||||
class Monad m => MonadFail m where
|
||||
fail :: String -> m a
|
||||
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFail Maybe where
|
||||
fail _ = Nothing
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFail [] where
|
||||
{-# INLINE fail #-}
|
||||
fail _ = []
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFail IO where
|
||||
fail = failIO
|
@ -1,159 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Monad.Fix
|
||||
-- Copyright : (c) Andy Gill 2001,
|
||||
-- (c) Oregon Graduate Institute of Science and Technology, 2002
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Monadic fixpoints.
|
||||
--
|
||||
-- For a detailed discussion, see Levent Erkok's thesis,
|
||||
-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Monad.Fix (
|
||||
MonadFix(mfix),
|
||||
fix
|
||||
) where
|
||||
|
||||
import Data.Either
|
||||
import Data.Function ( fix )
|
||||
import Data.Maybe
|
||||
import Data.Monoid ( Dual(..), Sum(..), Product(..)
|
||||
, First(..), Last(..), Alt(..), Ap(..) )
|
||||
import Data.Ord ( Down(..) )
|
||||
import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) )
|
||||
import GHC.Generics
|
||||
import GHC.List ( head, tail )
|
||||
import Control.Monad.ST.Imp
|
||||
import System.IO
|
||||
|
||||
-- | Monads having fixed points with a \'knot-tying\' semantics.
|
||||
-- Instances of 'MonadFix' should satisfy the following laws:
|
||||
--
|
||||
-- [Purity]
|
||||
-- @'mfix' ('Control.Monad.return' . h) = 'Control.Monad.return' ('fix' h)@
|
||||
--
|
||||
-- [Left shrinking (or Tightening)]
|
||||
-- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@
|
||||
--
|
||||
-- [Sliding]
|
||||
-- @'mfix' ('Control.Monad.liftM' h . f) = 'Control.Monad.liftM' h ('mfix' (f . h))@,
|
||||
-- for strict @h@.
|
||||
--
|
||||
-- [Nesting]
|
||||
-- @'mfix' (\\x -> 'mfix' (\\y -> f x y)) = 'mfix' (\\x -> f x x)@
|
||||
--
|
||||
-- This class is used in the translation of the recursive @do@ notation
|
||||
-- supported by GHC and Hugs.
|
||||
class (Monad m) => MonadFix m where
|
||||
-- | The fixed point of a monadic computation.
|
||||
-- @'mfix' f@ executes the action @f@ only once, with the eventual
|
||||
-- output fed back as the input. Hence @f@ should not be strict,
|
||||
-- for then @'mfix' f@ would diverge.
|
||||
mfix :: (a -> m a) -> m a
|
||||
|
||||
-- Instances of MonadFix for Prelude monads
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadFix Maybe where
|
||||
mfix f = let a = f (unJust a) in a
|
||||
where unJust (Just x) = x
|
||||
unJust Nothing = errorWithoutStackTrace "mfix Maybe: Nothing"
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadFix [] where
|
||||
mfix f = case fix (f . head) of
|
||||
[] -> []
|
||||
(x:_) -> x : mfix (tail . f)
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFix NonEmpty where
|
||||
mfix f = case fix (f . neHead) of
|
||||
~(x :| _) -> x :| mfix (neTail . f)
|
||||
where
|
||||
neHead ~(a :| _) = a
|
||||
neTail ~(_ :| as) = as
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadFix IO where
|
||||
mfix = fixIO
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadFix ((->) r) where
|
||||
mfix f = \ r -> let a = f a r in a
|
||||
|
||||
-- | @since 4.3.0.0
|
||||
instance MonadFix (Either e) where
|
||||
mfix f = let a = f (unRight a) in a
|
||||
where unRight (Right x) = x
|
||||
unRight (Left _) = errorWithoutStackTrace "mfix Either: Left"
|
||||
|
||||
-- | @since 2.01
|
||||
instance MonadFix (ST s) where
|
||||
mfix = fixST
|
||||
|
||||
-- Instances of Data.Monoid wrappers
|
||||
|
||||
-- | @since 4.8.0.0
|
||||
instance MonadFix Dual where
|
||||
mfix f = Dual (fix (getDual . f))
|
||||
|
||||
-- | @since 4.8.0.0
|
||||
instance MonadFix Sum where
|
||||
mfix f = Sum (fix (getSum . f))
|
||||
|
||||
-- | @since 4.8.0.0
|
||||
instance MonadFix Product where
|
||||
mfix f = Product (fix (getProduct . f))
|
||||
|
||||
-- | @since 4.8.0.0
|
||||
instance MonadFix First where
|
||||
mfix f = First (mfix (getFirst . f))
|
||||
|
||||
-- | @since 4.8.0.0
|
||||
instance MonadFix Last where
|
||||
mfix f = Last (mfix (getLast . f))
|
||||
|
||||
-- | @since 4.8.0.0
|
||||
instance MonadFix f => MonadFix (Alt f) where
|
||||
mfix f = Alt (mfix (getAlt . f))
|
||||
|
||||
-- | @since 4.12.0.0
|
||||
instance MonadFix f => MonadFix (Ap f) where
|
||||
mfix f = Ap (mfix (getAp . f))
|
||||
|
||||
-- Instances for GHC.Generics
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFix Par1 where
|
||||
mfix f = Par1 (fix (unPar1 . f))
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFix f => MonadFix (Rec1 f) where
|
||||
mfix f = Rec1 (mfix (unRec1 . f))
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadFix f => MonadFix (M1 i c f) where
|
||||
mfix f = M1 (mfix (unM1. f))
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
|
||||
mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))
|
||||
where
|
||||
fstP (a :*: _) = a
|
||||
sndP (_ :*: b) = b
|
||||
|
||||
-- Instances for Data.Ord
|
||||
|
||||
-- | @since 4.12.0.0
|
||||
instance MonadFix Down where
|
||||
mfix f = Down (fix (getDown . f))
|
||||
where getDown (Down x) = x
|
@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE Safe #-}
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Monad.IO.Class
|
||||
-- Copyright : (c) Andy Gill 2001,
|
||||
-- (c) Oregon Graduate Institute of Science and Technology, 2001
|
||||
-- License : BSD-style (see the file LICENSE)
|
||||
--
|
||||
-- Maintainer : R.Paterson@city.ac.uk
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Class of monads based on @IO@.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Monad.IO.Class (
|
||||
MonadIO(..)
|
||||
) where
|
||||
|
||||
-- | Monads in which 'IO' computations may be embedded.
|
||||
-- Any monad built by applying a sequence of monad transformers to the
|
||||
-- 'IO' monad will be an instance of this class.
|
||||
--
|
||||
-- Instances should satisfy the following laws, which state that 'liftIO'
|
||||
-- is a transformer of monads:
|
||||
--
|
||||
-- * @'liftIO' . 'return' = 'return'@
|
||||
--
|
||||
-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@
|
||||
|
||||
class (Monad m) => MonadIO m where
|
||||
-- | Lift a computation from the 'IO' monad.
|
||||
liftIO :: IO a -> m a
|
||||
|
||||
-- | @since 4.9.0.0
|
||||
instance MonadIO IO where
|
||||
liftIO = id
|
@ -1,19 +0,0 @@
|
||||
{-# LANGUAGE Safe #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Monad.Instances
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- /This module is DEPRECATED and will be removed in the future!/
|
||||
--
|
||||
-- 'Functor' and 'Monad' instances for @(->) r@ and
|
||||
-- 'Functor' instances for @(,) a@ and @'Either' a@.
|
||||
|
||||
module Control.Monad.Instances {-# DEPRECATED "This module now contains no instances and will be removed in the future" #-} -- deprecated in 7.8
|
||||
(Functor(..),Monad(..)) where
|
@ -1,35 +0,0 @@
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Control.Monad.ST
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : non-portable (requires universal quantification for runST)
|
||||
--
|
||||
-- This library provides support for /strict/ state threads, as
|
||||
-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton
|
||||
-- Jones /Lazy Functional State Threads/.
|
||||
--
|
||||
-- References (variables) that can be used within the @ST@ monad are
|
||||
-- provided by "Data.STRef", and arrays are provided by
|
||||
-- [Data.Array.ST](https://hackage.haskell.org/package/array/docs/Data-Array-ST.html).
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Control.Monad.ST (
|
||||
-- * The 'ST' Monad
|
||||
ST, -- abstract, instance of Functor, Monad, Typeable.
|
||||
runST,
|
||||
fixST,
|
||||
|
||||
-- * Converting 'ST' to 'IO'
|
||||
RealWorld, -- abstract
|
||||
stToIO,
|
||||
) where
|
||||
|
||||
import Control.Monad.ST.Imp
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user