[Git][ghc/ghc][wip/T25647] 20 commits: interpreter: Always print unit and module name in BCO_NAME instruction
Patrick (@soulomoon)
gitlab at gitlab.haskell.org
Thu Feb 6 14:00:00 UTC 2025
Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC
Commits:
cbbb64fb by Matthew Pickering at 2025-02-03T23:40:33-05:00
interpreter: Always print unit and module name in BCO_NAME instruction
Currently the BCO_Name instruction is a bit difficult to use since the
names are not qualified by the module they come from. When you have a
very generic name such as "wildX4", it becomes impossible to work out
which module the identifier comes from.
Fixes #25694
- - - - -
764a43ac by Ben Gamari at 2025-02-03T23:41:10-05:00
upload-ghc-libs: Drop more references to ghc-internal from ghc-boot-th
(cherry picked from commit afec4b75c2d0e9f5c462a86d9f3697acf30355c7)
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
- - - - -
9a59b026 by Ben Gamari at 2025-02-04T10:00:18-05:00
gitlab-ci: Don't use .full-ci to run test-primops
test-primops depends upon the existence of validate jobs, yet these do
not exist in the context of nightly jobs, which .full-ci includes.
- - - - -
7cc08550 by Ben Gamari at 2025-02-04T18:34:49-05:00
CorePrep: Name `sat` binders more descriptively
- - - - -
fb40981d by Ben Gamari at 2025-02-04T18:35:26-05:00
ghc-toolchain: Parse i686 triples
This is a moniker used for later 32-bit x86 implementations
(Pentium Pro and later).
Fixes #25691.
- - - - -
02794411 by Cheng Shao at 2025-02-04T18:36:03-05:00
compiler: remove unused assembleOneBCO function
This patch removes the unused assembleOneBCO function from the
bytecode assembler.
- - - - -
db19c8a9 by Matthew Pickering at 2025-02-05T23:16:50-05:00
perf: Replace uses of genericLength with strictGenericLength
genericLength is a recursive function and marked NOINLINE. It is not
going to specialise. In profiles, it can be seen that 3% of total compilation
time when computing bytecode is spend calling this non-specialised
function.
In addition, we can simplify `addListToSS` to avoid traversing the input
list twice and also allocating an intermediate list (after the call to
reverse).
Overall these changes reduce the time spend in 'assembleBCOs' from 5.61s
to 3.88s. Allocations drop from 8GB to 5.3G.
Fixes #25706
- - - - -
5622a14a by Matthew Pickering at 2025-02-05T23:17:27-05:00
perf: nameToCLabel: Directly manipulate ByteString rather than going via strings
`nameToCLabel` is called from `lookupHsSymbol` many times during
bytecode linking. We can save a lot of allocations and time by directly
manipulating the bytestrings rather than going via intermediate lists.
Before: 2GB allocation, 1.11s
After: 260MB allocation, 375ms
Fixes #25719
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
-------------------------
- - - - -
d960d879 by Simon Peyton Jones at 2025-02-06T13:59:43+00:00
WIP towards #25267
- - - - -
c7399d43 by Simon Peyton Jones at 2025-02-06T13:59:43+00:00
Wibbles
- - - - -
06fe5c89 by Simon Peyton Jones at 2025-02-06T13:59:43+00:00
Default tyvars in data/newtype insnstances
This is what fixes #25647
- - - - -
dd1e8a1f by Simon Peyton Jones at 2025-02-06T13:59:43+00:00
wibbles
Including fix for #25725
- - - - -
7401f532 by Simon Peyton Jones at 2025-02-06T13:59:43+00:00
Wibble
- - - - -
2a43fc17 by Patrick at 2025-02-06T13:59:43+00:00
add more tests
- - - - -
552684c2 by Patrick at 2025-02-06T13:59:43+00:00
Fix up T25611d with explicit kind annotation
- - - - -
df781af6 by Patrick at 2025-02-06T13:59:43+00:00
fix up T25647_fail
- - - - -
b96f5a99 by Patrick at 2025-02-06T13:59:43+00:00
cleanup whitespace
- - - - -
81aa3efe by Patrick at 2025-02-06T13:59:43+00:00
fix up T23512a
- - - - -
8d3f6768 by Patrick at 2025-02-06T13:59:43+00:00
add more examples to T25647b
- - - - -
af267833 by Patrick at 2025-02-06T13:59:43+00:00
add Dix6 to T25647_fail
- - - - -
28 changed files:
- .gitlab-ci.yml
- .gitlab/rel_eng/upload_ghc_libs.py
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- libraries/ghc-boot/GHC/Data/SizedSeq.hs
- testsuite/tests/core-to-stg/T14895.stderr
- testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/ghci/should_run/T21052.stdout
- testsuite/tests/indexed-types/should_compile/T25611d.hs
- testsuite/tests/rename/should_fail/T23512a.stderr
- testsuite/tests/simplCore/should_compile/T20040.stderr
- testsuite/tests/simplCore/should_compile/T23083.stderr
- testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/simplStg/should_compile/T19717.stderr
- + testsuite/tests/typecheck/should_compile/T25647_fail.hs
- + testsuite/tests/typecheck/should_compile/T25647_fail.stderr
- + testsuite/tests/typecheck/should_compile/T25647a.hs
- + testsuite/tests/typecheck/should_compile/T25647b.hs
- + testsuite/tests/typecheck/should_compile/T25725.hs
- testsuite/tests/typecheck/should_compile/all.T
- utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -909,7 +909,10 @@ test-primops-label:
extends: .test-primops-validate-template
rules:
- if: '$CI_MERGE_REQUEST_LABELS =~ /.*test-primops.*/'
- - *full-ci
+ # We do not use *.full-ci here since that would imply running in nightly
+ # where we do not have the normal validate jobs. We have the -nightly job
+ # below to handle this case.
+ - if: '$CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/'
test-primops-nightly:
extends: .test-primops
=====================================
.gitlab/rel_eng/upload_ghc_libs.py
=====================================
@@ -94,9 +94,23 @@ def prep_ghc():
build_copy_file(PACKAGES['ghc'], 'GHC/Settings/Config.hs')
def prep_ghc_boot_th():
- # Drop ghc-internal from `hs-source-dirs` as Hackage rejects this
+ # Drop references to `ghc-internal` from `hs-source-dirs` as Hackage rejects
+ # out-of-sdist references and this packages is only uploaded for documentation
+ # purposes.
modify_file(PACKAGES['ghc-boot-th'], 'ghc-boot-th.cabal',
- lambda s: s.replace('../ghc-internal/src', ''))
+ lambda s: s.replace('../ghc-internal/src', '')
+ .replace('GHC.Internal.TH.Lib.Map', '')
+ .replace('GHC.Internal.TH.PprLib', '')
+ .replace('GHC.Internal.TH.Ppr', '')
+ .replace('GHC.Internal.TH.Lib,', '')
+ .replace('GHC.Internal.TH.Lib', '')
+ .replace('GHC.Internal.TH.Lift,', '')
+ .replace('GHC.Internal.TH.Quote,', '')
+ .replace('GHC.Internal.TH.Syntax', '')
+ .replace('GHC.Internal.ForeignSrcLang', '')
+ .replace('GHC.Internal.LanguageExtensions', '')
+ .replace('GHC.Internal.Lexeme', '')
+ )
PACKAGES = {
pkg.name: pkg
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -8,7 +8,7 @@
-- | Bytecode assembler and linker
module GHC.ByteCode.Asm (
- assembleBCOs, assembleOneBCO,
+ assembleBCOs,
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH,
@@ -34,7 +34,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.TyCon
-import GHC.Data.FlatBag
import GHC.Data.SizedSeq
import GHC.StgToCmm.Layout ( ArgRep(..) )
@@ -53,7 +52,6 @@ import Data.Array.Base ( UArray(..) )
import Foreign hiding (shiftL, shiftR)
import Data.Char ( ord )
-import Data.List ( genericLength )
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
@@ -168,15 +166,6 @@ mallocStrings interp ulbcos = do
collectPtr (BCOPtrBCO bco) = collect bco
collectPtr _ = return ()
-
-assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
-assembleOneBCO interp profile pbco = do
- -- TODO: the profile should be bundled with the interpreter: the rts ways are
- -- fixed for an interpreter
- ubco <- assembleBCO (profilePlatform profile) pbco
- UnitFlatBag ubco' <- mallocStrings interp (UnitFlatBag ubco)
- return ubco'
-
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO platform
(ProtoBCO { protoBCOName = nm
@@ -343,6 +332,7 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
+
inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
@@ -350,7 +340,7 @@ inspectAsm platform long_jumps initial_offset
go s (NullAsm _) = (instrCount s, lblEnv s)
go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
where n = ptrCount s
- go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
+ go s (AllocLit ls k) = go (s { litCount = n + strictGenericLength ls }) (k n)
where n = litCount s
go s (AllocLabel lbl k) = go s' k
where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -210,9 +211,9 @@ linkFail who what
nameToCLabel :: Name -> String -> FastString
-nameToCLabel n suffix = mkFastString label
+nameToCLabel n suffix = mkFastStringByteString label
where
- encodeZ = zString . zEncodeFS
+ encodeZ = fastZStringToByteString . zEncodeFS
(Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
-- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
-- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
@@ -222,11 +223,14 @@ nameToCLabel n suffix = mkFastString label
modulePart = encodeZ (moduleNameFS modName)
occPart = encodeZ $ occNameMangledFS (nameOccName n)
- label = concat
- [ if pkgKey == mainUnit then "" else packagePart ++ "_"
- , modulePart
- , '_':occPart
- , '_':suffix
+ label = mconcat $
+ [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
+ ++
+ [modulePart
+ , "_"
+ , occPart
+ , "_"
+ , fromString suffix
]
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -59,7 +59,8 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
-import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
+import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName, OccName )
+import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import GHC.Types.Literal
import GHC.Types.Tickish
@@ -70,6 +71,7 @@ import qualified Data.ByteString.Builder as BB
import Data.ByteString.Builder.Prim
import Control.Monad
+import Data.List (intercalate)
{-
Note [CorePrep Overview]
@@ -247,11 +249,11 @@ corePrepPgm logger cp_cfg pgm_cfg
withTiming logger
(text "CorePrep"<+>brackets (ppr this_mod))
(\a -> a `seqList` ()) $ do
- us <- mkSplitUniqSupply 's'
let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg
- let
- implicit_binds = mkDataConWorkers
+ us <- mkSplitUniqSupply 's'
+
+ let implicit_binds = mkDataConWorkers
(cpPgm_generateDebugInfo pgm_cfg)
mod_loc data_tycons
-- NB: we must feed mkImplicitBinds through corePrep too
@@ -711,13 +713,13 @@ cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-> UniqSM (Floats, CpeRhs)
-- Used for all bindings
-- The binder is already cloned, hence an OutId
-cpePair top_lvl is_rec dmd lev env bndr rhs
+cpePair top_lvl is_rec dmd lev env0 bndr rhs
= assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
do { (floats1, rhs1) <- cpeRhsE env rhs
-- See if we are allowed to float this stuff out of the RHS
; let dec = want_float_from_rhs floats1 rhs1
- ; (floats2, rhs2) <- executeFloatDecision dec floats1 rhs1
+ ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1
-- Make the arity match up
; (floats3, rhs3)
@@ -725,7 +727,7 @@ cpePair top_lvl is_rec dmd lev env bndr rhs
then return (floats2, cpeEtaExpand arity rhs2)
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-- Note [Silly extra arguments]
- (do { v <- newVar (idType bndr)
+ (do { v <- newVar env (idType bndr)
; let (float, v') = mkNonRecFloat env Lifted v rhs2
; return ( snocFloat floats2 float
, cpeEtaExpand arity (Var v')) })
@@ -735,6 +737,8 @@ cpePair top_lvl is_rec dmd lev env bndr rhs
; return (floats4, rhs4) }
where
+ env = pushBinderContext bndr env0
+
arity = idArity bndr -- We must match this arity
want_float_from_rhs floats rhs
@@ -967,36 +971,36 @@ cpeBodyNF env expr
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody env expr
= do { (floats1, rhs) <- cpeRhsE env expr
- ; (floats2, body) <- rhsToBody rhs
+ ; (floats2, body) <- rhsToBody env rhs
; return (floats1 `appFloats` floats2, body) }
--------
-rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
+rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)
-- Remove top level lambdas by let-binding
-rhsToBody (Tick t expr)
+rhsToBody env (Tick t expr)
| tickishScoped t == NoScope -- only float out of non-scoped annotations
- = do { (floats, expr') <- rhsToBody expr
+ = do { (floats, expr') <- rhsToBody env expr
; return (floats, mkTick t expr') }
-rhsToBody (Cast e co)
+rhsToBody env (Cast e co)
-- You can get things like
-- case e of { p -> coerce t (\s -> ...) }
- = do { (floats, e') <- rhsToBody e
+ = do { (floats, e') <- rhsToBody env e
; return (floats, Cast e' co) }
-rhsToBody expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody]
+rhsToBody env expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody]
| all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { let rhs = cpeEtaExpand (exprArity expr) expr
- ; fn <- newVar (exprType rhs)
+ ; fn <- newVar env (exprType rhs)
; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable
; return (unitFloat float, Var fn) }
where
(bndrs,_) = collectBinders expr
-rhsToBody expr = return (emptyFloats, expr)
+rhsToBody _env expr = return (emptyFloats, expr)
{- Note [No eta reduction needed in rhsToBody]
@@ -1168,7 +1172,7 @@ cpeApp top_env expr
-- allocating CaseBound Floats for token and thing as needed
= do { (floats1, token) <- cpeArg env topDmd token
; (floats2, thing) <- cpeBody env thing
- ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar ty
+ ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty
; let tup = mkCoreUnboxedTuple [token, Var case_bndr]
; let float = mkCaseFloat case_bndr thing
; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }
@@ -1577,7 +1581,7 @@ cpeArg env dmd arg
; let arg_ty = exprType arg1
lev = typeLevity arg_ty
dec = wantFloatLocal NonRecursive dmd lev floats1 arg1
- ; (floats2, arg2) <- executeFloatDecision dec floats1 arg1
+ ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1
-- Else case: arg1 might have lambdas, and we can't
-- put them inside a wrapBinds
@@ -1586,7 +1590,7 @@ cpeArg env dmd arg
-- see Note [ANF-ising literal string arguments]
; if exprIsTrivial arg2
then return (floats2, arg2)
- else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty
+ else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty
-- See Note [Pin demand info on floats]
; let arity = cpeArgArity env dec floats1 arg2
arg3 = cpeEtaExpand arity arg2
@@ -2424,13 +2428,13 @@ instance Outputable FloatDecision where
ppr FloatNone = text "none"
ppr FloatAll = text "all"
-executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
-executeFloatDecision dec floats rhs
+executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
+executeFloatDecision env dec floats rhs
= case dec of
FloatAll -> return (floats, rhs)
FloatNone
| isEmptyFloats floats -> return (emptyFloats, rhs)
- | otherwise -> do { (floats', body) <- rhsToBody rhs
+ | otherwise -> do { (floats', body) <- rhsToBody env rhs
; return (emptyFloats, wrapBinds floats $
wrapBinds floats' body) }
-- FloatNone case: `rhs` might have lambdas, and we can't
@@ -2569,6 +2573,8 @@ data CorePrepEnv
, cpe_subst :: Subst -- ^ See Note [CorePrepEnv: cpe_subst]
, cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
+
+ , cpe_context :: [OccName] -- ^ See Note [Binder context]
}
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
@@ -2576,6 +2582,7 @@ mkInitialCorePrepEnv cfg = CPE
{ cpe_config = cfg
, cpe_subst = emptySubst
, cpe_rec_ids = emptyUnVarSet
+ , cpe_context = []
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -2616,6 +2623,14 @@ cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co
-- substCo has a short-cut if the TCvSubst is empty
+-- | See Note [Binder context]
+pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv
+pushBinderContext ident env
+ | lengthAtLeast (cpe_context env) 2
+ = env
+ | otherwise
+ = env { cpe_context = getOccName ident : cpe_context env}
+
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
@@ -2704,10 +2719,20 @@ fiddleCCall id
-- Generating new binders
-- ---------------------------------------------------------------------------
-newVar :: Type -> UniqSM Id
-newVar ty
- = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty
-
+newVar :: CorePrepEnv -> Type -> UniqSM Id
+newVar env ty
+ -- See Note [Binder context]
+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty
+ where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat"
+
+{- Note [Binder context]
+ ~~~~~~~~~~~~~~~~~~~~~
+ To ensure that the compiled program (specifically symbol names)
+ remains understandable to the user we maintain a context
+ of binders that we are currently under. This allows us to give
+ identifiers conjured during CorePrep more contextually-meaningful
+ names. This is done in `newVar`.
+ -}
------------------------------------------------------------------------------
-- Floating ticks
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -25,6 +25,8 @@ module GHC.Prelude.Basic
, shiftL, shiftR
, setBit, clearBit
, head, tail
+
+ , strictGenericLength
) where
@@ -130,3 +132,15 @@ head = Prelude.head
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+
+{- |
+The 'genericLength' function defined in base can't be specialised due to the
+NOINLINE pragma.
+
+It is also not strict in the accumulator, and strictGenericLength is not exported.
+
+See #25706 for why it is important to use a strict, specialised version.
+
+-}
+strictGenericLength :: Num a => [x] -> a
+strictGenericLength = fromIntegral . length
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -659,6 +659,7 @@ rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _)
rnFamEqn :: HsDocContext
-> AssocTyFamInfo
-> FamEqn GhcPs rhs
+ -> FreeKiTyVars -- Implicit binders of the rhs payload
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
rnFamEqn doc atfi
@@ -666,7 +667,7 @@ rnFamEqn doc atfi
, feqn_bndrs = outer_bndrs
, feqn_pats = pats
, feqn_fixity = fixity
- , feqn_rhs = payload }) rn_payload
+ , feqn_rhs = payload }) payload_kvs rn_payload
= do { tycon' <- lookupFamInstName mb_cls tycon
-- all_imp_vars represent the implicitly bound type variables. This is
@@ -697,7 +698,7 @@ rnFamEqn doc atfi
--
-- For associated type family instances, exclude the type variables
-- bound by the instance head with filterInScopeM (#19649).
- ; all_imp_vars <- filterInScopeM $ pat_kity_vars
+ ; all_imp_vars <- filterInScopeM $ (pat_kity_vars ++ payload_kvs)
; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
@@ -788,7 +789,7 @@ rnFamEqn doc atfi
-- type instance F a b c = Either a b
-- ^^^^^
lhs_loc = case map lhsTypeArgSrcSpan pats of
- [] -> panic "rnFamEqn.lhs_loc"
+ [] -> getLocA tycon
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
@@ -847,8 +848,9 @@ rnTyFamInstEqn :: AssocTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon })
- = rnFamEqn (TySynCtx tycon) atfi eqn rnTySyn
-
+ = rnFamEqn (TySynCtx tycon) atfi eqn
+ [{- No implicit vars on RHS of a type instance -}]
+ rnTySyn
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
@@ -859,9 +861,9 @@ rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =
- eqn@(FamEqn { feqn_tycon = tycon })})
- = do { (eqn', fvs) <-
- rnFamEqn (TyDataCtx tycon) atfi eqn rnDataDefn
+ eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = defn })})
+ = do { let implicit_kvs = extractDataDefnKindVars defn
+ ; (eqn', fvs) <- rnFamEqn (TyDataCtx tycon) atfi eqn implicit_kvs rnDataDefn
; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
-- Renaming of the associated types in instances.
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -70,7 +70,7 @@ import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import GHC.Types.SptEntry
-import Data.List ( genericReplicate, genericLength, intersperse
+import Data.List ( genericReplicate, intersperse
, partition, scanl', sortBy, zip4, zip6 )
import Foreign hiding (shiftL, shiftR)
import Control.Monad
@@ -240,11 +240,12 @@ ppBCEnv p
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO
- :: (Outputable name)
- => Platform
- -> Bool -- ^ True <=> label with @BCO_NAME@ instruction
- -- see Note [BCO_NAME]
- -> name
+ ::
+ Platform
+ -> Maybe Module
+ -- ^ Just cur_mod <=> label with @BCO_NAME@ instruction
+ -- see Note [BCO_NAME]
+ -> Name
-> BCInstrList
-> Either [CgStgAlt] (CgStgRhs)
-- ^ original expression; for debugging only
@@ -253,7 +254,7 @@ mkProtoBCO
-> [StgWord] -- ^ bitmap
-> Bool -- ^ True <=> is a return point, rather than a function
-> [FFIInfo]
- -> ProtoBCO name
+ -> ProtoBCO Name
mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
= ProtoBCO {
protoBCOName = nm,
@@ -267,9 +268,9 @@ mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bit
where
#if MIN_VERSION_rts(1,0,3)
maybe_add_bco_name instrs
- | _add_bco_name = BCO_NAME str : instrs
- where
- str = BS.pack $ showSDocOneLine defaultSDocContext (ppr nm)
+ | Just cur_mod <- _add_bco_name =
+ let str = BS.pack $ showSDocOneLine defaultSDocContext (pprFullName cur_mod nm)
+ in BCO_NAME str : instrs
#endif
maybe_add_bco_name instrs = instrs
@@ -393,7 +394,7 @@ schemeR_wrk fvs nm original_body (args, body)
-- make the arg bitmap
bits = argBits platform (reverse (map (idArgRep platform) all_args))
- bitmap_size = genericLength bits
+ bitmap_size = strictGenericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -607,7 +608,7 @@ schemeE d s p (StgLet _ext binds body) = do
platform <- targetPlatform <$> getDynFlags
let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
StgRec xs_n_rhss -> unzip xs_n_rhss
- n_binds = genericLength xs
+ n_binds = strictGenericLength xs
fvss = map (fvsToEnv p') rhss
@@ -616,7 +617,7 @@ schemeE d s p (StgLet _ext binds body) = do
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss
+ arities = map (strictGenericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1 word. d' and p' reflect the stack
@@ -1398,7 +1399,7 @@ Note [unboxed tuple bytecodes and tuple_BCO]
tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO platform args_info args =
- mkProtoBCO platform False invented_name body_code (Left [])
+ mkProtoBCO platform Nothing invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
where
{-
@@ -1419,7 +1420,7 @@ tupleBCO platform args_info args =
primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
primCallBCO platform args_info args =
- mkProtoBCO platform False invented_name body_code (Left [])
+ mkProtoBCO platform Nothing invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
where
{-
@@ -1857,7 +1858,7 @@ implement_tagToId
implement_tagToId d s p arg names
= assert (notNull names) $
do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
- labels <- getLabelsBc (genericLength names)
+ labels <- getLabelsBc (strictGenericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
dflags <- getDynFlags
@@ -2359,8 +2360,12 @@ getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
getProfile :: BcM Profile
getProfile = targetProfile <$> getDynFlags
-shouldAddBcoName :: BcM Bool
-shouldAddBcoName = gopt Opt_AddBcoName <$> getDynFlags
+shouldAddBcoName :: BcM (Maybe Module)
+shouldAddBcoName = do
+ add <- gopt Opt_AddBcoName <$> getDynFlags
+ if add
+ then Just <$> getCurrentModule
+ else return Nothing
emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3141,7 +3141,7 @@ tcDataDefn err_ctxt roles_info tc_name
-- via inferInitialKinds
, dd_cons = cons
, dd_derivs = derivs })
- = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->
+ = bindTyClTyVars tc_name $ \ tc_bndrs tc_res_kind ->
-- The TyCon tyvars must scope over
-- - the stupid theta (dd_ctxt)
-- - for H98 constructors only, the ConDecl
@@ -3152,18 +3152,18 @@ tcDataDefn err_ctxt roles_info tc_name
; tcg_env <- getGblEnv
; let hsc_src = tcg_src tcg_env
; unless (mk_permissive_kind hsc_src cons) $
- checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind
+ checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) tc_res_kind
- ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $
+ ; tc_stupid_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $
tcHsContext ctxt
-- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
-- Example: (typecheck/should_fail/T17567StupidTheta)
-- data (forall a. a b ~ a c) => T b c
-- The kind of 'a' is unconstrained.
- ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta
+ ; dvs <- candidateQTyVarsOfTypes tc_stupid_theta
; let err_ctx tidy_env
- = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta
+ = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env tc_stupid_theta
; return (tidy_env2, UninfTyCtx_DataContext theta) }
; doNotQuantifyTyVars dvs err_ctx
@@ -3177,12 +3177,12 @@ tcDataDefn err_ctxt roles_info tc_name
; (bndrs, stupid_theta, res_kind) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs ->
- do { stupid_theta <- zonkTcTypesToTypesX stupid_tc_theta
- ; res_kind <- zonkTcTypeToTypeX res_kind
+ do { stupid_theta <- zonkTcTypesToTypesX tc_stupid_theta
+ ; res_kind <- zonkTcTypeToTypeX tc_res_kind
; return (bndrs, stupid_theta, res_kind) }
; tycon <- fixM $ \ rec_tycon -> do
- { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
+ { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs tc_res_kind cons
; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
@@ -3360,24 +3360,52 @@ So, we use bindOuterFamEqnTKBndrs (which does not create an implication for
the telescope), and generalise over /all/ the variables in the LHS,
without treating the explicitly-quantified ones specially. Wrinkles:
- - When generalising, include the explicit user-specified forall'd
+(GT1) When generalising, include the explicit user-specified forall'd
variables, so that we get an error from Validity.checkFamPatBinders
if a forall'd variable is not bound on the LHS
- - We still want to complain about a bad telescope among the user-specified
+(GT2) We still want to complain about a bad telescope among the user-specified
variables. So in checkFamTelescope we emit an implication constraint
quantifying only over them, purely so that we get a good telescope error.
- - Note that, unlike a type signature like
+(GT3) Note that, unlike a type signature like
f :: forall (a::k). blah
we do /not/ care about the Inferred/Specified designation or order for
the final quantified tyvars. Type-family instances are not invoked
directly in Haskell source code, so visible type application etc plays
no role.
-See also Note [Re-quantify type variables in rules] in
-GHC.Tc.Gen.Rule, which explains a /very/ similar design when
-generalising over the type of a rewrite rule.
+(GT4) Consider #25647 (with UnliftedNewtypes)
+ type N :: forall r. (TYPE r -> TYPE r) -> TYPE r
+ newtype N f where { MkN :: ff (N ff) -> N ff }
+ When kind-checking the type signature for MkN we'll start wtih
+ ff :: TYPE kappa -> TYPE kappa
+ MkN :: ff (N @kappa) ff -> N @kappa ff
+ Then we generalise /and default the RuntimeRep variable kappa/
+ (via `kindGeneralizeAll` in `tcConDecl`), thus kappa := LiftedRep
+
+ But now the newtype looks like a GADT and we get an error
+ A newtype must not be a GADT
+
+ This seems OK. We are just following the rules.
+
+ But this variant (the original report in #25647)
+ data family Fix2 :: (k -> Type) -> k
+ newtype instance Fix2 f where { In2 :: f (Fix2 f) -> Fix2 f }
+ At the `newtype instance`, we first
+ 1. Find the kind of the newtype instance in `tcDataFamInstHeader`
+ 2. Typecheck the newtype definitition itself in `tcConDecl`
+ In step 1 we do /not/ want to get
+ newtype instance forall r . Fix2 (f :: TYPE r -> TYPE r) :: TYPE r where
+ If we do, we'll get that same "newtype must not be GADT" error as for N above.
+ Rather, we want to default the RuntimeRep variable r := LiftedRep. Hence
+ the use of `DefaultNonStandardTyVars` in `tcDataFamInstHeader`. The key thing
+ is that we must make the /same/ choice here as we do in kind-checking the data
+ constructor's type.
+
+See also Note [Re-quantify type variables in rules] in GHC.Tc.Gen.Rule, which
+explains a /very/ similar design when generalising over the type of a rewrite
+rule.
-}
@@ -3753,23 +3781,30 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
; return (NE.singleton dc) }
-tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
- -- NB: don't use res_kind here, as it's ill-scoped. Instead,
+tcConDecl new_or_data dd_info rep_tycon tc_bndrs _tc_res_kind tag_map
+ -- NB: don't use _tc_res_kind here, as it's ill-scoped. Instead,
-- we get the res_kind by typechecking the result type.
(ConDeclGADT { con_names = names
, con_bndrs = L _ outer_hs_bndrs
, con_mb_cxt = cxt, con_g_args = hs_args
, con_res_ty = hs_res_ty })
= addErrCtxt (DataConDefCtxt names) $
- do { traceTc "tcConDecl 1 gadt" (ppr names)
+ do { traceTc "tcConDecl 1 gadt" (ppr names $$ ppr _tc_res_kind)
; let L _ name :| _ = names
; skol_info <- mkSkolemInfo (DataConSkol name)
- ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
+ ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts, res_kind)))
<- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $
tcOuterTKBndrs skol_info outer_hs_bndrs $
do { ctxt <- tcHsContext cxt
+
; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty
- -- See Note [GADT return kinds]
+ -- See Note [GADT return kinds]
+
+ -- See Note [Datatype return kinds]
+ ; let exp_kind = getArgExpKind new_or_data res_kind
+ ; btys <- tcConGADTArgs exp_kind hs_args
+
+ ; traceTc "tcConDecl 1a gadt" (ppr res_ty <+> dcolon <+> ppr res_kind)
-- For data instances (only), ensure that the return type,
-- res_ty, is a substitution instance of the header.
@@ -3784,13 +3819,9 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
addErrCtxt (DataConResTyCtxt names) $
unifyType Nothing res_ty head_shape }
- -- See Note [Datatype return kinds]
- ; let exp_kind = getArgExpKind new_or_data res_kind
- ; btys <- tcConGADTArgs exp_kind hs_args
-
; let (arg_tys, stricts) = unzip btys
; field_lbls <- lookupConstructorFields name
- ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+ ; return (ctxt, arg_tys, res_ty, field_lbls, stricts, res_kind)
}
; outer_bndrs <- scopedSortOuter outer_bndrs
@@ -3801,7 +3832,10 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
tcMkPhiTy ctxt $
tcMkScaledFunTys arg_tys $
res_ty)
- ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)
+ ; traceTc "tcConDecl:GADT" (vcat [ text "names:" <+> ppr names
+ , text "tkvs:" <+> ppr tkvs
+ , text "res_ty:" <+> ppr res_ty
+ , text "res_kind:" <+> ppr res_kind ])
; reportUnsolvedEqualities skol_info tkvs tclvl wanted
; let tvbndrs = mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -790,10 +790,10 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
, text "eta_tcbs" <+> ppr eta_tcbs ]
; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(rec_rep_tc, _) ->
do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $
- -- For H98 decls, the tyvars scope
- -- over the data constructors
- tcConDecls (DDataInstance orig_res_ty) rec_rep_tc tc_ty_binders tc_res_kind
- hs_cons
+ -- tcExtendTyVarEnv: for H98 decls, the tyvars
+ -- scope over the data constructors
+ tcConDecls (DDataInstance orig_res_ty) rec_rep_tc
+ tc_ty_binders tc_res_kind hs_cons
; rep_tc_name <- newFamInstTyConName lfam_name pats
; axiom_name <- newFamInstAxiomName lfam_name [pats]
@@ -943,11 +943,6 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-- with its parent class
; addConsistencyConstraints mb_clsinfo lhs_ty
- -- Add constraints from the data constructors
- -- Fix #25611
- -- See DESIGN CHOICE in Note [Kind inference for data family instances]
- ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons
-
-- Check that the result kind of the TyCon applied to its args
-- is compatible with the explicit signature (or Type, if there
-- is none)
@@ -956,6 +951,11 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
; res_kind <- tc_kind_sig m_ksig
; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind
+ -- Add constraints from the data constructors
+ -- Fix #25611
+ -- See DESIGN CHOICE in Note [Kind inference for data family instances]
+ ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons
+
; traceTc "tcDataFamInstHeader" $
vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig]
; return ( stupid_theta
@@ -975,7 +975,10 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty
- ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
+ ; qtvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs
+ -- DefaultNonStandardTyVars: see (GT4) in
+ -- GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
+
; let final_tvs = scopedSort (qtvs ++ outer_tvs)
-- This scopedSort is important: the qtvs may be /interleaved/ with
-- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts]
@@ -999,7 +1002,7 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-- Split up the LHS type to get the type patterns
-- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts]
- ; let pats = unravelFamInstPats lhs_ty
+ ; let pats = unravelFamInstPats lhs_ty
; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) }
where
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -809,9 +809,11 @@ data HsDataDefn pass -- The payload of a data type defn
-- *and* for data family instances
= -- | Declares a data type or newtype, giving its constructors
-- @
- -- data/newtype T a = <constrs>
- -- data/newtype instance T [a] = <constrs>
+ -- data/newtype T a :: ksig = <constrs>
+ -- data/newtype instance T [a] :: ksig = <constrs>
-- @
+ -- The HsDataDefn describes the (optional) kind signature and the <constrs>
+ -- but not the `data T a` or `newtype T [a]` headers
HsDataDefn { dd_ext :: XCHsDataDefn pass,
dd_ctxt :: Maybe (LHsContext pass), -- ^ Context
dd_cType :: Maybe (XRec pass CType),
=====================================
libraries/ghc-boot/GHC/Data/SizedSeq.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-}
module GHC.Data.SizedSeq
( SizedSeq(..)
, emptySS
@@ -11,9 +11,12 @@ module GHC.Data.SizedSeq
import Prelude -- See note [Why do we import Prelude here?]
import Control.DeepSeq
import Data.Binary
-import Data.List (genericLength)
import GHC.Generics
+#if ! MIN_VERSION_base(4,20,0)
+import Data.List (foldl')
+#endif
+
data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]
deriving (Generic, Show)
@@ -37,9 +40,9 @@ emptySS = SizedSeq 0 []
addToSS :: SizedSeq a -> a -> SizedSeq a
addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
+-- NB, important this is eta-expand so that foldl' is inlined.
addListToSS :: SizedSeq a -> [a] -> SizedSeq a
-addListToSS (SizedSeq n r_xs) xs
- = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
+addListToSS s xs = foldl' addToSS s xs
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
=====================================
testsuite/tests/core-to-stg/T14895.stderr
=====================================
@@ -11,10 +11,10 @@ T14895.go
GHC.Internal.Data.Either.Left e [Occ=Once1] -> wild<TagProper>;
GHC.Internal.Data.Either.Right a1 [Occ=Once1] ->
let {
- sat [Occ=Once1] :: b
+ go_sat [Occ=Once1] :: b
[LclId] =
{a1, f} \u [] f a1;
- } in GHC.Internal.Data.Either.Right [sat];
+ } in GHC.Internal.Data.Either.Right [go_sat];
};
=====================================
testsuite/tests/core-to-stg/T24124.stderr
=====================================
@@ -9,16 +9,16 @@ T24124.testFun1
T24124.StrictPair a b #)
[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] =
{} \r [x y void]
- case x of sat {
+ case x of testFun1_sat {
__DEFAULT ->
case
case y of y [OS=OneShot] {
- __DEFAULT -> T24124.MkStrictPair [sat y];
+ __DEFAULT -> T24124.MkStrictPair [testFun1_sat y];
}
of
- sat
+ testFun1_sat
{
- __DEFAULT -> GHC.Internal.Types.MkSolo# [sat];
+ __DEFAULT -> GHC.Internal.Types.MkSolo# [testFun1_sat];
};
};
=====================================
testsuite/tests/ghci/should_run/T21052.stdout
=====================================
@@ -4,9 +4,9 @@ BCO_toplevel :: GHC.Internal.Types.IO [GHC.Internal.Types.Any]
[LclIdX] =
{} \u []
let {
- sat :: [GHC.Internal.Types.Any]
+ _sat :: [GHC.Internal.Types.Any]
[LclId, Unf=OtherCon []] =
:! [GHC.Internal.Tuple.() GHC.Internal.Types.[]];
- } in GHC.Internal.Base.returnIO sat;
+ } in GHC.Internal.Base.returnIO _sat;
=====================================
testsuite/tests/indexed-types/should_compile/T25611d.hs
=====================================
@@ -20,7 +20,7 @@ data instance T p q where
MkkV :: forall l. l Int# -> T l Int#
type N :: TYPE r -> TYPE r
-newtype N a = MkN a
+newtype N (a::TYPE r) = MkN a
f :: Int# -> N Int#
f x = MkN x
@@ -29,7 +29,7 @@ g :: Int -> N Int
g x = MkN x
data family D :: Type -> k -> k
-newtype instance D Int a = MkD a
+newtype instance D Int (a::TYPE r) = MkD a
f1 :: Int# -> D Int Int#
f1 x = MkD x
=====================================
testsuite/tests/rename/should_fail/T23512a.stderr
=====================================
@@ -1,6 +1,3 @@
-
T23512a.hs:6:31: error: [GHC-76037] Not in scope: type variable ‘j’
T23512a.hs:6:36: error: [GHC-76037] Not in scope: type variable ‘j’
-
-T23512a.hs:9:20: error: [GHC-76037] Not in scope: type variable ‘k’
=====================================
testsuite/tests/simplCore/should_compile/T20040.stderr
=====================================
@@ -16,7 +16,9 @@ ifoldl' =
Cons ipv2 ipv3 ->
case z of z1 {
__DEFAULT ->
- case f z1 ipv2 of sat { __DEFAULT -> ifoldl' f sat ipv3; };
+ case f z1 ipv2 of ifoldl'_sat {
+ __DEFAULT -> ifoldl' f ifoldl'_sat ipv3;
+ };
};
};
end Rec }
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -13,10 +13,10 @@ T23083.g :: ((GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer
T23083.g
= \ (f [Occ=Once1!] :: (GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer) -> GHC.Internal.Bignum.Integer.Integer) (h [Occ=OnceL1] :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer) ->
let {
- sat [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer
+ g_sat [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Bignum.Integer.Integer
[LclId, Unf=OtherCon []]
- sat = \ (eta [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Internal.Bignum.Integer.Integer @GHC.Internal.Bignum.Integer.Integer h1 eta } } in
- f sat
+ g_sat = \ (eta [Occ=Once1] :: GHC.Internal.Bignum.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Internal.Bignum.Integer.Integer @GHC.Internal.Bignum.Integer.Integer h1 eta } } in
+ f g_sat
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T23083.$trModule4 :: GHC.Prim.Addr#
=====================================
testsuite/tests/simplStg/should_compile/T15226b.stderr
=====================================
@@ -8,13 +8,13 @@ T15226b.bar1
T15226b.Str (GHC.Internal.Maybe.Maybe a) #)
[GblId, Arity=2, Str=<L><L>, Cpr=1(, 1), Unf=OtherCon []] =
{} \r [x void]
- case x of sat {
+ case x of bar1_sat {
__DEFAULT ->
let {
- sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a)
+ bar1_sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a)
[LclId, Unf=OtherCon []] =
- T15226b.Str! [sat];
- } in GHC.Internal.Types.MkSolo# [sat];
+ T15226b.Str! [bar1_sat];
+ } in GHC.Internal.Types.MkSolo# [bar1_sat];
};
T15226b.bar
=====================================
testsuite/tests/simplStg/should_compile/T19717.stderr
=====================================
@@ -6,14 +6,14 @@ Foo.f :: forall {a}. a -> [GHC.Internal.Maybe.Maybe a]
case x of x1 {
__DEFAULT ->
let {
- sat [Occ=Once1] :: GHC.Internal.Maybe.Maybe a
+ f_sat [Occ=Once1] :: GHC.Internal.Maybe.Maybe a
[LclId, Unf=OtherCon []] =
GHC.Internal.Maybe.Just! [x1]; } in
let {
- sat [Occ=Once1] :: [GHC.Internal.Maybe.Maybe a]
+ f_sat [Occ=Once1] :: [GHC.Internal.Maybe.Maybe a]
[LclId, Unf=OtherCon []] =
- :! [sat GHC.Internal.Types.[]];
- } in : [sat sat];
+ :! [f_sat GHC.Internal.Types.[]];
+ } in : [f_sat f_sat];
};
=====================================
testsuite/tests/typecheck/should_compile/T25647_fail.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds, UnliftedNewtypes, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647_fail where
+
+import GHC.Exts
+import Data.Kind
+
+-- Rejected because in the type signature for In2 we default
+-- the runtime-rep variable to LiftedRep, and that makes In2
+-- into a GADT
+newtype Fix2 f :: TYPE r where
+ In2 :: forall ff. ff (Fix2 ff) -> Fix2 ff
+
+-- Rejected for the same reason
+type Fix4a :: forall r. (TYPE r -> TYPE r) -> TYPE r
+newtype Fix4a f where
+ In4a :: ff (Fix4a ff) -> Fix4a ff
+
+data family Dix6 :: (k -> TYPE 'IntRep) -> k
+newtype instance Dix6 f where
+ DIn6 :: forall ff. ff (Dix6 ff) -> Dix6 ff
=====================================
testsuite/tests/typecheck/should_compile/T25647_fail.stderr
=====================================
@@ -0,0 +1,23 @@
+T25647_fail.hs:12:4: [GHC-89498]
+ A newtype must not be a GADT
+ In2 :: forall (ff :: * -> *).
+ ff (Fix2 @LiftedRep ff) -> Fix2 @LiftedRep ff
+ In the definition of data constructor ‘In2’
+ In the newtype declaration for ‘Fix2’
+
+T25647_fail.hs:17:3: [GHC-89498]
+ A newtype must not be a GADT
+ In4a :: forall (ff :: * -> *).
+ ff (Fix4a @LiftedRep ff) -> Fix4a @LiftedRep ff
+ In the definition of data constructor ‘In4a’
+ In the newtype declaration for ‘Fix4a’
+
+T25647_fail.hs:21:3: [GHC-18872]
+ Couldn't match a lifted type with an unlifted type
+ When matching types
+ ff :: TYPE IntRep -> TYPE IntRep
+ f0 :: * -> TYPE IntRep
+ Expected: Dix6 f0
+ Actual: Dix6 ff
+ In the result type of data constructor ‘DIn6’
+ In the newtype family instance declaration for ‘Dix6’
\ No newline at end of file
=====================================
testsuite/tests/typecheck/should_compile/T25647a.hs
=====================================
@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds, UnliftedNewtypes, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647a where
+
+import GHC.Exts
+import Data.Kind
+
+-------------------- Plain newtypes -----------------
+
+-- A plain newtype, H98
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1a f = In1a (f (Fix1a f))
+
+-- A plain newtype, GADT syntax
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1b f where
+ In1b :: forall ff. ff (Fix1b ff) -> Fix1b ff
+
+-- A plain newtype, GADT syntax, with a return kind signature,
+-- and runtime-rep quantification in the data constructor
+-- Should infer Fix2 :: forall r k. (k -> TYPE r) -> TYPE r
+newtype Fix2 f :: TYPE r where
+ In2 :: forall r (ff :: TYPE r -> TYPE r). ff (Fix2 ff) -> Fix2 ff
+
+-- Plain newtype, H98 syntax, standalone kind signature
+-- Should get In3 :: forall r (f :: TYPE r -> TYPE r). Fix3 @r f -> Fix3 @r f
+type Fix3 :: forall r. (TYPE r -> TYPE r) -> TYPE r
+newtype Fix3 f = In3 (f (Fix3 f))
+
+-- Plain newtype, H98 syntax, standalone kind signature
+-- Should get In4 :: forall r k (f :: k -> TYPE r). Fix4 @r @k f -> Fix4 @r @k f
+type Fix4 :: forall r. (TYPE r -> TYPE r) -> TYPE r
+newtype Fix4 f where
+ In4 :: forall rr (ff :: TYPE rr -> TYPE rr).
+ ff (Fix4 ff) -> Fix4 @rr ff
+
+-------------------- Data families with newtype instance -----------------
+
+-- data instance in GADT sytntax
+data family Dix1 :: (k -> Type) -> k
+data instance Dix1 f where
+ DIn1 :: forall ff. ff (Dix1 ff) -> Dix1 ff
+
+-- newtype instance in GADT syntax
+data family Dix2 :: (k -> Type) -> k
+newtype instance Dix2 f where
+ DIn2 :: forall ff. ff (Dix2 ff) -> Dix2 ff
+
+data family Dix2a :: (k -> Type) -> k
+newtype instance Dix2a f :: Type where
+ DIn2a :: forall ff. ff (Dix2a ff) -> Dix2a ff
+
+-- newtype instance in H98 syntax
+data family Dix3 :: (k -> Type) -> k
+newtype instance Dix3 f = DIn3 (f (Dix3 f))
+
+-- newtype instance in GADT syntax
+-- The newtype instance defaults to LiftedRep
+data family Dix4 :: (k -> TYPE r) -> k
+newtype instance Dix4 f where
+ DIn4 :: forall ff. ff (Dix4 ff) -> Dix4 ff
+
+-- newtype instance in H98 syntax
+data family Dix5 :: (k -> TYPE r) -> k
+newtype instance Dix5 f = DIn5 (f (Dix5 f))
+
+-- -- newtype instance that is not TYPE 'LiftedRep
+-- data family Dix6 :: (k -> TYPE 'IntRep) -> k
+-- newtype instance Dix6 f where
+-- DIn6 :: forall ff. ff (Dix6 ff) -> Dix6 ff
+
+
=====================================
testsuite/tests/typecheck/should_compile/T25647b.hs
=====================================
@@ -0,0 +1,65 @@
+{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, MagicHash #-}
+
+module T25647b where
+
+import GHC.Exts
+import Data.Kind
+
+---------------------------
+-- without UnliftedNewtypes
+---------------------------
+
+-------------------- Plain newtypes -----------------
+
+-- A plain newtype, H98
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1a f = In1a (f (Fix1a f))
+
+-- A plain newtype, GADT syntax
+-- Defaulting happens; infers Fix1 :: forall k. (k -> Type) -> Type
+newtype Fix1b f where
+ In1b :: forall ff. ff (Fix1b ff) -> Fix1b ff
+
+-- A plain newtype, GADT syntax, with a return kind signature,
+-- and runtime-rep quantification in the data constructor
+-- Should infer Fix2 :: (Type -> Type) -> Type
+newtype Fix2 f where
+ In2 :: forall (ff :: Type -> Type). ff (Fix2 ff) -> Fix2 ff
+
+-- Plain newtype, H98 syntax, standalone kind signature
+type Fix3 :: (Type -> Type) -> Type
+newtype Fix3 f = In3 (f (Fix3 f))
+
+-- Plain newtype, H98 syntax, standalone kind signature
+type Fix4 :: (Type -> Type) -> Type
+newtype Fix4 f where
+ In4 :: forall (ff :: Type -> Type).
+ ff (Fix4 ff) -> Fix4 ff
+
+-------------------- Data families with newtype instance -----------------
+
+-- data instance in GADT sytntax
+data family Dix1 :: (k -> Type) -> k
+data instance Dix1 f where
+ DIn1 :: forall ff. ff (Dix1 ff) -> Dix1 ff
+
+-- newtype instance in GADT syntax
+data family Dix2 :: (k -> Type) -> k
+newtype instance Dix2 f where
+ DIn2 :: forall ff. ff (Dix2 ff) -> Dix2 ff
+
+data family Dix2a :: (k -> Type) -> k
+newtype instance Dix2a f :: Type where
+ DIn2a :: forall ff. ff (Dix2a ff) -> Dix2a ff
+
+-- newtype instance in H98 syntax
+data family Dix3 :: (k -> Type) -> k
+newtype instance Dix3 f = DIn3 (f (Dix3 f))
+
+-- newtype instance in H98 syntax
+data family Dix5 :: (k -> TYPE r) -> k
+newtype instance Dix5 f = DIn5 (f (Dix5 f))
+
+-- data family Dix6 :: (k -> TYPE 'IntRep) -> k
+-- newtype instance Dix6 f where
+-- DIn6 :: forall ff. ff (Dix6 ff) -> Dix6 ff
=====================================
testsuite/tests/typecheck/should_compile/T25725.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies, PolyKinds #-}
+
+module T25725 where
+
+import Data.Kind
+import GHC.Exts
+
+--This one was OK
+data D :: TYPE r -> Type where
+ MkD :: p -> D p
+
+-- But this was rejected
+data family Dix4 :: Type -> k
+data instance Dix4 Int :: TYPE r -> Type where
+ DIn4 :: p -> Dix4 Int p
+
+
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -933,3 +933,6 @@ test('T25266', normal, compile, [''])
test('T25266a', normal, compile_fail, [''])
test('T25266b', normal, compile, [''])
test('T25597', normal, compile, [''])
+test('T25647a', normal, compile, [''])
+test('T25647b', normal, compile, [''])
+test('T25647_fail', normal, compile_fail, [''])
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs
=====================================
@@ -36,6 +36,7 @@ parseArch :: Cc -> String -> M Arch
parseArch cc arch =
case arch of
"i386" -> pure ArchX86
+ "i686" -> pure ArchX86
"x86_64" -> pure ArchX86_64
"amd64" -> pure ArchX86_64
"powerpc" -> pure ArchPPC
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dec5bfda539e865a8f9efe01c222564570c1adb5...af26783367a1ebfb33b27de21d9c84f2b01fe187
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dec5bfda539e865a8f9efe01c222564570c1adb5...af26783367a1ebfb33b27de21d9c84f2b01fe187
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/20250206/5044069b/attachment-0001.html>
More information about the ghc-commits
mailing list