[Git][ghc/ghc][wip/pattern-synonym-docs] 6 commits: Boxity: Don't update Boxity unless worker/wrapper follows (#21754)
Hécate Moonlight (@Kleidukos)
gitlab at gitlab.haskell.org
Sun Oct 2 09:51:41 UTC 2022
Hécate Moonlight pushed to branch wip/pattern-synonym-docs at Glasgow Haskell Compiler / GHC
Commits:
f5e8f493 by Sebastian Graf at 2022-09-30T18:42:13+02:00
Boxity: Don't update Boxity unless worker/wrapper follows (#21754)
A small refactoring in our Core Opt pipeline and some new functions for
transfering argument boxities from one signature to another to facilitate
`Note [Don't change boxity without worker/wrapper]`.
Fixes #21754.
- - - - -
4baf7b1c by M Farkas-Dyck at 2022-09-30T17:45:47-04:00
Scrub various partiality involving empty lists.
Avoids some uses of `head` and `tail`, and some panics when an argument is null.
- - - - -
95ead839 by Alexis King at 2022-10-01T00:37:43-04:00
Fix a bug in continuation capture across multiple stack chunks
- - - - -
22096652 by Bodigrim at 2022-10-01T00:38:22-04:00
Enforce internal invariant of OrdList and fix bugs in viewCons / viewSnoc
`viewCons` used to ignore `Many` constructor completely, returning `VNothing`.
`viewSnoc` violated internal invariant of `Many` being a non-empty list.
- - - - -
39d4b87e by Brandon Chinn at 2022-10-02T09:51:29+00:00
Fix docs for pattern synonyms
- - - - -
63163e21 by Brandon Chinn at 2022-10-02T09:51:29+00:00
Clarify INLINE support for patterns were added in GHC 9.2
- - - - -
29 changed files:
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/Switch.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Pipeline/Types.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Data/OrdList.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Llvm/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Misc.hs
- docs/users_guide/exts/pattern_synonyms.rst
- rts/Continuation.c
- testsuite/tests/rts/continuations/all.T
- + testsuite/tests/rts/continuations/cont_stack_overflow.hs
- testsuite/tests/simplCore/should_compile/spec-inline.stderr
- + testsuite/tests/stranal/sigs/T21754.hs
- + testsuite/tests/stranal/sigs/T21754.stderr
- testsuite/tests/stranal/sigs/all.T
Changes:
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -45,6 +45,7 @@ import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
+import Data.Foldable (toList)
import Data.Functor.Classes (liftCompare)
import Data.Maybe
import Data.List (tails,sortBy)
@@ -247,7 +248,7 @@ pprNode platform node = pp_node <+> pp_debug
(cases, mbdef) = switchTargetsFallThrough ids
ppCase (is,l) = hsep
[ text "case"
- , commafy $ map integer is
+ , commafy $ toList $ fmap integer is
, text ": goto"
, ppr l <> semi
]
=====================================
compiler/GHC/Cmm/Switch.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Cmm.Switch (
createSwitchPlan,
) where
-import GHC.Prelude
+import GHC.Prelude hiding (head)
import GHC.Utils.Outputable
import GHC.Driver.Backend
@@ -20,7 +20,7 @@ import GHC.Utils.Panic
import GHC.Cmm.Dataflow.Label (Label)
import Data.Maybe
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty (..), groupWith, head)
import qualified Data.Map as M
-- Note [Cmm Switches, the general plan]
@@ -200,11 +200,11 @@ switchTargetsToList (SwitchTargets _ _ mbdef branches)
-- | Groups cases with equal targets, suitable for pretty-printing to a
-- c-like switch statement with fall-through semantics.
-switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
+switchTargetsFallThrough :: SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label)
switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
where
- groups = map (\xs -> (map fst (NE.toList xs), snd (NE.head xs))) $
- NE.groupWith snd $
+ groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $
+ groupWith snd $
M.toList branches
-- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -78,7 +78,7 @@ module GHC.CmmToAsm
)
where
-import GHC.Prelude
+import GHC.Prelude hiding (head)
import qualified GHC.CmmToAsm.X86 as X86
import qualified GHC.CmmToAsm.PPC as PPC
@@ -140,7 +140,7 @@ import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream
import Data.List (sortBy)
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (groupAllWith, head)
import Data.Maybe
import Data.Ord ( comparing )
import Control.Monad
@@ -776,8 +776,8 @@ makeImportsDoc config imports
| needImportedSymbols config
= vcat $
(pprGotDeclaration config :) $
- fmap ( pprImportedSymbol config . fst . NE.head) $
- NE.groupAllWith snd $
+ fmap (pprImportedSymbol config . fst . head) $
+ groupAllWith snd $
map doPpr $
imps
| otherwise
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -59,6 +59,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char
import Data.List (intersperse)
+import Data.List.NonEmpty (NonEmpty (..))
import Data.Map (Map)
import qualified Data.Map as Map
import GHC.Float
@@ -347,7 +348,7 @@ pprSwitch platform e ids
rep = typeWidth (cmmExprType platform e)
-- fall through case
- caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+ caseify (ix:|ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
where
do_fallthrough ix =
hsep [ text "case" , pprHexVal platform ix rep <> colon ,
@@ -357,8 +358,6 @@ pprSwitch platform e ids
hsep [ text "case" , pprHexVal platform ix rep <> colon ,
text "goto" , (pprBlockId ident) <> semi ]
- caseify (_ , _ ) = panic "pprSwitch: switch with no cases!"
-
def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi
| otherwise = text "default: __builtin_unreachable();"
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.CmmToLlvm
)
where
-import GHC.Prelude
+import GHC.Prelude hiding ( head )
import GHC.Llvm
import GHC.CmmToLlvm.Base
@@ -37,6 +37,7 @@ import GHC.Utils.Logger
import qualified GHC.Data.Stream as Stream
import Control.Monad ( when, forM_ )
+import Data.List.NonEmpty ( head )
import Data.Maybe ( fromMaybe, catMaybes )
import System.IO
@@ -68,7 +69,7 @@ llvmCodeGen logger cfg h cmm_stream
"System LLVM version: " <> text (llvmVersionStr ver) $$
"We will try though..."
let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X
- let major_ver = head . llvmVersionList $ ver
+ let major_ver = head . llvmVersionNE $ ver
when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $
"Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>
"You are using LLVM version: " <> text (llvmVersionStr ver)
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -59,9 +59,18 @@ _ = pprTrace -- Tired of commenting out the import all the time
-- | Options for the demand analysis
data DmdAnalOpts = DmdAnalOpts
- { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries
- , dmd_unbox_width :: !Int -- ^ Use strict dictionaries
+ { dmd_strict_dicts :: !Bool
+ -- ^ Value of `-fdicts-strict` (on by default).
+ -- When set, all functons are implicitly strict in dictionary args.
+ , dmd_do_boxity :: !Bool
+ -- ^ Governs whether the analysis should update boxity signatures.
+ -- See Note [Don't change boxity without worker/wrapper].
+ , dmd_unbox_width :: !Int
+ -- ^ Value of `-fdmd-unbox-width`.
+ -- See Note [Unboxed demand on function bodies returning small products]
, dmd_max_worker_args :: !Int
+ -- ^ Value of `-fmax-worker-args`.
+ -- Don't unbox anything if we end up with more than this many args.
}
-- This is a strict alternative to (,)
@@ -146,6 +155,40 @@ unforced thunks in demand or strictness information; and it is the
most memory-intensive part of the compilation process, so this added
seqBinds makes a big difference in peak memory usage.
+Note [Don't change boxity without worker/wrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (T21754)
+ f n = n+1
+ {-# NOINLINE f #-}
+With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says
+that it unboxes its argument! Client modules would never be able to cancel away
+the box for n. Likewise we shouldn't give `f` the CPR property.
+
+Similarly, in the last run of DmdAnal before codegen (which does not have a
+worker/wrapper phase) we should not change boxity in any way. Remember: an
+earlier result of the demand analyser, complete with worker/wrapper, has aleady
+given a demand signature (with boxity info) to the function.
+(The "last run" is mainly there to attach demanded-once info to let-bindings.)
+
+In general, we should not run Note [Boxity analysis] unless worker/wrapper
+follows to exploit the boxity and make sure that calling modules can observe the
+reported boxity.
+
+Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only
+if worker/wrapper follows after DmdAnal. If it is not set, and the signature
+is not subject to Note [Boxity for bottoming functions], DmdAnal tries
+to transfer over the previous boxity to the new demand signature, in
+`setIdDmdAndBoxSig`.
+
+Why isn't CprAnal configured with a similar flag? Because if we aren't going to
+do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline)
+
+It might be surprising that we only try to preserve *arg* boxity, not boxity on
+FVs. But FV demands won't make it into interface files anyway, so it's a waste
+of energy.
+Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old
+boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer].
+
Note [Analysing top-level bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a CoreProgram like
@@ -257,6 +300,16 @@ setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of
TopLevel | not (isInterestingTopLevelFn id) -> topDmd
_ -> dmd
+-- | Update the demand signature, but be careful not to change boxity info if
+-- `dmd_do_boxity` is True or if the signature is bottom.
+-- See Note [Don't change boxity without worker/wrapper]
+-- and Note [Boxity for bottoming functions].
+setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id
+setIdDmdAndBoxSig opts id sig = setIdDmdSig id $
+ if dmd_do_boxity opts || isBottomingSig sig
+ then sig
+ else transferArgBoxityDmdSig (idDmdSig id) sig
+
-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- This function handles the up variant.
@@ -1018,7 +1071,8 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div)
- final_id = id `setIdDmdSig` sig
+ opts = ae_opts env
+ final_id = setIdDmdAndBoxSig opts id sig
!final_env = extendAnalEnv top_lvl env final_id sig
-- See Note [Aggregated demand for cardinality]
@@ -1858,8 +1912,9 @@ dmdFix :: TopLevelFlag
dmdFix top_lvl env let_dmd orig_pairs
= loop 1 initial_pairs
where
+ opts = ae_opts env
-- See Note [Initialising strictness]
- initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ]
+ initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ]
| otherwise = orig_pairs
-- If fixed-point iteration does not yield a result we use this instead
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -150,7 +150,7 @@ getCoreToDo dflags rule_base extra_vars
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before (Phase phase)
- | phase `elem` strictnessBefore dflags = CoreDoDemand
+ | phase `elem` strictnessBefore dflags = CoreDoDemand False
maybe_strictness_before _
= CoreDoNothing
@@ -171,8 +171,8 @@ getCoreToDo dflags rule_base extra_vars
simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter
(initGentleSimplMode dflags) rule_base
- dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]
- else [CoreDoDemand,CoreDoCpr]
+ dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]
+ else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]
demand_analyser = (CoreDoPasses (
@@ -340,7 +340,7 @@ getCoreToDo dflags rule_base extra_vars
-- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal
-- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
-- can become /exponentially/ more expensive. See #11731, #12996.
- runWhen (strictness || late_dmd_anal) CoreDoDemand,
+ runWhen (strictness || late_dmd_anal) (CoreDoDemand False),
maybe_rule_check FinalPhase,
@@ -491,8 +491,8 @@ doCorePass pass guts = do
CoreDoExitify -> {-# SCC "Exitify" #-}
updateBinds exitifyProgram
- CoreDoDemand -> {-# SCC "DmdAnal" #-}
- updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts))
+ CoreDoDemand before_ww -> {-# SCC "DmdAnal" #-}
+ updateBindsM (liftIO . dmdAnal logger before_ww dflags fam_envs (mg_rules guts))
CoreDoCpr -> {-# SCC "CprAnal" #-}
updateBindsM (liftIO . cprAnalProgram logger fam_envs)
@@ -557,10 +557,11 @@ ruleCheckPass current_phase pat guts = do
rule_fn (mg_binds guts))
return guts
-dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
-dmdAnal logger dflags fam_envs rules binds = do
+dmdAnal :: Logger -> Bool -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
+dmdAnal logger before_ww dflags fam_envs rules binds = do
let !opts = DmdAnalOpts
{ dmd_strict_dicts = gopt Opt_DictsStrict dflags
+ , dmd_do_boxity = before_ww -- only run Boxity Analysis immediately preceding WW
, dmd_unbox_width = dmdUnboxWidth dflags
, dmd_max_worker_args = maxWorkerArgs dflags
}
=====================================
compiler/GHC/Core/Opt/Pipeline/Types.hs
=====================================
@@ -45,7 +45,8 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreDoStaticArgs
| CoreDoCallArity
| CoreDoExitify
- | CoreDoDemand
+ | CoreDoDemand Bool -- Bool: Do worker/wrapper afterwards?
+ -- See Note [Don't change boxity without worker/wrapper]
| CoreDoCpr
| CoreDoWorkerWrapper
| CoreDoSpecialising
@@ -74,7 +75,8 @@ instance Outputable CoreToDo where
ppr CoreDoStaticArgs = text "Static argument"
ppr CoreDoCallArity = text "Called arity analysis"
ppr CoreDoExitify = text "Exitification transformation"
- ppr CoreDoDemand = text "Demand analysis"
+ ppr (CoreDoDemand True) = text "Demand analysis (including Boxity)"
+ ppr (CoreDoDemand False) = text "Demand analysis"
ppr CoreDoCpr = text "Constructed Product Result analysis"
ppr CoreDoWorkerWrapper = text "Worker Wrapper binds"
ppr CoreDoSpecialising = text "Specialise"
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -63,6 +63,8 @@ import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
import GHC.Core.Unfold
+import Data.List.NonEmpty ( NonEmpty (..) )
+
{-
************************************************************************
* *
@@ -1201,7 +1203,7 @@ specCase env scrut' case_bndr [Alt con args rhs]
| -- See Note [Floating dictionaries out of cases]
interestingDict scrut' (idType case_bndr)
, not (isDeadBinder case_bndr && null sc_args')
- = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
+ = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
scrut_bind = mkDB (NonRec case_bndr_flt scrut')
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1200,12 +1200,9 @@ cpeApp top_env expr
arg_ty' = cpSubstTy env arg_ty
CpeApp (Coercion co)
- -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth
+ -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth
where
co' = cpSubstCo env co
- ss'
- | null ss = []
- | otherwise = tail ss
CpeApp arg -> do
let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make
=====================================
compiler/GHC/Data/BooleanFormula.hs
=====================================
@@ -16,9 +16,10 @@ module GHC.Data.BooleanFormula (
pprBooleanFormula, pprBooleanFormulaNice
) where
-import GHC.Prelude
+import GHC.Prelude hiding ( init, last )
import Data.List ( nub, intersperse )
+import Data.List.NonEmpty ( NonEmpty (..), init, last )
import Data.Data
import GHC.Utils.Monad
@@ -227,7 +228,7 @@ pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
pprAnd p = cparen (p > 1) . pprAnd'
pprAnd' [] = empty
pprAnd' [x,y] = x <+> text "and" <+> y
- pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs
+ pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs)
pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)
instance (OutputableBndr a) => Outputable (BooleanFormula a) where
=====================================
compiler/GHC/Data/OrdList.hs
=====================================
@@ -28,6 +28,8 @@ import GHC.Utils.Misc (strictMap)
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semigroup
infixl 5 `appOL`
@@ -37,7 +39,7 @@ infixr 5 `consOL`
data OrdList a
= None
| One a
- | Many [a] -- Invariant: non-empty
+ | Many (NonEmpty a)
| Cons a (OrdList a)
| Snoc (OrdList a) a
| Two (OrdList a) -- Invariant: non-empty
@@ -100,8 +102,12 @@ pattern ConsOL :: a -> OrdList a -> OrdList a
pattern ConsOL x xs <- (viewCons -> VJust x xs) where
ConsOL x xs = consOL x xs
{-# COMPLETE NilOL, ConsOL #-}
+
viewCons :: OrdList a -> VMaybe a (OrdList a)
-viewCons (One a) = VJust a NilOL
+viewCons None = VNothing
+viewCons (One a) = VJust a NilOL
+viewCons (Many (a :| [])) = VJust a NilOL
+viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs))
viewCons (Cons a as) = VJust a as
viewCons (Snoc as a) = case viewCons as of
VJust a' as' -> VJust a' (Snoc as' a)
@@ -109,15 +115,18 @@ viewCons (Snoc as a) = case viewCons as of
viewCons (Two as1 as2) = case viewCons as1 of
VJust a' as1' -> VJust a' (Two as1' as2)
VNothing -> viewCons as2
-viewCons _ = VNothing
pattern SnocOL :: OrdList a -> a -> OrdList a
pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where
SnocOL xs x = snocOL xs x
{-# COMPLETE NilOL, SnocOL #-}
+
viewSnoc :: OrdList a -> VMaybe (OrdList a) a
-viewSnoc (One a) = VJust NilOL a
-viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a
+viewSnoc None = VNothing
+viewSnoc (One a) = VJust NilOL a
+viewSnoc (Many as) = (`VJust` NE.last as) $ case NE.init as of
+ [] -> NilOL
+ b : bs -> Many (b :| bs)
viewSnoc (Snoc as a) = VJust as a
viewSnoc (Cons a as) = case viewSnoc as of
VJust as' a' -> VJust (Cons a as') a'
@@ -125,18 +134,17 @@ viewSnoc (Cons a as) = case viewSnoc as of
viewSnoc (Two as1 as2) = case viewSnoc as2 of
VJust as2' a' -> VJust (Two as1 as2') a'
VNothing -> viewSnoc as1
-viewSnoc _ = VNothing
headOL None = panic "headOL"
headOL (One a) = a
-headOL (Many as) = head as
+headOL (Many as) = NE.head as
headOL (Cons a _) = a
headOL (Snoc as _) = headOL as
headOL (Two as _) = headOL as
lastOL None = panic "lastOL"
lastOL (One a) = a
-lastOL (Many as) = last as
+lastOL (Many as) = NE.last as
lastOL (Cons _ as) = lastOL as
lastOL (Snoc _ a) = a
lastOL (Two _ as) = lastOL as
@@ -164,7 +172,7 @@ fromOL a = go a []
go (Cons a b) acc = a : go b acc
go (Snoc a b) acc = go a (b:acc)
go (Two a b) acc = go a (go b acc)
- go (Many xs) acc = xs ++ acc
+ go (Many xs) acc = NE.toList xs ++ acc
fromOLReverse :: OrdList a -> [a]
fromOLReverse a = go a []
@@ -175,7 +183,7 @@ fromOLReverse a = go a []
go (Cons a b) acc = go b (a : acc)
go (Snoc a b) acc = b : go a acc
go (Two a b) acc = go b (go a acc)
- go (Many xs) acc = reverse xs ++ acc
+ go (Many xs) acc = reverse (NE.toList xs) ++ acc
mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL = fmap
@@ -192,7 +200,9 @@ mapOL' f (Snoc xs x) = let !x1 = f x
mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1
!b2' = mapOL' f b2
in Two b1' b2'
-mapOL' f (Many xs) = Many $! strictMap f xs
+mapOL' f (Many (x :| xs)) = let !x1 = f x
+ !xs1 = strictMap f xs
+ in Many (x1 :| xs1)
foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL _ z None = z
@@ -214,7 +224,7 @@ foldlOL k z (Many xs) = foldl' k z xs
toOL :: [a] -> OrdList a
toOL [] = None
toOL [x] = One x
-toOL xs = Many xs
+toOL (x : xs) = Many (x :| xs)
reverseOL :: OrdList a -> OrdList a
reverseOL None = None
@@ -222,7 +232,7 @@ reverseOL (One x) = One x
reverseOL (Cons a b) = Snoc (reverseOL b) a
reverseOL (Snoc a b) = Cons b (reverseOL a)
reverseOL (Two a b) = Two (reverseOL b) (reverseOL a)
-reverseOL (Many xs) = Many (reverse xs)
+reverseOL (Many xs) = Many (NE.reverse xs)
-- | Compare not only the values but also the structure of two lists
strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool
=====================================
compiler/GHC/Driver/Config/Core/Lint.hs
=====================================
@@ -83,7 +83,7 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify
-coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal
+coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_stranal
coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal
coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1779,9 +1779,9 @@ getGccSearchDirectory logger dflags key = do
find :: String -> String -> String
find r x = let lst = lines x
val = filter (r `isPrefixOf`) lst
- in if null val
- then []
- else case break (=='=') (head val) of
+ in case val of
+ [] -> []
+ x:_ -> case break (=='=') x of
(_ , []) -> []
(_, (_:xs)) -> xs
=====================================
compiler/GHC/Llvm/Types.hs
=====================================
@@ -181,7 +181,7 @@ getLitType :: LlvmLit -> LlvmType
getLitType (LMIntLit _ t) = t
getLitType (LMFloatLit _ t) = t
getLitType (LMVectorLit []) = panic "getLitType"
-getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls))
+getLitType (LMVectorLit ls@(l:_)) = LMVector (length ls) (getLitType l)
getLitType (LMNullLit t) = t
getLitType (LMUndefLit t) = t
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2513,10 +2513,10 @@ mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns
| isRdrDataCon c
= do
let (fs, ps) = partitionEithers fbinds
- if not (null ps)
- then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $
- PsErrOverloadedRecordDotInvalid
- else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
+ case ps of
+ p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $
+ PsErrOverloadedRecordDotInvalid
+ _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns
| Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $
PsErrDotsInRecordUpdate
@@ -2546,15 +2546,13 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
[ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'
, isQual . rdrNameAmbiguousFieldOcc $ lbl
]
- if not $ null qualifiedFields
- then
- addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $
+ case qualifiedFields of
+ qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $
PsErrOverloadedRecordUpdateNoQualifiedFields
- else -- This is a RecordDotSyntax update.
- return RecordUpd {
- rupd_ext = anns
- , rupd_expr = exp
- , rupd_flds = Right (toProjUpdates fbinds) }
+ _ -> return RecordUpd -- This is a RecordDotSyntax update.
+ { rupd_ext = anns
+ , rupd_expr = exp
+ , rupd_flds = Right (toProjUpdates fbinds) }
where
toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]
toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -178,6 +178,8 @@ import qualified GHC.Data.BooleanFormula as BF
import Data.Functor.Classes ( liftEq )
import Data.List ( sortBy, sort )
+import Data.List.NonEmpty ( NonEmpty (..) )
+import qualified Data.List.NonEmpty as NE
import Data.Ord
import Data.Data ( Data )
import qualified Data.Set as S
@@ -2223,10 +2225,8 @@ type Plan = TcM PlanResult
-- | Try the plans in order. If one fails (by raising an exn), try the next.
-- If one succeeds, take it.
-runPlans :: [Plan] -> TcM PlanResult
-runPlans [] = panic "runPlans"
-runPlans [p] = p
-runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
+runPlans :: NonEmpty Plan -> Plan
+runPlans = foldr1 (flip tryTcDiscardingErrs)
-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
-- GHCi 'environment'.
@@ -2298,30 +2298,31 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
-- See Note [GHCi Plans]
- it_plans = [
+ it_plans =
-- Plan A
do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id)
- ; when (isUnitTy $ it_ty) failM
- ; return stuff },
+ ; when (isUnitTy it_ty) failM
+ ; return stuff } :|
-- Plan B; a naked bind statement
- tcGhciStmts [bind_stmt],
+ [ tcGhciStmts [bind_stmt]
-- Plan C; check that the let-binding is typeable all by itself.
-- If not, fail; if so, try to print it.
-- The two-step process avoids getting two errors: one from
-- the expression itself, and one from the 'print it' part
-- This two-step story is very clunky, alas
- do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
+ , do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
--- checkNoErrs defeats the error recovery of let-bindings
; tcGhciStmts [let_stmt, print_it] } ]
-- Plans where we don't bind "it"
- no_it_plans = [
- tcGhciStmts [no_it_a] ,
- tcGhciStmts [no_it_b] ,
- tcGhciStmts [no_it_c] ]
+ no_it_plans =
+ tcGhciStmts [no_it_a] :|
+ tcGhciStmts [no_it_b] :
+ tcGhciStmts [no_it_c] :
+ []
; generate_it <- goptM Opt_NoIt
@@ -2413,13 +2414,13 @@ tcUserStmt rdr_stmt@(L loc _)
; let print_result_plan
| opt_pr_flag -- The flag says "print result"
, [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder
- = [mk_print_result_plan gi_stmt v]
- | otherwise = []
+ = Just $ mk_print_result_plan gi_stmt v
+ | otherwise = Nothing
-- The plans are:
-- [stmt; print v] if one binder and not v::()
-- [stmt] otherwise
- ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
+ ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt]
; return (plan, fix_env) }
where
mk_print_result_plan stmt v
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -64,7 +64,8 @@ module GHC.Types.Demand (
-- * Demand signatures
DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig,
splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,
- nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,
+ nopSig, botSig, isNopSig, isBottomingSig, isDeadEndSig, isDeadEndAppSig,
+ trimBoxityDmdSig, transferArgBoxityDmdSig,
-- ** Handling arity adjustments
prependArgsDmdSig, etaConvertDmdSig,
@@ -2147,6 +2148,13 @@ isNopSig (DmdSig ty) = isNopDmdType ty
isDeadEndSig :: DmdSig -> Bool
isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res
+-- | True if the signature diverges or throws an imprecise exception in a saturated call.
+-- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'.
+-- See Note [Dead ends]
+-- and Note [Precise vs imprecise exceptions].
+isBottomingSig :: DmdSig -> Bool
+isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv
+
-- | True when the signature indicates all arguments are boxed
onlyBoxedArguments :: DmdSig -> Bool
onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds
@@ -2179,6 +2187,38 @@ trimBoxityDmdType (DmdType fvs ds res) =
trimBoxityDmdSig :: DmdSig -> DmdSig
trimBoxityDmdSig = coerce trimBoxityDmdType
+-- | Transfers the boxity of the left arg to the demand structure of the right
+-- arg. This only makes sense if applied to new and old demands of the same
+-- value.
+transferBoxity :: Demand -> Demand -> Demand
+transferBoxity from to = go_dmd from to
+ where
+ go_dmd (from_n :* from_sd) to_dmd@(to_n :* to_sd)
+ | isAbs from_n || isAbs to_n = to_dmd
+ | otherwise = case (from_sd, to_sd) of
+ (Poly from_b _, Poly _ to_c) ->
+ to_n :* Poly from_b to_c
+ (_, Prod _ to_ds)
+ | Just (from_b, from_ds) <- viewProd (length to_ds) from_sd
+ -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds)
+ (Prod from_b from_ds, _)
+ | Just (_, to_ds) <- viewProd (length from_ds) to_sd
+ -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds)
+ _ -> trimBoxity to_dmd
+
+transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType
+transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res)
+ | equalLength from_ds to_ds
+ = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $
+ DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper]
+ (zipWith transferBoxity from_ds to_ds)
+ to_res
+ | otherwise
+ = trimBoxityDmdType to
+
+transferArgBoxityDmdSig :: DmdSig -> DmdSig -> DmdSig
+transferArgBoxityDmdSig = coerce transferArgBoxityDmdType
+
prependArgsDmdSig :: Int -> DmdSig -> DmdSig
-- ^ Add extra ('topDmd') arguments to a strictness signature.
-- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -825,12 +825,12 @@ pprGlobalRdrEnv locals_only env
remove_locals gres | locals_only = filter isLocalGRE gres
| otherwise = gres
pp [] = empty
- pp gres = hang (ppr occ
+ pp gres@(gre:_) = hang (ppr occ
<+> parens (text "unique" <+> ppr (getUnique occ))
<> colon)
2 (vcat (map ppr gres))
where
- occ = nameOccName (greMangledName (head gres))
+ occ = nameOccName (greMangledName gre)
lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -699,8 +699,8 @@ getUnitDbRefs cfg = do
let base_conf_refs = case e_pkg_path of
Left _ -> system_conf_refs
Right path
- | not (null path) && isSearchPathSeparator (last path)
- -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
+ | Just (xs, x) <- snocView path, isSearchPathSeparator x
+ -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs
| otherwise
-> map PkgDbPath (splitSearchPath path)
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -124,7 +124,7 @@ module GHC.Utils.Misc (
HasDebugCallStack,
) where
-import GHC.Prelude
+import GHC.Prelude hiding ( last )
import GHC.Utils.Exception
import GHC.Utils.Panic.Plain
@@ -133,7 +133,7 @@ import GHC.Utils.Fingerprint
import Data.Data
import qualified Data.List as List
-import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.List.NonEmpty ( NonEmpty(..), last )
import GHC.Exts
import GHC.Stack (HasCallStack)
@@ -750,7 +750,7 @@ last2 = List.foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError)
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
-lastMaybe xs = Just $ last xs
+lastMaybe (x:xs) = Just $ last (x:|xs)
-- | @onJust x m f@ applies f to the value inside the Just or returns the default.
onJust :: b -> Maybe a -> (a->b) -> b
@@ -1293,9 +1293,9 @@ withAtomicRename targetFile f = do
-- string is returned in the first component (and the second one is just
-- empty).
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
-splitLongestPrefix str pred
- | null r_pre = (str, [])
- | otherwise = (reverse (tail r_pre), reverse r_suf)
+splitLongestPrefix str pred = case r_pre of
+ [] -> (str, [])
+ _:r_pre' -> (reverse r_pre', reverse r_suf)
-- 'tail' drops the char satisfying 'pred'
where (r_suf, r_pre) = break pred (reverse str)
=====================================
docs/users_guide/exts/pattern_synonyms.rst
=====================================
@@ -524,9 +524,9 @@ Pragmas for pattern synonyms
----------------------------
The :ref:`inlinable-pragma`, :ref:`inline-pragma` and :ref:`noinline-pragma` are supported for pattern
-synonyms. For example: ::
+synonyms as of GHC 9.2. For example: ::
- patternInlinablePattern x = [x]
+ pattern InlinablePattern x = [x]
{-# INLINABLE InlinablePattern #-}
pattern InlinedPattern x = [x]
{-# INLINE InlinedPattern #-}
=====================================
rts/Continuation.c
=====================================
@@ -472,12 +472,14 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT
stack = pop_stack_chunk(cap, tso);
for (StgWord i = 0; i < full_chunks; i++) {
- memcpy(cont_stack, stack->sp, stack->stack_size * sizeof(StgWord));
- cont_stack += stack->stack_size;
+ const size_t chunk_words = stack->stack + stack->stack_size - stack->sp - sizeofW(StgUnderflowFrame);
+ memcpy(cont_stack, stack->sp, chunk_words * sizeof(StgWord));
+ cont_stack += chunk_words;
stack = pop_stack_chunk(cap, tso);
}
memcpy(cont_stack, stack->sp, last_chunk_words * sizeof(StgWord));
+ cont_stack += last_chunk_words;
stack->sp += last_chunk_words;
}
=====================================
testsuite/tests/rts/continuations/all.T
=====================================
@@ -2,3 +2,4 @@ test('cont_simple_shift', [extra_files(['ContIO.hs'])], multimod_compile_and_run
test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_exn_masking', ''])
test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', ''])
test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', ''])
+test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"'])
=====================================
testsuite/tests/rts/continuations/cont_stack_overflow.hs
=====================================
@@ -0,0 +1,32 @@
+-- This test is run with RTS options that instruct GHC to use a small stack
+-- chunk size (2k), which ensures this test exercises multi-chunk continuation
+-- captures and restores.
+
+import Control.Monad (unless)
+import ContIO
+
+data Answer
+ = Done Int
+ | Yield (IO Int -> IO Answer)
+
+getAnswer :: Answer -> Int
+getAnswer (Done n) = n
+getAnswer (Yield _) = error "getAnswer"
+
+main :: IO ()
+main = do
+ tag <- newPromptTag
+ Yield k <- prompt tag $
+ Done <$> buildBigCont tag 6000
+ n <- getAnswer <$> k (getAnswer <$> k (pure 0))
+ unless (n == 36006000) $
+ error $ "produced wrong value: " ++ show n
+
+buildBigCont :: PromptTag Answer
+ -> Int
+ -> IO Int
+buildBigCont tag size
+ | size <= 0 = control0 tag (\k -> pure (Yield k))
+ | otherwise = do
+ n <- buildBigCont tag (size - 1)
+ pure $! n + size
=====================================
testsuite/tests/simplCore/should_compile/spec-inline.stderr
=====================================
@@ -143,7 +143,7 @@ Roman.foo1 = GHC.Maybe.Just @Int Roman.foo2
foo :: Int -> Int
[GblId,
Arity=1,
- Str=<1!P(L)>,
+ Str=<1L>,
Cpr=1,
Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
=====================================
testsuite/tests/stranal/sigs/T21754.hs
=====================================
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fno-worker-wrapper #-}
+
+module Test where
+
+f :: Int -> Int
+f n = n+1
+{-# NOINLINE f #-}
=====================================
testsuite/tests/stranal/sigs/T21754.stderr
=====================================
@@ -0,0 +1,10 @@
+
+==================== Strictness signatures ====================
+Test.f: <1L>
+
+
+
+==================== Strictness signatures ====================
+Test.f: <1L>
+
+
=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -34,5 +34,6 @@ test('T20746b', normal, compile, [''])
test('T21081', normal, compile, [''])
test('T21119', normal, compile, [''])
test('T21717', normal, compile, [''])
+test('T21754', normal, compile, [''])
test('T21888', normal, compile, [''])
test('T21888a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a704ff0311447c49a393c0ec8cbd528ced348d01...63163e2105b25f8c834c9e520716f2e808f21d6b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a704ff0311447c49a393c0ec8cbd528ced348d01...63163e2105b25f8c834c9e520716f2e808f21d6b
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/20221002/60006093/attachment-0001.html>
More information about the ghc-commits
mailing list