Commit 588acb99 authored by Adam Sandberg Eriksson's avatar Adam Sandberg Eriksson 🐈 Committed by Marge Bot

slightly better named cost-centres for simple pattern bindings #17006

```
main = do
  print $ g [1..100] a
  where g xs x   = map (`mod` x) xs
        a :: Int = 324
```

The above program previously attributed the cost of computing 324 to a cost
centre named `(...)`, with this change the cost is attributed to `a` instead.

This change only affects simple pattern bindings (decorated variables: type
signatures, parens, ~ annotations and ! annotations).
parent 7c122851
...@@ -31,6 +31,7 @@ module GHC.Hs.Pat ( ...@@ -31,6 +31,7 @@ module GHC.Hs.Pat (
mkPrefixConPat, mkCharLitPat, mkNilPat, mkPrefixConPat, mkCharLitPat, mkNilPat,
isSimplePat,
looksLazyPatBind, looksLazyPatBind,
isBangedLPat, isBangedLPat,
patNeedsParens, parenthesizePat, patNeedsParens, parenthesizePat,
...@@ -274,6 +275,7 @@ data Pat p ...@@ -274,6 +275,7 @@ data Pat p
| XPat | XPat
(XXPat p) (XXPat p)
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
data ListPatTc data ListPatTc
...@@ -730,6 +732,23 @@ isIrrefutableHsPat ...@@ -730,6 +732,23 @@ isIrrefutableHsPat
go (XPat {}) = False go (XPat {}) = False
-- | Is the pattern any of combination of:
--
-- - (pat)
-- - pat :: Type
-- - ~pat
-- - !pat
-- - x (variable)
isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x))
isSimplePat p = case unLoc p of
ParPat _ x -> isSimplePat x
SigPat _ x _ -> isSimplePat x
LazyPat _ x -> isSimplePat x
BangPat _ x -> isSimplePat x
VarPat _ x -> Just (unLoc x)
_ -> Nothing
{- Note [Unboxed sum patterns aren't irrefutable] {- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
......
...@@ -336,7 +336,12 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do ...@@ -336,7 +336,12 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
-- TODO: Revisit this -- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
, pat_rhs = rhs }))) = do , pat_rhs = rhs }))) = do
let name = "(...)"
let simplePatId = isSimplePat lhs
-- TODO: better name for rhs's for non-simple patterns?
let name = maybe "(...)" getOccString simplePatId
(fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
let pat' = pat { pat_rhs = rhs'} let pat' = pat { pat_rhs = rhs'}
...@@ -348,16 +353,24 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs ...@@ -348,16 +353,24 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
then return (L pos pat') then return (L pos pat')
else do else do
let mbCons = maybe id (:)
let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
-- Allocate the ticks -- Allocate the ticks
rhs_tick <- bindTick density name pos fvs rhs_tick <- bindTick density name pos fvs
let patvars = map getOccString (collectPatBinders lhs) let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
patvar_tickss <- case simplePatId of
Just{} -> return initial_patvar_tickss
Nothing -> do
let patvars = map getOccString (collectPatBinders lhs)
patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
return
(zipWith mbCons patvar_ticks
(initial_patvar_tickss ++ repeat []))
-- Add to pattern
let mbCons = maybe id (:)
rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
patvar_tickss = zipWith mbCons patvar_ticks
(snd (pat_ticks pat') ++ repeat [])
return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
-- Only internal stuff, not from source, uses VarBind, so we ignore it. -- Only internal stuff, not from source, uses VarBind, so we ignore it.
...@@ -365,7 +378,6 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind ...@@ -365,7 +378,6 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick bindTick
:: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
bindTick density name pos fvs = do bindTick density name pos fvs = do
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment