[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Clean up "Eta reduction for data families" Notes
Marge Bot
gitlab at gitlab.haskell.org
Wed Apr 1 05:53:05 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9b39f2e6 by Ryan Scott at 2020-04-01T01:20:00-04:00
Clean up "Eta reduction for data families" Notes
Before, there were two distinct Notes named
"Eta reduction for data families". This renames one of them to
"Implementing eta reduction for data families" to disambiguate the
two and fixes references in other parts of the codebase to ensure
that they are pointing to the right place.
Fixes #17313.
[ci skip]
- - - - -
7627eab5 by Ryan Scott at 2020-04-01T01:20:38-04:00
Fix the changelog/@since information for hGetContents'/getContents'/readFile'
Fixes #17979.
[ci skip]
- - - - -
0002db1b by Sylvain Henry at 2020-04-01T01:21:27-04:00
Kill wORDS_BIGENDIAN and replace it with platformByteOrder (#17957)
Metric Decrease:
T13035
T1969
- - - - -
856b624c by Sebastian Graf at 2020-04-01T01:52:54-04:00
PmCheck: Adjust recursion depth for inhabitation test
In #17977, we ran into the reduction depth limit of the typechecker.
That was only a symptom of a much broader issue: The recursion depth
of the coverage checker for trying to instantiate strict fields in the
`nonVoid` test was far too high (100, the `defaultMaxTcBound`).
As a result, we were performing quite poorly on `T17977`.
Short of a proper termination analysis to prove emptyness of a type,
we just arbitrarily default to a much lower recursion limit of 3.
Fixes #17977.
- - - - -
ecdc6599 by Andreas Klebinger at 2020-04-01T01:52:54-04:00
Make hadrian pass on the no-colour setting to GHC.
Fixes #17983.
- - - - -
30 changed files:
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/HsToCore/PmCheck/Oracle.hs
- compiler/GHC/Llvm/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/typecheck/TcDeriv.hs
- compiler/typecheck/TcInstDcls.hs
- compiler/typecheck/TcSplice.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/system.config.in
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/Ghc.hs
- includes/ghc.mk
- libraries/base/GHC/IO/Handle/Text.hs
- libraries/base/System/IO.hs
- libraries/base/changelog.md
- libraries/ghc-boot/GHC/Platform.hs
- libraries/ghc-boot/GHC/Settings.hs
- mk/config.mk.in
- + testsuite/tests/pmcheck/should_compile/T17977.hs
- + testsuite/tests/pmcheck/should_compile/T17977b.hs
- + testsuite/tests/pmcheck/should_compile/T17977b.stderr
- testsuite/tests/pmcheck/should_compile/all.T
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -206,7 +206,7 @@ mkInfoTableContents dflags
; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep
- = do { let layout = packIntsCLit dflags ptrs nonptrs
+ = do { let layout = packIntsCLit platform ptrs nonptrs
; (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
@@ -238,14 +238,14 @@ mkInfoTableContents dflags
-- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
- = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
+ = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label
; return (Nothing, Nothing, extra_bits, []) }
mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
= do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
; let fun_type | null liveness_data = aRG_GEN
| otherwise = aRG_GEN_BIG
- extra_bits = [ packIntsCLit dflags fun_type arity ]
+ extra_bits = [ packIntsCLit platform fun_type arity ]
++ (if inlineSRT dflags then [] else [ srt_lit ])
++ [ liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
@@ -259,11 +259,10 @@ mkInfoTableContents dflags
mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
-packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
-packIntsCLit dflags a b = packHalfWordsCLit dflags
+packIntsCLit :: Platform -> Int -> Int -> CmmLit
+packIntsCLit platform a b = packHalfWordsCLit platform
(toStgHalfWord platform (fromIntegral a))
(toStgHalfWord platform (fromIntegral b))
- where platform = targetPlatform dflags
mkSRTLit :: DynFlags
=====================================
compiler/GHC/Cmm/Utils.hs
=====================================
@@ -225,19 +225,18 @@ mkRODataLits lbl lits
mkStgWordCLit :: Platform -> StgWord -> CmmLit
mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
-packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
+packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit
-- Make a single word literal in which the lower_half_word is
-- at the lower address, and the upper_half_word is at the
-- higher address
-- ToDo: consider using half-word lits instead
-- but be careful: that's vulnerable when reversed
-packHalfWordsCLit dflags lower_half_word upper_half_word
- = if wORDS_BIGENDIAN dflags
- then mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
- else mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
+packHalfWordsCLit platform lower_half_word upper_half_word
+ = case platformByteOrder platform of
+ BigEndian -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
+ LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
where l = fromStgHalfWord lower_half_word
u = fromStgHalfWord upper_half_word
- platform = targetPlatform dflags
---------------------------------------------------
--
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -520,41 +520,41 @@ pprStatics dflags = pprStatics'
(CmmStaticLit (CmmFloat f W32) : rest)
-- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
| wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
- -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest'
+ -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest'
-- adjacent floats aren't padded but combined into a single word
| wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest
- -> pprLit1 dflags (floatPairToWord dflags f g) : pprStatics' rest'
+ -> pprLit1 dflags (floatPairToWord platform f g) : pprStatics' rest'
| wordWidth platform == W32
- -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest
+ -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest
| otherwise
-> pprPanic "pprStatics: float" (vcat (map ppr' rest))
where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)
ppr' _other = text "bad static!"
(CmmStaticLit (CmmFloat f W64) : rest)
- -> map (pprLit1 dflags) (doubleToWords dflags f) ++ pprStatics' rest
+ -> map (pprLit1 dflags) (doubleToWords platform f) ++ pprStatics' rest
(CmmStaticLit (CmmInt i W64) : rest)
| wordWidth platform == W32
- -> if wORDS_BIGENDIAN dflags
- then pprStatics' (CmmStaticLit (CmmInt q W32) :
- CmmStaticLit (CmmInt r W32) : rest)
- else pprStatics' (CmmStaticLit (CmmInt r W32) :
- CmmStaticLit (CmmInt q W32) : rest)
+ -> case platformByteOrder platform of
+ BigEndian -> pprStatics' (CmmStaticLit (CmmInt q W32) :
+ CmmStaticLit (CmmInt r W32) : rest)
+ LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) :
+ CmmStaticLit (CmmInt q W32) : rest)
where r = i .&. 0xffffffff
q = i `shiftR` 32
(CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)
| wordWidth platform == W64
- -> if wORDS_BIGENDIAN dflags
- then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)
- else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)
+ -> case platformByteOrder platform of
+ BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)
+ LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)
(CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)
| wordWidth platform == W32
- -> if wORDS_BIGENDIAN dflags
- then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)
- else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)
+ -> case platformByteOrder platform of
+ BigEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)
+ LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)
(CmmStaticLit (CmmInt _ w) : _)
| w /= wordWidth platform
@@ -1271,8 +1271,8 @@ castFloatToWord32Array = U.castSTUArray
castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
castDoubleToWord64Array = U.castSTUArray
-floatToWord :: DynFlags -> Rational -> CmmLit
-floatToWord dflags r
+floatToWord :: Platform -> Rational -> CmmLit
+floatToWord platform r
= runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 (fromRational r)
@@ -1281,12 +1281,13 @@ floatToWord dflags r
return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))
)
where wo | wordWidth platform == W64
- , wORDS_BIGENDIAN dflags = 32
- | otherwise = 0
- platform = targetPlatform dflags
+ , BigEndian <- platformByteOrder platform
+ = 32
+ | otherwise
+ = 0
-floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit
-floatPairToWord dflags r1 r2
+floatPairToWord :: Platform -> Rational -> Rational -> CmmLit
+floatPairToWord platform r1 r2
= runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 (fromRational r1)
@@ -1297,15 +1298,15 @@ floatPairToWord dflags r1 r2
return (pprWord32Pair w32_1 w32_2)
)
where pprWord32Pair w32_1 w32_2
- | wORDS_BIGENDIAN dflags =
+ | BigEndian <- platformByteOrder platform =
CmmInt ((shiftL i1 32) .|. i2) W64
| otherwise =
CmmInt ((shiftL i2 32) .|. i1) W64
where i1 = toInteger w32_1
i2 = toInteger w32_2
-doubleToWords :: DynFlags -> Rational -> [CmmLit]
-doubleToWords dflags r
+doubleToWords :: Platform -> Rational -> [CmmLit]
+doubleToWords platform r
= runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 (fromRational r)
@@ -1314,8 +1315,6 @@ doubleToWords dflags r
return (pprWord64 w64)
)
where targetWidth = wordWidth platform
- platform = targetPlatform dflags
- targetBE = wORDS_BIGENDIAN dflags
pprWord64 w64
| targetWidth == W64 =
[ CmmInt (toInteger w64) targetWidth ]
@@ -1324,9 +1323,9 @@ doubleToWords dflags r
, CmmInt (toInteger targetW2) targetWidth
]
| otherwise = panic "doubleToWords.pprWord64"
- where (targetW1, targetW2)
- | targetBE = (wHi, wLo)
- | otherwise = (wLo, wHi)
+ where (targetW1, targetW2) = case platformByteOrder platform of
+ BigEndian -> (wHi, wLo)
+ LittleEndian -> (wLo, wHi)
wHi = w64 `shiftR` 32
wLo = w64 .&. 0xFFFFffff
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -245,7 +245,7 @@ ppr_co_ax_branch ppr_rhs fam_tc branch
-- Eta-expand LHS and RHS types, because sometimes data family
-- instances are eta-reduced.
- -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv.
+ -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.
(ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch
pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -235,7 +235,7 @@ data CoAxBranch
, cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh
, cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars
-- See Note [CoAxBranch type variables]
- -- cab_tvs and cab_lhs may be eta-reduded; see
+ -- cab_tvs and cab_lhs may be eta-reduced; see
-- Note [Eta reduction for data families]
, cab_cvs :: [CoVar] -- Bound coercion variables
-- Always empty, for now.
@@ -443,9 +443,13 @@ looked like
(See #9692, #14179, and #15845 for examples of what can go wrong if
we don't eta-expand when showing things to the user.)
-(See also Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate
-and deals with the axiom connecting a newtype with its representation
-type; but it too is eta-reduced.)
+See also:
+
+* Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate
+ and deals with the axiom connecting a newtype with its representation
+ type; but it too is eta-reduced.
+* Note [Implementing eta reduction for data families] in TcInstDcls. This
+ describes the implementation details of this eta reduction happen.
-}
instance Eq (CoAxiom br) where
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -118,6 +118,7 @@ data FamInst -- See Note [FamInsts and CoAxioms]
, fi_tys :: [Type] -- The LHS type patterns
-- May be eta-reduced; see Note [Eta reduction for data families]
+ -- in GHC.Core.Coercion.Axiom
, fi_rhs :: Type -- the RHS, with its freshened vars
}
@@ -132,7 +133,8 @@ Note [Arity of data families]
Data family instances might legitimately be over- or under-saturated.
Under-saturation has two potential causes:
- U1) Eta reduction. See Note [Eta reduction for data families].
+ U1) Eta reduction. See Note [Eta reduction for data families] in
+ GHC.Core.Coercion.Axiom.
U2) When the user has specified a return kind instead of written out patterns.
Example:
@@ -160,8 +162,8 @@ Over-saturation is also possible:
However, we require that any over-saturation is eta-reducible. That is,
we require that any extra patterns be bare unrepeated type variables;
- see Note [Eta reduction for data families]. Accordingly, the FamInst
- is never over-saturated.
+ see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.
+ Accordingly, the FamInst is never over-saturated.
Why can we allow such flexibility for data families but not for type families?
Because data families can be decomposed -- that is, they are generative and
@@ -335,7 +337,7 @@ Then we get a data type for each instance, and an axiom:
axiom ax8 a :: T Bool [a] ~ TBoolList a
These two axioms for T, one with one pattern, one with two;
-see Note [Eta reduction for data families]
+see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
Note [FamInstEnv determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -479,7 +481,7 @@ irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).
Note [Compatibility of eta-reduced axioms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In newtype instances of data families we eta-reduce the axioms,
-See Note [Eta reduction for data families] in GHC.Core.FamInstEnv. This means that
+See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. This means that
we sometimes need to test compatibility of two axioms that were eta-reduced to
different degrees, e.g.:
@@ -1057,7 +1059,7 @@ We handle data families and type families separately here:
* For data family instances, though, we need to re-split for each
instance, because the breakdown might be different for each
instance. Why? Because of eta reduction; see
- Note [Eta reduction for data families].
+ Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.
-}
-- checks if one LHS is dominated by a list of other branches
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -240,7 +240,7 @@ See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make
DataFamInstTyCon T [Int] ax_ti
* The axiom ax_ti may be eta-reduced; see
- Note [Eta reduction for data families] in GHC.Core.FamInstEnv
+ Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
* Data family instances may have a different arity than the data family.
See Note [Arity of data families] in GHC.Core.FamInstEnv
@@ -1100,8 +1100,9 @@ data AlgTyConFlav
-- and R:T is the representation TyCon (ie this one)
-- and a,b,c are the tyConTyVars of this TyCon
--
- -- BUT may be eta-reduced; see FamInstEnv
- -- Note [Eta reduction for data families]
+ -- BUT may be eta-reduced; see
+ -- Note [Eta reduction for data families] in
+ -- GHC.Core.Coercion.Axiom
-- Cached fields of the CoAxiom, but adjusted to
-- use the tyConTyVars of this TyCon
=====================================
compiler/GHC/HsToCore/PmCheck/Oracle.hs
=====================================
@@ -1319,10 +1319,11 @@ checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> DsM Bool
checkAllNonVoid rec_ts amb_cs strict_arg_tys = do
let definitely_inhabited = definitelyInhabitedType (delta_ty_st amb_cs)
tys_to_check <- filterOutM definitely_inhabited strict_arg_tys
+ -- See Note [Fuel for the inhabitation test]
let rec_max_bound | tys_to_check `lengthExceeds` 1
= 1
| otherwise
- = defaultRecTcMaxBound
+ = 3
rec_ts' = setRecTcMaxBound rec_max_bound rec_ts
allM (nonVoid rec_ts' amb_cs) tys_to_check
@@ -1342,6 +1343,7 @@ nonVoid rec_ts amb_cs strict_arg_ty = do
mb_cands <- inhabitationCandidates amb_cs strict_arg_ty
case mb_cands of
Right (tc, _, cands)
+ -- See Note [Fuel for the inhabitation test]
| Just rec_ts' <- checkRecTc rec_ts tc
-> anyM (cand_is_inhabitable rec_ts' amb_cs) cands
-- A strict argument type is inhabitable by a terminating value if
@@ -1390,7 +1392,7 @@ definitelyInhabitedType ty_st ty = do
null (dataConImplBangs con) -- (2)
{- Note [Strict argument type constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the ConVar case of clause processing, each conlike K traditionally
generates two different forms of constraints:
@@ -1420,6 +1422,7 @@ say, `K2 undefined` or `K2 (let x = x in x)`.)
Since neither the term nor type constraints mentioned above take strict
argument types into account, we make use of the `nonVoid` function to
determine whether a strict type is inhabitable by a terminating value or not.
+We call this the "inhabitation test".
`nonVoid ty` returns True when either:
1. `ty` has at least one InhabitationCandidate for which both its term and type
@@ -1445,15 +1448,20 @@ determine whether a strict type is inhabitable by a terminating value or not.
`nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid
constructor contains Void as a strict argument type, and since `nonVoid Void`
returns False, that InhabitationCandidate is discarded, leaving no others.
+* Whether or not a type is inhabited is undecidable in general.
+ See Note [Fuel for the inhabitation test].
+* For some types, inhabitation is evident immediately and we don't need to
+ perform expensive tests. See Note [Types that are definitely inhabitable].
-* Performance considerations
+Note [Fuel for the inhabitation test]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whether or not a type is inhabited is undecidable in general. As a result, we
+can run into infinite loops in `nonVoid`. Therefore, we adopt a fuel-based
+approach to prevent that.
-We must be careful when recursively calling `nonVoid` on the strict argument
-types of an InhabitationCandidate, because doing so naïvely can cause GHC to
-fall into an infinite loop. Consider the following example:
+Consider the following example:
data Abyss = MkAbyss !Abyss
-
stareIntoTheAbyss :: Abyss -> a
stareIntoTheAbyss x = case x of {}
@@ -1474,7 +1482,6 @@ stareIntoTheAbyss above. Then again, the same problem occurs with recursive
newtypes, like in the following code:
newtype Chasm = MkChasm Chasm
-
gazeIntoTheChasm :: Chasm -> a
gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive
@@ -1498,9 +1505,26 @@ maximum recursion depth to 1 to mitigate the problem. If the branching factor
is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay
to stick with a larger maximum recursion depth.
+In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was
+too large and had detrimental effect on performance of the coverage checker.
+Given that we only commit to a best effort anyway, we decided to substantially
+decrement the recursion depth to 3, at the cost of precision in some edge cases
+like
+
+ data Nat = Z | S Nat
+ data Down :: Nat -> Type where
+ Down :: !(Down n) -> Down (S n)
+ f :: Down (S (S (S (S (S Z))))) -> ()
+ f x = case x of {}
+
+Since the coverage won't bother to instantiate Down 4 levels deep to see that it
+is in fact uninhabited, it will emit a inexhaustivity warning for the case.
+
+Note [Types that are definitely inhabitable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Another microoptimization applies to data types like this one:
- data S a = ![a] !T
+ data S a = S ![a] !T
Even though there is a strict field of type [a], it's quite silly to call
nonVoid on it, since it's "obvious" that it is inhabitable. To make this
=====================================
compiler/GHC/Llvm/Types.hs
=====================================
@@ -225,26 +225,26 @@ ppPlainName (LMLitVar x ) = ppLit x
-- | Print a literal value. No type.
ppLit :: LlvmLit -> SDoc
-ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32)
-ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64)
-ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int)
-ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r
-ppLit (LMFloatLit r LMDouble) = ppDouble r
-ppLit f@(LMFloatLit _ _) = pprPanic "ppLit" (text "Can't print this float literal: " <> ppr f)
-ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>'
-ppLit (LMNullLit _ ) = text "null"
--- #11487 was an issue where we passed undef for some arguments
--- that were actually live. By chance the registers holding those
--- arguments usually happened to have the right values anyways, but
--- that was not guaranteed. To find such bugs reliably, we set the
--- flag below when validating, which replaces undef literals (at
--- common types) with values that are likely to cause a crash or test
--- failure.
-ppLit (LMUndefLit t ) = sdocWithDynFlags f
- where f dflags
- | gopt Opt_LlvmFillUndefWithGarbage dflags,
- Just lit <- garbageLit t = ppLit lit
- | otherwise = text "undef"
+ppLit l = sdocWithDynFlags $ \dflags -> case l of
+ (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32)
+ (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64)
+ (LMIntLit i _ ) -> ppr ((fromInteger i)::Int)
+ (LMFloatLit r LMFloat ) -> ppFloat (targetPlatform dflags) $ narrowFp r
+ (LMFloatLit r LMDouble) -> ppDouble (targetPlatform dflags) r
+ f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppr f)
+ (LMVectorLit ls ) -> char '<' <+> ppCommaJoin ls <+> char '>'
+ (LMNullLit _ ) -> text "null"
+ -- #11487 was an issue where we passed undef for some arguments
+ -- that were actually live. By chance the registers holding those
+ -- arguments usually happened to have the right values anyways, but
+ -- that was not guaranteed. To find such bugs reliably, we set the
+ -- flag below when validating, which replaces undef literals (at
+ -- common types) with values that are likely to cause a crash or test
+ -- failure.
+ (LMUndefLit t )
+ | gopt Opt_LlvmFillUndefWithGarbage dflags
+ , Just lit <- garbageLit t -> ppLit lit
+ | otherwise -> text "undef"
garbageLit :: LlvmType -> Maybe LlvmLit
garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
@@ -836,19 +836,20 @@ instance Outputable LlvmCastOp where
-- regardless of underlying architecture.
--
-- See Note [LLVM Float Types].
-ppDouble :: Double -> SDoc
-ppDouble d
+ppDouble :: Platform -> Double -> SDoc
+ppDouble platform d
= let bs = doubleToBytes d
hex d' = case showHex d' "" of
- [] -> error "dToStr: too few hex digits for float"
- [x] -> ['0',x]
- [x,y] -> [x,y]
- _ -> error "dToStr: too many hex digits for float"
+ [] -> error "ppDouble: too few hex digits for float"
+ [x] -> ['0',x]
+ [x,y] -> [x,y]
+ _ -> error "ppDouble: too many hex digits for float"
- in sdocWithDynFlags (\dflags ->
- let fixEndian = if wORDS_BIGENDIAN dflags then id else reverse
- str = map toUpper $ concat $ fixEndian $ map hex bs
- in text "0x" <> text str)
+ fixEndian = case platformByteOrder platform of
+ BigEndian -> id
+ LittleEndian -> reverse
+ str = map toUpper $ concat $ fixEndian $ map hex bs
+ in text "0x" <> text str
-- Note [LLVM Float Types]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -875,8 +876,8 @@ widenFp :: Float -> Double
{-# NOINLINE widenFp #-}
widenFp = float2Double
-ppFloat :: Float -> SDoc
-ppFloat = ppDouble . widenFp
+ppFloat :: Platform -> Float -> SDoc
+ppFloat platform = ppDouble platform . widenFp
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -865,10 +865,9 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
-- This is a bit involved since we allow packing multiple fields
-- within a single word. See also
-- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding
- dflags <- getDynFlags
- let platform = targetPlatform dflags
- word_size = platformWordSizeInBytes platform
- big_endian = wORDS_BIGENDIAN dflags
+ platform <- targetPlatform <$> getDynFlags
+ let word_size = platformWordSizeInBytes platform
+ endian = platformByteOrder platform
size_b = primRepSizeB platform rep
-- Align the start offset (eg, 2-byte value should be 2-byte
-- aligned). But not more than to a word. The offset calculation
@@ -877,7 +876,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
!aligned_idx = roundUpTo arr_i (min word_size size_b)
!new_arr_i = aligned_idx + size_b
ws | size_b < word_size =
- [index size_b aligned_idx word_size big_endian]
+ [index size_b aligned_idx word_size endian]
| otherwise =
let (q, r) = size_b `quotRem` word_size
in ASSERT( r == 0 )
@@ -892,7 +891,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
(error "unboxedTupleTerm: no HValue for unboxed tuple") terms
-- Extract a sub-word sized field from a word
- index item_size_b index_b word_size big_endian =
+ index item_size_b index_b word_size endian =
(word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
where
mask :: Word
@@ -903,9 +902,9 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
_ -> panic ("Weird byte-index: " ++ show index_b)
(q,r) = index_b `quotRem` word_size
word = array!!q
- moveBytes = if big_endian
- then word_size - (r + item_size_b) * 8
- else r * 8
+ moveBytes = case endian of
+ BigEndian -> word_size - (r + item_size_b) * 8
+ LittleEndian -> r * 8
-- | Fast, breadth-first Type reconstruction
=====================================
compiler/typecheck/TcDeriv.hs
=====================================
@@ -1312,7 +1312,7 @@ write it out
return x = MkT [x]
... etc ...
-See Note [Eta reduction for data families] in GHC.Core.FamInstEnv
+See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
%************************************************************************
%* *
=====================================
compiler/typecheck/TcInstDcls.hs
=====================================
@@ -667,7 +667,7 @@ tcDataFamInstDecl mb_clsinfo
new_or_data
-- Eta-reduce the axiom if possible
- -- Quite tricky: see Note [Eta-reduction for data families]
+ -- Quite tricky: see Note [Implementing eta reduction for data families]
; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats
eta_tvs = map binderVar eta_tcbs
post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs
@@ -761,7 +761,7 @@ tcDataFamInstDecl mb_clsinfo
; return (fam_inst, m_deriv_info) }
where
eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
- -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv
+ -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
-- Splits the incoming patterns into two: the [TyVar]
-- are the patterns that can be eta-reduced away.
-- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c])
@@ -887,8 +887,8 @@ we actually have a place to put the regeneralised variables.
Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise
Examples in indexed-types/should_compile/T12369
-Note [Eta-reduction for data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Implementing eta reduction for data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data D :: * -> * -> * -> * -> *
@@ -906,7 +906,10 @@ and an axiom to connect them
except that we'll eta-reduce the axiom to
axiom AxDrep forall a b. D [(a,b]] = Drep a b
-There are several fiddly subtleties lurking here
+
+This is described at some length in Note [Eta reduction for data families]
+in GHC.Core.Coercion.Axiom. There are several fiddly subtleties lurking here,
+however, so this Note aims to describe these subtleties:
* The representation tycon Drep is parameterised over the free
variables of the pattern, in no particular order. So there is no
=====================================
compiler/typecheck/TcSplice.hs
=====================================
@@ -2046,7 +2046,7 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
DataFamilyInst rep_tc ->
do { let -- eta-expand lhs types, because sometimes data/newtype
-- instances are eta-reduced; See #9692
- -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv
+ -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
(ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
fam' = reifyName fam
dataCons = tyConDataCons rep_tc
=====================================
configure.ac
=====================================
@@ -952,6 +952,10 @@ else
AC_SUBST([Cabal64bit],[False])
fi
AC_SUBST(TargetWordSize)
+
+AC_C_BIGENDIAN([TargetWordBigEndian=YES],[TargetWordBigEndian=NO])
+AC_SUBST(TargetWordBigEndian)
+
FP_CHECK_FUNC([WinExec],
[@%:@include <windows.h>], [WinExec("",0)])
=====================================
distrib/configure.ac.in
=====================================
@@ -177,6 +177,17 @@ fi
TargetWordSize=$ac_cv_sizeof_void_p
AC_SUBST(TargetWordSize)
+dnl TargetWordBigEndian for settings file
+AC_C_BIGENDIAN([TargetWordBigEndian=YES],[TargetWordBigEndian=NO])
+dnl Check that the toolchain we have is consistent with what the compiler expects
+if test "x$TargetWordBigEndian" != "x at TargetWordBigEndian@"; then
+ AC_MSG_ERROR([This binary distribution produces binaries for a target with
+ a different byte order than your target toolchain.
+ Are you sure your toolchain targets the intended target platform
+ of this compiler?])
+fi
+AC_SUBST(TargetWordBigEndian)
+
#
dnl ** how to invoke `ar' and `ranlib'
#
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -146,6 +146,7 @@ settings-llc-command = @SettingsLlcCommand@
settings-opt-command = @SettingsOptCommand@
target-word-size = @TargetWordSize@
+target-word-big-endian = @TargetWordBigEndian@
target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@
target-has-ident-directive = @TargetHasIdentDirective@
target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -301,6 +301,7 @@ generateSettings = do
, ("target os", getSetting TargetOsHaskell)
, ("target arch", getSetting TargetArchHaskell)
, ("target word size", expr $ lookupValueOrError configFile "target-word-size")
+ , ("target word big endian", expr $ lookupValueOrError configFile "target-word-big-endian")
, ("target has GNU nonexec stack", expr $ lookupValueOrError configFile "target-has-gnu-nonexec-stack")
, ("target has .ident directive", expr $ lookupValueOrError configFile "target-has-ident-directive")
, ("target has subsections via symbols", expr $ lookupValueOrError configFile "target-has-subsections-via-symbols")
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -29,9 +29,12 @@ toolArgs = do
compileAndLinkHs :: Args
compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
ways <- getLibraryWays
+ useColor <- shakeColor <$> expr getShakeOptions
let hasVanilla = elem vanilla ways
hasDynamic = elem dynamic ways
mconcat [ arg "-Wall"
+ , not useColor ? builder (Ghc CompileHs) ?
+ arg "-fdiagnostics-color=never"
, (hasVanilla && hasDynamic) ? builder (Ghc CompileHs) ?
platformSupportsSharedLibs ? way vanilla ?
arg "-dynamic-too"
=====================================
includes/ghc.mk
=====================================
@@ -236,6 +236,7 @@ $(includes_SETTINGS) : includes/Makefile | $$(dir $$@)/.
@echo ',("target os", "$(HaskellTargetOs)")' >> $@
@echo ',("target arch", "$(HaskellTargetArch)")' >> $@
@echo ',("target word size", "$(TargetWordSize)")' >> $@
+ @echo ',("target word big endian", "$(TargetWordBigEndian)")' >> $@
@echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@
@echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@
@echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@
=====================================
libraries/base/GHC/IO/Handle/Text.hs
=====================================
@@ -466,7 +466,7 @@ getSomeCharacters handle_ at Handle__{..} buf at Buffer{..} =
-- | The 'hGetContents'' operation reads all input on the given handle
-- before returning it as a 'String' and closing the handle.
--
--- @since 4.14.0.0
+-- @since 4.15.0.0
hGetContents' :: Handle -> IO String
hGetContents' handle = do
=====================================
libraries/base/System/IO.hs
=====================================
@@ -312,7 +312,7 @@ getContents = hGetContents stdin
-- which is fully read before being returned
-- (same as 'hGetContents'' 'stdin').
--
--- @since 4.14.0.0
+-- @since 4.15.0.0
getContents' :: IO String
getContents' = hGetContents' stdin
@@ -337,7 +337,7 @@ readFile name = openFile name ReadMode >>= hGetContents
-- returns the contents of the file as a string.
-- The file is fully read before being returned, as with 'getContents''.
--
--- @since 4.14.0.0
+-- @since 4.15.0.0
readFile' :: FilePath -> IO String
readFile' name = openFile name ReadMode >>= hGetContents'
=====================================
libraries/base/changelog.md
=====================================
@@ -6,6 +6,9 @@
call, ensuring that the call can be interrupted with `SIGINT` on POSIX
systems.
+ * Add `hGetContents'`, `getContents'`, and `readFile'` in `System.IO`:
+ Strict IO variants of `hGetContents`, `getContents`, and `readFile`.
+
## 4.14.0.0 *TBA*
* Bundled with GHC 8.10.1
@@ -51,9 +54,6 @@
* Add `IsList` instance for `ZipList`.
- * Add `hGetContents'`, `getContents'`, and `readFile'` in `System.IO`:
- Strict IO variants of `hGetContents`, `getContents`, and `readFile`.
-
## 4.13.0.0 *July 2019*
* Bundled with GHC 8.8.1
=====================================
libraries/ghc-boot/GHC/Platform.hs
=====================================
@@ -12,6 +12,7 @@ module GHC.Platform (
ArmISAExt(..),
ArmABI(..),
PPC_64ABI(..),
+ ByteOrder(..),
target32Bit,
isARM,
@@ -38,6 +39,7 @@ where
import Prelude -- See Note [Why do we import Prelude here?]
import GHC.Read
+import GHC.ByteOrder (ByteOrder(..))
import Data.Word
import Data.Int
@@ -53,19 +55,17 @@ data PlatformMini
-- | Contains enough information for the native code generator to emit
-- code for this platform.
-data Platform
- = Platform {
- platformMini :: PlatformMini,
- -- Word size in bytes (i.e. normally 4 or 8,
- -- for 32bit and 64bit platforms respectively)
- platformWordSize :: PlatformWordSize,
- platformUnregisterised :: Bool,
- platformHasGnuNonexecStack :: Bool,
- platformHasIdentDirective :: Bool,
- platformHasSubsectionsViaSymbols :: Bool,
- platformIsCrossCompiling :: Bool
- }
- deriving (Read, Show, Eq)
+data Platform = Platform
+ { platformMini :: PlatformMini
+ , platformWordSize :: PlatformWordSize
+ , platformByteOrder :: ByteOrder
+ , platformUnregisterised :: Bool
+ , platformHasGnuNonexecStack :: Bool
+ , platformHasIdentDirective :: Bool
+ , platformHasSubsectionsViaSymbols :: Bool
+ , platformIsCrossCompiling :: Bool
+ }
+ deriving (Read, Show, Eq)
data PlatformWordSize
= PW4 -- ^ A 32-bit platform
=====================================
libraries/ghc-boot/GHC/Settings.hs
=====================================
@@ -36,6 +36,7 @@ getTargetPlatform settingsFile mySettings = do
targetArch <- readSetting "target arch"
targetOS <- readSetting "target os"
targetWordSize <- readSetting "target word size"
+ targetWordBigEndian <- getBooleanSetting "target word big endian"
targetUnregisterised <- getBooleanSetting "Unregisterised"
targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"
targetHasIdentDirective <- getBooleanSetting "target has .ident directive"
@@ -48,6 +49,7 @@ getTargetPlatform settingsFile mySettings = do
, platformMini_os = targetOS
}
, platformWordSize = targetWordSize
+ , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian
, platformUnregisterised = targetUnregisterised
, platformHasGnuNonexecStack = targetHasGnuNonexecStack
, platformHasIdentDirective = targetHasIdentDirective
=====================================
mk/config.mk.in
=====================================
@@ -494,6 +494,7 @@ HaskellHostArch = @HaskellHostArch@
HaskellTargetOs = @HaskellTargetOs@
HaskellTargetArch = @HaskellTargetArch@
TargetWordSize = @TargetWordSize@
+TargetWordBigEndian = @TargetWordBigEndian@
TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@
TargetHasIdentDirective = @TargetHasIdentDirective@
TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@
=====================================
testsuite/tests/pmcheck/should_compile/T17977.hs
=====================================
@@ -0,0 +1,33 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Bug where
+
+import Data.Kind
+import Data.Type.Equality
+
+data Nat = Z | S Nat
+
+data SNat :: Nat -> Type where
+ SZ :: SNat Z
+ SS :: SNat n -> SNat (S n)
+
+type family S' (n :: Nat) :: Nat where
+ S' n = S n
+
+data R :: Nat -> Nat -> Nat -> Type where
+ MkR :: !(R m n o) -> R (S m) n (S o)
+
+type family NatPlus (m :: Nat) (n :: Nat) :: Nat where
+ NatPlus Z n = n
+ NatPlus (S m) n = S' (NatPlus m n)
+
+f :: forall (m :: Nat) (n :: Nat) (o :: Nat).
+ SNat m -> SNat n -> SNat o
+ -> R m n o -> NatPlus m n :~: o
+f (SS sm) sn (SS so) (MkR r)
+ | Refl <- f sm sn so r
+ = Refl
=====================================
testsuite/tests/pmcheck/should_compile/T17977b.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE EmptyCase #-}
+module Bug where
+
+import Data.Kind
+
+data Nat = Z | S Nat
+
+data Down :: Nat -> Type where
+ Down :: !(Down n) -> Down (S n)
+
+data Up :: Nat -> Type where
+ Up :: !(Up (S n)) -> Up n
+
+f :: Down n -> ()
+f (Down r) = ()
+
+f' :: Down (S (S (S (S Z)))) -> ()
+f' (Down r) = ()
+
+g :: Up n -> ()
+g (Up r) = ()
=====================================
testsuite/tests/pmcheck/should_compile/T17977b.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T17977b.hs:21:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘f'’: f' (Down r) = ...
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -114,6 +114,10 @@ test('T17703', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T17783', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17977', collect_compiler_stats('bytes allocated',10), compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T17977b', collect_compiler_stats('bytes allocated',10), compile,
+ ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
# Other tests
test('pmc001', [], compile,
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -672,7 +672,6 @@ wanteds os = concat
-- Amount of pointer bits used for semi-tagging constructor closures
,constantWord Haskell "TAG_BITS" "TAG_BITS"
- ,constantBool Haskell "WORDS_BIGENDIAN" "defined(WORDS_BIGENDIAN)"
,constantBool Haskell "DYNAMIC_BY_DEFAULT" "defined(DYNAMIC_BY_DEFAULT)"
,constantWord Haskell "LDV_SHIFT" "LDV_SHIFT"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f54b3e379e712a2f6b1c8a2ccce0d6b7353486d5...ecdc6599d4aacbc8593ef4b415b8bac7dbc789c0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f54b3e379e712a2f6b1c8a2ccce0d6b7353486d5...ecdc6599d4aacbc8593ef4b415b8bac7dbc789c0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200401/8f528a25/attachment-0001.html>
More information about the ghc-commits
mailing list