Skip to content
Commits on Source (51)
......@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
DOCKER_REV: 6014fdf2843e07185a1762a95dce6bdedb544f55
# Sequential version number capturing the versions of all tools fetched by
# .gitlab/win32-init.sh.
......@@ -21,7 +21,8 @@ stages:
- full-build # Build all the things
- cleanup # See Note [Cleanup on Windows]
- packaging # Source distribution, etc.
- hackage # head.hackage testing
- testing # head.hackage correctness and compiler performance testing
- nofib
- deploy # push documentation
.only-default: &only-default
......@@ -30,6 +31,7 @@ stages:
- /ghc-[0-9]+\.[0-9]+/
- merge_requests
- tags
- web
############################################################
# Runner Tags
......@@ -124,7 +126,8 @@ lint-changelogs:
lint-release-changelogs:
extends: .lint-changelogs
only:
- tags
refs:
- /ghc-[0-9]+\.[0-9]+\.[0-9]+-.*/
############################################################
......@@ -142,6 +145,7 @@ lint-release-changelogs:
- ./boot
- ./configure $CONFIGURE_ARGS
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test
- mv _build/bindist/ghc*.tar.xz ghc.tar.xz
cache:
key: hadrian
......@@ -170,7 +174,7 @@ validate-x86_64-linux-deb8-hadrian:
hadrian-ghc-in-ghci:
<<: *only-default
stage: build
image: ghcci/x86_64-linux-deb8:0.1
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb8:$DOCKER_REV"
before_script:
# workaround for docker permissions
- sudo chown ghc:ghc -R .
......@@ -456,6 +460,27 @@ release-x86_64-linux-deb8:
when: always
expire_in: 2 week
#################################
# x86_64-linux-centos7
#################################
release-x86_64-linux-centos7:
extends: .validate-linux
stage: full-build
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-centos7:$DOCKER_REV"
variables:
# The sphinx release shipped with Centos 7 fails to build out documentation
BUILD_SPHINX_HTML: "NO"
BUILD_SPHINX_PDF: "NO"
TEST_ENV: "x86_64-linux-centos7"
BIN_DIST_PREP_TAR_COMP: "bindistprep/ghc-x86_64-centos7-linux.tar.xz"
only:
- tags
cache:
key: linux-x86_64-centos7
artifacts:
when: always
expire_in: 2 week
#################################
# x86_64-linux-fedora27
......@@ -603,6 +628,8 @@ release-i386-windows:
MSYSTEM: MINGW32
BUILD_FLAVOUR: "perf"
CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
# Due to #15934
BUILD_PROF_LIBS: "NO"
cache:
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
......@@ -614,6 +641,8 @@ nightly-i386-windows:
variables:
MSYSTEM: MINGW32
CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
# Due to #15934
BUILD_PROF_LIBS: "NO"
cache:
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
......@@ -683,10 +712,15 @@ doc-tarball:
stage: packaging
tags:
- x86_64-linux
image: ghcci/x86_64-linux-deb9:0.2
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
dependencies:
- validate-x86_64-linux-deb9
- validate-x86_64-windows
variables:
LINUX_BINDIST: "ghc-x86_64-deb9-linux.tar.xz"
WINDOWS_BINDIST: "ghc-x86_64-mingw32.tar.xz"
# Due to Windows allow_failure
allow_failure: true
artifacts:
paths:
- haddock.html.tar.xz
......@@ -695,8 +729,17 @@ doc-tarball:
- index.html
- "*.pdf"
script:
- |
if [ ! -f "$LINUX_BINDIST" ]; then
echo "Error: $LINUX_BINDIST does not exist. Did the Debian 9 job fail?"
exit 1
fi
if [ ! -f "$WINDOWS_BINDIST" ]; then
echo "Error: $WINDOWS_BINDIST does not exist. Did the 64-bit Windows job fail?"
exit 1
fi
- rm -Rf docs
- bash -ex distrib/mkDocs/mkDocs ghc-x86_64-deb9-linux.tar.xz ghc-x86_64-mingw32.tar.xz
- bash -ex distrib/mkDocs/mkDocs $LINUX_BINDIST $WINDOWS_BINDIST
- ls -lh
- mv docs/*.tar.xz docs/index.html .
......@@ -704,7 +747,8 @@ source-tarball:
stage: packaging
tags:
- x86_64-linux
image: ghcci/x86_64-linux-deb9:0.2
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
dependencies: []
only:
- tags
artifacts:
......@@ -732,8 +776,8 @@ source-tarball:
.hackage:
<<: *only-default
stage: hackage
image: ghcci/x86_64-linux-deb9:0.2
stage: testing
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
tags:
- x86_64-linux
dependencies: []
......@@ -758,11 +802,54 @@ nightly-hackage:
variables:
- $NIGHTLY
############################################################
# Nofib testing
############################################################
perf-nofib:
stage: nofib
dependencies:
- validate-x86_64-linux-deb9
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
only:
refs:
- merge_requests
- master
- /ghc-[0-9]+\.[0-9]+/
tags:
- x86_64-linux
script:
- root=$(pwd)/ghc
- |
mkdir tmp
tar -xf ghc-x86_64-deb9-linux.tar.xz -C tmp
pushd tmp/ghc-*/
./configure --prefix=$root
make install
popd
rm -Rf tmp
- export BOOT_HC=$(which ghc)
- cabal update; cabal install -w $BOOT_HC regex-compat
- export PATH=$root/bin:$PATH
- make -C nofib boot mode=fast -j$CPUS
- "make -C nofib EXTRA_RUNTEST_OPTS='-cachegrind +RTS -V0 -RTS' NoFibRuns=1 mode=fast -j$CPUS 2>&1 > nofib.log"
artifacts:
expire_in: 12 week
when: always
paths:
- nofib.log
############################################################
# Documentation deployment via GitLab Pages
############################################################
pages:
stage: deploy
dependencies:
- doc-tarball
image: ghcci/x86_64-linux-deb9:0.2
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
# Due to Windows allow_failure
allow_failure: true
tags:
- x86_64-linux
script:
......
......@@ -12,7 +12,7 @@
# RTS-like things
/rts/ @bgamari @simonmar @osa1 @Phyx @angerman
/rts/linker/ @angerman @Phyx
/rts/linker/ @angerman @Phyx @simonmar
/includes/ @bgamari @simonmar @osa1
# The compiler
......
......@@ -98,7 +98,7 @@ module CLabel (
needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
isLocalCLabel,
isLocalCLabel, mayRedirectTo,
-- * Conversions
toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
......@@ -1432,3 +1432,139 @@ pprDynamicLinkerAsmLabel platform dllInfo lbl =
SymbolPtr -> text ".LC_" <> ppr lbl
GotSymbolPtr -> ppr lbl <> text "@got"
GotSymbolOffset -> ppr lbl <> text "@gotoff"
-- Figure out whether `symbol` may serve as an alias
-- to `target` within one compilation unit.
--
-- This is true if any of these holds:
-- * `target` is a module-internal haskell name.
-- * `target` is an exported name, but comes from the same
-- module as `symbol`
--
-- These are sufficient conditions for establishing e.g. a
-- GNU assembly alias ('.equiv' directive). Sadly, there is
-- no such thing as an alias to an imported symbol (conf.
-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)
-- See note [emit-time elimination of static indirections].
--
-- Precondition is that both labels represent the
-- same semantic value.
mayRedirectTo :: CLabel -> CLabel -> Bool
mayRedirectTo symbol target
| Just nam <- haskellName
, staticClosureLabel
, isExternalName nam
, Just mod <- nameModule_maybe nam
, Just anam <- hasHaskellName symbol
, Just amod <- nameModule_maybe anam
= amod == mod
| Just nam <- haskellName
, staticClosureLabel
, isInternalName nam
= True
| otherwise = False
where staticClosureLabel = isStaticClosureLabel target
haskellName = hasHaskellName target
{-
Note [emit-time elimination of static indirections]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As described in #15155, certain static values are repesentationally
equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).
newtype A = A Int
{-# NOINLINE a #-}
a = A 42
a1_rYB :: Int
[GblId, Caf=NoCafRefs, Unf=OtherCon []]
a1_rYB = GHC.Types.I# 42#
a [InlPrag=NOINLINE] :: A
[GblId, Unf=OtherCon []]
a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)
Formerly we created static indirections for these (IND_STATIC), which
consist of a statically allocated forwarding closure that contains
the (possibly tagged) indirectee. (See CMM/assembly below.)
This approach is suboptimal for two reasons:
(a) they occupy extra space,
(b) they need to be entered in order to obtain the indirectee,
thus they cannot be tagged.
Fortunately there is a common case where static indirections can be
eliminated while emitting assembly (native or LLVM), viz. when the
indirectee is in the same module (object file) as the symbol that
points to it. In this case an assembly-level identification can
be created ('.equiv' directive), and as such the same object will
be assigned two names in the symbol table. Any of the identified
symbols can be referenced by a tagged pointer.
Currently the 'mayRedirectTo' predicate will
give a clue whether a label can be equated with another, already
emitted, label (which can in turn be an alias). The general mechanics
is that we identify data (IND_STATIC closures) that are amenable
to aliasing while pretty-printing of assembly output, and emit the
'.equiv' directive instead of static data in such a case.
Here is a sketch how the output is massaged:
Consider
newtype A = A Int
{-# NOINLINE a #-}
a = A 42 -- I# 42# is the indirectee
-- 'a' is exported
results in STG
a1_rXq :: GHC.Types.Int
[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
CCS_DONT_CARE GHC.Types.I#! [42#];
T15155.a [InlPrag=NOINLINE] :: T15155.A
[GblId, Unf=OtherCon []] =
CAF_ccs \ u [] a1_rXq;
and CMM
[section ""data" . a1_rXq_closure" {
a1_rXq_closure:
const GHC.Types.I#_con_info;
const 42;
}]
[section ""data" . T15155.a_closure" {
T15155.a_closure:
const stg_IND_STATIC_info;
const a1_rXq_closure+1;
const 0;
const 0;
}]
The emitted assembly is
#### INDIRECTEE
a1_rXq_closure: -- module local haskell value
.quad GHC.Types.I#_con_info -- an Int
.quad 42
#### BEFORE
.globl T15155.a_closure -- exported newtype wrapped value
T15155.a_closure:
.quad stg_IND_STATIC_info -- the closure info
.quad a1_rXq_closure+1 -- indirectee ('+1' being the tag)
.quad 0
.quad 0
#### AFTER
.globl T15155.a_closure -- exported newtype wrapped value
.equiv a1_rXq_closure,T15155.a_closure -- both are shared
The transformation is performed because
T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
returns True.
-}
......@@ -5,7 +5,7 @@
{-# LANGUAGE UndecidableInstances #-}
module CmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
, CmmReg(..), cmmRegType, cmmRegWidth
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
......@@ -43,6 +43,8 @@ import Unique
import Data.Set (Set)
import qualified Data.Set as Set
import BasicTypes (Alignment, mkAlignment, alignmentOf)
-----------------------------------------------------------------------------
-- CmmExpr
-- An expression. Expressions have no side effects.
......@@ -239,6 +241,13 @@ cmmLabelType dflags lbl
cmmExprWidth :: DynFlags -> CmmExpr -> Width
cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
-- | Returns an alignment in bytes of a CmmExpr when it's a statically
-- known integer constant, otherwise returns an alignment of 1 byte.
-- The caller is responsible for using with a sensible CmmExpr
-- argument.
cmmExprAlignment :: CmmExpr -> Alignment
cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)
cmmExprAlignment _ = mkAlignment 1
--------
--- Negation for conditional branches
......
......@@ -78,7 +78,9 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
-- closure pointing directly to the indirectee. This is exactly
-- what the CAF will eventually evaluate to anyway, we're just
-- shortcutting the whole process, and generating a lot less code
-- (#7308)
-- (#7308). Eventually the IND_STATIC closure will be eliminated
-- by assembly '.equiv' directives, where possible (#15155).
-- See note [emit-time elimination of static indirections] in CLabel.
--
-- Note: we omit the optimisation when this binding is part of a
-- recursive group, because the optimisation would inhibit the black
......
......@@ -2035,8 +2035,8 @@ doCopyByteArrayOp = emitCopyByteArray copy
where
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst dst_p src_p bytes =
emitMemcpyCall dst_p src_p bytes 1
copy _src _dst dst_p src_p bytes align =
emitMemcpyCall dst_p src_p bytes align
-- | Takes a source 'MutableByteArray#', an offset in the source
-- array, a destination 'MutableByteArray#', an offset into the
......@@ -2050,22 +2050,26 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
-- The only time the memory might overlap is when the two arrays
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
copy src dst dst_p src_p bytes align = do
dflags <- getDynFlags
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p bytes 1)
(getCode $ emitMemcpyCall dst_p src_p bytes 1)
(getCode $ emitMemmoveCall dst_p src_p bytes align)
(getCode $ emitMemcpyCall dst_p src_p bytes align)
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ())
-> Alignment -> FCode ())
-> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
emitCopyByteArray copy src src_off dst dst_off n = do
dflags <- getDynFlags
let byteArrayAlignment = wordAlignment dflags
srcOffAlignment = cmmExprAlignment src_off
dstOffAlignment = cmmExprAlignment dst_off
align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]
dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
copy src dst dst_p src_p n
copy src dst dst_p src_p n align
-- | Takes a source 'ByteArray#', an offset in the source array, a
-- destination 'Addr#', and the number of bytes to copy. Copies the given
......@@ -2075,7 +2079,7 @@ doCopyByteArrayToAddrOp src src_off dst_p bytes = do
-- Use memcpy (we are allowed to assume the arrays aren't overlapping)
dflags <- getDynFlags
src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
emitMemcpyCall dst_p src_p bytes 1
emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-- | Takes a source 'MutableByteArray#', an offset in the source array, a
-- destination 'Addr#', and the number of bytes to copy. Copies the given
......@@ -2092,7 +2096,7 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
-- Use memcpy (we are allowed to assume the arrays aren't overlapping)
dflags <- getDynFlags
dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
emitMemcpyCall dst_p src_p bytes 1
emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-- ----------------------------------------------------------------------------
......@@ -2107,9 +2111,7 @@ doSetByteArrayOp ba off len c = do
dflags <- getDynFlags
let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap
offsetAlignment = case off of
CmmLit (CmmInt intOff _) -> alignmentOf (fromInteger intOff)
_ -> mkAlignment 1
offsetAlignment = cmmExprAlignment off
align = min byteArrayAlignment offsetAlignment
p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
......@@ -2141,11 +2143,8 @@ doNewArrayOp res_r rep info payload n init = do
emit $ mkAssign arr base
-- Initialise all elements of the array
p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
let initialization =
[ mkStore (cmmOffsetW dflags (CmmReg (CmmLocal p)) off) init
| off <- [0.. n - 1]
]
let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)
initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]
emit (catAGraphs initialization)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
......@@ -2180,7 +2179,7 @@ doCopyArrayOp = emitCopyArray copy
copy _src _dst dst_p src_p bytes =
do dflags <- getDynFlags
emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags)
(wordAlignment dflags)
-- | Takes a source 'MutableArray#', an offset in the source array, a
......@@ -2198,9 +2197,9 @@ doCopyMutableArrayOp = emitCopyArray copy
dflags <- getDynFlags
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(wordAlignment dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(wordAlignment dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
......@@ -2247,7 +2246,7 @@ doCopySmallArrayOp = emitCopySmallArray copy
copy _src _dst dst_p src_p bytes =
do dflags <- getDynFlags
emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags)
(wordAlignment dflags)
doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
......@@ -2261,9 +2260,9 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
dflags <- getDynFlags
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(wordAlignment dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
(wORD_SIZE dflags))
(wordAlignment dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
......@@ -2328,7 +2327,7 @@ emitCloneArray info_p res_r src src_off n = do
(mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)
emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
(wORD_SIZE dflags)
(wordAlignment dflags)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
......@@ -2365,7 +2364,7 @@ emitCloneSmallArray info_p res_r src src_off n = do
(mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)
emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
(wORD_SIZE dflags)
(wordAlignment dflags)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
......@@ -2493,19 +2492,19 @@ doCasByteArray res mba idx idx_ty old new = do
-- Helpers for emitting function calls
-- | Emit a call to @memcpy@.
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
emitMemcpyCall dst src n align = do
emitPrimCall
[ {-no results-} ]
(MO_Memcpy align)
(MO_Memcpy (alignmentBytes align))
[ dst, src, n ]
-- | Emit a call to @memmove@.
emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
emitMemmoveCall dst src n align = do
emitPrimCall
[ {- no results -} ]
(MO_Memmove align)
(MO_Memmove (alignmentBytes align))
[ dst, src, n ]
-- | Emit a call to @memset@. The second argument must fit inside an
......
......@@ -2080,7 +2080,7 @@ defaultLintFlags = LF { lf_check_global_ids = False
newtype LintM a =
LintM { unLintM ::
LintEnv ->
WarnsAndErrs -> -- Error and warning messages so far
WarnsAndErrs -> -- Warning and error messages so far
(Maybe a, WarnsAndErrs) } -- Result and messages (if any)
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
......@@ -2189,10 +2189,13 @@ data LintLocInfo
| InCo Coercion -- Inside a coercion
initL :: DynFlags -> LintFlags -> InScopeSet
-> LintM a -> WarnsAndErrs -- Errors and warnings
-> LintM a -> WarnsAndErrs -- Warnings and errors
initL dflags flags in_scope m
= case unLintM m env (emptyBag, emptyBag) of
(_, errs) -> errs
(Just _, errs) -> errs
(Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs
| otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++
"without reporting an error message") empty
where
env = LE { le_flags = flags
, le_subst = mkEmptyTCvSubst in_scope
......
......@@ -157,7 +157,9 @@ data PmPat :: PatTy -> * where
PmNLit :: { pm_lit_id :: Id
, pm_lit_not :: [PmLit] } -> PmPat 'VA
PmGrd :: { pm_grd_pv :: PatVec
, pm_grd_expr :: PmExpr } -> PmPat 'PAT
, pm_grd_expr :: PmExpr } -> PmPat 'PAT
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle.
PmFake :: PmPat 'PAT
instance Outputable (PmPat a) where
ppr = pprPmPatDebug
......@@ -928,24 +930,11 @@ truePattern :: Pattern
truePattern = nullaryConPattern (RealDataCon trueDataCon)
{-# INLINE truePattern #-}
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
fake_pat :: Pattern
fake_pat = PmGrd { pm_grd_pv = [truePattern]
, pm_grd_expr = PmExprOther (EWildPat noExt) }
{-# INLINE fake_pat #-}
-- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool
isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
| c == trueDataCon = True
| otherwise = False
isFakeGuard _pats _e = False
-- | Generate a `canFail` pattern vector of a specific type
mkCanFailPmPat :: Type -> DsM PatVec
mkCanFailPmPat ty = do
var <- mkPmVar ty
return [var, fake_pat]
return [var, PmFake]
vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
-- ADT constructor pattern => no existentials, no local constraints
......@@ -1295,7 +1284,7 @@ translateGuards fam_insts guards = do
then pure all_guards
else do
kept <- filterM shouldKeep all_guards
pure (fake_pat : kept)
pure (PmFake : kept)
-- | Check whether a pattern can fail to match
cantFailPattern :: Pattern -> DsM Bool
......@@ -1377,7 +1366,7 @@ cases:
expressivity in our warnings.
Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
@fake_pat@: @True <- _@. That is, we record that there is a possibility
@PmFake@: @True <- _@. That is, we record that there is a possibility
of failure but we minimize it to a True/False. This generates a single
warning and much smaller uncovered sets.
......@@ -1421,7 +1410,7 @@ in the pattern bind case). Hence, we safely drop them.
Additionally, top-level guard translation (performed by @translateGuards@)
replaces guards that cannot be reasoned about (like the ones we described in
1-4) with a single @fake_pat@ to record the possibility of failure to match.
1-4) with a single @PmFake@ to record the possibility of failure to match.
Note [Translate CoPats]
~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1457,6 +1446,7 @@ pmPatType (PmNLit { pm_lit_id = x }) = idType x
pmPatType (PmGrd { pm_grd_pv = pv })
= ASSERT(patVecArity pv == 1) (pmPatType p)
where Just p = find ((==1) . patternArity) pv
pmPatType PmFake = pmPatType truePattern
-- | Information about a conlike that is relevant to coverage checking.
-- It is called an \"inhabitation candidate\" since it is a value which may
......@@ -1679,7 +1669,7 @@ mkGuard pv e = do
let expr = hsExprToPmExpr e
tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])
if | res -> pure (PmGrd pv expr)
| PmExprOther {} <- expr -> pure fake_pat
| PmExprOther {} <- expr -> pure PmFake
| otherwise -> pure (PmGrd pv expr)
-- | Create a term equality of the form: `(False ~ (x ~ lit))`
......@@ -1753,6 +1743,7 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
, pm_con_tvs = tvs, pm_con_dicts = dicts
, pm_con_args = coercePatVec args }]
coercePmPat (PmGrd {}) = [] -- drop the guards
coercePmPat PmFake = [] -- drop the guards
-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether
-- it is the only possible match in the given context. See also
......@@ -1765,7 +1756,7 @@ singleMatchConstructor cl tys =
Note [Single match constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When translating pattern guards for consumption by the checker, we desugar
every pattern guard that might fail ('cantFailPattern') to 'fake_pat'
every pattern guard that might fail ('cantFailPattern') to 'PmFake'
(True <- _). Which patterns can't fail? Exactly those that only match on
'singleMatchConstructor's.
......@@ -2023,13 +2014,15 @@ pmcheck [] guards vva@(ValVec [] _)
| otherwise = pmcheckGuardsI guards vva
-- Guard
pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
-- short-circuit if the guard pattern is useless.
-- we just have two possible outcomes: fail here or match and recurse
-- none of the two contains any useful information about the failure
-- though. So just have these two cases but do not do all the boilerplate
| isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
| otherwise = do
pmcheck (PmFake : ps) guards vva =
-- short-circuit if the guard pattern is useless.
-- we just have two possible outcomes: fail here or match and recurse
-- none of the two contains any useful information about the failure
-- though. So just have these two cases but do not do all the boilerplate
forces . mkCons vva <$> pmcheckI ps guards vva
pmcheck (p : ps) guards (ValVec vas delta)
| PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p
= do
y <- liftD $ mkPmId (pmPatType p)
let tm_state = extendSubst y e (delta_tm_cs delta)
delta' = delta { delta_tm_cs = tm_state }
......@@ -2182,6 +2175,7 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
= pmcheckHdI p ps guards (PmVar x) vva
-- Impossible: handled by pmcheck
pmcheckHd PmFake _ _ _ _ = panic "pmcheckHd: Fake"
pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
{-
......@@ -2742,6 +2736,7 @@ pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li
pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
<+> ppr ge
pprPmPatDebug PmFake = text "PmFake"
pprPatVec :: PatVec -> SDoc
pprPatVec ps = hang (text "Pattern:") 2
......
......@@ -105,14 +105,22 @@ import Data.Data hiding ( Fixity, Prefix, Infix )
type LBangType pass = Located (BangType pass)
-- | Bang Type
--
-- In the parser, strictness and packedness annotations bind more tightly
-- than docstrings. This means that when consuming a 'BangType' (and looking
-- for 'HsBangTy') we must be ready to peer behind a potential layer of
-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.
type BangType pass = HsType pass -- Bangs are in the HsType data type
getBangType :: LHsType a -> LHsType a
getBangType (L _ (HsBangTy _ _ ty)) = ty
getBangType ty = ty
getBangType (L _ (HsBangTy _ _ lty)) = lty
getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
addCLoc lty lds (HsDocTy x lty lds)
getBangType lty = lty
getBangStrictness :: LHsType a -> HsSrcBang
getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
{-
......
......@@ -185,6 +185,7 @@ pprSpecialStatic :: LlvmStatic -> SDoc
pprSpecialStatic (LMBitc v t) =
ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t
<> char ')'
pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v
pprSpecialStatic stat = ppr stat
......
......@@ -31,7 +31,7 @@ module LlvmCodeGen.Base (
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls,
aliasify,
aliasify, llvmDefLabel
) where
#include "HsVersions.h"
......@@ -57,6 +57,7 @@ import UniqSupply
import ErrUtils
import qualified Stream
import Data.Maybe (fromJust)
import Control.Monad (ap)
-- ----------------------------------------------------------------------------
......@@ -376,7 +377,7 @@ ghcInternalFunctions = do
mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
where
mk n ret args = do
let n' = fsLit n `appendFS` fsLit "$def"
let n' = llvmDefLabel $ fsLit n
decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
FixedArgs (tysToParams args) Nothing
renderLlvm $ ppLlvmFunctionDecl decl
......@@ -436,12 +437,17 @@ getGlobalPtr llvmLbl = do
let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
case m_ty of
-- Directly reference if we have seen it already
Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
-- Otherwise use a forward alias of it
Nothing -> do
saveAlias llvmLbl
return $ mkGlbVar llvmLbl i8 Alias
-- | Derive the definition label. It has an identified
-- structure type.
llvmDefLabel :: LMString -> LMString
llvmDefLabel = (`appendFS` fsLit "$def")
-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
--
-- Must be called at a point where we are sure that no new global definitions
......@@ -472,10 +478,28 @@ generateExternDecls = do
-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
-- See note [emit-time elimination of static indirections] in CLabel.
-- Here we obtain the indirectee's precise type and introduce
-- fresh aliases to both the precise typed label (lbl$def) and the i8*
-- typed (regular) label of it with the matching new names.
aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
(Just orig)) = do
let defLbl = llvmDefLabel lbl
LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
defOrigLbl = llvmDefLabel origLbl
orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
origType <- funLookup origLbl
let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
(pLift $ fromJust origType) oLnk
Nothing Nothing Alias))
(pLift ty)
pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
, LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
]
aliasify (LMGlobal var val) = do
let LMGlobalVar lbl ty link sect align const = var
defLbl = lbl `appendFS` fsLit "$def"
defLbl = llvmDefLabel lbl
defVar = LMGlobalVar defLbl ty Internal sect align const
defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
......
......@@ -32,12 +32,41 @@ import qualified Data.ByteString as BS
structStr :: LMString
structStr = fsLit "_struct"
-- | The LLVM visibility of the label
linkage :: CLabel -> LlvmLinkageType
linkage lbl = if externallyVisibleCLabel lbl
then ExternallyVisible else Internal
-- ----------------------------------------------------------------------------
-- * Top level
--
-- | Pass a CmmStatic section to an equivalent Llvm code.
genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
-- See note [emit-time elimination of static indirections] in CLabel.
genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind' = do
label <- strCLabel_llvm alias
label' <- strCLabel_llvm ind'
let link = linkage alias
link' = linkage ind'
-- the LLVM type we give the alias is an empty struct type
-- but it doesn't really matter, as the pointer is only
-- used for (bit/int)casting.
tyAlias = LMAlias (label `appendFS` structStr, LMStructU [])
aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
-- we don't know the type of the indirectee here
indType = panic "will be filled by 'aliasify', later"
orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias
pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
genLlvmData (sec, Statics lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
......@@ -45,11 +74,10 @@ genLlvmData (sec, Statics lbl xs) = do
let types = map getStatType static
strucTy = LMStruct types
tyAlias = LMAlias ((label `appendFS` structStr), strucTy)
tyAlias = LMAlias (label `appendFS` structStr, strucTy)
struct = Just $ LMStaticStruc static tyAlias
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
link = linkage lbl
align = case sec of
Section CString _ -> Just 1
_ -> Nothing
......
......@@ -71,7 +71,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
prefix lmblocks
name = decName $ funcDecl fun
defName = name `appendFS` fsLit "$def"
defName = llvmDefLabel name
funcDecl' = (funcDecl fun) { decName = defName }
fun' = fun { funcDecl = funcDecl' }
funTy = LMFunction funcDecl'
......
......@@ -41,6 +41,7 @@ module DynFlags (
whenGeneratingDynamicToo, ifGeneratingDynamicToo,
whenCannotGenerateDynamicToo,
dynamicTooMkDynamicDynFlags,
dynamicOutputFile,
DynFlags(..),
FlagSpec(..),
HasDynFlags(..), ContainsDynFlags(..),
......@@ -1823,6 +1824,12 @@ dynamicTooMkDynamicDynFlags dflags0
dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo
in dflags4
-- | Compute the path of the dynamic object corresponding to an object file.
dynamicOutputFile :: DynFlags -> FilePath -> FilePath
dynamicOutputFile dflags outputFile = dynOut outputFile
where
dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension
-----------------------------------------------------------------------------
-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value
......@@ -2772,11 +2779,11 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let chooseOutput
| isJust (outputFile dflags3) -- Only iff user specified -o ...
, not (isJust (dynOutputFile dflags3)) -- but not -dyno
= return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) }
= return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile }
| otherwise
= return dflags3
where
dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension
outFile = fromJust $ outputFile dflags3
dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3)
let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
......
......@@ -2805,6 +2805,9 @@ msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))
msHiFilePath ms = ml_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
msDynObjFilePath :: ModSummary -> DynFlags -> FilePath
msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)
-- | Did this 'ModSummary' originate from a hs-boot file?
isBootSummary :: ModSummary -> Bool
isBootSummary ms = ms_hsc_src ms == HsBootFile
......@@ -2824,20 +2827,26 @@ showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg dflags target recomp mod_summary = showSDoc dflags $
if gopt Opt_HideSourcePaths dflags
then text mod_str
else hsep
else hsep $
[ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')
, char '('
, text (op $ msHsFilePath mod_summary) <> char ','
, case target of
HscInterpreted | recomp -> text "interpreted"
HscNothing -> text "nothing"
_ -> text (op $ msObjFilePath mod_summary)
, char ')'
]
] ++
if gopt Opt_BuildDynamicToo dflags
then [ text obj_file <> char ','
, text dyn_file
, char ')'
]
else [ text obj_file, char ')' ]
where
op = normalise
mod = moduleName (ms_mod mod_summary)
mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
op = normalise
mod = moduleName (ms_mod mod_summary)
mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
dyn_file = op $ msDynObjFilePath mod_summary dflags
obj_file = case target of
HscInterpreted | recomp -> "interpreted"
HscNothing -> "nothing"
_ -> (op $ msObjFilePath mod_summary)
{-
************************************************************************
......
......@@ -27,6 +27,7 @@ import Hoopl.Label
import BlockId
import CLabel
import PprCmmExpr ()
import Unique ( pprUniqueAlways, getUnique )
import Platform
......@@ -119,6 +120,16 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
pprDatas :: CmmStatics -> SDoc
-- See note [emit-time elimination of static indirections] in CLabel.
pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
pprData :: CmmStatic -> SDoc
......
......@@ -102,6 +102,16 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
pprDatas :: CmmStatics -> SDoc
-- See note [emit-time elimination of static indirections] in CLabel.
pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
pprData :: CmmStatic -> SDoc
......@@ -634,4 +644,3 @@ pp_comma_lbracket = text ",["
pp_comma_a :: SDoc
pp_comma_a = text ",a"
......@@ -1767,12 +1767,11 @@ genCCall
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- Unroll memcpy calls if the source and destination pointers are at
-- least DWORD aligned and the number of bytes to copy isn't too
-- Unroll memcpy calls if the number of bytes to copy isn't too
-- large. Otherwise, call C's memcpy.
genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _
genCCall dflags _ (PrimTarget (MO_Memcpy align)) _
[dst, src, CmmLit (CmmInt n _)] _
| fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do
| fromInteger insns <= maxInlineMemcpyInsns dflags = do
code_dst <- getAnyReg dst
dst_r <- getNewRegNat format
code_src <- getAnyReg src
......@@ -1785,7 +1784,9 @@ genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _
-- instructions per move.
insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit)
maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
-- The size of each move, in bytes.
sizeBytes :: Integer
......
......@@ -145,7 +145,19 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
(l@LOCATION{} : _) -> pprInstr l
_other -> empty
pprDatas :: (Alignment, CmmStatics) -> SDoc
-- See note [emit-time elimination of static indirections] in CLabel.
pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
pprDatas (align, (Statics lbl dats))
= vcat (pprAlign align : pprLabel lbl : map pprData dats)
......
......@@ -50,7 +50,6 @@ module RdrHsSyn (
-- Bunch of functions in the parser monad for
-- checking and constructing values
checkBlockArguments,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
......@@ -61,7 +60,6 @@ module RdrHsSyn (
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
checkDoAndIfThenElse,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
......@@ -94,14 +92,6 @@ module RdrHsSyn (
ExpCmdI(..),
ecFromExp,
ecFromCmd,
ecHsLam,
ecHsLet,
ecOpApp,
ecHsCase,
ecHsApp,
ecHsIf,
ecHsDo,
ecHsPar,
) where
......@@ -672,10 +662,8 @@ mkConDeclH98 name mb_forall mb_cxt args
, con_forall = noLoc $ isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
, con_mb_cxt = mb_cxt
, con_args = args'
, con_args = args
, con_doc = Nothing }
where
args' = nudgeHsSrcBangs args
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs -- Always a HsForAllTy
......@@ -686,7 +674,7 @@ mkGadtDecl names ty
, con_forall = cL l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
, con_args = args'
, con_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
, anns1 ++ anns2)
......@@ -703,7 +691,6 @@ mkGadtDecl names ty
= (Nothing, tau, ann)
(args, res_ty) = split_tau tau
args' = nudgeHsSrcBangs args
-- See Note [GADT abstract syntax] in HsDecls
split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
......@@ -715,27 +702,6 @@ mkGadtDecl names ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
-- ^ This function ensures that fields with strictness or packedness
-- annotations put these annotations on an outer 'HsBangTy'.
--
-- The problem is that in the parser, strictness and packedness annotations
-- bind more tightly that docstrings. However, the expectation downstream of
-- the parser (by functions such as 'getBangType' and 'getBangStrictness')
-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
-- top-level type.
--
-- See #15206
nudgeHsSrcBangs details
= case details of
PrefixCon as -> PrefixCon (map go as)
RecCon r -> RecCon r
InfixCon a1 a2 -> InfixCon (go a1) (go a2)
where
go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
go lty = lty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
......@@ -1004,8 +970,9 @@ checkTyClHdr is_cls ty
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()
checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }
checkExpBlockArguments :: LHsExpr GhcPs -> P ()
checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
checkExpr :: LHsExpr GhcPs -> P ()
checkExpr expr = case unLoc expr of
......@@ -1315,19 +1282,6 @@ checkValSigLhs lhs@(dL->L l _)
default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse
:: forall b. ExpCmdI b =>
LHsExpr GhcPs
-> Bool
-> Located (b GhcPs)
-> Bool
-> Located (b GhcPs)
-> P ()
checkDoAndIfThenElse =
case expCmdG @b of
ExpG -> checkDoAndIfThenElse'
CmdG -> checkDoAndIfThenElse'
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> P ()
......@@ -1924,73 +1878,78 @@ checkMonadComp = do
newtype ExpCmdP =
ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
-- See Note [Ambiguous syntactic categories]
data ExpCmdG b where
ExpG :: ExpCmdG HsExpr
CmdG :: ExpCmdG HsCmd
-- See Note [Ambiguous syntactic categories]
class ExpCmdI b where expCmdG :: ExpCmdG b
instance ExpCmdI HsExpr where expCmdG = ExpG
instance ExpCmdI HsCmd where expCmdG = CmdG
ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
ecFromCmd c@(getLoc -> l) = ExpCmdP onB
where
onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c }
onExp :: P (LHsExpr GhcPs)
onExp = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
return (cL l hsHoleExpr)
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
ecFromExp e@(getLoc -> l) = ExpCmdP onB
where
onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd }
onCmd :: P (LHsCmd GhcPs)
onCmd =
addFatalError l $
text "Parse error in command:" <+> ppr e
ecFromExp a = ExpCmdP (ecFromExp' a)
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt }
ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }
ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
ecFromCmd a = ExpCmdP (ecFromCmd' a)
ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs
-> Located (b GhcPs) -> b GhcPs
ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }
where
cmdOpApp c1 op c2 =
-- See Note [Ambiguous syntactic categories]
class ExpCmdI b where
-- | Return a command without ambiguity, or fail in a non-command context.
ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs))
-- | Return an expression without ambiguity, or fail in a non-expression context.
ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs))
-- | Disambiguate "\... -> ..." (lambda)
ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-- | Disambiguate "let ... in ..."
ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
-- | Disambiguate "f # x" (infix operator)
ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs
-- | Disambiguate "case ... of ..."
ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-- | Disambiguate "f x" (function application)
ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
-- | Disambiguate "if ... then ... else ..."
ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
-- | Disambiguate "do { ... }" (do notation)
ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
-- | Disambiguate "( ... )" (parentheses)
ecHsPar :: Located (b GhcPs) -> b GhcPs
-- | Check if the argument requires -XBlockArguments.
checkBlockArguments :: Located (b GhcPs) -> PV ()
-- | Check if -XDoAndIfThenElse is enabled.
checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
-> Bool -> Located (b GhcPs) -> P ()
instance ExpCmdI HsCmd where
ecFromCmd' = return
ecFromExp' (dL-> L l e) =
addFatalError l $
text "Parse error in command:" <+> ppr e
ecHsLam = HsCmdLam noExt
ecHsLet = HsCmdLet noExt
ecOpApp c1 op c2 =
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
ecHsCase = HsCmdCase noExt
ecHsApp = HsCmdApp noExt
ecHsIf = mkHsCmdIf
ecHsDo = HsCmdDo noExt
ecHsPar = HsCmdPar noExt
checkBlockArguments = checkCmdBlockArguments
checkDoAndIfThenElse = checkDoAndIfThenElse'
instance ExpCmdI HsExpr where
ecFromCmd' (dL -> L l c) = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
return (cL l hsHoleExpr)
ecFromExp' = return
ecHsLam = HsLam noExt
ecHsLet = HsLet noExt
ecOpApp = OpApp noExt
ecHsCase = HsCase noExt
ecHsApp = HsApp noExt
ecHsIf = mkHsIf
ecHsDo = HsDo noExt DoExpr
ecHsPar = HsPar noExt
checkBlockArguments = checkExpBlockArguments
checkDoAndIfThenElse = checkDoAndIfThenElse'
ecHsCase :: forall b. ExpCmdI b =>
LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt }
ecHsApp :: forall b. ExpCmdI b =>
Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }
ecHsIf :: forall b. ExpCmdI b =>
LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }
ecHsDo :: forall b. ExpCmdI b =>
Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt }
ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs
ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2043,19 +2002,12 @@ we decided against, see Note [Resolving parsing ambiguities: non-taken alternati
The solution that keeps basic definitions (such as HsExpr) clean, keeps the
concerns local to the parser, and does not require duplication of hsSyn types,
or an extra pass over the entire AST, is to parse into a function from a GADT
to a parser-validator:
data ExpCmdG b where
ExpG :: ExpCmdG HsExpr
CmdG :: ExpCmdG HsCmd
or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding):
type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
checkExp f = f ExpG -- interpret as an expression
checkCmd f = f CmdG -- interpret as a command
class ExpCmdI b where ...
instance ExpCmdI HsCmd where ...
instance ExpCmdI HsExp where ...
Consider the 'alts' production used to parse case-of alternatives:
......@@ -2065,30 +2017,6 @@ Consider the 'alts' production used to parse case-of alternatives:
We abstract over LHsExpr, and it becomes:
alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
: alts1
{ \tag -> $1 tag >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts
{ \tag -> $2 tag >>= \ $2 ->
return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
Note that 'ExpCmdG' is a singleton type, the value is completely
determined by the type:
when (b~HsExpr), tag = ExpG
when (b~HsCmd), tag = CmdG
This is a clear indication that we can use a class to pass this value behind
the scenes:
class ExpCmdI b where expCmdG :: ExpCmdG b
instance ExpCmdI HsExpr where expCmdG = ExpG
instance ExpCmdI HsCmd where expCmdG = CmdG
And now the 'alts' production is simplified, as we no longer need to
thread 'tag' explicitly:
alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
: alts1 { $1 >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
......@@ -2331,6 +2259,63 @@ each reduction rule:
And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!
Alternative VIII, a function from a GADT
----------------------------------------
We could avoid code duplication of the Alternative VII by representing the product
as a function from a GADT:
data ExpCmdG b where
ExpG :: ExpCmdG HsExpr
CmdG :: ExpCmdG HsCmd
type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
checkExp f = f ExpG -- interpret as an expression
checkCmd f = f CmdG -- interpret as a command
Consider the 'alts' production used to parse case-of alternatives:
alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
: alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
We abstract over LHsExpr, and it becomes:
alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
: alts1
{ \tag -> $1 tag >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts
{ \tag -> $2 tag >>= \ $2 ->
return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
Note that 'ExpCmdG' is a singleton type, the value is completely
determined by the type:
when (b~HsExpr), tag = ExpG
when (b~HsCmd), tag = CmdG
This is a clear indication that we can use a class to pass this value behind
the scenes:
class ExpCmdI b where expCmdG :: ExpCmdG b
instance ExpCmdI HsExpr where expCmdG = ExpG
instance ExpCmdI HsCmd where expCmdG = CmdG
And now the 'alts' production is simplified, as we no longer need to
thread 'tag' explicitly:
alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
: alts1 { $1 >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { $2 >>= \ $2 ->
return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to
more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities.
-}
---------------------------------------------------------------------------
......