tweag/asterius
1
1
Fork 0
mirror of https://github.com/tweag/asterius.git synced 2024-09-11 08:55:32 +03:00
Code Issues Projects Releases Wiki Activity

Move to GHC 8.10, plus misc other fixes (#860)

Browse Source
This commit is contained in:
Cheng Shao 2021-10-15 07:51:55 -07:00 committed by GitHub
parent e7b823c874
commit 9c75ad777d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1091 changed files with 837 additions and 160276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.buildkite/pipeline.yml
View File

@ -1 +0,0 @@
steps: []

17
.devcontainer/build.sh
View File

@ -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

37
.devcontainer/devcontainer.json
View File

@ -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"
}
}
}

5
.dockerignore
View File

@ -1,5 +0,0 @@
**/.git
**/.stack-work
**/stack.yaml.lock
/lib

1
.envrc
View File

@ -1 +0,0 @@
export PATH=$(stack exec printenv PATH)

1
.ghcid
View File

@ -1 +0,0 @@
--command="utils/ghcid.sh"

12
.github/workflows/boot.sh vendored
View File

@ -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
View File

@ -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
View File

@ -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
View 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
View File

@ -22,3 +22,8 @@ package-lock.json
/test
/lib
cabal.project.local
.vscode
sysroot

12
asterius/app/ahc-boot.hs
View File

@ -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
}

22
asterius/app/ahc-cabal.hs
View File

@ -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

10
asterius/boot-init.sh
View File

@ -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
View File

@ -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

10
asterius/cabal/config
View File

@ -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

75
asterius/ghc-bin-asterius/GHCi/Leak.hs
View File

@ -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))

3998
asterius/ghc-bin-asterius/GHCi/UI.hs
View File

File diff suppressed because it is too large Load Diff

379
asterius/ghc-bin-asterius/GHCi/UI/Info.hs
View File

@ -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)

533
asterius/ghc-bin-asterius/GHCi/UI/Monad.hs
View File

@ -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

216
asterius/ghc-bin-asterius/GHCi/UI/Tags.hs
View File

@ -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")

16
asterius/ghc-bin-asterius/GHCi/Util.hs
View File

@ -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 ())

983
asterius/ghc-bin-asterius/Main.hs
View File

@ -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

2245
asterius/ghc-pkg-asterius/Main.hs
View File

File diff suppressed because it is too large Load Diff

5
asterius/ghc-pkg-asterius/Version.hs
View File

@ -1,5 +0,0 @@
module Version where
version, targetOS, targetARCH :: String
version = "8.8.4"
targetOS = "linux"
targetARCH = "x86_64"

54
asterius/libc/fnv.c
View File

@ -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);
}

90
asterius/libc/fpstring.c
View File

@ -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);
}

9
asterius/libc/fpstring.h
View File

@ -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);

93
asterius/libc/getRandomBytes.c
View File

@ -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

215
asterius/libc/itoa.c
View File

@ -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
asterius/libc/main.c
View File

@ -1 +0,0 @@
int main() { return 0; }

238
asterius/libc/md5.c
View File

@ -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;
}

18
asterius/libc/md5.h
View File

@ -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]);

306
asterius/libc/text_cbits.c
View File

@ -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;
}

11
asterius/libc/text_cbits.h
View File

@ -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

149
asterius/libc/unescape_string.c
View File

@ -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)
}

39
asterius/package.yaml
View File

@ -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

2
asterius/rts/rts.gc.mjs
View File

@ -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);

50
asterius/rts/rts.heapalloc.mjs
View File

@ -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;
}

59
asterius/rts/rts.memory.mjs
View File

@ -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);
}

10
asterius/rts/rts.mjs
View File

@ -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);

8
asterius/rts/rts.unicode.mjs
View File

File diff suppressed because one or more lines are too long

3
asterius/src-types/Asterius/Types.hs
View File

@ -570,8 +570,7 @@ data Module
globalExports :: [GlobalExport],
globalMap :: SymbolMap Global,
memorySegments :: [DataSegment],
memoryImport :: Maybe MemoryImport,
memoryMBlocks :: Int
memoryImport :: Maybe MemoryImport
}
deriving (Show, Data)

2
asterius/src-types/Asterius/Types/EntitySymbol.hs
View File

@ -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 #-}

45
asterius/src/Asterius/Backends/Binaryen.hs
View File

@ -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

129
asterius/src/Asterius/Boot.hs
View File

@ -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

55
asterius/src/Asterius/BuildInfo.hs
View File

@ -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"

4
asterius/src/Asterius/Builtins.hs
View File

@ -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

6
asterius/src/Asterius/CodeGen.hs
View File

@ -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

27
asterius/src/Asterius/Foreign/DsForeign.hs
View File

@ -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"

6
asterius/src/Asterius/Foreign/Internals.hs
View File

@ -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

2
asterius/src/Asterius/Foreign/TcForeign.hs
View File

@ -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

15
asterius/src/Asterius/FrontendPlugin.hs
View File

@ -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'
}

6
asterius/src/Asterius/GHCi/Internals.hs
View File

@ -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

10
asterius/src/Asterius/Internals/MagicNumber.hs
View File

@ -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)

4
asterius/src/Asterius/JSGen/Bundle.hs
View File

@ -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)

91
asterius/src/Asterius/JSGen/LibC.hs
View File

@ -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
View 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

25
asterius/src/Asterius/Main.hs
View File

@ -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

28
asterius/src/Asterius/Passes/DataOffsetTable.hs
View File

@ -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

18
asterius/src/Asterius/Resolve.hs
View File

@ -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
View 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

4
asterius/src/Asterius/Types/LinkReport.hs
View File

@ -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]

1
asterius/test/argv.hs
View File

@ -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",

1
asterius/test/ghc-testsuite.hs
View File

@ -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",

90
base.Dockerfile
View File

@ -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
View File

@ -0,0 +1,4 @@
packages:
asterius
ghc-toolkit
wasm-toolkit

33
cabal.project.nix Normal file
View 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

85
dev.Dockerfile
View File

@ -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/*

113
dev.rootless.Dockerfile
View File

@ -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/*

2
docs/building.md
View File

@ -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

64
docs/roadmap.md
View File

@ -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:

12
ghc-toolkit/boot-libs/base/.authorspellings
View File

@ -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
View File

@ -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

22
ghc-toolkit/boot-libs/base/Asterius/Magic.hs
View File

@ -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

41
ghc-toolkit/boot-libs/base/Asterius/TopHandler.hs
View File

@ -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 ()

33
ghc-toolkit/boot-libs/base/Asterius/Types.hs
View File

@ -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

57
ghc-toolkit/boot-libs/base/Asterius/Types/JSArray.hs
View File

@ -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 ()

28
ghc-toolkit/boot-libs/base/Asterius/Types/JSException.hs
View File

@ -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

19
ghc-toolkit/boot-libs/base/Asterius/Types/JSFunction.hs
View File

@ -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 ()

31
ghc-toolkit/boot-libs/base/Asterius/Types/JSObject.hs
View File

@ -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 ()

77
ghc-toolkit/boot-libs/base/Asterius/Types/JSString.hs
View File

@ -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

40
ghc-toolkit/boot-libs/base/Asterius/Types/JSUint8Array.hs
View File

@ -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 ()

35
ghc-toolkit/boot-libs/base/Asterius/Types/JSVal.hs
View File

@ -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

145
ghc-toolkit/boot-libs/base/Control/Applicative.hs
View File

@ -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&#xF6;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

389
ghc-toolkit/boot-libs/base/Control/Arrow.hs
View File

@ -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)

79
ghc-toolkit/boot-libs/base/Control/Category.hs
View File

@ -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

666
ghc-toolkit/boot-libs/base/Control/Concurrent.hs
View File

@ -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'.
-}

142
ghc-toolkit/boot-libs/base/Control/Concurrent/Chan.hs
View File

@ -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)

274
ghc-toolkit/boot-libs/base/Control/Concurrent/MVar.hs
View File

@ -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 #)

129
ghc-toolkit/boot-libs/base/Control/Concurrent/QSem.hs
View File

@ -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

120
ghc-toolkit/boot-libs/base/Control/Concurrent/QSemN.hs
View File

@ -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

398
ghc-toolkit/boot-libs/base/Control/Exception.hs
View File

@ -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.
-}

404
ghc-toolkit/boot-libs/base/Control/Exception/Base.hs
View File

@ -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."#

360
ghc-toolkit/boot-libs/base/Control/Monad.hs
View File

@ -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
-}

81
ghc-toolkit/boot-libs/base/Control/Monad/Fail.hs
View File

@ -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

159
ghc-toolkit/boot-libs/base/Control/Monad/Fix.hs
View File

@ -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

37
ghc-toolkit/boot-libs/base/Control/Monad/IO/Class.hs
View File

@ -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

19
ghc-toolkit/boot-libs/base/Control/Monad/Instances.hs
View File

@ -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

35
ghc-toolkit/boot-libs/base/Control/Monad/ST.hs
View File

@ -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