[Git][ghc/ghc][wip/T24359] More work in progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Nov 25 17:44:14 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
3c96f6bc by Simon Peyton Jones at 2024-11-25T17:43:50+00:00
More work in progress
won't actually compile yet
- - - - -
5 changed files:
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs
- testsuite/tests/simplCore/should_compile/simpl016.stderr
Changes:
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -8,7 +8,7 @@ module GHC.Core.SimpleOpt (
SimpleOpts (..), defaultSimpleOpts,
-- ** Simple expression optimiser
- simpleOptPgm, simpleOptExpr, simpleOptExprWith,
+ simpleOptPgm, simpleOptExpr, simpleOptExprNoOccAnal, simpleOptExprWith,
-- ** Join points
joinPointBinding_maybe, joinPointBindings_maybe,
@@ -146,6 +146,16 @@ simpleOptExpr opts expr
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
+simpleOptExprNoOccAnal :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
+-- Same as simpleOptExpr but without occurrence analysis
+-- Result: we don't inline evidence bindings, which is useful for the specialiser
+simpleOptExprNoOccAnal opts expr
+ = simpl_opt_expr init_env expr
+ where
+ init_env = (emptyEnv opts) { soe_subst = init_subst }
+ init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
+ -- It's potentially important to make a proper in-scope set
+
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith opts subst expr
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -71,7 +71,7 @@ import GHC.Data.SizedSeq ( sizeSS )
import GHC.Utils.Error
import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
+import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Logger
@@ -294,9 +294,24 @@ deSugar hsc_env
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
- = do { spec_prs <- mapMaybeM (dsSpec Nothing . unLoc) 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
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -802,14 +802,12 @@ dsSpecs poly_rhs (SpecPrags sps)
dsLSpec :: CoreExpr -> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsLSpec poly_rhs (L loc prag)
- = putSrcSpanDs loc $ dsSpec (Just poly_rhs) prag
+ = putSrcSpanDs loc $ dsSpec poly_rhs prag
-dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
- -- Nothing => RULE is for an imported Id
- -- rhs is in the Id's unfolding
+dsSpec :: CoreExpr -- RHS to be specialised
-> TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-dsSpec mb_poly_rhs (SpecPrag poly_id spec_co spec_inl)
+dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)
-- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
| isJust (isClassOpId_maybe poly_id)
= failBecauseOfClassOp poly_id
@@ -821,13 +819,12 @@ dsSpec mb_poly_rhs (SpecPrag poly_id spec_co spec_inl)
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
= dsHsWrapper spec_app $ \core_app ->
do { dflags <- getDynFlags
- ; let poly_rhs = specFunBody poly_id mb_poly_rhs
; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id))
(mkVarSet spec_bndrs) of {
Left msg -> do { diagnosticDs msg; return Nothing } ;
Right (rule_bndrs, poly_id, rule_lhs_args) ->
- finishSpecPrag rule_bndrs poly_id rule_lhs_args
- rule_bndrs (core_app poly_rhs) spec_inl } }
+ finishSpecPrag poly_rhs rule_bndrs poly_id rule_lhs_args
+ rule_bndrs core_app spec_inl } }
{-
dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
@@ -876,7 +873,7 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
drop_cast e = e
-}
-dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
+dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
, spe_id_bndrs = id_bndrs
, spe_tv_bndrs = tv_bndrs
, spe_lhs_ev_bndrs = lhs_evs
@@ -889,8 +886,7 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
| otherwise
= dsTcEvBinds lhs_binds $ \ ds_lhs_binds ->
- do { dflags <- getDynFlags
- ; ds_call <- zapUnspecables $
+ do { ds_call <- zapUnspecables $
-- zapUnspecables: see Note [Desugaring RULE left hand sides]
dsLExpr the_call
; tracePm "dsSpec1" (vcat
@@ -900,30 +896,37 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
, text "ds_lhs_binds" <+> ppr ds_lhs_binds
, text "ds_call" <+> ppr ds_call ])
+ ; dflags <- getDynFlags
; let simpl_opts = initSimpleOpts dflags
- core_call = drop_cast $
- simpleOptExpr simpl_opts $
- ds_call
+ core_call = simpleOptExprNoOccAnal simpl_opts $
+ mkLets ds_lhs_binds ds_call
+
+ ; case prepareSpecLHS lhs_evs core_call of {
+ Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
+ ; return Nothing } ;
- lhs_id_bndrs = id_bndrs ++ lhs_evs ++ bindersOfBinds ds_lhs_binds
- id_bndr_set = mkVarSet lhs_id_bndrs
+ Just (qevs, rhs_const_binds, fn_id, lhs_args) ->
+
+
+ assertPpr (fn_id == poly_id) (ppr fn_id $$ ppr poly_id) $
+ do { let lhs_id_bndrs = mkVarSet id_bndrs `unionVarSet`
+ qevs `unionVarSet`
+ mkVarSet (bindersOfBinds rhs_const_binds)
-- lhs_id_bndrs: all the Ids in core_call that should be quantified
-- These are the ones free in core_call that are local
-- to this specialisation, not global
- rule_bndrs = scopedSort (exprSomeFreeVarsList quantify_me core_call)
- quantify_me v = isTyVar v || v `elemVarSet` id_bndr_set
- -- Quantify over all tyvars; but only over Ids boundx explicitly
+ rule_bndrs = scopedSort (exprsSomeFreeVarsList quantify_me lhs_args)
+ quantify_me v = isTyVar v || v `elemVarSet` id_bndrs
+ -- Quantify over all tyvars; but only over Ids bound explicitly
-- this is a terrible hack. What about local SPECIALISE pragmas
-- that mention some in-scope TyVar?
- rhs_const_binds :: [CoreBind]
- rhs_const_binds = get_const_ev_binds lhs_evs ds_lhs_binds
- const_bndrs = mkVarSet (bindersOfBinds rhs_const_binds)
+ const_bndrs = mkVarSet (bindersOfBinds rhs_const_binds)
+ spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
- spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
-
- fn_body = specFunBody poly_id mb_poly_rhs
+ mk_spec_body fn_body = mkLets rhs_const_binds $
+ mkCoreApps fn_body lhs_args
; tracePm "dsSpec2" (vcat [ text "poly_id" <+> ppr poly_id
, text "ds_call" <+> ppr ds_call
@@ -935,34 +938,36 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
, text "rhs_const_binds" <+> ppr rhs_const_binds
])
- ; case collectArgs core_call of
- (Var fn_id, lhs_args)
- -> assertPpr (fn_id == poly_id) (ppr fn_id $$ ppr poly_id) $
- finishSpecPrag
+ ; finishSpecPrag poly_rhs
rule_bndrs poly_id lhs_args
- spec_bndrs spec_body inl
- where
- spec_body = mkLets rhs_const_binds $
- mkCoreApps fn_body lhs_args
+ spec_bndrs mk_spec_body inl } } }
- _other -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
- ; return Nothing } }
+prepareSpecLHS :: [EvVar] -> CoreExpr -> Maybe ([CoreBind], Id, [CoreExpr])
+prepareSpecLHS evs the_call
+ = go (mkVarSet evs) [] the_call
where
- drop_cast (Cast e _) = drop_cast e
- drop_cast e = e
-
-get_const_ev_binds :: [EvVar] -> [CoreBind] -> [CoreBind]
-get_const_ev_binds evs ev_binds
- = go (mkVarSet evs) ev_binds
- where
- go :: VarSet -> [CoreBind] -> [CoreBind]
- go _ [] = []
- go qevs (bind : binds)
+ go :: IdSet
+ -> [CoreBind] -- Reversed list of constant evidence bindings
+ -> CoreExpr
+ -> Maybe (IdSet, [CoreBind], Id, [CoreExpr])
+ go qevs acc (Cast e co)
+ = go qevs acc e
+ go qevs acc (Let bind e)
+ | not (all isDictId bndrs) -- A normal 'let' is too complicated
+ = Nothing
| all (isEmptyVarSet . exprSomeFreeVars (`elemVarSet` qevs)) $
rhssOfBind bind
- = bind : go qevs binds
+ = go qevs (bind:acc) e
| otherwise
- = go (qevs `extendVarSetList` bindersOf bind) binds
+ = go (qevs `extendVarSetList` bndrs) acc e
+ where
+ bndrs = bindersOf bind
+
+ go qevs acc e
+ | (Var fun, args) <- collectArgs e
+ = Just (qevs, reverse acc, fun, args)
+ | otherwise
+ = Nothing
failBecauseOfClassOp :: Id -> DsM (Maybe a)
-- There is no point in trying to specialise a class op
@@ -972,11 +977,18 @@ failBecauseOfClassOp poly_id
= do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
; return Nothing }
-finishSpecPrag :: [Var] -> Id -> [CoreExpr] -- LHS pattern
- -> [Var] -> CoreExpr -> InlinePragma -- Specialised form
+finishSpecPrag :: CoreExpr -- RHS to specialise
+ -> [Var] -> Id -> [CoreExpr] -- RULE LHS pattern
+ -> [Var] -> (CoreExpr -> CoreExpr) -> InlinePragma -- Specialised form
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-finishSpecPrag rule_bndrs poly_id rule_lhs_args
- spec_bndrs spec_body spec_inl
+finishSpecPrag poly_rhs rule_bndrs poly_id rule_args
+ spec_bndrs mk_spec_body spec_inl
+ -- The RULE looks like
+ -- RULE "USPEC" forall rule_bndrs. f rule_args = $sf spec_bndrs
+ -- The specialised function looks like
+ -- $sf spec_bndrs = mk_spec_body <f's original rhs>
+ -- We also use mk_spec_body to specialise the methods in f's stable unfolding
+ -- NB: spec_bindrs is a subset of rule_bndrs
= do { this_mod <- getModule
; uniq <- newUnique
; dflags <- getDynFlags
@@ -989,46 +1001,32 @@ finishSpecPrag rule_bndrs poly_id rule_lhs_args
simpl_opts = initSimpleOpts dflags
fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding simpl_opts spec_bndrs mk_app rule_lhs_args fn_unf
- mk_app e = mkApps e rule_lhs_args
+ spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_args fn_unf
spec_id = mkLocalId spec_name ManyTy spec_ty
-- Specialised binding is toplevel, hence Many.
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
- poly_id rule_bndrs rule_lhs_args
+ poly_id rule_bndrs rule_args
(mkVarApps (Var spec_id) spec_bndrs)
- rule_lhs_ty = exprType (mkApps (Var poly_id) rule_lhs_args)
- spec_ty = mkLamTypes spec_bndrs rule_lhs_ty
- spec_rhs = mkLams spec_bndrs spec_body
+ rule_ty = exprType (mkApps (Var poly_id) rule_args)
+ spec_ty = mkLamTypes spec_bndrs rule_ty
+ spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)
; dsWarnOrphanRule rule
; tracePm "dsSpec" (vcat
[ text "fun:" <+> ppr poly_id
, text "spec_bndrs:" <+> ppr spec_bndrs
- , text "spec_body:" <+> ppr spec_body
- , text "args:" <+> ppr rule_lhs_args ])
+ , text "args:" <+> ppr rule_args ])
; return (Just (unitOL (spec_id, spec_rhs), rule))
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
-- makeCorePair overwrites the unfolding, which we have
-- just created using specUnfolding
}
-specFunBody :: Id -> Maybe CoreExpr -> CoreExpr
-specFunBody _ (Just rhs)
- = rhs -- Local Id; this is its rhs
-specFunBody poly_id Nothing
- | 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
-
specFunInlinePrag :: Id -> InlinePragma
-> InlinePragma -> InlinePragma
-- See Note [Activation pragmas for SPECIALISE]
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -941,6 +941,14 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
emptyVarSet tv_bndrs qevs
wanted
+ ; traceTc "tcSpecPrag:SpecSigE" $
+ vcat [ text "nm:" <+> ppr nm
+ , text "tv_bndrs:" <+> ppr tv_bndrs
+ , text "id_bndrs:" <+> ppr id_bndrs
+ , text "qevs:" <+> ppr qevs
+ , text "spec_e:" <+> ppr spec_e'
+ , text "inl:" <+> ppr inl ]
+
; return [SpecPragE { spe_poly_id = poly_id
, spe_tv_bndrs = tv_bndrs
, spe_id_bndrs = id_bndrs
=====================================
testsuite/tests/simplCore/should_compile/simpl016.stderr
=====================================
@@ -1,10 +0,0 @@
-
-simpl016.hs:7:1: warning: [GHC-40548]
- Forall'd constraint ‘Num b’ is not bound in RULE lhs
- Orig bndrs: [b, $dNum]
- Orig lhs: let {
- $dEq :: Eq Int
- [LclId]
- $dEq = GHC.Classes.$fEqInt } in
- delta' @Int @b $dEq
- optimised lhs: delta' @Int @b $dEq
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c96f6bc145a6ae7247ea46c841b38e429f72295
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c96f6bc145a6ae7247ea46c841b38e429f72295
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/20241125/9f744d8d/attachment-0001.html>
More information about the ghc-commits
mailing list