[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Scrub various partiality involving empty lists.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Oct 1 01:17:58 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
7ffb11a1 by Alexis King at 2022-09-30T21:17:32-04:00
Fix a bug in continuation capture across multiple stack chunks
- - - - -
2de0bcf0 by Bodigrim at 2022-09-30T21:17:35-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.
- - - - -
19 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/Specialise.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Data/OrdList.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Llvm/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Misc.hs
- rts/Continuation.c
- testsuite/tests/rts/continuations/all.T
- + testsuite/tests/rts/continuations/cont_stack_overflow.hs
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/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/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/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)
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b36624262c1956f7fd2ba8b50b5fe14cd9e83e9...2de0bcf0672eda4fc8f701ae53bfecc8524bde48
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6b36624262c1956f7fd2ba8b50b5fe14cd9e83e9...2de0bcf0672eda4fc8f701ae53bfecc8524bde48
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/20220930/e3e07c84/attachment-0001.html>
More information about the ghc-commits
mailing list