[Git][ghc/ghc][wip/T24359] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Nov 30 22:19:12 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
4ddcf5ef by Simon Peyton Jones at 2024-11-30T22:18:43+00:00
Wibbles
- - - - -
14 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/ghc-api/T18522-dbg-ppr.hs
- testsuite/tests/simplCore/should_compile/T8537.stderr
- testsuite/tests/typecheck/should_compile/T10504.stderr
- testsuite/tests/warnings/should_compile/T19296.stderr
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -840,10 +840,15 @@ data TcSpecPrag
-- ^ The Id to be specialised, a wrapper that specialises the
-- polymorphic function, and inlining spec for the specialised function
- | SpecPragE { spe_poly_id :: Id -- THe Id being specialised
- , spe_bndrs :: [Var] -- TyVars, EvVars, and Ids
- , spe_call :: LHsExpr GhcTc -- The LHS of the RULE: a call of f
- , spe_inl :: InlinePragma }
+ | SpecPragE { spe_fn_nm :: Name -- The Name of the Id being specialised
+ , spe_fn_id :: Id -- The Id being specialised
+ -- The spe_fn_name may differ from (idName spe_fn_id) in the
+ -- case of instance methods, where the Name is the class-op
+ -- selector but the spe_fn_id is that for the local method
+
+ , spe_bndrs :: [Var] -- TyVars, EvVars, and Ids
+ , spe_call :: LHsExpr GhcTc -- The LHS of the RULE: a call of f
+ , spe_inl :: InlinePragma }
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -292,27 +292,6 @@ deSugar hsc_env
; return (msgs, Just mod_guts)
}}}}
-dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
-dsImpSpecs imp_specs
- = do { spec_prs <- mapMaybeM spec_one imp_specs
- ; let (spec_binds, spec_rules) = unzip spec_prs
- ; return (concatOL spec_binds, spec_rules) }
- where
- spec_one (L _ prag) = dsSpec (get_rhs prag) prag
-
- get_rhs (SpecPrag poly_id _ _) = get_rhs1 poly_id
- get_rhs (SpecPragE { spe_poly_id = poly_id }) = get_rhs1 poly_id
-
- get_rhs1 poly_id
- | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
- = unfolding -- Imported Id; this is its unfolding
- -- Use realIdUnfolding so we get the unfolding
- -- even when it is a loop breaker.
- -- We want to specialise recursive functions!
- | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
- -- The type checker has checked that it *has* an unfolding
-
-
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -15,7 +15,8 @@ lower levels it is preserved with @let@/@letrec at s).
-}
module GHC.HsToCore.Binds
- ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
+ ( dsTopLHsBinds, dsLHsBinds
+ , dsImpSpecs, decomposeRuleLhs
, dsHsWrapper, dsHsWrappers
, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
, dsWarnOrphanRule
@@ -845,6 +846,27 @@ dsSpecs poly_rhs (SpecPrags sps)
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
+dsImpSpecs imp_specs
+ = do { spec_prs <- mapMaybeM spec_one imp_specs
+ ; let (spec_binds, spec_rules) = unzip spec_prs
+ ; return (concatOL spec_binds, spec_rules) }
+ where
+ spec_one (L loc prag) = putSrcSpanDs loc $
+ dsSpec (get_rhs prag) prag
+
+ get_rhs (SpecPrag poly_id _ _) = get_rhs1 poly_id
+ get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id
+
+ get_rhs1 poly_id
+ | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+ = unfolding -- Imported Id; this is its unfolding
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
+ | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+ -- The type checker has checked that it *has* an unfolding
+
dsLSpec :: CoreExpr -> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsLSpec poly_rhs (L loc prag)
@@ -866,13 +888,15 @@ dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)
(mkVarSet spec_bndrs) of {
Left msg -> do { diagnosticDs msg; return Nothing } ;
Right (rule_bndrs, poly_id, rule_lhs_args) ->
- finishSpecPrag poly_rhs rule_bndrs poly_id rule_lhs_args
- spec_bndrs core_app spec_inl } }
-
-dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
- , spe_bndrs = bndrs
- , spe_call = the_call
- , spe_inl = inl })
+ finishSpecPrag (idName poly_id) poly_rhs
+ rule_bndrs poly_id rule_lhs_args
+ spec_bndrs core_app spec_inl } }
+
+dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm
+ , spe_fn_id = poly_id
+ , spe_bndrs = bndrs
+ , spe_call = the_call
+ , spe_inl = inl })
-- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
= do { ds_call <- zapUnspecables $ -- zapUnspecables: see
dsLExpr the_call -- Note [Desugaring RULE left hand sides]
@@ -903,7 +927,7 @@ dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
, text "core_call fvs" <+> ppr (exprFreeVars core_call)
, text "spec_const_binds" <+> ppr spec_const_binds ])
- ; finishSpecPrag poly_rhs
+ ; finishSpecPrag poly_nm poly_rhs
rule_bndrs poly_id lhs_args
spec_bndrs mk_spec_body inl } } }
@@ -944,26 +968,26 @@ prepareSpecLHS poly_id evs the_call
is_quant_id v = isId v && v `elemVarSet` qevs
-- See Note [Desugaring SPECIALISE pragmas] wrinkle (DS1)
-finishSpecPrag :: CoreExpr -- RHS to specialise
+finishSpecPrag :: Name -> CoreExpr -- RHS to specialise
-> [Var] -> Id -> [CoreExpr] -- RULE LHS pattern
-> [Var] -> (CoreExpr -> CoreExpr) -> InlinePragma -- Specialised form
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-finishSpecPrag poly_rhs rule_bndrs poly_id rule_args
- spec_bndrs mk_spec_body spec_inl
+finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
+ spec_bndrs mk_spec_body spec_inl
| isJust (isClassOpId_maybe poly_id)
- = do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
+ = do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_nm)
; return Nothing } -- There is no point in trying to specialise a class op
-- Moreover, classops don't (currently) have an inl_sat arity set
-- (it would be Just 0) and that in turn makes makeCorePair bleat
| no_act_spec && isNeverActive rule_act
- = do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
+ = do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_nm)
; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
-- See Note [Activation pragmas for SPECIALISE]
--- | all is_nop_arg rule_args
--- = do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
--- ; return Nothing } -- Specialisation does nothing
+ | all is_nop_arg rule_args
+ = do { diagnosticDs (DsUselessSpecialise poly_nm)
+ ; return Nothing } -- Specialisation does nothing
| otherwise
-- The RULE looks like
@@ -1020,14 +1044,12 @@ finishSpecPrag poly_rhs rule_bndrs poly_id rule_args
rule_act | no_act_spec = inl_prag_act -- Inherit
| otherwise = spec_prag_act -- Specified by user
-{-
is_nop_arg (Type {}) = True
is_nop_arg (Coercion {}) = True
is_nop_arg (Cast e _) = is_nop_arg e
is_nop_arg (Tick _ e) = is_nop_arg e
is_nop_arg (Var x) = x `elem` spec_bndrs
is_nop_arg _ = False
--}
specFunInlinePrag :: Id -> InlinePragma
-> InlinePragma -> InlinePragma
=====================================
compiler/GHC/HsToCore/Errors/Ppr.hs
=====================================
@@ -89,6 +89,9 @@ instance Diagnostic DsMessage where
DsUselessSpecialiseForNoInlineFunction poly_id
-> mkSimpleDecorated $
text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
+ DsUselessSpecialise poly_id
+ -> mkSimpleDecorated $
+ text "Ignoring useless SPECIALISE pragma for:" <+> quotes (ppr poly_id)
DsOrphanRule rule
-> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule
DsRuleLhsTooComplicated orig_lhs lhs2
@@ -226,6 +229,7 @@ instance Diagnostic DsMessage where
DsTopLevelBindsNotAllowed{} -> ErrorWithoutFlag
DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag
DsUselessSpecialiseForNoInlineFunction{} -> WarningWithoutFlag
+ DsUselessSpecialise{} -> WarningWithoutFlag
DsOrphanRule{} -> WarningWithFlag Opt_WarnOrphans
DsRuleLhsTooComplicated{} -> WarningWithoutFlag
DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag
@@ -262,6 +266,7 @@ instance Diagnostic DsMessage where
DsTopLevelBindsNotAllowed{} -> noHints
DsUselessSpecialiseForClassMethodSelector{} -> noHints
DsUselessSpecialiseForNoInlineFunction{} -> noHints
+ DsUselessSpecialise{} -> noHints
DsOrphanRule{} -> noHints
DsRuleLhsTooComplicated{} -> noHints
DsRuleIgnoredDueToConstructor{} -> noHints
=====================================
compiler/GHC/HsToCore/Errors/Types.hs
=====================================
@@ -105,9 +105,11 @@ data DsMessage
| DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc)
- | DsUselessSpecialiseForClassMethodSelector !Id
+ | DsUselessSpecialiseForClassMethodSelector !Name
- | DsUselessSpecialiseForNoInlineFunction !Id
+ | DsUselessSpecialiseForNoInlineFunction !Name
+
+ | DsUselessSpecialise !Name
| DsOrphanRule !CoreRule
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -122,12 +122,11 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Home.ModInfo
-import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
+import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces )
import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Env (tcGetInstEnvs, lookupGlobal)
import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Utils.Monad
-import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) )
import GHC.Unit.Env
import GHC.IfaceToCore
@@ -136,7 +135,6 @@ import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
import Data.Dynamic
-import Data.IORef( newIORef )
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
@@ -1074,9 +1072,8 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do
(ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ty <- hscParseType str
- skol_tv_ref <- liftIO (newIORef [])
ioMsgMaybe $ hoistTcRnMessage $
- tcRnType hsc_env (SkolemiseFlexi skol_tv_ref) True ty
+ tcRnTypeSkolemising hsc_env ty
-- I'm not sure what to do about those zonked skolems
return ty
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -696,7 +696,7 @@ There are two major routes:
{-# SPECIALISE f @Int 3 #-}
- See Note [Handling new-form SPECIALISE pragmas]
-Note [Handling new-form SPECIALISE pragmas]
+Note [Handling new-form SPECIALISE pragmas]*
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
New-form SPECIALISE pragmas are described by GHC Proposal #493.
@@ -974,10 +974,11 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
, text "inl:" <+> ppr inl ]
; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) spec_e'
- ; return [SpecPragE { spe_poly_id = poly_id
- , spe_bndrs = tv_bndrs ++ qevs ++ id_bndrs
- , spe_call = lhs_call
- , spe_inl = inl }] }
+ ; return [SpecPragE { spe_fn_nm = nm
+ , spe_fn_id = poly_id
+ , spe_bndrs = tv_bndrs ++ qevs ++ id_bndrs
+ , spe_call = lhs_call
+ , spe_inl = inl }] }
tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -16,7 +16,8 @@
--
-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
module GHC.Tc.Module (
- tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
+ tcRnStmt, tcRnExpr, TcRnExprMode(..),
+ tcRnType, tcRnTypeSkolemising,
tcRnImportDecls,
tcRnLookupRdrName,
getModuleInterface,
@@ -184,6 +185,7 @@ import qualified Data.Set as S
import qualified Data.Map as M
import Data.Foldable ( for_ )
import Data.Traversable ( for )
+import Data.IORef( newIORef )
@@ -2674,6 +2676,16 @@ tcRnImportDecls hsc_env import_decls
where
zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
+
+tcRnTypeSkolemising :: HscEnv
+ -> LHsType GhcPs
+ -> IO (Messages TcRnMessage, Maybe (Type, Kind))
+-- tcRnTypeSkolemising skolemisese any free unification variables,
+-- and normalises the type
+tcRnTypeSkolemising env ty
+ = do { skol_tv_ref <- liftIO (newIORef [])
+ ; tcRnType env (SkolemiseFlexi skol_tv_ref) True ty }
+
-- tcRnType just finds the kind of a type
tcRnType :: HscEnv
-> ZonkFlexi
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -854,10 +854,9 @@ zonkLTcSpecPrags ps
= do { co_fn' <- don'tBind $ zonkCoFn co_fn
; id' <- zonkIdOcc id
; return (L loc (SpecPrag id' co_fn' inl)) }
- zonk_prag (L loc (SpecPragE { spe_poly_id = poly_id
- , spe_bndrs = bndrs
- , spe_call = spec_e
- , spe_inl = inl }))
+ zonk_prag (L loc prag@(SpecPragE { spe_fn_id = poly_id
+ , spe_bndrs = bndrs
+ , spe_call = spec_e }))
= do { poly_id' <- zonkIdOcc poly_id
; skol_tvs_ref <- lift $ newTcRef []
@@ -866,10 +865,9 @@ zonkLTcSpecPrags ps
runZonkBndrT (zonkCoreBndrsX bndrs) $ \bndrs' ->
do { spec_e' <- zonkLExpr spec_e
; skol_tvs <- lift $ readTcRef skol_tvs_ref
- ; return (L loc (SpecPragE { spe_poly_id = poly_id'
- , spe_bndrs = skol_tvs ++ bndrs'
- , spe_call = spec_e'
- , spe_inl = inl })) } }
+ ; return (L loc (prag { spe_fn_id = poly_id'
+ , spe_bndrs = skol_tvs ++ bndrs'
+ , spe_call = spec_e' })) } }
{-
************************************************************************
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -149,6 +149,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DsTopLevelBindsNotAllowed" = 48099
GhcDiagnosticCode "DsUselessSpecialiseForClassMethodSelector" = 93315
GhcDiagnosticCode "DsUselessSpecialiseForNoInlineFunction" = 38524
+ GhcDiagnosticCode "DsUselessSpecialise" = 66582
GhcDiagnosticCode "DsOrphanRule" = 58181
GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441
GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828
=====================================
testsuite/tests/ghc-api/T18522-dbg-ppr.hs
=====================================
@@ -45,8 +45,7 @@ main = do
() |]
let hs_t = fromRight (error "convertToHsType") $
convertToHsType (Generated OtherExpansion SkipPmc) noSrcSpan th_t
- (messages, mres) <-
- tcRnType hsc_env SkolemiseFlexi True hs_t
+ (messages, mres) <- tcRnTypeSkolemising hsc_env hs_t
let (warnings, errors) = partitionMessages messages
case mres of
Nothing -> do
=====================================
testsuite/tests/simplCore/should_compile/T8537.stderr
=====================================
@@ -1,3 +1,4 @@
-T8537.hs:20:5: warning: [GHC-35827]
- SPECIALISE pragma for non-overloaded function ‘fmap’
+T8537.hs:20:5: warning: [GHC-66582]
+ Ignoring useless SPECIALISE pragma for: ‘fmap’
+
=====================================
testsuite/tests/typecheck/should_compile/T10504.stderr
=====================================
@@ -1,3 +1,3 @@
-T10504.hs:5:1: warning: [GHC-35827]
- SPECIALISE pragma for non-overloaded function ‘myfun’
+T10504.hs:5:1: warning: [GHC-66582]
+ Ignoring useless SPECIALISE pragma for: ‘myfun’
=====================================
testsuite/tests/warnings/should_compile/T19296.stderr
=====================================
@@ -1,4 +1,3 @@
-
T19296.hs:6:6: warning: [GHC-30606] [-Wredundant-constraints]
Redundant constraint: Eq a
In the type signature for:
@@ -25,24 +24,11 @@ T19296.hs:13:6: warning: [GHC-30606] [-Wredundant-constraints]
13 | h :: (Eq a, Ord b) => a -> b -> b
| ^^^^^^^^^^^^^
-T19296.hs:21:1: warning: [GHC-40548]
- Forall'd constraint ‘Eq a’ is not bound in RULE lhs
- Orig bndrs: [a, $dEq]
- Orig lhs: let {
- $dOrd :: Ord Int
- [LclId]
- $dOrd = GHC.Classes.$fOrdInt } in
- spec @Int @a $dOrd
- optimised lhs: spec @Int @a $dOrd
- |
-21 | {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
- | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
T19296.hs:21:24: warning: [GHC-30606] [-Wredundant-constraints]
• Redundant constraint: Eq a
- In the type signature for:
- spec :: forall a. Eq a => a -> Int -> Int
- • In the pragma: {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
+ In an expression type signature:
+ forall a. Eq a => a -> Int -> Int
+ • In the expression: spec :: Eq a => a -> Int -> Int
|
21 | {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
| ^^^^
@@ -63,3 +49,4 @@ T19296.hs:39:12: warning: [GHC-30606] [-Wredundant-constraints]
|
39 | bar :: (Eq b, Ord b) => Int -> b -> Int
| ^^^^^^^^^^^^^
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ddcf5ef2fb5ff38ae7851675042a6fe24426c39
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ddcf5ef2fb5ff38ae7851675042a6fe24426c39
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241130/d912d1be/attachment-0001.html>
More information about the ghc-commits
mailing list