[Git][ghc/ghc][master] Scrub various partiality involving empty lists.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Sep 30 21:46:09 UTC 2022
Marge Bot pushed to branch master 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.
- - - - -
15 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/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
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/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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4baf7b1ceaef2d4f49e81e5786a855e22ed864bf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4baf7b1ceaef2d4f49e81e5786a855e22ed864bf
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/4989773c/attachment-0001.html>
More information about the ghc-commits
mailing list