diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 6f85f587169e0bf610d616807c33aa37c640b239..b8e5532f9b90982dd23b618fa666aea925ab9a62 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -2129,7 +2129,7 @@ stripNArgs 0 e = Just e stripNArgs n (App f _) = stripNArgs (n - 1) f stripNArgs _ _ = Nothing --- | Like @collectArgs@, but also collects looks through floatable +-- | Like @collectArgs@, but also looks through floatable -- ticks if it means that we can find more arguments. collectArgsTicks :: (CoreTickish -> Bool) -> Expr b -> (Expr b, [Arg b], [CoreTickish]) diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 49ec9b55c1c6afa72db94ae96bacf2cd6625c07f..6efec52b23cbeaac3e403a748396bddcd1b87469 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, LambdaCase #-} #if __GLASGOW_HASKELL__ < 905 {-# LANGUAGE PatternSynonyms #-} #endif @@ -1478,7 +1478,8 @@ scExpr' env (Type t) = scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _ e@(Lit {}) = return (nullUsage, e) scExpr' env (Tick t e) = do (usg, e') <- scExpr env e - return (usg, Tick t e') + (usg_t, t') <- scTickish env t + return (combineUsage usg usg_t, Tick t' e') scExpr' env (Cast e co) = do (usg, e') <- scExpr env e return (usg, mkCast e' (scSubstCo env co)) -- Important to use mkCast here @@ -1537,6 +1538,17 @@ scExpr' env (Case scrut b ty alts) ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } +-- | Substitute the free variables captured by a breakpoint. +-- Variables are dropped if they have a non-variable substitution, like in +-- 'GHC.Opt.Specialise.specTickish'. +scTickish :: ScEnv -> CoreTickish -> UniqSM (ScUsage, CoreTickish) +scTickish env = \case + Breakpoint ext i fv modl -> do + (usg, fv') <- unzip <$> mapM (\ v -> scExpr env (Var v)) fv + pure (combineUsages usg, Breakpoint ext i [v | Var v <- fv'] modl) + t@ProfNote {} -> pure (nullUsage, t) + t@HpcTick {} -> pure (nullUsage, t) + t@SourceNote {} -> pure (nullUsage, t) {- Note [Do not specialise evals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst index 43cb2804e42c7ad781436669524fd2094b5869b9..bc56214d4b9618d89809adc3224a4fda68847ba0 100644 --- a/docs/users_guide/using-optimisation.rst +++ b/docs/users_guide/using-optimisation.rst @@ -993,8 +993,8 @@ as such you shouldn't need to set any of them explicitly. A flag last' x (y : ys) = last' y ys As well avoid unnecessary pattern matching it also helps avoid - unnecessary allocation. This applies when a argument is strict in - the recursive call to itself but not on the initial entry. As strict + unnecessary allocation. This applies when an argument is strict in + the recursive call to itself but not on the initial entry. A strict recursive branch of the function is created similar to the above example. diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 2eccbac3a3a056745e4e69ee5f992c961032cccb..dcefd71687faa510f0722064ee4f60874c52f934 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -477,7 +477,7 @@ test('T23012', normal, compile, ['-O']) test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques']) test('T23024', normal, multimod_compile, ['T23024', '-O -v0']) test('T23026', normal, compile, ['-O']) -test('T23267', [expect_broken(23267), only_ways(['ghci-opt']), extra_hc_opts('-fspec-constr')], ghci_script, ['T23267.script']) +test('T23267', [only_ways(['ghci-opt']), extra_hc_opts('-fspec-constr')], ghci_script, ['T23267.script']) test('T23362', normal, compile, ['-O']) test('T23307', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])