...
 
Commits (239)
......@@ -33,7 +33,7 @@ aliases:
- &configure_unix
run:
name: Configure
command: ./configure
command: ./configure
- &configure_unix_32
run:
name: Configure
......@@ -50,7 +50,7 @@ aliases:
- &make
run:
name: Build
command: "make -j$THREADS"
command: "make -j$THREADS V=0"
- &build_hadrian
run:
name: Build GHC using Hadrian
......@@ -73,7 +73,8 @@ aliases:
- &bindist
run:
name: Create bindist
command: make binary-dist
# Reduce compression effort to 3
command: make binary-dist TAR_COMP_OPTS="-2"
# Building bindist takes ~15 minutes without output, account for
# that.
no_output_timeout: "30m"
......@@ -93,7 +94,7 @@ jobs:
"validate-x86_64-linux":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux:0.0.2
- image: ghcci/x86_64-linux:0.0.4
environment:
<<: *buildenv
GHC_COLLECTOR_FLAVOR: x86_64-linux
......@@ -133,12 +134,13 @@ jobs:
macos:
xcode: "9.0"
environment:
# Disable sphinx PDF output as MacTeX apparently doesn't provide xelatex
BUILD_SPHINX_PDF: "NO"
MACOSX_DEPLOYMENT_TARGET: "10.7"
# Only Sierra and onwards supports clock_gettime. See #12858
ac_cv_func_clock_gettime: "no"
environment:
<<: *buildenv
GHC_COLLECTOR_FLAVOR: x86_64-darwin
<<: *buildenv
steps:
- checkout
- *prepare
......@@ -154,7 +156,7 @@ jobs:
"validate-hadrian-x86_64-linux":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux:0.0.2
- image: ghcci/x86_64-linux:0.0.4
environment:
<<: *buildenv
steps:
......@@ -168,7 +170,7 @@ jobs:
"validate-x86_64-linux-unreg":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux:0.0.2
- image: ghcci/x86_64-linux:0.0.4
environment:
<<: *buildenv
steps:
......@@ -184,7 +186,7 @@ jobs:
"validate-x86_64-linux-llvm":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux:0.0.2
- image: ghcci/x86_64-linux:0.0.4
environment:
<<: *buildenv
BUILD_FLAVOUR: perf-llvm
......@@ -209,7 +211,7 @@ jobs:
"validate-x86_64-linux-debug":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux:0.0.2
- image: ghcci/x86_64-linux:0.0.4
environment:
BUILD_FLAVOUR: devel2
<<: *buildenv
......@@ -218,7 +220,7 @@ jobs:
- *prepare
- *submodules
- *boot
- *configure_unreg
- *configure_unix
- *make
- *test
- *store_test_results
......@@ -226,7 +228,7 @@ jobs:
"validate-i386-linux":
resource_class: xlarge
docker:
- image: ghcci/i386-linux:0.0.2
- image: ghcci/i386-linux:0.0.5
environment:
<<: *buildenv
GHC_COLLECTOR_FLAVOR: i386-linux
......@@ -245,7 +247,7 @@ jobs:
"validate-x86_64-fedora":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux-fedora:0.0.4
- image: ghcci/x86_64-linux-fedora:0.0.15
environment:
<<: *buildenv
GHC_COLLECTOR_FLAVOR: x86_64-fedora
......@@ -264,7 +266,7 @@ jobs:
"slow-validate-x86_64-linux":
resource_class: xlarge
docker:
- image: ghcci/x86_64-linux:0.0.2
- image: ghcci/x86_64-linux:0.0.4
environment:
<<: *buildenv
GHC_COLLECTOR_FLAVOR: x86_64-linux
......
......@@ -5,7 +5,13 @@ ENV LANG C.UTF-8
RUN echo 'deb http://ppa.launchpad.net/hvr/ghc/ubuntu trusty main' > /etc/apt/sources.list.d/ghc.list
RUN apt-key adv --keyserver keyserver.ubuntu.com --recv-keys F6F88286
RUN apt-get update -qq
# Core build utilities
RUN apt-get install -qy git make automake autoconf gcc perl python3 texinfo xz-utils lbzip2 bzip2 patch openssh-client sudo curl zlib1g-dev libtinfo-dev libsqlite3-0 libsqlite3-dev ca-certificates g++ cabal-install-2.2 ghc-8.4.2 happy alex
# Documentation tools
RUN apt-get install -qy python3-sphinx texlive-xetex texlive-latex-extra
ENV PATH /home/ghc/.cabal/bin:/home/ghc/.local/bin:/opt/cabal/2.2/bin:/opt/ghc/8.4.2/bin:$PATH
# Get i386 GHC bindist for 32 bit CI builds.
......
#!/usr/bin/env bash
set -e
repo=ghcci
if [[ $# != 2 ]]; then
echo "Usage: $0 DIR VERSION"
echo
echo "Update Docker image in DIR, pushing it to the $repo repository as"
echo "version VERSION"
echo
echo "Example: $0 x86_64-linux-fedora 0.0.3"
exit 1
fi
name=$1
version=$2
versions="$(curl -s https://registry.hub.docker.com/v1/repositories/$repo/$name/tags | jq -r .[].name)"
if echo "$versions" | grep $version > /dev/null; then
echo "Version $version of $name already exists"
echo "Previous versions are:"
echo "$versions"
exit 1
fi
docker build $name -t $repo/$name:$version
docker push $repo/$name:$version
repo_name="$repo/$name"
sed -i -E -e "s%$repo_name"':[0-9]+(\.[0-9]+)*%'"$repo_name:$version%" ../config.yml
echo "Built, pushed, and bumped $name:$version"
......@@ -2,7 +2,25 @@ FROM fedora:27
ENV LANG C.UTF-8
RUN dnf -y install coreutils binutils which git make automake autoconf gcc perl python3 texinfo xz lbzip2 patch openssh-clients sudo curl zlib-devel sqlite ncurses-compat-libs gmp-devel ncurses-devel gcc-c++ findutils
# Core build utilities
RUN dnf -y install coreutils binutils which git make \
automake autoconf gcc perl python3 texinfo xz lbzip2 \
patch openssh-clients sudo curl zlib-devel sqlite \
ncurses-compat-libs gmp-devel ncurses-devel gcc-c++ findutils
# Documentation tools
RUN dnf -y install python3-sphinx \
texlive texlive-latex texlive-xetex \
texlive-collection-latex texlive-collection-latexrecommended \
texlive-xetex-def texlive-collection-xetex \
python-sphinx-latex dejavu-sans-fonts dejavu-serif-fonts \
dejavu-sans-mono-fonts
# This is in the PATH when I ssh into the CircleCI machine but somehow
# sphinx-build isn't found during configure unless we explicitly
# add it here as well; perhaps PATH is being overridden by CircleCI's
# infrastructure?
ENV PATH /usr/libexec/python3-sphinx:$PATH
# systemd isn't running so remove it from nsswitch.conf
# Failing to do this will result in testsuite failures due to
......
......@@ -5,7 +5,15 @@ ENV LANG C.UTF-8
RUN echo 'deb http://ppa.launchpad.net/hvr/ghc/ubuntu trusty main' > /etc/apt/sources.list.d/ghc.list
RUN apt-key adv --keyserver keyserver.ubuntu.com --recv-keys F6F88286
RUN apt-get update -qq
RUN apt-get install -qy cabal-install-2.2 ghc-8.4.2 happy alex zlib1g-dev libtinfo-dev libsqlite3-0 libsqlite3-dev ca-certificates g++ git curl git make automake autoconf gcc perl python3 texinfo xz-utils lbzip2 patch openssh-client sudo
# Core build utilities
RUN apt-get install -qy cabal-install-2.2 ghc-8.4.2 happy alex zlib1g-dev \
libtinfo-dev libsqlite3-0 libsqlite3-dev ca-certificates g++ git curl \
git make automake autoconf gcc perl python3 texinfo xz-utils lbzip2 \
patch openssh-client sudo
# Documentation tools
RUN apt-get install -qy python3-sphinx texlive-xetex texlive-latex-extra
# Stack intallation
RUN curl -fSL https://github.com/commercialhaskell/stack/releases/download/v1.6.5/stack-1.6.5-linux-x86_64-static.tar.gz -o stack.tar.gz
......
......@@ -7,16 +7,18 @@ fail() {
exit 1
}
echo 'BUILD_SPHINX_HTML = NO' > mk/validate.mk
echo 'BUILD_SPHINX_PDF = NO' >> mk/validate.mk
hackage_index_state="@1522046735"
if [[ -z ${BUILD_SPHINX_HTML:-} ]]; then BUILD_SPHINX_HTML=YES; fi
if [[ -z ${BUILD_SPHINX_PDF:-} ]]; then BUILD_SPHINX_PDF=YES; fi
cat > mk/build.mk <<EOF
V=1
HADDOCK_DOCS=YES
LATEX_DOCS=YES
HSCOLOUR_SRCS=YES
BUILD_DOCBOOK_HTML=YES
BUILD_SPHINX_HTML=$BUILD_SPHINX_HTML
BUILD_SPHINX_PDF=$BUILD_SPHINX_PDF
BeConservative=YES
EOF
......@@ -42,11 +44,12 @@ case "$(uname)" in
fail "TARGET=$target not supported"
fi
else
cabal update
cabal update -v
cabal install --reinstall hscolour
sudo ln -s /home/ghc/.cabal/bin/HsColour /usr/local/bin/HsColour || true
fi
;;
Darwin)
if [[ -n ${TARGET:-} ]]; then
fail "uname=$(uname) not supported for cross-compilation"
......@@ -55,13 +58,25 @@ case "$(uname)" in
# does not work.
brew upgrade python
brew install ghc cabal-install ncurses gmp
pip3 install sphinx
# PDF documentation disabled as MacTeX apparently doesn't include xelatex.
#brew cask install mactex
cabal update
cabal install --reinstall alex happy haddock hscolour --index-state=$hackage_index_state
# put them on the $PATH, don't fail if already installed
ln -s $HOME/.cabal/bin/alex /usr/local/bin/alex || true
ln -s $HOME/.cabal/bin/happy /usr/local/bin/happy || true
ln -s $HOME/.cabal/bin/HsColour /usr/local/bin/HsColour || true
echo "libraries/integer-gmp_CONFIGURE_OPTS += --configure-option=--with-intree-gmp" >> mk/build.mk
;;
*)
fail "uname=$(uname) not supported"
esac
echo "================================================="
echo "Build.mk:"
echo ""
cat mk/build.mk
echo "================================================="
#!/bin/bash
echo "$@" >> /tmp/hlint-lto-ar.out
# https://releases.llvm.org/6.0.0/docs/GoldPlugin.html#quickstart-for-using-lto-with-autotooled-projects
#exec /usr/lib/llvm-6.0/bin/llvm-ar ${1+"$@"}
# Try newer `ar` (doesn't seem to help undefined StgReturn when making libHSrts_thr.a)
# Not sure if version mismatch is a problem here, but older is incompatible with GNU ar:
exec /usr/lib/llvm-9/bin/llvm-ar ${1+"$@"}
#!/bin/bash
# -fno-semantic-interposition is apparently default, but at least not recognized in clang-6
echo ${1+"$@"} >> /tmp/clang.out.hask
#exec /usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only ${1+"$@"}
if [[ "$(pwd)" == *"/libffi"* ]]; then
exec gcc ${1+"$@"}
# Trying to ignore `-traditional` just results in errors
elif [[ "$@" == *"assembler-with-cpp"* || "$@" == *"-traditional"* ]]; then
exec gcc ${1+"$@"}
# DIDN'T HELP
# elif [[ "$@" == *"-shared"* ]]; then
# echo SHAAAAAARED >> /tmp/clang.out
# exec /usr/lib/llvm-6.0/bin/clang -gline-tables-only ${1+"$@"}
else
# This we used somewhat successfully to build ghc:
#/usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || /usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only ${1+"$@"}
# This we're trying in conjunction with llc shim for building haskell projects:
# Copying some flags from `llc` invocation,
#/usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only -O2 -msse -msse2 ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || /usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only ${1+"$@"}
# With -O3:
#/usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only -O3 -msse -msse2 ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || /usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only -O3 ${1+"$@"}
# NOTE: -mllvm '-relocation-model=static'
# ^ doesn't work
# With -O3, Clang-9 for Souper:
clang-9 -flto -gline-tables-only -O3 -msse -msse2 ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || clang-9 -flto -gline-tables-only -O3 ${1+"$@"}
# NOTE: actually this doesn't do anything; clang is only used for linking (see `opt` shim).
## With -O3 and POLLY
#POLLY_FLAGS="-mllvm -polly"
## POLLY_FLAGS="-mllvm -polly -mllvm -polly-parallel -lgomp "
#/usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only -O3 $POLLY_FLAGS -msse -msse2 ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || /usr/lib/llvm-6.0/bin/clang -flto -gline-tables-only -O3 $POLLY_FLAGS ${1+"$@"}
# PGO + O3
#/usr/lib/llvm-6.0/bin/clang -fprofile-sample-use=/tmp/hlint_lto_autodfo.prof -flto -gline-tables-only -O3 -msse -msse2 ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || /usr/lib/llvm-6.0/bin/clang -fprofile-sample-use=/tmp/hlint_lto_autodfo.prof -flto -gline-tables-only -O3 ${1+"$@"}
# PGO: we'd like to try fprofile-sample-accurate , but it's not in clang v6:
#/usr/lib/llvm-6.0/bin/clang -fprofile-sample-accurate -fprofile-sample-use=/tmp/hlint_lto_autodfo.prof -flto -gline-tables-only -O2 -msse -msse2 ${1+$(echo "$@" | sed "s/-x assembler /-x ir /g")} || /usr/lib/llvm-6.0/bin/clang -fprofile-sample-accurate -fprofile-sample-use=/tmp/hlint_lto_autodfo.prof -flto -gline-tables-only ${1+"$@"}
fi
#!/bin/bash
# DISABLED FOR NOW SINCE WE GET ERRORS RIGHT AWAY
# Big hammer, make sure we use clang always; not sure if necessary.
exec clang ${1+"$@"}
#!/bin/bash
ld.lld ${1+"$@"}
#!/bin/bash
#/usr/lib/llvm-6.0/bin/ld.lld ${1+"$@"}
# (doesn't seem to help undefined StgReturn when making libHSrts_thr.a):
# But this seems to be required for autofdo clang PGO?
/usr/lib/llvm-9/bin/ld.lld ${1+"$@"}
# Emit relocs (for BOLT)... no, BOLT still fucked
#/usr/lib/llvm-9/bin/ld.lld --emit-relocs ${1+"$@"}
#!/bin/bash
#
# called by ghc e.g.
# $ llc-6.0 -O2 -enable-tbaa '-relocation-model=static' '-mcpu=x86-64' '-mattr=+sse2,+sse' /tmp/ghc15832_0/ghc_2.bc -o /tmp/ghc15832_0/ghc_3.lm_s
#
# We turn into a cp noop, to expose to clang for LTO
FROM_TO=$(echo "$@" | awk '{print $(NF-2) " " $(NF)}')
cp $FROM_TO
#!/bin/bash
# User our shim:
exec llc ${1+"$@"}
#!/bin/bash
ld.lld ${1+"$@"}
# (doesn't seem to help undefined StgReturn when making libHSrts_thr.a):
#/usr/lib/llvm-9/bin/ld.lld ${1+"$@"}
#!/bin/bash
# https://releases.llvm.org/6.0.0/docs/GoldPlugin.html#quickstart-for-using-lto-with-autotooled-projects
exec /usr/lib/llvm-6.0/bin/llvm-nm ${1+"$@"}
#!/bin/bash
# Shim for running POLLY. Must be used with -fast-llvm
exec /usr/bin/opt-6.0 ${1+"$@"} -O3 -polly
# Souper; non-exhaustive
# Requires redis server running, for external caching
#exec /home/me/.local/lib/souper/opt -load /home/me/.local/lib/souper/libsouperPass.so -souper -z3-path=/home/me/.local/bin/z3 -souper-external-cache=true -souper-exhaustive-synthesis ${1+"$@"}
# There aren't useful built in timeouts in souper it seems; fallback to non-exhaustive after 10 min
# timeout 600 /home/me/.local/lib/souper/opt -load /home/me/.local/lib/souper/libsouperPass.so -souper -z3-path=/home/me/.local/bin/z3 -souper-external-cache=true -souper-exhaustive-synthesis ${1+"$@"} ||
# /home/me/.local/lib/souper/opt -load /home/me/.local/lib/souper/libsouperPass.so -souper -z3-path=/home/me/.local/bin/z3 -souper-external-cache=true ${1+"$@"} ||
# /usr/bin/opt-6.0 ${1+"$@"}
#!/bin/bash
# https://releases.llvm.org/6.0.0/docs/GoldPlugin.html#quickstart-for-using-lto-with-autotooled-projects
#exec /bin/true
exec /usr/lib/llvm-6.0/bin/llvm-ranlib ${1+"$@"}
#!/bin/bash
set -e
set -o pipefail
# set -x
if [ "$2" = "--all" ]; then
# Test all files for LLVM Bitcode
PAT=*
else
PAT=*.o
fi
# Keep track of files that change:
declare -a changed=()
for f in `find "$1" -name "$PAT" -type f`; do
# Skip if not LLVM IR bitcode file...
if ! grep -q "LLVM IR" <(file "$f") 2>/dev/null ; then
echo -en _
continue
fi
HASH_BEFORE=$(md5sum "$f")
# Backup
cp --force --backup=numbered "$f" "$f"
# Run basic polly pass (other documented variants didn't seem to do anything, in fact; maybe only for later versions):
opt "$f" -O3 -polly -o "$f"
HASH_AFTER=$(md5sum "$f")
if [ "$HASH_BEFORE" = "$HASH_AFTER" ]; then
echo -en "."
else
changed+=("$f")
echo -en "o"
fi
done
echo
# echo "Files that were modified during reoptimization:"
# for f in "${changed[@]}"; do
# echo " $f"
# done
# To restore original backup, e.g.
#
# for f in `find "$1" -name '*.o.~1~'`; do grep -q LLVM <(file "$f") && mv "$f" "${f%.~1~}"; done 2>/dev/null
#!/usr/bin/zsh
# Not portable, sorry...
set -e
set -o pipefail
# set -x
# Calls `reopt` on objects in archive and repacks
TARGET_DIR=$(realpath "$@")
for f in `find "$TARGET_DIR" -name '*.a' -type f`; do
grep -q "ar archive" <(file "$f") 2>/dev/null || continue
echo -n "$f: "
TMP_DIR=$(mktemp -d)
cd "$TMP_DIR"
# Individual libraries can and do have identical names, which makes this a huge pain.
# We unpack each member into a separate numbered directory, and repack in the same order
O_NUM=1
for cnt nm in `ar t "$f" | sort | uniq -c`; do
for c in {1..$cnt}; do
mkdir $O_NUM
cd $O_NUM
ar xN $c $f $nm
cd ..
((O_NUM++))
done
done
# optimize all objects we just unpacked (some may not be named *.o)
reopt . --all
# rearchive; use zsh numeric blob qualifier.
ar cq repackaged.a */*(n)
# Backup original
cp --force --backup=numbered "$f" "$f"
cp repackaged.a "$f"
rm -r "$TMP_DIR"
done
# To restore original backup, e.g.
#
# for f in `find "$@" -name '*.a.~1~'`; do mv "$f" "${f%.~1~}"; done 2>/dev/null
#!/usr/bin/zsh
# Not portable, sorry...
set -e
set -o pipefail
# set -x
# Another variation on these reopt script. THis unpacks an archive and pauses
# while the programmer fiddles with it, then repacks and backs up original.
# Calls `reopt` on objects in archive and repacks
TARGET_AR=$(realpath "$@")
echo -n "$TARGET_AR: "
TMP_DIR=$(mktemp -d)
cd "$TMP_DIR"
# Individual libraries can and do have identical names, which makes this a huge pain.
# We unpack each member into a separate numbered directory, and repack in the same order
O_NUM=1
for cnt nm in `ar t "$TARGET_AR" | sort | uniq -c`; do
for c in {1..$cnt}; do
mkdir $O_NUM
cd $O_NUM
ar xN $c "$TARGET_AR" $nm
cd ..
((O_NUM++))
done
done
echo
echo "Pausing while you fiddle with contents of $TARGET_AR, unpacked at:"
echo " $TMP_DIR"
read "?Enter to continue and repack"
# rearchive; use zsh numeric blob qualifier.
ar cq repackaged.a */*(n)
# Backup original
cp --force --backup=numbered "$TARGET_AR" "$TARGET_AR"
cp repackaged.a "$TARGET_AR"
rm -r "$TMP_DIR"
......@@ -1546,7 +1546,7 @@ if test "$RELEASE" = "NO"; then
fi
AC_MSG_CHECKING([for GHC Git commit id])
if test -d .git; then
if test -e .git; then
git_commit_id=`git rev-parse HEAD`
if test -n "$git_commit_id" 2>&1 >/dev/null; then true; else
AC_MSG_ERROR([failed to detect revision: check that git is in your path])
......
......@@ -1436,9 +1436,12 @@ data IntegralLit
deriving (Data, Show)
mkIntegralLit :: Integral a => a -> IntegralLit
mkIntegralLit i = IL { il_text = SourceText (show (fromIntegral i :: Int))
mkIntegralLit i = IL { il_text = SourceText (show i_integer)
, il_neg = i < 0
, il_value = toInteger i }
, il_value = i_integer }
where
i_integer :: Integer
i_integer = toInteger i
negateIntegralLit :: IntegralLit -> IntegralLit
negateIntegralLit (IL text neg value)
......@@ -1463,6 +1466,13 @@ data FractionalLit
mkFractionalLit :: Real a => a -> FractionalLit
mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
-- Converting to a Double here may technically lose
-- precision (see #15502). We could alternatively
-- convert to a Rational for the most accuracy, but
-- it would cause Floats and Doubles to be displayed
-- strangely, so we opt not to do this. (In contrast
-- to mkIntegralLit, where we always convert to an
-- Integer for the highest accuracy.)
, fl_neg = r < 0
, fl_value = toRational r }
......
......@@ -845,27 +845,27 @@ isMarkedStrict _ = True -- All others are strict
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
-> TyConRepName -- ^ TyConRepName for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyVar] -- ^ Existentials.
-> [TyVarBinder] -- ^ User-written 'TyVarBinder's.
-- These must be Inferred/Specified.
-- See @Note [TyVarBinders in DataCons]@
-> [EqSpec] -- ^ GADT equalities
-> ThetaType -- ^ Theta-type occuring before the arguments proper
-> [Type] -- ^ Original argument types
-> Type -- ^ Original result type
-> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'
-> TyCon -- ^ Representation type constructor
-> ConTag -- ^ Constructor tag
-> ThetaType -- ^ The "stupid theta", context of the data
-- declaration e.g. @data Eq a => T a ...@
-> Id -- ^ Worker Id
-> DataConRep -- ^ Representation
-> Bool -- ^ Is the constructor declared infix?
-> TyConRepName -- ^ TyConRepName for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyVar] -- ^ Existentials.
-> [TyVarBinder] -- ^ User-written 'TyVarBinder's.
-- These must be Inferred/Specified.
-- See @Note [TyVarBinders in DataCons]@
-> [EqSpec] -- ^ GADT equalities
-> KnotTied ThetaType -- ^ Theta-type occuring before the arguments proper
-> [KnotTied Type] -- ^ Original argument types
-> KnotTied Type -- ^ Original result type
-> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'
-> KnotTied TyCon -- ^ Representation type constructor
-> ConTag -- ^ Constructor tag
-> ThetaType -- ^ The "stupid theta", context of the data
-- declaration e.g. @data Eq a => T a ...@
-> Id -- ^ Worker Id
-> DataConRep -- ^ Representation
-> DataCon
-- Can get the tag from the TyCon
......@@ -1442,8 +1442,8 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
where
binders = mkTyConBindersPreferAnon ktvs liftedTypeKind
buildSynTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> Type -> TyCon
buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> KnotTied Type -> TyCon
buildSynTyCon name binders res_kind roles rhs
= mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free
where
......
......@@ -39,7 +39,7 @@ module Demand (
nopSig, botSig, exnSig, cprProdSig,
isTopSig, hasDemandEnvSig,
splitStrictSig, strictSigDmdEnv,
increaseStrictSigArity,
increaseStrictSigArity, etaExpandStrictSig,
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
......@@ -1737,8 +1737,23 @@ splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
increaseStrictSigArity :: Int -> StrictSig -> StrictSig
-- Add extra arguments to a strictness signature
increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
= StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res))
| isTopDmdType dmd_ty = sig
| arity_increase <= 0 = sig
| otherwise = StrictSig (DmdType env dmds' res)
where
dmds' = replicate arity_increase topDmd ++ dmds
etaExpandStrictSig :: Arity -> StrictSig -> StrictSig
-- We are expanding (\x y. e) to (\x y z. e z)
-- Add exta demands to the /end/ of the arg demands if necessary
etaExpandStrictSig arity sig@(StrictSig dmd_ty@(DmdType env dmds res))
| isTopDmdType dmd_ty = sig
| arity_increase <= 0 = sig
| otherwise = StrictSig (DmdType env dmds' res)
where
arity_increase = arity - length dmds
dmds' = dmds ++ replicate arity_increase topDmd
isTopSig :: StrictSig -> Bool
isTopSig (StrictSig ty) = isTopDmdType ty
......
......@@ -19,8 +19,7 @@ module MkId (
mkPrimOpId, mkFCallId,
wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody,
unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), mkDataConRep, mkDataConWorkId,
-- And some particular Ids; see below for why they are wired in
......@@ -247,6 +246,47 @@ Hence we translate to
-- Coercion from family type to representation type
Co7T a :: T [a] ~ :R7T a
Newtype instances through an additional wrinkle into the mix. Consider the
following example (adapted from #15318, comment:2):
data family T a
newtype instance T [a] = MkT [a]
Within the newtype instance, there are three distinct types at play:
1. The newtype's underlying type, [a].
2. The instance's representation type, TList a (where TList is the
representation tycon).
3. The family type, T [a].
We need two coercions in order to cast from (1) to (3):
(a) A newtype coercion axiom:
axiom coTList a :: TList a ~ [a]
(Where TList is the representation tycon of the newtype instance.)
(b) A data family instance coercion axiom:
axiom coT a :: T [a] ~ TList a
When we translate the newtype instance to Core, we obtain:
-- Wrapper
$WMkT :: forall a. [a] -> T [a]
$WMkT a x = MkT a x |> Sym (coT a)
-- Worker
MkT :: forall a. [a] -> TList [a]
MkT a x = x |> Sym (coTList a)
Unlike for data instances, the worker for a newtype instance is actually an
executable function which expands to a cast, but otherwise, the general
strategy is essentially the same as for data instances. Also note that we have
a wrapper, which is unusual for a newtype, but we make GHC produce one anyway
for symmetry with the way data instances are handled.
Note [Newtype datacons]
~~~~~~~~~~~~~~~~~~~~~~~
The "data constructor" for a newtype should always be vanilla. At one
......@@ -614,8 +654,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- of some newtypes written with GADT syntax. See below.
&& (any isBanged (ev_ibangs ++ arg_ibangs)
-- Some forcing/unboxing (includes eq_spec)
|| isFamInstTyCon tycon -- Cast result
|| (not $ null eq_spec))) -- GADT
|| isFamInstTyCon tycon -- Cast result
|| dataConUserTyVarsArePermuted data_con
-- If the data type was written with GADT syntax and
-- orders the type variables differently from what the
......@@ -1009,15 +1049,9 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
--
-- If a coercion constructor is provided in the newtype, then we use
-- it, otherwise the wrap/unwrap are both no-ops
--
-- If the we are dealing with a newtype *instance*, we have a second coercion
-- identifying the family instance with the constructor of the newtype
-- instance. This coercion is applied in any case (ie, composed with the
-- coercion constructor of the newtype or applied by itself).
wrapNewTypeBody tycon args result_expr
= ASSERT( isNewTyCon tycon )
wrapFamInstBody tycon args $
mkCast result_expr (mkSymCo co)
where
co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []
......
......@@ -1311,14 +1311,10 @@ pprLoc (UnhelpfulSpan {}) = empty
-- coming from GHC.TypeNats). In this case the user will get a kind
-- mismatch error. This is a violation of assumption (c).
--
-- Since NoStarIsType is implied by a fairly common extension TypeOperators,
-- the user might be working on a module with NoStarIsType unbeknownst to him.
-- Even if the user switched off StarIsType manually, he might have forgotten
-- about it and use '*' as 'Data.Kind.Type' out of habit.
--
-- Thus it is very important to give a hint whenever an assumption about '*' is
-- violated. Unfortunately, it is somewhat difficult to deal with (c), so we
-- limit ourselves to (a) and (b).
-- The user might unknowingly be working on a module with NoStarIsType
-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a
-- hint whenever an assumption about '*' is violated. Unfortunately, it is
-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).
--
-- 'starInfo' generates an appropriate hint to the user depending on the
-- extensions enabled in the module and the name that triggered the error.
......@@ -1326,10 +1322,10 @@ pprLoc (UnhelpfulSpan {}) = empty
-- Unicode variant, the resulting SDoc will contain a helpful suggestion.
-- Otherwise it is empty.
--
starInfo :: (Bool, Bool) -> RdrName -> SDoc
starInfo (type_operators, star_is_type) rdr_name =
starInfo :: Bool -> RdrName -> SDoc
starInfo star_is_type rdr_name =
-- One might ask: if can use sdocWithDynFlags here, why bother to take
-- (type_operators, star_is_type) as input? Why not refactor?
-- star_is_type as input? Why not refactor?
--
-- The reason is that sdocWithDynFlags would provide DynFlags that are active
-- in the module that tries to load the problematic definition, not
......@@ -1340,10 +1336,7 @@ starInfo (type_operators, star_is_type) rdr_name =
-- with StarIsType enabled!
--
if isUnqualStar && not star_is_type
then text "With NoStarIsType" <>
(if type_operators
then text " (implied by TypeOperators), "
else text ", ") <>
then text "With NoStarIsType, " <>
quotes (ppr rdr_name) <>
text " is treated as a regular type operator. "
$$
......
......@@ -307,12 +307,14 @@ mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
= RealSrcSpan (mkRealSrcSpan loc1 loc2)
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
-- within both spans. Returns UnhelpfulSpan if the files differ.
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
= RealSrcSpan (combineRealSrcSpans span1 span2)
| srcSpanFile span1 == srcSpanFile span2
= RealSrcSpan (combineRealSrcSpans span1 span2)
| otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
......
......@@ -32,6 +32,7 @@ module UniqSupply (
import GhcPrelude
import Unique
import Panic (panic)
import GHC.IO
......@@ -39,6 +40,7 @@ import MonadUtils
import Control.Monad
import Data.Bits
import Data.Char
import Control.Monad.Fail
#include "Unique.h"
......@@ -147,6 +149,10 @@ instance Applicative UniqSM where
(# xx, us'' #) -> (# ff xx, us'' #)
(*>) = thenUs_
-- TODO: try to get rid of this instance
instance MonadFail UniqSM where
fail = panic
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
......
This diff is collapsed.
......@@ -86,8 +86,10 @@ cgTopRhsCon dflags id con args =
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
CmmLit lit <- getArgAmode arg
return lit
amode <- getArgAmode arg
case amode of
CmmLit lit -> return lit
_ -> panic "StgCmmCon.cgTopRhsCon"
nonptr_wds = tot_wds - ptr_wds
......
......@@ -65,6 +65,16 @@ cgExpr (StgApp fun args) = cgIdApp fun args
cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
cgIdApp a []
-- dataToTag# :: a -> Int#
-- See Note [dataToTag#] in primops.txt.pp
cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
dflags <- getDynFlags
emitComment (mkFastString "dataToTag#")
tmp <- newTemp (bWord dflags)
_ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
-- TODO: For small types look at the tag bits instead of reading info table
emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con args _)= cgConApp con args
cgExpr (StgTick t e) = cgTick t >> cgExpr e
......@@ -550,6 +560,8 @@ isSimpleScrut _ _ = return False
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
-- True iff the op cannot block or allocate
isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
isSimpleOp (StgPrimOp DataToTagOp) _ = return False
isSimpleOp (StgPrimOp op) stg_args = do
arg_exprs <- getNonVoidArgAmodes stg_args
dflags <- getDynFlags
......
......@@ -29,7 +29,7 @@ module StgCmmMonad (
mkCall, mkCmmCall,
forkClosureBody, forkLneBody, forkAlts, codeOnly,
forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
ConTagZ,
......@@ -636,6 +636,15 @@ forkAlts branch_fcodes
-- NB foldl. state is the *left* argument to stateIncUsage
; return branch_results }
forkAltPair :: FCode a -> FCode a -> FCode (a,a)
-- Most common use of 'forkAlts'; having this helper function avoids
-- accidental use of failible pattern-matches in @do@-notation
forkAltPair x y = do
xy' <- forkAlts [x,y]
case xy' of
[x',y'] -> return (x',y')
_ -> panic "forkAltPair"
-- collect the code emitted by an FCode computation
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR fcode
......
......@@ -37,7 +37,6 @@ import BlockId
import MkGraph
import StgSyn
import Cmm
import CmmInfo
import Type ( Type, tyConAppTyCon )
import TyCon
import CLabel
......@@ -371,11 +370,6 @@ emitPrimOp _ [res] AddrToAnyOp [arg]
emitPrimOp _ [res] AnyToAddrOp [arg]
= emitAssign (CmmLocal res) arg
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-- Note: argument may be tagged!
emitPrimOp dflags [res] DataToTagOp [arg]
= emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))
{- Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable
objects, even if they are in old space. When they become immutable,
......@@ -1929,10 +1923,9 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts [
getCode $ emitMemmoveCall dst_p src_p bytes 1,
getCode $ emitMemcpyCall dst_p src_p bytes 1
]
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p bytes 1)
(getCode $ emitMemcpyCall dst_p src_p bytes 1)
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
......@@ -2073,12 +2066,11 @@ doCopyMutableArrayOp = emitCopyArray copy
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts [
getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags),
getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags)
]
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
......@@ -2136,12 +2128,11 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts
[ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wO