...
 
Commits (26)
  • Travis Whitaker's avatar
    Correct closure observation, construction, and mutation on weak memory machines. · 11bac115
    Travis Whitaker authored
    Here the following changes are introduced:
        - A read barrier machine op is added to Cmm.
        - The order in which a closure's fields are read and written is changed.
        - Memory barriers are added to RTS code to ensure correctness on
          out-or-order machines with weak memory ordering.
    
    Cmm has a new CallishMachOp called MO_ReadBarrier. On weak memory machines, this
    is lowered to an instruction that ensures memory reads that occur after said
    instruction in program order are not performed before reads coming before said
    instruction in program order. On machines with strong memory ordering properties
    (e.g. X86, SPARC in TSO mode) no such instruction is necessary, so
    MO_ReadBarrier is simply erased. However, such an instruction is necessary on
    weakly ordered machines, e.g. ARM and PowerPC.
    
    Weam memory ordering has consequences for how closures are observed and mutated.
    For example, consider a closure that needs to be updated to an indirection. In
    order for the indirection to be safe for concurrent observers to enter, said
    observers must read the indirection's info table before they read the
    indirectee. Furthermore, the entering observer makes assumptions about the
    closure based on its info table contents, e.g. an INFO_TYPE of IND imples the
    closure has an indirectee pointer that is safe to follow.
    
    When a closure is updated with an indirection, both its info table and its
    indirectee must be written. With weak memory ordering, these two writes can be
    arbitrarily reordered, and perhaps even interleaved with other threads' reads
    and writes (in the absence of memory barrier instructions). Consider this
    example of a bad reordering:
    
    - An updater writes to a closure's info table (INFO_TYPE is now IND).
    - A concurrent observer branches upon reading the closure's INFO_TYPE as IND.
    - A concurrent observer reads the closure's indirectee and enters it. (!!!)
    - An updater writes the closure's indirectee.
    
    Here the update to the indirectee comes too late and the concurrent observer has
    jumped off into the abyss. Speculative execution can also cause us issues,
    consider:
    
    - An observer is about to case on a value in closure's info table.
    - The observer speculatively reads one or more of closure's fields.
    - An updater writes to closure's info table.
    - The observer takes a branch based on the new info table value, but with the
      old closure fields!
    - The updater writes to the closure's other fields, but its too late.
    
    Because of these effects, reads and writes to a closure's info table must be
    ordered carefully with respect to reads and writes to the closure's other
    fields, and memory barriers must be placed to ensure that reads and writes occur
    in program order. Specifically, updates to a closure must follow the following
    pattern:
    
    - Update the closure's (non-info table) fields.
    - Write barrier.
    - Update the closure's info table.
    
    Observing a closure's fields must follow the following pattern:
    
    - Read the closure's info pointer.
    - Read barrier.
    - Read the closure's (non-info table) fields.
    
    This patch updates RTS code to obey this pattern. This should fix long-standing
    SMP bugs on ARM (specifically newer aarch64 microarchitectures supporting
    out-of-order execution) and PowerPC. This fixes issue #15449.
    Co-Authored-By: Ben Gamari's avatarBen Gamari <ben@well-typed.com>
    11bac115
  • Ben Gamari's avatar
    rts: Assert that LDV profiling isn't used with parallel GC · bd660ede
    Ben Gamari authored
    I'm not entirely sure we are careful about ensuring this; this is a
    last-ditch check.
    bd660ede
  • Moritz Angermann's avatar
    Add _GLOBAL_OFFSET_TABLE_ support · 82693938
    Moritz Angermann authored
    This adds lookup logic for _GLOBAL_OFFSET_TABLE_ as well as
    relocation logic for R_ARM_BASE_PREL and R_ARM_GOT_BREL which
    the gnu toolchain (gas, gcc, ...) prefers to produce.  Apparently
    recent llvm toolchains will produce those as well.
    82693938
  • Edward Amsden's avatar
  • Moritz Angermann's avatar
    No atomics on arm32; this will just yield stubs. · e9abcad4
    Moritz Angermann authored
    As such the internal linker will fail for them.  The alternative
    would be to implement them as stubs in the linker and have them
    barf when called.
    
    > Not all operations are supported by all target processors. If a
      particular operation cannot be implemented on the target processor,
      a warning is generated and a call an external function is
      generated. The external function carries the same name as the
      built-in version, with an additional suffix ‘_n’ where n is the size
      of the data type.
    
    (https://gcc.gnu.org/onlinedocs/gcc/_005f_005fsync-Builtins.html)
    e9abcad4
  • Ben Gamari's avatar
    Apply suggestion to rts/linker/elf_got.c · 023a2bc7
    Ben Gamari authored
    023a2bc7
  • Ben Gamari's avatar
    Apply suggestion to rts/linker/Elf.c · 0bed9647
    Ben Gamari authored
    0bed9647
  • Alex D's avatar
  • Eric Wolf's avatar
    Add test for #16575 · 294b55dc
    Eric Wolf authored
    just use the test to show the defective behaviour, so we can see
    the difference, when it gets fixed
    294b55dc
  • Ömer Sinan Ağacan's avatar
    Fix stage 1 warnings · 60b9eab9
    Ömer Sinan Ağacan authored
    60b9eab9
  • David Eichmann's avatar
    Hadrian: disable cloud build cache for symlinks #16800 · df3e5b74
    David Eichmann authored
    This is a temporary workaround shake not supporting symlinks
    when using cloud/cached builds.
    df3e5b74
  • Abhiroop Sarkar's avatar
    Add support for SIMD operations in the NCG · acd79558
    Abhiroop Sarkar authored
    This adds support for constructing vector types from Float#, Double# etc
    and performing arithmetic operations on them
    Cleaned-Up-By: Ben Gamari's avatarBen Gamari <ben@well-typed.com>
    acd79558
  • Ben Gamari's avatar
    gitlab-ci: Fix doc-tarball job · 973c61b5
    Ben Gamari authored
    Previously we used the deb9-debug job which used the `validate` build
    flavour which disabled `BUILD_SPHINX_PDF`. Fix this.
    
    Fixes #16890.
    973c61b5
  • Ryan Scott's avatar
    Bump template-haskell version to 2.16.0.0 · a25f6f55
    Ryan Scott authored
    Commit cef80c0b debuted a breaking
    change to `template-haskell`, so in order to guard against it
    properly with CPP, we need to bump the `template-haskell` version
    number accordingly.
    a25f6f55
  • Ben Gamari's avatar
    Bump parsec submodule to 3.1.14.0 · f7a2e709
    Ben Gamari authored
    f7a2e709
  • Siddharth Bhat's avatar
    Make printer untag when chasing a pointer in a RET_FUN frame · d7f7e1ed
    Siddharth Bhat authored
    This is to mimic what `Scav.c` does. This should fix a crash in
    the printer.
    d7f7e1ed
  • Ben Gamari's avatar
    gitlab: Reduce size of template headings · 675d27fc
    Ben Gamari authored
    675d27fc
  • Vladislav Zavialov's avatar
    Produce all DerivInfo in tcTyAndClassDecls · 679427f8
    Vladislav Zavialov authored
    Before this refactoring:
    
    * DerivInfo for data family instances was returned from tcTyAndClassDecls
    * DerivInfo for data declarations was generated with mkDerivInfos and added at a
      later stage of the pipeline in tcInstDeclsDeriv
    
    After this refactoring:
    
    * DerivInfo for both data family instances and data declarations is returned from
      tcTyAndClassDecls in a single list.
    
    This uniform treatment results in a more convenient arrangement to fix #16731.
    679427f8
  • Simon Peyton Jones's avatar
    Add a missing zonk (fixes #16902) · 53aa59f3
    Simon Peyton Jones authored
    In the eager unifier, when unifying (tv1 ~ tv2),
    when we decide to swap them over, to unify (tv2 ~ tv1),
    I'd forgotten to ensure that tv1's kind was fully zonked,
    which is an invariant of uUnfilledTyVar2.
    
    That could lead us to build an infinite kind, or (in the
    case of #16902) update the same unification variable twice.
    
    Yikes.
    
    Now we get an error message rather than non-termination,
    which is much better.  The error message is not great,
    but it's a very strange program, and I can't see an easy way
    to improve it, so for now I'm just committing this fix.
    
    Here's the decl
     data F (a :: k) :: (a ~~ k) => Type where
        MkF :: F a
    
    and the rather error message of which I am not proud
    
      T16902.hs:11:10: error:
        • Expected a type, but found something with kind ‘a1’
        • In the type ‘F a’
    53aa59f3
  • Daniel Gröber (dxld)'s avatar
    rts: Fix -hT option with profiling rts · ed662901
    Daniel Gröber (dxld) authored
    In dumpCensus we switch/case on doHeapProfile twice. The second switch
    tries to barf on unknown doHeapProfile modes but HEAP_BY_CLOSURE_TYPE is
    checked by the first switch and not included in the second.
    
    So when trying to pass -hT to the profiling rts it barfs.
    
    This commit simply merges the two switches into one which fixes this
    problem.
    ed662901
  • Simon Peyton Jones's avatar
    Fix over-eager implication constraint discard · 80afdf6b
    Simon Peyton Jones authored
    Ticket #16247 showed that we were discarding an implication
    constraint that had empty ic_wanted, when we still needed to
    keep it so we could check whether it had a bad telescope.
    
    Happily it's a one line fix.  All the rest is comments!
    80afdf6b
  • Andreas Klebinger's avatar
    Dont gather ticks when only striping them in STG. · f002250a
    Andreas Klebinger authored
    Adds stripStgTicksTopE which only returns the stripped expression.
    So far we also allocated a list for the stripped ticks which was
    never used.
    
    Allocation difference is as expected very small but present.
    About 0.02% difference when compiling with -O.
    f002250a
  • Artem Pelenitsyn's avatar
    Make all submodules have absolute URLs · a76b233d
    Artem Pelenitsyn authored
    The relative URLs were a workaround to let most contributors fork from
    Github due to a weakness in the haskell.org server.
    
    This workaround is no longer needed. And relative submodule URLs are
    an impediment to forking which makes contributions harder than they
    should be.
    
    The URLs are chosen to clone from https, because this makes sure that
    anybody, even not a registered Gitlab user, can clone a fork
    recursively.
    a76b233d
  • Ryan Scott's avatar
    More sensible SrcSpans for recursive pattern synonym errors (#16900) · 62b82135
    Ryan Scott authored
    Attach the `SrcSpan` of the first pattern synonym binding involved in
    the recursive group when throwing the corresponding error message,
    similarly to how it is done for type synonyms.
    
    Fixes #16900.
    62b82135
  • Alex D's avatar
  • Phuong Trinh's avatar
    Fix #16511: changes in interface dependencies should trigger recompilation · f43df489
    Phuong Trinh authored
    If the union of dependencies of imported modules change, the `mi_deps`
    field of the interface files should change as well. Because of that, we
    need to check for changes in this in recompilation checker which we are
    not doing right now. This adds a checks for that.
    f43df489
......@@ -503,6 +503,8 @@ validate-x86_64-linux-deb9-debug:
stage: build
variables:
BUILD_FLAVOUR: validate
# Override validate flavour default; see #16890.
BUILD_SPHINX_PDF: "YES"
TEST_TYPE: slowtest
TEST_ENV: "x86_64-linux-deb9-debug"
artifacts:
......
# Summary
## Summary
Write a brief description of the issue.
# Steps to reproduce
## Steps to reproduce
Please provide a set of concrete steps to reproduce the issue.
# Expected behavior
## Expected behavior
What do you expect the reproducer described above to do?
# Environment
## Environment
* GHC version used:
......
# Motivation
## Motivation
Briefly describe the problem your proposal solves and why this problem should
be solved.
# Proposal
## Proposal
Describe your proposed feature here.
......
[submodule "libraries/binary"]
path = libraries/binary
url = ../packages/binary.git
url = https://gitlab.haskell.org/ghc/packages/binary.git
ignore = untracked
[submodule "libraries/bytestring"]
path = libraries/bytestring
url = ../packages/bytestring.git
url = https://gitlab.haskell.org/ghc/packages/bytestring.git
ignore = untracked
[submodule "libraries/Cabal"]
path = libraries/Cabal
url = ../packages/Cabal.git
url = https://gitlab.haskell.org/ghc/packages/Cabal.git
ignore = untracked
[submodule "libraries/containers"]
path = libraries/containers
url = ../packages/containers.git
url = https://gitlab.haskell.org/ghc/packages/containers.git
ignore = untracked
[submodule "libraries/haskeline"]
path = libraries/haskeline
url = ../packages/haskeline.git
url = https://gitlab.haskell.org/ghc/packages/haskeline.git
ignore = untracked
[submodule "libraries/pretty"]
path = libraries/pretty
url = ../packages/pretty.git
url = https://gitlab.haskell.org/ghc/packages/pretty.git
ignore = untracked
[submodule "libraries/terminfo"]
path = libraries/terminfo
url = ../packages/terminfo.git
url = https://gitlab.haskell.org/ghc/packages/terminfo.git
ignore = untracked
[submodule "libraries/transformers"]
path = libraries/transformers
url = ../packages/transformers.git
url = https://gitlab.haskell.org/ghc/packages/transformers.git
ignore = untracked
[submodule "libraries/xhtml"]
path = libraries/xhtml
url = ../packages/xhtml.git
url = https://gitlab.haskell.org/ghc/packages/xhtml.git
ignore = untracked
[submodule "libraries/Win32"]
path = libraries/Win32
url = ../packages/Win32.git
url = https://gitlab.haskell.org/ghc/packages/Win32.git
ignore = untracked
[submodule "libraries/time"]
path = libraries/time
url = ../packages/time.git
url = https://gitlab.haskell.org/ghc/packages/time.git
ignore = untracked
[submodule "libraries/array"]
path = libraries/array
url = ../packages/array.git
url = https://gitlab.haskell.org/ghc/packages/array.git
ignore = untracked
[submodule "libraries/deepseq"]
path = libraries/deepseq
url = ../packages/deepseq.git
url = https://gitlab.haskell.org/ghc/packages/deepseq.git
ignore = untracked
[submodule "libraries/directory"]
path = libraries/directory
url = ../packages/directory.git
url = https://gitlab.haskell.org/ghc/packages/directory.git
ignore = untracked
[submodule "libraries/filepath"]
path = libraries/filepath
url = ../packages/filepath.git
url = https://gitlab.haskell.org/ghc/packages/filepath.git
ignore = untracked
[submodule "libraries/hpc"]
path = libraries/hpc
url = ../packages/hpc.git
url = https://gitlab.haskell.org/ghc/packages/hpc.git
ignore = untracked
[submodule "libraries/parsec"]
path = libraries/parsec
url = ../packages/parsec.git
url = https://gitlab.haskell.org/ghc/packages/parsec.git
ignore = untracked
[submodule "libraries/text"]
path = libraries/text
url = ../packages/text.git
url = https://gitlab.haskell.org/ghc/packages/text.git
ignore = untracked
[submodule "libraries/mtl"]
path = libraries/mtl
url = ../packages/mtl.git
url = https://gitlab.haskell.org/ghc/packages/mtl.git
ignore = untracked
[submodule "libraries/process"]
path = libraries/process
url = ../packages/process.git
url = https://gitlab.haskell.org/ghc/packages/process.git
ignore = untracked
[submodule "libraries/unix"]
path = libraries/unix
url = ../packages/unix.git
url = https://gitlab.haskell.org/ghc/packages/unix.git
ignore = untracked
branch = 2.7
[submodule "libraries/stm"]
path = libraries/stm
url = ../packages/stm.git
url = https://gitlab.haskell.org/ghc/packages/stm.git
ignore = untracked
[submodule "utils/haddock"]
path = utils/haddock
url = ../haddock.git
url = https://github.com/haskell/haddock.git
ignore = untracked
branch = ghc-head
[submodule "nofib"]
path = nofib
url = ../nofib.git
url = https://gitlab.haskell.org/ghc/nofib.git
ignore = untracked
[submodule "utils/hsc2hs"]
path = utils/hsc2hs
url = ../hsc2hs.git
url = https://gitlab.haskell.org/ghc/hsc2hs.git
ignore = untracked
[submodule "libffi-tarballs"]
path = libffi-tarballs
url = ../libffi-tarballs.git
url = https://gitlab.haskell.org/ghc/libffi-tarballs.git
ignore = untracked
[submodule "gmp-tarballs"]
path = libraries/integer-gmp/gmp/gmp-tarballs
url = ../gmp-tarballs.git
url = https://gitlab.haskell.org/ghc/gmp-tarballs.git
......@@ -64,13 +64,20 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
assign_regs assts (r:rs) regs | isVecType ty = vec
| isFloatType ty = float
| otherwise = int
where vec = case (w, regs) of
(W128, (vs, fs, ds, ls, s:ss))
| passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
(W256, (vs, fs, ds, ls, s:ss))
| passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
(W512, (vs, fs, ds, ls, s:ss))
| passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
where vec = case regs of
(vs, fs, ds, ls, s:ss)
| passVectorInReg w dflags
-> let elt_ty = vecElemType ty
reg_ty = if isFloatType elt_ty
then Float else Integer
reg_class = case w of
W128 -> XmmReg
W256 -> YmmReg
W512 -> ZmmReg
_ -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width"
in k (RegisterParam
(reg_class s (vecLength ty) (typeWidth elt_ty) reg_ty),
(vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
float = case (w, regs) of
(W32, (vs, fs, ds, ls, s:ss))
......@@ -89,6 +96,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
(_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
-> k (RegisterParam l, (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
ty = arg_ty r
w = typeWidth ty
......@@ -202,11 +210,13 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags
| passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
realLongRegs dflags ++
map XmmReg (realXmmRegNos dflags)
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
realLongRegs dflags ++
map XmmReg (realXmmRegNos dflags)
| passFloatArgsInXmm dflags
= map ($VGcPtr) (realVanillaRegs dflags) ++
realLongRegs dflags ++
map (\x -> XmmReg x 2 W64 Integer) (realXmmRegNos dflags)
| otherwise
= map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
realLongRegs dflags ++
map (\x -> XmmReg x 2 W64 Integer) (realXmmRegNos dflags)
......@@ -14,6 +14,7 @@ module CmmExpr
, currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
, node, baseReg
, VGcPtr(..)
, GlobalVecRegTy(..)
, DefinerOfRegs, UserOfRegs
, foldRegsDefd, foldRegsUsed
......@@ -41,6 +42,7 @@ import Outputable (panic)
import Unique
import Data.Set (Set)
import Data.Monoid ((<>))
import qualified Data.Set as Set
import BasicTypes (Alignment, mkAlignment, alignmentOf)
......@@ -392,6 +394,7 @@ data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
-----------------------------------------------------------------------------
{-
Note [Overlapping global registers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The backend might not faithfully implement the abstraction of the STG
machine with independent registers for different values of type
......@@ -413,6 +416,26 @@ on a particular platform. The instance Eq GlobalReg is syntactic
equality of STG registers and does not take overlap into
account. However it is still used in UserOfRegs/DefinerOfRegs and
there are likely still bugs there, beware!
Note [SIMD registers]
~~~~~~~~~~~~~~~~~~~~~
GHC's treatment of SIMD registers is heavily modelled after the x86_64
architecture. Namely we have 128- (XMM), 256- (YMM), and 512-bit (ZMM)
registers. Furthermore, we treat each possible format in these registers as a
distinct register which overlaps with the others. For instance, we XMM1 as a
2xI64 register is distinct from but overlaps with (in the sense defined in Note
[Overlapping global registers]) its use as a 4xI32 register.
This model makes it easier to fit SIMD registers into the NCG, which generally
expects that each global register has a single, known CmmType.
In the future we could consider further refactoring this to eliminate the
XMM, YMM, and ZMM register names (which are quite x86-specific) and instead just
having a set of NxM-bit vector registers (e.g. Vec2x64A, Vec2x64B, ...,
Vec4x32A, ..., Vec4x64A).
-}
data GlobalReg
......@@ -432,12 +455,15 @@ data GlobalReg
| XmmReg -- 128-bit SIMD vector register
{-# UNPACK #-} !Int -- its number
!Length !Width !GlobalVecRegTy
| YmmReg -- 256-bit SIMD vector register
{-# UNPACK #-} !Int -- its number
!Length !Width !GlobalVecRegTy
| ZmmReg -- 512-bit SIMD vector register
{-# UNPACK #-} !Int -- its number
!Length !Width !GlobalVecRegTy
-- STG registers
| Sp -- Stack ptr; points to last occupied stack location.
......@@ -478,17 +504,17 @@ data GlobalReg
deriving( Show )
data GlobalVecRegTy = Integer | Float
deriving (Show, Eq, Ord)
instance Eq GlobalReg where
VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
FloatReg i == FloatReg j = i==j
DoubleReg i == DoubleReg j = i==j
LongReg i == LongReg j = i==j
-- NOTE: XMM, YMM, ZMM registers actually are the same registers
-- at least with respect to store at YMM i and then read from XMM i
-- and similarly for ZMM etc.
XmmReg i == XmmReg j = i==j
YmmReg i == YmmReg j = i==j
ZmmReg i == ZmmReg j = i==j
XmmReg i l w grt == XmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt'
YmmReg i l w grt == YmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt'
ZmmReg i l w grt == ZmmReg j l' w' grt' = i==j && l == l' && w == w' && grt == grt'
Sp == Sp = True
SpLim == SpLim = True
Hp == Hp = True
......@@ -512,9 +538,21 @@ instance Ord GlobalReg where
compare (FloatReg i) (FloatReg j) = compare i j
compare (DoubleReg i) (DoubleReg j) = compare i j
compare (LongReg i) (LongReg j) = compare i j
compare (XmmReg i) (XmmReg j) = compare i j
compare (YmmReg i) (YmmReg j) = compare i j
compare (ZmmReg i) (ZmmReg j) = compare i j
compare (XmmReg i l w grt)
(XmmReg j l' w' grt') = compare i j
<> compare l l'
<> compare w w'
<> compare grt grt'
compare (YmmReg i l w grt)
(YmmReg j l' w' grt') = compare i j
<> compare l l'
<> compare w w'
<> compare grt grt'
compare (ZmmReg i l w grt)
(ZmmReg j l' w' grt') = compare i j
<> compare l l'
<> compare w w'
<> compare grt grt'
compare Sp Sp = EQ
compare SpLim SpLim = EQ
compare Hp Hp = EQ
......@@ -538,12 +576,12 @@ instance Ord GlobalReg where
compare _ (DoubleReg _) = GT
compare (LongReg _) _ = LT
compare _ (LongReg _) = GT
compare (XmmReg _) _ = LT
compare _ (XmmReg _) = GT
compare (YmmReg _) _ = LT
compare _ (YmmReg _) = GT
compare (ZmmReg _) _ = LT
compare _ (ZmmReg _) = GT
compare (XmmReg _ _ _ _) _ = LT
compare _ (XmmReg _ _ _ _) = GT
compare (YmmReg _ _ _ _) _ = LT
compare _ (YmmReg _ _ _ _) = GT
compare (ZmmReg _ _ _ _) _ = LT
compare _ (ZmmReg _ _ _ _) = GT
compare Sp _ = LT
compare _ Sp = GT
compare SpLim _ = LT
......@@ -596,12 +634,15 @@ globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
globalRegType _ (FloatReg _) = cmmFloat W32
globalRegType _ (DoubleReg _) = cmmFloat W64
globalRegType _ (LongReg _) = cmmBits W64
-- TODO: improve the internal model of SIMD/vectorized registers
-- the right design SHOULd improve handling of float and double code too.
-- see remarks in "NOTE [SIMD Design for the future]"" in StgCmmPrim
globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32)
globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32)
globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32)
globalRegType _ (XmmReg _ l w ty) = case ty of
Integer -> cmmVec l (cmmBits w)
Float -> cmmVec l (cmmFloat w)
globalRegType _ (YmmReg _ l w ty) = case ty of
Integer -> cmmVec l (cmmBits w)
Float -> cmmVec l (cmmFloat w)
globalRegType _ (ZmmReg _ l w ty) = case ty of
Integer -> cmmVec l (cmmBits w)
Float -> cmmVec l (cmmFloat w)
globalRegType dflags Hp = gcWord dflags
-- The initialiser for all
......
......@@ -148,9 +148,13 @@ lintCmmMiddle node = case node of
dflags <- getDynFlags
erep <- lintCmmExpr expr
let reg_ty = cmmRegType dflags reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
case isVecCatType reg_ty of
True -> if ((typeWidth reg_ty) == (typeWidth erep))
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
_ -> if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
CmmStore l r -> do
_ <- lintCmmExpr l
......
......@@ -136,8 +136,9 @@ data MachOp
| MO_VU_Rem Length Width
-- Floting point vector element insertion and extraction operations
| MO_VF_Insert Length Width -- Insert scalar into vector
| MO_VF_Extract Length Width -- Extract scalar from vector
| MO_VF_Broadcast Length Width -- Broadcast a scalar into a vector
| MO_VF_Insert Length Width -- Insert scalar into vector
| MO_VF_Extract Length Width -- Extract scalar from vector
-- Floating point vector operations
| MO_VF_Add Length Width
......@@ -430,6 +431,7 @@ machOpResultType dflags mop tys =
MO_VU_Quot l w -> cmmVec l (cmmBits w)
MO_VU_Rem l w -> cmmVec l (cmmBits w)
MO_VF_Broadcast l w -> cmmVec l (cmmFloat w)
MO_VF_Insert l w -> cmmVec l (cmmFloat w)
MO_VF_Extract _ w -> cmmFloat w
......@@ -522,16 +524,21 @@ machOpArgReps dflags op =
MO_VU_Quot _ r -> [r,r]
MO_VU_Rem _ r -> [r,r]
MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]
MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]
-- offset is always W32 as mentioned in StgCmmPrim.hs
MO_VF_Broadcast l r -> [vecwidth l r, r]
MO_VF_Insert l r -> [vecwidth l r, r, W32]
MO_VF_Extract l r -> [vecwidth l r, W32]
MO_VF_Add _ r -> [r,r]
MO_VF_Sub _ r -> [r,r]
MO_VF_Mul _ r -> [r,r]
MO_VF_Quot _ r -> [r,r]
MO_VF_Neg _ r -> [r]
-- NOTE: The below is owing to the fact that floats use the SSE registers
MO_VF_Add l w -> [vecwidth l w, vecwidth l w]
MO_VF_Sub l w -> [vecwidth l w, vecwidth l w]
MO_VF_Mul l w -> [vecwidth l w, vecwidth l w]
MO_VF_Quot l w -> [vecwidth l w, vecwidth l w]
MO_VF_Neg l w -> [vecwidth l w]
MO_AlignmentCheck _ r -> [r]
where
vecwidth l w = widthFromBytes (l*widthInBytes w)
-----------------------------------------------------------------------------
-- CallishMachOp
......@@ -593,6 +600,7 @@ data CallishMachOp
| MO_SubIntC Width
| MO_U_Mul2 Width
| MO_ReadBarrier
| MO_WriteBarrier
| MO_Touch -- Keep variables live (when using interior pointers)
......
......@@ -1001,6 +1001,7 @@ machOps = listToUFM $
callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
( "read_barrier", (MO_ReadBarrier,)),
( "write_barrier", (MO_WriteBarrier,)),
( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
( "memset", memcpyLikeTweakArgs MO_Memset ),
......
......@@ -6,6 +6,7 @@ module CmmType
, typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
, isFloatType, isGcPtrType, isBitsType
, isWord32, isWord64, isFloat64, isFloat32
, isVecCatType
, Width(..)
, widthInBits, widthInBytes, widthInLog, widthFromBytes
......@@ -133,7 +134,7 @@ cInt :: DynFlags -> CmmType
cInt dflags = cmmBits (cIntWidth dflags)
------------ Predicates ----------------
isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool
isFloatType, isGcPtrType, isBitsType, isVecCatType :: CmmType -> Bool
isFloatType (CmmType FloatCat _) = True
isFloatType _other = False
......@@ -143,6 +144,9 @@ isGcPtrType _other = False
isBitsType (CmmType BitsCat _) = True
isBitsType _ = False
isVecCatType (CmmType (VecCat _ _) _) = True
isVecCatType _other = False
isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool
-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)
-- isFloat32 and 64 are obvious
......
......@@ -713,6 +713,10 @@ pprMachOp_for_C mop = case mop of
(panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
++ " should have been handled earlier!")
MO_VF_Broadcast {} -> pprTrace "offending mop:"
(text "MO_VF_Broadcast")
(panic $ "PprC.pprMachOp_for_C: MO_VF_Broadcast"
++ " should have been handled earlier!")
MO_VF_Insert {} -> pprTrace "offending mop:"
(text "MO_VF_Insert")
(panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
......@@ -812,6 +816,7 @@ pprCallishMachOp_for_C mop
MO_F32_ExpM1 -> text "expm1f"
MO_F32_Sqrt -> text "sqrtf"
MO_F32_Fabs -> text "fabsf"
MO_ReadBarrier -> text "load_load_barrier"
MO_WriteBarrier -> text "write_barrier"
MO_Memcpy _ -> text "memcpy"
MO_Memset _ -> text "memset"
......
......@@ -261,9 +261,9 @@ pprGlobalReg gr
FloatReg n -> char 'F' <> int n
DoubleReg n -> char 'D' <> int n
LongReg n -> char 'L' <> int n
XmmReg n -> text "XMM" <> int n
YmmReg n -> text "YMM" <> int n
ZmmReg n -> text "ZMM" <> int n
XmmReg n _ _ _ -> text "XMM" <> int n
YmmReg n _ _ _ -> text "YMM" <> int n
ZmmReg n _ _ _ -> text "ZMM" <> int n
Sp -> text "Sp"
SpLim -> text "SpLim"
Hp -> text "Hp"
......
......@@ -57,27 +57,27 @@ baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags
baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags
baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags
baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags
baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags
baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags
baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags
baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags
baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags
baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags
baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags
baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags
baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags
baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags
baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags
baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags
baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags
baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags
baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags
baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags
baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags
baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
baseRegOffset dflags (XmmReg 1 _ _ _) = oFFSET_StgRegTable_rXMM1 dflags
baseRegOffset dflags (XmmReg 2 _ _ _) = oFFSET_StgRegTable_rXMM2 dflags
baseRegOffset dflags (XmmReg 3 _ _ _) = oFFSET_StgRegTable_rXMM3 dflags
baseRegOffset dflags (XmmReg 4 _ _ _) = oFFSET_StgRegTable_rXMM4 dflags
baseRegOffset dflags (XmmReg 5 _ _ _) = oFFSET_StgRegTable_rXMM5 dflags
baseRegOffset dflags (XmmReg 6 _ _ _) = oFFSET_StgRegTable_rXMM6 dflags
baseRegOffset _ (XmmReg n _ _ _) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
baseRegOffset dflags (YmmReg 1 _ _ _) = oFFSET_StgRegTable_rYMM1 dflags
baseRegOffset dflags (YmmReg 2 _ _ _) = oFFSET_StgRegTable_rYMM2 dflags
baseRegOffset dflags (YmmReg 3 _ _ _) = oFFSET_StgRegTable_rYMM3 dflags
baseRegOffset dflags (YmmReg 4 _ _ _) = oFFSET_StgRegTable_rYMM4 dflags
baseRegOffset dflags (YmmReg 5 _ _ _) = oFFSET_StgRegTable_rYMM5 dflags
baseRegOffset dflags (YmmReg 6 _ _ _) = oFFSET_StgRegTable_rYMM6 dflags
baseRegOffset _ (YmmReg n _ _ _) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
baseRegOffset dflags (ZmmReg 1 _ _ _) = oFFSET_StgRegTable_rZMM1 dflags
baseRegOffset dflags (ZmmReg 2 _ _ _) = oFFSET_StgRegTable_rZMM2 dflags
baseRegOffset dflags (ZmmReg 3 _ _ _) = oFFSET_StgRegTable_rZMM3 dflags
baseRegOffset dflags (ZmmReg 4 _ _ _) = oFFSET_StgRegTable_rZMM4 dflags
baseRegOffset dflags (ZmmReg 5 _ _ _) = oFFSET_StgRegTable_rZMM5 dflags
baseRegOffset dflags (ZmmReg 6 _ _ _) = oFFSET_StgRegTable_rZMM6 dflags
baseRegOffset _ (ZmmReg n _ _ _) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
......
......@@ -265,7 +265,7 @@ mkRhsClosure dflags bndr _cc
upd_flag -- Updatable thunk
[] -- A thunk
expr
| let strip = snd . stripStgTicksTop (not . tickishIsCode)
| let strip = stripStgTicksTopE (not . tickishIsCode)
, StgCase (StgApp scrutinee [{-no args-}])
_ -- ignore bndr
(AlgAlt _)
......@@ -632,6 +632,7 @@ emitBlackHoleCode node = do
when eager_blackholing $ do
emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
-- See Note [Heap memory barriers] in SMP.h.
emitPrimCall [] MO_WriteBarrier []
emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
......
......@@ -669,7 +669,7 @@ emitPrimOp _ [res] Word2DoubleOp [w] = emitPrimCall [res]
-- SIMD primops
emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do
checkVecCompatibility dflags vcat n w
doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res
doVecBroadcastOp (vecElemInjectCast dflags vcat w) ty zeros e res
where
zeros :: CmmExpr
zeros = CmmLit $ CmmVec (replicate n zero)
......@@ -1765,9 +1765,8 @@ vecElemProjectCast _ _ _ = Nothing
checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()
checkVecCompatibility dflags vcat l w = do
when (hscTarget dflags /= HscLlvm) $ do
sorry $ unlines ["SIMD vector instructions require the LLVM back-end."
,"Please use -fllvm."]
when (hscTarget dflags /= HscLlvm && hscTarget dflags /= HscAsm) $ do
sorry "SIMD vector instructions not supported for the C backend or GHCi"
check vecWidth vcat l w
where
check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()
......@@ -1792,6 +1791,38 @@ checkVecCompatibility dflags vcat l w = do
------------------------------------------------------------------------------
-- Helpers for translating vector packing and unpacking.
doVecBroadcastOp :: Maybe MachOp -- Cast from element to vector component
-> CmmType -- Type of vector
-> CmmExpr -- Initial vector
-> CmmExpr -- Elements
-> CmmFormal -- Destination for result
-> FCode ()
doVecBroadcastOp maybe_pre_write_cast ty z es res = do
dst <- newTemp ty
emitAssign (CmmLocal dst) z
vecBroadcast dst es 0
where
vecBroadcast :: CmmFormal -> CmmExpr -> Int -> FCode ()
vecBroadcast src e _ = do
dst <- newTemp ty
if isFloatType (vecElemType ty)
then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Broadcast len wid)
[CmmReg (CmmLocal src), cast e])
--TODO : Add the MachOp MO_V_Broadcast
else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
[CmmReg (CmmLocal src), cast e])
emitAssign (CmmLocal res) (CmmReg (CmmLocal dst))
cast :: CmmExpr -> CmmExpr
cast val = case maybe_pre_write_cast of
Nothing -> val
Just cast -> CmmMachOp cast [val]
len :: Length
len = vecLength ty
wid :: Width
wid = typeWidth (vecElemType ty)
doVecPackOp :: Maybe MachOp -- Cast from element to vector component
-> CmmType -- Type of vector
......@@ -1809,16 +1840,16 @@ doVecPackOp maybe_pre_write_cast ty z es res = do
emitAssign (CmmLocal res) (CmmReg (CmmLocal src))
vecPack src (e : es) i = do
dst <- newTemp ty
if isFloatType (vecElemType ty)
then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
[CmmReg (CmmLocal src), cast e, iLit])
else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
[CmmReg (CmmLocal src), cast e, iLit])
vecPack dst es (i + 1)
dst <- newTemp ty
if isFloatType (vecElemType ty)
then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
[CmmReg (CmmLocal src), cast e, iLit])
else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
[CmmReg (CmmLocal src), cast e, iLit])
vecPack dst es (i + 1)
where
-- vector indices are always 32-bits
iLit = CmmLit (CmmInt (toInteger i) W32)
iLit = CmmLit (CmmInt ((toInteger i) * 16) W32)
cast :: CmmExpr -> CmmExpr
cast val = case maybe_pre_write_cast of
......
......@@ -1332,12 +1332,20 @@ repE e@(HsDo _ ctxt (dL->L _ sts))
= notHandled "monad comprehension and [: :]" (ppr e)
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitTuple _ es boxed)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
| isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
; repTup xs }
| otherwise = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
; repUnboxedTup xs }
repE (ExplicitTuple _ es boxity) =
let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
tupArgToCoreExp a
| L _ (Present _ e) <- dL a = do { e' <- repLE e
; coreJust expQTyConName e' }
| otherwise = coreNothing expQTyConName
in do { args <- mapM tupArgToCoreExp es
; expQTy <- lookupType expQTyConName
; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]
listArg = coreList' maybeExpQTy args
; if isBoxed boxity
then repTup listArg
else repUnboxedTup listArg }
repE (ExplicitSum _ alt arity e)
= do { e1 <- repLE e
......@@ -2077,10 +2085,10 @@ repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
repLamCase (MkC ms) = rep2 lamCaseEName [ms]
repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]
repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
......
......@@ -74,7 +74,7 @@ Library
containers >= 0.5 && < 0.7,
array >= 0.1 && < 0.6,
filepath >= 1 && < 1.5,
template-haskell == 2.15.*,
template-haskell == 2.16.*,
hpc == 0.6.*,
transformers == 0.5.*,
ghc-boot == @ProjectVersionMunged@,
......
......@@ -891,17 +891,11 @@ cvtl e = wrapL (cvt e)
; return $ HsLamCase noExt
(mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple noExt
(map (noLoc . (Present noExt)) es')
Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple noExt
(map (noLoc . (Present noExt)) es')
Unboxed }
cvt (TupE es) = cvt_tup es Boxed
cvt (UnboxedTupE es) = cvt_tup es Unboxed
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
; return $ ExplicitSum noExt
......@@ -931,7 +925,7 @@ cvtl e = wrapL (cvt e)
}
-- Infix expressions
cvt (InfixE (Just x) s (Just y)) =
cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $
do { x' <- cvtl x
; s' <- cvtl s
; y' <- cvtl y
......@@ -943,20 +937,24 @@ cvtl e = wrapL (cvt e)
-- to ensure this operator application does
-- does not get re-associated
-- See Note [Operator association]
cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $
do { s' <- cvtl s; y' <- cvtl y
; wrapParL (HsPar noExt) $
SectionR noExt s' y' }
-- See Note [Sections in HsSyn] in HsExpr
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $
do { x' <- cvtl x; s' <- cvtl s
; wrapParL (HsPar noExt) $
SectionL noExt x' s' }
cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $
do { s' <- cvtl s
; return $ HsPar noExt s' }
-- Can I indicate this is an infix thing?
-- Note [Dropping constructors]
cvt (UInfixE x s y) = do { x' <- cvtl x
cvt (UInfixE x s y) = ensureValidOpExp s $
do { x' <- cvtl x
; let x'' = case unLoc x' of
OpApp {} -> x'
_ -> mkLHsPar x'
......@@ -983,6 +981,24 @@ cvtl e = wrapL (cvt e)
cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:
$(uInfixE [|1|] [|id id|] [|2|])
This infix expression is obviously ill-formed so we use this helper function
to reject such programs outright.
The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`
in Language.Haskell.TH.Ppr from the template-haskell library.
-}
ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a
ensureValidOpExp (VarE _n) m = m
ensureValidOpExp (ConE _n) m = m
ensureValidOpExp (UnboundVarE _n) m = m
ensureValidOpExp _e _m =
failWith (text "Non-variable expression is not allowed in an infix expression")
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
......@@ -1013,6 +1029,15 @@ cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x
cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg
cvtl_maybe (Just e) = fmap (Present noExt) (cvtl e)
; es' <- mapM cvtl_maybe es
; return $ ExplicitTuple
noExt
(map noLoc es')
boxity }
{- Note [Operator assocation]
We must be quite careful about adding parens:
* Infix (UInfix ...) op arg Needs parens round the first arg
......
......@@ -115,6 +115,7 @@ import Control.Monad
import Data.Function
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Ord
import Data.IORef
import System.Directory
......@@ -1177,8 +1178,8 @@ recompileRequired _ = True
-- is equivalent to the current source file the user asked us to compile.
-- If the same, we can avoid recompilation. We return a tuple where the
-- first element is a bool saying if we should recompile the object file
-- and the second is maybe the interface file, where Nothng means to
-- and the second is maybe the interface file, where Nothing means to
-- rebuild the interface file and not use the existing one.
checkOldIface
:: HscEnv
-> ModSummary
......@@ -1486,11 +1487,30 @@ checkMergedSignatures mod_summary iface = do
-- - a new home module has been added that shadows a package module
-- See bug #1372.
--
-- In addition, we also check if the union of dependencies of the imported
-- modules has any difference to the previous set of dependencies. We would need
-- to recompile in that case also since the `mi_deps` field of ModIface needs
-- to be updated to match that information. This is one of the invariants
-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).
-- See bug #16511.
--
-- Returns (RecompBecause <textual reason>) if recompilation is required.
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
where
= do
checkList $
[ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
, do
(recomp, mnames_seen) <- runUntilRecompRequired $ map
checkForNewHomeDependency
(ms_home_imps summary)
case recomp of
UpToDate -> do
let
seen_home_deps = Set.unions $ map Set.fromList mnames_seen
checkIfAllOldHomeDependenciesAreSeen seen_home_deps
_ -> return recomp]
where
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_plgn = dep_plgins (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
......@@ -1522,12 +1542,74 @@ checkDependencies hsc_env summary iface
where pkg = moduleUnitId mod
_otherwise -> return (RecompBecause reason)
old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods
isOldHomeDeps = flip Set.member old_deps
checkForNewHomeDependency (L _ mname) = do
let
mod = mkModule this_pkg mname
str_mname = moduleNameString mname
reason = str_mname ++ " changed"
-- We only want to look at home modules to check if any new home dependency
-- pops in and thus here, skip modules that are not home. Checking
-- membership in old home dependencies suffice because the `dep_missing`
-- check already verified that all imported home modules are present there.
if not (isOldHomeDeps mname)
then return (UpToDate, [])
else do
mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
let mnames = mname:(map fst $ filter (not . snd) $
dep_mods $ mi_deps imported_iface)
case find (not . isOldHomeDeps) mnames of
Nothing -> return (UpToDate, mnames)
Just new_dep_mname -> do
traceHiDiffs $
text "imported home module " <> quotes (ppr mod) <>
text " has a new dependency " <> quotes (ppr new_dep_mname)
return (RecompBecause reason, [])
return $ fromMaybe (MustCompile, []) mb_result
-- Performs all recompilation checks in the list until a check that yields
-- recompile required is encountered. Returns the list of the results of
-- all UpToDate checks.
runUntilRecompRequired [] = return (UpToDate, [])
runUntilRecompRequired (check:checks) = do
(recompile, value) <- check
if recompileRequired recompile
then return (recompile, [])
else do
(recomp, values) <- runUntilRecompRequired checks
return (recomp, value:values)
checkIfAllOldHomeDependenciesAreSeen seen_deps = do
let unseen_old_deps = Set.difference
old_deps
seen_deps
if not (null unseen_old_deps)
then do
let missing_dep = Set.elemAt 0 unseen_old_deps
traceHiDiffs $
text "missing old home dependency " <> quotes (ppr missing_dep)
return $ RecompBecause "missing old dependency"
else return UpToDate
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
-> IfG RecompileRequired
needInterface mod continue
= do
mb_recomp <- getFromModIface
"need version info for"
mod
continue
case mb_recomp of
Nothing -> return MustCompile
Just recomp -> return recomp
getFromModIface :: String -> Module -> (ModIface -> IfG a)
-> IfG (Maybe a)
getFromModIface doc_msg mod getter
= do -- Load the imported interface if possible
let doc_str = sep [text "need version info for", ppr mod]
traceHiDiffs (text "Checking usages for module" <+> ppr mod)
let doc_str = sep [text doc_msg, ppr mod]
traceHiDiffs (text "Checking innterface for module" <+> ppr mod)
mb_iface <- loadInterface doc_str mod ImportBySystem
-- Load the interface, but don't complain on failure;
......@@ -1537,12 +1619,12 @@ needInterface mod continue
Failed _ -> do
traceHiDiffs (sep [text "Couldn't load interface for module",
ppr mod])
return MustCompile
return Nothing
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain: it might
-- just be that the current module doesn't need that
-- import and it's been deleted
Succeeded iface -> continue iface
Succeeded iface -> Just <$> getter iface
-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
......
......@@ -152,12 +152,12 @@ llvmFunArgs dflags live =
where platform = targetPlatform dflags
isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
isPassed r = not (isSSE r) || isLive r
isSSE (FloatReg _) = True
isSSE (DoubleReg _) = True
isSSE (XmmReg _) = True
isSSE (YmmReg _) = True
isSSE (ZmmReg _) = True
isSSE _ = False
isSSE (FloatReg _) = True
isSSE (DoubleReg _) = True
isSSE (XmmReg _ _ _ _ ) = True
isSSE (YmmReg _ _ _ _ ) = True
isSSE (ZmmReg _ _ _ _ ) = True
isSSE _ = False
-- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr]
......
......@@ -169,17 +169,25 @@ barrier = do
let s = Fence False SyncSeqCst
return (unitOL s, [])
-- | Insert a 'barrier', unless the target platform is in the provided list of
-- exceptions (where no code will be emitted instead).
barrierUnless :: [Arch] -> LlvmM StmtData
barrierUnless exs = do
platform <- getLlvmPlatform
if platformArch platform `elem` exs
then return (nilOL, [])
else barrier
-- | Foreign Calls
genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
-> LlvmM StmtData
-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
-- Barriers need to be handled specially as they are implemented as LLVM
-- intrinsic functions.
genCall (PrimTarget MO_ReadBarrier) _ _ =
barrierUnless [ArchX86, ArchX86_64, ArchSPARC]
genCall (PrimTarget MO_WriteBarrier) _ _ = do
platform <- getLlvmPlatform
if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
then return (nilOL, [])
else barrier
barrierUnless [ArchX86, ArchX86_64, ArchSPARC]
genCall (PrimTarget MO_Touch) _ _
= return (nilOL, [])
......@@ -831,6 +839,7 @@ cmmPrimOpFunctions mop = do
-- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
-- appropriate case of genCall.
MO_U_Mul2 {} -> unsupported
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_UF_Conv _ -> unsupported
......@@ -1278,6 +1287,7 @@ genMachOp _ op [x] = case op of
MO_VU_Quot _ _ -> panicOp
MO_VU_Rem _ _ -> panicOp
MO_VF_Broadcast _ _ -> panicOp
MO_VF_Insert _ _ -> panicOp
MO_VF_Extract _ _ -> panicOp
......@@ -1474,6 +1484,7 @@ genMachOp_slow opt op [x, y] = case op of
MO_VS_Neg {} -> panicOp
MO_VF_Broadcast {} -> panicOp
MO_VF_Insert {} -> panicOp
MO_VF_Extract {} -> panicOp
......@@ -1835,9 +1846,9 @@ funEpilogue live = do
let liveRegs = alwaysLive ++ live
isSSE (FloatReg _) = True
isSSE (DoubleReg _) = True
isSSE (XmmReg _) = True
isSSE (YmmReg _) = True
isSSE (ZmmReg _) = True
isSSE (XmmReg _ _ _ _) = True
isSSE (YmmReg _ _ _ _) = True
isSSE (ZmmReg _ _ _ _) = True
isSSE _ = False
-- Set to value or "undef" depending on whether the register is
......
......@@ -60,24 +60,24 @@ lmGlobalReg dflags suf reg
DoubleReg 4 -> doubleGlobal $ "D4" ++ suf
DoubleReg 5 -> doubleGlobal $ "D5" ++ suf
DoubleReg 6 -> doubleGlobal $ "D6" ++ suf
XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf
XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf
XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf
XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf
XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf
XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf
YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf
YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf
YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf
YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf
YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf
YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf
ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf
ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf
ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf
ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf
ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf
ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf
XmmReg 1 _ _ _ -> xmmGlobal $ "XMM1" ++ suf
XmmReg 2 _ _ _ -> xmmGlobal $ "XMM2" ++ suf
XmmReg 3 _ _ _ -> xmmGlobal $ "XMM3" ++ suf
XmmReg 4 _ _ _ -> xmmGlobal $ "XMM4" ++ suf
XmmReg 5 _ _ _ -> xmmGlobal $ "XMM5" ++ suf
XmmReg 6 _ _ _ -> xmmGlobal $ "XMM6" ++ suf
YmmReg 1 _ _ _ -> ymmGlobal $ "YMM1" ++ suf
YmmReg 2 _ _ _ -> ymmGlobal $ "YMM2" ++ suf
YmmReg 3 _ _ _ -> ymmGlobal $ "YMM3" ++ suf
YmmReg 4 _ _ _ -> ymmGlobal $ "YMM4" ++ suf
YmmReg 5 _ _ _ -> ymmGlobal $ "YMM5" ++ suf
YmmReg 6 _ _ _ -> ymmGlobal $ "YMM6" ++ suf
ZmmReg 1 _ _ _ -> zmmGlobal $ "ZMM1" ++ suf
ZmmReg 2 _ _ _ -> zmmGlobal $ "ZMM2" ++ suf
ZmmReg 3 _ _ _ -> zmmGlobal $ "ZMM3" ++ suf
ZmmReg 4 _ _ _ -> zmmGlobal $ "ZMM4" ++ suf
ZmmReg 5 _ _ _ -> zmmGlobal $ "ZMM5" ++ suf
ZmmReg 6 _ _ _ -> zmmGlobal $ "ZMM6" ++ suf
MachSp -> wordGlobal $ "MachSp" ++ suf
_other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
++ ") not supported!"
......
......@@ -219,6 +219,7 @@ module DynFlags (
-- * SSE and AVX
isSseEnabled,
isSse2Enabled,
isSse4_1Enabled,
isSse4_2Enabled,
isBmiEnabled,
isBmi2Enabled,
......@@ -320,7 +321,8 @@ import qualified EnumSet
import GHC.Foreign (withCString, peekCString)
import qualified GHC.LanguageExtensions as LangExt
#if defined(HAVE_INTERPRETER)
#if STAGE >= 2
-- used by SHARED_GLOBAL_VAR
import Foreign (Ptr)
#endif
......@@ -5907,6 +5909,8 @@ isSse2Enabled dflags = case platformArch (targetPlatform dflags) of
ArchX86 -> True
_ -> False
isSse4_1Enabled :: DynFlags -> Bool
isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4
isSse4_2Enabled :: DynFlags -> Bool
isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42
......
......@@ -2255,28 +2255,6 @@ msDeps s =
concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
++ [ (m,NotBoot) | m <- ms_home_imps s ]
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
isLocal mb_pkg ]
where isLocal Nothing = True
isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
isLocal _ = False
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
-- | Like 'ms_home_imps', but for SOURCE imports.
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps = home_imps . ms_srcimps
-- | All of the (possibly) home module imports from a
-- 'ModSummary'; that is to say, each of these module names
-- could be a home import if an appropriately named file
-- existed. (This is in contrast to package qualified
-- imports, which are guaranteed not to be home imports.)
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps = home_imps . ms_imps
-----------------------------------------------------------------------------
-- Summarising modules
......
......@@ -33,7 +33,8 @@ module HscTypes (
ForeignSrcLang(..),
phaseForeignLanguage,
ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps,
home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
SourceModified(..), isTemplateHaskellOrQQNonBoot,
......@@ -2800,6 +2801,28 @@ ms_imps ms =
where
mk_additional_import mod_nm = (Nothing, noLoc mod_nm)
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
isLocal mb_pkg ]
where isLocal Nothing = True
isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
isLocal _ = False
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
-- | Like 'ms_home_imps', but for SOURCE imports.
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps = home_imps . ms_srcimps
-- | All of the (possibly) home module imports from a
-- 'ModSummary'; that is to say, each of these module names
-- could be a home import if an appropriately named file
-- existed. (This is in contrast to package qualified
-- imports, which are guaranteed not to be home imports.)
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps = home_imps . ms_imps
-- The ModLocation contains both the original source filename and the
-- filename of the cleaned-up source file after all preprocessing has been
-- done. The point is that the summariser will have to cpp/unlit/whatever
......
......@@ -10,9 +10,11 @@
--
module Format (
Format(..),
ScalarFormat(..),
intFormat,
floatFormat,
isFloatFormat,
isVecFormat,
cmmTypeFormat,
formatToWidth,
formatInBytes
......@@ -25,6 +27,29 @@ import GhcPrelude
import Cmm
import Outputable