Skip to content
Commits on Source (24)
  • Ben Gamari's avatar
    testsuite: Add testcase for #16111 · 6c0dd085
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    6c0dd085
  • Andreas Klebinger's avatar
    Restore Xmm registers properly in StgCRun.c · cbb88865
    Andreas Klebinger authored and Marge Bot's avatar Marge Bot committed
    This fixes #16514: Xmm6-15 was restored based off rax instead of rsp.
    The code was introduced in the fix for #14619.
    cbb88865
  • Ryan Scott's avatar
    Tweak error messages for narrowly-kinded assoc default decls · 33b0a291
    Ryan Scott authored and Marge Bot's avatar Marge Bot committed
    This program, from #13971, currently has a rather confusing error
    message:
    
    ```hs
    class C a where
      type T a :: k
      type T a = Int
    ```
    ```
        • Kind mis-match on LHS of default declaration for ‘T’
        • In the default type instance declaration for ‘T’
          In the class declaration for ‘C’
    ```
    
    It's not at all obvious why GHC is complaining about the LHS until
    you realize that the default, when printed with
    `-fprint-explicit-kinds`, is actually `type T @{k} @* a = Int`.
    That is to say, the kind of `a` is being instantiated to `Type`,
    whereas it ought to be a kind variable. The primary thrust of this
    patch is to weak the error message to make this connection
    more obvious:
    
    ```
        • Illegal argument ‘*’ in:
            ‘type T @{k} @* a = Int’
            The arguments to ‘T’ must all be type variables
        • In the default type instance declaration for ‘T’
          In the class declaration for ‘C’
    ```
    
    Along the way, I performed some code cleanup suggested by @rae in
    ghc/ghc#13971 (comment 191287). Before,
    we were creating a substitution from the default declaration's type
    variables to the type family tycon's type variables by way of
    `tcMatchTys`. But this is overkill, since we already know (from the
    aforementioned validity checking) that all the arguments in a default
    declaration must be type variables anyway. Therefore, creating the
    substitution is as simple as using `zipTvSubst`. I took the
    opportunity to perform this refactoring while I was in town.
    
    Fixes #13971.
    33b0a291
  • Eric Crockett's avatar
    Fix #16282. · 3a38ea44
    Eric Crockett authored and Ben Gamari's avatar Ben Gamari committed
    Previously, -W(all-)missed-specs was created with 'NoReason',
    so no information about the flag was printed along with the warning.
    Now, -Wall-missed-specs is listed as the Reason if it was set,
    otherwise -Wmissed-specs is listed as the reason.
    3a38ea44
  • Michal Terepeta's avatar
    Generate straightline code for inline array allocation · 63b7d5fb
    Michal Terepeta authored and Marge Bot's avatar Marge Bot committed
    
    
    GHC has an optimization for allocating arrays when the size is
    statically known -- it'll generate the code allocating and initializing
    the array inline (instead of a call to a procedure from
    `rts/PrimOps.cmm`).
    
    However, the generated code uses a loop to do the initialization. Since
    we already check that the requested size is small (we check against
    `maxInlineAllocSize`), we can generate faster straightline code instead.
    This brings about 15% improvement for `newSmallArray#` in my testing and
    slightly simplifies the code in GHC.
    
    Signed-off-by: default avatarMichal Terepeta <michal.terepeta@gmail.com>
    63b7d5fb
  • Phuong Trinh's avatar
    Fix #16500: look for interface files in -hidir flag in OneShot mode · 2b3f4718
    Phuong Trinh authored and Marge Bot's avatar Marge Bot committed
    We are currently ignoring options set in the hiDir field of hsc_dflags
    when looking for interface files while compiling in OneShot mode. This
    is inconsistent with the behaviour of other directory redirecting fields
    (such as objectDir or hieDir). It is also inconsistent with the
    behaviour of compilation in CompManager mode (a.k.a `ghc --make`) which
    looks for interface files in the directory set in hidir flag. This
    changes Finder.hs so that we use the value of hiDir while looking for
    interface in OneShot mode.
    2b3f4718
  • Yuriy Syrovetskiy's avatar
    Add `-optcxx` option (#16477) · 97502be8
    Yuriy Syrovetskiy authored and Marge Bot's avatar Marge Bot committed
    97502be8
  • Ben Gamari's avatar
    testsuite: Unmark T16190 as broken · 97d3d546
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    Was broken via #16389 yet strangely it has started passing despite the
    fact that the suggested root cause has not changed.
    97d3d546
  • Yuriy Syrovetskiy's avatar
    Fix whitespace style · a42d206a
    Yuriy Syrovetskiy authored and Marge Bot's avatar Marge Bot committed
    a42d206a
  • Matthew Pickering's avatar
    Use ./hadrian/ghci.sh in .ghcid · 4dda2270
    Matthew Pickering authored and Marge Bot's avatar Marge Bot committed
    4dda2270
  • Sebastian Graf's avatar
    Make `singleConstructor` cope with pattern synonyms · d236d9d0
    Sebastian Graf authored and Marge Bot's avatar Marge Bot committed
    Previously, `singleConstructor` didn't handle singleton `COMPLETE` sets
    of a single pattern synonym, resulting in incomplete pattern warnings
    in #15753.
    
    This is fixed by making `singleConstructor` (now named
    `singleMatchConstructor`) query `allCompleteMatches`, necessarily making
    it effectful. As a result, most of this patch is concerned with
    threading the side-effect through to `singleMatchConstructor`.
    
    Unfortunately, this is not enough to completely fix the original
    reproduction from #15753 and #15884, which are related to function
    applications in pattern guards being translated too conservatively.
    d236d9d0
  • Ömer Sinan Ağacan's avatar
    Skip test ArithInt16 and ArithWord16 in GHCi way · 1085090e
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    These tests use unboxed tuples, which GHCi doesn't support
    1085090e
  • Ömer Sinan Ağacan's avatar
    testsuite: Show exit code of GHCi tests on failure · 7287bb9e
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    7287bb9e
  • John Ericson's avatar
    settings.in: Reformat · f5604d37
    John Ericson authored and Marge Bot's avatar Marge Bot committed
    We're might be about to switch to generating it in Hadrian/Make. This
    reformat makes it easier to programmingmatically generate and end up
    with the exact same thing, which is good for diffing to ensure no
    regressions.
    
    I had this as part of !712, but given the difficulty of satisfying CI, I
    figured I should break things up even further.
    f5604d37
  • Ryan Scott's avatar
    Bump hpc submodule · cf9e1837
    Ryan Scott authored and Marge Bot's avatar Marge Bot committed
    Currently, the `hpc` submodule is pinned against the `wip/final-mfp`
    branch, not against `master`. This pins it back against `master`.
    cf9e1837
  • Ben Gamari's avatar
    users-guide: Document how to disable package environments · 36d38047
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    As noted in #16309 this somehow went undocumented.
    36d38047
  • Artem Pyanykh's avatar
    codegen: fix memset unroll for small bytearrays, add 64-bit sets · af4cea7f
    Artem Pyanykh authored and Marge Bot's avatar Marge Bot committed
    Fixes #16052
    
    When the offset in `setByteArray#` is statically known, we can provide
    better alignment guarantees then just 1 byte.
    
    Also, memset can now do 64-bit wide sets.
    
    The current memset intrinsic is not optimal however and can be
    improved for the case when we know that we deal with
    
    (baseAddress at known alignment) + offset
    
    For instance, on 64-bit
    
    `setByteArray# s 1# 23# 0#`
    
    given that bytearray is 8 bytes aligned could be unrolled into
    `movb, movw, movl, movq, movq`; but currently it is
    `movb x23` since alignment of 1 is all we can embed into MO_Memset op.
    af4cea7f
  • Artem Pyanykh's avatar
    codegen: use newtype for Alignment in BasicTypes · bd2de4f0
    Artem Pyanykh authored and Marge Bot's avatar Marge Bot committed
    bd2de4f0
  • Artem Pyanykh's avatar
    docs: add a note about changes in memset unrolling to 8.10.1-notes · 14a78707
    Artem Pyanykh authored and Marge Bot's avatar Marge Bot committed
    14a78707
  • Sylvain Henry's avatar
    Hadrian: fix library install paths in bindist Makefile (#16498) · fe40ddd9
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    GHC now works out-of-the-box (i.e. without any wrapper script) by
    assuming that @bin@ and @lib@ directories sit next to each other. In
    particular, its RUNPATH uses $ORIGIN-based relative path to find the
    libraries.
    
    However, to be good citizens we want to support the case where @bin@ and
    @lib@ directories (respectively BINDIR and LIBDIR) don't sit next to
    each other or are renamed. To do that the install script simply creates
    GHC specific @bin@ and @lib@ siblings directories into:
    
       LIBDIR/ghc-VERSION/{bin,lib}
    
    Then it installs wrapper scripts into BINDIR that call the appropriate
    programs into LIBDIR/ghc-VERSION/bin/.
    
    The issue fixed by this patch is that libraries were not installed into
    LIBDIR/ghc-VERSION/lib but directly into LIBDIR.
    fe40ddd9
  • Ben Gamari's avatar
    gitlab: Bump cabal-install version used by Windows builds to 2.4 · 9acdc4c0
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    Hopefully fixes Windows Hadrian build.
    9acdc4c0
  • Joachim Breitner's avatar
    GHC no longer ever defines TABLES_NEXT_TO_CODE on its own · fc3f421b
    Joachim Breitner authored and Marge Bot's avatar Marge Bot committed
    It should be entirely the responsibility of make/Hadrian to ensure that
    everything that needs this flag gets it. GHC shouldn't be hardcoded to
    assist with bootstrapping since it builds other things besides itself.
    
    Reviewers:
    
    Subscribers: TerrorJack, rwbarton, carter
    
    GHC Trac Issues: #15548 -- progress towards but not fix
    
    Differential Revision: https://phabricator.haskell.org/D5082 -- extract
    from that
    fc3f421b
  • Ryan Scott's avatar
    Use ghc-prim < 0.7, not <= 0.6.1, as upper version bounds · be0dde8e
    Ryan Scott authored and Marge Bot's avatar Marge Bot committed
    Using `ghc-prim <= 0.6.1` is somewhat dodgy from a PVP point of view,
    as it makes it awkward to support new minor releases of `ghc-prim`.
    Let's instead use `< 0.7`, which is the idiomatic way of expressing
    PVP-compliant upper version bounds.
    be0dde8e
  • Joachim Breitner's avatar
    Make tablesNextToCode a proper dynamic flag (#15548) · ca475136
    Joachim Breitner authored and John Ericson's avatar John Ericson committed
    Summary:
    There is no more use of the TABLES_NEXT_TO_CODE CPP macro in
    `compiler/`. GHCI_TABLES_NEXT_TO_CODE is also removed entirely. The
    default value of `tablesNextToCode` is calculated as before, but now
    users of the GHCI API can modify this flag.
    
    That said, GHC still is hardcoded to define TABLES_NEXT_TO_CODE based on
    that default value. This is bad, but neccessary until the remaining uses
    of TABLES_NEXT_TO_CODE get it from make/Hadrian.
    
    Reviewers:
    
    Subscribers: TerrorJack, rwbarton, carter
    
    GHC Trac Issues: #15548
    
    Differential Revision: https://phabricator.haskell.org/D5082
    ca475136
--command utils/ghc-in-ghci/run.sh
--command ./hadrian/ghci.sh
--reload compiler
--reload ghc
--reload includes
--restart utils/ghc-in-ghci/run.sh
--restart utils/ghc-in-ghci/load-main.ghci
--restart utils/ghc-in-ghci/settings.ghci
--restart hadrian/
......@@ -4,6 +4,10 @@ variables:
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
# Sequential version number capturing the versions of all tools fetched by
# .gitlab/win32-init.sh.
WINDOWS_TOOLCHAIN_VERSION: 1
before_script:
- python3 .gitlab/fix-submodules.py
- git submodule sync --recursive
......@@ -48,7 +52,7 @@ ghc-linters:
stage: lint
image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
script:
- git fetch origin $CI_MERGE_REQUEST_TARGET_BRANCH_NAME
- git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME
- base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"
- "echo Merge base $base"
# - validate-commit-msg .git $(git rev-list $base..$CI_COMMIT_SHA)
......@@ -525,7 +529,7 @@ validate-x86_64-windows-hadrian:
variables:
MSYSTEM: MINGW64
cache:
key: x86_64-windows-hadrian
key: "x86_64-windows-hadrian-$WINDOWS_TOOLCHAIN_VERSION"
nightly-i386-windows-hadrian:
extends: .build-windows-hadrian
......@@ -535,7 +539,7 @@ nightly-i386-windows-hadrian:
variables:
- $NIGHTLY
cache:
key: i386-windows-hadrian
key: "i386-windows-hadrian-$WINDOWS_TOOLCHAIN_VERSION"
.build-windows-make:
extends: .build-windows
......@@ -571,7 +575,7 @@ validate-x86_64-windows:
MSYSTEM: MINGW64
CONFIGURE_ARGS: "--target=x86_64-unknown-mingw32"
cache:
key: x86_64-windows
key: "x86_64-windows-$WINDOWS_TOOLCHAIN_VERSION"
# Normal Windows validate builds are profiled; that won't do for releases.
release-x86_64-windows:
......@@ -592,7 +596,7 @@ release-i386-windows:
BUILD_FLAVOUR: "perf"
CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
cache:
key: i386-windows
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
nightly-i386-windows:
extends: .build-windows-make
......@@ -603,7 +607,7 @@ nightly-i386-windows:
MSYSTEM: MINGW32
CONFIGURE_ARGS: "--target=i386-unknown-mingw32"
cache:
key: i386-windows
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
############################################################
# Cleanup
......@@ -764,4 +768,3 @@ pages:
artifacts:
paths:
- public
......@@ -27,7 +27,8 @@ if [ ! -e $toolchain/bin/ghc ]; then
fi
if [ ! -e $toolchain/bin/cabal ]; then
curl https://www.haskell.org/cabal/release/cabal-install-2.2.0.0/cabal-install-2.2.0.0-i386-unknown-mingw32.zip > /tmp/cabal.zip
url="https://downloads.haskell.org/~cabal/cabal-install-latest/cabal-install-2.4.1.0-x86_64-unknown-mingw32.zip"
curl $url > /tmp/cabal.zip
unzip /tmp/cabal.zip
mv cabal.exe $toolchain/bin
fi
......
......@@ -26,7 +26,7 @@ module BasicTypes(
Arity, RepArity, JoinArity,
Alignment,
Alignment, mkAlignment, alignmentOf, alignmentBytes,
PromotionFlag(..), isPromoted,
FunctionOrData(..),
......@@ -116,6 +116,7 @@ import Outputable
import SrcLoc ( Located,unLoc )
import Data.Data hiding (Fixity, Prefix, Infix)
import Data.Function (on)
import Data.Bits
{-
************************************************************************
......@@ -196,8 +197,39 @@ fIRST_TAG = 1
************************************************************************
-}
type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
-- | A power-of-two alignment
newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord)
-- Builds an alignment, throws on non power of 2 input. This is not
-- ideal, but convenient for internal use and better then silently
-- passing incorrect data.
mkAlignment :: Int -> Alignment
mkAlignment n
| n == 1 = Alignment 1
| n == 2 = Alignment 2
| n == 4 = Alignment 4
| n == 8 = Alignment 8
| n == 16 = Alignment 16
| n == 32 = Alignment 32
| n == 64 = Alignment 64
| n == 128 = Alignment 128
| n == 256 = Alignment 256
| n == 512 = Alignment 512
| otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512"
-- Calculates an alignment of a number. x is aligned at N bytes means
-- the remainder from x / N is zero. Currently, interested in N <= 8,
-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX
-- context.
alignmentOf :: Int -> Alignment
alignmentOf x = case x .&. 7 of
0 -> Alignment 8
4 -> Alignment 4
2 -> Alignment 2
_ -> Alignment 1
instance Outputable Alignment where
ppr (Alignment m) = ppr m
{-
************************************************************************
* *
......
......@@ -2073,10 +2073,17 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
-- character.
doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
doSetByteArrayOp ba off len c
= do dflags <- getDynFlags
p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
emitMemsetCall p c len 1
doSetByteArrayOp ba off len c = do
dflags <- getDynFlags
let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap
offsetAlignment = case off of
CmmLit (CmmInt intOff _) -> alignmentOf (fromInteger intOff)
_ -> mkAlignment 1
align = min byteArrayAlignment offsetAlignment
p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
emitMemsetCall p c len align
-- ----------------------------------------------------------------------------
-- Allocating arrays
......@@ -2105,17 +2112,11 @@ doNewArrayOp res_r rep info payload n init = do
-- Initialise all elements of the array
p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
for <- newBlockId
emitLabel for
let loopBody =
[ mkStore (CmmReg (CmmLocal p)) init
, mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1)
, mkBranch for ]
emit =<< mkCmmIfThen
(cmmULtWord dflags (CmmReg (CmmLocal p))
(cmmOffsetW dflags (CmmReg arr)
(hdrSizeW dflags rep + n)))
(catAGraphs loopBody)
let initialization =
[ mkStore (cmmOffsetW dflags (CmmReg (CmmLocal p)) off) init
| off <- [0.. n - 1]
]
emit (catAGraphs initialization)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
......@@ -2353,7 +2354,7 @@ emitSetCards dst_start dst_cards_start n = do
emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
(mkIntExpr dflags 1)
(cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))
1 -- no alignment (1 byte)
(mkAlignment 1) -- no alignment (1 byte)
-- Convert an element index to a card index
cardCmm :: DynFlags -> CmmExpr -> CmmExpr
......@@ -2479,11 +2480,11 @@ emitMemmoveCall dst src n align = do
-- | Emit a call to @memset@. The second argument must fit inside an
-- unsigned char.
emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
emitMemsetCall dst c n align = do
emitPrimCall
[ {- no results -} ]
(MO_Memset align)
(MO_Memset (alignmentBytes align))
[ dst, c, n ]
emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
......
......@@ -4,9 +4,13 @@ Author: George Karachalias <george.karachalias@cs.kuleuven.be>
Pattern Matching Coverage Checking.
-}
{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
module Check (
-- Checking and printing
......@@ -55,7 +59,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.List (find)
import Data.Maybe (catMaybes, isJust, fromMaybe)
import Control.Monad (forM, when, forM_, zipWithM)
import Control.Monad (forM, when, forM_, zipWithM, filterM)
import Coercion
import TcEvidence
import TcSimplify (tcNormalise)
......@@ -289,6 +293,14 @@ data PmResult =
, pmresultUncovered :: UncoveredCandidates
, pmresultInaccessible :: [Located [LPat GhcTc]] }
instance Outputable PmResult where
ppr pmr = hang (text "PmResult") 2 $ vcat
[ text "pmresultProvenance" <+> ppr (pmresultProvenance pmr)
, text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)
, text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)
, text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)
]
-- | Either a list of patterns that are not covered, or their type, in case we
-- have no patterns at hand. Not having patterns at hand can arise when
-- handling EmptyCase expressions, in two cases:
......@@ -303,6 +315,10 @@ data PmResult =
data UncoveredCandidates = UncoveredPatterns Uncovered
| TypeOfUncovered Type
instance Outputable UncoveredCandidates where
ppr (UncoveredPatterns uc) = text "UnPat" <+> ppr uc
ppr (TypeOfUncovered ty) = text "UnTy" <+> ppr ty
-- | The empty pattern check result
emptyPmResult :: PmResult
emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []
......@@ -987,7 +1003,7 @@ translatePat fam_insts pat = case pat of
| otherwise -> do
ps <- translatePat fam_insts p
(xp,xe) <- mkPmId2Forms ty
let g = mkGuard ps (mkHsWrap wrapper (unLoc xe))
g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
......@@ -997,10 +1013,11 @@ translatePat fam_insts pat = case pat of
ViewPat arg_ty lexpr lpat -> do
ps <- translatePat fam_insts (unLoc lpat)
-- See Note [Guards and Approximation]
case all cantFailPattern ps of
res <- allM cantFailPattern ps
case res of
True -> do
(xp,xe) <- mkPmId2Forms arg_ty
let g = mkGuard ps (HsApp noExt lexpr xe)
g <- mkGuard ps (HsApp noExt lexpr xe)
return [xp,g]
False -> mkCanFailPmPat arg_ty
......@@ -1255,41 +1272,38 @@ translateMatch _ _ = panic "translateMatch"
translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec
translateGuards fam_insts guards = do
all_guards <- concat <$> mapM (translateGuard fam_insts) guards
return (replace_unhandled all_guards)
-- It should have been (return all_guards) but it is too expressive.
let
shouldKeep :: Pattern -> DsM Bool
shouldKeep p
| PmVar {} <- p = pure True
| PmCon {} <- p = (&&)
<$> singleMatchConstructor (pm_con_con p) (pm_con_arg_tys p)
<*> allM shouldKeep (pm_con_args p)
shouldKeep (PmGrd pv e)
| isNotPmExprOther e = pure True -- expensive but we want it
| otherwise = allM shouldKeep pv
shouldKeep _other_pat = pure False -- let the rest..
all_handled <- allM shouldKeep all_guards
-- It should have been @pure all_guards@ but it is too expressive.
-- Since the term oracle does not handle all constraints we generate,
-- we (hackily) replace all constraints the oracle cannot handle with a
-- single one (we need to know if there is a possibility of falure).
-- single one (we need to know if there is a possibility of failure).
-- See Note [Guards and Approximation] for all guard-related approximations
-- we implement.
where
replace_unhandled :: PatVec -> PatVec
replace_unhandled gv
| any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]
| otherwise = gv
any_unhandled :: PatVec -> Bool
any_unhandled gv = any (not . shouldKeep) gv
shouldKeep :: Pattern -> Bool
shouldKeep p
| PmVar {} <- p = True
| PmCon {} <- p = singleConstructor (pm_con_con p)
&& all shouldKeep (pm_con_args p)
shouldKeep (PmGrd pv e)
| all shouldKeep pv = True
| isNotPmExprOther e = True -- expensive but we want it
shouldKeep _other_pat = False -- let the rest..
if all_handled
then pure all_guards
else do
kept <- filterM shouldKeep all_guards
pure (fake_pat : kept)
-- | Check whether a pattern can fail to match
cantFailPattern :: Pattern -> Bool
cantFailPattern p
| PmVar {} <- p = True
| PmCon {} <- p = singleConstructor (pm_con_con p)
&& all cantFailPattern (pm_con_args p)
cantFailPattern (PmGrd pv _e)
= all cantFailPattern pv
cantFailPattern _ = False
cantFailPattern :: Pattern -> DsM Bool
cantFailPattern PmVar {} = pure True
cantFailPattern PmCon { pm_con_con = c, pm_con_arg_tys = tys, pm_con_args = ps}
= (&&) <$> singleMatchConstructor c tys <*> allM cantFailPattern ps
cantFailPattern (PmGrd pv _e) = allM cantFailPattern pv
cantFailPattern _ = pure False
-- | Translate a guard statement to Pattern
translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
......@@ -1312,7 +1326,8 @@ translateLet _binds = return []
translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
translateBind fam_insts (dL->L _ p) e = do
ps <- translatePat fam_insts p
return [mkGuard ps (unLoc e)]
g <- mkGuard ps (unLoc e)
return [g]
-- | Translate a boolean guard
translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec
......@@ -1321,7 +1336,7 @@ translateBoolGuard e
-- The formal thing to do would be to generate (True <- True)
-- but it is trivial to solve so instead we give back an empty
-- PatVec for efficiency
| otherwise = return [mkGuard [truePattern] (unLoc e)]
| otherwise = (:[]) <$> mkGuard [truePattern] (unLoc e)
{- Note [Guards and Approximation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1658,13 +1673,14 @@ mkOneConFull x con = do
-- * More smart constructors and fresh variable generation
-- | Create a guard pattern
mkGuard :: PatVec -> HsExpr GhcTc -> Pattern
mkGuard pv e
| all cantFailPattern pv = PmGrd pv expr
| PmExprOther {} <- expr = fake_pat
| otherwise = PmGrd pv expr
where
expr = hsExprToPmExpr e
mkGuard :: PatVec -> HsExpr GhcTc -> DsM Pattern
mkGuard pv e = do
res <- allM cantFailPattern pv
let expr = hsExprToPmExpr e
tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])
if | res -> pure (PmGrd pv expr)
| PmExprOther {} <- expr -> pure fake_pat
| otherwise -> pure (PmGrd pv expr)
-- | Create a term equality of the form: `(False ~ (x ~ lit))`
mkNegEq :: Id -> PmLit -> ComplexEq
......@@ -1738,14 +1754,37 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
, pm_con_args = coercePatVec args }]
coercePmPat (PmGrd {}) = [] -- drop the guards
-- | Check whether a data constructor is the only way to construct
-- a data type.
singleConstructor :: ConLike -> Bool
singleConstructor (RealDataCon dc) =
case tyConDataCons (dataConTyCon dc) of
[_] -> True
_ -> False
singleConstructor _ = False
-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether
-- it is the only possible match in the given context. See also
-- 'allCompleteMatches' and Note [Single match constructors].
singleMatchConstructor :: ConLike -> [Type] -> DsM Bool
singleMatchConstructor cl tys =
any (isSingleton . snd) <$> allCompleteMatches cl tys
{-
Note [Single match constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When translating pattern guards for consumption by the checker, we desugar
every pattern guard that might fail ('cantFailPattern') to 'fake_pat'
(True <- _). Which patterns can't fail? Exactly those that only match on
'singleMatchConstructor's.
Here are a few examples:
* @f a | (a, b) <- foo a = 42@: Product constructors are generally
single match. This extends to single constructors of GADTs like 'Refl'.
* If @f | Id <- id () = 42@, where @pattern Id = ()@ and 'Id' is part of a
singleton `COMPLETE` set, then 'Id' has the single match property.
In effect, we can just enumerate 'allCompleteMatches' and check if the conlike
occurs as a singleton set.
There's the chance that 'Id' is part of multiple `COMPLETE` sets. That's
irrelevant; If the user specified a singleton set, it is single-match.
Note that this doesn't really take into account incoming type constraints;
It might be obvious from type context that a particular GADT constructor has
the single-match property. We currently don't (can't) check this in the
translation step. See #15753 for why this yields surprising results.
-}
-- | For a given conlike, finds all the sets of patterns which could
-- be relevant to that conlike by consulting the result type.
......
......@@ -330,14 +330,6 @@ endif
ifeq "$(GhcWithInterpreter)" "YES"
compiler_stage2_CONFIGURE_OPTS += --flags=ghci
ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
# Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style
# or not?
# XXX This should logically be a CPP option, but there doesn't seem to
# be a flag for that
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE
endif
# Should the debugger commands be enabled?
ifeq "$(GhciWithDebugger)" "YES"
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DDEBUGGER
......
......@@ -71,6 +71,8 @@ make_constr_itbls hsc_env cons =
descr = dataConIdentity dcon
r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
tables_next_to_code = tablesNextToCode dflags
r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
conNo (tagForCon dflags dcon) descr)
return (getName dcon, ItblPtr r)
......@@ -369,4 +369,3 @@ isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f)
isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool
isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)
isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)
......@@ -1218,17 +1218,8 @@ runPhase (RealPhase cc_phase) input_fn dflags
ghcVersionH <- liftIO $ getGhcVersionPathName dflags
let gcc_lang_opt | cc_phase `eqPhase` Ccxx = "c++"
| cc_phase `eqPhase` Cobjc = "objective-c"
| cc_phase `eqPhase` Cobjcxx = "objective-c++"
| otherwise = "c"
liftIO $ SysTools.runCc dflags (
-- force the C compiler to interpret this file as C when
-- compiling .hc files, by adding the -x c option.
-- Also useful for plain .c files, just in case GHC saw a
-- -x c option.
[ SysTools.Option "-x", SysTools.Option gcc_lang_opt
, SysTools.FileOption "" input_fn
liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags (
[ SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
......@@ -1917,7 +1908,7 @@ doCpp dflags raw input_fn output_fn = do
let verbFlags = getVerbFlags dflags
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
| otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args)
let target_defs =
[ "-D" ++ HOST_OS ++ "_BUILD_OS",
......
......@@ -58,7 +58,6 @@ module DynFlags (
fFlags, fLangFlags, xFlags,
wWarningFlags,
dynFlagDependencies,
tablesNextToCode, mkTablesNextToCode,
makeDynFlagsConsistent,
shouldUseColor,
shouldUseHexWordLiterals,
......@@ -92,7 +91,8 @@ module DynFlags (
extraGccViaCFlags, systemPackageConfig,
pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T,
pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,
pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
pgm_lcc, pgm_i,
opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i,
opt_P_signature,
opt_windres, opt_lo, opt_lc, opt_lcc,
......@@ -146,6 +146,7 @@ module DynFlags (
#include "GHCConstantsHaskellExports.hs"
bLOCK_SIZE_W,
wORD_SIZE_IN_BITS,
wordAlignment,
tAG_MASK,
mAX_PTR_TAG,
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
......@@ -204,7 +205,7 @@ import Maybes
import MonadUtils
import qualified Pretty
import SrcLoc
import BasicTypes ( IntWithInf, treatZeroAsInf )
import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )
import FastString
import Fingerprint
import Outputable
......@@ -876,6 +877,10 @@ data DynFlags = DynFlags {
integerLibrary :: IntegerLibrary,
-- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden
-- by GHC-API users. See Note [The integer library] in PrelNames
tablesNextToCode :: Bool,
-- ^ Determines whether we will be compiling info tables that reside just
-- before the entry code, or with an indirection to the entry code. See
-- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.
llvmTargets :: LlvmTargets,
llvmPasses :: LlvmPasses,
verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels]
......@@ -1340,6 +1345,7 @@ data Settings = Settings {
-- See Note [Repeated -optP hashing]
sOpt_F :: [String],
sOpt_c :: [String],
sOpt_cxx :: [String],
sOpt_a :: [String],
sOpt_l :: [String],
sOpt_windres :: [String],
......@@ -1423,6 +1429,8 @@ opt_F dflags = sOpt_F (settings dflags)
opt_c :: DynFlags -> [String]
opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)
++ sOpt_c (settings dflags)
opt_cxx :: DynFlags -> [String]
opt_cxx dflags = sOpt_cxx (settings dflags)
opt_a :: DynFlags -> [String]
opt_a dflags = sOpt_a (settings dflags)
opt_l :: DynFlags -> [String]
......@@ -1614,18 +1622,6 @@ defaultObjectTarget platform
| cGhcWithNativeCodeGen == "YES" = HscAsm
| otherwise = HscLlvm
tablesNextToCode :: DynFlags -> Bool
tablesNextToCode dflags
= mkTablesNextToCode (platformUnregisterised (targetPlatform dflags))
-- Determines whether we will be compiling
-- info tables that reside just before the entry code, or with an
-- indirection to the entry code. See TABLES_NEXT_TO_CODE in
-- includes/rts/storage/InfoTables.h.
mkTablesNextToCode :: Bool -> Bool
mkTablesNextToCode unregisterised
= not unregisterised && cGhcEnableTablesNextToCode == "YES"
data DynLibLoader
= Deployable
| SystemDependent
......@@ -1874,6 +1870,9 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings),
integerLibrary = cIntegerLibraryType,
tablesNextToCode =
not (platformUnregisterised $ sTargetPlatform mySettings) &&
cGhcEnableTablesNextToCode == "YES",
verbosity = 0,
optLevel = 0,
debugLevel = 0,
......@@ -2520,7 +2519,7 @@ setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,
setDynObjectSuf, setDynHiSuf,
setDylibInstallName,
setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,
setPgmP, addOptl, addOptc, addOptP,
setPgmP, addOptl, addOptc, addOptcxx, addOptP,
addCmdlineFramework, addHaddockOpts, addGhciScript,
setInteractivePrint
:: String -> DynFlags -> DynFlags
......@@ -2636,6 +2635,7 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f}
setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)})
addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s})
addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s})
addOptcxx f = alterSettings (\s -> s { sOpt_cxx = f : sOpt_cxx s})
addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s
, sOpt_P_fingerprint = fingerprintStrings (f : sOpt_P s)
})
......@@ -3038,6 +3038,8 @@ dynamic_flags_deps = [
(hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s})))
, make_ord_flag defFlag "optc"
(hasArg addOptc)
, make_ord_flag defFlag "optcxx"
(hasArg addOptcxx)
, make_ord_flag defFlag "opta"
(hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s})))
, make_ord_flag defFlag "optl"
......@@ -5654,6 +5656,9 @@ bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags
wORD_SIZE_IN_BITS :: DynFlags -> Int
wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8
wordAlignment :: DynFlags -> Alignment
wordAlignment dflags = alignmentOf (wORD_SIZE dflags)
tAG_MASK :: DynFlags -> Int
tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
......
......@@ -313,8 +313,10 @@ findInstalledHomeModule hsc_env mod_name =
, ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig")
]
hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf)
, (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf)
-- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
-- when hiDir field is set in dflags, we know to look there (see #16500)
hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name)
, (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name)
]
-- In compilation manager modes, we look for source files in the home
......@@ -489,6 +491,15 @@ mkHomeModLocation2 dflags mod src_basename ext = do
ml_obj_file = obj_fn,
ml_hie_file = hie_fn })
mkHomeModHiOnlyLocation :: DynFlags
-> ModuleName
-> FilePath
-> BaseName
-> IO ModLocation
mkHomeModHiOnlyLocation dflags mod path basename = do
loc <- mkHomeModLocation2 dflags mod (path </> basename) ""
return loc { ml_hs_file = Nothing }
mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
-> IO ModLocation
mkHiOnlyModLocation dflags hisuf path basename
......
......@@ -30,6 +30,7 @@ module HscTypes (
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),
ForeignSrcLang(..),
phaseForeignLanguage,
ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
......@@ -182,6 +183,7 @@ import CmdLineParser
import DynFlags
import DriverPhases ( Phase, HscSource(..), hscSourceString
, isHsBootOrSig, isHsigFile )
import qualified DriverPhases as Phase
import BasicTypes
import IfaceSyn
import Maybes
......@@ -3136,3 +3138,15 @@ Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed
explanation for how GHC ensures that all the conlikes in a COMPLETE set are
consistent.
-}
-- | Foreign language of the phase if the phase deals with a foreign code
phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang
phaseForeignLanguage phase = case phase of
Phase.Cc -> Just LangC
Phase.Ccxx -> Just LangCxx
Phase.Cobjc -> Just LangObjc
Phase.Cobjcxx -> Just LangObjcxx
Phase.HCc -> Just LangC
Phase.As _ -> Just LangAsm
Phase.MergeForeign -> Just RawObject
_ -> Nothing
......@@ -199,15 +199,9 @@ initSysTools top_dir
let unreg_gcc_args = if targetUnregisterised
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
-- TABLES_NEXT_TO_CODE affects the info table layout.
tntc_gcc_args
| mkTablesNextToCode targetUnregisterised
= ["-DTABLES_NEXT_TO_CODE"]
| otherwise = []
cpp_args= map Option (words cpp_args_str)
gcc_args = map Option (words gcc_args_str
++ unreg_gcc_args
++ tntc_gcc_args)
++ unreg_gcc_args)
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
......@@ -301,6 +295,7 @@ initSysTools top_dir
sOpt_P_fingerprint = fingerprint0,
sOpt_F = [],
sOpt_c = [],
sOpt_cxx = [],
sOpt_a = [],
sOpt_l = [],
sOpt_windres = [],
......
......@@ -40,7 +40,7 @@ mkExtraObj dflags extn xs
oFile <- newTempName dflags TFL_GhcSession "o"
writeFile cFile xs
ccInfo <- liftIO $ getCompilerInfo dflags
runCc dflags
runCc Nothing dflags
([Option "-c",
FileOption "" cFile,
Option "-o",
......
......@@ -10,6 +10,7 @@ module SysTools.Tasks where
import Exception
import ErrUtils
import HscTypes
import DynFlags
import Outputable
import Platform
......@@ -58,11 +59,12 @@ runPp dflags args = do
opts = map Option (getOpts dflags opt_F)
runSomething dflags "Haskell pre-processor" prog (args ++ opts)
runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args = do
-- | Run compiler of C-like languages and raw objects (such as gcc or clang).
runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
runCc mLanguage dflags args = do
let (p,args0) = pgm_c dflags
args1 = map Option (getOpts dflags opt_c)
args2 = args0 ++ args ++ args1
args1 = map Option userOpts
args2 = args0 ++ languageOptions ++ args ++ args1
-- We take care to pass -optc flags in args1 last to ensure that the
-- user can override flags passed by GHC. See #14452.
mb_env <- getGccEnv args2
......@@ -118,6 +120,21 @@ runCc dflags args = do
| "warning: call-clobbered register used" `isContainedIn` w = False
| otherwise = True
-- force the C compiler to interpret this file as C when
-- compiling .hc files, by adding the -x c option.
-- Also useful for plain .c files, just in case GHC saw a
-- -x c option.
(languageOptions, userOpts) = case mLanguage of
Nothing -> ([], userOpts_c)
Just language -> ([Option "-x", Option languageName], opts) where
(languageName, opts) = case language of
LangCxx -> ("c++", userOpts_cxx)
LangObjc -> ("objective-c", userOpts_c)
LangObjcxx -> ("objective-c++", userOpts_cxx)
_ -> ("c", userOpts_c)
userOpts_c = getOpts dflags opt_c
userOpts_cxx = getOpts dflags opt_cxx
isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
......
......@@ -128,7 +128,7 @@ cmmTopCodeGen (CmmProc info lab live graph) = do
Nothing -> return tops
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic
return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic
basicBlockCodeGen
......@@ -569,7 +569,7 @@ getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =
return (Any format code)
| otherwise = do
Amode addr code <- memConstant (widthInBytes w) lit
Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
loadFloatAmode True w addr code
float_const_x87 = case w of
......@@ -583,7 +583,7 @@ getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =
in return (Any FF80 code)
_otherwise -> do
Amode addr code <- memConstant (widthInBytes w) lit
Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
loadFloatAmode False w addr code
-- catch simple cases of zero- or sign-extended load
......@@ -1247,7 +1247,7 @@ getNonClobberedOperand (CmmLit lit) = do
if use_sse2 && isSuitableFloatingPointLit lit
then do
let CmmFloat _ w = lit
Amode addr code <- memConstant (widthInBytes w) lit
Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
return (OpAddr addr, code)
else do
......@@ -1303,7 +1303,7 @@ getOperand (CmmLit lit) = do
if (use_sse2 && isSuitableFloatingPointLit lit)
then do
let CmmFloat _ w = lit
Amode addr code <- memConstant (widthInBytes w) lit
Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
return (OpAddr addr, code)
else do
......@@ -1351,7 +1351,7 @@ addAlignmentCheck align reg =
, JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
]
memConstant :: Int -> CmmLit -> NatM Amode
memConstant :: Alignment -> CmmLit -> NatM Amode
memConstant align lit = do
lbl <- getNewLabelNat
let rosection = Section ReadOnlyData lbl
......@@ -1848,17 +1848,25 @@ genCCall dflags _ (PrimTarget (MO_Memset align)) _
CmmLit (CmmInt c _),
CmmLit (CmmInt n _)]
_
| fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do
| fromInteger insns <= maxInlineMemsetInsns dflags = do
code_dst <- getAnyReg dst
dst_r <- getNewRegNat format
return $ code_dst dst_r `appOL` go dst_r (fromInteger n)
if format == II64 && n >= 8 then do
code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))
imm8byte_r <- getNewRegNat II64
return $ code_dst dst_r `appOL`
code_imm8byte imm8byte_r `appOL`
go8 dst_r imm8byte_r (fromInteger n)
else
return $ code_dst dst_r `appOL`
go4 dst_r (fromInteger n)
where
(format, val) = case align .&. 3 of
2 -> (II16, c2)
0 -> (II32, c4)
_ -> (II8, c)
maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
c2 = c `shiftL` 8 .|. c
c4 = c2 `shiftL` 16 .|. c2
c8 = c4 `shiftL` 32 .|. c4
-- The number of instructions we will generate (approx). We need 1
-- instructions per move.
......@@ -1868,25 +1876,45 @@ genCCall dflags _ (PrimTarget (MO_Memset align)) _
sizeBytes :: Integer
sizeBytes = fromIntegral (formatInBytes format)
go :: Reg -> Integer -> OrdList Instr
go dst i
-- TODO: Add movabs instruction and support 64-bit sets.
| i >= sizeBytes = -- This might be smaller than the below sizes
unitOL (MOV format (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL`
go dst (i - sizeBytes)
| i >= 4 = -- Will never happen on 32-bit
unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL`
go dst (i - 4)
| i >= 2 =
unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL`
go dst (i - 2)
| i >= 1 =
unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL`
go dst (i - 1)
| otherwise = nilOL
-- Depending on size returns the widest MOV instruction and its
-- width.
gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)
gen4 addr size
| size >= 4 =
(unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)
| size >= 2 =
(unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)
| size >= 1 =
(unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)
| otherwise = (nilOL, 0)
-- Generates a 64-bit wide MOV instruction from REG to MEM.
gen8 :: AddrMode -> Reg -> InstrBlock
gen8 addr reg8byte =
unitOL (MOV format (OpReg reg8byte) (OpAddr addr))
-- Unrolls memset when the widest MOV is <= 4 bytes.
go4 :: Reg -> Integer -> InstrBlock
go4 dst left =
if left <= 0 then nilOL
else curMov `appOL` go4 dst (left - curWidth)
where
dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
(ImmInteger (n - i))
possibleWidth = minimum [left, sizeBytes]
dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))
(curMov, curWidth) = gen4 dst_addr possibleWidth
-- Unrolls memset when the widest MOV is 8 bytes (thus another Reg
-- argument). Falls back to go4 when all 8 byte moves are
-- exhausted.
go8 :: Reg -> Reg -> Integer -> InstrBlock
go8 dst reg8byte left =
if possibleWidth >= 8 then
let curMov = gen8 dst_addr reg8byte
in curMov `appOL` go8 dst reg8byte (left - 8)
else go4 dst left
where
possibleWidth = minimum [left, sizeBytes]
dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))
genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL
-- write barrier compiles to no code on x86/x86-64;
......@@ -2322,7 +2350,7 @@ genCCall _ is32Bit target dest_regs args bid = do
let
const | FF32 <- fmt = CmmInt 0x7fffffff W32
| otherwise = CmmInt 0x7fffffffffffffff W64
Amode amode amode_code <- memConstant (widthInBytes w) const
Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const
tmp <- getNewRegNat fmt
let
code dst = x_code dst `appOL` amode_code `appOL` toOL [
......@@ -3051,7 +3079,7 @@ createJumpTable dflags ids section lbl
where blockLabel = blockLbl blockid
in map jumpTableEntryRel ids
| otherwise = map (jumpTableEntry dflags) ids
in CmmData section (1, Statics lbl jumpTable)
in CmmData section (mkAlignment 1, Statics lbl jumpTable)
extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints instrs =
......@@ -3418,7 +3446,7 @@ sse2NegCode w x = do
x@FF80 -> wrongFmt x
where
wrongFmt x = panic $ "sse2NegCode: " ++ show x
Amode amode amode_code <- memConstant (widthInBytes w) const
Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const
tmp <- getNewRegNat fmt
let
code dst = x_code dst `appOL` amode_code `appOL` toOL [
......
......@@ -36,7 +36,7 @@ import PprBase
import Hoopl.Collections
import Hoopl.Label
import BasicTypes (Alignment)
import BasicTypes (Alignment, mkAlignment, alignmentBytes)
import DynFlags
import Cmm hiding (topInfoTable)
import BlockId
......@@ -72,7 +72,7 @@ import Data.Bits
pprProcAlignment :: SDoc
pprProcAlignment = sdocWithDynFlags $ \dflags ->
(maybe empty pprAlign . cmmProcAlignment $ dflags)
(maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags))
pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
pprNatCmmDecl (CmmData section dats) =
......@@ -236,14 +236,15 @@ pprLabel lbl = pprGloblDecl lbl
$$ pprTypeDecl lbl
$$ (ppr lbl <> char ':')
pprAlign :: Int -> SDoc
pprAlign bytes
pprAlign :: Alignment -> SDoc
pprAlign alignment
= sdocWithPlatform $ \platform ->
text ".align " <> int (alignment platform)
text ".align " <> int (alignmentOn platform)
where
alignment platform = if platformOS platform == OSDarwin
then log2 bytes
else bytes
bytes = alignmentBytes alignment
alignmentOn platform = if platformOS platform == OSDarwin
then log2 bytes
else bytes
log2 :: Int -> Int -- cache the common ones
log2 1 = 0
......
......@@ -778,8 +778,8 @@ we aren't using annotations heavily.
************************************************************************
-}
msg :: Severity -> SDoc -> CoreM ()
msg sev doc
msg :: Severity -> WarnReason -> SDoc -> CoreM ()
msg sev reason doc
= do { dflags <- getDynFlags
; loc <- getSrcSpanM
; unqual <- getPrintUnqualified
......@@ -791,7 +791,7 @@ msg sev doc
err_sty = mkErrStyle dflags unqual
user_sty = mkUserStyle dflags unqual AllTheWay
dump_sty = mkDumpStyle dflags unqual
; liftIO $ putLogMsg dflags NoReason sev loc sty doc }
; liftIO $ putLogMsg dflags reason sev loc sty doc }
-- | Output a String message to the screen
putMsgS :: String -> CoreM ()
......@@ -799,7 +799,7 @@ putMsgS = putMsg . text
-- | Output a message to the screen
putMsg :: SDoc -> CoreM ()
putMsg = msg SevInfo
putMsg = msg SevInfo NoReason
-- | Output an error to the screen. Does not cause the compiler to die.
errorMsgS :: String -> CoreM ()
......@@ -807,9 +807,9 @@ errorMsgS = errorMsg . text
-- | Output an error to the screen. Does not cause the compiler to die.
errorMsg :: SDoc -> CoreM ()
errorMsg = msg SevError
errorMsg = msg SevError NoReason
warnMsg :: SDoc -> CoreM ()
warnMsg :: WarnReason -> SDoc -> CoreM ()
warnMsg = msg SevWarning
-- | Output a fatal error to the screen. Does not cause the compiler to die.
......@@ -818,7 +818,7 @@ fatalErrorMsgS = fatalErrorMsg . text
-- | Output a fatal error to the screen. Does not cause the compiler to die.
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg = msg SevFatal
fatalErrorMsg = msg SevFatal NoReason
-- | Output a string debugging message at verbosity level of @-v@ or higher
debugTraceMsgS :: String -> CoreM ()
......@@ -826,7 +826,7 @@ debugTraceMsgS = debugTraceMsg . text
-- | Outputs a debugging message at verbosity level of @-v@ or higher
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg = msg SevDump
debugTraceMsg = msg SevDump NoReason
-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
......
......@@ -730,28 +730,35 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn
; return (rules2 ++ rules1, final_binds) }
| warnMissingSpecs dflags callers
= do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))
2 (vcat [ text "when specialising" <+> quotes (ppr caller)
| caller <- callers])
, whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
, text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
; return ([], []) }
| otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn
; return ([], [])}
| otherwise
= return ([], [])
where
unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers
warnMissingSpecs :: DynFlags -> [Id] -> Bool
-- | Returns whether or not to show a missed-spec warning.
-- If -Wall-missed-specializations is on, show the warning.
-- Otherwise, if -Wmissed-specializations is on, only show a warning
-- if there is at least one imported function being specialized,
-- and if all imported functions are marked with an inline pragma
-- Use the most specific warning as the reason.
tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
-- See Note [Warning about missed specialisations]
warnMissingSpecs dflags callers
| wopt Opt_WarnAllMissedSpecs dflags = True
| not (wopt Opt_WarnMissedSpecs dflags) = False
| null callers = False
| otherwise = all has_inline_prag callers
tryWarnMissingSpecs dflags callers fn calls_for_fn
| wopt Opt_WarnMissedSpecs dflags
&& not (null callers)
&& allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs
| wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs
| otherwise = return ()
where
has_inline_prag id = isAnyInlinePragma (idInlinePragma id)
allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
doWarn reason =
warnMsg reason
(vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
2 (vcat [ text "when specialising" <+> quotes (ppr caller)
| caller <- callers])
, whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
, text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
wantSpecImport :: DynFlags -> Unfolding -> Bool
-- See Note [Specialise imported INLINABLE things]
......