Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
172a5933
Commit
172a5933
authored
Jan 30, 2019
by
Ben Gamari
🐢
Browse files
Revert "Batch merge"
This reverts commit
76c8fd67
.
parent
76c8fd67
Changes
198
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 [Clean
ing up after shell executor
]
# ~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~
# Note [Clean
up 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
::
Name
Env
Id
{
name_remapping
::
M
.
Map
Name
Id
}
initState
::
HieState
initState
=
HieState
empty
NameEnv
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
lookup
NameEnv
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