01 Nov '26
Mikolaj Konarski pushed new branch wip/T27981-ncg-mw-hybrid at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T27981-ncg-mw-hybrid
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-32
by Alan Zimmerman (＠alanz) 31 Oct '26
by Alan Zimmerman (＠alanz) 31 Oct '26
31 Oct '26
Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-32 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-32
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] gitmodules: ignore dirty libffi-clib submodule (#26785)
by Marge Bot (＠marge-bot) 31 Oct '26
by Marge Bot (＠marge-bot) 31 Oct '26
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3594a908 by Sylvain Henry at 2026-10-31T09:23:51-04:00
gitmodules: ignore dirty libffi-clib submodule (#26785)
`./boot` runs autoreconf in libraries/libffi-clib, which leaves
`configure~` behind and rewrites the tracked `aclocal.m4` whenever the
local automake version differs from the one that generated it. Every
checkout then looks dirty. Ignore working-tree changes in the submodule
(`ignore = dirty`); a changed submodule commit is still reported.
Co-Authored-By: Claude Fable 5.1 <noreply(a)anthropic.com>
- - - - -
1 changed file:
- .gitmodules
Changes:
=====================================
.gitmodules
=====================================
@@ -122,3 +122,4 @@
[submodule "libraries/libffi-clib"]
path = libraries/libffi-clib
url = https://gitlab.haskell.org/ghc/libffi-clib.git
+ ignore = dirty
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3594a9084c1f0ac1c523d9830db31be…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3594a9084c1f0ac1c523d9830db31be…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
233cce46 by Alan Zimmerman at 2026-10-31T09:23:01-04:00
EPA: Tidy up ExactPrint.markAnnListA'
It takes an action which can modify the AnnList, but this
is never used. So remove it.
- - - - -
1 changed file:
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1486,9 +1486,7 @@ markAnnList ann action = do
markAnnList' :: (Monad m, Monoid w)
=> AnnList -> EP w m a -> EP w m (AnnList, a)
markAnnList' ann action = do
- markAnnListA' ann $ \a -> do
- r <- action
- return (a,r)
+ markAnnListA' ann $ action
markAnnListA :: (Monad m, Monoid w)
=> EpAnn AnnList
@@ -1503,14 +1501,14 @@ markAnnListA an action = do
markAnnListA' :: (Monad m, Monoid w)
=> AnnList
- -> (AnnList -> EP w m (AnnList, a))
+ -> EP w m a
-> EP w m (AnnList, a)
markAnnListA' an action = do
an0 <- markLensBracketsO' an lal_brackets
an1 <- markEpAnnAllLT' an0 lal_semis
- (an2, r) <- action an1
- an3 <- markLensBracketsC' an2 lal_brackets
- return (an3, r)
+ r <- action
+ an2 <- markLensBracketsC' an1 lal_brackets
+ return (an2, r)
-- ---------------------------------------------------------------------
@@ -2413,9 +2411,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where
, cid_modifiers = mods })
= do
(mbWarn', i', w', mbOverlap', inst_ty', mods') <- top_matter
- (ann_list', decls') <- markAnnListA' ann_list $ \a -> do
- r <- setLayoutBoth $ mapM markAnnotated decls
- return (a,r)
+ (ann_list', decls') <- markAnnListA' ann_list $ setLayoutBoth $ mapM markAnnotated decls
return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' ann_list')
, cid_poly_ty = inst_ty'
, cid_decls = decls'
@@ -3336,9 +3332,7 @@ markMaybeDodgyStmts (an,l) stmts =
c' <- markEpToken c
return (Left (o',c'), r)
Right an' -> do
- (an'',r') <- markAnnListA' an' $ \a -> do
- r <- markAnnotatedWithLayout stmts
- return (a, r)
+ (an'',r') <- markAnnListA' an' $ markAnnotatedWithLayout stmts
return (Right an'',r')
return ((an0, l), stmts')
else return ((an, l), stmts)
@@ -3411,9 +3405,7 @@ instance (Typeable body,
= MG (origin,an) (L (setAnchorEpa l anc ts cs) matches)
exact (MG (origin,an) (L l matches)) = do
- (an0,matches') <- markAnnListA' an $ \a -> do
- m' <- markAnnotated matches
- return (a,m')
+ (an0,matches') <- markAnnListA' an $ markAnnotated matches
return (MG (origin, an0) (L l matches'))
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/233cce4652a8100c6701b946955430b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/233cce4652a8100c6701b946955430b…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] refactor: Keep the interactive Ids directly rather than Name
by Marge Bot (＠marge-bot) 31 Oct '26
by Marge Bot (＠marge-bot) 31 Oct '26
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
341223c0 by Rodrigo Mesquita at 2026-10-31T09:24:33-04:00
refactor: Keep the interactive Ids directly rather than Name
Removes things like
names <- map idName ids
map (\i -> let id = find (\x -> i==idName x) names) idso
and is more straightforward because there's less state going around (no
more updating HscEnv as an output)
It also kills `printTypeOfNames` completely, since now we just have the
Ids. No longer `lookupName` names to get back the ids...
```
printTypeOfName :: GHC.GhcMonad m => Name -> m ()
printTypeOfName n
= do maybe_tything <- GHC.lookupName n
case maybe_tything of
Nothing -> return ()
Just thing -> printTyThing thing
```
now is just `printTyThing . AnId`
Also:
```diff
- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
- docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
+ docs <- mapM pprTypeAndContents idsSorted
```
(and yes, in ExecBreaks there are only Ids, no TyThings, bc they are
only constructed by the interpreter execution which can only bind ids.
for TyThings use runDecls which doesn't return execBreaks.)
There's some care to be had to make sure we use the "most refined" Ids,
whereas when using `Name`s we'd always fetch the most refined Id from
scratch.
Fixes #28052
- - - - -
12 changed files:
- + changelog.d/ghc-api-interactive-ids
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- + testsuite/tests/ghci.debugger/scripts/RttiSharedTyVar.hs
- + testsuite/tests/ghci.debugger/scripts/RttiSharedTyVar.script
- + testsuite/tests/ghci.debugger/scripts/RttiSharedTyVar.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
Changes:
=====================================
changelog.d/ghc-api-interactive-ids
=====================================
@@ -0,0 +1,15 @@
+section: ghc-lib
+synopsis: The GHCi evaluation API now returns ``Id``\s and ``TyThing``\s rather than ``Name``\s
+issues: #28052
+mrs: !16883
+
+description: {
+The results of interactive evaluation are now returned directly, rather than as
+``Name``\s that had to be looked up again in the interactive context:
+
+- ``ExecComplete``'s ``execResult`` and ``ExecBreak``'s ``breakNames`` now hold ``[Id]``.
+- ``runDecls``, ``runDeclsWithLocation`` and ``runParsedDecls`` now return ``[TyThing]`` rather than ``[Name]``.
+- ``rttiEnvironment`` now returns a Subst with the inferred types.
+
+The returned ``Id``\s carry the types refined by runtime type inference.
+}
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -6,6 +6,8 @@ module GHC.Runtime.Context
, extendInteractiveContextWithIds
, setInteractivePrintName
, substInteractiveContext
+ , substInteractiveTyThing
+ , substInteractiveId
, replaceImportEnv
, icReaderEnv
, icExtendGblRdrEnv
@@ -496,15 +498,18 @@ icExtendGblRdrEnv drop_only_qualified env tythings
substInteractiveContext :: InteractiveContext -> Subst -> InteractiveContext
substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
| isEmptyTCvSubst subst = ictxt
- | otherwise = ictxt { ic_tythings = map subst_ty tts }
- where
- subst_ty (AnId id)
- = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id
- -- Variables in the interactive context *can* mention free type variables
- -- because of the runtime debugger. Otherwise you'd expect all
- -- variables bound in the interactive context to be closed.
- subst_ty tt
- = tt
+ | otherwise = ictxt { ic_tythings = map (substInteractiveTyThing subst) tts }
+
+substInteractiveTyThing :: Subst -> TyThing -> TyThing
+substInteractiveTyThing subst (AnId id) = AnId $ substInteractiveId subst id
+substInteractiveTyThing _ tt = tt
+
+substInteractiveId :: Subst -> Id -> Id
+substInteractiveId subst id =
+ -- Variables in the interactive context *can* mention free type variables
+ -- because of the runtime debugger. Otherwise you'd expect all
+ -- variables bound in the interactive context to be closed.
+ updateIdTypeAndMult (substTyAddInScope subst) id
instance Outputable InteractiveImport where
ppr (IIModule m) = char '*' <> ppr m
=====================================
compiler/GHC/Runtime/Debugger.hs
=====================================
@@ -121,8 +121,7 @@ pprintClosureCommand bindThings force str = do
-- Then, we extract a substitution,
-- mapping the old tyvars to the reconstructed types.
let reconstructed_type = termType term
- hsc_env <- getSession
- case (improveRTTIType hsc_env id_ty' reconstructed_type) of
+ case improveRTTIType id_ty' reconstructed_type of
Nothing -> return (subst, term')
Just subst' -> do { logger <- getLogger
; liftIO $
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -131,7 +131,7 @@ import GHC.ByteCode.Breakpoints
import Control.Monad
import Data.Dynamic
import Data.IntMap (IntMap)
-import Data.List (find,intercalate)
+import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import Unsafe.Coerce ( unsafeCoerce )
import qualified GHC.Unit.Home.Graph as HUG
@@ -241,12 +241,12 @@ execStmt' stmt stmt_text ExecOptions{..} = do
handleRunStatus execSingleStep stmt_text bindings ids
status (emptyHistory size)
-runDecls :: GhcMonad m => String -> m [Name]
+runDecls :: GhcMonad m => String -> m [TyThing]
runDecls = runDeclsWithLocation "<interactive>" 1
-- | Run some declarations and return any user-visible names that were brought
-- into scope.
-runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
+runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [TyThing]
runDeclsWithLocation source line_num input = do
hsc_env <- getSession
decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
@@ -255,18 +255,18 @@ runDeclsWithLocation source line_num input = do
-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
-- (see GHCi.UI.runStmt).
-runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
+runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [TyThing]
runParsedDecls decls = do
- hsc_env <- getSession
- (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
-
+ hsc_env <- getSession
+ (tyThings, ic) <- liftIO $ hscParsedDecls hsc_env decls
setSession $ hsc_env { hsc_IC = ic }
hsc_env <- getSession
- hsc_env' <- liftIO $ rttiEnvironment hsc_env
+ (hsc_env', subst) <- liftIO $ rttiEnvironment hsc_env
setSession hsc_env'
- return $ filter (not . isDerivedOccName . nameOccName)
+ return $ map (substInteractiveTyThing subst)
+ $ filter (not . isDerivedOccName . nameOccName . getName)
-- For this filter, see Note [What to show to users]
- $ map getName tyThings
+ $ tyThings
{- Note [What to show to users]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -310,9 +310,10 @@ handleRunStatus step expr bindings final_ids status history0 = do
final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
final_names = map getName final_ids
liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals)
- hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+ (hsc_env', subst) <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+ let improved_final_ids = map (substInteractiveId subst) final_ids
setSession hsc_env'
- return (ExecComplete (Right final_names) allocs)
+ return (ExecComplete (Right improved_final_ids) allocs)
-- Completed with an exception
EvalComplete alloc (EvalException e) ->
@@ -323,7 +324,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
let span = mkGeneralSrcSpan (fsLit "<unknown>")
- (hsc_env1, names) <- liftIO $
+ (hsc_env1, break_ids) <- liftIO $
bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing
let
resume = Resume
@@ -342,7 +343,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
hsc_env2 = pushResume hsc_env1 resume
setSession hsc_env2
- return (ExecBreak names Nothing)
+ return (ExecBreak break_ids Nothing)
-- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint
--
@@ -370,7 +371,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- This function only returns control to ghci with 'ExecBreak' when it is really meant to break.
-- Specifically, for :steplocal or :stepmodule, don't return control
-- and simply resume execution from here until we hit a breakpoint we do want to stop at.
- (hsc_env1, names) <- liftIO $
+ (hsc_env1, break_ids) <- liftIO $
bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi)
let
resume = Resume
@@ -388,7 +389,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
}
hsc_env2 = pushResume hsc_env1 resume
setSession hsc_env2
- return (ExecBreak names (Just ibi))
+ return (ExecBreak break_ids (Just ibi))
else do
-- resume with the same step type
let eval_opts = initEvalOpts dflags (enableGhcStepMode step)
@@ -491,13 +492,13 @@ getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do
( ld_st'
, ba
)
-back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
+back :: GhcMonad m => Int -> m ([Id], Int, SrcSpan)
back n = moveHist (+n)
-forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
+forward :: GhcMonad m => Int -> m ([Id], Int, SrcSpan)
forward n = moveHist (subtract n)
-moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Id], Int, SrcSpan)
moveHist fn = do
hsc_env <- getSession
case ic_resume (hsc_IC hsc_env) of
@@ -521,7 +522,7 @@ moveHist fn = do
let hug = hsc_HUG hsc_env
brks <- readIModBreaks hug ibi
getBreakLoc (readIModModBreaks hug) ibi brks
- (hsc_env1, names) <-
+ (hsc_env1, final_ids) <-
liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info
let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
@@ -529,7 +530,7 @@ moveHist fn = do
setSession hsc_env1{ hsc_IC = ic' }
- return (names, new_ix, span)
+ return (final_ids, new_ix, span)
-- careful: we want apStack to be the AP_STACK itself, not a thunk
-- around it, hence the cases are carefully constructed below to
@@ -555,7 +556,7 @@ bindLocalsAtBreakpoint
-> ForeignHValue
-> SrcSpan
-> Maybe InternalBreakpointId
- -> IO (HscEnv, [Name])
+ -> IO (HscEnv, [Id])
-- Nothing case: we stopped when an exception was raised, not at a
-- breakpoint. We have no location information or local variables to
@@ -575,7 +576,7 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
interp = hscInterp hsc_env
--
Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(exn_name, apStack)]
- return (hsc_env{ hsc_IC = ictxt1 }, [exn_name])
+ return (hsc_env{ hsc_IC = ictxt1 }, [exn_id])
-- Just case: we stopped at a breakpoint, we have information about the location
-- of the breakpoint and the free variables of the expression.
@@ -635,8 +636,9 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
let fhvs = catMaybes mb_hValues
Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs)
when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)]
- hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
- return (hsc_env1, if result_ok then result_name:names else names)
+ (hsc_env1, subst) <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
+ let improved_final_ids = map (substInteractiveId subst) final_ids
+ return (hsc_env1, improved_final_ids)
where
-- We need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings
@@ -676,34 +678,33 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do
joinOccs = zipWithEqual joinOcc
joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc
-rttiEnvironment :: HscEnv -> IO HscEnv
+rttiEnvironment :: HscEnv -> IO (HscEnv, Subst)
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let tmp_ids = [id | AnId id <- ic_tythings ic]
incompletelyTypedIds =
[id | id <- tmp_ids
, not $ noSkolems id
, (occNameFS.nameOccName.idName) id /= result_fs]
- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+ foldM improveTypes (hsc_env, emptySubst) incompletelyTypedIds
where
noSkolems = noFreeVarsOfType . idType
- improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
- let tmp_ids = [id | AnId id <- ic_tythings ic]
- id = expectJust $ find (\i -> idName i == name) tmp_ids
+ improveTypes (hsc_env@HscEnv{hsc_IC=ic}, last_subst) id0 = do
+ let id = substInteractiveId last_subst id0
if noSkolems id
- then return hsc_env
+ then return (hsc_env, last_subst)
else do
mb_new_ty <- reconstructType hsc_env 10 id
let old_ty = idType id
case mb_new_ty of
- Nothing -> return hsc_env
+ Nothing -> return (hsc_env, last_subst)
Just new_ty -> do
- case improveRTTIType hsc_env old_ty new_ty of
+ case improveRTTIType old_ty new_ty of
Nothing -> warnPprTrace True (":print failed to calculate the "
++ "improvement for a type")
(vcat [ text "id" <+> ppr id
, text "old_ty" <+> debugPprType old_ty
, text "new_ty" <+> debugPprType new_ty ]) $
- return hsc_env
+ return (hsc_env, last_subst)
Just subst -> do
let logger = hsc_logger hsc_env
putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"
@@ -712,7 +713,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
ppr subst])
let ic' = substInteractiveContext ic subst
- return hsc_env{hsc_IC=ic'}
+ return (hsc_env{hsc_IC=ic'}, subst `composeTCvSubst` last_subst)
pushResume :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
=====================================
compiler/GHC/Runtime/Eval/Types.hs
=====================================
@@ -19,7 +19,6 @@ import GHCi.RemoteTypes
import GHCi.Message (EvalExpr, ResumeContext)
import GHC.ByteCode.Types (InternalBreakpointId(..))
import GHC.Types.Id
-import GHC.Types.Name
import GHC.Types.TyThing
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
@@ -150,7 +149,7 @@ data ExecResult
-- | Execution is complete with either an exception or the list of
-- user-visible names that were brought into scope.
= ExecComplete
- { execResult :: Either SomeException [Name]
+ { execResult :: Either SomeException [Id]
, execAllocation :: Word64
}
@@ -161,7 +160,7 @@ data ExecResult
-- subsequently deciding whether to really stop here.
-- `ExecBreak` always means GHCi breaks.
| ExecBreak
- { breakNames :: [Name]
+ { breakNames :: [Id]
, breakPointId :: Maybe InternalBreakpointId
}
=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -1163,8 +1163,8 @@ findPtrTyss i tys = foldM step (i, []) tys
-- improveType <base_type> <rtti_type>
-- The types can contain skolem type variables, which need to be treated as normal vars.
-- In particular, we want them to unify with things.
-improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst
-improveRTTIType _ base_ty new_ty = U.tcUnifyDebugger base_ty new_ty
+improveRTTIType :: RttiType -> RttiType -> Maybe Subst
+improveRTTIType base_ty new_ty = U.tcUnifyDebugger base_ty new_ty
getDataConArgTys :: DataCon -> Type -> TR [Type]
-- Given the result type ty of a constructor application (D a b c :: ty)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1495,7 +1495,7 @@ runOneCommand eh gCmd = do
-- runStmt wrapper for temporarily overridden line-number
runStmtWithLineNum :: Int -> String -> SingleStep
- -> GHCi (Maybe GHC.ExecResult)
+ -> GHCi (Maybe RunResult)
runStmtWithLineNum lnum stmt step = do
st0 <- getGHCiState
setGHCiState st0 { line_number = lnum }
@@ -1560,7 +1560,7 @@ enqueueCommands cmds = do
-- | Entry point to execute some haskell code from user.
-- The return value True indicates success, as in `runOneCommand`.
-runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe RunResult)
runStmt input step = do
dflags <- GHC.getInteractiveDynFlags
let pflags = initParserOpts dflags
@@ -1582,7 +1582,7 @@ runStmt input step = do
case mb_stmt of
Nothing ->
-- empty statement / comment
- return (Just exec_complete)
+ return (Just (RunDeclsResult []))
Just stmt ->
run_stmt stmt
@@ -1605,8 +1605,6 @@ runStmt input step = do
run_imports imports
run_decls decls
where
- exec_complete = GHC.ExecComplete (Right []) 0
-
run_imports imports = mapM_ (addImportToContext . unLoc) imports
set_pragmas pflags sec supported =
@@ -1615,12 +1613,12 @@ runStmt input step = do
opts = unLoc <$> loc_opts
in setOptions opts
- run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)
+ run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe RunResult)
run_stmt stmt = do
m_result <- GhciMonad.runStmt stmt input step
case m_result of
Nothing -> return Nothing
- Just result -> Just <$> afterRunStmt step result
+ Just result -> Just <$> afterRunStmt step (RunStmtResult result)
-- `x = y` (a declaration) should be treated as `let x = y` (a statement).
-- The reason is because GHCi wasn't designed to support `x = y`, but then
@@ -1636,7 +1634,7 @@ runStmt input step = do
--
-- Instead of dealing with all these problems individually here we fix this
-- mess by just treating `x = y` as `let x = y`.
- run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)
+ run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe RunResult)
-- Only turn `FunBind` and `VarBind` into statements, other bindings
-- (e.g. `PatBind`) need to stay as decls.
run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt (locA l) bind)
@@ -1651,8 +1649,8 @@ runStmt input step = do
-- a file, otherwise the read buffer can't be flushed).
_ <- liftIO $ tryIO $ hFlushAll stdin
m_result <- GhciMonad.runDecls' decls
- forM m_result $ \result ->
- afterRunStmt step (GHC.ExecComplete (Right result) 0)
+ forM m_result $ \result -> do
+ afterRunStmt step (RunDeclsResult result)
mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
mk_stmt loc bind =
@@ -1668,32 +1666,39 @@ runStmt input step = do
where
modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic
+data RunResult
+ = RunStmtResult GHC.ExecResult
+ | RunDeclsResult [TyThing]
+
-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: GhciMonad m => SingleStep {-^ Type of step we took just before -}
- -> GHC.ExecResult -> m GHC.ExecResult
+ -> RunResult -> m RunResult
afterRunStmt step run_result = do
resumes <- GHC.getResumeContext
case run_result of
- GHC.ExecComplete{..} ->
- case execResult of
- Left ex -> liftIO $ Exception.throwIO ex
- Right names -> do
- show_types <- isOptionSet ShowType
- when show_types $ printTypeOfNames names
- GHC.ExecBreak names mb_info
- | first_resume : _ <- resumes
- -> do mb_id_loc <- toBreakIdAndLocation mb_info
- let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
- if (null bCmd)
- then printStoppedAtBreakInfo first_resume names
- else enqueueCommands [bCmd]
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- return ()
-
- | otherwise -> resume step Nothing >>=
- afterRunStmt step >> return ()
+ RunDeclsResult things -> do
+ show_types <- isOptionSet ShowType
+ when show_types $ printTypeOfThings things
+ RunStmtResult GHC.ExecComplete{..} ->
+ case execResult of
+ Left ex -> liftIO $ Exception.throwIO ex
+ Right ids -> do
+ show_types <- isOptionSet ShowType
+ when show_types $ printTypeOfIds ids
+ RunStmtResult (GHC.ExecBreak ids mb_info)
+ | first_resume : _ <- resumes
+ -> do mb_id_loc <- toBreakIdAndLocation mb_info
+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+ if (null bCmd)
+ then printStoppedAtBreakInfo first_resume ids
+ else enqueueCommands [bCmd]
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+
+ | otherwise -> resume step Nothing >>=
+ afterRunStmt step . RunStmtResult >> return ()
flushInterpBuffers
withSignalHandlers $ do
@@ -1702,16 +1707,19 @@ afterRunStmt step run_result = do
return run_result
-runSuccess :: Maybe GHC.ExecResult -> Bool
+runSuccess :: Maybe RunResult -> Bool
runSuccess run_result
- | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True
+ | Just (RunDeclsResult _) <- run_result = True
+ | Just (RunStmtResult GHC.ExecComplete { execResult = Right _ })
+ <- run_result = True
| otherwise = False
-runAllocs :: Maybe GHC.ExecResult -> Maybe Integer
+runAllocs :: Maybe RunResult -> Maybe Integer
runAllocs m = do
res <- m
case res of
- GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
+ RunDeclsResult _ -> Just 0
+ RunStmtResult GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
_ -> Nothing
toBreakIdAndLocation :: GhciMonad m
@@ -1725,30 +1733,23 @@ toBreakIdAndLocation (Just inf) = do
return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
breakId loc == bi ]
-printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
-printStoppedAtBreakInfo res names = do
+printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [GHC.Id] -> m ()
+printStoppedAtBreakInfo res ids = do
printForUser =<< pprStopped res
- -- printTypeOfNames session names
- let namesSorted = sortBy compareNames names
- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
- docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
+ let idsSorted = sortBy (compareNames `on` getName) ids
+ docs <- mapM pprTypeAndContents idsSorted
printForUserPartWay $ vcat docs
-printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()
-printTypeOfNames names
- = mapM_ (printTypeOfName ) $ sortBy compareNames names
+printTypeOfIds :: GHC.GhcMonad m => [GHC.Id] -> m ()
+printTypeOfIds = printTypeOfThings . map AnId
+
+printTypeOfThings :: GHC.GhcMonad m => [GHC.TyThing] -> m ()
+printTypeOfThings things
+ = mapM_ printTyThing $ sortBy (compareNames `on` getName) things
compareNames :: Name -> Name -> Ordering
compareNames = on compare getOccString S.<> on SrcLoc.leftmost_smallest getSrcSpan
-printTypeOfName :: GHC.GhcMonad m => Name -> m ()
-printTypeOfName n
- = do maybe_tything <- GHC.lookupName n
- case maybe_tything of
- Nothing -> return ()
- Just thing -> printTyThing thing
-
-
data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
-- | Entry point for execution a ':<command>' input from user
@@ -4400,7 +4401,7 @@ doContinue step = doContinue' step Nothing
doContinue' :: GhciMonad m => SingleStep -> Maybe Int -> m ()
doContinue' step mbCnt= do
runResult <- resume step mbCnt
- _ <- afterRunStmt step runResult
+ _ <- afterRunStmt step (RunStmtResult runResult)
return ()
abandonCmd :: GhciMonad m => String -> m ()
@@ -4551,9 +4552,9 @@ backCmd arg
| otherwise = liftIO $ putStrLn "Syntax: :back [num]"
where
back num = withSandboxOnly ":back" $ do
- (names, _, pan) <- GHC.back num
+ (ids, _, pan) <- GHC.back num
printForUser $ text "Logged breakpoint at" <+> ppr pan
- printTypeOfNames names
+ printTypeOfIds ids
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
enqueueCommands [stop st]
@@ -4565,11 +4566,11 @@ forwardCmd arg
| otherwise = liftIO $ putStrLn "Syntax: :forward [num]"
where
forward num = withSandboxOnly ":forward" $ do
- (names, ix, pan) <- GHC.forward num
+ (ids, ix, pan) <- GHC.forward num
printForUser $ (if (ix == 0)
then text "Stopped at"
else text "Logged breakpoint at") <+> ppr pan
- printTypeOfNames names
+ printTypeOfIds ids
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
enqueueCommands [stop st]
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -381,7 +381,7 @@ runStmt stmt stmt_text step = do
(EvalThis fhv) }
Just <$> GHC.execStmt' stmt stmt_text opts
-runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])
+runDecls :: GhciMonad m => String -> m (Maybe [GHC.TyThing])
runDecls decls = do
st <- getGHCiState
reifyGHCi $ \x ->
@@ -393,7 +393,7 @@ runDecls decls = do
r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
return (Just r)
-runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])
+runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.TyThing])
runDecls' decls = do
st <- getGHCiState
reifyGHCi $ \x ->
=====================================
testsuite/tests/ghci.debugger/scripts/RttiSharedTyVar.hs
=====================================
@@ -0,0 +1,4 @@
+module RttiSharedTyVar where
+
+f :: a -> a -> ()
+f x y = x `seq` y `seq` ()
=====================================
testsuite/tests/ghci.debugger/scripts/RttiSharedTyVar.script
=====================================
@@ -0,0 +1,9 @@
+:l RttiSharedTyVar
+let a = Just undefined :: Maybe Int
+let b = Just 5 :: Maybe Int
+a `seq` b `seq` ()
+:break f
+-- should say x y have type Maybe Int, not Maybe a
+f a b
+:t x
+:t y
=====================================
testsuite/tests/ghci.debugger/scripts/RttiSharedTyVar.stdout
=====================================
@@ -0,0 +1,8 @@
+()
+Breakpoint 0 activated at RttiSharedTyVar.hs:4:9-26
+Stopped in RttiSharedTyVar.f, RttiSharedTyVar.hs:4:9-26
+_result :: () = _
+x :: Maybe Int = Just _
+y :: Maybe Int = Just 5
+x :: Maybe Int
+y :: Maybe Int
=====================================
testsuite/tests/ghci.debugger/scripts/all.T
=====================================
@@ -155,3 +155,5 @@ test('T26042f2', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), ext
test('T26042g', extra_files(['T26042g.hs']), ghci_script, ['T26042g.script'])
test('T27633c', extra_files(['T27633c_obj.hs']), ghci_script, ['T27633c.script'])
+
+test('RttiSharedTyVar', extra_files(['RttiSharedTyVar.hs']), ghci_script, ['RttiSharedTyVar.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/341223c0be3eed72a5ff41593aa11e5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/341223c0be3eed72a5ff41593aa11e5…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bc6c0db6 by sheaf at 2026-10-31T09:22:20-04:00
mightBeFunTy: hotfix for #27979
ce01ccb6 refactored 'GHC.Types.RepType.mightBeFunTy' to look through
unary classes. That change introduced the helper function 'unwrap_type'
which was supposed to always return an unwrapped type, but its fallback
equation mistakenly returned the original type. This caused the
subsequent 'tyConAppTyCon_maybe' to fail in cases where it should
succeed (e.g. looking through foralls).
In this commit, we move all the unary class unwrapping logic into
'unwrapType' where it belonged from the start, and update the
documentation of 'unwrapType' to better explain what it should be used
for (#26695).
Fixes #27979 #26695
-------------------------
Metric Increase:
T5642
-------------------------
- - - - -
6 changed files:
- + changelog.d/T27979
- compiler/GHC/Types/RepType.hs
- + testsuite/tests/codeGen/should_compile/T27979.hs
- + testsuite/tests/codeGen/should_compile/T27979.stderr
- testsuite/tests/codeGen/should_compile/all.T
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
changelog.d/T27979
=====================================
@@ -0,0 +1,10 @@
+
+section: compiler
+issues: #27979
+mrs: !16873
+synopsis:
+ Avoid performance regressions when evaluating values whose types are
+ polymorphic
+description:
+ Evaluating a value of a type such as ``forall a. D a`` for a datatype ``D``
+ again uses fast inline code instead of a slower fallback in the RTS.
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -32,7 +32,6 @@ import GHC.Types.Basic (Arity, RepArity)
import GHC.Core.DataCon
import GHC.Core.Coercion
import GHC.Core.TyCon
-import GHC.Core.TyCon.Set
import GHC.Core.TyCon.RecWalk
import GHC.Core.TyCo.Rep
import GHC.Core.Type
@@ -80,13 +79,21 @@ isNvUnaryRep :: [PrimRep] -> Bool
isNvUnaryRep [_] = True
isNvUnaryRep _ = False
--- | Gets rid of the stuff that prevents us from understanding the
--- runtime representation of a type. Including:
--- 1. Casts
--- 2. Newtypes
--- 3. Foralls
--- 4. Synonyms
--- But not type/data families, because we don't have the envs to hand.
+-- | Look through casts, foralls, type synonyms, newtypes and unary classes
+-- at the top-level of a type.
+--
+-- Does /not/ reduce type family applications nor peel off data family instance
+-- newtypes.
+--
+-- Use this function to try to discover the 'TyCon' used to represent values
+-- of a type at runtime:
+--
+-- * the function arrow: the values are functions;
+-- * a data type: the values are built from its data constructors;
+-- * a primitive type constructor (e.g. @Int#@, @ByteArray#@).
+--
+-- __Warning__: do __not__ use this function to compute the runtime
+-- representation of a type (#26695). That's what 'typePrimRep' is for.
unwrapType :: Type -> Type
unwrapType ty
| Just (_, unwrapped)
@@ -105,12 +112,20 @@ unwrapType ty
-- cf. GHC.Core.Coercion.unwrapNewTypeStepper
stepper :: RecTcChecker -> TyCon -> [Type] -> NormaliseStepResult ()
stepper rec_nts tc tys
+ -- Unwrap newtypes.
| Just (ty', _) <- instNewTyCon_maybe tc tys
- = case checkRecTc rec_nts tc of
- Just rec_nts' -> NS_Step rec_nts' (go ty') ()
- Nothing -> NS_Abort -- infinite newtypes
+ = step ty'
+ -- Look through unary classes.
+ | Just (_cls, dc) <- isUnaryClassTyCon_maybe tc
+ , [Scaled _ ty'] <- dataConInstArgTys dc tys
+ = step ty'
| otherwise
= NS_Done
+ where
+ step ty' =
+ case checkRecTc rec_nts tc of
+ Just rec_nts' -> NS_Step rec_nts' (go ty') ()
+ Nothing -> NS_Abort -- fell into a loop (e.g. recursive newtypes)
-- | Count the arity of a function post-unarisation, including zero-width arguments.
--
@@ -711,7 +726,7 @@ primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep
--------------
mightBeFunTy :: Type -> Bool
-- ^ Might this type be a function type, including after looking through
--- newtypes and reducing type family applications?
+-- newtypes, unary classes, and reducing type family applications?
--
-- In particular, returns @True@ for @IO a@: after unwrapping the newtype,
-- we get @State# RealWorld -> (# State# RealWorld, a #)@, which is indeed a
@@ -734,26 +749,9 @@ mightBeFunTy ty
-- definitely not a function type.
| definitelyUnliftedType ty
= False
- | Just tc <- tyConAppTyCon_maybe (unwrap_type ty)
+ | Just tc <- tyConAppTyCon_maybe (unwrapType ty)
-- A proper datatype (such as 'Int' or 'Maybe Bool') is definitely not
-- a function type. (This does not include newtypes nor type families.)
= not $ isBoxedDataTyCon tc
| otherwise
= True
-
- where
- -- Use 'unwrapType' to look through casts, newtypes and foralls.
- -- Separately, look through unary classes (supposed to be transparent as per
- -- Note [Unary class magic] in GHC.Core.TyCon). We don't try to reduce type
- -- family applications, as we don't have a FamInstEnv to hand.
- unwrap_type = go emptyTyConSet
- where
- go seen_tcs ty
- | Just (tc, tys) <- splitTyConApp_maybe (unwrapType ty)
- , Just (_cls, unary_dc) <- isUnaryClassTyCon_maybe tc
- , [inst_meth_ty] <- map scaledThing (dataConInstArgTys unary_dc tys)
- = if tc `elemTyConSet` seen_tcs
- then ty -- cycle detected: bail out
- else go (seen_tcs `extendTyConSet` tc) inst_meth_ty
- | otherwise
- = ty
=====================================
testsuite/tests/codeGen/should_compile/T27979.hs
=====================================
@@ -0,0 +1,19 @@
+module T27979 (poly, elemAge) where
+
+data Box a = Box Int [a]
+
+newtype Age = Age Int
+
+mkBox :: Int -> Box a
+mkBox n = Box n []
+{-# NOINLINE mkBox #-}
+
+cafP :: Box a
+cafP = mkBox 1
+
+poly :: Int -> Int
+poly i = case (cafP :: Box ()) of Box n _ -> n + i
+
+elemAge :: [Age] -> Int
+elemAge (Age n : _) = n
+elemAge [] = 0
=====================================
testsuite/tests/codeGen/should_compile/T27979.stderr
=====================================
@@ -0,0 +1,4 @@
+!! The Cmm must not contain a call to the RTS's "stg_ap_0" fast entry point
+!! (generic evaluation of an unknown closure).
+!!
+!! See #27979.
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -152,3 +152,4 @@ test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typea
test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
test('T27368', normal, compile, ['-O'])
+test('T27979', [req_cmm, check_errmsg('stg_ap_0_fast')], compile, ['-O -ddump-cmm -dno-typeable-binds -dsuppress-uniques'])
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -58,7 +58,6 @@ GHC.Core.TyCo.Tidy
GHC.Core.TyCon
GHC.Core.TyCon.Env
GHC.Core.TyCon.RecWalk
-GHC.Core.TyCon.Set
GHC.Core.Type
GHC.Core.Unfold
GHC.Core.Unfold.Make
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc6c0db64a4a3e0f217c2db94cbdc06…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc6c0db64a4a3e0f217c2db94cbdc06…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] 4 commits: Simplify a tc-trace which could crash the compiler
by Marge Bot (＠marge-bot) 31 Oct '26
by Marge Bot (＠marge-bot) 31 Oct '26
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c5a8bb9f by Simon Peyton Jones at 2026-10-31T09:20:34-04:00
Simplify a tc-trace which could crash the compiler
The trace formatted an error message, which prematurely
read the ExpType in a FunResCtxt.
Solution: don't put call the error message formatting
when tc-tracing.
- - - - -
ab49b1d2 by Simon Peyton Jones at 2026-10-31T09:20:34-04:00
Tiny comment change to uniqAway
- - - - -
6efe4ba3 by Simon Peyton Jones at 2026-10-31T09:20:34-04:00
Make niFixSubst idempotent
I discovered (when fixing #27994) that `niFixSubst` didn't actually
generate an idempotent subsitution despite its claims. It could
return a substitution that mentions domain variables on in its range,
when those variables are hidden inside the kind of a type variable
occurrence. As a result it can generate ill-kinded types. Boo!
The fix is simple, and uses deep substitution.
See Note [Finding the substitution fixpoint]
I don't think it actually /caused/ any bugs, so there is no
regression test.
- - - - -
3b60ae7e by Simon Peyton Jones at 2026-10-31T09:20:34-04:00
Fix a nasty bug in fundeps
This MR fixes #27994, which turned out to be very tricky.
See Note [Exploiting closed type famililes], especially (CF7). I was
ending up with TyVars (not TcTyVars) in the solver, because the
substitution computed in `getRelevantBranches` mixed the two.
The code was just too clever. I ended up simplifying it quite a bit.
For /closed/ families we no longer call `trimQtvs` (was `trim_qtvs`).
Open families still do use `trimQtvs`. See Note [trimQTvs]
This patch also fixes one other buglet in the same code.
* Over-saturated type families were being mis-handled.
See the new use of `saturatedFamApp_maybe`.
- - - - -
15 changed files:
- + changelog.d/T27994
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/Var/Env.hs
- + testsuite/tests/typecheck/should_compile/T27994.hs
- + testsuite/tests/typecheck/should_compile/T27994a.hs
- + testsuite/tests/typecheck/should_compile/T27994b.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
changelog.d/T27994
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+issues: #27994
+mrs: !16842
+synopsis:
+ Fix a compiler Lint error in a heavily kind-polymorphic program
+description:
+ There was a subtle bug deep in the code for computing functional dependencies for type families.
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -277,8 +277,8 @@ data CoAxBranch
-- See Note [CoAxBranch type variables]
, cab_eta_tvs :: [TyVar]
-- ^ Eta-reduced tyvars
- -- cab_tvs and cab_lhs may be eta-reduced; see
- -- Note [Eta reduction for data families]
+ -- For a data family (only) cab_tvs and cab_lhs may be eta-reduced
+ -- See Note [Eta reduction for data families]
, cab_cvs :: [CoVar]
-- ^ Bound coercion variables
-- Always empty, for now.
@@ -286,8 +286,14 @@ data CoAxBranch
-- in GHC.Tc.TyCl
, cab_roles :: [Role]
-- ^ See Note [CoAxBranch roles]
+
, cab_lhs :: [Type]
-- ^ Type patterns to match against
+ -- For a data family `cab_lhs` may be shorter than the arity
+ -- of the data type
+ -- For a type family `cab_lhs` is exactly the family arity
+ -- See Note [Eta reduction for data families]
+
, cab_rhs :: Type
-- ^ Right-hand side of the equality
-- See Note [CoAxioms are homogeneous]
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -36,7 +36,7 @@ module GHC.Core.Predicate (
-- Equality left-hand sides
CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,
- canEqLHSKind, canEqLHSType, eqCanEqLHS
+ canEqLHSKind, canEqLHSType, eqCanEqLHS, saturatedFamApp_maybe
) where
@@ -61,6 +61,8 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.FastString
+import GHC.Exts( inline )
+
{- *********************************************************************
* *
@@ -700,7 +702,9 @@ types/kinds are fully settled and zonked.
-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"
scopedSort :: [Var] -> [Var]
-scopedSort = go [] []
+scopedSort xs
+ | null xs = []
+ | otherwise = go [] [] xs
where
go :: [Var] -- already sorted, in reverse order
-> [TyCoVarSet] -- each set contains all the variables which must be placed
@@ -781,13 +785,19 @@ canEqLHS_maybe xi
| otherwise
= canTyFamEqLHS_maybe xi
-canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS
-canTyFamEqLHS_maybe xi
+saturatedFamApp_maybe :: Type -> Maybe (TyCon,[Type])
+saturatedFamApp_maybe xi
| Just (tc, args) <- tcSplitTyConApp_maybe xi
, isTypeFamilyTyCon tc
, args `lengthIs` tyConArity tc
- = Just $ TyFamLHS tc args
+ = Just (tc,args)
+ | otherwise
+ = Nothing
+canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS
+canTyFamEqLHS_maybe xi
+ | Just (tc, args) <- inline saturatedFamApp_maybe xi
+ = Just $ TyFamLHS tc args
| otherwise
= Nothing
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1159,10 +1159,12 @@ nice tight loops.
{-# INLINE afvFolder #-} -- See Note [Any-free-var folder]
afvFolder :: TyCoFolder (FV (BoundVars, TyCoVar -> Bool) DM.Any)
-- 'afvFolder' is short for "any-free-var folder", good for checking
--- if any /deep/ free var of a type satisfies a predicate `check_fv`
+-- if any /shallow/ free var of a type satisfies a predicate `check_fv`
-- The "env" of the (FV env Any) is a pair (bvs,pred) of
-- the bound variables (which are definitely not free), and
-- an "interesting var" predicate which the client supplies
+--
+-- You can get "deep" by supplying a predicate that also looks in the kind
afvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms]
, tcf_tyvar = do_tcv
, tcf_covar = do_tcv
@@ -1173,8 +1175,7 @@ afvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms]
-- Check the variable itself with check_fv,
-- and check its kind (this is a deep folder)
do_tcv tcv = MkFV $ \ (bvs,check_fv) ->
- Any (not (tcv `elemVarSet` bvs) &&
- (check_fv tcv || runAny check_fv (afv_type (varType tcv))))
+ Any (not (tcv `elemVarSet` bvs) && check_fv tcv)
do_hole hole = do_tcv (coHoleCoVar hole)
afv_type :: Type -> FV (BoundVars, TyVar -> Bool) DM.Any
@@ -1186,16 +1187,32 @@ runAny :: (TyVar -> Bool) -> FV (BoundVars, TyCoVar -> Bool) DM.Any -> Bool
{-# INLINE runAny #-}
runAny check_fv fvs = DM.getAny (runFV fvs (emptyVarSet, check_fv))
+---------------------------------------------
+-- anyShallowFreeVarsOfType and friends look only for shallow free vars
+-- (Currently not needed, left here in case we need it one day)
+-- anyShallowFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
+-- {-# INLINE anyShallowFreeVarsOfType #-}
+-- anyShallowFreeVarsOfType check_fv ty = runAny check_fv (afv_type ty)
+
+---------------------------------------------
+-- anyFreeVarsOfType and friends look for deep free vars
+
+deep_check :: (TyCoVar -> Bool) -> TyCoVar -> Bool
+-- This is inefficient because if one tyvar occurs many times
+-- in a type, it'll look in its kind at each occurrence. Boo.
+deep_check check_fv tcv = check_fv tcv || anyFreeVarsOfType check_fv (varType tcv)
+
anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
{-# INLINE anyFreeVarsOfType #-}
-anyFreeVarsOfType check_fv ty = runAny check_fv (afv_type ty)
+-- Looks deeply, into the kinds of the free vars
+anyFreeVarsOfType check_fv ty = runAny (deep_check check_fv) (afv_type ty)
anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool
{-# INLINE anyFreeVarsOfTypes #-}
-anyFreeVarsOfTypes check_fv tys = runAny check_fv (afv_types tys)
+anyFreeVarsOfTypes check_fv tys = runAny (deep_check check_fv) (afv_types tys)
anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool
-anyFreeVarsOfCo check_fv co = runAny check_fv (afv_co co)
+anyFreeVarsOfCo check_fv co = runAny (deep_check check_fv) (afv_co co)
noFreeVarsOfType :: Type -> Bool
noFreeVarsOfType ty = not $ runAny (const True) (afv_type ty)
@@ -1206,6 +1223,7 @@ noFreeVarsOfTypes tys = not $ runAny (const True) (afv_types tys)
noFreeVarsOfCo :: Coercion -> Bool
noFreeVarsOfCo co = not $ runAny (const True) (afv_co co)
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -48,6 +48,8 @@ module GHC.Core.TyCo.Subst
substTyCoBndr,
substVarBndrUsing,
checkValidSubst, isValidTCvSubst,
+
+ deepSubstTy
) where
import GHC.Prelude
@@ -775,9 +777,15 @@ substThetaUnchecked = substTysUnchecked
-- building no thunks. See Note [Specialising mappers] in GHC.Core.TyCo.Make
type SubstM = StrictReaderT Subst StrictIdentity
-runSubstM :: SubstM a -> Subst -> a
-runSubstM m subst = runStrictIdentity (runStrictReaderT m subst)
+runSubstM :: forall a. (a -> SubstM a) -> Subst -> a -> a
{-# INLINE runSubstM #-}
+runSubstM tx subst x = runStrictIdentity (runStrictReaderT (tx x) subst)
+
+subst_ty :: Subst -> Type -> Type
+subst_co :: Subst -> Coercion -> Coercion
+(subst_ty, subst_co)
+ = case mapTyCo substTyCoMapper of
+ (ms_ty, _, ms_co, _) -> (runSubstM ms_ty, runSubstM ms_co)
substTyCoMapper :: TyCoMapper SubstM
substTyCoMapper
@@ -785,8 +793,8 @@ substTyCoMapper
, tcm_covar = subst_cv
, tcm_hole = subst_ch
, tcm_tycobinder = tcv_bndr
- , tcm_tcapp_ty = tcapp_ty
- , tcm_tcapp_co = tcapp_co
+ , tcm_tcapp_ty = nopTcAppTy
+ , tcm_tcapp_co = nopTcAppCo
}
where
subst_tv tv = StrictReaderT $ \subst -> return (substTyVar subst tv)
@@ -802,23 +810,15 @@ substTyCoMapper
-- Avoid allocation in this very
-- common case (E.g. Int, LiftedRep etc)
- tcapp_ty :: Type -> TyCon -> [Type] -> SubstM Type
- tcapp_ty ty tc tys'
- | null tys' = return ty
- | otherwise = return (mkTyConApp tc tys')
- tcapp_co :: Coercion -> Role -> TyCon -> [Coercion] -> SubstM Coercion
- tcapp_co co r tc cos'
- | null cos' = return co
- | otherwise = return (mkTyConAppCo r tc cos')
+nopTcAppTy :: Type -> TyCon -> [Type] -> SubstM Type
+nopTcAppTy ty tc tys'
+ | null tys' = return ty
+ | otherwise = return (mkTyConApp tc tys')
-subst_ty :: Subst -> Type -> Type
-subst_co :: Subst -> Coercion -> Coercion
-(subst_ty, subst_co)
- = case mapTyCo substTyCoMapper of
- (ms_ty, _, ms_co, _) -> (run ms_ty, run ms_co)
- where
- run :: forall a. (a -> SubstM a) -> Subst -> a -> a
- run ms subst x = runSubstM (ms x) subst
+nopTcAppCo :: Coercion -> Role -> TyCon -> [Coercion] -> SubstM Coercion
+nopTcAppCo co r tc cos'
+ | null cos' = return co
+ | otherwise = return (mkTyConAppCo r tc cos')
substTyVar :: Subst -> TyVar -> Type
substTyVar (Subst _ _ tenv _) tv
@@ -1019,3 +1019,86 @@ it is /very/ valuable to /keep/ it empty:
If the substitution is empty, this is a no-op -- but only if it
is empty!
-}
+
+
+{- **********************************************************************
+%* *
+ Deep substitution
+%* *
+%********************************************************************* -}
+
+{- Note [Deep substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deep substitution applies the substitution to the /kinds/ of un-substituted
+type variables. Suppose the substitution is
+ [ k :-> Type ]
+and we apply it to the type
+ Proxy k (a :: k)
+Ordinary shallow substitution will give
+ Proxy Type (a :: k)
+which is ill-kinded. Deep substitution will give
+ Proxy Type (a :: Type)
+
+Ordinary (shallow) substitution is usually fine, because we will substitute for
+`a` as well, but not always. In particular, the pure unifier in GHC.Core.Unify
+uses `niFixSubst` to find a fixpoint, and we really don't want domain tyvars
+appearing in the range. See Note [Finding the substitution fixpoint].
+
+Wrinkles:
+
+(DS1) Deep substitution risks being rather inefficient because it re-applies the
+ substitution to the kind at /each occurrence/ of a free variable. We could
+ perhaps find the free vars, and build a re-kinding substitution, but that's a
+ bit more complicated.
+
+(DS2) Deep substitution, as implemented here, relies on invariant
+ (NoTypeShadowing); see Note [No type-shadowing in Core] in Core.hs.
+ Otherwise we may have e.g.
+ S = [r :-> LiftedRep] in-scope = {r, x}
+ T = forall (r :: RuntimeRep). (x :: TYPE r) -> ...
+ and we would want to apply the outer substitution S to the
+ occurrence of r in the kind of x. But we'll have removed it
+ from the subsitution when pasing the 'forall r'.
+-}
+
+deepSubstTyCoMapper :: TyCoMapper SubstM
+deepSubstTyCoMapper
+ = TyCoMapper { tcm_tyvar = subst_tv
+ , tcm_covar = subst_cv
+ , tcm_hole = subst_ch
+ , tcm_tycobinder = tcv_bndr
+ , tcm_tcapp_ty = nopTcAppTy
+ , tcm_tcapp_co = nopTcAppCo
+ }
+ where
+ subst_tv tv = StrictReaderT $ \subst -> return (deepSubstTyVar subst tv)
+ subst_cv cv = StrictReaderT $ \subst -> return (deepSubstCoVar subst cv)
+ subst_ch ch = StrictReaderT $ \subst -> return (deepSubstCoHole subst ch)
+
+ tcv_bndr :: TyCoVar -> ForAllTyFlag -> (TyCoVar -> SubstM r) -> SubstM r
+ tcv_bndr tcv _vis k
+ = StrictReaderT $ \subst ->
+ let !(subst', tcv') = substVarBndrUsing deepSubstTy subst tcv
+ in runStrictReaderT (k tcv') subst'
+
+deepSubstTy :: Subst -> Type -> Type
+deepSubstTy = case mapTyCo deepSubstTyCoMapper of
+ (subst_ty, _, _, _) -> runSubstM subst_ty
+
+deepSubstTyVar :: Subst -> TyVar -> Type
+deepSubstTyVar subst@(Subst _ _ tenv _) tv
+ = assert (isTyVar tv) $
+ case lookupVarEnv tenv tv of
+ Just ty -> ty
+ Nothing -> TyVarTy (updateVarType (deepSubstTy subst) tv)
+
+deepSubstCoVar :: Subst -> CoVar -> Coercion
+deepSubstCoVar subst@(Subst _ _ _ cenv) cv
+ = case lookupVarEnv cenv cv of
+ Just co -> co
+ Nothing -> CoVarCo (updateVarType (deepSubstTy subst) cv)
+
+deepSubstCoHole :: Subst -> CoercionHole -> Coercion
+-- See Note [Substituting in a coercion hole]
+deepSubstCoHole subst h@(CH { ch_co_var = cv })
+ = HoleCo (h { ch_co_var = updateVarType (deepSubstTy subst) cv })
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -483,7 +483,7 @@ expandTypeSynonyms ty
expandTypeSynonymsX :: Subst -> Type -> Type
expandTypeSynonymsX
= case mapTyCo expandTypeSynonymMapper of
- (exp_ty, _, _, _) -> \subst ty -> runSubstM (exp_ty ty) subst
+ (exp_ty, _, _, _) -> runSubstM exp_ty
expandTypeSynonymMapper :: TyCoMapper SubstM
-- Just like substitution, but treat TyConApp specially
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -28,13 +28,12 @@ import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Type hiding ( getTvSubstEnv )
import GHC.Core.Coercion hiding ( getCvSubstEnv )
-import GHC.Core.Predicate( scopedSort )
import GHC.Core.TyCon
import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe )
import GHC.Core.TyCon.Env
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs )
-import GHC.Core.TyCo.Subst ( mkTvSubst )
+import GHC.Core.TyCo.Subst ( mkTvSubst, deepSubstTy )
import GHC.Core.Map.Type
import GHC.Core.Multiplicity
@@ -1063,21 +1062,31 @@ During unification we use a TvSubstEnv/CvSubstEnv pair that is
Note [Finding the substitution fixpoint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Finding the fixpoint of a non-idempotent substitution arising from a
-unification is much trickier than it looks, because of kinds. Consider
+We want an /idempotent/ substitution, so `niFixSubst` takes a non-idempotent
+one and composes it with itself until it becomes idempotent. Thus if the original
+is S0, we compute S1 = S0 o S0, S2 = S1 o S1, etc.
+
+A variable chain v0 :-> v1 :-> ... :-> vm therefore takes about log2(m) rounds,
+The unifier can build such chains. For example:
+ (a, a, a, ..., a) ~ (x1, x2, x3, ..., xm)
+produces a :-> x1, x1 :-> x2, ..., x(m-1) :-> xm.
+
+Finding the fixpoint is much trickier than it looks, because of kinds.
+Consider
T k (H k (f:k)) ~ T * (g:*)
If we unify, we get the substitution
[ k -> *
, g -> H k (f:k) ]
+This isn't idempotent: it mentions `k` in the range.
+
To make it idempotent we don't want to get just
[ k -> *
, g -> H * (f:k) ]
-We also want to substitute inside f's kind, to get
- [ k -> *
- , g -> H k (f:*) ]
-If we don't do this, we may apply the substitution to something,
-and get an ill-formed type, i.e. one where typeKind will fail.
+because (H * (f:k)) is itself ill-kinded, and `typeKind` will fail.
This happened, for example, in #9106.
+So (yuckily) we must also substitute inside f's kind, to get
+ [ k -> *
+ , g -> H * (f:*) ]
It gets worse. In #14164 we wanted to take the fixpoint of
this substitution
@@ -1090,84 +1099,53 @@ the invocation of F! We don't have a function that recursively
applies substitutions inside the kinds of variable occurrences (and
probably rightly so).
-So, we work as follows:
-
- 1. Start with the current substitution (which we are
- trying to fixpoint
- [ xs :-> F a (z :: a) (rest :: G a (z :: a))
- , a :-> b ]
-
- 2. Take all the free vars of the range of the substitution:
- {a, z, rest, b}
- NB: the free variable finder closes over
- the kinds of variable occurrences
-
- 3. If none are in the domain of the substitution, stop.
- We have found a fixpoint.
-
- 4. Remove the variables that are bound by the substitution, leaving
- {z, rest, b}
-
- 5. Do a topo-sort to put them in dependency order:
- [ b :: *, z :: a, rest :: G a z ]
-
- 6. Apply the substitution left-to-right to the kinds of these
- tyvars, extending it each time with a new binding, so we
- finish up with
- [ xs :-> ..as before..
- , a :-> b
- , b :-> b :: *
- , z :-> z :: b
- , rest :-> rest :: G b (z :: b) ]
- Note that rest now has the right kind
-
- 7. Apply this extended substitution (once) to the range of the
- /original/ substitution. (Note that the extended substitution
- would go on forever if you tried to find its fixpoint, because it
- maps z to z.)
-
- 8. And go back to step 1
-
-In Step 6 we use the free vars from Step 2 as the initial
-in-scope set, because all of those variables appear in the
-range of the substitution, so they must all be in the in-scope
-set. But NB that the type substitution engine does not look up
-variables in the in-scope set; it is used only to ensure no
-shadowing.
+Ugh! This whole thing is pretty horrible. But the solution is simple enough:
+
+ Use deep substitution (deepSubstTy)
+
+(deepSubst `s` (Proxy k (a::k)) applies the substitution `s` not only to
+the occurrence of `k` in the argument of `Proxy`, but also to the `k` inside
+the kind of `a`. See Note [Deep substitution] in GHC.Core.TyCo.Subst.
+
+So `niFixSubst` just applies the substitution /deeply/ to the types in its
+range, until we reach a fixed point. Easy!
+
+Historical Note:
+ Immediately prior to this solution there was a previous, more complicated
+ `niFixSubst` which involved finding the (deep) free variables and "re-kinding"
+ them. It accomplished essentially the same things, and it avoided the
+ potential duplication noted in Note [Deep substitution]. But it was pretty
+ subtle and this version is more obviously correct.
+End of Historical Note
-}
niFixSubst :: InScopeSet -> TvSubstEnv -> Subst
-- Find the idempotent fixed point of the non-idempotent substitution
-- This is surprisingly tricky:
-- see Note [Finding the substitution fixpoint]
--- ToDo: use laziness instead of iteration?
niFixSubst in_scope tenv
- | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv)
- | otherwise = tenv_subst
+ | isEmptyVarEnv tenv -- Fast path for common case
+ = mkEmptySubst in_scope
+ | otherwise
+ = -- pprTrace "niFixSubst" (vcat [ text "In: " <+> ppr tenv
+ -- , text "Out:" <+> ppr (S.getTvSubstEnv subst) ])
+ subst
where
- tenv_subst = mkTvSubst in_scope tenv -- This is our starting point
-
- range_tvs :: [TyVar]
- range_tvs = nonDetVarSetElems $
- tyCoVarsOfTypes $
- nonDetEltsUFM tenv
- -- It's OK to use nonDetEltsUFM (twice) here because
- -- the order of range_tvs is immaterial
-
- not_fixpoint = any in_domain range_tvs
- in_domain tv = tv `elemVarEnv` tenv
+ subst = niFixSubst' 1 in_scope tenv
- free_tvs = scopedSort (filterOut in_domain range_tvs)
-
- -- See Note [Finding the substitution fixpoint], Step 6
- subst = foldl' add_free_tv tenv_subst free_tvs
-
- add_free_tv :: Subst -> TyVar -> Subst
- add_free_tv subst tv
- | isTyVar tv = extendTvSubst subst tv (mkTyVarTy tv')
- | otherwise = subst -- Ignore free coercion variables
- where
- tv' = updateTyVarKind (substTy subst) tv
+niFixSubst' :: Int -> InScopeSet -> TvSubstEnv -> Subst
+niFixSubst' n in_scope tenv_orig
+ | fixpoint_found = mkTvSubst in_scope tenv_orig
+ | otherwise = niFixSubst' (n+1) in_scope tenv_new
+ where
+ in_dom tv = tv `elemVarEnv` tenv_orig
+ tenv_new = mapVarEnv (deepSubstTy subst) tenv_orig
+ subst = mkTvSubst in_scope tenv_orig
+
+ fixpoint_found = nonDetStrictFoldUFM and_fix True tenv_orig
+ and_fix :: Type -> Bool -> Bool
+ and_fix _ False = False
+ and_fix ty _ = not (anyFreeVarsOfType in_dom ty)
{-
************************************************************************
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Driver.Env
+import GHC.Core.Predicate( saturatedFamApp_maybe )
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.TyCon
@@ -715,15 +716,9 @@ reportInjectivityErrors dflags fi_ax axiom inj
when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom
-- | Is type headed by a type family application?
-isTFHeaded :: Type -> Bool
-- See Note [Verifying injectivity annotation], case 3.
-isTFHeaded ty | Just ty' <- coreView ty
- = isTFHeaded ty'
-isTFHeaded ty | (TyConApp tc args) <- ty
- , isTypeFamilyTyCon tc
- = args `lengthIs` tyConArity tc
-isTFHeaded _ = False
-
+isTFHeaded :: Type -> Bool
+isTFHeaded ty = isJust (saturatedFamApp_maybe ty)
-- | If a RHS is a bare type variable return a set of LHS patterns that are not
-- bare type variables.
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -24,16 +24,16 @@ import GHC.Tc.Types.Constraint
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.TyCo.Rep( Type(..) )
-import GHC.Core.Predicate( EqRel(..) )
+import GHC.Core.TyCo.Subst( deepSubstTy, elemSubst, extendTvSubstWithClone )
+import GHC.Core.Predicate( EqRel(..), saturatedFamApp_maybe )
import GHC.Core.TyCon
import GHC.Core.Unify( AmIUnifying(..)
, tcUnifyTysForInjectivity, typeListsAreApart )
import GHC.Core.Coercion.Axiom
-import GHC.Core.TyCo.Subst( elemSubst, extendTvSubstWithClone )
import GHC.Builtin.WiredIn.TypeLits( tryInteractTopFam, tryInteractInertFam )
-import GHC.Types.Var( TyVar, tyVarKind, setTyVarKind )
+import GHC.Types.Var( TyVar, updateVarType, tyVarKind )
import GHC.Types.Var.Set
import GHC.Types.Var.Env( mkInScopeSet )
@@ -57,7 +57,6 @@ Here is our plan for dealing with functional dependencies
* send the current constraint back to the start of the pipeline;
it might now be soluble, and it probably isn't inert
-
* Once a unification is done, it can't be un-done. So we must be very careful
not to threaten completeness by doing a unification when there might be
another way to solve the constraint.
@@ -613,6 +612,7 @@ tryFamEqFunDeps mode eqs_for_me fam_tc work_args
mkTopFamEqFDs :: TyCon -> [TcType] -> EqCt -> SolverStage [FunDepEqns]
mkTopFamEqFDs fam_tc work_args work_item
+ -- NB: work_args exactly saturate fam_tc
| isOpenTypeFamilyTyCon fam_tc
, Injective inj_flags <- tyConInjectivityInfo fam_tc
= -- Open, injective type families
@@ -694,6 +694,8 @@ hasRelevantGiven eqs_for_me work_args (EqCt { eq_rhs = work_rhs })
getRelevantBranches :: CoAxiom Branched -> [TcType] -> Xi -> [FunDepEqns]
-- Return the FunDepEqns that arise from each relevant branch
-- Implements Note [Relevance]
+-- Caller will only use these FunDepEqns if there is just one relevant
+-- equation, i.e. the returned [FunDepEqns] is a singleton.
getRelevantBranches ax work_args work_rhs
= go (fromBranches (coAxiomBranches ax))
where
@@ -709,24 +711,33 @@ getRelevantBranches ax work_args work_rhs
, cab_lhs = lhs_tys
, cab_rhs = rhs_ty })
| Just subst <- tcUnifyTysForInjectivity Unifying (rhs_ty:lhs_tys) work_tys
- -- See (RW1)-(RW3) in Note [Relevance]
- -- This is a pre-/unification/ check (not matching)
- -- so `subst` can bind both `qtvs` and fvs(work_tys)
- , let (subst',qtvs') = trim_qtvs subst qtvs
- lhs_tys' = substTys subst' lhs_tys
- rhs_ty' = substTy subst' rhs_ty
- branch_tys' = rhs_ty' : lhs_tys'
+ -- See (RW1)-(RW3) in Note [Relevance]
+ , let lhs_tys' = map (deepSubstTy subst) lhs_tys
+ -- deepSubstTy: see (CF8) in Note [Exploiting closed type families]
, noEarlierMatchCheck lhs_tys' branch -- See (RW4) in Note [Relevance]
- = Just (FDEqns { fd_qtvs = qtvs'
- , fd_eqs = zipWith Pair branch_tys' work_tys })
- -- Do not apply the substition to `work_tys`;
- -- See (CF7) in Note [Exploiting closed type families]
+ = -- Ignore the substitution, except for `noEarlierMatchCheck`
+ Just $
+ if all (`elemSubst` subst) qtvs
+ then -- `subst` eliminates all qtvs; and no qtvs in range of subst
+ -- See (CF7)(A) in Note [Exploiting closed type families]
+ FDEqns { fd_qtvs = []
+ , fd_eqs = zipWith Pair (substTy subst rhs_ty : lhs_tys')
+ work_tys }
+ -- Do not apply `subst` to `work_tys`;
+ -- See (CF9) in Note [Exploiting closed type families]
+
+ else -- Abandon `subst`; re-create it from (rhs_ty ~ work_rhs)
+ -- See (CF7)(B) in Note [Exploiting closed type families]
+ FDEqns { fd_qtvs = qtvs
+ , fd_eqs = zipWith Pair (rhs_ty:lhs_tys) work_tys }
+
| otherwise
= Nothing
mkTopOpenFamEqFDs :: TyCon -> [Bool] -> [TcType] -> EqCt -> TcS [FunDepEqns]
-- Implements (INJFAM:Wanted/top-open)
-- See Note [Exploiting open type families]
+-- NB: work_args exactly saturate fam_tc
mkTopOpenFamEqFDs fam_tc inj_flags work_args (EqCt { eq_rhs = work_rhs })
= do { fam_envs <- getFamInstEnvs
; let branches :: [CoAxBranch]
@@ -739,11 +750,14 @@ mkTopOpenFamEqFDs fam_tc inj_flags work_args (EqCt { eq_rhs = work_rhs })
, cab_lhs = branch_lhs_tys
, cab_rhs = branch_rhs })
| Just subst <- tcUnifyTysForInjectivity Matching [branch_rhs] [work_rhs]
- , let (subst', qtvs') = trim_qtvs subst branch_qtvs
+ -- No need for an apartness check here;
+ -- for open type families there are no "preceding" equations
+ -- Both branch_lhs_tys and work_args exactly saturate fam_tc
+ , let (subst', qtvs') = trimQtvs subst branch_qtvs
branch_lhs_tys' = substTys subst' branch_lhs_tys
- -- No need for an apartness check here; for open type families
- -- there are no "preceding" equations
- = Just (mkInjectivityFDEqn inj_flags qtvs' branch_lhs_tys' work_args)
+ -- We must apply the substitution here see
+ -- the Basic Plan in Note [Exploiting open type families]
+ = Just (mkInjectivityFDEqn qtvs' inj_flags branch_lhs_tys' work_args)
| otherwise
= Nothing
@@ -756,9 +770,9 @@ mkLocalFamEqFDs eqs_for_me fam_tc inj_flags work_args work_rhs
= do { let -- eqns_from_inerts: see (INJFAM:Wanted/other)
eqns_from_inerts = mapMaybe do_one eqs_for_me
-- eqns_from_self: see (INJFAM:Wanted/Self)
- eqns_from_self = case tcSplitTyConApp_maybe work_rhs of
- Just (tc,rhs_tys) | tc==fam_tc -> [mk_eqn rhs_tys]
- _ -> []
+ eqns_from_self = case saturatedFamApp_maybe work_rhs of
+ Just (tc, rhs_tys) | fam_tc == tc -> [mk_eqn rhs_tys]
+ _ -> []
; return (eqns_from_inerts ++ eqns_from_self) }
where
@@ -768,11 +782,12 @@ mkLocalFamEqFDs eqs_for_me fam_tc inj_flags work_args work_rhs
| otherwise = Nothing
do_one _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS
- mk_eqn iargs = mkInjectivityFDEqn inj_flags [] work_args iargs
+ mk_eqn iargs = mkInjectivityFDEqn [] inj_flags work_args iargs
+
-trim_qtvs :: Subst -> [TyVar] -> (Subst, [TyVar])
--- Tricky stuff: see (OF1) in Note [Exploiting open type families]
-trim_qtvs unif_subst qtvs
+trimQtvs :: Subst -> [TyVar] -> (Subst, [TyVar])
+-- Tricky stuff: see Note [Exploiting open type families] and Note [trimQtvs]
+trimQtvs unif_subst qtvs
= go unif_subst qtvs
where
go :: Subst -> [TyVar] -> (Subst, [TyVar])
@@ -786,10 +801,9 @@ trim_qtvs unif_subst qtvs
go_fresh subst tv tvs = (subst'', tv':tvs')
where
!(subst'', tvs') = go subst' tvs
- tv' = tv `setTyVarKind` substTy subst (tyVarKind tv)
+ tv' = updateVarType (substTy subst) tv
subst' = extendTvSubstWithClone subst tv tv'
- -- extendTvSubstWithClone: see (OF1b) in
- -- Note [Exploiting open type families]
+ -- extendTvSubstWithClone: see (TQ1) in Note [trimQtvs]
-----------------------------------------
@@ -883,15 +897,22 @@ mkLocalBuiltinFamEqFDs eqs_for_me fam_tc ops work_args work_rhs
; return (eqns_from_inerts ++ eqns_from_self) }
--------------------
-mkInjectivityFDEqn :: [Bool] -- Injectivity flags
- -> [TcTyVar] -- Quantify these
+mkInjectivityFDEqn :: [TcTyVar] -- Quantify these
+ -> [Bool] -- Injectivity flags
-> [TcType] -> [TcType] -- Make these equal
-> FunDepEqns
-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]
-- return the FDEqns { fd_eqs = [Pair s1 t1, Pair s3 t3] }
--- The injectivity flags [Bool] will not all be False, but nothing goes wrong if they are
-mkInjectivityFDEqn inj_args qtvs lhs_args rhs_args
- = FDEqns { fd_qtvs = qtvs, fd_eqs = eqs }
+-- The injectivity flags [Bool] will not all be False,
+-- but nothing goes wrong if they are
+mkInjectivityFDEqn qtvs inj_args lhs_args rhs_args
+ = assertPpr (let len = length inj_args in
+ len == length lhs_args && len == length rhs_args)
+ (vcat [ text "inj_args:" <+> ppr inj_args
+ , text "lhs_args:" <+> ppr lhs_args
+ , text "rhs_args:" <+> ppr rhs_args ]) $
+ -- Need inj_args lhs_args and rhs_args to be same length for zip3
+ FDEqns { fd_qtvs = qtvs, fd_eqs = eqs }
where
eqs = [ Pair lhs_arg rhs_arg
| (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]
@@ -1096,73 +1117,108 @@ Note [Exploiting closed type families].
Note [Exploiting open type families] see `mkTopOpenFamEqFDs`
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generating fundeps from a top-level type instance is covered in Section 5.2 in
-the Injective Type Families paper. For open type families, suppose we have
-
- type family F a = r | r -> a
- type instance F [a] = a->a
-
- [W] F alpha ~ Int->Int
-
-Then, since F has been checked as injective, and the RHS `a->a` (pre-)unifies
-with the `Int->Int` in the Wanted with substitution [a :-> Int], we can
-add a derived FunDepEqns
+For an open type family, generating fundeps from a top-level type instance
+is covered in Section 5.2 in the Injective Type Families paper.
+
+Basic plan: Suppose type family F a b = r | r -> b
+ and Wanted [W] F wlhs1 wlhs2 ~ wrhs
+ Then for each type instance (F lhs1 lhs2 = rhs)
+ * Pre-match `rhs` against `wrhs` to get a substitution S
+ * Generate fundep equalities S(lhs2) ~ wrhs
+ one for each fundep in the type family
+
+For example, suppose we have
+ type family F a b = r | r -> a
+ type instance F [a] Int = a->a
+ [W] F alpha beta ~ Int->Int
+Then we pre-match template (a->a) against target (Int->Int) to get
+substitution S = [a :-> Int]. Then we can generate
FDEqns{ fd_qtvs = [], fd_eqs = [ [Int] ~ alpha ] }
and thereby emit (via `instantiateFunDepEqns`)
[W] [Int] ~ alpha
+Note that `fd_qtvs = []`; we have substituted away the quantifed type variable `a`.
Things are a bit trickier when not all the quantified variables of the
instance are bound by the pre-unification step. Suppose we have
-
type family F a = r | r -> a
- type instance F (Maybe a) = [G a] -- G is a type family
+ type instance F (b -> Maybe a) = [(G a,b)] -- G is a type family
+ [W] F alpha ~ [(ty,Int)]
- [W] F alpha ~ [ty]
-
-Then, the RHS [G a] pre-unifies with the RHS of the Wanted, but with an
-empty substitution, which does not fix `a`. So we get this FunDepEqns:
- FDEqns{ fd_qtvs = a, fd_eqs = [ Maybe a ~ alpha ] }
+Then, the RHS [(G a,b)] pre-matches with the RHS of the Wanted, but with
+the substitution [b :-> Int], which does not fix `a`. So, after trimming
+the quantified type variables, we get this FunDepEqns:
+ FDEqns{ fd_qtvs = [a], fd_eqs = [ (Int -> Maybe a) ~ alpha ] }
(note the fd_qtvs=a) and thereby emit (via `instantiateFunDepEqns`)
- [W] Maybe gamma ~ alpha -- Fresh gamma
-We have learned that `alpha` must be a list, but that is all; we don't
-know what is inside it, hence the fresh `gamma`.
-
-In general we have:
-
- type family F x1 ... xn = r | r -> x1 x3 (say)
- type instance forall qs. F t1 ... tn = rhs
- [W] F a1 ... an ~ b
-
-Suppose `b` pre-unifies with `rhs`, with substitution `S` that binds
-some (but perhaps not all) of the `qs`. Lets say
- unbound_qs = qs \ dom(S)
-
-Then we generate the FunDepEqs
- FDEqns{ fd_qtvs = unbound_qs
- , fd_eqs = [ S(t1) ~ S(a1), S(t3) ~ S(a3) ]
-
-These 'fd_qtvs' are subsequently instantiated to fresh metavariables by
-'instantiateFunDepEqns'.
-
-(OF1) The computation of `unbound_qs` is done by `trim_qtvs`, but we
- have to be careful. Suppose (OF1a)
- qs = [ k::*, a::k ]
- S = [ k :-> UnliftedType ]
- Then we want
- unbound_qs = [ a::UnliftedType ] -- Must apply S to q's kind!!
-
- And (OF1b), although I'm not sure if this can acutally happen:
- qs = [ k::*, a::(k::*), b::(a::k) ]
- S = [ k :-> UnliftedType ]
- We want
- unbound_qs = [ a::UnliftedType, b::(a::UnliftedType) ]
- Note that the occurrence of `a` in b's kind should be replaced by the
- newly-kinded `a` not the original `a::k`.
-
- This fancy footwork for `fd_qtvs` is done by `trim_qtvs`. It
- * Drops a quantified tyvar that /is/ matched
- * Substitutes in the kind of a quantified tyvar `a` that is /not/ matched
- * Adds the substitution [a::k :-> a::S(k)] to the substitution
+ [W] (Int -> Maybe gamma) ~ alpha -- Fresh gamma
+We have learned that `alpha` must be a list of functions, but that is all;
+we don't know `gamma`.
+
+It gets tricker. Suppose we have
+ type family F @k a = r | r -> k,a
+ type instance F @k (Proxy @k (a::k)) = T k
+ [W] F alpha beta ~ T Type
+Matching the RHS gives substitution [k :-> Type]. But we do /not/ want
+to end up with this:
+ FDEqns{ fd_qtvs = [a::k], fd_eqs = [ Proxy @Type (a::k) ~ alpha ] }
+because that `k`, hidden inside the kind of `a`, escapes into the solver.
+
+Instead we must not only "trim" the quantified variables of the equation,
+but /substitute/ in the kinds of the leftover quantified ones: see Note [trimQtvs].
+Then we get
+ FDEqns{ fd_qtvs = [a::Type], fd_eqs = [ Proxy @Type (a::Type) ~ alpha ] }
+
+Side note:
+
+You might wonder whether we can use the same solution as we do for /closed/
+families, by generating an equality for the RHSs; see (CF7). But we can't.
+Example:
+ type family G a where G Int = Char
+ type family F a b = r | r -> a
+ type instance F a [c] = (a, G a) -- (I1)
+ type instance F Int Bool = (Int, Bool) -- (I2)
+ [W] F alpha Bool ~ (Int,gamma)
+Note that (I1) and (I2) are pariwise-injective: if the RHSs are the same,
+the LHSs are the same /in the injective position(s)/. See Section 4.2 in
+the "Injective Type Families" paper. We pre-match (I1) against the Wanted
+giving substitution [a :-> Int]. We /cannot/ then generate
+ FDEqns { fd_qtvs = [a,c], fd_eqs = [ a~alpha
+ , (a,G a)~(Int,gamma) ] }
+where the second equality (wrongly)equates the RHSs. This is wrong because we
+can solve those fundeps unifying alpha:=Int, gamma:=Char, by reducing (G a) to
+Char. So we end up with [W] F Int Char, which is insoluble. Bad.
+
+End of side note.
+
+Note [trimQtvs]
+~~~~~~~~~~~~~~~
+In Note [Exploiting open type families], we needed to "trim" the quantified
+type variables of the axiom, removing ones that are eliminated by the
+auubstitution `S`. So can we just do this?
+ unbound_qs = qs \ dom(S)
+so that we could make fresh meta-variables for only the unbound `qs`.
+No, we can't. Suppose (TQ1)
+ qs = [ k::*, a::k ]
+ S = [ k :-> UnliftedType ]
+Then we want
+ unbound_qs = [ a::UnliftedType ] -- Must apply S to q's kind!!
+
+And (TQ2), although I'm not sure if this can actually happen:
+ qs = [ k::*, a::(k::*), b::(a::k) ]
+ S = [ k :-> UnliftedType ]
+We want
+ unbound_qs = [ a::UnliftedType, b::(a::UnliftedType) ]
+Note that the occurrence of `a` in b's kind should be replaced by the
+newly-kinded `a` not the original `a::k`.
+
+The function `trimQtvs` does the job. It
+ * Drops a quantified tyvar that /is/ matched
+ * Substitutes in the kind of a quantified tyvar `a` that is /not/ matched
+ * Adds the substitution [a::k :-> a::S(k)] to the substitution
+
+We only use `trimQtvs` for /open/ families. For /closed/ families where we
+/unify/ (rather than match) the equation with the Wanted, it just doesn't work
+(#27994), because the substitution `S` has both meta-tyvars and instance-head
+tyvars in the range. See (CF7).
Note [Exploiting closed type families] see `mkTopClosedFamEqFDs`
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1194,9 +1250,6 @@ More precisely, here is the very clever Closed Family Fundep Algorithm (CFFA)
with fresh unification vars in lhs and rhs for the quantified variables of the
equation.
- Actually we take advantage of the substitution generated by the relevance
- check, see (CF7) below.
-
See Note [Relevance] for what "relevant" means.
We need to take care about non-termination; see (CF3).
@@ -1303,7 +1356,7 @@ Key point: equations that are not relevant do not need to be considered for fund
I was looking at non-termination for closed type families, but it's a small
improvement in general.
- This bale-out is implementedn in `tryFDEqns`.
+ This bale-out is implemented in `tryFDEqns`.
(CF5) Consider (see "Yikes5" in #23162):
type family F a where
@@ -1353,32 +1406,20 @@ Key point: equations that are not relevant do not need to be considered for fund
`app` Proxy @'[ty_n]
Every `app` call gives rise to a Wanted of the form:
-
[W] MapId acc_i ++ MapId '[ty_i] ~ MapId (acc_i ++ '[ty_i])
-
while the overall result type gives us a Wanted of the form
-
[W] acc_n ++ '[ty_n] ~ [ty_1, ..., ty_n]
-
By using (CFFA) on this result Wanted, we deduce that we must have
-
acc_n ~ [ty_1, ..., ty_{n-1}]
-
which is a flat list. Repeating the process, (CFFA) allows us to deduce that
-
acc_i ~ [ty_1, ..., ty_{i-1}]
-
for all i. This allows the other Wanteds to be solved directly, giving rise to
proof terms with the typical triangular O(n^2) shape
-
co_i = (O(i) proof that MapId acc_i ++ MapId '[ty_i] ~ acc_{i+1})
; (O(i) proof that acc_{i+1} ~ MapId (acc_i ++ '[ty_i]))
-
However, /without/ (CFFA), 'acc_i' is not unified with a flat list but is left
as the nested application:
-
acc_i ~ (... (('[ty_1] ++ '[ty_2]) ++ '[ty_3]) ... ++ '[ty_{i-1}])
-
This means that 'MapId acc_i' is stuck until we reduce the above, which takes
O(i^2) type family reduction steps, instead of O(i). The same applies to
the other proof term involving 'MapId (acc_i ++ '[ty_i])'.
@@ -1388,29 +1429,77 @@ Key point: equations that are not relevant do not need to be considered for fund
instead of relying on recursively built sub-proof terms, which brings down
coercion sizes (in certain situations) from O(n^3) to O(n^2).
-(CF7) Relevance. When computing relevance in the Closed Family Fundep Algorithm,
- for [W] F wlhs1 wlhs2 ~ wrhs, against an equation F lhs1 lhs2 ~ rhs
- we get back a pre-unifying substitution S that makes the two as equal as poss.
- Then we use `trim_qtvs` in exactly the same way as in
- (OF1) of Note [Exploiting open type families], to generate qtvs' and S'
- Then we generate
- FDEqns { fd_qtvs = qtvs', fd_eqs [ S'(lhs1) ~ wlhs1
- , S'(lhs2) ~ wlhs2
- , S'(rhs) ~ wrhs ] }
- Notice that we do /not/ apply S' to wlhs/wrhs. These type contain unification
- variables that we must actually unify! Example
+(CF7) Relevance. The function `getRelevantBranches` finds the relevant branch(es)
+ using the (CFFA). Given an equation
+ type family F a b where { ...; F lhs1 lhs2 = rhs; ... }
+ is the equation relevant for this Wanted?
+ [W] F wlhs1 wlhs2 ~ wrhs
+ We pre-unify [wrhs,wlhs1,wlhs2] against [rhs,lhs1,lhs2], getting back a
+ substitution `S` that makes the two as equal as poss. This substitution can bind
+ both /quantified/ type variables from the instance, and /unification variables/
+ from the solver. Moreover, both kind of type variable can appear in the range
+ of the substitution.
+
+ That's pretty complicated, so we are very cautious about using the returned
+ substitution `S`. I had a long struggle (#27994) when we were previously trying to
+ apply that returned substitution as an optimisation. But because type variables
+ can occur in kinds, it was a losing battle -- I ended up with TyVars from the
+ instance head escaping into the solver. Consider
+ type F :: forall k. k -> *
+ type instance F k a where
+ F (k->*) (b::k->*) = Int
+ [W] F kappa (alpha::kappa) ~ Int
+ We unify the Wanted with the equation to get the substitution
+ [ kappa :-> k->*, b :-> (alpha::k->*) ]
+ I tried using `trimQtvs` (see Note [trimQtvs]) but my head hurt
+ FAR too much: #27994 is an excellent example.
+
+ So here's the plan:
+ (A) As a fast-path optimisation, if `S` binds all the quantified variables of
+ the type-family equation (which is common), it's all easy: generate
+ FDEqns { fd_qtvs = []
+ , fd_eqs = [ S(lhs1) ~ wlhs1, S(lhs2) ~ wlhs2, S(rhs) ~ wrhs }
+ Note that we do not apply S to `wlhs1/2` or `wrhs`; see (CF9).
+ And note that `fd_qtvs` is empty, because `S` eliminates all the quantified
+ type variables.
+
+ (B) If not, then /discard `S` entirely/ and instead generate
+ FDEqns { fd_qtvs = qtvs
+ , fd_eqs = [ lhs ~ wlhs1, lhs2 ~ wlhs2, rhs ~ wrhs }
+ Now `instantiateFDEqns` will generate fresh unification variables for the
+ `qtvs` and the solver will in effect reconstruct `S`.
+
+(CF8) When computing relevance (Note [Relevance] (R2)) we use `noEarlierMatch`
+ on S(lhs). But we must use /deep/ substitution on LHS. Consider
+ type family F (a :: k) r where
+ F @Type (Maybe Bool) r = r -- B0
+ F @Type ((f :: Type -> Type) Int) r = Bool -- B1
+ F @k ((g :: Type -> k) Int) r = r -- B2
+
+ [W] F @Type alpha Char ~ Char
+ The `tcUnifyTysForInjectivity` will return substitution
+ [k :-> Type, r :-> Char, alpha :-> (g :: Type->Type) Int], with g unbound
+ If we used `substTy` on the LHS-tys for B2 we'd get
+ lhs_tys' = [Type, (g :: Type -> k) Int, Char]
+ That's ill-kinded because of the free `k`; and (worse) when `noEarlierMatch` matches
+ lhs_tys' against earlier equations, (B1) will fail to match. So (B2) will be
+ judged relevant, even though it isn't. Bad, bad. Use deep substitution.
+
+(CF9) Notice that, in (CF7) when generating the fundep equations for the solver to
+ deal with, we do /not/ apply the pre-unifying substitution `S` to the Wanted types.
+ The types wlhs,wrhs contain meta-variables that we must actually unify! Example
type family F a b where
F [a] (Maybe b) = (a, G b)
[W] F alpha beta ~ (Int, [gamma])
Pre-unification gives [alpha :-> [a], beta :-> Maybe b, a :-> Int]
- This substitution eliminates the quantified variable `a` but not `b`, so we
- want this:
- FDEqns { fd_qtvs = [b], fd_eqs [ [Int] ~ alpha
- , Maybe b ~ beta
- , (Int,G b) ~ (Int, [gamma]) ] }
-
- Notice also that by applying the substitution to the template but not to the
- Wanted, we uphold the `fd_eqs` invariant in `FDEqns` (see its data type decl)
+ We don't want to substitute `alpha` away! In fact we just generate these eqns:
+ FDEqns { fd_qtvs = [a,b], fd_eqs [ [a] ~ alpha
+ , Maybe b ~ beta
+ , (a, G b) ~ (Int, [gamma]) ] }
+ with `fd_qtvs` being the quantified variables of the equation, the LHSs
+ being the types from the equation and the RHSs being the types from the Wanted.
+ Notice that we thereby uphold the `fd_eqs` invariant in `FDEqns` (see its data
+ type decl).
Note [Cache-caused loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1517,8 +1606,8 @@ instantiateFunDepEqns (FDEqns { fd_qtvs = qtvs, fd_eqs = eqs })
rev_eqs = reverse eqs
-- (reverse eqs): See Note [Reverse order of fundep equations]
- -- The kinds of `qtvs` can have free variables, because of `trim_qtvs`
- -- Example: T27828b
+ -- The kinds of `qtvs` can have free variables;
+ -- in the FDEqns produced by GHC.Tc.Instance.FunDeps.improveFromInstEnv
empty_subst = mkEmptySubst $ mkInScopeSet $
tyCoVarsOfTypes (map tyVarKind qtvs)
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -61,7 +61,6 @@ import GHC.Prelude
import GHC.Hs
import GHC.Tc.Errors.Types ( HsCtxt(..) )
-import GHC.Tc.Errors.Ppr ( pprHsCtxt )
import GHC.Tc.Utils.Concrete
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Instantiate
@@ -2801,17 +2800,15 @@ uType_defer (UE { u_loc = loc, u_defer = ref
-- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality
-- Error trace only
- -- NB. do *not* call tidyErrCtxt unless tracing is on,
- -- because it is hugely expensive (#5631)
+ -- NB. do *not* call tidyErrCtxt because
+ -- (a) it is hugely expensive (#5631) and
+ -- (b) it crashes in some cases because because it reads
+ -- res_ty too early via FunResCtxt and getCheckExpType
; whenDOptM Opt_D_dump_tc_trace $
- do { ctxt <- getErrCtxt
- ; err_ctxt <- tidyErrCtxt emptyTidyEnv ctxt
- ; traceTc "utype_defer" $
- vcat ( ppr role
- : debugPprType ty1
- : debugPprType ty2
- : map pprHsCtxt err_ctxt )
- ; traceTc "utype_defer2" (ppr co) }
+ traceTc "utype_defer" $
+ vcat [ text "role:" <+> ppr role
+ , text "ty1:" <+> debugPprType ty1
+ , text "ty2:" <+> debugPprType ty2 ]
; return co }
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -229,9 +229,17 @@ uniqAway' in_scope var
-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the
-- given 'InScopeSet'. This must be used very carefully since one can very easily
-- introduce non-unique 'Unique's this way. See Note [Local uniques].
+--
+-- Despite its name, there is nothing unsafe about it, provided you
+-- know that all it does is find a unique not in the in-scope set.
+-- Two calls with the same in-scope set will (of course) produce the
+-- same unique.
unsafeGetFreshLocalUnique :: InScopeSet -> Unique
unsafeGetFreshLocalUnique (InScope set)
| Just (uniq,_) <- Word64Map.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
+ -- (lookupLT k m) finds the largest (key,value) in `m` such that key < k
+ -- So if we make k=maxLocalUnique we'll just get the largest key in `m`
+ -- Then all we need do is increment it, and that'll give us a fresh one
, let uniq' = mkLocalUnique uniq
, not $ uniq' `ltUnique` minLocalUnique
= incrUnique uniq'
=====================================
testsuite/tests/typecheck/should_compile/T27994.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+module T27994a (l2) where
+
+import Data.Kind (Constraint, Type)
+
+l1 :: [String]
+l1 = ["hello", "world!"]
+
+l2 :: [Int]
+l2 = gmap (HCons length HNil) l1
+
+-----
+
+type HList :: [Type] -> Type
+data HList p where
+ HNil :: HList '[]
+ HCons :: x -> HList xs -> HList (x:xs)
+
+type ($$) :: k -> [Type] -> Type
+type family s $$ p where
+ (s :: Type) $$ '[] = s
+ (s :: Type -> k) $$ (a:b) = s a $$ b
+
+type Doms :: [Type] -> [Type]
+type family Doms t where
+ Doms '[] = '[]
+ Doms ((a -> b) : t) = a : Doms t
+
+type Codoms :: [Type] -> [Type]
+type family Codoms t where
+ Codoms '[] = '[]
+ Codoms ((a -> b) : t) = b : Codoms t
+
+type GMap :: k -> [Type] -> Constraint
+class GMap (s :: k) t | t -> k where
+ gmap :: HList t -> s $$ Doms t -> s $$ Codoms t
+
+instance GMap [] '[a -> b] where
+ gmap :: HList '[a -> b] -> [a] -> [b]
+ gmap (HCons f HNil) = go
+ where
+ go :: [a] -> [b]
+ go [] = []
+ go (x:xs) = f x : go xs
=====================================
testsuite/tests/typecheck/should_compile/T27994a.hs
=====================================
@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, GADTs, AllowAmbiguousTypes #-}
+module T27994 where
+
+import Data.Kind (Type)
+import Data.Proxy (Proxy)
+
+type F :: forall{k}. k -> Type -> Type
+type family F s x where
+ F (s :: Type -> k) (Proxy s) = Int
+
+f :: forall k (s :: k) x. F s x -> x
+f _ = undefined
+
+g :: Proxy Maybe -> ()
+g _ = ()
+
+data T a where
+ MkT :: T Int
+
+test :: T a -> ()
+test t = (\y -> case t of MkT -> g y) (f (3 :: Int))
+
+{- [W] F @k_azX (s_azY::k_azX) p_azN ~ Int
+
+unify [*->k, s::*->k, Proxy @(*->k) (s::*->k), Int]
+ ~ [k_azX, s_azY::k_azX, p_azN, Int]
+
+ --> [ k_azX :-> (* -> k)
+ , s :-> s_azY::k_azX
+ , p_azN :-> Proxy @(*->k) (s::*->k) ]
+
+ fixpt --> [ k_azX :-> Type -> k
+ , s :-> s_azY::(Type -> k)
+ , p_azN :-> Proxy @(Type->k) (s::k_azX) ]
+
+Generate a [W] for each pair
+ [W] k ~ k_azX
+ [W] s ~ s_azY
+ [W] Proxy s ~ p_azN
+ [W] Int ~ Int
+As an opt (claim) apply subst first
+ [W] k_azX ~ k_azX
+ [W] s_azY ~ s_azY
+ [W] Proxy s_azY ~ p_azN
+ [W] Int ~ Int
+
+-- [W] F @k_azX s_azY[tau] p_azN ~ Int
+-- Want: fresh k' s'
+-- [W] k' ~ k_azX
+-- [W] s':k' ~ s_azY:k_azX
+-- [W] Proxy s' ~ x
+-}
+
=====================================
testsuite/tests/typecheck/should_compile/T27994b.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+
+
+module T27994b where
+import Data.Proxy
+
+type family G a where G Int = Char
+type family F a b = r | r -> a
+type instance F a [c] = (a, G a) -- instance 1
+type instance F Int Bool = (Int, Bool) -- instance 2
+
+h :: Proxy a -> F a Bool
+h = h
+k :: (Int, b) -> b
+k = k
+
+test = k (h Proxy) `seq` () -- [W] F alpha Bool ~ (Int, gamma)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -972,4 +972,6 @@ test('T27557', normal, compile, [''])
test('T27664', normal, compile, [''])
test('T27916', normal, compile, [''])
test('T26543_orig', normal, compile, [''])
-
+test('T27994', normal, compile, [''])
+test('T27994a', normal, compile, [''])
+test('T27994b', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d842c67282c6719534e11cdf2c1486…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d842c67282c6719534e11cdf2c1486…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] rts: tombstone Weak# copies that lose an evacuation race (#23160)
by Marge Bot (＠marge-bot) 31 Oct '26
by Marge Bot (＠marge-bot) 31 Oct '26
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
13d38047 by Luite Stegeman at 2026-10-31T09:19:11-04:00
rts: tombstone Weak# copies that lose an evacuation race (#23160)
Mark the losing copy of a Weak# during an evacuation race in parallel
GC with stg_DEAD_WEAK_info. This ensures that the nonmoving GC
doesn't follow dangling pointers, leading to crashes.
Fixes #23160
- - - - -
5 changed files:
- + changelog.d/fix-nonmoving-weak-evacuation-race-23160
- rts/sm/Evac.c
- + testsuite/tests/rts/T23160.hs
- + testsuite/tests/rts/T23160.stdout
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/fix-nonmoving-weak-evacuation-race-23160
=====================================
@@ -0,0 +1,10 @@
+section: rts
+synopsis: Fix crash in the nonmoving GC caused by racing weak pointer evacuation
+issues: #23160
+mrs: !16522
+description:
+ When two threads compete for evacuating the same ``Weak#`` object, the
+ losing thread would produces an object that is never put on a weak list.
+ This resulted in pointers in the object getting stale, and the nonmoving
+ GC crashing trying to follow them. This is fixed by immediately marking
+ the losing weak object as dead.
=====================================
rts/sm/Evac.c
=====================================
@@ -265,6 +265,17 @@ copy_tag(StgClosure **p, const StgInfoTable *info,
LDVW(to) = 0;
}
#endif
+ // The weak we just created is dead and doesn't appear on any
+ // weak pointer list. This means that its value, finalizer and link
+ // pointers will not be updated. However the nonmoving collector
+ // can still see it (update remembered set, mutable list), so we must
+ // tombstone it to avoid following stale pointers. See #23160.
+
+ // The copy is still thread-private here so a plain store
+ // suffices.
+ if (INFO_PTR_TO_STRUCT(info)->type == WEAK) {
+ ((StgClosure *)to)->header.info = &stg_DEAD_WEAK_info;
+ }
return evacuate(p); // does the failed_to_evac stuff
} else {
// This doesn't need to have RELEASE ordering since we are guaranteed
=====================================
testsuite/tests/rts/T23160.hs
=====================================
@@ -0,0 +1,50 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+-- Regression test for multiple threads competing for evacuating a Weak#
+-- Based on the reproducer by Ben Gamari in #23160
+
+
+import GHC.Exts
+import GHC.Weak
+import GHC.IO (IO(..))
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import System.Mem
+import System.Mem.Weak
+
+data MBA = MBA (MutableByteArray# RealWorld)
+
+newPinnedMBA :: Int -> IO MBA
+newPinnedMBA (I# n) = IO $ \s ->
+ case newPinnedByteArray# n s of
+ (# s', mba #) -> (# s', MBA mba #)
+
+mkMBAWeak :: MBA -> a -> IO (Weak a)
+mkMBAWeak (MBA mba) v = IO $
+ \s -> case mkWeakNoFinalizer# mba v s of
+ (# s', w #) -> (# s', Weak w #)
+
+forced :: String -> IO Int
+forced a = evaluate (length a)
+
+worker :: IO ()
+worker = forever $ do
+ xs <- mapM f [0..200000::Int]
+ mapM_ (\w -> deRefWeak w >>= mapM_ forced) (take 1000 xs)
+ where
+ f n = do
+ mba <- newPinnedMBA 10
+ v <- forced (show n)
+ mkMBAWeak mba (show (n + v))
+
+main :: IO ()
+main = do
+ forkIO $ forever $ do
+ threadDelay (100*1000)
+ performMajorGC
+
+ replicateM_ 10 (forkIO worker)
+ threadDelay (25*1000*1000)
+ putStrLn "OK"
=====================================
testsuite/tests/rts/T23160.stdout
=====================================
@@ -0,0 +1 @@
+OK
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -767,3 +767,12 @@ test('T27526',
extra_hc_opts('-fno-prof-auto -fprof-late -rtsopts'),
extra_run_opts('+RTS -kc2k -kb256 -A64k -AL8k -RTS')],
compile_and_run, [''])
+
+test('T23160',
+ [ req_target_smp
+ , extra_ways(['nonmoving_thr_sanity'])
+ , only_ways(['nonmoving_thr_sanity'])
+ , extra_run_opts('+RTS -A1M -N4 -RTS')
+ , unless(slow(), skip)
+ ],
+ compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13d38047f6ef2cba401867f031c9ee5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13d38047f6ef2cba401867f031c9ee5…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] Don't report -XStrict-generated bangs under -Wredundant-bang-patterns
by Marge Bot (＠marge-bot) 31 Oct '26
by Marge Bot (＠marge-bot) 31 Oct '26
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
cc533b66 by Sasha Bogicevic at 2026-10-31T09:18:15-04:00
Don't report -XStrict-generated bangs under -Wredundant-bang-patterns
The -XStrict flag causes the desugarer to insert bang patterns.
These are not user-written, so -Wredundant-bang-patterns must not
report them.
To achieve this, the desugarer now tracks whether it is desugaring
compiler-generated code (similar to the typechecker's 'tcl_in_gen_code').
Bangs inserted by -XStrict are given generated spans, which suppresses
the "redundant bang" warnings without otherwise affecting pattern-match
warnings.
Fixes #27323
- - - - -
15 changed files:
- + changelog.d/T27323
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/HsToCore/Utils.hs
- + testsuite/tests/pmcheck/should_compile/T27323.hs
- + testsuite/tests/pmcheck/should_compile/T27323b.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/warnings/should_compile/Overflow.stderr-ws-32
- testsuite/tests/warnings/should_compile/Overflow.stderr-ws-64
- testsuite/tests/warnings/should_compile/T13256.stderr-ws-32
- testsuite/tests/warnings/should_compile/T13256.stderr-ws-64
Changes:
=====================================
changelog.d/T27323
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+synopsis: Don't report ``-XStrict``-generated bang patterns under ``-Wredundant-bang-patterns``
+description:
+ Bangs introduced by ``-XStrict`` are no longer reported as redundant under
+ ``-Wredundant-bang-patterns``, as they are not user-written.
+issues: #27323
+mrs: !16395
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -383,12 +383,14 @@ tidyEqnInfo :: MatchId -> EquationInfo
tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
-tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do
- (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat
+tidyEqnInfo v eqn@(EqnMatch { eqn_pat = p@(L loc _) }) = do
+ (wrap, pat') <- tidyLPat v p
return (wrap, eqn{eqn_pat = L loc pat' })
+tidyLPat :: MatchId -> LPat GhcTc -> DsM (DsWrapper, Pat GhcTc)
+tidyLPat v (L loc pat) = putSrcSpanDsA loc (tidy1 v pat)
+
tidy1 :: MatchId -- The scrutinee
- -> Bool -- `True` if the pattern was generated, `False` if it was user-written
-> Pat GhcTc -- The pattern against which it is to be matched
-> DsM (DsWrapper, -- Extra bindings to do before the match
Pat GhcTc) -- Equivalent pattern
@@ -399,21 +401,22 @@ tidy1 :: MatchId -- The scrutinee
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) and returns any created bindings in the wrapper.
-tidy1 v g (ParPat _ pat) = tidy1 v g (unLoc pat)
-tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat)
-tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p
-tidy1 v g (ModifiedPat _ _ pat) = tidy1 v g (unLoc pat)
+tidy1 v (ParPat _ pat) = tidyLPat v pat
+tidy1 v (SigPat _ pat _) = tidyLPat v pat
+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p
+tidy1 v (ModifiedPat _ _ pat) = tidyLPat v pat
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v _ (VarPat _ (L _ var))
+tidy1 v (VarPat _ (L _ var))
= return (bindMatchId var v, WildPat (idType var))
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v g (AsPat _ (L _ var) pat)
- = do { (wrap, pat') <- tidy1 v g (unLoc pat)
+tidy1 v (AsPat _ (L _ var) pat)
+
+ = do { (wrap, pat') <- tidyLPat v pat
; return (bindMatchId var v . wrap, pat') }
{- now, here we handle lazy patterns:
@@ -427,7 +430,7 @@ tidy1 v g (AsPat _ (L _ var) pat)
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
-tidy1 v _ (LazyPat _ pat)
+tidy1 v (LazyPat _ pat)
-- This is a convenient place to check for unlifted types under a lazy pattern.
-- Doing this check during type-checking is unsatisfactory because we may
-- not fully know the zonked types yet. We sure do here.
@@ -441,14 +444,14 @@ tidy1 v _ (LazyPat _ pat)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (matchIdType v)) }
-tidy1 _ _ (ListPat ty pats)
+tidy1 _ (ListPat ty pats)
= return (idDsWrapper, unLoc list_ConPat)
where
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
(mkNilPat ty)
pats
-tidy1 _ _ (TuplePat tys pats boxity)
+tidy1 _ (TuplePat tys pats boxity)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
@@ -458,34 +461,37 @@ tidy1 _ _ (TuplePat tys pats boxity)
Boxed -> tys
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-tidy1 _ _ (SumPat tys pat alt arity)
+tidy1 _ (SumPat tys pat alt arity)
= return (idDsWrapper, unLoc sum_ConPat)
where
sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ g (LitPat _ lit)
- = do { unless g $
+tidy1 _ (LitPat _ lit)
+ = do { in_gen <- inGeneratedCodeDs;
+ unless in_gen $
warnAboutOverflowedLit lit
; return (idDsWrapper, tidyLitPat lit) }
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ g (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
- = do { unless g $
+tidy1 _ (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
+ = do { in_gen <- inGeneratedCodeDs;
+ unless in_gen $
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
in warnAboutOverflowedOverLit lit'
; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-- NPlusKPat: we may want to warn about the literals
-tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
- = do { unless g $ do
+tidy1 _ n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
+ = do { in_gen <- inGeneratedCodeDs;
+ unless in_gen $ do
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
; return (idDsWrapper, n) }
-tidy1 _ _ (OrPat ty lpats)
+tidy1 _ (OrPat ty lpats)
-- See Note [Implementation of OrPatterns]. We desugar
-- (1; 2; 3)
-- to
@@ -514,44 +520,44 @@ tidy1 _ _ (OrPat ty lpats)
single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField)
-- Everything else goes through unchanged...
-tidy1 _ _ non_interesting_pat
+tidy1 _ non_interesting_pat
= return (idDsWrapper, non_interesting_pat)
--------------------
-tidy_bang_pat :: MatchId -> Bool -> SrcSpanAnnA -> Pat GhcTc
+tidy_bang_pat :: MatchId -> SrcSpanAnnA -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v g _ (ParPat _ (L l p)) = tidy_bang_pat v g l p
-tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p
+tidy_bang_pat v _ (ParPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
-tidy_bang_pat v g l (AsPat x v' p)
- = tidy1 v g (AsPat x v' (L l (BangPat noExtField p)))
-tidy_bang_pat v g l (XPat (CoPat w p t))
- = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
-tidy_bang_pat v g l (OrPat x (p:|ps)) -- push bang into first pat alt
- = tidy1 v g (OrPat x (L l (BangPat noExtField p) :| ps))
+tidy_bang_pat v l (AsPat x v' p)
+ = tidy1 v (AsPat x v' (L l (BangPat noExtField p)))
+tidy_bang_pat v l (XPat (CoPat w p t))
+ = tidy1 v (XPat $ CoPat w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v l (OrPat x (p:|ps)) -- push bang into first pat alt
+ = tidy1 v (OrPat x (L l (BangPat noExtField p) :| ps))
-- Discard bang around strict pattern
-tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p
-tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p
-tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p
-tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p
+tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
+tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p
+tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p
+tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p
-- Data/newtype constructors
-tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
- , pat_args = args
- , pat_con_ext = ConPatTc
- { cpt_arg_tys = arg_tys
- }
- })
+tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
+ , pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = arg_tys
+ }
+ })
-- Newtypes: push bang inwards (#9844)
=
if isNewTyCon (dataConTyCon dc)
- then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
- else tidy1 v g p -- Data types: discard the bang
+ then tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
+ else tidy1 v p -- Data types: discard the bang
where
(ty:_) = dataConInstArgTys dc arg_tys
@@ -570,7 +576,7 @@ tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
--
-- NB: SigPatIn, ConPatIn should not happen
-tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExtField (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpanAnnA
@@ -954,7 +960,7 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
; ldi_nablas <-
if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat
then addCoreScrutTmCs (maybeToList mb_scrut) [var] $
- pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
+ pmcPatBind (DsMatchContext ctx locn) var pat
else getLdiNablas
; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.HsToCore.Utils
import GHC.Hs
+import GHC.Rename.Utils (wrapGenSpan)
import GHC.Tc.Utils.TcMType ( shortCutLit )
import GHC.Tc.Utils.TcType
@@ -580,7 +581,8 @@ tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat con lit
- = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] [])
+ -- Mark the generated literal to avoid duplicate -Woverflowed-literals.
+ = unLoc (mkPrefixConPat con [wrapGenSpan $ LitPat noExtField lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.HsToCore.Monad (
duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,
newUniqueId, newPredVarDs, newStaticId,
- getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
+ getSrcSpanDs, inGeneratedCodeDs, putSrcSpanDs, putSrcSpanDsA,
mkNamePprCtxDs,
newUnique,
UniqSupply, newUniqueSupply,
@@ -584,6 +584,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env tcm_plugins ptc msg_var
, dsl_loc = real_span
, dsl_nablas = Ldi initNablas
, dsl_unspecables = Just emptyVarSet
+ , dsl_in_generated_code = False
}
in (gbl_env, lcl_env)
@@ -676,13 +677,17 @@ getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
+-- | See 'dsl_in_generated_code'
+inGeneratedCodeDs :: DsM Bool
+inGeneratedCodeDs = dsl_in_generated_code <$> getLclEnv
+
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (RealSrcSpan real_span _) thing_inside
- = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
+ = updLclEnv (\ env -> env {dsl_loc = real_span, dsl_in_generated_code = False}) thing_inside
putSrcSpanDs UnhelpfulSpan{} thing_inside
= thing_inside
putSrcSpanDs GeneratedSrcSpan{} thing_inside
- = thing_inside
+ = updLclEnv (\ env -> env {dsl_in_generated_code = True}) thing_inside
putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA loc = putSrcSpanDs (locA loc)
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -104,7 +104,7 @@ whenDoingPmc no_pmc thing_inside
Ldi nablas -> thing_inside nablas }
-- | Check a pattern binding (let, where) for exhaustiveness.
-pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM LdiNablas
+pmcPatBind :: DsMatchContext -> Id -> LPat GhcTc -> DsM LdiNablas
pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
= whenDoingPmc NoPmc $ \ !missing ->
mb_discard_warnings $ do
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -155,11 +155,15 @@ desugarPat x pat = case pat of
VarPat _ y -> pure (mkPmLetVar (unLoc y) x)
ParPat _ p -> desugarLPat x p
LazyPat _ _ -> pure GdEnd -- like a wildcard
- BangPat _ p@(L l p') ->
+ BangPat _ p@(L l p') -> do
-- Add the bang in front of the list, because it will happen before any
-- nested stuff.
+ in_gen <- inGeneratedCodeDs
+ -- A bang inserted by -XStrict (decideBangHood) has no SrcInfo: it is
+ -- divergence-checked but never reported as redundant (#27323).
+ let pm_loc | in_gen = Nothing
+ | otherwise = Just (SrcInfo (L (locA l) (ppr p')))
consGrdDag (PmBang x pm_loc) <$> desugarLPat x p
- where pm_loc = Just (SrcInfo (L (locA l) (ppr p')))
-- (x@pat) ==> Desugar pat with x as match var and handle impedance
-- mismatch with incoming match var
@@ -311,11 +315,11 @@ desugarPatV pat = do
pure (x, grds)
desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag
-desugarLPat x = desugarPat x . unLoc
+desugarLPat x (L loc pat) = putSrcSpanDsA loc (desugarPat x pat)
-- | 'desugarLPat', but also select and return a new match var.
desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag)
-desugarLPatV = desugarPatV . unLoc
+desugarLPatV (L loc pat) = putSrcSpanDsA loc (desugarPatV pat)
-- | @desugarListPat _ x [p1, ..., pn]@ is basically
-- @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever
@@ -374,11 +378,11 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case
-- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)
pure (con_grd `consGrdDag` arg_grds)
-desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
+desugarPatBind :: SrcSpan -> Id -> LPat GhcTc -> DsM (PmPatBind Pre)
-- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
-- See Note [Suppress warnings in PMC desugaring]
desugarPatBind loc var pat = discardWarningsDs $
- PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat
+ PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarLPat var pat
desugarEmptyCase :: Id -> DsM PmEmptyCase
desugarEmptyCase var = pure PmEmptyCase { pe_var = var }
@@ -633,21 +637,16 @@ Consider (#21761)
idV :: Void -> Void
idV v = v
-Without -XStrict, we would not warn here. But with -XStrict, there is an
-implicit bang on `v` and we should give an inaccessible warning for the RHS.
-The way we account for that is by calling `decideBangHood` on patterns
-in a `Match`, which inserts the implicit bang.
+With -XStrict, there is an implicit bang pattern on `v` as per
+Note [decideBangHood], so the RHS is inaccessible and we must report it as such.
-Making the call here actually seems redundant with the call to `decideBangHood`
-in `GHC.HsToCore.Match.matchWrapper`, which does it *after* it calls the
-pattern-match checker on the Match's patterns. It would be great if we could expect
-`matchWrapper` to pass the bang-adorned `Match` to the pattern-match checker,
-but sadly then we get worse warning messages which would print `idV` as if the
-user *had* written a bang:
+The natural way to achieve this is described in #27677: insert the bang using
+'ExpansionPat' (see Note [Handling overloaded and rebindable constructs] in
+GHC.Rename.Expr). Then the pattern-match checker sees the bang pattern, while
+warning messages display the user-written pattern.
- Pattern match has inaccessible right hand side
-- In an equation for ‘idV’: idV v = ...
-+ In an equation for ‘idV’: idV !v = ...
-
-So we live with the duplication.
+This approach hasn't been implemented yet, so for the time being 'desugarMatches'
+calls 'decideBangHood' itself, duplicating the call in 'GHC.HsToCore.Match.matchWrapper'.
+'decideBangHood' gives the bangs it inserts a generated span, so that they are
+never reported as redundant (see Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check).
-}
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.HsToCore.Types (
DsMetaEnv, DsMetaVal(..), CompleteMatches
) where
-import GHC.Prelude (Int)
+import GHC.Prelude (Bool, Int)
import Data.IORef
@@ -125,6 +125,7 @@ data DsLclEnv
-- ^ See Note [Desugaring non-canonical evidence]
-- This field collects all un-specialisable evidence variables in scope.
-- Nothing <=> don't collect this info (used for the LHS of Rules)
+ , dsl_in_generated_code :: Bool -- ^ Are we desugaring compiler-generated code?
}
-- Inside [| |] brackets, the desugarer looks
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -72,6 +72,7 @@ import GHC.Unit.Module
import GHC.Builtin.KnownKeys
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Rename.Utils (wrapGenSpan')
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc
@@ -1024,8 +1025,9 @@ Specifically:
-}
--- | Use -XStrict to add a ! or remove a ~
--- See Note [decideBangHood]
+-- | Use -XStrict to add a ! or remove a ~, as per Note [decideBangHood].
+--
+-- The inserted bang is compiler-generated: see Note [Desugaring -XStrict matches in Pmc].
decideBangHood :: DynFlags
-> LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- Pattern with bang if necessary
@@ -1040,7 +1042,7 @@ decideBangHood dflags lpat
ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
- _ -> L l (BangPat noExtField lp)
+ _ -> wrapGenSpan' (locA l) (BangPat noExtField lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
=====================================
testsuite/tests/pmcheck/should_compile/T27323.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash, Strict #-}
+{-# OPTIONS_GHC -Wredundant-bang-patterns #-}
+
+import GHC.Prim (Int#)
+
+idInt# :: Int# -> Int#
+idInt# x = x
+
+main = pure ()
=====================================
testsuite/tests/pmcheck/should_compile/T27323b.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE Strict, MonoLocalBinds #-}
+{-# OPTIONS_GHC -Wredundant-bang-patterns #-}
+module T27323b where
+
+f :: Int -> Int
+f x = let (a, b) = (x, x) in a + b
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -190,4 +190,6 @@ test('T24845', [], compile, [overlapping_incomplete])
test('T22652', [], compile, [overlapping_incomplete])
test('T22652a', [], compile, [overlapping_incomplete])
test('T24867', [], compile_fail, [overlapping_incomplete])
+test('T27323', normal, compile, ['-Wredundant-bang-patterns'])
+test('T27323b', normal, compile, ['-Wredundant-bang-patterns'])
test('T27360', normal, compile, [overlapping_incomplete + '-g3'])
=====================================
testsuite/tests/warnings/should_compile/Overflow.stderr-ws-32
=====================================
@@ -1,18 +1,18 @@
-
Overflow.hs:8:15: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 10000000000000000000000000000000 is out of the Int# range -2147483648..2147483647
-Overflow.hs:13:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+Overflow.hs:13:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 100000000000000000000000000 is out of the Int# range -2147483648..2147483647
Overflow.hs:18:5: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 1000000000000000000000000000000 is out of the Int range -2147483648..2147483647
-Overflow.hs:22:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+Overflow.hs:22:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 100000000000000000000000000000000 is out of the Int range -2147483648..2147483647
Overflow.hs:27:6: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal -1 is out of the Word range 0..4294967295
-Overflow.hs:31:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+Overflow.hs:31:4: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal -1 is out of the Word range 0..4294967295
+
=====================================
testsuite/tests/warnings/should_compile/Overflow.stderr-ws-64
=====================================
@@ -1,18 +1,18 @@
-
Overflow.hs:8:15: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 10000000000000000000000000000000 is out of the Int# range -9223372036854775808..9223372036854775807
-Overflow.hs:13:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+Overflow.hs:13:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 100000000000000000000000000 is out of the Int# range -9223372036854775808..9223372036854775807
Overflow.hs:18:5: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 1000000000000000000000000000000 is out of the Int range -9223372036854775808..9223372036854775807
-Overflow.hs:22:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+Overflow.hs:22:3: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 100000000000000000000000000000000 is out of the Int range -9223372036854775808..9223372036854775807
Overflow.hs:27:6: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal -1 is out of the Word range 0..18446744073709551615
-Overflow.hs:31:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+Overflow.hs:31:4: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal -1 is out of the Word range 0..18446744073709551615
+
=====================================
testsuite/tests/warnings/should_compile/T13256.stderr-ws-32
=====================================
@@ -1,3 +1,3 @@
-
-T13256.hs:4:12: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+T13256.hs:4:31: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 100000000000000000000000000000000 is out of the Int range -2147483648..2147483647
+
=====================================
testsuite/tests/warnings/should_compile/T13256.stderr-ws-64
=====================================
@@ -1,3 +1,3 @@
-
-T13256.hs:4:12: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
+T13256.hs:4:31: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
Literal 100000000000000000000000000000000 is out of the Int range -9223372036854775808..9223372036854775807
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc533b66534ed384d91a174212c4ad9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc533b66534ed384d91a174212c4ad9…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][master] Have haddock --incremental look for the module in -this-unit-id
by Marge Bot (＠marge-bot) 31 Oct '26
by Marge Bot (＠marge-bot) 31 Oct '26
31 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e4610f2d by Facundo Domínguez at 2026-10-31T09:21:24-04:00
Have haddock --incremental look for the module in -this-unit-id
- - - - -
6 changed files:
- + testsuite/tests/haddock/haddock_testsuite/IncrementalUnitId.hs
- testsuite/tests/haddock/haddock_testsuite/Makefile
- testsuite/tests/haddock/haddock_testsuite/all.T
- + testsuite/tests/haddock/haddock_testsuite/haddockIncrementalUnitId.stdout
- utils/haddock/CHANGES.md
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
testsuite/tests/haddock/haddock_testsuite/IncrementalUnitId.hs
=====================================
@@ -0,0 +1,7 @@
+-- | A module to test that @haddock --incremental@ finds the module
+-- in the unit given by @-this-unit-id@.
+module IncrementalUnitId where
+
+-- | A value with some documentation.
+theAnswer :: Int
+theAnswer = 42
=====================================
testsuite/tests/haddock/haddock_testsuite/Makefile
=====================================
@@ -84,3 +84,12 @@ haddockForeignTest:
.PHONY: T26114
T26114:
'$(HADDOCK)' T26114.hs
+
+# Check that `haddock --incremental` looks for the module in the
+# unit given by `-this-unit-id`.
+.PHONY: haddockIncrementalUnitId
+haddockIncrementalUnitId:
+ rm -f IncrementalUnitId.hi IncrementalUnitId.o IncrementalUnitId.haddock IncrementalUnitId2.haddock
+ '$(TEST_HC)' -c -haddock -fwrite-interface -this-unit-id mypkg-1.0 IncrementalUnitId.hs
+ @echo "== haddock finds the module in the unit given by -this-unit-id =="
+ '$(HADDOCK)' --incremental=IncrementalUnitId --optghc=-this-unit-id=mypkg-1.0 --dump-interface=IncrementalUnitId.haddock
=====================================
testsuite/tests/haddock/haddock_testsuite/all.T
=====================================
@@ -30,3 +30,8 @@ test('T26114',
[ignore_stderr, req_haddock, extra_files(['T26114.hs'])],
makefile_test,
['T26114'])
+
+test('haddockIncrementalUnitId',
+ [ignore_stderr, req_haddock, extra_files(['IncrementalUnitId.hs'])],
+ makefile_test,
+ ['haddockIncrementalUnitId'])
=====================================
testsuite/tests/haddock/haddock_testsuite/haddockIncrementalUnitId.stdout
=====================================
@@ -0,0 +1,3 @@
+== haddock finds the module in the unit given by -this-unit-id ==
+Warning: IncrementalUnitId: could not find link destinations for:
+ - GHC.Internal.Types.Int
=====================================
utils/haddock/CHANGES.md
=====================================
@@ -1,3 +1,10 @@
+## Changes in next
+
+ * Allow the `--incremental` flag for modules in other units than main.
+ In the initial implementation, the argument to incremental could only
+ be the name of a module in the main unit. Now this can be changed by
+ specifying `--optghc=-this-unit-id=my-unit-id` when invoking haddock.
+
## Changes in 2.32.0
* Add highlighting for inline-code-blocks (sections enclosed in @'s)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -47,7 +47,6 @@ import Debug.Trace (traceMarkerIO)
import System.Exit (exitFailure ) -- TODO use Haddock's die
import Text.Printf
import GHC hiding (verbosity, SuccessFlag(..))
-import GHC.Builtin.Modules (mkMainModule_)
import qualified GHC.Data.EnumSet as EnumSet
import GHC.Data.FastString (unpackFS)
import GHC.Data.Graph.Directed
@@ -76,6 +75,7 @@ import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..))
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModIface (mi_semantic_module, mi_boot)
import GHC.Unit.Module.ModSummary (isBootSummary)
+import GHC.Unit.Types (stringToUnit, unitIdString)
import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text)
import GHC.Utils.Error (withTiming)
import GHC.Utils.Monad (mapMaybeM)
@@ -369,12 +369,14 @@ createOneShotIface verbosity flags instIfaceMap moduleNameStr = do
out verbosity verbose $ "Checking interface " ++ moduleNameStr ++ "..."
- -- Turn on GHC's one-shot mode
+ -- Turn on GHC's one-shot mode.
dflags <- (\df -> df{ ghcMode = OneShot }) <$> getDynFlags
modifySession $ hscSetFlags dflags
hsc_env <- getSession
- (iface, insts) <- liftIO $ loadHiFile hsc_env doc $ mkMainModule_ moduleNm
+ let oneShotUnit = stringToUnit (unitIdString (homeUnitId_ dflags))
+
+ (iface, insts) <- liftIO $ loadHiFile hsc_env doc $ mkModule oneShotUnit moduleNm
-- Update the DynFlags with the extensions from the source file (as stored in the interface file)
-- This is instead of ms_hspp_opts from ModSummary, which is not available in one-shot mode.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e4610f2d80ece6d72bd2d79a88b3d99…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e4610f2d80ece6d72bd2d79a88b3d99…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0