[Git][ghc/ghc][wip/T25281] Yet more
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Oct 4 12:16:30 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
bf68253d by Simon Peyton Jones at 2024-10-04T13:16:16+01:00
Yet more
- - - - -
4 changed files:
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1340,8 +1340,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- [Activation for data constructor wrappers]) but we want to do
-- case-of-known-constructor optimisation eagerly (see Note
-- [exprIsConApp_maybe on data constructors with wrappers]).
- | isDataConWrapId fun
- , let rhs = uf_tmpl (realIdUnfolding fun)
+ | Just rhs <- dataConWrapUnfolding_maybe fun
= go (Left in_scope) floats rhs cont
-- Look through dictionary functions; see Note [Unfolding DFuns]
=====================================
compiler/GHC/Hs/Stats.hs
=====================================
@@ -134,9 +134,8 @@ ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = impor
spec_info (Just (Exactly, _)) = (0,0,0,0,0,1,0)
spec_info (Just (EverythingBut, _)) = (0,0,0,0,0,0,1)
- data_info (DataDecl { tcdDataDefn = HsDataDefn
- { dd_cons = cs
- , dd_derivs = derivs}})
+ data_info (DataDecl { tcdDataDefn = dd :: HsDataDefn GhcPs })
+ | HsDataDefn { dd_cons = cs, dd_derivs = derivs} <- dd
= ( length cs
, foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
0 derivs )
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -247,7 +247,7 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isInlinePragma (idInlinePragma pid) ] }
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do
let name = getOccString id
decl_path <- getPathEntry
density <- getDensity
@@ -264,7 +264,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
(fvs, mg) <-
getFreeVars $
addPathEntry name $
- addTickMatchGroup False (fun_matches funBind)
+ addTickMatchGroup False matches
blackListed <- isBlackListed (locA pos)
exported_names <- liftM exports getEnv
@@ -272,7 +272,9 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
-- We don't want to generate code for blacklisted positions
-- We don't want redundant ticks on simple pattern bindings
-- We don't want to tick non-exported bindings in TickExportedFunctions
- let simple = isSimplePatBind funBind
+ let simple = matchGroupArity matches == 0
+ -- A binding is a "simple pattern binding" if it is a
+ -- funbind with zero patterns
toplev = null decl_path
exported = idName id `elemNameSet` exported_names
@@ -288,15 +290,10 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
, fun_ext = second (tick `mbCons`) (fun_ext funBind) }
}
- where
- -- a binding is a simple pattern binding if it is a funbind with
- -- zero patterns
- isSimplePatBind :: HsBind GhcTc -> Bool
- isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-
-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
- , pat_rhs = rhs }))) = do
+ , pat_rhs = rhs
+ , pat_ext = (grhs_ty, initial_ticks}))) = do
let simplePatId = isSimplePat lhs
@@ -314,14 +311,12 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
then return (L pos pat')
else do
- let mbCons = maybe id (:)
-
- let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat'
-
-- Allocate the ticks
-
rhs_tick <- bindTick density name (locA pos) fvs
- let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
+
+ let mbCons = maybe id (:)
+ (initial_rhs_ticks, initial_patvar_tickss) = initial_ticks
+ rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
patvar_tickss <- case simplePatId of
Just{} -> return initial_patvar_tickss
@@ -332,7 +327,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
(zipWith mbCons patvar_ticks
(initial_patvar_tickss ++ repeat []))
- return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') }
+ return $ L pos $ pat' { pat_ext = (ghhs_ty, (rhs_ticks, patvar_tickss)) }
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -141,7 +141,9 @@ import GHC.Types.Var( Id, CoVar, JoinId,
setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM)
import qualified GHC.Types.Var as Var
-import GHC.Core
+import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun
+ , isStableUnfolding, isCompulsoryUnfolding, isEvaldUnfolding
+ , hasSomeUnfolding, noUnfolding, evaldUnfolding )
import GHC.Core.Type
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.DataCon
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf68253dee300d576ab478d48490ad6c2f26906b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf68253dee300d576ab478d48490ad6c2f26906b
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/20241004/2b0eb0bf/attachment-0001.html>
More information about the ghc-commits
mailing list