Skip to content

GitLab

Commit 172a5933 authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Revert "Batch merge" 

This reverts commit 76c8fd67.
parent 76c8fd67
Hide whitespace changes
Inline Side-by-side
.gitlab-ci.yml
View file @ 172a5933
......@@ -6,7 +6,6 @@ before_script:
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
- "git fetch origin refs/notes/perf:refs/notes/ci/perf || true"
stages:
- lint
......@@ -76,7 +75,6 @@ validate-x86_64-linux-deb8-hadrian:
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
- "git fetch origin refs/notes/perf:refs/notes/ci/perf || true"
tags:
- x86_64-linux
......@@ -98,17 +96,9 @@ validate-x86_64-linux-deb8-hadrian:
- |
make binary-dist TAR_COMP_OPTS="-1"
mv ghc-*.tar.xz ghc.tar.xz
- |
# Prepare to push git notes.
METRICS_FILE=$(mktemp)
git config user.email "ben+ghc-ci@smart-cactus.org"
git config user.name "GHC GitLab CI"
- |
THREADS=`mk/detect-cpu-count.sh`
make $TEST_TYPE THREADS=$THREADS JUNIT_FILE=../../junit.xml METRICS_FILE=$METRICS_FILE
- |
# Push git notes.
METRICS_FILE=$METRICS_FILE .gitlab/push-test-metrics.sh
make $TEST_TYPE THREADS=$THREADS JUNIT_FILE=../../junit.xml
dependencies: []
artifacts:
reports:
......@@ -130,14 +120,12 @@ validate-x86_64-darwin:
ac_cv_func_clock_gettime: "no"
LANG: "en_US.UTF-8"
CONFIGURE_ARGS: --with-intree-gmp
TEST_ENV: "x86_64-darwin"
before_script:
- git clean -xdf && git submodule foreach git clean -xdf
- python3 .gitlab/fix-submodules.py
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
- "git fetch origin refs/notes/perf:refs/notes/ci/perf || true"
- bash .gitlab/darwin-init.sh
- PATH="`pwd`/toolchain/bin:$PATH"
......@@ -162,7 +150,6 @@ validate-x86_64-darwin:
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
- "git fetch origin refs/notes/perf:refs/notes/ci/perf || true"
- bash .circleci/prepare-system.sh
# workaround for docker permissions
......@@ -180,8 +167,6 @@ validate-aarch64-linux-deb9:
stage: full-build
image: ghcci/aarch64-linux-deb9:0.1
allow_failure: true
variables:
TEST_ENV: "aarch64-linux-deb9"
artifacts:
when: always
expire_in: 2 week
......@@ -206,8 +191,6 @@ validate-i386-linux-deb9:
stage: full-build
image: ghcci/i386-linux-deb9:0.1
allow_failure: true
variables:
TEST_ENV: "i386-linux-deb9"
artifacts:
when: always
expire_in: 2 week
......@@ -221,7 +204,6 @@ nightly-i386-linux-deb9:
allow_failure: true
variables:
TEST_TYPE: slowtest
TEST_ENV: "i386-linux-deb9"
artifacts:
when: always
expire_in: 2 week
......@@ -235,8 +217,6 @@ validate-x86_64-linux-deb9:
extends: .validate-linux
stage: build
image: ghcci/x86_64-linux-deb9:0.2
variables:
TEST_ENV: "x86_64-linux-deb9"
artifacts:
when: always
expire_in: 2 week
......@@ -261,7 +241,6 @@ validate-x86_64-linux-deb9-llvm:
image: ghcci/x86_64-linux-deb9:0.2
variables:
BUILD_FLAVOUR: perf-llvm
TEST_ENV: "x86_64-linux-deb9-llvm"
cache:
key: linux-x86_64-deb9
......@@ -269,8 +248,6 @@ validate-x86_64-linux-deb8:
extends: .validate-linux
stage: full-build
image: ghcci/x86_64-linux-deb8:0.1
variables:
TEST_ENV: "x86_64-linux-deb8"
cache:
key: linux-x86_64-deb8
artifacts:
......@@ -281,8 +258,6 @@ validate-x86_64-linux-fedora27:
extends: .validate-linux
stage: full-build
image: ghcci/x86_64-linux-fedora27:0.1
variables:
TEST_ENV: "x86_64-linux-fedora27"
cache:
key: linux-x86_64-fedora27
artifacts:
......@@ -294,7 +269,6 @@ validate-x86_64-linux-deb9-integer-simple:
stage: full-build
variables:
INTEGER_LIBRARY: integer-simple
TEST_ENV: "x86_64-linux-deb9-integer-simple"
image: ghcci/x86_64-linux-deb9:0.2
cache:
key: linux-x86_64-deb9
......@@ -315,7 +289,6 @@ validate-x86_64-linux-deb9-unreg:
stage: full-build
variables:
CONFIGURE_ARGS: --enable-unregisterised
TEST_ENV: "x86_64-linux-deb9-unreg"
image: ghcci/x86_64-linux-deb9:0.2
cache:
key: linux-x86_64-deb9
......@@ -341,7 +314,6 @@ validate-x86_64-linux-deb9-unreg:
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
- "git fetch origin refs/notes/perf:refs/notes/ci/perf || true"
- bash .gitlab/win32-init.sh
after_script:
- rd /s /q tmp
......@@ -408,8 +380,8 @@ validate-x86_64-windows:
- ghc.tar.xz
- junit.xml
# Note [Cleaning up after shell executor]
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Note [Cleanup on Windows]
# ~~~~~~~~~~~~~~~~~~~~~~~~~
#
# As noted in [1], gitlab-runner's shell executor doesn't clean up its working
# directory after builds. Unfortunately, we are forced to use the shell executor
......@@ -419,7 +391,7 @@ validate-x86_64-windows:
#
# [1] https://gitlab.com/gitlab-org/gitlab-runner/issues/3856
# See Note [Cleanup after shell executor]
# See Note [Cleanup on Windows]
cleanup-windows:
stage: cleanup
tags:
......@@ -440,21 +412,3 @@ cleanup-windows:
- del %BUILD_DIR%\* /F /Q
- for /d %%p in (%BUILD_DIR%\*) do rd /Q /S "%%p"
- exit /b 0
# See Note [Cleanup after shell executor]
cleanup-darwin:
stage: cleanup
tags:
- x86_64-darwin
when: always
before_script:
- echo "Time to clean up"
script:
- echo "Let's go"
after_script:
- BUILD_DIR=$CI_PROJECT_DIR
- echo "Cleaning $BUILD_DIR"
- cd $HOME
- rm -Rf $BUILD_DIR/*
- exit 0
.gitlab/push-test-metrics.sh deleted 100755 → 0
View file @ 76c8fd67
#!/usr/bin/env bash
# vim: sw=2 et
set -euo pipefail
NOTES_ORIGIN="git@gitlab.haskell.org:ghc/ghc-performance-notes.git"
REF="perf"
fail() {
echo "ERROR: $*" >&2
exit 1
}
# Check that private key is available (Set on all GitLab protected branches).
if ! [ -v PERF_NOTE_KEY ] || [ "$PERF_NOTE_KEY" = "" ]; then
echo "Not pushing performance git notes: PERF_NOTE_KEY is not set."
exit 0
fi
# TEST_ENV must be set.
if ! [ -v TEST_ENV ] || [ "$TEST_ENV" = "" ]; then
fail "Not pushing performance git notes: TEST_ENV must be set."
fi
# Assert that the METRICS_FILE exists and can be read.
if ! [ -v TEST_ENV ] || [ "$METRICS_FILE" = "" ]
then
fail "\$METRICS_FILE not set."
fi
if ! [ -r $METRICS_FILE ]
then
fail "Metrics file not found: $METRICS_FILE"
fi
# Add gitlab as a known host.
mkdir -p ~/.ssh
echo "|1|+AUrMGS1elvPeLNt+NHGa5+c6pU=|4XvfRsQftO1OgZD4c0JJ7oNaii8= ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAACAQDXilA5l4kOZPx0nM6xDATF+t4fS6te0eYPDwBI/jLWD9cJVtCnsrwMl5ar+/NfmcD0jnCYztUiVHuXyTaWPJYSQpwltfpTeqpo9/z/0MxkPtSl1uMP2cLbDiqA01OWveChktOXwU6hRQ+7MmO+dNRS/iXrRmYrGv/p1W811QgLBLS9fefEdF25n+0dP71L7Ov7riOawlDmd0C11FraE/R8HX6gs6lbXta1kisdxGyKojYSiCtobUaJxRoatMfUP0a9rwTAyl8tf56LgB+igjMky879VAbL7eQ/AmfHYPrSGJ/YlWP6Jj23Dnos5nOVlWL/rVTs9Y/NakLpPwMs75KTC0Pd74hdf2e3folDdAi2kLrQgO2SI6so7rOYZ+mFkCM751QdDVy4DzjmDvSgSIVf9SV7RQf7e7unE7pSZ/ILupZqz9KhR1MOwVO+ePa5qJMNSdC204PIsRWkIO5KP0QLl507NI9Ri84+aODoHD7gDIWNhU08J2P8/E6r0wcC8uWaxh+HaOjI9BkHjqRYsrgfn54BAuO9kw1cDvyi3c8n7VFlNtvQP15lANwim3gr9upV+r95KEPJCgZMYWJBDPIVtp4GdYxCfXxWj5oMXbA5pf0tNixwNJjAsY7I6RN2htHbuySH36JybOZk+gCj6mQkxpCT/tKaUn14hBJWLq7Q+Q==" >> ~/.ssh/known_hosts
echo "|1|JZkdAPJmpX6SzGeqhmQLfMWLGQA=|4vTELroOlbFxbCr0WX+PK9EcpD0= ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIJknufU+I6A5Nm58lmse4/o11Ai2UzYbYe7782J1+kRk" >> ~/.ssh/known_hosts
# Setup ssh keys.
eval `ssh-agent`
echo "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDJPR1vrZgeGTXmgJw2PsJfMjf22LcDnVVwt3l0rwTZ+8Q2J0bHaYxMRKBco1sON6LGcZepw0Hy76RQ87v057pTz18SXvnfE7U/B6v9qBk0ILJz+4BOX9sEhxu2XmScp/wMxkG9IoyruMlsxXzd1sz09o+rzzx24U2Rp27PRm08vG0oipve6BWLbYEqYrE4/nCufqOJmGd56fju7OTU0lTpEkGDEDWGMxutaX2CbTbDju7qy07Ld8BjSc9aHfvuQaslUbj3ex3EF8EXahURzGpHQn/UFFzVGMokFumiJCAagHQb7cj6jOkKseZLaysbA/mTBQsOzjWiRmkN23bQf1wF ben+ghc-ci@smart-cactus.org" > ~/.ssh/perf_rsa.pub
touch ~/.ssh/perf_rsa
chmod 0600 ~/.ssh/perf_rsa
echo "$PERF_NOTE_KEY" >> ~/.ssh/perf_rsa
ssh-add ~/.ssh/perf_rsa
# Reset the git notes and append the metrics file to the notes, then push and return the result.
# This is favoured over a git notes merge as it avoids potential data loss/duplication from the merge strategy.
function reset_append_note_push {
git fetch -f $NOTES_ORIGIN refs/notes/$REF:refs/notes/$REF || true
echo "git notes --ref=$REF append -F $METRICS_FILE HEAD"
git notes --ref=$REF append -F $METRICS_FILE HEAD
echo "git push $NOTES_ORIGIN refs/notes/$REF"
git push $NOTES_ORIGIN refs/notes/$REF
}
# Push the metrics file as a git note. This may fail if another task pushes a note first. In that case
# the latest note is fetched and appended.
MAX_RETRY=20
until reset_append_note_push || [ $MAX_RETRY -le 0 ]
do
((MAX_RETRY--))
echo ""
echo "Failed to push git notes. Fetching, appending, and retrying... $MAX_RETRY retries left."
done
compiler/hieFile/HieAst.hs
View file @ 172a5933
......@@ -28,11 +28,9 @@ import HscTypes
import Module ( ModuleName, ml_hs_file )
import MonadUtils ( concatMapM, liftIO )
import Name ( Name, nameSrcSpan, setNameLoc )
import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import SrcLoc
import TcHsSyn ( hsLitType, hsPatType )
import Type ( mkFunTys, Type )
import TysWiredIn ( mkListTy, mkSumTy )
import TcHsSyn ( hsPatType )
import Type ( Type )
import Var ( Id, Var, setVarName, varName, varType )
import HieTypes
......@@ -62,11 +60,11 @@ We don't care about the distinction between mono and poly bindings,
so we replace all occurrences of the mono name with the poly name.
-}
newtype HieState = HieState
{ name_remapping :: NameEnv Id
{ name_remapping :: M.Map Name Id
}
initState :: HieState
initState = HieState emptyNameEnv
initState = HieState M.empty
class ModifyState a where -- See Note [Name Remapping]
addSubstitution :: a -> a -> HieState -> HieState
......@@ -76,7 +74,7 @@ instance ModifyState Name where
instance ModifyState Id where
addSubstitution mono poly hs =
hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
modifyState = foldr go id
......@@ -379,9 +377,7 @@ instance ToHie (Context (Located Var)) where
C context (L (RealSrcSpan span) name')
-> do
m <- asks name_remapping
let name = case lookupNameEnv m (varName name') of
Just var -> var
Nothing-> name'
let name = M.findWithDefault name' (varName name') m
pure
[Node
(NodeInfo S.empty [] $
......@@ -396,7 +392,7 @@ instance ToHie (Context (Located Name)) where
toHie c = case c of
C context (L (RealSrcSpan span) name') -> do
m <- asks name_remapping
let name = case lookupNameEnv m name' of
let name = case M.lookup name' m of
Just var -> varName var
Nothing -> name'
pure
......@@ -436,67 +432,13 @@ instance HasType (LPat GhcTc) where
instance HasType (LHsExpr GhcRn) where
getTypeNode (L spn e) = makeNode e spn
-- | This instance tries to construct 'HieAST' nodes which include the type of
-- the expression. It is not yet possible to do this efficiently for all
-- expression forms, so we skip filling in the type for those inputs.
--
-- 'HsApp', for example, doesn't have any type information available directly on
-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
-- query the type of that. Yet both the desugaring call and the type query both
-- involve recursive calls to the function and argument! This is particularly
-- problematic when you realize that the HIE traversal will eventually visit
-- those nodes too and ask for their types again.
--
-- Since the above is quite costly, we just skip cases where computing the
-- expression's type is going to be expensive.
--
-- See #16233
instance HasType (LHsExpr GhcTc) where
getTypeNode e@(L spn e') = lift $
-- Some expression forms have their type immediately available
let tyOpt = case e' of
HsLit _ l -> Just (hsLitType l)
HsOverLit _ o -> Just (overLitType o)
HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
ExplicitList ty _ _ -> Just (mkListTy ty)
ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
HsDo ty _ _ -> Just ty
HsMultiIf ty _ -> Just ty
_ -> Nothing
in
case tyOpt of
_ | skipDesugaring e' -> fallback
| otherwise -> do
hs_env <- Hsc $ \e w -> return (e,w)
(_,mbe) <- liftIO $ deSugarExpr hs_env e
maybe fallback (makeTypeNode e' spn . exprType) mbe
where
fallback = makeNode e' spn
matchGroupType :: MatchGroupTc -> Type
matchGroupType (MatchGroupTc args res) = mkFunTys args res
-- | Skip desugaring of these expressions for performance reasons.
--
-- See impact on Haddock output (esp. missing type annotations or links)
-- before marking more things here as 'False'. See impact on Haddock
-- performance before marking more things as 'True'.
skipDesugaring :: HsExpr a -> Bool
skipDesugaring e = case e of
HsVar{} -> False
HsUnboundVar{} -> False
HsConLikeOut{} -> False
HsRecFld{} -> False
HsOverLabel{} -> False
HsIPVar{} -> False
HsWrap{} -> False
_ -> True
getTypeNode e@(L spn e') = lift $ do
hs_env <- Hsc $ \e w -> return (e,w)
(_,mbe) <- liftIO $ deSugarExpr hs_env e
case mbe of
Just te -> makeTypeNode e' spn (exprType te)
Nothing -> makeNode e' spn
instance ( ToHie (Context (Located (IdP a)))
, ToHie (MatchGroup a (LHsExpr a))
......
compiler/nativeGen/X86/CodeGen.hs
View file @ 172a5933
......@@ -2045,37 +2045,25 @@ genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] b
| otherwise = do
code_src <- getAnyReg src
src_r <- getNewRegNat format
tmp_r <- getNewRegNat format
let dst_r = getRegisterReg platform False (CmmLocal dst)
if isBmi2Enabled dflags
then do
src_r <- getNewRegNat (intFormat width)
return $ appOL (code_src src_r) $ case width of
W8 -> toOL
[ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit
, LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros
, SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros
]
W16 -> toOL
[ LZCNT II16 (OpReg src_r) dst_r
, MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit
]
_ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)
else do
let format = if width == W8 then II16 else intFormat width
src_r <- getNewRegNat format
tmp_r <- getNewRegNat format
return $ code_src src_r `appOL` toOL
([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++
[ BSR format (OpReg src_r) tmp_r
, MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)
, CMOV NE format (OpReg tmp_r) dst_r
, XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r)
]) -- NB: We don't need to zero-extend the result for the
-- W8/W16 cases because the 'MOV' insn already
-- took care of implicitly clearing the upper bits
-- The following insn sequence makes sure 'clz 0' has a defined value.
-- starting with Haswell, one could use the LZCNT insn instead.
return $ code_src src_r `appOL` toOL
([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++
[ BSR format (OpReg src_r) tmp_r
, MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)
, CMOV NE format (OpReg tmp_r) dst_r
, XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r)
]) -- NB: We don't need to zero-extend the result for the
-- W8/W16 cases because the 'MOV' insn already
-- took care of implicitly clearing the upper bits
where
bw = widthInBits width
platform = targetPlatform dflags
format = if width == W8 then II16 else intFormat width
lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))
genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
......@@ -2085,7 +2073,6 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
dst_r = getRegisterReg platform False (CmmLocal dst)
lbl1 <- getBlockIdNat
lbl2 <- getBlockIdNat
let format = if width == W8 then II16 else intFormat width
tmp_r <- getNewRegNat format
-- New CFG Edges:
......@@ -2122,38 +2109,24 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
| otherwise = do
code_src <- getAnyReg src
src_r <- getNewRegNat format
tmp_r <- getNewRegNat format
let dst_r = getRegisterReg platform False (CmmLocal dst)
if isBmi2Enabled dflags
then do
src_r <- getNewRegNat (intFormat width)
return $ appOL (code_src src_r) $ case width of
W8 -> toOL
[ OR II32 (OpImm (ImmInt 0xFFFFFF00)) (OpReg src_r)
, TZCNT II32 (OpReg src_r) dst_r
]
W16 -> toOL
[ TZCNT II16 (OpReg src_r) dst_r
, MOVZxL II16 (OpReg dst_r) (OpReg dst_r)
]
_ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r
else do
-- The following insn sequence makes sure 'ctz 0' has a defined value.
-- starting with Haswell, one could use the TZCNT insn instead.
let format = if width == W8 then II16 else intFormat width
src_r <- getNewRegNat format
tmp_r <- getNewRegNat format
return $ code_src src_r `appOL` toOL
([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++
[ BSF format (OpReg src_r) tmp_r
, MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r)
, CMOV NE format (OpReg tmp_r) dst_r
]) -- NB: We don't need to zero-extend the result for the
-- W8/W16 cases because the 'MOV' insn already
-- took care of implicitly clearing the upper bits
-- The following insn sequence makes sure 'ctz 0' has a defined value.
-- starting with Haswell, one could use the TZCNT insn instead.
return $ code_src src_r `appOL` toOL
([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++
[ BSF format (OpReg src_r) tmp_r
, MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r)
, CMOV NE format (OpReg tmp_r) dst_r
]) -- NB: We don't need to zero-extend the result for the
-- W8/W16 cases because the 'MOV' insn already
-- took care of implicitly clearing the upper bits
where
bw = widthInBits width
platform = targetPlatform dflags
format = if width == W8 then II16 else intFormat width
genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
targetExpr <- cmmMakeDynamicReference dflags
......
compiler/nativeGen/X86/Instr.hs
View file @ 172a5933
......@@ -342,8 +342,6 @@ data Instr
-- bit counting instructions
| POPCNT Format Operand Reg -- [SSE4.2] count number of bits set to 1
| LZCNT Format Operand Reg -- [BMI2] count number of leading zeros
| TZCNT Format Operand Reg -- [BMI2] count number of trailing zeros
| BSF Format Operand Reg -- bit scan forward
| BSR Format Operand Reg -- bit scan reverse
......@@ -473,8 +471,6 @@ x86_regUsageOfInstr platform instr
DELTA _ -> noUsage
POPCNT _ src dst -> mkRU (use_R src []) [dst]
LZCNT _ src dst -> mkRU (use_R src []) [dst]
TZCNT _ src dst -> mkRU (use_R src []) [dst]
BSF _ src dst -> mkRU (use_R src []) [dst]
BSR _ src dst -> mkRU (use_R src []) [dst]
......@@ -657,8 +653,6 @@ x86_patchRegsOfInstr instr env
CLTD _ -> instr
POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)
LZCNT fmt src dst -> LZCNT fmt (patchOp src) (env dst)
TZCNT fmt src dst -> TZCNT fmt (patchOp src) (env dst)
PDEP fmt src mask dst -> PDEP fmt (patchOp src) (patchOp mask) (env dst)
PEXT fmt src mask dst -> PEXT fmt (patchOp src) (patchOp mask) (env dst)
BSF fmt src dst -> BSF fmt (patchOp src) (env dst)
......
compiler/nativeGen/X86/Ppr.hs
View file @ 172a5933
......@@ -693,8 +693,6 @@ pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor") format src dst
pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)
pprInstr (LZCNT format src dst) = pprOpOp (sLit "lzcnt") format src (OpReg dst)
pprInstr (TZCNT format src dst) = pprOpOp (sLit "tzcnt") format src (OpReg dst)
pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst)
pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst)
......
compiler/parser/RdrHsSyn.hs
View file @ 172a5933
......@@ -151,11 +151,10 @@ mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
= do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams
; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts
; sequence_ annsi
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts
; sequence_ anns
; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
......@@ -187,7 +186,7 @@ mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs })
; pure (f, addAnnsAt loc anns) }
; pure (f, anns) }
mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
mkATDefault _ = panic "mkATDefault: Impossible Match"
......@@ -204,9 +203,8 @@ mkTyData :: SrcSpan
mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (cL loc (DataDecl { tcdDExt = noExt,
tcdLName = tc, tcdTyVars = tyvars,
......@@ -237,9 +235,8 @@ mkTySynonym :: SrcSpan
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
; return (cL loc (SynDecl { tcdSExt = noExt
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
......@@ -296,9 +293,8 @@ mkFamDecl :: SrcSpan
-> P (LTyClDecl GhcPs)
mkFamDecl loc info lhs ksig injAnn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
; return (cL loc (FamDecl noExt (FamilyDecl
{ fdExt = noExt
, fdInfo = info, fdLName = tc
......@@ -808,11 +804,13 @@ really doesn't matter!
-}
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> P (LHsQTyVars GhcPs, [AddAnn])
-> P (LHsQTyVars GhcPs)
-- Same as checkTyVars, but in the P monad
checkTyVarsP pp_what equals_or_where tc tparms
= do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms
; eitherToP checkedTvs }
; (tvs, anns) <- eitherToP checkedTvs
; anns
; pure tvs }
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
......@@ -822,14 +820,14 @@ eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]
-> Either (SrcSpan, SDoc)
( LHsQTyVars GhcPs -- the synthesized type variables
, [AddAnn] ) -- action which adds annotations
, P () ) -- action which adds annotations
-- ^ Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
-- We use the Either monad because it's also called (via 'mkATDefault') from
-- "Convert".
checkTyVars pp_what equals_or_where tc tparms
= do { (tvs, anns) <- fmap unzip $ mapM check tparms
; return (mkHsQTvs tvs, concat anns) }
; return (mkHsQTvs tvs, sequence_ anns) }
where