[Git][ghc/ghc][master] Remove the `CoreBindings` constructor from `LinkablePart`
by Marge Bot (＠marge-bot) 07 Nov '25
by Marge Bot (＠marge-bot) 07 Nov '25
07 Nov '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b253013e by Georgios Karachalias at 2025-11-07T17:21:57-05:00
Remove the `CoreBindings` constructor from `LinkablePart`
Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings
from being passed as input to getLinkDeps (which would previously
panic in this case).
Fixes #26497
- - - - -
7 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -277,6 +277,7 @@ import Data.Data hiding (Fixity, TyCon)
import Data.Functor ((<&>))
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
+import Data.Traversable (for)
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
@@ -850,11 +851,11 @@ hscRecompStatus
if | not (backendGeneratesCode (backend lcl_dflags)) -> do
-- No need for a linkable, we're good to go
msg UpToDate
- return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
+ return $ HscUpToDate checked_iface emptyRecompLinkables
| not (backendGeneratesCodeForHsBoot (backend lcl_dflags))
, IsBoot <- isBootSummary mod_summary -> do
msg UpToDate
- return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
+ return $ HscUpToDate checked_iface emptyRecompLinkables
-- Always recompile with the JS backend when TH is enabled until
-- #23013 is fixed.
@@ -883,7 +884,7 @@ hscRecompStatus
let just_o = justObjects <$> obj_linkable
bytecode_or_object_code
- | gopt Opt_WriteByteCode lcl_dflags = justBytecode <$> definitely_bc
+ | gopt Opt_WriteByteCode lcl_dflags = justBytecode . Left <$> definitely_bc
| otherwise = (justBytecode <$> maybe_bc) `choose` just_o
@@ -900,13 +901,13 @@ hscRecompStatus
definitely_bc = bc_obj_linkable `prefer` bc_in_memory_linkable
-- If not -fwrite-byte-code, then we could use core bindings or object code if that's available.
- maybe_bc = bc_in_memory_linkable `choose`
- bc_obj_linkable `choose`
- bc_core_linkable
+ maybe_bc = (Left <$> bc_in_memory_linkable) `choose`
+ (Left <$> bc_obj_linkable) `choose`
+ (Right <$> bc_core_linkable)
bc_result = if gopt Opt_WriteByteCode lcl_dflags
-- If the byte-code artifact needs to be produced, then we certainly need bytecode.
- then definitely_bc
+ then Left <$> definitely_bc
else maybe_bc
trace_if (hsc_logger hsc_env)
@@ -1021,14 +1022,13 @@ checkByteCodeFromObject hsc_env mod_sum = do
-- | Attempt to load bytecode from whole core bindings in the interface if they exist.
-- This is a legacy code-path, these days it should be preferred to use the bytecode object linkable.
-checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated Linkable)
+checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated WholeCoreBindingsLinkable)
checkByteCodeFromIfaceCoreBindings _hsc_env iface mod_sum = do
let
this_mod = ms_mod mod_sum
if_date = fromJust $ ms_iface_date mod_sum
case iface_core_bindings iface (ms_location mod_sum) of
- Just fi -> do
- return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
+ Just fi -> return $ UpToDateItem (Linkable if_date this_mod fi)
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
--------------------------------------------------------------
@@ -1142,20 +1142,22 @@ initWholeCoreBindings ::
HscEnv ->
ModIface ->
ModDetails ->
- Linkable ->
- IO Linkable
-initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do
- Linkable utc_time this_mod <$> mapM (go hsc_env) uls
+ RecompLinkables ->
+ IO HomeModLinkable
+initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do
+ bc' <- go bc
+ pure $ HomeModLinkable bc' o
where
- go hsc_env' = \case
- CoreBindings wcb -> do
+ type_env = md_types details
+
+ go :: RecompBytecodeLinkable -> IO (Maybe Linkable)
+ go (NormalLinkable l) = pure l
+ go (WholeCoreBindingsLinkable wcbl) =
+ fmap Just $ for wcbl $ \wcb -> do
add_iface_to_hpt iface details hsc_env
bco <- unsafeInterleaveIO $
- compileWholeCoreBindings hsc_env' type_env wcb
- pure (DotGBC bco)
- l -> pure l
-
- type_env = md_types details
+ compileWholeCoreBindings hsc_env type_env wcb
+ pure $ NE.singleton (DotGBC bco)
-- | Hydrate interface Core bindings and compile them to bytecode.
--
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -109,6 +109,7 @@ import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
+import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
@@ -249,8 +250,8 @@ compileOne' mHscMessage
(iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline
-- See Note [ModDetails and --make mode]
details <- initModDetails plugin_hsc_env iface
- linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
- return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
+ linkable' <- initWholeCoreBindings plugin_hsc_env iface details linkable
+ return $! HomeModInfo iface details linkable'
where lcl_dflags = ms_hspp_opts summary
location = ms_location summary
@@ -759,7 +760,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do
$ phaseIfFlag hsc_env flag def action
-- | The complete compilation pipeline, from start to finish
-fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
+fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables)
fullPipeline pipe_env hsc_env pp_fn src_flavour = do
(dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn
let hsc_env' = hscSetFlags dflags hsc_env
@@ -768,7 +769,7 @@ fullPipeline pipe_env hsc_env pp_fn src_flavour = do
hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
-- | Everything after preprocess
-hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable)
+hscPipeline :: P m => PipeEnv -> (HscEnv, ModSummary, HscRecompStatus) -> m (ModIface, RecompLinkables)
hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
case hsc_recomp_status of
HscUpToDate iface mb_linkable -> return (iface, mb_linkable)
@@ -777,7 +778,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction
-hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable)
+hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, RecompLinkables)
hscBackendPipeline pipe_env hsc_env mod_sum result =
if backendGeneratesCode (backend (hsc_dflags hsc_env)) then
do
@@ -796,15 +797,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
return res
else
case result of
- HscUpdate iface -> return (iface, emptyHomeModInfoLinkable)
- HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable
+ HscUpdate iface -> return (iface, emptyRecompLinkables)
+ HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyRecompLinkables
hscGenBackendPipeline :: P m
=> PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
- -> m (ModIface, HomeModLinkable)
+ -> m (ModIface, RecompLinkables)
hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
let mod_name = moduleName (ms_mod mod_sum)
src_flavour = (ms_hsc_src mod_sum)
@@ -812,7 +813,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
(fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)
final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
final_linkable <-
- case final_fp of
+ safeCastHomeModLinkable <$> case final_fp of
-- No object file produced, bytecode or NoBackend
Nothing -> return mlinkable
Just o_fp -> do
@@ -936,7 +937,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
as :: P m => Bool -> m (Maybe FilePath)
as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
- objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
+ objFromLinkable (_, recompLinkables_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
objFromLinkable _ = Nothing
fromPhase :: P m => Phase -> m (Maybe FilePath)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -33,7 +33,6 @@ import GHC.Utils.Error
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module
-import GHC.Unit.Module.WholeCoreBindings
import GHC.Unit.Home.ModInfo
import GHC.Iface.Errors.Types
@@ -206,10 +205,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
DotO file ForeignObject -> pure (DotO file ForeignObject)
DotA fp -> panic ("adjust_ul DotA " ++ show fp)
DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp)
- DotGBC {} -> pure part
- CoreBindings WholeCoreBindings {wcb_module} ->
- pprPanic "Unhydrated core bindings" (ppr wcb_module)
-
+ DotGBC {} -> pure part
{-
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveTraversable #-}
-----------------------------------------------------------------------------
--
@@ -30,7 +31,9 @@ module GHC.Linker.Types
, PkgsLoaded
-- * Linkable
- , Linkable(..)
+ , Linkable
+ , WholeCoreBindingsLinkable
+ , LinkableWith(..)
, mkModuleByteCodeLinkable
, LinkablePart(..)
, LinkableObjectSort (..)
@@ -254,7 +257,7 @@ instance Outputable LoadedPkgInfo where
-- | Information we can use to dynamically link modules into the compiler
-data Linkable = Linkable
+data LinkableWith parts = Linkable
{ linkableTime :: !UTCTime
-- ^ Time at which this linkable was built
-- (i.e. when the bytecodes were produced,
@@ -263,9 +266,13 @@ data Linkable = Linkable
, linkableModule :: !Module
-- ^ The linkable module itself
- , linkableParts :: NonEmpty LinkablePart
+ , linkableParts :: parts
-- ^ Files and chunks of code to link.
- }
+ } deriving (Functor, Traversable, Foldable)
+
+type Linkable = LinkableWith (NonEmpty LinkablePart)
+
+type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings
type LinkableSet = ModuleEnv Linkable
@@ -282,7 +289,7 @@ unionLinkableSet = plusModuleEnv_C go
| linkableTime l1 > linkableTime l2 = l1
| otherwise = l2
-instance Outputable Linkable where
+instance Outputable a => Outputable (LinkableWith a) where
ppr (Linkable when_made mod parts)
= (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)
$$ nest 3 (ppr parts)
@@ -318,11 +325,6 @@ data LinkablePart
| DotDLL FilePath
-- ^ Dynamically linked library file (.so, .dll, .dylib)
- | CoreBindings WholeCoreBindings
- -- ^ Serialised core which we can turn into BCOs (or object files), or
- -- used by some other backend See Note [Interface Files with Core
- -- Definitions]
-
| DotGBC ModuleByteCode
-- ^ A byte-code object, lives only in memory.
@@ -350,7 +352,6 @@ instance Outputable LinkablePart where
ppr (DotA path) = text "DotA" <+> text path
ppr (DotDLL path) = text "DotDLL" <+> text path
ppr (DotGBC bco) = text "DotGBC" <+> ppr bco
- ppr (CoreBindings {}) = text "CoreBindings"
-- | Return true if the linkable only consists of native code (no BCO)
linkableIsNativeCodeOnly :: Linkable -> Bool
@@ -391,7 +392,6 @@ isNativeCode = \case
DotA {} -> True
DotDLL {} -> True
DotGBC {} -> False
- CoreBindings {} -> False
-- | Is the part a native library? (.so/.dll)
isNativeLib :: LinkablePart -> Bool
@@ -400,7 +400,6 @@ isNativeLib = \case
DotA {} -> True
DotDLL {} -> True
DotGBC {} -> False
- CoreBindings {} -> False
-- | Get the FilePath of linkable part (if applicable)
linkablePartPath :: LinkablePart -> Maybe FilePath
@@ -408,7 +407,6 @@ linkablePartPath = \case
DotO fn _ -> Just fn
DotA fn -> Just fn
DotDLL fn -> Just fn
- CoreBindings {} -> Nothing
DotGBC {} -> Nothing
-- | Return the paths of all object code files (.o, .a, .so) contained in this
@@ -418,7 +416,6 @@ linkablePartNativePaths = \case
DotO fn _ -> [fn]
DotA fn -> [fn]
DotDLL fn -> [fn]
- CoreBindings {} -> []
DotGBC {} -> []
-- | Return the paths of all object files (.o) contained in this 'LinkablePart'.
@@ -427,7 +424,6 @@ linkablePartObjectPaths = \case
DotO fn _ -> [fn]
DotA _ -> []
DotDLL _ -> []
- CoreBindings {} -> []
DotGBC bco -> gbc_foreign_files bco
-- | Retrieve the compiled byte-code from the linkable part.
@@ -444,12 +440,11 @@ linkableFilter f linkable = do
Just linkable {linkableParts = new}
linkablePartNative :: LinkablePart -> [LinkablePart]
-linkablePartNative = \case
- u@DotO {} -> [u]
- u@DotA {} -> [u]
- u@DotDLL {} -> [u]
+linkablePartNative u = case u of
+ DotO {} -> [u]
+ DotA {} -> [u]
+ DotDLL {} -> [u]
DotGBC bco -> [DotO f ForeignObject | f <- gbc_foreign_files bco]
- _ -> []
linkablePartByteCode :: LinkablePart -> [LinkablePart]
linkablePartByteCode = \case
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -3,13 +3,10 @@
module GHC.Unit.Home.ModInfo
(
HomeModInfo (..)
- , HomeModLinkable(..)
+ , HomeModLinkable (..)
, homeModInfoObject
, homeModInfoByteCode
, emptyHomeModInfoLinkable
- , justBytecode
- , justObjects
- , bytecodeAndObjects
)
where
@@ -18,11 +15,9 @@ import GHC.Prelude
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
-import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )
+import GHC.Linker.Types ( Linkable )
import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -68,22 +63,6 @@ data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
-justBytecode :: Linkable -> HomeModLinkable
-justBytecode lm =
- assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
-
-justObjects :: Linkable -> HomeModLinkable
-justObjects lm =
- assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
- $ emptyHomeModInfoLinkable { homeMod_object = Just lm }
-
-bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
-bytecodeAndObjects bc o =
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- (HomeModLinkable (Just bc) (Just o))
-
-
{-
Note [Home module build products]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Unit/Module/Status.hs
=====================================
@@ -1,22 +1,35 @@
+{-# LANGUAGE LambdaCase #-}
+
module GHC.Unit.Module.Status
- ( HscBackendAction(..), HscRecompStatus (..)
+ ( HscBackendAction(..)
+ , HscRecompStatus (..)
+ , RecompLinkables (..)
+ , RecompBytecodeLinkable (..)
+ , emptyRecompLinkables
+ , justBytecode
+ , justObjects
+ , bytecodeAndObjects
+ , safeCastHomeModLinkable
)
where
import GHC.Prelude
import GHC.Unit
+import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
+import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly )
+
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
-import GHC.Unit.Home.ModInfo
+import GHC.Utils.Panic
-- | Status of a module in incremental compilation
data HscRecompStatus
-- | Nothing to do because code already exists.
- = HscUpToDate ModIface HomeModLinkable
+ = HscUpToDate ModIface RecompLinkables
-- | Recompilation of module, or update of interface is required. Optionally
-- pass the old interface hash to avoid updating the existing interface when
-- it has not changed.
@@ -41,6 +54,16 @@ data HscBackendAction
-- changed.
}
+-- | Linkables produced by @hscRecompStatus@. Might contain serialized core
+-- which can be turned into BCOs (or object files), or used by some other
+-- backend. See Note [Interface Files with Core Definitions].
+data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompBytecodeLinkable
+ , recompLinkables_object :: !(Maybe Linkable) }
+
+data RecompBytecodeLinkable
+ = NormalLinkable !(Maybe Linkable)
+ | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable
+
instance Outputable HscRecompStatus where
ppr HscUpToDate{} = text "HscUpToDate"
ppr HscRecompNeeded{} = text "HscRecompNeeded"
@@ -48,3 +71,37 @@ instance Outputable HscRecompStatus where
instance Outputable HscBackendAction where
ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi))
ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml
+
+instance Outputable RecompLinkables where
+ ppr (RecompLinkables l1 l2) = ppr l1 $$ ppr l2
+
+instance Outputable RecompBytecodeLinkable where
+ ppr (NormalLinkable lm) = text "NormalLinkable:" <+> ppr lm
+ ppr (WholeCoreBindingsLinkable lm) = text "WholeCoreBindingsLinkable:" <+> ppr lm
+
+emptyRecompLinkables :: RecompLinkables
+emptyRecompLinkables = RecompLinkables (NormalLinkable Nothing) Nothing
+
+safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables
+safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable bc) o
+
+justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
+justBytecode = \case
+ Left lm ->
+ assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
+ $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
+
+justObjects :: Linkable -> RecompLinkables
+justObjects lm =
+ assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
+ $ emptyRecompLinkables { recompLinkables_object = Just lm }
+
+bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
+bytecodeAndObjects either_bc o = case either_bc of
+ Left bc ->
+ assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
+ Right bc ->
+ assertPpr (linkableIsNativeCodeOnly o) (ppr o)
+ $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -130,6 +130,9 @@ data WholeCoreBindings = WholeCoreBindings
, wcb_foreign :: IfaceForeign
}
+instance Outputable WholeCoreBindings where
+ ppr (WholeCoreBindings {}) = text "WholeCoreBindings"
+
{-
Note [Foreign stubs and TH bytecode linking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b253013ebeea5273a1cc7bb0082ed95…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b253013ebeea5273a1cc7bb0082ed95…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mp/14996] Use response file for invoking ghc
by Matthew Pickering (＠mpickering) 07 Nov '25
by Matthew Pickering (＠mpickering) 07 Nov '25
07 Nov '25
Matthew Pickering pushed to branch wip/mp/14996 at Glasgow Haskell Compiler / GHC
Commits:
01262c01 by Matthew Pickering at 2025-11-07T16:48:55+00:00
Use response file for invoking ghc
- - - - -
1 changed file:
- hadrian/src/Builder.hs
Changes:
=====================================
hadrian/src/Builder.hs
=====================================
@@ -352,6 +352,9 @@ instance H.Builder Builder where
Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Ghc FindHsDependencies _ -> do
+ runGhcWithResponse path buildArgs buildInputs
+
HsCpp -> captureStdout
Make dir -> cmd' buildOptions path ["-C", dir] buildArgs
@@ -394,6 +397,13 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
cmd [haddockPath] flagArgs ('@' : tmp)
+runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action ()
+runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do
+ writeFile' tmp $ escapeArgs (fileInputs)
+
+ cmd [ghcPath] flagArgs ('@' : tmp)
+
+
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
-- specific optional builders as soon as we can reliably test this feature.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/01262c019aefc67ead69fc2b7bd8344…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/01262c019aefc67ead69fc2b7bd8344…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mp/14996] Use response file for invoking ghc
by Matthew Pickering (＠mpickering) 07 Nov '25
by Matthew Pickering (＠mpickering) 07 Nov '25
07 Nov '25
Matthew Pickering pushed to branch wip/mp/14996 at Glasgow Haskell Compiler / GHC
Commits:
f969aa91 by Matthew Pickering at 2025-11-07T16:24:52+00:00
Use response file for invoking ghc
- - - - -
1 changed file:
- hadrian/src/Builder.hs
Changes:
=====================================
hadrian/src/Builder.hs
=====================================
@@ -352,6 +352,8 @@ instance H.Builder Builder where
Haddock BuildPackage -> runHaddock path buildArgs buildInputs
+ Ghc {} -> runGhc path buildArgs buildInputs
+
HsCpp -> captureStdout
Make dir -> cmd' buildOptions path ["-C", dir] buildArgs
@@ -394,6 +396,12 @@ runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
cmd [haddockPath] flagArgs ('@' : tmp)
+runGhc :: FilePath -> [String] -> [FilePath] -> Action ()
+runGhc ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do
+ writeFile' tmp $ escapeArgs fileInputs
+ cmd [ghcPath] flagArgs ('@' : tmp)
+
+
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
-- specific optional builders as soon as we can reliably test this feature.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f969aa916094b5ec5eb139aa55263eb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f969aa916094b5ec5eb139aa55263eb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Correct hasFixedRuntimeRep in matchExpectedFunTys
by Marge Bot (＠marge-bot) 07 Nov '25
by Marge Bot (＠marge-bot) 07 Nov '25
07 Nov '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
93fc7265 by sheaf at 2025-11-06T21:33:24-05:00
Correct hasFixedRuntimeRep in matchExpectedFunTys
This commit fixes a bug in the representation-polymormorphism check in
GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put
the coercion resulting from hasFixedRuntimeRep in the wrong place,
leading to the Core Lint error reported in #26528.
The change is that we have to be careful when using 'mkWpFun': it
expects **both** the expected and actual argument types to have a
syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT]
in GHC.Tc.Types.Evidence.
On the way, this patch improves some of the commentary relating to
other usages of 'mkWpFun' in the compiler, in particular in the view
pattern case of 'tc_pat'. No functional changes, but some stylistic
changes to make the code more readable, and make it easier to understand
how we are upholding the WpFun-FRR-INVARIANT.
Fixes #26528
- - - - -
c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
26628a77 by Georgios Karachalias at 2025-11-07T11:21:02-05:00
Remove the `CoreBindings` constructor from `LinkablePart`
Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings
from being passed as input to getLinkDeps (which would previously
panic in this case).
Fixes #26497
- - - - -
19a1f0d9 by Sylvain Henry at 2025-11-07T11:21:26-05:00
Testsuite: pass ext-interp test way (#26552)
Note that some tests are still marked as broken with the ext-interp way
(see #26552 and #14335)
- - - - -
23 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- libraries/base/tests/all.T
- testsuite/driver/testlib.py
- testsuite/tests/driver/T20696/all.T
- testsuite/tests/driver/fat-iface/all.T
- + testsuite/tests/rep-poly/T26528.hs
- testsuite/tests/rep-poly/all.T
- testsuite/tests/splice-imports/all.T
- + testsuite/tests/typecheck/should_compile/T26451.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -277,6 +277,7 @@ import Data.Data hiding (Fixity, TyCon)
import Data.Functor ((<&>))
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
+import Data.Traversable (for)
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
@@ -850,11 +851,11 @@ hscRecompStatus
if | not (backendGeneratesCode (backend lcl_dflags)) -> do
-- No need for a linkable, we're good to go
msg UpToDate
- return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
+ return $ HscUpToDate checked_iface emptyRecompLinkables
| not (backendGeneratesCodeForHsBoot (backend lcl_dflags))
, IsBoot <- isBootSummary mod_summary -> do
msg UpToDate
- return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
+ return $ HscUpToDate checked_iface emptyRecompLinkables
-- Always recompile with the JS backend when TH is enabled until
-- #23013 is fixed.
@@ -883,7 +884,7 @@ hscRecompStatus
let just_o = justObjects <$> obj_linkable
bytecode_or_object_code
- | gopt Opt_WriteByteCode lcl_dflags = justBytecode <$> definitely_bc
+ | gopt Opt_WriteByteCode lcl_dflags = justBytecode . Left <$> definitely_bc
| otherwise = (justBytecode <$> maybe_bc) `choose` just_o
@@ -900,13 +901,13 @@ hscRecompStatus
definitely_bc = bc_obj_linkable `prefer` bc_in_memory_linkable
-- If not -fwrite-byte-code, then we could use core bindings or object code if that's available.
- maybe_bc = bc_in_memory_linkable `choose`
- bc_obj_linkable `choose`
- bc_core_linkable
+ maybe_bc = (Left <$> bc_in_memory_linkable) `choose`
+ (Left <$> bc_obj_linkable) `choose`
+ (Right <$> bc_core_linkable)
bc_result = if gopt Opt_WriteByteCode lcl_dflags
-- If the byte-code artifact needs to be produced, then we certainly need bytecode.
- then definitely_bc
+ then Left <$> definitely_bc
else maybe_bc
trace_if (hsc_logger hsc_env)
@@ -1021,14 +1022,13 @@ checkByteCodeFromObject hsc_env mod_sum = do
-- | Attempt to load bytecode from whole core bindings in the interface if they exist.
-- This is a legacy code-path, these days it should be preferred to use the bytecode object linkable.
-checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated Linkable)
+checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated WholeCoreBindingsLinkable)
checkByteCodeFromIfaceCoreBindings _hsc_env iface mod_sum = do
let
this_mod = ms_mod mod_sum
if_date = fromJust $ ms_iface_date mod_sum
case iface_core_bindings iface (ms_location mod_sum) of
- Just fi -> do
- return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
+ Just fi -> return $ UpToDateItem (Linkable if_date this_mod fi)
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
--------------------------------------------------------------
@@ -1142,20 +1142,22 @@ initWholeCoreBindings ::
HscEnv ->
ModIface ->
ModDetails ->
- Linkable ->
- IO Linkable
-initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do
- Linkable utc_time this_mod <$> mapM (go hsc_env) uls
+ RecompLinkables ->
+ IO HomeModLinkable
+initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do
+ bc' <- go bc
+ pure $ HomeModLinkable bc' o
where
- go hsc_env' = \case
- CoreBindings wcb -> do
+ type_env = md_types details
+
+ go :: RecompBytecodeLinkable -> IO (Maybe Linkable)
+ go (NormalLinkable l) = pure l
+ go (WholeCoreBindingsLinkable wcbl) =
+ fmap Just $ for wcbl $ \wcb -> do
add_iface_to_hpt iface details hsc_env
bco <- unsafeInterleaveIO $
- compileWholeCoreBindings hsc_env' type_env wcb
- pure (DotGBC bco)
- l -> pure l
-
- type_env = md_types details
+ compileWholeCoreBindings hsc_env type_env wcb
+ pure $ NE.singleton (DotGBC bco)
-- | Hydrate interface Core bindings and compile them to bytecode.
--
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -109,6 +109,7 @@ import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
+import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
@@ -249,8 +250,8 @@ compileOne' mHscMessage
(iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline
-- See Note [ModDetails and --make mode]
details <- initModDetails plugin_hsc_env iface
- linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
- return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
+ linkable' <- initWholeCoreBindings plugin_hsc_env iface details linkable
+ return $! HomeModInfo iface details linkable'
where lcl_dflags = ms_hspp_opts summary
location = ms_location summary
@@ -759,7 +760,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do
$ phaseIfFlag hsc_env flag def action
-- | The complete compilation pipeline, from start to finish
-fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
+fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables)
fullPipeline pipe_env hsc_env pp_fn src_flavour = do
(dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn
let hsc_env' = hscSetFlags dflags hsc_env
@@ -768,7 +769,7 @@ fullPipeline pipe_env hsc_env pp_fn src_flavour = do
hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
-- | Everything after preprocess
-hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable)
+hscPipeline :: P m => PipeEnv -> (HscEnv, ModSummary, HscRecompStatus) -> m (ModIface, RecompLinkables)
hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
case hsc_recomp_status of
HscUpToDate iface mb_linkable -> return (iface, mb_linkable)
@@ -777,7 +778,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction
-hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable)
+hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, RecompLinkables)
hscBackendPipeline pipe_env hsc_env mod_sum result =
if backendGeneratesCode (backend (hsc_dflags hsc_env)) then
do
@@ -796,15 +797,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
return res
else
case result of
- HscUpdate iface -> return (iface, emptyHomeModInfoLinkable)
- HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable
+ HscUpdate iface -> return (iface, emptyRecompLinkables)
+ HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyRecompLinkables
hscGenBackendPipeline :: P m
=> PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
- -> m (ModIface, HomeModLinkable)
+ -> m (ModIface, RecompLinkables)
hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
let mod_name = moduleName (ms_mod mod_sum)
src_flavour = (ms_hsc_src mod_sum)
@@ -812,7 +813,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
(fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)
final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
final_linkable <-
- case final_fp of
+ safeCastHomeModLinkable <$> case final_fp of
-- No object file produced, bytecode or NoBackend
Nothing -> return mlinkable
Just o_fp -> do
@@ -936,7 +937,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
as :: P m => Bool -> m (Maybe FilePath)
as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
- objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
+ objFromLinkable (_, recompLinkables_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
objFromLinkable _ = Nothing
fromPhase :: P m => Phase -> m (Maybe FilePath)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -33,7 +33,6 @@ import GHC.Utils.Error
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module
-import GHC.Unit.Module.WholeCoreBindings
import GHC.Unit.Home.ModInfo
import GHC.Iface.Errors.Types
@@ -206,10 +205,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
DotO file ForeignObject -> pure (DotO file ForeignObject)
DotA fp -> panic ("adjust_ul DotA " ++ show fp)
DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp)
- DotGBC {} -> pure part
- CoreBindings WholeCoreBindings {wcb_module} ->
- pprPanic "Unhydrated core bindings" (ppr wcb_module)
-
+ DotGBC {} -> pure part
{-
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveTraversable #-}
-----------------------------------------------------------------------------
--
@@ -30,7 +31,9 @@ module GHC.Linker.Types
, PkgsLoaded
-- * Linkable
- , Linkable(..)
+ , Linkable
+ , WholeCoreBindingsLinkable
+ , LinkableWith(..)
, mkModuleByteCodeLinkable
, LinkablePart(..)
, LinkableObjectSort (..)
@@ -254,7 +257,7 @@ instance Outputable LoadedPkgInfo where
-- | Information we can use to dynamically link modules into the compiler
-data Linkable = Linkable
+data LinkableWith parts = Linkable
{ linkableTime :: !UTCTime
-- ^ Time at which this linkable was built
-- (i.e. when the bytecodes were produced,
@@ -263,9 +266,13 @@ data Linkable = Linkable
, linkableModule :: !Module
-- ^ The linkable module itself
- , linkableParts :: NonEmpty LinkablePart
+ , linkableParts :: parts
-- ^ Files and chunks of code to link.
- }
+ } deriving (Functor, Traversable, Foldable)
+
+type Linkable = LinkableWith (NonEmpty LinkablePart)
+
+type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings
type LinkableSet = ModuleEnv Linkable
@@ -282,7 +289,7 @@ unionLinkableSet = plusModuleEnv_C go
| linkableTime l1 > linkableTime l2 = l1
| otherwise = l2
-instance Outputable Linkable where
+instance Outputable a => Outputable (LinkableWith a) where
ppr (Linkable when_made mod parts)
= (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)
$$ nest 3 (ppr parts)
@@ -318,11 +325,6 @@ data LinkablePart
| DotDLL FilePath
-- ^ Dynamically linked library file (.so, .dll, .dylib)
- | CoreBindings WholeCoreBindings
- -- ^ Serialised core which we can turn into BCOs (or object files), or
- -- used by some other backend See Note [Interface Files with Core
- -- Definitions]
-
| DotGBC ModuleByteCode
-- ^ A byte-code object, lives only in memory.
@@ -350,7 +352,6 @@ instance Outputable LinkablePart where
ppr (DotA path) = text "DotA" <+> text path
ppr (DotDLL path) = text "DotDLL" <+> text path
ppr (DotGBC bco) = text "DotGBC" <+> ppr bco
- ppr (CoreBindings {}) = text "CoreBindings"
-- | Return true if the linkable only consists of native code (no BCO)
linkableIsNativeCodeOnly :: Linkable -> Bool
@@ -391,7 +392,6 @@ isNativeCode = \case
DotA {} -> True
DotDLL {} -> True
DotGBC {} -> False
- CoreBindings {} -> False
-- | Is the part a native library? (.so/.dll)
isNativeLib :: LinkablePart -> Bool
@@ -400,7 +400,6 @@ isNativeLib = \case
DotA {} -> True
DotDLL {} -> True
DotGBC {} -> False
- CoreBindings {} -> False
-- | Get the FilePath of linkable part (if applicable)
linkablePartPath :: LinkablePart -> Maybe FilePath
@@ -408,7 +407,6 @@ linkablePartPath = \case
DotO fn _ -> Just fn
DotA fn -> Just fn
DotDLL fn -> Just fn
- CoreBindings {} -> Nothing
DotGBC {} -> Nothing
-- | Return the paths of all object code files (.o, .a, .so) contained in this
@@ -418,7 +416,6 @@ linkablePartNativePaths = \case
DotO fn _ -> [fn]
DotA fn -> [fn]
DotDLL fn -> [fn]
- CoreBindings {} -> []
DotGBC {} -> []
-- | Return the paths of all object files (.o) contained in this 'LinkablePart'.
@@ -427,7 +424,6 @@ linkablePartObjectPaths = \case
DotO fn _ -> [fn]
DotA _ -> []
DotDLL _ -> []
- CoreBindings {} -> []
DotGBC bco -> gbc_foreign_files bco
-- | Retrieve the compiled byte-code from the linkable part.
@@ -444,12 +440,11 @@ linkableFilter f linkable = do
Just linkable {linkableParts = new}
linkablePartNative :: LinkablePart -> [LinkablePart]
-linkablePartNative = \case
- u@DotO {} -> [u]
- u@DotA {} -> [u]
- u@DotDLL {} -> [u]
+linkablePartNative u = case u of
+ DotO {} -> [u]
+ DotA {} -> [u]
+ DotDLL {} -> [u]
DotGBC bco -> [DotO f ForeignObject | f <- gbc_foreign_files bco]
- _ -> []
linkablePartByteCode :: LinkablePart -> [LinkablePart]
linkablePartByteCode = \case
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin
-> SyntaxOpType -- ^ shape it is expected to have
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
-> TcM (a, HsWrapper)
- -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
+ -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in)
tcSynArgE orig op sigma_ty syn_ty thing_inside
= do { (skol_wrap, (result, ty_wrapper))
<- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty ->
@@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside
; return (result, mkWpCastN list_co) }
go rho_ty (SynFun arg_shape res_shape)
- = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
+ = do { ( match_wrapper -- :: (arg_ty -> res_ty) ~~> rho_ty
, ( ( (result, arg_ty, res_ty, op_mult)
- , res_wrapper ) -- :: res_ty_out "->" res_ty
- , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out
+ , res_wrapper ) -- :: res_ty_out ~~> res_ty
+ , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty ~~> arg_ty_out
<- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
\ [ExpFunPatTy arg_ty] res_ty ->
do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
@@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin
tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
<- matchActualFunTys herald orig (length arg_shapes) sigma_ty
- -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
+ -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty)
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
tc_syn_arg res_ty res_shape $ \ res_results ->
@@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
; return (result, idHsWrapper) }
tc_syn_arg res_ty SynRho thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
- -- inst_wrap :: res_ty "->" rho_ty
+ -- inst_wrap :: res_ty ~~> rho_ty
; result <- thing_inside [rho_ty]
; return (result, inst_wrap) }
tc_syn_arg res_ty SynList thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
- -- inst_wrap :: res_ty "->" rho_ty
+ -- inst_wrap :: res_ty ~~> rho_ty
; (list_co, elt_ty) <- matchExpectedListTy rho_ty
-- list_co :: [elt_ty] ~N rho_ty
; result <- thing_inside [elt_ty]
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
-- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
| Just bndr_id <- sig_fn bndr_name -- There is a signature
- = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
+ = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id)
-- See Note [Subsumption check at pattern variables]
; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
; return (wrap, bndr_id) }
@@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty
newLetBndr (LetGblBndr prags) name w ty
= addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
-tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
--- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
--- Used during typechecking patterns
-tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
+-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'.
+--
+-- Used during typechecking of patterns.
+tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+tcSubTypePat_GenSigCtxt penv t1 t2 =
+ tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
{- Note [Subsumption check at pattern variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -618,111 +620,123 @@ tc_pat :: Scaled ExpSigmaTypeFRR
-> Checker (Pat GhcRn) (Pat GhcTc)
-- ^ Translated pattern
-tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-
- VarPat x (L l name) -> do
- { (wrap, id) <- tcPatBndr penv name pat_ty
- ; res <- tcCheckUsage name (scaledMult pat_ty) $
- tcExtendIdEnv1 name id thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
-
- ParPat x pat -> do
- { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
- ; return (ParPat x pat', res) }
-
- BangPat x pat -> do
- { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
- ; return (BangPat x pat', res) }
-
- OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
- { let pats_list = NE.toList pats
- ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
- ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
- ; emitConstraints pat_ct
- -- captureConstraints/extendConstraints:
- -- like in Note [Hopping the LIE in lazy patterns]
- ; pat_ty <- expTypeToType (scaledThing pat_ty)
- ; return (OrPat pat_ty pats', res) }
-
- LazyPat x pat -> do
- { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
- ; (pat', (res, pat_ct))
- <- tc_lpat pat_ty (makeLazy penv) pat $
- captureConstraints thing_inside
- -- Ignore refined penv', revert to penv
-
- ; emitConstraints pat_ct
- -- captureConstraints/extendConstraints:
- -- see Note [Hopping the LIE in lazy patterns]
-
- -- Check that the expected pattern type is itself lifted
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
-
- ; return ((LazyPat x pat'), res) }
-
- WildPat _ -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; res <- thing_inside
- ; pat_ty <- expTypeToType (scaledThing pat_ty)
- ; return (WildPat pat_ty, res) }
-
- AsPat x (L nm_loc name) pat -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
- ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
- tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
- penv pat thing_inside
- -- NB: if we do inference on:
- -- \ (y@(x::forall a. a->a)) = e
- -- we'll fail. The as-pattern infers a monotype for 'y', which then
- -- fails to unify with the polymorphic type for 'x'. This could
- -- perhaps be fixed, but only with a bit more work.
- --
- -- If you fix it, don't forget the bindInstsOfPatIds!
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
-
- ViewPat _ expr pat -> do
- { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
- --
- -- It should be possible to have view patterns at linear (or otherwise
- -- non-Many) multiplicity. But it is not clear at the moment what
- -- restriction need to be put in place, if any, for linear view
- -- patterns to desugar to type-correct Core.
-
- ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr
- -- IIF_ShallowRho: do not perform deep instantiation, regardless of
- -- DeepSubsumption (Note [View patterns and polymorphism])
- -- But we must do top-instantiation to expose the arrow to matchActualFunTy
-
- -- Expression must be a function
- ; let herald = ExpectedFunTyViewPat $ unLoc expr
- ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
- <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
- -- See Note [View patterns and polymorphism]
- -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
-
- -- Check that overall pattern is more polymorphic than arg type
- ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
- -- expr_wrap2 :: pat_ty "->" inf_arg_ty
-
- -- Pattern must have inf_res_sigma
- ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
-
- ; let Scaled w h_pat_ty = pat_ty
- ; pat_ty <- readExpType h_pat_ty
- ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
- (Scaled w pat_ty) inf_res_sigma
- -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
- -- (pat_ty -> inf_res_sigma)
- -- NB: pat_ty comes from matchActualFunTy, so it has a
- -- fixed RuntimeRep, as needed to call mkWpFun.
-
- expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
-
- ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
+tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
+
+ case ps_pat of
+
+ VarPat x (L l name) -> do
+ { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty
+ ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
+
+ ParPat x pat -> do
+ { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
+ ; return (ParPat x pat', res) }
+
+ BangPat x pat -> do
+ { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
+ ; return (BangPat x pat', res) }
+
+ OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
+ { let pats_list = NE.toList pats
+ pat_exp_tys = map (const scaled_exp_pat_ty) pats_list
+ ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside)
+ ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- like in Note [Hopping the LIE in lazy patterns]
+ ; pat_ty <- expTypeToType exp_pat_ty
+ ; return (OrPat pat_ty pats', res) }
+
+ LazyPat x pat -> do
+ { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; (pat', (res, pat_ct))
+ <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $
+ captureConstraints thing_inside
+ -- Ignore refined penv', revert to penv
+
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- see Note [Hopping the LIE in lazy patterns]
+
+ -- Check that the expected pattern type is itself lifted
+ ; pat_ty <- readExpType exp_pat_ty
+ ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
+
+ ; return ((LazyPat x pat'), res) }
+
+ WildPat _ -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; res <- thing_inside
+ ; pat_ty <- expTypeToType exp_pat_ty
+ ; return (WildPat pat_ty, res) }
+
+ AsPat x (L nm_loc name) pat -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty)
+ ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+ tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id))
+ penv pat thing_inside
+ -- NB: if we do inference on:
+ -- \ (y@(x::forall a. a->a)) = e
+ -- we'll fail. The as-pattern infers a monotype for 'y', which then
+ -- fails to unify with the polymorphic type for 'x'. This could
+ -- perhaps be fixed, but only with a bit more work.
+ --
+ -- If you fix it, don't forget the bindInstsOfPatIds!
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
+
+ ViewPat _ view_expr inner_pat -> do
+
+ -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'.
+ -- First infer the type of 'view_expr'; the overall type of the pattern
+ -- is the argument type of 'view_expr', and the inner pattern type is
+ -- checked against the result type of 'view_expr'.
+
+ { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ -- It should be possible to have view patterns at linear (or otherwise
+ -- non-Many) multiplicity. But it is not clear at the moment what
+ -- restrictions need to be put in place, if any, for linear view
+ -- patterns to desugar to type-correct Core.
+
+ -- Infer the type of 'view_expr'.
+ ; (view_expr', view_expr_rho) <- tcInferExpr IIF_ShallowRho view_expr
+ -- IIF_ShallowRho: do not perform deep instantiation, regardless of
+ -- DeepSubsumption (Note [View patterns and polymorphism])
+ -- But we must do top-instantiation to expose the arrow to matchActualFunTy
+
+ -- 'view_expr' must be a function; expose its argument/result types
+ -- using 'matchActualFunTy'.
+ ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
+ ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
+ <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
+ (1, view_expr_rho) view_expr_rho
+ -- See Note [View patterns and polymorphism]
+ -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty)
+
+ -- Check that the overall pattern's type is more polymorphic than
+ -- the view function argument type.
+ ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty
+ -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty
+
+ -- The inner pattern must have type 'view_res_ty'.
+ ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside
+
+ ; pat_ty <- readExpType exp_pat_ty
+ ; let view_expr_wrap2' =
+ mkWpFun view_expr_wrap2 idHsWrapper
+ (Scaled w_pat pat_ty) view_res_ty
+ -- view_expr_wrap2' :: (view_arg_ty -> view_res_ty)
+ -- ~~> (pat_ty -> view_res_ty)
+ -- This satisfies WpFun-FRR-INVARIANT:
+ -- 'view_arg_ty' was returned by matchActualFunTy, hence FRR
+ -- 'pat_ty' was passed in and is an 'ExpSigmaTypeFRR'
+
+ view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1
+
+ ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) }
{- Note [View patterns and polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -748,93 +762,91 @@ Another example is #26331.
-- Type signatures in patterns
-- See Note [Pattern coercions] below
- SigPat _ pat sig_ty -> do
- { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
- sig_ty (scaledThing pat_ty)
- -- Using tcExtendNameTyVarEnv is appropriate here
- -- because we're not really bringing fresh tyvars into scope.
- -- We're *naming* existing tyvars. Note that it is OK for a tyvar
- -- from an outer scope to mention one of these tyvars in its kind.
- ; (pat', res) <- tcExtendNameTyVarEnv wcs $
- tcExtendNameTyVarEnv tv_binds $
- tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
+ SigPat _ pat sig_ty -> do
+ { (inner_ty, tv_binds, wcs, wrap) <-
+ tcPatSig (inPatBind penv) sig_ty exp_pat_ty
+ -- Using tcExtendNameTyVarEnv is appropriate here
+ -- because we're not really bringing fresh tyvars into scope.
+ -- We're *naming* existing tyvars. Note that it is OK for a tyvar
+ -- from an outer scope to mention one of these tyvars in its kind.
+ ; (pat', res) <- tcExtendNameTyVarEnv wcs $
+ tcExtendNameTyVarEnv tv_binds $
+ tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
------------------------
-- Lists, tuples, arrays
-- Necessarily a built-in list pattern, not an overloaded list pattern.
-- See Note [Desugaring overloaded list patterns].
- ListPat _ pats -> do
- { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
- ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
- penv pats thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat coi
- (ListPat elt_ty pats') pat_ty, res) }
-
- TuplePat _ pats boxity -> do
- { let arity = length pats
- tc = tupleTyCon boxity arity
- -- NB: tupleTyCon does not flatten 1-tuples
- -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
- ; checkTupSize arity
- ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
- penv (scaledThing pat_ty)
- -- Unboxed tuples have RuntimeRep vars, which we discard:
- -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
- ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
- Boxed -> arg_tys
- ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
+ ListPat _ pats -> do
+ { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty
+ ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty))
penv pats thing_inside
-
- ; dflags <- getDynFlags
-
- -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
- -- so that we can experiment with lazy tuple-matching.
- -- This is a pretty odd place to make the switch, but
- -- it was easy to do.
- ; let
- unmangled_result = TuplePat con_arg_tys pats' boxity
- -- pat_ty /= pat_ty iff coi /= IdCo
- possibly_mangled_result
- | gopt Opt_IrrefutableTuples dflags &&
- isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
- | otherwise = unmangled_result
-
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
- ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
- }
-
- SumPat _ pat alt arity -> do
- { let tc = sumTyCon arity
- ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
- penv (scaledThing pat_ty)
- ; -- Drop levity vars, we don't care about them here
- let con_arg_tys = drop arity arg_tys
- ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
- penv pat thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
- , res)
- }
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat coi
+ (ListPat elt_ty pats') pat_ty, res) }
+
+ TuplePat _ pats boxity -> do
+ { let arity = length pats
+ tc = tupleTyCon boxity arity
+ -- NB: tupleTyCon does not flatten 1-tuples
+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
+ ; checkTupSize arity
+ ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
+ -- Unboxed tuples have RuntimeRep vars, which we discard:
+ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
+ ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
+ Boxed -> arg_tys
+ ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys)
+ penv pats thing_inside
+
+ ; dflags <- getDynFlags
+
+ -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
+ -- so that we can experiment with lazy tuple-matching.
+ -- This is a pretty odd place to make the switch, but
+ -- it was easy to do.
+ ; let
+ unmangled_result = TuplePat con_arg_tys pats' boxity
+ -- pat_ty /= pat_ty iff coi /= IdCo
+ possibly_mangled_result
+ | gopt Opt_IrrefutableTuples dflags &&
+ isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
+ | otherwise = unmangled_result
+
+ ; pat_ty <- readExpType exp_pat_ty
+ ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
+ ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
+ }
+
+ SumPat _ pat alt arity -> do
+ { let tc = sumTyCon arity
+ ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
+ ; -- Drop levity vars, we don't care about them here
+ let con_arg_tys = drop arity arg_tys
+ ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+ penv pat thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+ , res)
+ }
------------------------
-- Data constructors
- ConPat _ con arg_pats ->
- tcConPat penv con pat_ty arg_pats thing_inside
+ ConPat _ con arg_pats ->
+ tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside
------------------------
-- Literal patterns
- LitPat x simple_lit -> do
- { let lit_ty = hsLitType simple_lit
- ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty
- ; res <- thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
- , res) }
+ LitPat x simple_lit -> do
+ { let lit_ty = hsLitType simple_lit
+ ; wrap <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty
+ ; res <- thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
+ , res) }
------------------------
-- Overloaded patterns: n, and n+k
@@ -854,31 +866,31 @@ Another example is #26331.
-- where lit_ty is the type of the overloaded literal 5.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
- NPat _ (L l over_lit) mb_neg eq -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- -- It may be possible to refine linear pattern so that they work in
- -- linear environments. But it is not clear how useful this is.
- ; let orig = LiteralOrigin over_lit
- ; ((lit', mb_neg'), eq')
- <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
- (mkCheckExpType boolTy) $
- \ [neg_lit_ty] _ ->
- let new_over_lit lit_ty = newOverloadedLit over_lit
- (mkCheckExpType lit_ty)
- in case mb_neg of
- Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
- Just neg -> -- Negative literal
- -- The 'negate' is re-mappable syntax
- second Just <$>
- (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
- \ [lit_ty] _ -> new_over_lit lit_ty)
- -- applied to a closed literal: linearity doesn't matter as
- -- literals are typed in an empty environment, hence have
- -- all multiplicities.
-
- ; res <- thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
+ NPat _ (L l over_lit) mb_neg eq -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ -- It may be possible to refine linear pattern so that they work in
+ -- linear environments. But it is not clear how useful this is.
+ ; let orig = LiteralOrigin over_lit
+ ; ((lit', mb_neg'), eq')
+ <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny]
+ (mkCheckExpType boolTy) $
+ \ [neg_lit_ty] _ ->
+ let new_over_lit lit_ty = newOverloadedLit over_lit
+ (mkCheckExpType lit_ty)
+ in case mb_neg of
+ Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ second Just <$>
+ (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
+ \ [lit_ty] _ -> new_over_lit lit_ty)
+ -- applied to a closed literal: linearity doesn't matter as
+ -- literals are typed in an empty environment, hence have
+ -- all multiplicities.
+
+ ; res <- thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
{-
Note [NPlusK patterns]
@@ -904,68 +916,67 @@ AST is used for the subtraction operation.
-}
-- See Note [NPlusK patterns]
- NPlusKPat _ (L nm_loc name)
- (L loc lit) _ ge minus -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; let pat_exp_ty = scaledThing pat_ty
- orig = LiteralOrigin lit
- ; (lit1', ge')
- <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
- (mkCheckExpType boolTy) $
- \ [lit1_ty] _ ->
- newOverloadedLit lit (mkCheckExpType lit1_ty)
- ; ((lit2', minus_wrap, bndr_id), minus')
- <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
- \ [lit2_ty, var_ty] _ ->
- do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
- tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
- -- co :: var_ty ~ idType bndr_id
-
- -- minus_wrap is applicable to minus'
- ; return (lit2', wrap, bndr_id) }
-
- ; pat_ty <- readExpType pat_exp_ty
-
- -- The Report says that n+k patterns must be in Integral
- -- but it's silly to insist on this in the RebindableSyntax case
- ; unlessM (xoptM LangExt.RebindableSyntax) $
- do { icls <- tcLookupClass integralClassName
- ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
-
- ; res <- tcExtendIdEnv1 name bndr_id thing_inside
-
- ; let minus'' = case minus' of
- NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
- -- this should be statically avoidable
- -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
- SyntaxExprTc { syn_expr = minus'_expr
- , syn_arg_wraps = minus'_arg_wraps
- , syn_res_wrap = minus'_res_wrap }
- -> SyntaxExprTc { syn_expr = minus'_expr
- , syn_arg_wraps = minus'_arg_wraps
- , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
- -- Oy. This should really be a record update, but
- -- we get warnings if we try. #17783
- pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
- ge' minus''
- ; return (pat', res) }
+ NPlusKPat _ (L nm_loc name)
+ (L loc lit) _ ge minus -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; let orig = LiteralOrigin lit
+ ; (lit1', ge')
+ <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho]
+ (mkCheckExpType boolTy) $
+ \ [lit1_ty] _ ->
+ newOverloadedLit lit (mkCheckExpType lit1_ty)
+ ; ((lit2', minus_wrap, bndr_id), minus')
+ <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $
+ \ [lit2_ty, var_ty] _ ->
+ do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
+ ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
+ tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
+ -- co :: var_ty ~ idType bndr_id
+
+ -- minus_wrap is applicable to minus'
+ ; return (lit2', wrap, bndr_id) }
+
+ ; pat_ty <- readExpType exp_pat_ty
+
+ -- The Report says that n+k patterns must be in Integral
+ -- but it's silly to insist on this in the RebindableSyntax case
+ ; unlessM (xoptM LangExt.RebindableSyntax) $
+ do { icls <- tcLookupClass integralClassName
+ ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
+
+ ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+
+ ; let minus'' = case minus' of
+ NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
+ -- this should be statically avoidable
+ -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
+ SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus'_res_wrap }
+ -> SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
+ -- Oy. This should really be a record update, but
+ -- we get warnings if we try. #17783
+ pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
+ ge' minus''
+ ; return (pat', res) }
-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
- SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
+ SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
{ addModFinalizersWithLclEnv mod_finalizers
- ; tc_pat pat_ty penv pat thing_inside }
+ ; tc_pat scaled_exp_pat_ty penv pat thing_inside }
- SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
+ SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
- EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
+ EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
- InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
+ InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
- XPat (HsPatExpanded lpat rpat) -> do
- { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
- ; return (XPat $ ExpansionPat lpat rpat', res) }
+ XPat (HsPatExpanded lpat rpat) -> do
+ { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside
+ ; return (XPat $ ExpansionPat lpat rpat', res) }
{-
Note [Hopping the LIE in lazy patterns]
@@ -1295,7 +1306,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats
- ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
+ ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty'
; traceTc "tcPatSynPat" $
vcat [ text "Pat syn:" <+> ppr pat_syn
@@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv
-- In the case of a data family, this would
-- mention the /family/ TyCon
-> TcM (HsWrapper, [TcSigmaType])
--- See Note [Matching constructor patterns]
--- Returns a wrapper : pat_ty "->" T ty1 ... tyn
+-- ^ See Note [Matching constructor patterns]
+--
+-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn
matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
| Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-- Comments refer to Note [Matching constructor patterns]
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -263,7 +263,9 @@ in two places:
* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
-* Wrinkle (SIP1): we must be careful of superclasses. Consider
+There are wrinkles:
+
+* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider
f,g :: (?x::Int, C a) => a -> a
f v = let ?x = 4 in g v
@@ -271,24 +273,31 @@ in two places:
We must /not/ solve this from the Given (?x::Int, C a), because of
the intervening binding for (?x::Int). #14218.
- We deal with this by arranging that when we add [G] (?x::ty) we delete
+ We deal with this by arranging that when we add [G] (?x::ty) we /delete/
* from the inert_cans, and
* from the inert_solved_dicts
any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
- An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
- But it could happen for `class xx => D xx where ...` and the constraint D
- (?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explored.
+ An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
+
+ But it could also happen for `class xx => D xx where ...` and the constraint
+ D (?x :: int); again see Note [Local implicit parameters]. This corner
+ (constraint-kinded variables instantiated with implicit parameter constraints)
+ is not well explored.
- Example in #14218, and #23761
+ You might worry about whether deleting an /entire/ constraint just because
+ a distant superclass has an implicit parameter might make another Wanted for
+ that constraint un-solvable. Indeed so. But for constraint tuples it doesn't
+ matter -- their entire payload is their superclasses. And the other case is
+ the ill-explored corner above.
The code that accounts for (SIP1) is in updInertDicts; in particular the call to
GHC.Core.Predicate.mentionsIP.
* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
- as well as `inert_cans`.
+ as well as `inert_cans` (#23761).
+
You might think that wouldn't be necessary, because an element of
`inert_solved_dicts` is never an implicit parameter (see
Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
@@ -301,6 +310,19 @@ in two places:
Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
+* Wrinkle (SIP3)
+ - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
+ existing /Givens/! Deleting an existing Wanted led to #26451; we just never
+ solved it!
+
+ - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
+ Givens; they may be "inherited" from outer scopes, so we must delete any
+ solved dictionaries for this implicit parameter for /both/ Givens /and/
+ Wanteds.
+
+ Otherwise the new Given doesn't properly shadow those inherited solved
+ dictionaries. Test T23761 showed this up.
+
Example 1:
Suppose we have (typecheck/should_compile/ImplicitParamFDs)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict.
-}
updInertDicts :: DictCt -> TcS ()
-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
- = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
-
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
- -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
- -- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
- -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
- updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
- | otherwise
- -> return ()
+updInertDicts dict_ct
+ = do { traceTcS "Adding inert dict" (ppr dict_ct)
+
+ -- For Given implicit parameters (only), delete any existing
+ -- Givens for the same implicit parameter.
+ -- See Note [Shadowing of implicit parameters]
+ ; deleteGivenIPs dict_ct
+
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
+
+deleteGivenIPs :: DictCt -> TcS ()
+-- Special magic when adding a Given implicit parameter to the inert set
+-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
+-- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
+-- See Note [Shadowing of implicit parameters]
+deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ | isGiven ev
+ , Just (str_ty, _) <- isIPPred_maybe cls tys
+ = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
+ inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics
+ , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
+ | otherwise
+ = return ()
where
- -- Does this class constraint or any of its superclasses mention
- -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
- does_not_mention_ip_for :: Type -> DictCt -> Bool
- does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mightMentionIP]
- -- in GHC.Core.Predicate
+ keep_can, keep_solved :: Type -> DictCt -> Bool
+ -- keep_can: we keep an inert dictionary UNLESS
+ -- (1) it is a Given
+ -- (2) it binds an implicit parameter (?str :: ty) for the given 'str'
+ -- regardless of 'ty', possibly via its superclasses
+ -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
+ -- See Note [Using typesAreApart when calling mightMentionIP]
+ -- in GHC.Core.Predicate
+ --
+ -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
+ --
+ -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters]
+ keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ = not (isGiven ev -- (1)
+ && mentions_ip str cls tys) -- (2)
+ keep_solved str (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentions_ip str cls tys)
+
+ -- mentions_ip: the inert constraint might provide evidence
+ -- for an implicit parameter (?str :: ty) for the given 'str'
+ mentions_ip str cls tys
+ = mightMentionIP (not . typesAreApart str) (const True) cls tys
updInertIrreds :: IrredCt -> TcS ()
updInertIrreds irred
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -197,29 +197,29 @@ that it is a no-op. Here's our solution:
* we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
* there is little point in attempting to optimise any other HsWrappers
-Note [WpFun-RR-INVARIANT]
-~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [WpFun-FRR-INVARIANT]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
Given
wrap = WpFun wrap1 wrap2 sty1 ty2
where: wrap1 :: exp_arg ~~> act_arg
wrap2 :: act_res ~~> exp_res
wrap :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
we have
- WpFun-RR-INVARIANT:
+ WpFun-FRR-INVARIANT:
the input (exp_arg) and output (act_arg) types of `wrap1`
both have a fixed runtime-rep
Reason: We desugar wrap[e] into
\(x:exp_arg). wrap2[ e wrap1[x] ]
-And then, because of Note [Representation polymorphism invariants], we need:
+And then, because of Note [Representation polymorphism invariants]:
* `exp_arg` must have a fixed runtime rep,
so that lambda obeys the the FRR rules
* `act_arg` must have a fixed runtime rep,
- so the that application (e wrap1[x]) obeys the FRR tules
+ so that the application (e wrap1[x]) obeys the FRR rules
-Hence WpFun-INVARIANT.
+Hence WpFun-FRR-INVARIANT.
-}
data HsWrapper
@@ -246,7 +246,7 @@ data HsWrapper
-- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
--
-- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
- -- See Note [WpFun-RR-INVARIANT]
+ -- See Note [WpFun-FRR-INVARIANT]
--
-- Typing rules:
-- If e :: act_arg -> act_res
@@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper
-- ^ Smart constructor for `WpFun`
-- Just removes clutter and optimises some common cases.
--
--- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
+-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT]
--
-- Unfortunately, we can't check PRECONDITION with an assertion here, because of
-- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- Instantiate outer invisible binders (both Inferred and Specified)
-- If top_instantiate ty = (wrap, inner_ty)
--- then wrap :: inner_ty "->" ty
+-- then wrap :: inner_ty ~~> ty
-- NB: returns a type with no (=>),
-- and no invisible forall at the top
topInstantiate orig sigma
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify (
import GHC.Prelude
import GHC.Hs
-
import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )
import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg )
import GHC.Tc.Utils.Concrete
@@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
-- and res_ty is a RhoType
-- NB: the returned type is top-instantiated; it's a RhoType
matchActualFunTys herald ct_orig n_val_args_wanted top_ty
- = go n_val_args_wanted [] top_ty
+ = go n_val_args_wanted top_ty
where
- go n so_far fun_ty
+ go n fun_ty
| not (isRhoTy fun_ty)
= do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
- ; (wrap2, arg_tys, res_ty) <- go n so_far rho
+ ; (wrap2, arg_tys, res_ty) <- go n rho
; return (wrap2 <.> wrap1, arg_tys, res_ty) }
- go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
+ go 0 fun_ty = return (idHsWrapper, [], fun_ty)
- go n so_far fun_ty
- = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
- (n_val_args_wanted, top_ty) fun_ty
- ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
- ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
- -- NB: arg_ty1 comes from matchActualFunTy, so it has
- -- a syntactically fixed RuntimeRep
- ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
+ go n fun_ty
+ = do { (co1, arg1_ty_frr, res_ty1) <-
+ matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty
+ ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1
+ ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty
+ -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT:
+ -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR.
+ ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) }
{-
************************************************************************
@@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
= assert (isVisibleFunArg af) $
do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc
; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
- ; let arg_sty_frr = Scaled mult arg_ty_frr
- ; (wrap_res, result) <- check (n_req - 1)
- (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
+ ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
+ ; (res_wrap, result) <- check (n_req - 1)
+ (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
res_ty
- ; let wrap_arg = mkWpCastN arg_co
- fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
+
+ -- arg_co :: arg_ty ~ arg_ty_frr
+ -- res_wrap :: act_res_ty ~~> res_ty
+ ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty)
+ = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty
+ -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR
+
+ fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty)
+ = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty))
+
+ fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty)
+ = fun_wrap2 <.> fun_wrap1
+
+-- NB: in the common case, 'arg_ty' is already FRR (in the sense of
+-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'.
+-- Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively;
+-- as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will
+-- typically just be 'WpHole'; no clutter.
+-- This is important because 'matchExpectedFunTys' is called a lot.
+
; return (fun_wrap, result) }
----------------------------
@@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
------------------------
tcSubTypePat :: CtOrigin -> UserTypeCtxt
- -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+ -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
-- Used in patterns; polarity is backwards compared
-- to tcSubType
-- If wrap = tc_sub_type_et t1 t2
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -3,13 +3,10 @@
module GHC.Unit.Home.ModInfo
(
HomeModInfo (..)
- , HomeModLinkable(..)
+ , HomeModLinkable (..)
, homeModInfoObject
, homeModInfoByteCode
, emptyHomeModInfoLinkable
- , justBytecode
- , justObjects
- , bytecodeAndObjects
)
where
@@ -18,11 +15,9 @@ import GHC.Prelude
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
-import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )
+import GHC.Linker.Types ( Linkable )
import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -68,22 +63,6 @@ data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
-justBytecode :: Linkable -> HomeModLinkable
-justBytecode lm =
- assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
-
-justObjects :: Linkable -> HomeModLinkable
-justObjects lm =
- assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
- $ emptyHomeModInfoLinkable { homeMod_object = Just lm }
-
-bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
-bytecodeAndObjects bc o =
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- (HomeModLinkable (Just bc) (Just o))
-
-
{-
Note [Home module build products]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Unit/Module/Status.hs
=====================================
@@ -1,22 +1,35 @@
+{-# LANGUAGE LambdaCase #-}
+
module GHC.Unit.Module.Status
- ( HscBackendAction(..), HscRecompStatus (..)
+ ( HscBackendAction(..)
+ , HscRecompStatus (..)
+ , RecompLinkables (..)
+ , RecompBytecodeLinkable (..)
+ , emptyRecompLinkables
+ , justBytecode
+ , justObjects
+ , bytecodeAndObjects
+ , safeCastHomeModLinkable
)
where
import GHC.Prelude
import GHC.Unit
+import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
+import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly )
+
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
-import GHC.Unit.Home.ModInfo
+import GHC.Utils.Panic
-- | Status of a module in incremental compilation
data HscRecompStatus
-- | Nothing to do because code already exists.
- = HscUpToDate ModIface HomeModLinkable
+ = HscUpToDate ModIface RecompLinkables
-- | Recompilation of module, or update of interface is required. Optionally
-- pass the old interface hash to avoid updating the existing interface when
-- it has not changed.
@@ -41,6 +54,16 @@ data HscBackendAction
-- changed.
}
+-- | Linkables produced by @hscRecompStatus@. Might contain serialized core
+-- which can be turned into BCOs (or object files), or used by some other
+-- backend. See Note [Interface Files with Core Definitions].
+data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompBytecodeLinkable
+ , recompLinkables_object :: !(Maybe Linkable) }
+
+data RecompBytecodeLinkable
+ = NormalLinkable !(Maybe Linkable)
+ | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable
+
instance Outputable HscRecompStatus where
ppr HscUpToDate{} = text "HscUpToDate"
ppr HscRecompNeeded{} = text "HscRecompNeeded"
@@ -48,3 +71,37 @@ instance Outputable HscRecompStatus where
instance Outputable HscBackendAction where
ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi))
ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml
+
+instance Outputable RecompLinkables where
+ ppr (RecompLinkables l1 l2) = ppr l1 $$ ppr l2
+
+instance Outputable RecompBytecodeLinkable where
+ ppr (NormalLinkable lm) = text "NormalLinkable:" <+> ppr lm
+ ppr (WholeCoreBindingsLinkable lm) = text "WholeCoreBindingsLinkable:" <+> ppr lm
+
+emptyRecompLinkables :: RecompLinkables
+emptyRecompLinkables = RecompLinkables (NormalLinkable Nothing) Nothing
+
+safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables
+safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable bc) o
+
+justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
+justBytecode = \case
+ Left lm ->
+ assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
+ $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
+
+justObjects :: Linkable -> RecompLinkables
+justObjects lm =
+ assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
+ $ emptyRecompLinkables { recompLinkables_object = Just lm }
+
+bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
+bytecodeAndObjects either_bc o = case either_bc of
+ Left bc ->
+ assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
+ Right bc ->
+ assertPpr (linkableIsNativeCodeOnly o) (ppr o)
+ $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -130,6 +130,9 @@ data WholeCoreBindings = WholeCoreBindings
, wcb_foreign :: IfaceForeign
}
+instance Outputable WholeCoreBindings where
+ ppr (WholeCoreBindings {}) = text "WholeCoreBindings"
+
{-
Note [Foreign stubs and TH bytecode linking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/base/tests/all.T
=====================================
@@ -80,7 +80,7 @@ test('length001',
# excessive amounts of stack space. So we specifically set a low
# stack limit and mark it as failing under a few conditions.
[extra_run_opts('+RTS -K8m -RTS'),
- expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']),
+ expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc', 'ext-interp']),
# JS doesn't support stack limit so the test sometimes passes just fine. Therefore the test is
# marked as fragile.
when(js_arch(), fragile(22921))],
=====================================
testsuite/driver/testlib.py
=====================================
@@ -352,6 +352,9 @@ def req_plugins( name, opts ):
"""
req_interp(name, opts)
+ # Plugins aren't supported with the external interpreter (#14335)
+ expect_broken_for(14335,['ext-interp'])(name,opts)
+
if config.cross:
opts.skip = True
=====================================
testsuite/tests/driver/T20696/all.T
=====================================
@@ -1,4 +1,5 @@
test('T20696', [extra_files(['A.hs', 'B.hs', 'C.hs'])
+ , expect_broken_for(26552, ['ext-interp'])
, unless(ghc_dynamic(), skip)], multimod_compile, ['A', ''])
test('T20696-static', [extra_files(['A.hs', 'B.hs', 'C.hs'])
, when(ghc_dynamic(), skip)], multimod_compile, ['A', ''])
=====================================
testsuite/tests/driver/fat-iface/all.T
=====================================
@@ -9,12 +9,12 @@ test('fat010', [req_th,extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files],
# Check linking works when using -fbyte-code-and-object-code
test('fat011', [req_th, extra_files(['FatMain.hs', 'FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatMain', '-fbyte-code-and-object-code -fprefer-byte-code'])
# Check that we use interpreter rather than enable dynamic-too if needed for TH
-test('fat012', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code'])
+test('fat012', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code'])
# Check that no objects are generated if using -fno-code and -fprefer-byte-code
test('fat013', [req_th, req_bco, extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code'])
# When using interpreter should not produce objects
test('fat014', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script'])
-test('fat015', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
+test('fat015', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
test('T22807', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807A.hs', 'T22807B.hs'])]
, makefile_test, ['T22807'])
test('T22807_ghci', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807_ghci.hs'])]
=====================================
testsuite/tests/rep-poly/T26528.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE GHC2024, TypeFamilies #-}
+
+module T26528 where
+
+import Data.Kind
+import GHC.Exts
+
+type F :: Type -> RuntimeRep
+type family F a where
+ F Int = LiftedRep
+
+g :: forall (r::RuntimeRep).
+ (forall (a :: TYPE r). a -> forall b. b -> b) -> Int
+g _ = 3
+{-# NOINLINE g #-}
+
+foo = g @(F Int) (\x y -> y)
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, [''])
test('T23883c', normal, compile_fail, [''])
test('T23903', normal, compile_fail, [''])
test('T26107', js_broken(22364), compile, ['-O'])
+test('T26528', normal, compile, [''])
test('EtaExpandDataCon', normal, compile, ['-O'])
test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -9,7 +9,7 @@ test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0']
test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0'])
test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0'])
test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0'])
-test('SI07', [unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
+test('SI07', [expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
# Instance tests
test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0'])
test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0'])
=====================================
testsuite/tests/typecheck/should_compile/T26451.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
+
+module T26451 where
+
+type family F a
+type instance F Bool = [Char]
+
+class C a b | b -> a
+instance C Bool Bool
+instance C Char Char
+
+eq :: forall a b. C a b => a -> b -> ()
+eq p q = ()
+
+g :: a -> F a
+g = g
+
+f (x::tx) (y::ty) -- x :: alpha y :: beta
+ = let ?v = g x -- ?ip :: F alpha
+ in (?v::[ty], eq x True)
+
+
+{- tx, and ty are unification variables
+
+Inert: [G] dg :: IP "v" (F tx)
+ [W] dw :: IP "v" [ty]
+Work-list: [W] dc1 :: C tx Bool
+ [W] dc2 :: C ty Char
+
+* Solve dc1, we get tx := Bool from fundep
+* Kick out dg
+* Solve dg to get [G] dc : IP "v" [Char]
+* Add that new dg to the inert set: that simply deletes dw!!!
+-}
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -955,3 +955,4 @@ test('T26376', normal, compile, [''])
test('T26457', normal, compile, [''])
test('T17705', normal, compile, [''])
test('T14745', normal, compile, [''])
+test('T26451', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9d258d32e9b8e3adfb9079dde931e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9d258d32e9b8e3adfb9079dde931e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-link-node-errors] 70 commits: T22859: Increase threadDelay for small machines
by Matthew Pickering (＠mpickering) 07 Nov '25
by Matthew Pickering (＠mpickering) 07 Nov '25
07 Nov '25
Matthew Pickering pushed to branch wip/fix-link-node-errors at Glasgow Haskell Compiler / GHC
Commits:
e10dcd65 by Sven Tennie at 2025-10-12T10:24:56+00:00
T22859: Increase threadDelay for small machines
The previously used thread delay led to failures on my RISC-V test
setups.
- - - - -
d59ef6b6 by Hai / @BestYeen at 2025-10-14T21:51:14-04:00
Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again.
- - - - -
c98abb6a by Hai / @BestYeen at 2025-10-14T21:52:08-04:00
Update occurrences of return to pure and add a sample for redefining :m to mean :main
- - - - -
70ee825a by Cheng Shao at 2025-10-14T21:52:50-04:00
testsuite: fix T3586 for non-SSE3 platforms
`T3586.hs` contains `-fvia-C -optc-msse3` which I think is a
best-effort basis to harvest the C compiler's auto vectorization
optimizations via the C backend back when the test was added. The
`-fvia-C` part is now a deprecated no-op because GHC can't fall back
to the C backend on a non-unregisterised build, and `-optc-msse3`
might actually cause the test to fail on non x86/x64 platforms, e.g.
recent builds of wasi-sdk would report `wasm32-wasi-clang: error:
unsupported option '-msse3' for target 'wasm32-unknown-wasi'`.
So this patch cleans up this historical cruft. `-fvia-C` is removed,
and `-optc-msse3` is only passed when cpuid contains `pni` (which
indicates support of SSE3).
- - - - -
4be32153 by Teo Camarasu at 2025-10-15T08:06:09-04:00
Add submodules for template-haskell-lift and template-haskell-quasiquoter
These two new boot libraries expose stable subsets of the
template-haskell interface.
This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696
Work towards #25262
- - - - -
0c00c9c3 by Ben Gamari at 2025-10-15T08:06:51-04:00
rts: Eliminate uses of implicit constant arrays
Folding of `const`-sized variable-length arrays to a constant-length
array is a gnu extension which clang complains about.
Closes #26502.
- - - - -
bf902a1d by Fendor at 2025-10-15T16:00:59-04:00
Refactor distinct constructor tables map construction
Adds `GHC.Types.Unique.FM.alterUFM_L`, `GHC.Types.Unique.DFM.alterUDFM_L`
`GHC.Data.Word64Map.alterLookup` to support fusion of distinct
constructor data insertion and lookup during the construction of the `DataCon`
map in `GHC.Stg.Debug.numberDataCon`.
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
b3585ba1 by Fendor at 2025-10-15T16:00:59-04:00
Allow per constructor refinement of distinct-constructor-tables
Introduce `-fno-distinct-constructor-tables`. A distinct constructor table
configuration is built from the combination of flags given, in order. For
example, to only generate distinct constructor tables for a few specific
constructors and no others, just pass
`-fdistinct-constructor-tables-only=C1,...,CN`.
This flag can be supplied multiple times to extend the set of
constructors to generate a distinct info table for.
You can disable generation of distinct constructor tables for all
configurations by passing `-fno-distinct-constructor-tables`.
The various configurations of these flags is included in the `DynFlags`
fingerprints, which should result in the expected recompilation logic.
Adds a test that checks for distinct tables for various given or omitted
constructors.
Updates CountDepsAst and CountDepsParser tests to account for new dependencies.
Fixes #23703
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
e17dc695 by fendor at 2025-10-15T16:01:41-04:00
Fix typos in haddock documentation for stack annotation API
- - - - -
f85058d3 by Zubin Duggal at 2025-10-17T13:50:52+05:30
compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag
Fixes #26264
Metric Decrease:
T9233
- - - - -
c85c845d by sheaf at 2025-10-17T22:35:32-04:00
Don't prematurely final-zonk PatSyn declarations
This commit makes GHC hold off on the final zonk for pattern synonym
declarations, in 'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'.
This accommodates the fact that pattern synonym declarations without a
type signature can contain unfilled metavariables, e.g. if the RHS of
the pattern synonym involves view-patterns whose type mentions promoted
(level 0) metavariables. Just like we do for ordinary function bindings,
we should allow these metavariables to be settled later, instead of
eagerly performing a final zonk-to-type.
Now, the final zonking-to-type for pattern synonyms is performed in
GHC.Tc.Module.zonkTcGblEnv.
Fixes #26465
- - - - -
ba3e5bdd by Rodrigo Mesquita at 2025-10-18T16:57:18-04:00
Move code-gen aux symbols from ghc-internal to rts
These symbols were all previously defined in ghc-internal and made the
dependency structure awkward, where the rts may refer to some of these
symbols and had to work around that circular dependency the way
described in #26166.
Moreover, the code generator will produce code that uses these symbols!
Therefore, they should be available in the rts:
PRINCIPLE: If the code generator may produce code which uses this
symbol, then it should be defined in the rts rather than, say,
ghc-internal.
That said, the main motivation is towards fixing #26166.
Towards #26166. Pre-requisite of !14892
- - - - -
f31de2a9 by Ben Gamari at 2025-10-18T16:57:18-04:00
rts: Avoid static symbol references to ghc-internal
This resolves #26166, a bug due to new constraints placed by Apple's
linker on undefined references.
One source of such references in the RTS is the many symbols referenced
in ghc-internal. To mitigate #26166, we make these references dynamic,
as described in Note [RTS/ghc-internal interface].
Fixes #26166
Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com>
Co-authored-by: Cheng Shao <terrorjack(a)type.dance>
- - - - -
43fdfddc by Ben Gamari at 2025-10-18T16:57:18-04:00
compiler: Rename isMathFun -> isLibcFun
This set includes more than just math functions.
- - - - -
4ed5138f by Ben Gamari at 2025-10-18T16:57:18-04:00
compiler: Add libc allocator functions to libc_funs
Prototypes for these are now visible from `Prim.h`, resulting in
multiple-declaration warnings in the unregisterised job.
- - - - -
9a0a076b by Ben Gamari at 2025-10-18T16:57:18-04:00
rts: Minimize header dependencies of Prim.h
Otherwise we will end up with redundant and incompatible declarations
resulting in warnings during the unregisterised build.
- - - - -
26b8a414 by Diego Antonio Rosario Palomino at 2025-10-18T16:58:10-04:00
Cmm Parser: Fix incorrect example in comment
The Parser.y file contains a comment with an incorrect example of textual
Cmm (used in .cmm files). This commit updates the comment to ensure it
reflects valid textual Cmm syntax.
Fixes #26313
- - - - -
d4a9d6d6 by ARATA Mizuki at 2025-10-19T18:43:47+09:00
Handle implications between x86 feature flags
This includes:
* Multiple -msse* options can be specified
* -mavx implies -msse4.2
* -mavx2 implies -mavx
* -mfma implies -mavx
* -mavx512f implies -mavx2 and -mfma
* -mavx512{cd,er,pf} imply -mavx512f
Closes #24989
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
c9b8465c by Cheng Shao at 2025-10-20T10:16:00-04:00
wasm: workaround WebKit bug in dyld
This patch works around a WebKit bug and allows dyld to run on WebKit
based platforms as well. See added note for detailed explanation.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
91b6be10 by Julian Ospald at 2025-10-20T18:21:03-04:00
Improve error handling in 'getPackageArchives'
When the library dirs in the package conf files are not set up correctly,
the JS linker will happily ignore such packages and not link against them,
although they're part of the link plan.
Fixes #26383
- - - - -
6c5269da by Sven Tennie at 2025-10-20T18:21:44-04:00
Align coding style
Improve readability by using the same style for all constructor calls in
this function.
- - - - -
3d305889 by Sven Tennie at 2025-10-20T18:21:44-04:00
Reduce complexity by removing joins with mempty
ldArgs, cArgs and cppArgs are all `mempty`. Thus concatenating them adds
nothing but some complexity while reading the code.
- - - - -
38d65187 by Matthew Pickering at 2025-10-21T13:12:20+01:00
Fix stack decoding when using profiled runtime
There are three fixes in this commit.
* We need to replicate the `InfoTable` and `InfoTableProf`
approach for the other stack constants (see the new Stack.ConstantsProf
file).
* Then we need to appropiately import the profiled or non-profiled
versions.
* Finally, there was an incorrect addition in `stackFrameSize`. We need
to cast after performing addition on words.
Fixes #26507
- - - - -
17231bfb by fendor at 2025-10-21T13:12:20+01:00
Add regression test for #26507
- - - - -
4f5bf93b by Simon Peyton Jones at 2025-10-25T04:05:34-04:00
Postscript to fix for #26255
This MR has comments only
- - - - -
6ef22fa0 by IC Rainbow at 2025-10-26T18:23:01-04:00
Add SIMD primops for bitwise logical operations
This adds 128-bit wide and/or/xor instructions for X86 NCG,
with both SSE and AVX encodings.
```
andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -- andps / vandps
andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -- andpd / vandpd
andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16# -- pand / vpand
```
The new primops are available on ARM when using LLVM backend.
Tests added:
- simd015 (floats and doubles)
- simd016 (integers)
- simd017 (words)
Fixes #26417
- - - - -
fbdc623a by sheaf at 2025-10-26T18:23:52-04:00
Add hints for unsolved HasField constraints
This commit adds hints and explanations for unsolved 'HasField'
constraints.
GHC will now provide additional explanations for an unsolved constraint
of the form 'HasField fld_name rec_ty fld_ty'; the details are laid out in
Note [Error messages for unsolved HasField constraints], but briefly:
1. Provide similar name suggestions (e.g. mis-spelled field name)
and import suggestions (record field not in scope).
These result in actionable 'GhcHints', which is helpful to provide
code actions in HLS.
2. Explain why GHC did not solve the constraint, e.g.:
- 'fld_name' is not a string literal (e.g. a type variable)
- 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
- 'fld_ty' contains existentials variables or foralls.
- The record field is a pattern synonym field (GHC does not generate
HasField instances for those).
- 'HasField' is a custom 'TyCon', not actually the built-in
'HasField' typeclass from 'GHC.Records'.
On the way, we slightly refactor the mechanisms for import suggestions
in GHC.Rename.Unbound. This is to account for the fact that, for
'HasField', we don't care whether the field is imported qualified or
unqualified. 'importSuggestions' was refactored, we now have
'sameQualImportSuggestions' and 'anyQualImportSuggestions'.
Fixes #18776 #22382 #26480
- - - - -
99d5707f by sheaf at 2025-10-26T18:23:52-04:00
Rename PatSyn MatchContext to PatSynCtx to avoid punning
- - - - -
5dc2e9ea by Julian Ospald at 2025-10-27T18:17:23-04:00
Skip uniques test if sources are not available
- - - - -
544b9ec9 by Vladislav Zavialov at 2025-10-27T18:18:06-04:00
Re-export GHC.Hs.Basic from GHC.Hs
Clean up some import sections in GHC by re-exporting GHC.Hs.Basic
from GHC.Hs.
- - - - -
643ce801 by Julian Ospald at 2025-10-28T18:18:55-04:00
rts: remove unneccesary cabal flags
We perform those checks via proper autoconf macros
instead that do the right thing and then add those
libs to the rts buildinfo.
- - - - -
d69ea8fe by Vladislav Zavialov at 2025-10-28T18:19:37-04:00
Test case for #17705
Starting with GHC 9.12 (the first release to include 5745dbd3),
all examples in this ticket are handled as expected.
- - - - -
4038a28b by Andreas Klebinger at 2025-10-30T12:38:52-04:00
Add a perf test for #26425
- - - - -
f997618e by Andreas Klebinger at 2025-10-30T12:38:52-04:00
OccAnal: Be stricter for better compiler perf.
In particular we are now stricter:
* When combining usageDetails.
* When computing binder info.
In combineUsageDetails when combining the underlying adds we compute a
new `LocalOcc` for each entry by combining the two existing ones.
Rather than wait for those entries to be forced down the road we now
force them immediately. Speeding up T26425 by about 10% with little
effect on the common case.
We also force binders we put into the Core AST everywhere now.
Failure to do so risks leaking the occ env used to set the binders
OccInfo.
For T26425 compiler residency went down by a factor of ~10x.
Compile time also improved by a factor of ~1.6.
-------------------------
Metric Decrease:
T18698a
T26425
T9233
-------------------------
- - - - -
5618645b by Vladislav Zavialov at 2025-10-30T12:39:33-04:00
Fix namespace specifiers in subordinate exports (#12488)
This patch fixes an oversight in the `lookupChildrenExport` function that
caused explicit namespace specifiers of subordinate export items to be
ignored:
module M (T (type A)) where -- should be rejected
data T = A
Based on the `IEWrappedName` data type, there are 5 cases to consider:
1. Unadorned name: P(X)
2. Named default: P(default X)
3. Pattern synonym: P(pattern X)
4. Type name: P(type X)
5. Data name: P(data X)
Case 1 is already handled correctly; cases 2 and 3 are parse errors; and
it is cases 4 and 5 that we are concerned with in this patch.
Following the precedent established in `LookupExactName`, we introduce
a boolean flag in `LookupChildren` to control whether to look up in all
namespaces or in a specific one. If an export item is accompanied by an
explicit namespace specifier `type` or `data`, we restrict the lookup in
`lookupGRE` to a specific namespace.
The newly introduced diagnostic `TcRnExportedSubordinateNotFound`
provides error messages and suggestions more tailored to this context
than the previously used `reportUnboundName`.
- - - - -
f75ab223 by Peter Trommler at 2025-10-31T18:43:13-04:00
ghc-toolchain: detect PowerPC 64 bit ABI
Check preprocessor macro defined for ABI v2 and assume v1 otherwise.
Fixes #26521
- - - - -
d086c474 by Peter Trommler at 2025-10-31T18:43:13-04:00
ghc-toolchain: refactor, move lastLine to Utils
- - - - -
995dfe0d by Vladislav Zavialov at 2025-10-31T18:43:54-04:00
Tests for -Wduplicate-exports, -Wdodgy-exports
Add test cases for the previously untested diagnostics:
[GHC-51876] TcRnDupeModuleExport
[GHC-64649] TcRnNullExportedModule
This also revealed a typo (incorrect capitalization of "module") in the
warning text for TcRnDupeModuleExport, which is now fixed.
- - - - -
f6961b02 by Cheng Shao at 2025-11-01T00:08:01+01:00
wasm: reformat dyld source code
This commit reformats dyld source code with prettier, to avoid
introducing unnecessary diffs in subsequent patches when they're
formatted before committing.
- - - - -
0c9032a0 by Cheng Shao at 2025-11-01T00:08:01+01:00
wasm: simplify _initialize logic in dyld
This commit simplifies how we _initialize a wasm shared library in
dyld and removes special treatment for libc.so, see added comment for
detailed explanation.
- - - - -
ec1b40bd by Cheng Shao at 2025-11-01T00:08:01+01:00
wasm: support running dyld fully client side in the browser
This commit refactors the wasm dyld script so that it can be used to
load and run wasm shared libraries fully client-side in the browser
without needing a wasm32-wasi-ghci backend:
- A new `DyLDBrowserHost` class is exported, which runs in the browser
and uses the in-memory vfs without any RPC calls. This meant to be
used to create a `rpc` object for the fully client side use cases.
- The exported `main` function now can be used to load user-specified
shared libraries, and the user can use the returned `DyLD` instance
to run their own exported Haskell functions.
- The in-browser wasi implementation is switched to
https://github.com/haskell-wasm/browser_wasi_shim for bugfixes and
major performance improvements not landed upstream yet.
- When being run by deno, it now correctly switches to non-nodejs code
paths, so it's more convenient to test dyld logic with deno.
See added comments for details, as well as the added `playground001`
test case for an example of using it to build an in-browser Haskell
playground.
- - - - -
8f3e481f by Cheng Shao at 2025-11-01T00:08:01+01:00
testsuite: add playground001 to test haskell playground
This commit adds the playground001 test case to test the haskell
playground in browser, see comments for details.
- - - - -
af40606a by Cheng Shao at 2025-11-01T00:08:04+01:00
Revert "testsuite: add T26431 test case"
This reverts commit 695036686f8c6d78611edf3ed627608d94def6b7. T26431
is now retired, wasm ghc internal-interpreter logic is tested by
playground001.
- - - - -
86c82745 by Vladislav Zavialov at 2025-11-01T07:24:29-04:00
Supplant TcRnExportHiddenComponents with TcRnDodgyExports (#26534)
Remove a bogus special case in lookup_ie_kids_all,
making TcRnExportHiddenComponents obsolete.
- - - - -
fcf6331e by Richard Eisenberg at 2025-11-03T08:33:05+00:00
Refactor fundep solving
This commit is a large-scale refactor of the increasingly-messy code that
handles functional dependencies. It has virtually no effect on what compiles
but improves error messages a bit. And it does the groundwork for #23162.
The big picture is described in
Note [Overview of functional dependencies in type inference]
in GHC.Tc.Solver.FunDeps
* New module GHC.Tc.Solver.FunDeps contains all the fundep-handling
code for the constraint solver.
* Fundep-equalities are solved in a nested scope; they may generate
unifications but otherwise have no other effect.
See GHC.Tc.Solver.FunDeps.solveFunDeps
The nested needs to start from the Givens in the inert set, but
not the Wanteds; hence a new function `resetInertCans`, used in
`nestFunDepsTcS`.
* That in turn means that fundep equalities never show up in error
messages, so the complicated FunDepOrigin tracking can all disappear.
* We need to be careful about tracking unifications, so we kick out
constraints from the inert set after doing unifications. Unification
tracking has been majorly reformed: see Note [WhatUnifications] in
GHC.Tc.Utils.Unify.
A good consequence is that the hard-to-grok `resetUnificationFlag`
has been replaced with a simpler use of
`reportCoarseGrainUnifications`
Smaller things:
* Rename `FunDepEqn` to `FunDepEqns` since it contains multiple
type equalities.
Some compile time improvement
Metrics: compile_time/bytes allocated
Baseline
Test value New value Change
---------------------- --------------------------------------
T5030(normal) 173,839,232 148,115,248 -14.8% GOOD
hard_hole_fits(normal) 286,768,048 284,015,416 -1.0%
geo. mean -0.2%
minimum -14.8%
maximum +0.3%
Metric Decrease:
T5030
- - - - -
231adc30 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
QuickLook's tcInstFun should make instantiation variables directly
tcInstFun must make "instantiation variables", not regular
unification variables, when instantiating function types. That was
previously implemented by a hack: set the /ambient/ level to QLInstTyVar.
But the hack finally bit me, when I was refactoring WhatUnifications.
And it was always wrong: see the now-expunged (TCAPP2) note.
This commit does it right, by making tcInstFun call its own
instantiation functions. That entails a small bit of duplication,
but the result is much, much cleaner.
- - - - -
39d4a24b by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Build implication for constraints from (static e)
This commit addresses #26466, by buiding an implication for the
constraints arising from a (static e) form. The implication has
a special ic_info field of StaticFormSkol, which tells the constraint
solver to use an empty set of Givens.
See (SF3) in Note [Grand plan for static forms]
in GHC.Iface.Tidy.StaticPtrTable
This commit also reinstates an `assert` in GHC.Tc.Solver.Equality.
The test `StaticPtrTypeFamily` was failing with an assertion failure,
but it now works.
- - - - -
2e2aec1e by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Comments about defaulting representation equalities
- - - - -
52a4d1da by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Improve tracking of rewriter-sets
This refactor substantially improves the treatment of so-called
"rewriter-sets" in the constraint solver.
The story is described in the rewritten
Note [Wanteds rewrite Wanteds: rewriter-sets]
in GHC.Tc.Types.Constraint
Some highlights
* Trace the free coercion holes of a filled CoercionHole,
in CoercionPlusHoles. See Note [Coercion holes] (COH5)
This avoids taking having to take the free coercion variables
of a coercion when zonking a rewrriter-set
* Many knock on changes
* Make fillCoercionHole take CoercionPlusHoles as its argument
rather than to separate arguments.
* Similarly setEqIfWanted, setWantedE, wrapUnifierAndEmit.
* Be more careful about passing the correct CoHoleSet to
`rewriteEqEvidence` and friends
* Make kickOurAfterFillingCoercionHole more clever. See
new Note [Kick out after filling a coercion hole]
Smaller matters
* Rename RewriterSet to CoHoleSet
* Add special-case helper `rewriteEqEvidenceSwapOnly`
- - - - -
3e78e1ba by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Tidy up constraint solving for foralls
* In `can_eq_nc_forall` make sure to track Givens that are used
in the nested solve step.
* Tiny missing-swap bug-fix in `lookup_eq_in_qcis`
* Fix some leftover mess from
commit 14123ee646f2b9738a917b7cec30f9d3941c13de
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Wed Aug 20 00:35:48 2025 +0100
Solve forall-constraints via an implication, again
Specifically, trySolveImplication is now dead.
- - - - -
973f2c25 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Do not treat CoercionHoles as free variables in coercions
This fixes a long-standing wart in the free-variable finder;
now CoercionHoles are no longer treated as a "free variable"
of a coercion.
I got big and unexpected performance regressions when making
this change. Turned out that CallArity didn't discover that
the free variable finder could be eta-expanded, which gave very
poor code.
So I re-used Note [The one-shot state monad trick] for Endo,
resulting in GHC.Utils.EndoOS. Very simple, big win.
- - - - -
c2b8a0f9 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Update debug-tracing in CallArity
No effect on behaviour, and commented out anyway
- - - - -
9aa5ee99 by Simon Peyton Jones at 2025-11-03T08:33:28+00:00
Comments only -- remove dangling Note references
- - - - -
6683f183 by Simon Peyton Jones at 2025-11-03T08:33:28+00:00
Accept error message wibbles
- - - - -
3ba3d9f9 by Luite Stegeman at 2025-11-04T00:59:41-05:00
rts: fix eager black holes: record mutated closure and fix assertion
This fixes two problems with handling eager black holes, introduced
by a1de535f762bc23d4cf23a5b1853591dda12cdc9.
- the closure mutation must be recorded even for eager black holes,
since the mutator has mutated it before calling threadPaused
- The assertion that an unmarked eager black hole must be owned by
the TSO calling threadPaused is incorrect, since multiple threads
can race to claim the black hole.
fixes #26495
- - - - -
b5508f2c by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
build: Relax ghc/ghc-boot Cabal bound to 3.16
Fixes #26202
- - - - -
c5b3541f by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
cabal-reinstall: Use haddock-api +in-tree-ghc
Fixes #26202
- - - - -
c6d4b945 by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
cabal-reinstall: Pass --strict to Happy
This is necessary to make the generated Parser build successfully
This mimics Hadrian, which always passes --strict to happy.
Fixes #26202
- - - - -
79df1e0e by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
genprimopcode: Require higher happy version
I've bumped the happy version to forbid deprecated Happy versions which
don't successfully compile.
- - - - -
fa5d33de by Simon Peyton Jones at 2025-11-05T08:35:40-05:00
Add a HsWrapper optimiser
This MR addresses #26349, by introduceing optSubTypeHsWrapper.
There is a long
Note [Deep subsumption and WpSubType]
in GHC.Tc.Types.Evidence that explains what is going on.
- - - - -
ea58cae5 by Simon Peyton Jones at 2025-11-05T08:35:40-05:00
Improve mkWpFun_FRR
This commit ensures that `mkWpFun_FRR` directly produces a `FunCo` in
the cases where it can.
(Previously called `mkWpFun` which in turn optimised to a `FunCo`, but
that made the smarts in `mkWpFun` /essential/ rather than (as they
should be) optional.
- - - - -
5cdcfaed by Ben Gamari at 2025-11-06T09:01:36-05:00
compiler: Exclude units with no exposed modules from unused package check
Such packages cannot be "used" in the Haskell sense of the word yet
are nevertheless necessary as they may provide, e.g., C object code or
link flags.
Fixes #24120.
- - - - -
74b8397a by Brandon Chinn at 2025-11-06T09:02:19-05:00
Replace deprecated argparse.FileType
- - - - -
36ddf988 by Ben Gamari at 2025-11-06T09:03:01-05:00
Bump unix submodule to 2.8.8.0
Closes #26474.
- - - - -
c32b3a29 by fendor at 2025-11-06T09:03:43-05:00
Fix assertion in `postStringLen` to account for \0 byte
We fix the assertion to handle trailing \0 bytes in `postStringLen`.
Before this change, the assertion looked like this:
ASSERT(eb->begin + eb->size > eb->pos + len + 1);
Let's assume some values to see why this is actually off by one:
eb->begin = 0
eb->size = 1
eb->pos = 0
len = 1
then the assertion would trigger correctly:
0 + 1 > 0 + 1 + 1 => 1 > 2 => false
as there is not enough space for the \0 byte (which is the trailing +1).
However, if we change `eb->size = 2`, then we do have enough space for a
string of length 1, but the assertion still fails:
0 + 2 > 0 + 1 + 1 => 2 > 2 => false
Which causes the assertion to fail if there is exactly enough space for
the string with a trailing \0 byte.
Clearly, the assertion should be `>=`!
If we switch around the operand, it should become more obvious that `<=`
is the correct comparison:
ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
This is expresses more naturally that the current position plus the
length of the string (and the null byte) must be smaller or equal to the
overall size of the buffer.
This change also is in line with the implementation in
`hasRoomForEvent` and `hasRoomForVariableEvent`:
```
StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum)
{
uint32_t size = ...;
if (eb->pos + size > eb->begin + eb->size)
...
```
the check `eb->pos + size > eb->begin + eb->size` is identical to
`eb->pos + size <= eb->begin + eb->size` plus a negation.
- - - - -
3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00
Bump os-string submodule to 2.0.8
- - - - -
39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00
rts: use computed goto for instruction dispatch in the bytecode interpreter
This patch uses computed goto for instruction dispatch in the bytecode
interpreter. Previously instruction dispatch is done by a classic
switch loop, so executing the next instruction requires two jumps: one
to the start of the switch loop and another to the case block based on
the instruction tag. By using computed goto, we can build a jump table
consisted of code addresses indexed by the instruction tags
themselves, so executing the next instruction requires only one jump,
to the destination directly fetched from the jump table.
Closes #12953.
- - - - -
93fc7265 by sheaf at 2025-11-06T21:33:24-05:00
Correct hasFixedRuntimeRep in matchExpectedFunTys
This commit fixes a bug in the representation-polymormorphism check in
GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put
the coercion resulting from hasFixedRuntimeRep in the wrong place,
leading to the Core Lint error reported in #26528.
The change is that we have to be careful when using 'mkWpFun': it
expects **both** the expected and actual argument types to have a
syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT]
in GHC.Tc.Types.Evidence.
On the way, this patch improves some of the commentary relating to
other usages of 'mkWpFun' in the compiler, in particular in the view
pattern case of 'tc_pat'. No functional changes, but some stylistic
changes to make the code more readable, and make it easier to understand
how we are upholding the WpFun-FRR-INVARIANT.
Fixes #26528
- - - - -
c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
aa9dddde by Matthew Pickering at 2025-11-07T14:54:43+00:00
driver: Properly handle errors during LinkNode steps
Previously we were not properly catching errors during the LinkNode step
(see T9930fail test).
This is fixed by wrapping the `LinkNode` action in `wrapAction`, the
same handler which is used for module compilation.
Fixes #26496
- - - - -
423 changed files:
- .gitmodules
- cabal.project-reinstall
- compiler/GHC/Builtin/Uniques.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/CallArity.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/Config/Stg/Debug.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Flags.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/JS/JStg/Monad.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Platform.hs
- compiler/GHC/Platform/Reg.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Stg/Debug.hs
- + compiler/GHC/Stg/Debug/Types.hs
- compiler/GHC/Stg/EnforceEpt.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToCmm/ExtCode.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/FunDeps.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- + compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Irred.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Solver/Solve.hs-boot
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/DSM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Types/Var/Env.hs
- + compiler/GHC/Utils/EndoOS.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Setup.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/compare-flags.py
- docs/users_guide/debug-info.rst
- docs/users_guide/ghci.rst
- docs/users_guide/using.rst
- hadrian/src/Packages.hs
- hadrian/src/Rules/Gmp.hs
- hadrian/src/Rules/Libffi.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Common.hs
- hadrian/src/Settings/Builders/DeriveConstants.hs
- hadrian/src/Settings/Builders/Hsc2Hs.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-boot/Setup.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-experimental/CHANGELOG.md
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- + libraries/ghc-internal/cbits/RtsIface.c
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/include/RtsIfaceSymbols.h
- + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- + libraries/ghc-internal/tests/backtraces/T26507.hs
- + libraries/ghc-internal/tests/backtraces/T26507.stderr
- libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-prim/changelog.md
- libraries/os-string
- + libraries/template-haskell-lift
- + libraries/template-haskell-quasiquoter
- libraries/unix
- m4/fp_check_pthreads.m4
- m4/fptools_alex.m4
- m4/fptools_happy.m4
- rts/BuiltinClosures.c
- rts/CloneStack.h
- rts/Compact.cmm
- rts/ContinuationOps.cmm
- rts/Exception.cmm
- rts/Interpreter.c
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RtsAPI.c
- rts/RtsStartup.c
- rts/RtsSymbols.c
- + rts/RtsToHsIface.c
- rts/StgStdThunks.cmm
- rts/ThreadPaused.c
- rts/configure.ac
- rts/eventlog/EventLog.c
- − rts/external-symbols.list.in
- rts/gen_event_types.py
- rts/include/Rts.h
- rts/include/RtsAPI.h
- rts/include/Stg.h
- rts/include/rts/Bytecodes.h
- + rts/include/rts/RtsToHsIface.h
- rts/include/rts/Types.h
- rts/include/stg/Prim.h
- rts/posix/OSMem.c
- rts/posix/Signals.c
- libraries/ghc-internal/cbits/atomic.c → rts/prim/atomic.c
- libraries/ghc-internal/cbits/bitrev.c → rts/prim/bitrev.c
- libraries/ghc-internal/cbits/bswap.c → rts/prim/bswap.c
- libraries/ghc-internal/cbits/clz.c → rts/prim/clz.c
- libraries/ghc-internal/cbits/ctz.c → rts/prim/ctz.c
- libraries/ghc-internal/cbits/int64x2minmax.c → rts/prim/int64x2minmax.c
- libraries/ghc-internal/cbits/longlong.c → rts/prim/longlong.c
- libraries/ghc-internal/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c
- libraries/ghc-internal/cbits/pdep.c → rts/prim/pdep.c
- libraries/ghc-internal/cbits/pext.c → rts/prim/pext.c
- libraries/ghc-internal/cbits/popcnt.c → rts/prim/popcnt.c
- libraries/ghc-internal/cbits/vectorQuotRem.c → rts/prim/vectorQuotRem.c
- libraries/ghc-internal/cbits/word2float.c → rts/prim/word2float.c
- rts/rts.buildinfo.in
- rts/rts.cabal
- rts/wasm/JSFFI.c
- rts/wasm/scheduler.cmm
- rts/win32/libHSghc-internal.def
- testsuite/driver/cpu_features.py
- testsuite/driver/runtests.py
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.asm
- + testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.hs
- + testsuite/tests/codeGen/should_gen_asm/msse-option-order.asm
- + testsuite/tests/codeGen/should_gen_asm/msse-option-order.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/dependent/should_fail/T13135_simple.stderr
- testsuite/tests/deriving/should_fail/T3621.stderr
- testsuite/tests/diagnostic-codes/codes.stdout
- + testsuite/tests/driver/T24120.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/ghc-api-browser/README.md
- + testsuite/tests/ghc-api-browser/all.T
- + testsuite/tests/ghc-api-browser/index.html
- + testsuite/tests/ghc-api-browser/playground001.hs
- + testsuite/tests/ghc-api-browser/playground001.js
- + testsuite/tests/ghc-api-browser/playground001.sh
- testsuite/tests/ghci-wasm/T26431.stdout → testsuite/tests/ghc-api-browser/playground001.stdout
- + testsuite/tests/ghc-api/T26264.hs
- + testsuite/tests/ghc-api/T26264.stdout
- testsuite/tests/ghc-api/all.T
- testsuite/tests/ghc-e/should_fail/T9930fail.stderr
- testsuite/tests/ghc-e/should_fail/all.T
- − testsuite/tests/ghci-wasm/T26431.hs
- testsuite/tests/ghci-wasm/all.T
- testsuite/tests/indexed-types/should_fail/T14369.stderr
- testsuite/tests/indexed-types/should_fail/T1897b.stderr
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- testsuite/tests/linters/all.T
- testsuite/tests/linters/notes.stdout
- testsuite/tests/module/mod4.stderr
- testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr
- testsuite/tests/overloadedrecflds/should_fail/T16745.stderr
- testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr
- + testsuite/tests/overloadedrecflds/should_fail/T26480.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480.stderr
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
- testsuite/tests/overloadedrecflds/should_fail/all.T
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- + testsuite/tests/parser/should_fail/T12488c.hs
- + testsuite/tests/parser/should_fail/T12488c.stderr
- + testsuite/tests/parser/should_fail/T12488d.hs
- + testsuite/tests/parser/should_fail/T12488d.stderr
- testsuite/tests/parser/should_fail/T20654a.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/partial-sigs/should_fail/T14584a.stderr
- + testsuite/tests/patsyn/should_compile/T26465b.hs
- + testsuite/tests/patsyn/should_compile/T26465c.hs
- + testsuite/tests/patsyn/should_compile/T26465d.hs
- + testsuite/tests/patsyn/should_compile/T26465d.stderr
- testsuite/tests/patsyn/should_compile/all.T
- + testsuite/tests/patsyn/should_fail/T26465.hs
- + testsuite/tests/patsyn/should_fail/T26465.stderr
- testsuite/tests/patsyn/should_fail/all.T
- + testsuite/tests/perf/compiler/T26425.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/perf/should_run/T3586.hs
- testsuite/tests/perf/should_run/UniqLoop.hs
- testsuite/tests/perf/should_run/all.T
- testsuite/tests/polykinds/T6068.stdout
- testsuite/tests/quantified-constraints/T15359.hs
- testsuite/tests/regalloc/regalloc_unit_tests.hs
- + testsuite/tests/rename/should_compile/T12488b.hs
- + testsuite/tests/rename/should_compile/T12488f.hs
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/rename/should_fail/T12488a.hs
- + testsuite/tests/rename/should_fail/T12488a.stderr
- + testsuite/tests/rename/should_fail/T12488a_foo.hs
- + testsuite/tests/rename/should_fail/T12488a_foo.stderr
- + testsuite/tests/rename/should_fail/T12488e.hs
- + testsuite/tests/rename/should_fail/T12488e.stderr
- + testsuite/tests/rename/should_fail/T12488g.hs
- + testsuite/tests/rename/should_fail/T12488g.stderr
- testsuite/tests/rename/should_fail/T19843h.stderr
- testsuite/tests/rename/should_fail/T25899e2.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rep-poly/RepPolyNPlusK.stderr
- testsuite/tests/rep-poly/RepPolyRightSection.stderr
- testsuite/tests/rep-poly/T13233.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T23903.stderr
- + testsuite/tests/rep-poly/T26528.hs
- testsuite/tests/rep-poly/all.T
- testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/ipe/distinct-tables/Main.hs
- + testsuite/tests/rts/ipe/distinct-tables/Makefile
- + testsuite/tests/rts/ipe/distinct-tables/X.hs
- + testsuite/tests/rts/ipe/distinct-tables/all.T
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables01.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables02.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables03.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables04.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables05.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables06.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables07.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables08.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables09.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables10.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables11.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables12.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables13.stdout
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simd/should_run/simd015.hs
- + testsuite/tests/simd/should_run/simd015.stdout
- + testsuite/tests/simd/should_run/simd016.hs
- + testsuite/tests/simd/should_run/simd016.stdout
- + testsuite/tests/simd/should_run/simd017.hs
- + testsuite/tests/simd/should_run/simd017.stdout
- + testsuite/tests/simplCore/should_compile/T26349.hs
- + testsuite/tests/simplCore/should_compile/T26349.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_compile/rule2.stderr
- testsuite/tests/th/T8761.stderr
- testsuite/tests/typecheck/no_skolem_info/T13499.stderr
- testsuite/tests/typecheck/should_compile/T13651.hs
- − testsuite/tests/typecheck/should_compile/T13651.stderr
- + testsuite/tests/typecheck/should_compile/T14745.hs
- + testsuite/tests/typecheck/should_compile/T17705.hs
- + testsuite/tests/typecheck/should_compile/T26451.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr
- testsuite/tests/typecheck/should_compile/tc126.hs
- testsuite/tests/typecheck/should_fail/AmbigFDs.hs
- − testsuite/tests/typecheck/should_fail/AmbigFDs.stderr
- testsuite/tests/typecheck/should_fail/FD3.stderr
- testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr
- testsuite/tests/typecheck/should_fail/T13506.stderr
- testsuite/tests/typecheck/should_fail/T16512a.stderr
- testsuite/tests/typecheck/should_fail/T18851b.hs
- − testsuite/tests/typecheck/should_fail/T18851b.stderr
- testsuite/tests/typecheck/should_fail/T18851c.hs
- − testsuite/tests/typecheck/should_fail/T18851c.stderr
- testsuite/tests/typecheck/should_fail/T19415.stderr
- testsuite/tests/typecheck/should_fail/T19415b.stderr
- testsuite/tests/typecheck/should_fail/T22684.stderr
- + testsuite/tests/typecheck/should_fail/T23162a.hs
- + testsuite/tests/typecheck/should_fail/T23162a.stderr
- testsuite/tests/typecheck/should_fail/T25325.stderr
- testsuite/tests/typecheck/should_fail/T5246.stderr
- testsuite/tests/typecheck/should_fail/T5978.stderr
- testsuite/tests/typecheck/should_fail/T7368a.stderr
- testsuite/tests/typecheck/should_fail/T7696.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail122.stderr
- testsuite/tests/typecheck/should_fail/tcfail143.stderr
- + testsuite/tests/warnings/should_compile/DodgyExports02.hs
- + testsuite/tests/warnings/should_compile/DodgyExports02.stderr
- + testsuite/tests/warnings/should_compile/DodgyExports03.hs
- + testsuite/tests/warnings/should_compile/DodgyExports03.stderr
- + testsuite/tests/warnings/should_compile/DuplicateModExport.hs
- + testsuite/tests/warnings/should_compile/DuplicateModExport.stderr
- + testsuite/tests/warnings/should_compile/EmptyModExport.hs
- + testsuite/tests/warnings/should_compile/EmptyModExport.stderr
- testsuite/tests/warnings/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/deriveConstants/Main.hs
- utils/genprimopcode/genprimopcode.cabal
- utils/ghc-toolchain/ghc-toolchain.cabal
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- + utils/ghc-toolchain/src/GHC/Toolchain/CheckPower.hs
- utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/jsffi/dyld.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae57144f22c77173724b831a04ace1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae57144f22c77173724b831a04ace1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
07 Nov '25
Matthew Pickering pushed new branch wip/mp/14996 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mp/14996
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC
Commits:
2b0c10d6 by Simon Peyton Jones at 2025-11-07T13:14:25+00:00
More [skip ci]
Making static bindings have static constraint solveing
Sigh
- - - - -
23 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Types/BasicTypes.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- − compiler/GHC/Tc/Utils/TcMType.hs-boot
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/TcType.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -98,7 +98,7 @@ type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, StaticFlag)
data StaticFlag
= IsStatic | NotStatic
- deriving( Data )
+ deriving( Eq, Data )
-- IsStatic <=> this binding consists only code; all free
-- vars are top level (or themselves static).
-- So it can be moved to top level
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -412,7 +412,7 @@ warnRedundantConstraints ctxt env info redundant_evs
| null redundant_evs
= return ()
- | SigSkol user_ctxt _ _ <- info
+ | SigSkol _ user_ctxt _ _ <- info
-- When dealing with a user-written type signature,
-- we want to add "In the type signature for f".
= report_redundant_msg True (setCtLocEnvLoc env (redundantConstraintsSpan user_ctxt))
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -5481,7 +5481,7 @@ suggestAddSig ctxt ty1 _ty2
find [] _ _ = []
find (implic:implics) seen_eqs tv
| tv `elem` ic_skols implic
- , InferSkol prs <- ic_info implic
+ , InferSkol _ prs <- ic_info implic
, seen_eqs
= map fst prs
| otherwise
@@ -5555,7 +5555,7 @@ ctxtFixes has_ambig_tvs pred implics
, isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say
, (skol:skols) <- usefulContext implics pred
, let what | null skols
- , SigSkol (PatSynCtxt {}) _ _ <- skol
+ , SigSkol _ (PatSynCtxt {}) _ _ <- skol
= text "\"required\""
| otherwise
= empty
@@ -5580,7 +5580,7 @@ usefulContext implics pred
go :: [Implication] -> [SkolemInfoAnon]
go [] = []
go (ic : ics)
- | StaticFormSkol <- ic_info ic = []
+ | isStaticSkolInfo (ic_info ic) = []
-- Stop at a static form, because all outer Givens are irrelevant
-- See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
| implausible ic = rest
@@ -5595,7 +5595,7 @@ usefulContext implics pred
| implausible_info (ic_info ic) = True
| otherwise = False
- implausible_info (SigSkol (InfSigCtxt {}) _ _) = True
+ implausible_info (SigSkol _ (InfSigCtxt {}) _ _) = True
implausible_info _ = False
-- Do not suggest adding constraints to an *inferred* type signature
@@ -5690,17 +5690,17 @@ tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env
----------------
tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon
tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty)
-tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs
-tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
+tidySkolemInfoAnon env (SigSkol st cx ty tv_prs) = tidySigSkol env st cx ty tv_prs
+tidySkolemInfoAnon env (InferSkol st ids) = InferSkol st (mapSnd (tidyType env) ids)
tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty)
tidySkolemInfoAnon _ info = info
-tidySigSkol :: TidyEnv -> UserTypeCtxt
+tidySigSkol :: TidyEnv -> StaticFlag -> UserTypeCtxt
-> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon
-- We need to take special care when tidying SigSkol
-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"
-tidySigSkol env cx ty tv_prs
- = SigSkol cx (tidy_ty env ty) tv_prs'
+tidySigSkol env st cx ty tv_prs
+ = SigSkol st cx (tidy_ty env ty) tv_prs'
where
tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs
inst_env = mkNameEnv tv_prs'
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -5530,8 +5530,8 @@ discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens]
| otherwise
= givens
where
- discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'
- discard _ _ = False
+ discard n (Implic { ic_info = SigSkol _ (PatSynCtxt n') _ _ }) = n == n'
+ discard _ _ = False
-- | An error reported after constraint solving.
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -366,6 +366,7 @@ tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside
; let final_closed = adjustClosedForUnlifted closed ids
; thing <- tcExtendLetEnv top_lvl sig_fn final_closed ids thing_inside
+
; return ( (NonRecursive, bind', sendToTopLevel final_closed), thing ) }
tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton
@@ -473,7 +474,9 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
-- Knows nothing about the scope of the bindings
-- None of the bindings are pattern synonyms
-tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
+tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc
+ closed@(IsGroupClosed {gc_static = static_flag})
+ bind_list
= setSrcSpan loc $
recoverM (recoveryCode binder_names sig_fn) $ do
-- Set up main recover; take advantage of any type sigs
@@ -481,12 +484,12 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
{ traceTc "------------------------------------------------" Outputable.empty
; traceTc "Bindings for {" (ppr binder_names)
; dflags <- getDynFlags
- ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list
+ ; let plan = decideGeneralisationPlan dflags closed sig_fn bind_list
; traceTc "Generalisation plan" (ppr plan)
; result@(_, scaled_poly_ids) <- case plan of
- NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
- InferGen -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn bind_list
- CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
+ NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
+ InferGen -> tcPolyInfer top_lvl static_flag rec_tc prag_fn sig_fn bind_list
+ CheckGen lbind sig -> tcPolyCheck static_flag prag_fn sig lbind
; let poly_ids = map scaledThing scaled_poly_ids
@@ -567,14 +570,13 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
* *
********************************************************************* -}
-tcPolyCheck :: TcPragEnv
- -> TcCompleteSig
+tcPolyCheck :: StaticFlag -> TcPragEnv -> TcCompleteSig
-> LHsBind GhcRn -- Must be a FunBind
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-- There is just one binding,
-- it is a FunBind
-- it has a complete type signature,
-tcPolyCheck prag_fn
+tcPolyCheck static_flag prag_fn
sig@(CSig { sig_bndr = poly_id, sig_ctxt = ctxt })
(L bind_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches }))
@@ -589,7 +591,7 @@ tcPolyCheck prag_fn
; mult <- newMultiplicityVar
; (wrap_gen, (wrap_res, matches'))
- <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty ->
+ <- tcSkolemiseCompleteSig sig static_flag $ \invis_pat_tys rho_ty ->
let mono_id = mkLocalId mono_name (idMult poly_id) rho_ty in
tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
@@ -632,7 +634,7 @@ tcPolyCheck prag_fn
; return ([abs_bind], [Scaled mult poly_id]) }
-tcPolyCheck _prag_fn sig bind
+tcPolyCheck _static _prag_fn sig bind
= pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
@@ -719,13 +721,14 @@ To address this we to do a few things
-}
tcPolyInfer
- :: TopLevelFlag
+ :: TopLevelFlag -- Syntactically top-leve
+ -> StaticFlag -- Static (morally top level)
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list
+tcPolyInfer top_lvl static_flag rec_tc prag_fn tc_sig_fn bind_list
= do { (tclvl, wanted, (binds', mono_infos))
<- pushLevelAndCaptureConstraints $
tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
@@ -745,7 +748,8 @@ tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list
; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
; ((qtvs, givens, ev_binds, insoluble), residual)
- <- captureConstraints $ simplifyInfer top_lvl tclvl infer_mode sigs name_taus wanted
+ <- captureConstraints $
+ simplifyInfer top_lvl static_flag tclvl infer_mode sigs name_taus wanted
; let inferred_theta = map evVarPred givens
; scaled_exports <- checkNoErrs $
@@ -1804,29 +1808,32 @@ instance Outputable GeneralisationPlan where
ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
decideGeneralisationPlan
- :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun
+ :: DynFlags -> IsGroupClosed -> TcSigFun
-> [LHsBind GhcRn] -> GeneralisationPlan
-decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
+decideGeneralisationPlan dflags (IsGroupClosed { gc_static = static_flag
+ , gc_closed = closed_type })
+ sig_fn lbinds
| Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
| generalise_binds = InferGen
| otherwise = NoGen
where
generalise_binds
- | isTopLevel top_lvl = True
- -- See Note [Always generalise top-level bindings]
+ | null binders = False
+ -- Not if `binders` is empty: there is no binder to generalise, so
+ -- generalising does nothing. And trying to generalise hurts linear
+ -- types (see #25428). So we don't force it.
+ -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind.
+
+ | IsStatic <- static_flag = True
+ -- See Note [Always generalise syntactically top-level bindings]
| has_mult_anns_and_pats = False
-- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear]
- | IsGroupClosed _ _ True <- closed
- , not (null binders) = True
- -- The 'True' means that all of the group's
+ | closed_type = True
+ -- The `closed_type` means that all of the group's
-- free vars have ClosedTypeId=True; so we can ignore
-- -XMonoLocalBinds, and generalise anyway.
- -- Except if 'fv' is empty: there is no binder to generalise, so
- -- generalising does nothing. And trying to generalise hurts linear
- -- types (see #25428). So we don't force it.
- -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind.
| has_partial_sigs = True
-- See Note [Partial type signatures and generalisation]
@@ -1855,7 +1862,9 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed
isClosedBndrGroup type_env binds
- = IsGroupClosed is_static fv_env type_closed
+ = IsGroupClosed { gc_static = is_static
+ , gc_fvs = fv_env
+ , gc_closed = type_closed }
where
fv_env :: NameEnv NameSet
fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ]
@@ -1886,9 +1895,9 @@ isClosedBndrGroup type_env binds
id_is_static name
| Just thing <- lookupNameEnv type_env name
= case thing of
- AGlobal {} -> True
- ATcId { tct_info = LetBound { lb_top = IsStatic } } -> True
- _ -> False
+ AGlobal {} -> True
+ ATcId { tct_info = LetBound { lb_static = IsStatic } } -> True
+ _ -> False
| otherwise -- Imported Ids
= True
@@ -1916,15 +1925,20 @@ isClosedBndrGroup type_env binds
-- Ditto class method etc from the current module
adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed
-adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids
- | IsStatic <- top_lvl
- , all definitely_lifted ids = closed
- | otherwise = IsGroupClosed NotStatic fv_env type_closed
+adjustClosedForUnlifted closed ids
+ | IsGroupClosed { gc_static = IsStatic } <- closed
+ , not (all closed_and_lifted ids)
+ = closed { gc_static = NotStatic }
+ | otherwise
+ = closed
where
- definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id)
+ closed_and_lifted (Scaled _ id) = noFreeVarsOfType ty
+ && definitelyLiftedType ty
+ where
+ ty = idType id
sendToTopLevel :: IsGroupClosed -> StaticFlag
-sendToTopLevel (IsGroupClosed top _ _) = top
+sendToTopLevel (IsGroupClosed { gc_static = is_static }) = is_static
lHsBindFreeVars :: LHsBind GhcRn -> NameSet
lHsBindFreeVars (L _ (FunBind { fun_ext = fvs })) = fvs
@@ -1932,16 +1946,17 @@ lHsBindFreeVars (L _ (PatBind { pat_ext = fvs })) = fvs
lHsBindFreeVars _ = emptyNameSet
-{- Note [Always generalise top-level bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Always generalise syntactically top-level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is very confusing to apply NoGen to a top level binding. Consider (#20123):
module M where
x = 5
f y = (x, y)
-The MR means that x=5 is not generalise, so f's binding is no Closed. So we'd
-be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which
-is plain stupid.
+The MR means that x=5 is not generalised, so f's binding has a free variable
+that is not ClosedTypeId. So we'd be tempted to use NoGen. But that leads to
+ f :: Any -> (Integer, Any)
+which is plain stupid.
NoGen is good when we have call sites, but not at top level, where the
function may be exported. And it's easier to grok "MonoLocalBinds" as
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -204,7 +204,7 @@ tcPolyExprCheck expr res_ty
= do { (wrap, expr') <- tcSkolemiseExpectedType ty thing_inside
; return (mkHsWrap wrap expr') }
outer_skolemise (Right sig) thing_inside
- = do { (wrap, expr') <- tcSkolemiseCompleteSig sig thing_inside
+ = do { (wrap, expr') <- tcSkolemiseCompleteSig sig NotStatic thing_inside
; return (mkHsWrap wrap expr') }
-- inner_skolemise is used when we do not have a lambda
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -689,7 +689,8 @@ tcExprSig expr sig@(TcPartialSig (PSig { psig_name = name, psig_loc = loc }))
= NoRestrictions
; ((qtvs, givens, ev_binds, _), residual)
<- captureConstraints $
- simplifyInfer NotTopLevel tclvl infer_mode [sig_inst] [(name, tau)] wanted
+ simplifyInfer NotTopLevel NotStatic tclvl infer_mode
+ [sig_inst] [(name, tau)] wanted
; emitConstraints residual
; tau <- liftZonkM $ zonkTcType tau
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -622,7 +622,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
VarPat x (L l name) -> do
{ (wrap, id) <- tcPatBndr penv name pat_ty
- ; res <- tcCheckUsage name (scaledMult pat_ty) $
+ ; res <- tcCheckUsage (Scaled (scaledMult pat_ty) id) $
tcExtendIdEnv1 name id thing_inside
; pat_ty <- readExpType (scaledThing pat_ty)
; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -1979,7 +1979,7 @@ setMainCtxt main_name io_ty thing_inside
checkConstraints skol_info [] [] $ -- Builds an implication if necessary
thing_inside -- e.g. with -fdefer-type-errors
where
- skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []
+ skol_info = SigSkol IsStatic (FunSigCtxt main_name NoRRC) io_ty []
{- Note [Dealing with main]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2635,7 +2635,7 @@ tcRnExpr hsc_env mode rdr_expr
let { fresh_it = itName uniq (getLocA rdr_expr) } ;
((qtvs, dicts, _, _), residual)
<- captureConstraints $
- simplifyInfer TopLevel tclvl infer_mode
+ simplifyInfer TopLevel IsStatic tclvl infer_mode
[] {- No sig vars -}
[(fresh_it, res_ty)]
lie ;
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -46,6 +46,8 @@ import GHC.Tc.Instance.FunDeps
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
+import GHC.Hs.Binds ( StaticFlag )
+
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.Ppr
@@ -908,7 +910,8 @@ instance Outputable InferMode where
ppr EagerDefaulting = text "EagerDefaulting"
ppr NoRestrictions = text "NoRestrictions"
-simplifyInfer :: TopLevelFlag
+simplifyInfer :: TopLevelFlag -- Syntactically top-level
+ -> StaticFlag -- Static (morally top level)
-> TcLevel -- Used when generating the constraints
-> InferMode
-> [TcIdSigInst] -- Any signatures (possibly partial)
@@ -920,7 +923,7 @@ simplifyInfer :: TopLevelFlag
TcEvBinds, -- ... binding these evidence variables
Bool) -- True <=> the residual constraints are insoluble
-simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
+simplifyInfer top_lvl static_flag rhs_tclvl infer_mode sigs name_taus wanteds
| isEmptyWC wanteds
= do { -- When quantifying, we want to preserve any order of variables as they
-- appear in partial signatures. cf. decideQuantifiedTyVars
@@ -931,7 +934,7 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)
- ; skol_info <- mkSkolemInfo (InferSkol name_taus)
+ ; skol_info <- mkSkolemInfo (InferSkol static_flag name_taus)
; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars
; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
; return (qtkvs, [], emptyTcEvBinds, False) }
@@ -992,7 +995,8 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
; bound_theta_vars <- mapM TcM.newEvVar bound_theta
; let full_theta = map idType bound_theta_vars
- skol_info = InferSkol [ (name, mkPhiTy full_theta ty)
+ skol_info = InferSkol static_flag
+ [ (name, mkPhiTy full_theta ty)
| (name, ty) <- name_taus ]
-- mkPhiTy: we don't add the quantified variables here, because
-- they are also bound in ic_skols and we want them to be tidied
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1284,7 +1284,7 @@ nestImplicTcS skol_info ev_binds_var inner_tclvl (TcS thing_inside)
-- start with a completely empty inert set; in particular, no Givens
-- See (SF3) in Note [Grand plan for static forms]
-- in GHC.Iface.Tidy.StaticPtrTable
- | StaticFormSkol <- skol_info
+ | isStaticSkolInfo skol_info
= emptyInertSet inner_tclvl
| otherwise
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -533,7 +533,7 @@ findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens
= any isImprovementPred (pred : transSuperClasses pred)
warnRedundantGivens :: SkolemInfoAnon -> Bool
-warnRedundantGivens (SigSkol ctxt _ _)
+warnRedundantGivens (SigSkol _ ctxt _ _)
= case ctxt of
FunSigCtxt _ rrc -> reportRedundantConstraints rrc
ExprSigCtxt rrc -> reportRedundantConstraints rrc
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -299,7 +299,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars [this_dict] $
- tcPolyCheck no_prag_fn local_dm_sig
+ tcPolyCheck NotStatic no_prag_fn local_dm_sig
(L bind_loc lm_bind)
; let export = ABE { abe_poly = global_dm_id
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -2121,7 +2121,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
, sig_ctxt = ctxt
, sig_loc = getLocA hs_sig_ty }
- ; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
+ ; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck NotStatic no_prag_fn inner_meth_sig meth_bind
; let export = ABE { abe_poly = local_meth_id
, abe_mono = inner_id
@@ -2146,7 +2146,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
-- instance C [c] where { op = <rhs> }
-- In <rhs>, 'c' is scope but 'b' is not!
- ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
+ ; (tc_bind, _) <- tcPolyCheck NotStatic no_prag_fn tc_sig meth_bind
; return tc_bind }
where
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -153,7 +153,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
; ((univ_tvs, req_dicts, ev_binds, _), residual)
<- captureConstraints $
- simplifyInfer TopLevel tclvl NoRestrictions [] named_taus wanted
+ simplifyInfer TopLevel IsStatic tclvl NoRestrictions [] named_taus wanted
; top_ev_binds <- checkNoErrs (simplifyTop residual)
; addTopEvBinds top_ev_binds $
@@ -392,7 +392,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
; checkTc (all (isManyTy . scaledMult) arg_tys) $
TcRnLinearPatSyn sig_body_ty
- ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty [])
+ ; skol_info <- mkSkolemInfo (SigSkol IsStatic (PatSynCtxt name) pat_ty [])
-- The type here is a bit bogus, but we do not print
-- the type for PatSynCtxt, so it doesn't matter
-- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"
@@ -980,7 +980,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
; traceTc "tcPatSynBuilderBind {" $
vcat [ ppr patsyn
, ppr builder_id <+> dcolon <+> ppr (idType builder_id) ]
- ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind)
+ ; (builder_binds, _) <- tcPolyCheck IsStatic emptyPragEnv sig (noLocA bind)
; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
; return builder_binds } } }
=====================================
compiler/GHC/Tc/Types/BasicTypes.hs
=====================================
@@ -351,7 +351,7 @@ data IdBindingInfo
= NotLetBound
| LetBound
- { lb_top :: StaticFlag
+ { lb_static :: StaticFlag
-- IsStatic <=> this binding may safely be moved to top level
-- E.g f x = let ys = reverse [1,2]
-- zs = reverse ys
@@ -369,14 +369,17 @@ data IdBindingInfo
-- all free vars of `e` have lb_clos=ClosedTypeId
}
--- | IsGroupClosed describes a group of
--- mutually-recursive /renamed/ (but not yet typechecked) bindings
+-- | IsGroupClosed describes a group of mutually-recursive /renamed/
+-- (but not yet typechecked) bindings
data IsGroupClosed
= IsGroupClosed
- StaticFlag -- IsStatic <=> all free vars of the group are top-level or static
- (NameEnv RhsNames) -- Frees for the RHS of each binding in the group
- -- (includes free vars of RHS bound in the same group)
- ClosedTypeId -- True <=> all the free vars of the group have closed types
+ { gc_static :: StaticFlag -- IsStatic <=> all free vars of the group are top-level or static
+
+ , gc_fvs :: NameEnv RhsNames -- Free vars for the RHS of each binding in the group
+ -- (includes free vars of RHS bound in the same group)
+
+ , gc_closed :: ClosedTypeId -- True <=> all the free vars of the group have closed types
+ }
type RhsNames = NameSet -- Names of variables, mentioned on the RHS of
-- a definition, that are not Global or ClosedLet
@@ -536,7 +539,7 @@ in the type environment.
instance Outputable IdBindingInfo where
ppr NotLetBound = text "NotLetBound"
- ppr (LetBound { lb_top = top_lvl, lb_fvs = fvs, lb_closed = cls })
+ ppr (LetBound { lb_static = top_lvl, lb_fvs = fvs, lb_closed = cls })
= text "LetBound" <> braces (sep [ ppr top_lvl, text "closed-type=" <+> ppr cls
, ppr fvs ])
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -1642,7 +1642,7 @@ getUserGivensFromImplics implics
get acc [] = acc
get acc (implic : implics)
- | StaticFormSkol <- ic_info implic
+ | isStaticSkolInfo (ic_info implic)
= acc -- For static forms, ignore all outer givens
-- See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
@@ -2150,7 +2150,9 @@ checkSkolInfoAnon :: SkolemInfoAnon -- From the implication
-- So it doesn't matter much if its's incomplete
checkSkolInfoAnon sk1 sk2 = go sk1 sk2
where
- go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2
+ go (SigSkol _ c1 t1 s1) (SigSkol _ c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2
+ go (InferSkol _ ids1) (InferSkol _ ids2) = equalLength ids1 ids2 &&
+ and (zipWith eq_pr ids1 ids2)
go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2
go (ForAllSkol _) (ForAllSkol _) = True
@@ -2167,8 +2169,6 @@ checkSkolInfoAnon sk1 sk2 = go sk1 sk2
go (SpecESkol n1) (SpecESkol n2) = n1==n2
go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2
-- Too tedious to compare the HsMatchContexts
- go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 &&
- and (zipWith eq_pr ids1 ids2)
go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2
go ReifySkol ReifySkol = True
go RuntimeUnkSkol RuntimeUnkSkol = True
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -15,9 +15,9 @@ module GHC.Tc.Types.Origin (
ReportRedundantConstraints(..), reportRedundantConstraints,
redundantConstraintsSpan,
- -- * SkolemInfo
+ -- * SkolemInfo, SkolemInfoAnon
SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo,
- unkSkol, unkSkolAnon,
+ unkSkol, unkSkolAnon, isStaticSkolInfo,
-- * CtOrigin
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
@@ -270,11 +270,18 @@ data SkolemInfoAnon
-- a programmer-supplied type signature
-- Location of the binding site is on the TyVar
-- See Note [SigSkol SkolemInfo]
+ StaticFlag
UserTypeCtxt -- What sort of signature
TcType -- Original type signature (before skolemisation)
[(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar
-- to its instantiated version
+ | InferSkol
+ StaticFlag
+ [(Name,TcType)] -- We have inferred a type for these (mutually recursive)
+ -- polymorphic Ids, and are now checking that their RHS
+ -- constraints are satisfied.
+
| SigTypeSkol UserTypeCtxt
-- like SigSkol, but when we're kind-checking the *type*
-- hence, we have less info
@@ -311,11 +318,6 @@ data SkolemInfoAnon
| RuleSkol RuleName -- The LHS of a RULE
| SpecESkol Name -- A SPECIALISE pragma
- | InferSkol [(Name,TcType)]
- -- We have inferred a type for these (mutually recursive)
- -- polymorphic Ids, and are now checking that their RHS
- -- constraints are satisfied.
-
| BracketSkol -- Template Haskell bracket
| UnifyForAllSkol -- We are unifying two for-all types
@@ -370,7 +372,7 @@ instance Outputable SkolemInfoAnon where
pprSkolInfo :: SkolemInfoAnon -> SDoc
-- Complete the sentence "is a rigid type variable bound by..."
-pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
+pprSkolInfo (SigSkol _ cx ty _) = pprSigSkolInfo cx ty
pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx
pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> ppr tvs
pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for"
@@ -388,7 +390,7 @@ pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name
pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name)
pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl
, text "in" <+> pprMatchContext mc ]
-pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of")
+pprSkolInfo (InferSkol _ ids) = hang (text "the inferred type" <> plural ids <+> text "of")
2 (vcat [ ppr name <+> dcolon <+> ppr ty
| (name,ty) <- ids ])
pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty
@@ -467,6 +469,13 @@ in the right place. So we proceed as follows:
the instantiated skolems lying around in other types.
-}
+isStaticSkolInfo :: SkolemInfoAnon -> Bool
+isStaticSkolInfo StaticFormSkol = True
+isStaticSkolInfo (SigSkol IsStatic _ _ _) = True
+isStaticSkolInfo (InferSkol IsStatic _) = True
+isStaticSkolInfo _ = False
+
+
{- *********************************************************************
* *
CtOrigin
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -91,7 +91,7 @@ import GHC.Iface.Load
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
-import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage )
+import GHC.Tc.Utils.TcMType ( tcCheckUsage )
import GHC.Tc.Types.LclEnv
import GHC.Core.InstEnv
@@ -675,7 +675,7 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
- , tct_info = LetBound { lb_top = NotStatic
+ , tct_info = LetBound { lb_static = NotStatic
, lb_fvs = emptyNameSet
, lb_closed = False } })
| (name, let_id) <- pairs ] $
@@ -691,7 +691,7 @@ tcExtendSigIds top_lvl sig_ids thing_inside
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
- info = LetBound { lb_top = NotStatic
+ info = LetBound { lb_static = NotStatic
, lb_fvs = emptyNameSet
, lb_closed = closed } ]
thing_inside
@@ -703,25 +703,21 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-- Used for both top-level value bindings and nested let/where-bindings
-- Used for a single NonRec or a single Rec
-- Adds to the TcBinderStack too
-tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_static fv_env _)
+tcExtendLetEnv top_lvl _sig_fn
+ (IsGroupClosed {gc_static = group_static, gc_fvs = fv_env})
ids thing_inside
= tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $
tc_extend_local_env top_lvl
[ (idName id, ATcId { tct_id = id
, tct_info = mk_tct_info id })
| Scaled _ id <- ids ] $
- foldr check_usage thing_inside scaled_names
+ foldr tcCheckUsage thing_inside ids
where
mk_tct_info id
- = LetBound { lb_top = group_static
+ = LetBound { lb_static = group_static
, lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet
, lb_closed = isTypeClosedLetBndr id }
- scaled_names = [Scaled p (idName id) | Scaled p id <- ids ]
-
- check_usage :: Scaled Name -> TcM a -> TcM a
- check_usage (Scaled p id) thing_inside = tcCheckUsage id p thing_inside
-
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-- For lambda-bound and case-bound Ids
-- Extends the TcBinderStack as well
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -2227,13 +2227,15 @@ a \/\a in the final result but all the occurrences of a will be zonked to ()
-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the
-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the
-- usage environment.
-tcCheckUsage :: Name -> Mult -> TcM a -> TcM a
-tcCheckUsage name id_mult thing_inside
+tcCheckUsage :: Scaled TcId -> TcM a -> TcM a
+tcCheckUsage (Scaled id_mult id) thing_inside
= do { (local_usage, result) <- tcCollectingUsage thing_inside
; check_usage (lookupUE local_usage name)
; tcEmitBindingUsage (deleteUE local_usage name)
; return result }
where
+ name = idName id
+
check_usage :: Usage -> TcM ()
-- Checks that the usage of the newly introduced binder is compatible with
-- its multiplicity.
=====================================
compiler/GHC/Tc/Utils/TcMType.hs-boot deleted
=====================================
@@ -1,7 +0,0 @@
-module GHC.Tc.Utils.TcMType where
-
-import GHC.Tc.Types
-import GHC.Types.Name
-import GHC.Core.TyCo.Rep
-
-tcCheckUsage :: Name -> Mult -> TcM a -> TcM a
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -421,6 +421,7 @@ Some examples:
tcSkolemiseGeneral
:: DeepSubsumptionFlag
+ -> StaticFlag
-> UserTypeCtxt
-> TcType -> TcType -- top_ty and expected_ty
-- Here, top_ty is the type we started to skolemise; used only in SigSkol
@@ -429,11 +430,11 @@ tcSkolemiseGeneral
-- keeping the same top_ty, but successively smaller expected_tys
-> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result)
-> TcM (HsWrapper, result)
-tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside
+tcSkolemiseGeneral ds_flag static_flag ctxt top_ty expected_ty thing_inside
| isRhoTyDS ds_flag expected_ty
-- Fast path for a very very common case: no skolemisation to do
-- But still call checkConstraints in case we need an implication regardless
- = do { let sig_skol = SigSkol ctxt top_ty []
+ = do { let sig_skol = SigSkol static_flag ctxt top_ty []
; (ev_binds, result) <- checkConstraints sig_skol [] [] $
thing_inside [] expected_ty
; return (mkWpLet ev_binds, result) }
@@ -444,7 +445,7 @@ tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside
; rec { (wrap, tv_prs, given, rho_ty) <- case ds_flag of
Deep -> deeplySkolemise skol_info expected_ty
Shallow -> topSkolemise skol_info expected_ty
- ; let sig_skol = SigSkol ctxt top_ty (map (fmap binderVar) tv_prs)
+ ; let sig_skol = SigSkol static_flag ctxt top_ty (map (fmap binderVar) tv_prs)
; skol_info <- mkSkolemInfo sig_skol }
; let skol_tvs = map (binderVar . snd) tv_prs
@@ -457,6 +458,7 @@ tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside
-- often empty, in which case mkWpLet is a no-op
tcSkolemiseCompleteSig :: TcCompleteSig
+ -> StaticFlag
-> ([ExpPatType] -> TcRhoType -> TcM result)
-> TcM (HsWrapper, result)
-- ^ The wrapper has type: spec_ty ~> expected_ty
@@ -464,11 +466,11 @@ tcSkolemiseCompleteSig :: TcCompleteSig
-- tcSkolemiseCompleteSig and tcTopSkolemise
tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = loc })
- thing_inside
+ static_flag thing_inside
= do { cur_loc <- getSrcSpanM
; let poly_ty = idType poly_id
; setSrcSpan loc $ -- Sets the location for the implication constraint
- tcSkolemiseGeneral Shallow ctxt poly_ty poly_ty $ \tv_prs rho_ty ->
+ tcSkolemiseGeneral Shallow static_flag ctxt poly_ty poly_ty $ \tv_prs rho_ty ->
setSrcSpan cur_loc $ -- Revert to the original location
tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $
thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty }
@@ -482,14 +484,14 @@ tcSkolemiseExpectedType :: TcSigmaType
-- In the call (f e) we will call tcSkolemiseExpectedType on (forall a.blah)
-- before typececking `e`
tcSkolemiseExpectedType exp_ty thing_inside
- = tcSkolemiseGeneral Shallow GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty ->
+ = tcSkolemiseGeneral Shallow NotStatic GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty ->
thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty
tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType
-> (TcRhoType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise ds_flag ctxt expected_ty thing_inside
- = tcSkolemiseGeneral ds_flag ctxt expected_ty expected_ty $ \_ rho_ty ->
+ = tcSkolemiseGeneral ds_flag NotStatic ctxt expected_ty expected_ty $ \_ rho_ty ->
thing_inside rho_ty
checkConstraints :: SkolemInfoAnon
@@ -584,6 +586,7 @@ implicationNeeded skol_info skol_tvs given
alwaysBuildImplication :: SkolemInfoAnon -> Bool
-- See Note [When to build an implication]
+alwaysBuildImplication (SigSkol IsStatic _ _ _) = True
alwaysBuildImplication _ = False
{- Commmented out for now while I figure out about error messages.
@@ -829,7 +832,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
| isSigmaTy ty -- An invisible quantifier at the top
|| (n_req > 0 && isForAllTy ty) -- A visible quantifier at top, and we need it
= do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty
- ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs)
+ ; let sig_skol = SigSkol NotStatic ctx top_ty (tv_nms `zip` skol_tvs)
skol_tvs = binderVars bndrs
; skol_info <- mkSkolemInfo sig_skol }
-- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
@@ -854,7 +857,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
; case ds_flag of
Shallow -> do { res <- thing_inside pat_tys (mkCheckExpType rho_ty)
; return (idHsWrapper, res) }
- Deep -> tcSkolemiseGeneral Deep ctx top_ty rho_ty $ \_ rho_ty ->
+ Deep -> tcSkolemiseGeneral Deep NotStatic ctx top_ty rho_ty $ \_ rho_ty ->
-- "_" drop the /deeply/-skolemise binders
-- They do not line up with binders in the Match
thing_inside pat_tys (mkCheckExpType rho_ty) }
@@ -2054,7 +2057,7 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected
arg_wrap res_wrap
}
where
- given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])
+ given_orig = GivenOrigin (SigSkol NotStatic GenSigCtxt exp_arg [])
-- | Like 'mkWpFun', except that it performs the necessary
-- representation-polymorphism checks on the argument type in the case that
=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -521,10 +521,10 @@ zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo
zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk
zonkSkolemInfoAnon :: SkolemInfoAnon -> ZonkM SkolemInfoAnon
-zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty
- ; return (SigSkol cx ty' tv_prs) }
-zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys
- ; return (InferSkol ntys') }
+zonkSkolemInfoAnon (SigSkol st cx ty tv_prs) = do { ty' <- zonkTcType ty
+ ; return (SigSkol st cx ty' tv_prs) }
+zonkSkolemInfoAnon (InferSkol st ntys) = do { ntys' <- mapM do_one ntys
+ ; return (InferSkol st ntys') }
where
do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
zonkSkolemInfoAnon skol_info = return skol_info
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b0c10d66f4576bd6cf0313a5838731…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b0c10d66f4576bd6cf0313a5838731…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Fix a horrible shadowing bug in implicit parameters
by Marge Bot (＠marge-bot) 07 Nov '25
by Marge Bot (＠marge-bot) 07 Nov '25
07 Nov '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- + testsuite/tests/typecheck/should_compile/T26451.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -263,7 +263,9 @@ in two places:
* In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
existing [G] (?x :: ty'), regardless of ty'.
-* Wrinkle (SIP1): we must be careful of superclasses. Consider
+There are wrinkles:
+
+* Wrinkle (SIP1): we must be careful of superclasses (#14218). Consider
f,g :: (?x::Int, C a) => a -> a
f v = let ?x = 4 in g v
@@ -271,24 +273,31 @@ in two places:
We must /not/ solve this from the Given (?x::Int, C a), because of
the intervening binding for (?x::Int). #14218.
- We deal with this by arranging that when we add [G] (?x::ty) we delete
+ We deal with this by arranging that when we add [G] (?x::ty) we /delete/
* from the inert_cans, and
* from the inert_solved_dicts
any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate.
- An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
- But it could happen for `class xx => D xx where ...` and the constraint D
- (?x :: int). This corner (constraint-kinded variables instantiated with
- implicit parameter constraints) is not well explored.
+ An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
+
+ But it could also happen for `class xx => D xx where ...` and the constraint
+ D (?x :: int); again see Note [Local implicit parameters]. This corner
+ (constraint-kinded variables instantiated with implicit parameter constraints)
+ is not well explored.
- Example in #14218, and #23761
+ You might worry about whether deleting an /entire/ constraint just because
+ a distant superclass has an implicit parameter might make another Wanted for
+ that constraint un-solvable. Indeed so. But for constraint tuples it doesn't
+ matter -- their entire payload is their superclasses. And the other case is
+ the ill-explored corner above.
The code that accounts for (SIP1) is in updInertDicts; in particular the call to
GHC.Core.Predicate.mentionsIP.
* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
- as well as `inert_cans`.
+ as well as `inert_cans` (#23761).
+
You might think that wouldn't be necessary, because an element of
`inert_solved_dicts` is never an implicit parameter (see
Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
@@ -301,6 +310,19 @@ in two places:
Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
+* Wrinkle (SIP3)
+ - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
+ existing /Givens/! Deleting an existing Wanted led to #26451; we just never
+ solved it!
+
+ - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
+ Givens; they may be "inherited" from outer scopes, so we must delete any
+ solved dictionaries for this implicit parameter for /both/ Givens /and/
+ Wanteds.
+
+ Otherwise the new Given doesn't properly shadow those inherited solved
+ dictionaries. Test T23761 showed this up.
+
Example 1:
Suppose we have (typecheck/should_compile/ImplicitParamFDs)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict.
-}
updInertDicts :: DictCt -> TcS ()
-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
- = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
-
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
- -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
- -- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
- -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
- updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
- | otherwise
- -> return ()
+updInertDicts dict_ct
+ = do { traceTcS "Adding inert dict" (ppr dict_ct)
+
+ -- For Given implicit parameters (only), delete any existing
+ -- Givens for the same implicit parameter.
+ -- See Note [Shadowing of implicit parameters]
+ ; deleteGivenIPs dict_ct
+
-- Add the new constraint to the inert set
; updInertCans (updDicts (addDict dict_ct)) }
+
+deleteGivenIPs :: DictCt -> TcS ()
+-- Special magic when adding a Given implicit parameter to the inert set
+-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
+-- from /both/ inert_cans /and/ inert_solved_dicts (#23761)
+-- See Note [Shadowing of implicit parameters]
+deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ | isGiven ev
+ , Just (str_ty, _) <- isIPPred_maybe cls tys
+ = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
+ inerts { inert_cans = updDicts (filterDicts (keep_can str_ty)) ics
+ , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
+ | otherwise
+ = return ()
where
- -- Does this class constraint or any of its superclasses mention
- -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
- does_not_mention_ip_for :: Type -> DictCt -> Bool
- does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mightMentionIP]
- -- in GHC.Core.Predicate
+ keep_can, keep_solved :: Type -> DictCt -> Bool
+ -- keep_can: we keep an inert dictionary UNLESS
+ -- (1) it is a Given
+ -- (2) it binds an implicit parameter (?str :: ty) for the given 'str'
+ -- regardless of 'ty', possibly via its superclasses
+ -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
+ -- See Note [Using typesAreApart when calling mightMentionIP]
+ -- in GHC.Core.Predicate
+ --
+ -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
+ --
+ -- Why two functions? See (SIP3) in Note [Shadowing of implicit parameters]
+ keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
+ = not (isGiven ev -- (1)
+ && mentions_ip str cls tys) -- (2)
+ keep_solved str (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentions_ip str cls tys)
+
+ -- mentions_ip: the inert constraint might provide evidence
+ -- for an implicit parameter (?str :: ty) for the given 'str'
+ mentions_ip str cls tys
+ = mightMentionIP (not . typesAreApart str) (const True) cls tys
updInertIrreds :: IrredCt -> TcS ()
updInertIrreds irred
=====================================
testsuite/tests/typecheck/should_compile/T26451.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
+
+module T26451 where
+
+type family F a
+type instance F Bool = [Char]
+
+class C a b | b -> a
+instance C Bool Bool
+instance C Char Char
+
+eq :: forall a b. C a b => a -> b -> ()
+eq p q = ()
+
+g :: a -> F a
+g = g
+
+f (x::tx) (y::ty) -- x :: alpha y :: beta
+ = let ?v = g x -- ?ip :: F alpha
+ in (?v::[ty], eq x True)
+
+
+{- tx, and ty are unification variables
+
+Inert: [G] dg :: IP "v" (F tx)
+ [W] dw :: IP "v" [ty]
+Work-list: [W] dc1 :: C tx Bool
+ [W] dc2 :: C ty Char
+
+* Solve dc1, we get tx := Bool from fundep
+* Kick out dg
+* Solve dg to get [G] dc : IP "v" [Char]
+* Add that new dg to the inert set: that simply deletes dw!!!
+-}
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -955,3 +955,4 @@ test('T26376', normal, compile, [''])
test('T26457', normal, compile, [''])
test('T17705', normal, compile, [''])
test('T14745', normal, compile, [''])
+test('T26451', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c052c724d2dfc994994b65485458369…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c052c724d2dfc994994b65485458369…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Correct hasFixedRuntimeRep in matchExpectedFunTys
by Marge Bot (＠marge-bot) 07 Nov '25
by Marge Bot (＠marge-bot) 07 Nov '25
07 Nov '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
93fc7265 by sheaf at 2025-11-06T21:33:24-05:00
Correct hasFixedRuntimeRep in matchExpectedFunTys
This commit fixes a bug in the representation-polymormorphism check in
GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put
the coercion resulting from hasFixedRuntimeRep in the wrong place,
leading to the Core Lint error reported in #26528.
The change is that we have to be careful when using 'mkWpFun': it
expects **both** the expected and actual argument types to have a
syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT]
in GHC.Tc.Types.Evidence.
On the way, this patch improves some of the commentary relating to
other usages of 'mkWpFun' in the compiler, in particular in the view
pattern case of 'tc_pat'. No functional changes, but some stylistic
changes to make the code more readable, and make it easier to understand
how we are upholding the WpFun-FRR-INVARIANT.
Fixes #26528
- - - - -
7 changed files:
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Unify.hs
- + testsuite/tests/rep-poly/T26528.hs
- testsuite/tests/rep-poly/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin
-> SyntaxOpType -- ^ shape it is expected to have
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
-> TcM (a, HsWrapper)
- -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
+ -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in)
tcSynArgE orig op sigma_ty syn_ty thing_inside
= do { (skol_wrap, (result, ty_wrapper))
<- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty ->
@@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside
; return (result, mkWpCastN list_co) }
go rho_ty (SynFun arg_shape res_shape)
- = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
+ = do { ( match_wrapper -- :: (arg_ty -> res_ty) ~~> rho_ty
, ( ( (result, arg_ty, res_ty, op_mult)
- , res_wrapper ) -- :: res_ty_out "->" res_ty
- , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out
+ , res_wrapper ) -- :: res_ty_out ~~> res_ty
+ , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty ~~> arg_ty_out
<- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
\ [ExpFunPatTy arg_ty] res_ty ->
do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
@@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin
tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
<- matchActualFunTys herald orig (length arg_shapes) sigma_ty
- -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
+ -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty)
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
tc_syn_arg res_ty res_shape $ \ res_results ->
@@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
; return (result, idHsWrapper) }
tc_syn_arg res_ty SynRho thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
- -- inst_wrap :: res_ty "->" rho_ty
+ -- inst_wrap :: res_ty ~~> rho_ty
; result <- thing_inside [rho_ty]
; return (result, inst_wrap) }
tc_syn_arg res_ty SynList thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
- -- inst_wrap :: res_ty "->" rho_ty
+ -- inst_wrap :: res_ty ~~> rho_ty
; (list_co, elt_ty) <- matchExpectedListTy rho_ty
-- list_co :: [elt_ty] ~N rho_ty
; result <- thing_inside [elt_ty]
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
-- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
| Just bndr_id <- sig_fn bndr_name -- There is a signature
- = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
+ = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id)
-- See Note [Subsumption check at pattern variables]
; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
; return (wrap, bndr_id) }
@@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty
newLetBndr (LetGblBndr prags) name w ty
= addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
-tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
--- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
--- Used during typechecking patterns
-tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
+-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'.
+--
+-- Used during typechecking of patterns.
+tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+tcSubTypePat_GenSigCtxt penv t1 t2 =
+ tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
{- Note [Subsumption check at pattern variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -618,111 +620,123 @@ tc_pat :: Scaled ExpSigmaTypeFRR
-> Checker (Pat GhcRn) (Pat GhcTc)
-- ^ Translated pattern
-tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-
- VarPat x (L l name) -> do
- { (wrap, id) <- tcPatBndr penv name pat_ty
- ; res <- tcCheckUsage name (scaledMult pat_ty) $
- tcExtendIdEnv1 name id thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
-
- ParPat x pat -> do
- { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
- ; return (ParPat x pat', res) }
-
- BangPat x pat -> do
- { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
- ; return (BangPat x pat', res) }
-
- OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
- { let pats_list = NE.toList pats
- ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
- ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
- ; emitConstraints pat_ct
- -- captureConstraints/extendConstraints:
- -- like in Note [Hopping the LIE in lazy patterns]
- ; pat_ty <- expTypeToType (scaledThing pat_ty)
- ; return (OrPat pat_ty pats', res) }
-
- LazyPat x pat -> do
- { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
- ; (pat', (res, pat_ct))
- <- tc_lpat pat_ty (makeLazy penv) pat $
- captureConstraints thing_inside
- -- Ignore refined penv', revert to penv
-
- ; emitConstraints pat_ct
- -- captureConstraints/extendConstraints:
- -- see Note [Hopping the LIE in lazy patterns]
-
- -- Check that the expected pattern type is itself lifted
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
-
- ; return ((LazyPat x pat'), res) }
-
- WildPat _ -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; res <- thing_inside
- ; pat_ty <- expTypeToType (scaledThing pat_ty)
- ; return (WildPat pat_ty, res) }
-
- AsPat x (L nm_loc name) pat -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
- ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
- tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
- penv pat thing_inside
- -- NB: if we do inference on:
- -- \ (y@(x::forall a. a->a)) = e
- -- we'll fail. The as-pattern infers a monotype for 'y', which then
- -- fails to unify with the polymorphic type for 'x'. This could
- -- perhaps be fixed, but only with a bit more work.
- --
- -- If you fix it, don't forget the bindInstsOfPatIds!
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
-
- ViewPat _ expr pat -> do
- { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
- --
- -- It should be possible to have view patterns at linear (or otherwise
- -- non-Many) multiplicity. But it is not clear at the moment what
- -- restriction need to be put in place, if any, for linear view
- -- patterns to desugar to type-correct Core.
-
- ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr
- -- IIF_ShallowRho: do not perform deep instantiation, regardless of
- -- DeepSubsumption (Note [View patterns and polymorphism])
- -- But we must do top-instantiation to expose the arrow to matchActualFunTy
-
- -- Expression must be a function
- ; let herald = ExpectedFunTyViewPat $ unLoc expr
- ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
- <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
- -- See Note [View patterns and polymorphism]
- -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
-
- -- Check that overall pattern is more polymorphic than arg type
- ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
- -- expr_wrap2 :: pat_ty "->" inf_arg_ty
-
- -- Pattern must have inf_res_sigma
- ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
-
- ; let Scaled w h_pat_ty = pat_ty
- ; pat_ty <- readExpType h_pat_ty
- ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
- (Scaled w pat_ty) inf_res_sigma
- -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
- -- (pat_ty -> inf_res_sigma)
- -- NB: pat_ty comes from matchActualFunTy, so it has a
- -- fixed RuntimeRep, as needed to call mkWpFun.
-
- expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
-
- ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
+tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
+
+ case ps_pat of
+
+ VarPat x (L l name) -> do
+ { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty
+ ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
+
+ ParPat x pat -> do
+ { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
+ ; return (ParPat x pat', res) }
+
+ BangPat x pat -> do
+ { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
+ ; return (BangPat x pat', res) }
+
+ OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
+ { let pats_list = NE.toList pats
+ pat_exp_tys = map (const scaled_exp_pat_ty) pats_list
+ ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside)
+ ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- like in Note [Hopping the LIE in lazy patterns]
+ ; pat_ty <- expTypeToType exp_pat_ty
+ ; return (OrPat pat_ty pats', res) }
+
+ LazyPat x pat -> do
+ { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; (pat', (res, pat_ct))
+ <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $
+ captureConstraints thing_inside
+ -- Ignore refined penv', revert to penv
+
+ ; emitConstraints pat_ct
+ -- captureConstraints/extendConstraints:
+ -- see Note [Hopping the LIE in lazy patterns]
+
+ -- Check that the expected pattern type is itself lifted
+ ; pat_ty <- readExpType exp_pat_ty
+ ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
+
+ ; return ((LazyPat x pat'), res) }
+
+ WildPat _ -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; res <- thing_inside
+ ; pat_ty <- expTypeToType exp_pat_ty
+ ; return (WildPat pat_ty, res) }
+
+ AsPat x (L nm_loc name) pat -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty)
+ ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+ tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id))
+ penv pat thing_inside
+ -- NB: if we do inference on:
+ -- \ (y@(x::forall a. a->a)) = e
+ -- we'll fail. The as-pattern infers a monotype for 'y', which then
+ -- fails to unify with the polymorphic type for 'x'. This could
+ -- perhaps be fixed, but only with a bit more work.
+ --
+ -- If you fix it, don't forget the bindInstsOfPatIds!
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
+
+ ViewPat _ view_expr inner_pat -> do
+
+ -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'.
+ -- First infer the type of 'view_expr'; the overall type of the pattern
+ -- is the argument type of 'view_expr', and the inner pattern type is
+ -- checked against the result type of 'view_expr'.
+
+ { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ -- It should be possible to have view patterns at linear (or otherwise
+ -- non-Many) multiplicity. But it is not clear at the moment what
+ -- restrictions need to be put in place, if any, for linear view
+ -- patterns to desugar to type-correct Core.
+
+ -- Infer the type of 'view_expr'.
+ ; (view_expr', view_expr_rho) <- tcInferExpr IIF_ShallowRho view_expr
+ -- IIF_ShallowRho: do not perform deep instantiation, regardless of
+ -- DeepSubsumption (Note [View patterns and polymorphism])
+ -- But we must do top-instantiation to expose the arrow to matchActualFunTy
+
+ -- 'view_expr' must be a function; expose its argument/result types
+ -- using 'matchActualFunTy'.
+ ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
+ ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
+ <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
+ (1, view_expr_rho) view_expr_rho
+ -- See Note [View patterns and polymorphism]
+ -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty)
+
+ -- Check that the overall pattern's type is more polymorphic than
+ -- the view function argument type.
+ ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty
+ -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty
+
+ -- The inner pattern must have type 'view_res_ty'.
+ ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside
+
+ ; pat_ty <- readExpType exp_pat_ty
+ ; let view_expr_wrap2' =
+ mkWpFun view_expr_wrap2 idHsWrapper
+ (Scaled w_pat pat_ty) view_res_ty
+ -- view_expr_wrap2' :: (view_arg_ty -> view_res_ty)
+ -- ~~> (pat_ty -> view_res_ty)
+ -- This satisfies WpFun-FRR-INVARIANT:
+ -- 'view_arg_ty' was returned by matchActualFunTy, hence FRR
+ -- 'pat_ty' was passed in and is an 'ExpSigmaTypeFRR'
+
+ view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1
+
+ ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) }
{- Note [View patterns and polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -748,93 +762,91 @@ Another example is #26331.
-- Type signatures in patterns
-- See Note [Pattern coercions] below
- SigPat _ pat sig_ty -> do
- { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
- sig_ty (scaledThing pat_ty)
- -- Using tcExtendNameTyVarEnv is appropriate here
- -- because we're not really bringing fresh tyvars into scope.
- -- We're *naming* existing tyvars. Note that it is OK for a tyvar
- -- from an outer scope to mention one of these tyvars in its kind.
- ; (pat', res) <- tcExtendNameTyVarEnv wcs $
- tcExtendNameTyVarEnv tv_binds $
- tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
+ SigPat _ pat sig_ty -> do
+ { (inner_ty, tv_binds, wcs, wrap) <-
+ tcPatSig (inPatBind penv) sig_ty exp_pat_ty
+ -- Using tcExtendNameTyVarEnv is appropriate here
+ -- because we're not really bringing fresh tyvars into scope.
+ -- We're *naming* existing tyvars. Note that it is OK for a tyvar
+ -- from an outer scope to mention one of these tyvars in its kind.
+ ; (pat', res) <- tcExtendNameTyVarEnv wcs $
+ tcExtendNameTyVarEnv tv_binds $
+ tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
------------------------
-- Lists, tuples, arrays
-- Necessarily a built-in list pattern, not an overloaded list pattern.
-- See Note [Desugaring overloaded list patterns].
- ListPat _ pats -> do
- { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
- ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
- penv pats thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat coi
- (ListPat elt_ty pats') pat_ty, res) }
-
- TuplePat _ pats boxity -> do
- { let arity = length pats
- tc = tupleTyCon boxity arity
- -- NB: tupleTyCon does not flatten 1-tuples
- -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
- ; checkTupSize arity
- ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
- penv (scaledThing pat_ty)
- -- Unboxed tuples have RuntimeRep vars, which we discard:
- -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
- ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
- Boxed -> arg_tys
- ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
+ ListPat _ pats -> do
+ { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty
+ ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty))
penv pats thing_inside
-
- ; dflags <- getDynFlags
-
- -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
- -- so that we can experiment with lazy tuple-matching.
- -- This is a pretty odd place to make the switch, but
- -- it was easy to do.
- ; let
- unmangled_result = TuplePat con_arg_tys pats' boxity
- -- pat_ty /= pat_ty iff coi /= IdCo
- possibly_mangled_result
- | gopt Opt_IrrefutableTuples dflags &&
- isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
- | otherwise = unmangled_result
-
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
- ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
- }
-
- SumPat _ pat alt arity -> do
- { let tc = sumTyCon arity
- ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
- penv (scaledThing pat_ty)
- ; -- Drop levity vars, we don't care about them here
- let con_arg_tys = drop arity arg_tys
- ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
- penv pat thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
- , res)
- }
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat coi
+ (ListPat elt_ty pats') pat_ty, res) }
+
+ TuplePat _ pats boxity -> do
+ { let arity = length pats
+ tc = tupleTyCon boxity arity
+ -- NB: tupleTyCon does not flatten 1-tuples
+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
+ ; checkTupSize arity
+ ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
+ -- Unboxed tuples have RuntimeRep vars, which we discard:
+ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
+ ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
+ Boxed -> arg_tys
+ ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys)
+ penv pats thing_inside
+
+ ; dflags <- getDynFlags
+
+ -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
+ -- so that we can experiment with lazy tuple-matching.
+ -- This is a pretty odd place to make the switch, but
+ -- it was easy to do.
+ ; let
+ unmangled_result = TuplePat con_arg_tys pats' boxity
+ -- pat_ty /= pat_ty iff coi /= IdCo
+ possibly_mangled_result
+ | gopt Opt_IrrefutableTuples dflags &&
+ isBoxed boxity = LazyPat noExtField (noLocA unmangled_result)
+ | otherwise = unmangled_result
+
+ ; pat_ty <- readExpType exp_pat_ty
+ ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
+ ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
+ }
+
+ SumPat _ pat alt arity -> do
+ { let tc = sumTyCon arity
+ ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
+ ; -- Drop levity vars, we don't care about them here
+ let con_arg_tys = drop arity arg_tys
+ ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+ penv pat thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+ , res)
+ }
------------------------
-- Data constructors
- ConPat _ con arg_pats ->
- tcConPat penv con pat_ty arg_pats thing_inside
+ ConPat _ con arg_pats ->
+ tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside
------------------------
-- Literal patterns
- LitPat x simple_lit -> do
- { let lit_ty = hsLitType simple_lit
- ; wrap <- tc_sub_type penv (scaledThing pat_ty) lit_ty
- ; res <- thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
- , res) }
+ LitPat x simple_lit -> do
+ { let lit_ty = hsLitType simple_lit
+ ; wrap <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty
+ ; res <- thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
+ , res) }
------------------------
-- Overloaded patterns: n, and n+k
@@ -854,31 +866,31 @@ Another example is #26331.
-- where lit_ty is the type of the overloaded literal 5.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
- NPat _ (L l over_lit) mb_neg eq -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- -- It may be possible to refine linear pattern so that they work in
- -- linear environments. But it is not clear how useful this is.
- ; let orig = LiteralOrigin over_lit
- ; ((lit', mb_neg'), eq')
- <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
- (mkCheckExpType boolTy) $
- \ [neg_lit_ty] _ ->
- let new_over_lit lit_ty = newOverloadedLit over_lit
- (mkCheckExpType lit_ty)
- in case mb_neg of
- Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
- Just neg -> -- Negative literal
- -- The 'negate' is re-mappable syntax
- second Just <$>
- (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
- \ [lit_ty] _ -> new_over_lit lit_ty)
- -- applied to a closed literal: linearity doesn't matter as
- -- literals are typed in an empty environment, hence have
- -- all multiplicities.
-
- ; res <- thing_inside
- ; pat_ty <- readExpType (scaledThing pat_ty)
- ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
+ NPat _ (L l over_lit) mb_neg eq -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ -- It may be possible to refine linear pattern so that they work in
+ -- linear environments. But it is not clear how useful this is.
+ ; let orig = LiteralOrigin over_lit
+ ; ((lit', mb_neg'), eq')
+ <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny]
+ (mkCheckExpType boolTy) $
+ \ [neg_lit_ty] _ ->
+ let new_over_lit lit_ty = newOverloadedLit over_lit
+ (mkCheckExpType lit_ty)
+ in case mb_neg of
+ Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ second Just <$>
+ (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
+ \ [lit_ty] _ -> new_over_lit lit_ty)
+ -- applied to a closed literal: linearity doesn't matter as
+ -- literals are typed in an empty environment, hence have
+ -- all multiplicities.
+
+ ; res <- thing_inside
+ ; pat_ty <- readExpType exp_pat_ty
+ ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
{-
Note [NPlusK patterns]
@@ -904,68 +916,67 @@ AST is used for the subtraction operation.
-}
-- See Note [NPlusK patterns]
- NPlusKPat _ (L nm_loc name)
- (L loc lit) _ ge minus -> do
- { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
- ; let pat_exp_ty = scaledThing pat_ty
- orig = LiteralOrigin lit
- ; (lit1', ge')
- <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
- (mkCheckExpType boolTy) $
- \ [lit1_ty] _ ->
- newOverloadedLit lit (mkCheckExpType lit1_ty)
- ; ((lit2', minus_wrap, bndr_id), minus')
- <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
- \ [lit2_ty, var_ty] _ ->
- do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
- tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
- -- co :: var_ty ~ idType bndr_id
-
- -- minus_wrap is applicable to minus'
- ; return (lit2', wrap, bndr_id) }
-
- ; pat_ty <- readExpType pat_exp_ty
-
- -- The Report says that n+k patterns must be in Integral
- -- but it's silly to insist on this in the RebindableSyntax case
- ; unlessM (xoptM LangExt.RebindableSyntax) $
- do { icls <- tcLookupClass integralClassName
- ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
-
- ; res <- tcExtendIdEnv1 name bndr_id thing_inside
-
- ; let minus'' = case minus' of
- NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
- -- this should be statically avoidable
- -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
- SyntaxExprTc { syn_expr = minus'_expr
- , syn_arg_wraps = minus'_arg_wraps
- , syn_res_wrap = minus'_res_wrap }
- -> SyntaxExprTc { syn_expr = minus'_expr
- , syn_arg_wraps = minus'_arg_wraps
- , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
- -- Oy. This should really be a record update, but
- -- we get warnings if we try. #17783
- pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
- ge' minus''
- ; return (pat', res) }
+ NPlusKPat _ (L nm_loc name)
+ (L loc lit) _ ge minus -> do
+ { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
+ ; let orig = LiteralOrigin lit
+ ; (lit1', ge')
+ <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho]
+ (mkCheckExpType boolTy) $
+ \ [lit1_ty] _ ->
+ newOverloadedLit lit (mkCheckExpType lit1_ty)
+ ; ((lit2', minus_wrap, bndr_id), minus')
+ <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $
+ \ [lit2_ty, var_ty] _ ->
+ do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
+ ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
+ tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
+ -- co :: var_ty ~ idType bndr_id
+
+ -- minus_wrap is applicable to minus'
+ ; return (lit2', wrap, bndr_id) }
+
+ ; pat_ty <- readExpType exp_pat_ty
+
+ -- The Report says that n+k patterns must be in Integral
+ -- but it's silly to insist on this in the RebindableSyntax case
+ ; unlessM (xoptM LangExt.RebindableSyntax) $
+ do { icls <- tcLookupClass integralClassName
+ ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
+
+ ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+
+ ; let minus'' = case minus' of
+ NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
+ -- this should be statically avoidable
+ -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
+ SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus'_res_wrap }
+ -> SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
+ -- Oy. This should really be a record update, but
+ -- we get warnings if we try. #17783
+ pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
+ ge' minus''
+ ; return (pat', res) }
-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
- SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
+ SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
{ addModFinalizersWithLclEnv mod_finalizers
- ; tc_pat pat_ty penv pat thing_inside }
+ ; tc_pat scaled_exp_pat_ty penv pat thing_inside }
- SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
+ SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
- EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
+ EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
- InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
+ InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
- XPat (HsPatExpanded lpat rpat) -> do
- { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
- ; return (XPat $ ExpansionPat lpat rpat', res) }
+ XPat (HsPatExpanded lpat rpat) -> do
+ { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside
+ ; return (XPat $ ExpansionPat lpat rpat', res) }
{-
Note [Hopping the LIE in lazy patterns]
@@ -1295,7 +1306,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats
- ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
+ ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty'
; traceTc "tcPatSynPat" $
vcat [ text "Pat syn:" <+> ppr pat_syn
@@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv
-- In the case of a data family, this would
-- mention the /family/ TyCon
-> TcM (HsWrapper, [TcSigmaType])
--- See Note [Matching constructor patterns]
--- Returns a wrapper : pat_ty "->" T ty1 ... tyn
+-- ^ See Note [Matching constructor patterns]
+--
+-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn
matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
| Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-- Comments refer to Note [Matching constructor patterns]
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -197,29 +197,29 @@ that it is a no-op. Here's our solution:
* we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
* there is little point in attempting to optimise any other HsWrappers
-Note [WpFun-RR-INVARIANT]
-~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [WpFun-FRR-INVARIANT]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
Given
wrap = WpFun wrap1 wrap2 sty1 ty2
where: wrap1 :: exp_arg ~~> act_arg
wrap2 :: act_res ~~> exp_res
wrap :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
we have
- WpFun-RR-INVARIANT:
+ WpFun-FRR-INVARIANT:
the input (exp_arg) and output (act_arg) types of `wrap1`
both have a fixed runtime-rep
Reason: We desugar wrap[e] into
\(x:exp_arg). wrap2[ e wrap1[x] ]
-And then, because of Note [Representation polymorphism invariants], we need:
+And then, because of Note [Representation polymorphism invariants]:
* `exp_arg` must have a fixed runtime rep,
so that lambda obeys the the FRR rules
* `act_arg` must have a fixed runtime rep,
- so the that application (e wrap1[x]) obeys the FRR tules
+ so that the application (e wrap1[x]) obeys the FRR rules
-Hence WpFun-INVARIANT.
+Hence WpFun-FRR-INVARIANT.
-}
data HsWrapper
@@ -246,7 +246,7 @@ data HsWrapper
-- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
--
-- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
- -- See Note [WpFun-RR-INVARIANT]
+ -- See Note [WpFun-FRR-INVARIANT]
--
-- Typing rules:
-- If e :: act_arg -> act_res
@@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper
-- ^ Smart constructor for `WpFun`
-- Just removes clutter and optimises some common cases.
--
--- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
+-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT]
--
-- Unfortunately, we can't check PRECONDITION with an assertion here, because of
-- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- Instantiate outer invisible binders (both Inferred and Specified)
-- If top_instantiate ty = (wrap, inner_ty)
--- then wrap :: inner_ty "->" ty
+-- then wrap :: inner_ty ~~> ty
-- NB: returns a type with no (=>),
-- and no invisible forall at the top
topInstantiate orig sigma
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify (
import GHC.Prelude
import GHC.Hs
-
import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )
import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg )
import GHC.Tc.Utils.Concrete
@@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
-- and res_ty is a RhoType
-- NB: the returned type is top-instantiated; it's a RhoType
matchActualFunTys herald ct_orig n_val_args_wanted top_ty
- = go n_val_args_wanted [] top_ty
+ = go n_val_args_wanted top_ty
where
- go n so_far fun_ty
+ go n fun_ty
| not (isRhoTy fun_ty)
= do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
- ; (wrap2, arg_tys, res_ty) <- go n so_far rho
+ ; (wrap2, arg_tys, res_ty) <- go n rho
; return (wrap2 <.> wrap1, arg_tys, res_ty) }
- go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
+ go 0 fun_ty = return (idHsWrapper, [], fun_ty)
- go n so_far fun_ty
- = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
- (n_val_args_wanted, top_ty) fun_ty
- ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
- ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
- -- NB: arg_ty1 comes from matchActualFunTy, so it has
- -- a syntactically fixed RuntimeRep
- ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
+ go n fun_ty
+ = do { (co1, arg1_ty_frr, res_ty1) <-
+ matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty
+ ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1
+ ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty
+ -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT:
+ -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR.
+ ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) }
{-
************************************************************************
@@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
= assert (isVisibleFunArg af) $
do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc
; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
- ; let arg_sty_frr = Scaled mult arg_ty_frr
- ; (wrap_res, result) <- check (n_req - 1)
- (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
+ ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
+ ; (res_wrap, result) <- check (n_req - 1)
+ (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
res_ty
- ; let wrap_arg = mkWpCastN arg_co
- fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
+
+ -- arg_co :: arg_ty ~ arg_ty_frr
+ -- res_wrap :: act_res_ty ~~> res_ty
+ ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty)
+ = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty
+ -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR
+
+ fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty)
+ = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty))
+
+ fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty)
+ = fun_wrap2 <.> fun_wrap1
+
+-- NB: in the common case, 'arg_ty' is already FRR (in the sense of
+-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'.
+-- Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively;
+-- as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will
+-- typically just be 'WpHole'; no clutter.
+-- This is important because 'matchExpectedFunTys' is called a lot.
+
; return (fun_wrap, result) }
----------------------------
@@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
------------------------
tcSubTypePat :: CtOrigin -> UserTypeCtxt
- -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+ -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
-- Used in patterns; polarity is backwards compared
-- to tcSubType
-- If wrap = tc_sub_type_et t1 t2
=====================================
testsuite/tests/rep-poly/T26528.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE GHC2024, TypeFamilies #-}
+
+module T26528 where
+
+import Data.Kind
+import GHC.Exts
+
+type F :: Type -> RuntimeRep
+type family F a where
+ F Int = LiftedRep
+
+g :: forall (r::RuntimeRep).
+ (forall (a :: TYPE r). a -> forall b. b -> b) -> Int
+g _ = 3
+{-# NOINLINE g #-}
+
+foo = g @(F Int) (\x y -> y)
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, [''])
test('T23883c', normal, compile_fail, [''])
test('T23903', normal, compile_fail, [''])
test('T26107', js_broken(22364), compile, ['-O'])
+test('T26528', normal, compile, [''])
test('EtaExpandDataCon', normal, compile, ['-O'])
test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93fc72651bc911827bb92e7551eca01…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93fc72651bc911827bb92e7551eca01…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
07 Nov '25
Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC
Commits:
c8978c05 by Simon Peyton Jones at 2025-11-07T00:31:51+00:00
Yet more [skip ci]
- - - - -
10 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types/BasicTypes.hs
- compiler/GHC/Tc/Utils/Env.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -38,13 +38,16 @@ import Language.Haskell.Syntax.Expr( LHsExpr )
import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind )
import {-# SOURCE #-} GHC.Hs.Pat (pprLPat )
-import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )
-import GHC.Types.Tickish
import GHC.Hs.Extension
-import GHC.Parser.Annotation
import GHC.Hs.Type
+
import GHC.Tc.Types.Evidence
+
import GHC.Core.Type
+
+import GHC.Parser.Annotation
+
+import GHC.Types.Tickish
import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Types.SourceText
@@ -52,6 +55,8 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Var
import GHC.Types.Name
+import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )
+
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
@@ -89,7 +94,18 @@ data HsValBindGroups p -- Divided into strongly connected components
type family HsValBindGroup p
type instance HsValBindGroup GhcPs = ()
type instance HsValBindGroup GhcRn = (RecFlag, LHsBinds GhcRn)
-type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, TopLevelFlag)
+type instance HsValBindGroup GhcTc = (RecFlag, LHsBinds GhcTc, StaticFlag)
+
+data StaticFlag
+ = IsStatic | NotStatic
+ deriving( Data )
+ -- IsStatic <=> this binding consists only code; all free
+ -- vars are top level (or themselves static).
+ -- So it can be moved to top level
+
+instance Outputable StaticFlag where
+ ppr IsStatic = text "static"
+ ppr NotStatic = text "not-static"
-- ---------------------------------------------------------------------
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -95,9 +95,9 @@ dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body
-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (XValBindsLR (NValBinds binds _)) body
+dsValBinds (XValBindsLR (HsVBG grps _)) body
= do { dflags <- getDynFlags
- ; foldrM (ds_val_bind dflags) body binds }
+ ; foldrM (ds_val_bind dflags) body grps }
dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
@@ -119,12 +119,14 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
-------------------------
-- caller sets location
-ds_val_bind :: DynFlags -> (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
+ds_val_bind :: DynFlags
+ -> (RecFlag, LHsBinds GhcTc, StaticFlag) -> CoreExpr
+ -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
-ds_val_bind _ (NonRecursive, hsbinds) body
+ds_val_bind _ (NonRecursive, hsbinds, _) body
| [L loc bind] <- hsbinds
-- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
@@ -158,7 +160,7 @@ ds_val_bind _ (NonRecursive, hsbinds) body
is_polymorphic _ = False
-ds_val_bind _ (is_rec, binds) _body
+ds_val_bind _ (is_rec, binds, _) _body
| any (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds
= assert (isRec is_rec )
errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys binds
@@ -168,7 +170,7 @@ ds_val_bind _ (is_rec, binds) _body
-- linear, but selectors as used in the general case aren't. So the general case
-- would transform a linear definition into a non-linear one. See Wrinkle 2
-- Note [Desugar Strict binds] in GHC.HsToCore.Binds.
-ds_val_bind dflags (NonRecursive, hsbinds) body
+ds_val_bind dflags (NonRecursive, hsbinds, _) body
| [L _loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann
, pat_ext = (ty, (rhs_tick, _var_ticks))})] <- hsbinds
-- Non-recursive, non-overloaded bindings only come in ones
@@ -190,21 +192,26 @@ ds_val_bind dflags (NonRecursive, hsbinds) body
-- problem?
-- Ordinary case for bindings; none should be unlifted
-ds_val_bind _ (is_rec, binds) body
+ds_val_bind _ (is_rec, binds, static_flag) body
= do { massert (isRec is_rec || isSingleton binds)
- -- we should never produce a non-recursive list of multiple binds
+ -- We should never produce a non-recursive list of multiple binds
; (force_vars,prs) <- dsLHsBinds binds
- ; let body' = foldr seqVar body force_vars
+
; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
-- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
case prs of
[] -> return body
- _ -> return (mkLets (mk_binds is_rec prs) body') }
+ _ -> case static_flag of
+ NotStatic -> return (mkLets (mk_binds is_rec prs) body')
+ IsStatic -> do { emitStaticBinds prs; return body' }
+ where
+ body' = foldr seqVar body force_vars
-- We can make a non-recursive let because we make sure to return
-- the bindings in dependency order in dsLHsBinds,
-- see Note [Return non-recursive bindings in dependency order] in
-- GHC.HsToCore.Binds
+ }
-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for
-- instance.
@@ -494,7 +501,7 @@ dsExpr (HsStatic (_, whole_ty) expr@(L loc _))
; static_id <- newStaticId (mkSpecForAllTys static_fvs whole_ty)
- ; emitStaticBind static_id static_rhs
+ ; emitStaticBinds [(static_id, static_rhs)]
; return (mkVarApps (Var static_id) static_fvs) }
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.HsToCore.Monad (
DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
-- Static bindings
- emitStaticBind, getStaticBinds,
+ emitStaticBinds, getStaticBinds,
-- Getting and setting pattern match oracle states
getPmNablas, updPmNablas,
@@ -643,10 +643,10 @@ pprRuntimeTrace str doc expr = do
getCCIndexDsM :: FastString -> DsM CostCentreIndex
getCCIndexDsM = getCCIndexM ds_cc_st
-emitStaticBind :: Id -> CoreExpr -> DsM ()
-emitStaticBind static_id rhs
+emitStaticBinds :: [(Id,CoreExpr)] -> DsM ()
+emitStaticBinds static_binds
= do { env <- getGblEnv
- ; liftIO $ modifyIORef' (ds_static_binds env) (`snocOL` (static_id,rhs)) }
+ ; liftIO $ modifyIORef' (ds_static_binds env) (`appOL` toOL static_binds) }
getStaticBinds :: DsM (OrdList (Id,CoreExpr))
getStaticBinds = do { env <- getGblEnv
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -341,8 +341,8 @@ hsScopedTvBinders binds
= concatMap get_scoped_tvs sigs
where
sigs = case binds of
- ValBinds _ _ sigs -> sigs
- XValBindsLR (NValBinds _ sigs) -> sigs
+ ValBinds _ _ sigs -> sigs
+ XValBindsLR (HsVBG _ sigs) -> sigs
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
@@ -1987,7 +1987,7 @@ rep_implicit_param_name (HsIPName name) = coreStringLit name
rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (XValBindsLR (NValBinds binds sigs))
+rep_val_binds (XValBindsLR (HsVBG binds sigs))
= do { core1 <- rep_binds (concatMap snd binds)
; core2 <- rep_sigs sigs
; return (core1 ++ core2) }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -260,7 +260,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
- -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
+ -> TcM ([(RecFlag, LHsBinds GhcTc, StaticFlag)], thing)
tcValBinds top_lvl grps sigs thing_inside
= do { -- Typecheck the signatures
@@ -285,7 +285,7 @@ tcValBinds top_lvl grps sigs thing_inside
-- See Note [Pattern synonym builders don't yield dependencies]
-- in GHC.Rename.Bind
; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
- ; let extra_binds = [ (NonRecursive, builder, TopLevel)
+ ; let extra_binds = [ (NonRecursive, builder, IsStatic)
| builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
@@ -297,7 +297,7 @@ tcValBinds top_lvl grps sigs thing_inside
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
- -> TcM ([(RecFlag, LHsBinds GhcTc, TopLevelFlag)], thing)
+ -> TcM ([(RecFlag, LHsBinds GhcTc, StaticFlag)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-- Here a "strongly connected component" has the straightforward
@@ -334,7 +334,7 @@ before we sub-divide it based on what type signatures it has.
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds GhcRn) -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+ -> TcM ((RecFlag, LHsBinds GhcTc, StaticFlag), thing)
-- Typecheck one strongly-connected component of the original program.
tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside
= case rec_flag of
@@ -345,12 +345,12 @@ tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside
tc_nonrec_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBinds GhcRn -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+ -> TcM ((RecFlag, LHsBinds GhcTc, StaticFlag), thing)
tc_nonrec_group top_lvl sig_fn prag_fn [lbind] thing_inside
| L loc (PatSynBind _ psb) <- lbind
= do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
; thing <- setGblEnv tcg_env thing_inside
- ; return ((NonRecursive, aux_binds, TopLevel), thing) }
+ ; return ((NonRecursive, aux_binds, IsStatic), thing) }
| otherwise
= -- A single non-recursive binding
@@ -375,7 +375,7 @@ tc_nonrec_group _ _ _ binds _ -- Non-rec groups should always be a singleton
tc_rec_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBinds GhcRn -> TcM thing
- -> TcM ((RecFlag, LHsBinds GhcTc, TopLevelFlag), thing)
+ -> TcM ((RecFlag, LHsBinds GhcTc, StaticFlag), thing)
tc_rec_group top_lvl sig_fn prag_fn binds thing_inside
= -- For a recursive group, to maximise polymorphism, we do a new
-- strongly-connected-component analysis, this time omitting
@@ -1855,7 +1855,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed
isClosedBndrGroup type_env binds
- = IsGroupClosed is_top fv_env type_closed
+ = IsGroupClosed is_static fv_env type_closed
where
fv_env :: NameEnv NameSet
fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ]
@@ -1875,16 +1875,20 @@ isClosedBndrGroup type_env binds
`delListFromNameSet` all_bndrs
-- all_fvs does not include the binders of this group
- is_top | nameSetAll id_is_top all_fvs = TopLevel
- | otherwise = NotTopLevel
+ is_static | not (any (is_pat_bind . unLoc) binds)
+ , nameSetAll id_is_static all_fvs = IsStatic
+ | otherwise = NotStatic
- id_is_top :: Name -> Bool
- id_is_top name
+ is_pat_bind (PatBind {}) = True
+ is_pat_bind _ = False
+
+ id_is_static :: Name -> Bool
+ id_is_static name
| Just thing <- lookupNameEnv type_env name
= case thing of
- AGlobal {} -> True
- ATcId { tct_info = LetBound { lb_top = top } } -> isTopLevel top
- _ -> False
+ AGlobal {} -> True
+ ATcId { tct_info = LetBound { lb_top = IsStatic } } -> True
+ _ -> False
| otherwise -- Imported Ids
= True
@@ -1897,10 +1901,12 @@ isClosedBndrGroup type_env binds
is_closed_type_id name
| Just thing <- lookupNameEnv type_env name
= case thing of
- AGlobal {} -> True
- ATcId { tct_info = info } -> lb_closed info
- ATyVar {} -> False
- -- In-scope type variables are not closed!
+ AGlobal {} -> True
+ ATyVar {} -> False -- In-scope type variables are not closed!
+ ATcId { tct_info = info}
+ -> case info of
+ LetBound { lb_closed = closed } -> closed
+ NotLetBound -> False
_ -> pprPanic "is_closed_id" (ppr name)
| otherwise
@@ -1911,13 +1917,13 @@ isClosedBndrGroup type_env binds
adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed
adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids
- | TopLevel <- top_lvl
+ | IsStatic <- top_lvl
, all definitely_lifted ids = closed
- | otherwise = IsGroupClosed NotTopLevel fv_env type_closed
+ | otherwise = IsGroupClosed NotStatic fv_env type_closed
where
definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id)
-sendToTopLevel :: IsGroupClosed -> TopLevelFlag
+sendToTopLevel :: IsGroupClosed -> StaticFlag
sendToTopLevel (IsGroupClosed top _ _) = top
lHsBindFreeVars :: LHsBind GhcRn -> NameSet
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1506,7 +1506,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
let_binds :: HsLocalBindsLR GhcRn GhcRn
let_binds = HsValBinds noAnn $ XValBindsLR
- $ NValBinds upd_ids_lhs (map mk_idSig upd_ids)
+ $ HsVBG upd_ids_lhs (map mk_idSig upd_ids)
upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
upd_ids_lhs = [ (NonRecursive, [genSimpleFunBind (idName id) [] rhs])
| (_, (id, rhs)) <- upd_ids ]
@@ -1821,9 +1821,8 @@ checkClosedInStaticForm name = do
-- visited nodes, so we avoid repeating cycles in the traversal.
case lookupNameEnv type_env n of
Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
- ClosedLet -> Nothing
NotLetBound -> Just NotLetBoundReason
- NonClosedLet fvs type_closed -> listToMaybe $
+ LetBound { lb_fvs = fvs, lb_closed = type_closed } -> listToMaybe $
-- Look for a non-closed variable in fvs
[ NotClosed n' reason
| n' <- nameSetElemsStable fvs
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -791,7 +791,7 @@ tcRnHsBootDecls boot_or_sig decls
, hs_defds = def_decls
, hs_ruleds = rule_decls
, hs_annds = _
- , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
+ , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) })
<- rnTopSrcDecls first_group
; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
@@ -1707,7 +1707,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = hs_val_binds@(XValBindsLR
- (NValBinds val_binds val_sigs)) })
+ (HsVBG val_binds val_sigs)) })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
@@ -1716,7 +1716,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
- XValBindsLR (NValBinds deriv_binds deriv_sigs))
+ XValBindsLR (HsVBG deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ;
updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
@@ -2316,7 +2316,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
-- [let it = expr]
let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn
$ XValBindsLR
- (NValBinds [(NonRecursive,[the_bind])] [])
+ (HsVBG [(NonRecursive,[the_bind])] [])
-- [it <- e]
bind_stmt = L loc $ BindStmt
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -846,7 +846,7 @@ tcRecSelBinds sel_bind_prs
-- See Note [Impredicative record selectors]
setXOptM LangExt.ImpredicativeTypes $
tcValBinds TopLevel binds sigs getGblEnv
- ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
+ ; return (tcg_env `addTypecheckedBinds` map sndOf3 rec_sel_binds) }
where
sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)
| (sel_id, _) <- sel_bind_prs
=====================================
compiler/GHC/Tc/Types/BasicTypes.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Hs.Extension ( GhcRn )
+import GHC.Hs.Binds ( StaticFlag )
import Language.Haskell.Syntax.Type ( LHsSigWcType )
@@ -309,7 +310,7 @@ data TcTyThing
| ATcId -- Ids defined in this module; may not be fully zonked
{ tct_id :: Id
- , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo]
+ , tct_info :: IdBindingInfo
}
| ATyVar Name TcTyVar -- See Note [Type variables in the type environment]
@@ -346,16 +347,16 @@ instance Outputable TcTyThing where -- Debugging only
-- b) to figure out when a nested binding can be generalised,
-- in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'.
--
-data IdBindingInfo -- See Note [Meaning of IdBindingInfo]
+data IdBindingInfo
= NotLetBound
| LetBound
- { lb_top :: TopLevelFlag
- -- TopLevel <=> this binding may safely be moved to top level
+ { lb_top :: StaticFlag
+ -- IsStatic <=> this binding may safely be moved to top level
-- E.g f x = let ys = reverse [1,2]
-- zs = reverse ys
-- in ...
- -- Both ys and zs count as TopLevel
+ -- Both ys and zs count as IsStatic
, lb_fvs :: RhsNames
-- Free vars of the RHS that are NotLetBound, or LetBound NotTopLevel
@@ -372,7 +373,7 @@ data IdBindingInfo -- See Note [Meaning of IdBindingInfo]
-- mutually-recursive /renamed/ (but not yet typechecked) bindings
data IsGroupClosed
= IsGroupClosed
- TopLevelFlag -- TopLevel <=> all free vars are themselves TopLevel
+ StaticFlag -- IsStatic <=> all free vars of the group are top-level or static
(NameEnv RhsNames) -- Frees for the RHS of each binding in the group
-- (includes free vars of RHS bound in the same group)
ClosedTypeId -- True <=> all the free vars of the group have closed types
@@ -383,8 +384,21 @@ type RhsNames = NameSet -- Names of variables, mentioned on the RHS of
type ClosedTypeId = Bool
-- See Note [Meaning of IdBindingInfo]
-{- Note [Meaning of IdBindingInfo]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Static bindings and StaticFlag]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A (possibly-recursive) binding is /static/ iff
+ * It is syntactically top-level
+OR
+ * It is not a PatBind
+ * Its free variables are all static
+ * It has a lifted type
+
+Static bindings are important for static forms (static e):
+ * The free vars of `e` must all be static
+ * All static bindings are immediately floated to top level by the desugarer
+ * The desugarer also floats `e` to top level, and replaces (static e)
+Static bindings can all float to top level, and the de
+
* NotLetBound means that
- the Id is not let-bound (e.g. it is bound in a
lambda-abstraction or in a case pattern)
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -675,7 +675,7 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
- , tct_info = LetBound { lb_top = NotTopLevel
+ , tct_info = LetBound { lb_top = NotStatic
, lb_fvs = emptyNameSet
, lb_closed = False } })
| (name, let_id) <- pairs ] $
@@ -691,7 +691,7 @@ tcExtendSigIds top_lvl sig_ids thing_inside
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
- info = LetBound { lb_top = NotTopLevel
+ info = LetBound { lb_top = NotStatic
, lb_fvs = emptyNameSet
, lb_closed = closed } ]
thing_inside
@@ -703,7 +703,7 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-- Used for both top-level value bindings and nested let/where-bindings
-- Used for a single NonRec or a single Rec
-- Adds to the TcBinderStack too
-tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _)
+tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_static fv_env _)
ids thing_inside
= tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $
tc_extend_local_env top_lvl
@@ -713,7 +713,7 @@ tcExtendLetEnv top_lvl _sig_fn (IsGroupClosed group_top fv_env _)
foldr check_usage thing_inside scaled_names
where
mk_tct_info id
- = LetBound { lb_top = group_top
+ = LetBound { lb_top = group_static
, lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet
, lb_closed = isTypeClosedLetBndr id }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8978c0582898f2afa2a1313841bfe0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8978c0582898f2afa2a1313841bfe0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0