[Git][ghc/ghc][wip/T25647] 20 commits: interpreter: Fix INTERP_STATS profiling code
Patrick (@soulomoon)
gitlab at gitlab.haskell.org
Fri Feb 7 19:31:50 UTC 2025
Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC
Commits:
66c7f656 by Matthew Pickering at 2025-02-06T17:15:25-05:00
interpreter: Fix INTERP_STATS profiling code
The profiling code had slightly bitrotted since the last time it was
used. This just fixes things so that if you toggle the INTERP_STATS
macro then it just works and prints out the stats.
Fixes #25695
- - - - -
f71c2835 by Matthew Pickering at 2025-02-06T17:16:02-05:00
perf: Key the interpreter symbol cache by Name rather than FastString
Profiles showed that about 0.2s was being spend constructing the keys
before looking up values in the old symbol cache.
The performance of this codepath is critical as it translates directly
to a delay when a user evaluates a function like `main` in the
interpreter.
Therefore we implement a solution which keys the cache(s) by `Name`
rather than the symbol directly, so the cache can be consulted before
the symbol is constructed.
Fixes #25731
- - - - -
7fe1142d by Simon Peyton Jones at 2025-02-07T19:31:30+00:00
WIP towards #25267
- - - - -
c8a5cf38 by Simon Peyton Jones at 2025-02-07T19:31:30+00:00
Wibbles
- - - - -
ab03aaf1 by Simon Peyton Jones at 2025-02-07T19:31:30+00:00
Default tyvars in data/newtype insnstances
This is what fixes #25647
- - - - -
18ccf05e by Simon Peyton Jones at 2025-02-07T19:31:30+00:00
wibbles
Including fix for #25725
- - - - -
90b33ab9 by Simon Peyton Jones at 2025-02-07T19:31:30+00:00
Wibble
- - - - -
8c7e9bc4 by Patrick at 2025-02-07T19:31:30+00:00
add more tests
- - - - -
d8596cd9 by Patrick at 2025-02-07T19:31:30+00:00
Fix up T25611d with explicit kind annotation
- - - - -
3dfa302e by Patrick at 2025-02-07T19:31:30+00:00
fix up T25647_fail
- - - - -
6b094553 by Patrick at 2025-02-07T19:31:30+00:00
cleanup whitespace
- - - - -
fd16cd6d by Patrick at 2025-02-07T19:31:30+00:00
fix up T23512a
- - - - -
bac3be92 by Patrick at 2025-02-07T19:31:30+00:00
add more examples to T25647b
- - - - -
59ad7cac by Patrick at 2025-02-07T19:31:30+00:00
add Dix6 to T25647_fail
- - - - -
d5e7c229 by Patrick at 2025-02-07T19:31:30+00:00
add Dix7 for T25647a
- - - - -
cfcef23f by Patrick at 2025-02-07T19:31:30+00:00
change DefaultingStrategy of tcTyFamInstEqnGuts as well
- - - - -
d1f61858 by Patrick at 2025-02-07T19:31:30+00:00
align wildcard with named typevar on wether it is skolem
- - - - -
f37f1154 by Patrick at 2025-02-07T19:31:30+00:00
fix T17536c
- - - - -
7de2ece0 by Patrick at 2025-02-07T19:31:30+00:00
Fix T9357
- - - - -
ccc9152f by Patrick at 2025-02-07T19:31:30+00:00
remove wildcard usage
- - - - -
28 changed files:
- compiler/GHC.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- + compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Types/Error.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/ghc.cabal.in
- rts/Interpreter.c
- rts/Interpreter.h
- rts/RtsMain.c
- testsuite/tests/indexed-types/should_compile/T17536.hs
- testsuite/tests/indexed-types/should_compile/T17536c.hs
- testsuite/tests/indexed-types/should_compile/T25611d.hs
- testsuite/tests/indexed-types/should_fail/T9357.stderr
- testsuite/tests/rename/should_fail/T23512a.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
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -420,7 +420,6 @@ import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.Breakpoint
import GHC.Types.PkgQual
-import GHC.Types.Unique.FM
import GHC.Unit
import GHC.Unit.Env as UnitEnv
@@ -705,7 +704,7 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags dflags = do
hsc_env <- getSession
logger <- getLogger
- lookup_cache <- liftIO $ newMVar emptyUFM
+ lookup_cache <- liftIO $ mkInterpSymbolCache
-- Interpreter
interp <- if
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -12,7 +13,6 @@ module GHC.ByteCode.Linker
( linkBCO
, lookupStaticPtr
, lookupIE
- , nameToCLabel
, linkFail
)
where
@@ -26,7 +26,6 @@ import GHCi.ResolvedBCO
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
-import GHC.Builtin.Names
import GHC.Unit.Types
@@ -43,8 +42,6 @@ import GHC.Types.Name.Env
import qualified GHC.Types.Id as Id
import GHC.Types.Unique.DFM
-import Language.Haskell.Syntax.Module.Name
-
-- Standard libraries
import Data.Array.Unboxed
import Foreign.Ptr
@@ -92,30 +89,30 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
lookupStaticPtr interp addr_of_label_string = do
- m <- lookupSymbol interp addr_of_label_string
+ m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
- (unpackFS addr_of_label_string)
+ (ppr addr_of_label_string)
lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
lookupIE interp pkgs_loaded ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
Nothing -> do -- try looking up in the object files.
- let sym_to_find1 = nameToCLabel con_nm "con_info"
- m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"
+ let sym_to_find1 = IConInfoSymbol con_nm
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find1
case m of
Just addr -> return addr
Nothing
-> do -- perhaps a nullary constructor?
- let sym_to_find2 = nameToCLabel con_nm "static_info"
- n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"
+ let sym_to_find2 = IStaticInfoSymbol con_nm
+ n <- lookupHsSymbol interp pkgs_loaded sym_to_find2
case n of
Just addr -> return addr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
- (unpackFS sym_to_find1 ++ " or " ++
- unpackFS sym_to_find2)
+ (ppr sym_to_find1 <> " or " <>
+ ppr sym_to_find2)
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
@@ -123,21 +120,21 @@ lookupAddr interp pkgs_loaded ae addr_nm = do
case lookupNameEnv ae addr_nm of
Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
Nothing -> do -- try looking up in the object files.
- let sym_to_find = nameToCLabel addr_nm "bytes"
+ let sym_to_find = IBytesSymbol addr_nm
-- see Note [Bytes label] in GHC.Cmm.CLabel
- m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
- (unpackFS sym_to_find)
+ (ppr sym_to_find)
lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
lookupPrimOp interp pkgs_loaded primop = do
let sym_to_find = primopToCLabel primop "closure"
- m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"
+ m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))
case m of
Just p -> return (toRemotePtr p)
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)
resolvePtr
:: Interp
@@ -157,11 +154,11 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
| otherwise
-> assertPpr (isExternalName nm) (ppr nm) $
do
- let sym_to_find = nameToCLabel nm "closure"
- m <- lookupHsSymbol interp pkgs_loaded nm "closure"
+ let sym_to_find = IClosureSymbol nm
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)
BCOPtrPrimOp op
-> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
@@ -176,11 +173,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
-- loaded units.
--
-- See Note [Looking up symbols in the relevant objects].
-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
- massertPpr (isExternalName nm) (ppr nm)
- let sym_to_find = nameToCLabel nm sym_suffix
- pkg_id = moduleUnitId $ nameModule nm
+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp pkgs_loaded sym_to_find = do
+ massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)
+ let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)
loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id
go (dll:dlls) = do
@@ -194,12 +190,12 @@ lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
go loaded_dlls
-linkFail :: String -> String -> IO a
+linkFail :: String -> SDoc -> IO a
linkFail who what
= throwGhcExceptionIO (ProgramError $
unlines [ "",who
, "During interactive linking, GHCi couldn't find the following symbol:"
- , ' ' : ' ' : what
+ , ' ' : ' ' : showSDocUnsafe what
, "This may be due to you not asking GHCi to load extra object files,"
, "archives or DLLs needed by your current session. Restart GHCi, specifying"
, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
@@ -210,28 +206,8 @@ linkFail who what
])
-nameToCLabel :: Name -> String -> FastString
-nameToCLabel n suffix = mkFastStringByteString label
- where
- 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.
- mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
- mod -> mod
- packagePart = encodeZ (unitFS pkgKey)
- modulePart = encodeZ (moduleNameFS modName)
- occPart = encodeZ $ occNameMangledFS (nameOccName n)
-
- label = mconcat $
- [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
- ++
- [modulePart
- , "_"
- , occPart
- , "_"
- , fromString suffix
- ]
+
+
-- See Note [Primop wrappers] in GHC.Builtin.PrimOps
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2901,7 +2901,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots
-- look up "id_sym" closure and create a StablePtr (HValue) from it
- href <- lookupClosure interp (unpackFS id_sym) >>= \case
+ href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case
Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)
Just r -> pure r
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -217,12 +217,12 @@ loadName interp hsc_env name = do
case lookupNameEnv (closure_env (linker_env pls)) name of
Just (_,aa) -> return (pls,(aa, links, pkgs))
Nothing -> assertPpr (isExternalName name) (ppr name) $
- do let sym_to_find = nameToCLabel name "closure"
- m <- lookupClosure interp (unpackFS sym_to_find)
+ do let sym_to_find = IClosureSymbol name
+ m <- lookupClosure interp sym_to_find
r <- case m of
Just hvref -> mkFinalizedHValue interp hvref
Nothing -> linkFail "GHC.Linker.Loader.loadName"
- (unpackFS sym_to_find)
+ (ppr sym_to_find)
return (pls,(r, links, pkgs))
loadDependencies
@@ -909,7 +909,7 @@ dynLoadObjs interp hsc_env pls at LoaderState{..} objs = do
m <- loadDLL interp soFile
case m of
Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
- Left err -> linkFail msg err
+ Left err -> linkFail msg (text err)
where
msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
=====================================
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/Runtime/Interpreter.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
-- | Interacting with the iserv interpreter, whether it is running on an
-- external process or in the current process.
@@ -83,7 +84,6 @@ import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Utils.Panic
@@ -116,6 +116,12 @@ import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Directory
import System.Process
+import GHC.Builtin.Names
+import GHC.Types.Name
+
+-- Standard libraries
+import GHC.Exts
+
{- Note [Remote GHCi]
~~~~~~~~~~~~~~~~~~
When the flag -fexternal-interpreter is given to GHC, interpreted code
@@ -457,38 +463,65 @@ handleSeqHValueStatus interp unit_env eval_status =
initObjLinker :: Interp -> IO ()
initObjLinker interp = interpCmd interp InitLinker
-lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
+ sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
+ sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
-lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS str))
+ sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
-lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
+interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString
+interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is ->
+ let
+ n = interpSymbolName is
+ suffix = interpSymbolSuffix is
+
+ 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.
+ mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
+ mod -> mod
+ packagePart = encodeZ (unitFS pkgKey)
+ modulePart = encodeZ (moduleNameFS modName)
+ occPart = encodeZ $ occNameMangledFS (nameOccName n)
+
+ label = mconcat $
+ [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
+ ++
+ [modulePart
+ , "_"
+ , occPart
+ , "_"
+ , fromString suffix
+ ]
+ in mkFastStringByteString label
+
+lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure str)
+ interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
@@ -496,7 +529,7 @@ lookupClosure interp str =
-- a miss we run the action which determines the symbol's address and populate
-- the cache with the answer.
withSymbolCache :: Interp
- -> FastString
+ -> InterpSymbol s
-- ^ The symbol we are looking up in the cache
-> IO (Maybe (Ptr ()))
-- ^ An action which determines the address of the symbol we
@@ -513,21 +546,19 @@ withSymbolCache interp str determine_addr = do
-- The analysis in #23415 further showed this cache should also benefit the
-- internal interpreter's loading times, and needn't be used by the external
-- interpreter only.
- cache <- readMVar (interpLookupSymbolCache interp)
- case lookupUFM cache str of
- Just p -> return (Just p)
+ cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp)
+ case cached_val of
+ Just {} -> return cached_val
Nothing -> do
-
maddr <- determine_addr
case maddr of
Nothing -> return Nothing
Just p -> do
- let upd_cache cache' = addToUFM cache' str p
- modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)
- return (Just p)
+ updateInterpSymbolCache str (interpSymbolCache interp) p
+ return maddr
purgeLookupSymbolCache :: Interp -> IO ()
-purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))
+purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp)
-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Types used by the runtime interpreter
module GHC.Runtime.Interpreter.Types
@@ -10,6 +12,20 @@ module GHC.Runtime.Interpreter.Types
, ExtInterpInstance (..)
, ExtInterpState (..)
, InterpStatus(..)
+ -- * InterpSymbolCache
+ , InterpSymbolCache(..)
+ , mkInterpSymbolCache
+ , lookupInterpSymbolCache
+ , updateInterpSymbolCache
+ , purgeInterpSymbolCache
+ , InterpSymbol(..)
+ , SuffixOrInterpreted(..)
+ , interpSymbolName
+ , interpSymbolSuffix
+ , eliminateInterpSymbol
+ , interpretedInterpSymbol
+
+
-- * IServ
, IServ
, IServConfig(..)
@@ -30,9 +46,6 @@ import GHC.Linker.Types
import GHCi.RemoteTypes
import GHCi.Message ( Pipe )
-import GHC.Types.Unique.FM
-import GHC.Data.FastString ( FastString )
-import Foreign
import GHC.Platform
import GHC.Utils.TmpFs
@@ -42,6 +55,7 @@ import GHC.Unit.State
import GHC.Unit.Types
import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Types
+import GHC.Runtime.Interpreter.Types.SymbolCache
import Control.Concurrent
import System.Process ( ProcessHandle, CreateProcess )
@@ -56,7 +70,7 @@ data Interp = Interp
, interpLoader :: !Loader
-- ^ Interpreter loader
- , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
+ , interpSymbolCache :: !InterpSymbolCache
-- ^ LookupSymbol cache
}
=====================================
compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
=====================================
@@ -0,0 +1,142 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | The SymbolCache is used to cache lookups for specific symbols when using
+-- the interpreter.
+module GHC.Runtime.Interpreter.Types.SymbolCache (
+ InterpSymbolCache(..)
+ , mkInterpSymbolCache
+ , lookupInterpSymbolCache
+ , updateInterpSymbolCache
+ , purgeInterpSymbolCache
+ , InterpSymbol(..)
+ , SuffixOrInterpreted(..)
+ , interpSymbolName
+ , interpSymbolSuffix
+ , eliminateInterpSymbol
+ , interpretedInterpSymbol
+ ) where
+
+import GHC.Prelude
+
+import GHC.Types.Unique.FM
+import GHC.Types.Name
+import GHC.Data.FastString
+import Foreign
+
+import Control.Concurrent
+import GHC.Utils.Outputable
+import GHC.TypeLits
+
+
+-- The symbols records the suffix which each cache deals with.
+newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) }
+
+-- Each cache is keyed by Name, there is one cache for each type of symbol we will
+-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult
+-- a complicated `FastString` each time.
+data InterpSymbolCache = InterpSymbolCache {
+ interpClosureCache :: MVar (SymbolCache "closure")
+ , interpConInfoCache :: MVar (SymbolCache "con_info")
+ , interpStaticInfoCache :: MVar (SymbolCache "static_info")
+ , interpBytesCache :: MVar (SymbolCache "bytes")
+ , interpFaststringCache :: MVar (UniqFM FastString (Ptr ()))
+ }
+
+data SuffixOrInterpreted = Suffix Symbol | Interpreted
+
+data InterpSymbol (s :: SuffixOrInterpreted) where
+ IClosureSymbol :: Name -> InterpSymbol (Suffix "closure")
+ IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info")
+ IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info")
+ IBytesSymbol :: Name -> InterpSymbol (Suffix "bytes")
+ IFaststringSymbol :: FastString -> InterpSymbol Interpreted
+
+instance Outputable (InterpSymbol s) where
+ ppr s = eliminateInterpSymbol s
+ (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s)
+ (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s))
+
+eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r)
+ -> (forall x . InterpSymbol (Suffix x) -> r)
+ -> r
+eliminateInterpSymbol s k1 k2 =
+ case s of
+ IFaststringSymbol {} -> k1 s
+ IBytesSymbol {} -> k2 s
+ IStaticInfoSymbol {} -> k2 s
+ IConInfoSymbol {} -> k2 s
+ IClosureSymbol {} -> k2 s
+
+
+interpSymbolName :: InterpSymbol (Suffix s) -> Name
+interpSymbolName (IClosureSymbol n) = n
+interpSymbolName (IConInfoSymbol n) = n
+interpSymbolName (IStaticInfoSymbol n) = n
+interpSymbolName (IBytesSymbol n) = n
+
+interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString
+interpretedInterpSymbol (IFaststringSymbol s) = s
+
+interpSymbolSuffix :: InterpSymbol (Suffix s) -> String
+interpSymbolSuffix (IClosureSymbol {}) = "closure"
+interpSymbolSuffix (IConInfoSymbol {}) = "con_info"
+interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info"
+interpSymbolSuffix (IBytesSymbol {}) = "bytes"
+
+emptySymbolCache :: SymbolCache s
+emptySymbolCache = SymbolCache emptyUFM
+
+lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ())
+lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s)
+
+insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s
+insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v)
+
+lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ()))
+lookupInterpSymbolCache = withInterpSymbolCache
+ (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var)
+ (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var)
+
+
+updateInterpSymbolCache :: InterpSymbol s
+ -> InterpSymbolCache -> Ptr () -> IO ()
+updateInterpSymbolCache = withInterpSymbolCache
+ (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v))
+ (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache))
+
+withInterpSymbolCache ::
+ (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r)
+ -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r)
+ -> InterpSymbol s
+ -> InterpSymbolCache
+ -> r
+withInterpSymbolCache k1 k2 key InterpSymbolCache{..} =
+ case key of
+ IClosureSymbol {} -> k2 key interpClosureCache
+ IConInfoSymbol {} -> k2 key interpConInfoCache
+ IStaticInfoSymbol {} -> k2 key interpStaticInfoCache
+ IBytesSymbol {} -> k2 key interpBytesCache
+ IFaststringSymbol {} -> k1 key interpFaststringCache
+
+-- | Clear all symbol caches.
+purgeInterpSymbolCache :: InterpSymbolCache -> IO ()
+purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do
+ modifyMVar_ a (\_ -> do
+ modifyMVar_ b (\_ -> do
+ modifyMVar_ c (\_ -> do
+ modifyMVar_ d (\_ -> do
+ modifyMVar_ e (\_ -> pure emptyUFM)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+
+mkInterpSymbolCache :: IO InterpSymbolCache
+mkInterpSymbolCache = do
+ InterpSymbolCache <$> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptyUFM
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -777,17 +777,18 @@ There is also the possibility of mentioning a wildcard
-}
-tcFamTyPats :: TyCon
+tcFamTyPats :: (Maybe SkolemInfo)
+ -> TyCon
-> HsFamEqnPats GhcRn -- Patterns
-> TcM (TcType, TcKind) -- (lhs_type, lhs_kind)
-- Check the LHS of a type/data family instance
-- e.g. type instance F ty1 .. tyn = ...
-- Used for both type and data families
-tcFamTyPats fam_tc hs_pats
+tcFamTyPats skol_info fam_tc hs_pats
= do { traceTc "tcFamTyPats {" $
vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]
- ; mode <- mkHoleMode TypeLevel HM_FamPat
+ ; mode <- mkHoleMode TypeLevel (HM_FamPat skol_info)
-- HM_FamPat: See Note [Wildcards in family instances] in
-- GHC.Rename.Module
; let fun_ty = mkTyConApp fam_tc []
@@ -967,7 +968,7 @@ type HoleInfo = Maybe (TcLevel, HoleMode)
-- HoleMode says how to treat the occurrences
-- of anonymous wildcards; see tcAnonWildCardOcc
data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int
- | HM_FamPat -- Family instances: F _ Int = Bool
+ | HM_FamPat (Maybe SkolemInfo) -- Family instances: F _ Int = Bool
| HM_VTA -- Visible type and kind application:
-- f @(Maybe _)
-- Maybe @(_ -> _)
@@ -990,10 +991,10 @@ mkHoleMode tyki hm
, mode_holes = Just (lvl,hm) }) }
instance Outputable HoleMode where
- ppr HM_Sig = text "HM_Sig"
- ppr HM_FamPat = text "HM_FamPat"
- ppr HM_VTA = text "HM_VTA"
- ppr HM_TyAppPat = text "HM_TyAppPat"
+ ppr HM_Sig = text "HM_Sig"
+ ppr (HM_FamPat _) = text "HM_FamPat"
+ ppr HM_VTA = text "HM_VTA"
+ ppr HM_TyAppPat = text "HM_TyAppPat"
instance Outputable TcTyMode where
ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })
@@ -2212,7 +2213,7 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
-- esp the bullet on nested forall types
= do { kv_details <- newTauTvDetailsAtLevel hole_lvl
; kv_name <- newMetaTyVarName (fsLit "k")
- ; wc_details <- newTauTvDetailsAtLevel hole_lvl
+ ; wc_details <- mk_wc_details
; wc_name <- newMetaTyVarName wc_nm
; let kv = mkTcTyVar kv_name liftedTypeKind kv_details
wc_kind = mkTyVarTy kv
@@ -2230,17 +2231,21 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
-- so we have to do it properly (T14140a)
; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }
where
+ -- make sure we align with none-wild card type variables
+ mk_wc_details = case hole_mode of
+ HM_FamPat (Just skol_info) -> return $ SkolemTv skol_info hole_lvl False
+ _ -> newTauTvDetailsAtLevel hole_lvl
-- See Note [Wildcard names]
wc_nm = case hole_mode of
HM_Sig -> fsLit "w"
- HM_FamPat -> fsLit "_"
+ HM_FamPat _ -> fsLit "_"
HM_VTA -> fsLit "w"
HM_TyAppPat -> fsLit "_"
emit_holes = case hole_mode of
- HM_Sig -> True
- HM_FamPat -> False
- HM_VTA -> False
+ HM_Sig -> True
+ HM_FamPat _ -> False
+ HM_VTA -> False
HM_TyAppPat -> False
tcAnonWildCardOcc is_extra _ _ _
=====================================
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
@@ -3253,7 +3253,7 @@ kcTyFamInstEqn tc_fam_tc
; discardResult $
bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $
- do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
+ do { (_fam_app, res_kind) <- tcFamTyPats Nothing tc_fam_tc hs_pats
; tcCheckLHsTypeInContext hs_rhs_ty (TheKind res_kind) }
-- Why "_Tv" here? Consider (#14066)
-- type family Bar x y where
@@ -3275,7 +3275,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
, feqn_rhs = hs_rhs_ty }))
= setSrcSpanA loc $
do { traceTc "tcTyFamInstEqn" $
- vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats
+ vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats <+> ppr outer_bndrs
, text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
, case mb_clsinfo of
NotAssociated {} -> empty
@@ -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.
-}
@@ -3402,7 +3430,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty)))
<- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $
bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $
- do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
+ do { (lhs_ty, rhs_kind) <- tcFamTyPats (Just skol_info) fam_tc hs_pats
-- Ensure that the instance is consistent with its
-- parent class (#16008)
; addConsistencyConstraints mb_clsinfo lhs_ty
@@ -3423,7 +3451,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
-- See Note [Generalising in tcTyFamInstEqnGuts]
; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty
- ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
+ ; qtvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs
; 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]
@@ -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]
@@ -933,7 +933,7 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
<- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $
bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs $ -- Binds skolem TcTyVars
do { stupid_theta <- tcHsContext hs_ctxt
- ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
+ ; (lhs_ty, lhs_kind) <- tcFamTyPats (Just skol_info) fam_tc hs_pats
; (lhs_applied_ty, lhs_applied_kind)
<- tcInstInvisibleTyBinders lhs_ty lhs_kind
-- See Note [Data family/instance return kinds]
@@ -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/GHC/Types/Error.hs
=====================================
@@ -298,8 +298,8 @@ data UnknownDiagnostic opts hint where
type UnknownDiagnosticFor a = UnknownDiagnostic (DiagnosticOpts a) (DiagnosticHint a)
instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (UnknownDiagnostic opts hint) where
- type DiagnosticOpts (UnknownDiagnostic opts _) = opts
- type DiagnosticHint (UnknownDiagnostic _ hint) = hint
+ type DiagnosticOpts (UnknownDiagnostic opts hint) = opts
+ type DiagnosticHint (UnknownDiagnostic opts hint) = hint
diagnosticMessage opts (UnknownDiagnostic f _ diag) = diagnosticMessage (f opts) diag
diagnosticReason (UnknownDiagnostic _ _ diag) = diagnosticReason diag
diagnosticHints (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag)
=====================================
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),
=====================================
compiler/ghc.cabal.in
=====================================
@@ -699,6 +699,7 @@ Library
GHC.Runtime.Interpreter.JS
GHC.Runtime.Interpreter.Process
GHC.Runtime.Interpreter.Types
+ GHC.Runtime.Interpreter.Types.SymbolCache
GHC.Runtime.Interpreter.Wasm
GHC.Runtime.Loader
GHC.Runtime.Utils
=====================================
rts/Interpreter.c
=====================================
@@ -182,6 +182,8 @@ int rts_stop_on_exception = 0;
#if defined(INTERP_STATS)
+#define N_CODES 128
+
/* Hacky stats, for tuning the interpreter ... */
int it_unknown_entries[N_CLOSURE_TYPES];
int it_total_unknown_entries;
@@ -195,8 +197,8 @@ int it_slides;
int it_insns;
int it_BCO_entries;
-int it_ofreq[27];
-int it_oofreq[27][27];
+int it_ofreq[N_CODES];
+int it_oofreq[N_CODES][N_CODES];
int it_lastopc;
@@ -210,9 +212,9 @@ void interp_startup ( void )
for (i = 0; i < N_CLOSURE_TYPES; i++)
it_unknown_entries[i] = 0;
it_slides = it_insns = it_BCO_entries = 0;
- for (i = 0; i < 27; i++) it_ofreq[i] = 0;
- for (i = 0; i < 27; i++)
- for (j = 0; j < 27; j++)
+ for (i = 0; i < N_CODES; i++) it_ofreq[i] = 0;
+ for (i = 0; i < N_CODES; i++)
+ for (j = 0; j < N_CODES; j++)
it_oofreq[i][j] = 0;
it_lastopc = 0;
}
@@ -234,14 +236,14 @@ void interp_shutdown ( void )
}
debugBelch("%d insns, %d slides, %d BCO_entries\n",
it_insns, it_slides, it_BCO_entries);
- for (i = 0; i < 27; i++)
+ for (i = 0; i < N_CODES; i++)
debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
for (k = 1; k < 20; k++) {
o_max = 0;
i_max = j_max = 0;
- for (i = 0; i < 27; i++) {
- for (j = 0; j < 27; j++) {
+ for (i = 0; i < N_CODES; i++) {
+ for (j = 0; j < N_CODES; j++) {
if (it_oofreq[i][j] > o_max) {
o_max = it_oofreq[i][j];
i_max = i; j_max = j;
@@ -259,6 +261,12 @@ void interp_shutdown ( void )
#else // !INTERP_STATS
+void interp_startup( void ){
+}
+
+void interp_shutdown( void ){
+}
+
#define INTERP_TICK(n) /* nothing */
#endif
@@ -419,7 +427,7 @@ eval:
eval_obj:
obj = UNTAG_CLOSURE(tagged_obj);
- INTERP_TICK(it_total_evals);
+ INTERP_TICK(it_total_entries);
IF_DEBUG(interpreter,
debugBelch(
@@ -1098,7 +1106,7 @@ run_BCO:
INTERP_TICK(it_insns);
#if defined(INTERP_STATS)
- ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
+ ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < N_CODES );
it_ofreq[ (int)instrs[bciPtr] ] ++;
it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
it_lastopc = (int)instrs[bciPtr];
=====================================
rts/Interpreter.h
=====================================
@@ -9,3 +9,5 @@
#pragma once
RTS_PRIVATE Capability *interpretBCO (Capability* cap);
+void interp_startup ( void );
+void interp_shutdown ( void );
=====================================
rts/RtsMain.c
=====================================
@@ -17,6 +17,7 @@
#include "Prelude.h"
#include "Task.h"
#include "Excn.h"
+#include "Interpreter.h"
#if defined(DEBUG)
# include "Printer.h" /* for printing */
@@ -56,6 +57,8 @@ int hs_main ( int argc, char *argv[], // program args
hs_init_ghc(&argc, &argv, rts_config);
+ interp_startup();
+
BEGIN_WINDOWS_VEH_HANDLER
// kick off the computation by creating the main thread with a pointer
@@ -96,6 +99,8 @@ int hs_main ( int argc, char *argv[], // program args
END_WINDOWS_VEH_HANDLER
+ interp_shutdown();
+
shutdownHaskellAndExit(exit_status, 0 /* !fastExit */);
// No code beyond this point. Dead code elimination will remove it
}
=====================================
testsuite/tests/indexed-types/should_compile/T17536.hs
=====================================
@@ -28,3 +28,27 @@ type family M m where
g :: M One -> Int
g x = x
+
+
+-- make sure wildcard and non-wildcard type variables are treated the same
+
+type R1 :: RuntimeRep -> Type
+type family R1 r where
+ R1 r = Int
+
+r1 :: R1 FloatRep -> Int
+r1 x = x
+
+type L1 :: Levity -> Type
+type family L1 l where
+ L1 l = Int
+
+l1 :: L1 Unlifted -> Int
+l1 x = x
+
+type M1 :: Multiplicity -> Type
+type family M1 m where
+ M1 m = Int
+
+g1 :: M1 One -> Int
+g1 x = x
=====================================
testsuite/tests/indexed-types/should_compile/T17536c.hs
=====================================
@@ -15,3 +15,11 @@ type family R r a where
r :: R FloatRep Float# -> Int
r x = x
+
+-- make sure wildcard and non-wildcard type variables are treated the same
+type R1 :: forall (r :: RuntimeRep) -> TYPE r -> Type
+type family R1 r a where
+ R1 r a = Int
+
+r1 :: R1 FloatRep Float# -> Int
+r1 x = x
=====================================
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/indexed-types/should_fail/T9357.stderr
=====================================
@@ -1,4 +1,4 @@
T9357.hs:12:15: error: [GHC-91510]
- • Illegal polymorphic type: forall (a :: TYPE t). a -> a
+ Illegal polymorphic type: forall a. a -> a
• In the type family instance declaration for ‘F’
=====================================
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/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,82 @@
+{-# 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
+
+data family Dix7 :: (k -> TYPE 'IntRep) -> k
+newtype instance Dix7 f = DIn7 (f (Dix7 f))
+
+
+-- user written wildcards
+type Dix8 :: RuntimeRep -> Type
+data family Dix8 r
+newtype instance Dix8 _ = Dix8 Int
+
+dix8 :: Dix8 FloatRep -> Int
+dix8 (Dix8 x) = x
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/602f6072d5fd8039e918ab77b7adde54d5cd5312...ccc9152f23177ab7a542852ffedf626edcdcef95
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/602f6072d5fd8039e918ab77b7adde54d5cd5312...ccc9152f23177ab7a542852ffedf626edcdcef95
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/20250207/ee33506b/attachment-0001.html>
More information about the ghc-commits
mailing list