summaryrefslogtreecommitdiff
path: root/compiler/GHC/Core
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Core')
-rw-r--r--compiler/GHC/Core/InstEnv.hs16
-rw-r--r--compiler/GHC/Core/Lint.hs4
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs5
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs16
-rw-r--r--compiler/GHC/Core/Utils.hs14
5 files changed, 34 insertions, 21 deletions
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 53d7077e61..af2045caac 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -32,7 +32,7 @@ module GHC.Core.InstEnv (
isOverlappable, isOverlapping, isIncoherent
) where
-import GHC.Prelude
+import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker,
-- and depends on TcType in many ways
@@ -50,6 +50,8 @@ import GHC.Core.Unify
import GHC.Types.Basic
import GHC.Types.Id
import Data.Data ( Data )
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
import Data.Maybe ( isJust )
import GHC.Utils.Outputable
@@ -280,16 +282,18 @@ mkLocalInstance dfun oflag tvs cls tys
-- See Note [When exactly is an instance decl an orphan?]
orph | is_local cls_name = NotOrphan (nameOccName cls_name)
- | all notOrphan mb_ns = assert (not (null mb_ns)) $ head mb_ns
+ | all notOrphan mb_ns = NE.head mb_ns
| otherwise = IsOrphan
notOrphan NotOrphan{} = True
notOrphan _ = False
- mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name
- -- that is not in the "determined" arguments
- mb_ns | null fds = [choose_one arg_names]
- | otherwise = map do_one fds
+ mb_ns :: NonEmpty IsOrphan
+ -- One for each fundep; a locally-defined name
+ -- that is not in the "determined" arguments
+ mb_ns = case nonEmpty fds of
+ Nothing -> NE.singleton (choose_one arg_names)
+ Just fds -> fmap do_one fds
do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names
, not (tv `elem` rtvs)]
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 04f685de55..f983c49d6f 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -3196,8 +3196,8 @@ dumpLoc (UnfoldingOf b)
dumpLoc (BodyOfLetRec [])
= (noSrcLoc, text "In body of a letrec with no binders")
-dumpLoc (BodyOfLetRec bs@(_:_))
- = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs)
+dumpLoc (BodyOfLetRec bs@(b:_))
+ = ( getSrcLoc b, text "In the body of letrec with binders" <+> pp_binders bs)
dumpLoc (AnExpr e)
= (noSrcLoc, text "In the expression:" <+> ppr e)
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index a195f3997e..e06d4ed06d 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -70,6 +70,7 @@ import GHC.Unit.External
import Data.Bifunctor ( bimap )
import Data.Dynamic
+import Data.Maybe (listToMaybe)
import Data.Word
import Control.Monad
import Control.Applicative ( Alternative(..) )
@@ -328,8 +329,8 @@ getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleE
getFirstAnnotations deserialize guts
= bimap mod name <$> getAnnotations deserialize guts
where
- mod = mapModuleEnv head . filterModuleEnv (const $ not . null)
- name = mapNameEnv head . filterNameEnv (not . null)
+ mod = mapMaybeModuleEnv (const listToMaybe)
+ name = mapMaybeNameEnv listToMaybe
{-
Note [Annotations]
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index bf6393f292..5e59e149a9 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -22,7 +22,7 @@ module GHC.Core.Opt.OccurAnal (
zapLambdaBndrs
) where
-import GHC.Prelude
+import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Core
import GHC.Core.FVs
@@ -59,6 +59,8 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL, mapAccumR)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import qualified Data.List.NonEmpty as NE
{-
************************************************************************
@@ -3129,7 +3131,7 @@ tagNonRecBinder :: TopLevelFlag -- At top level?
tagNonRecBinder lvl usage binder
= let
occ = lookupDetails usage binder
- will_be_join = decideJoinPointHood lvl usage [binder]
+ will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
occ' | will_be_join = -- must already be marked AlwaysTailCalled
assert (isAlwaysTailCalled occ) occ
| otherwise = markNonTail occ
@@ -3154,7 +3156,11 @@ tagRecBinders lvl body_uds details_s
-- 1. Determine join-point-hood of whole group, as determined by
-- the *unadjusted* usage details
unadj_uds = foldr andUDs body_uds rhs_udss
- will_be_joins = decideJoinPointHood lvl unadj_uds bndrs
+
+ -- This is only used in `mb_join_arity`, to adjust each `Details` in `details_s`, thus,
+ -- when `bndrs` is non-empty. So, we only write `maybe False` as `decideJoinPointHood`
+ -- takes a `NonEmpty CoreBndr`; the default value `False` won't affect program behavior.
+ will_be_joins = maybe False (decideJoinPointHood lvl unadj_uds) (nonEmpty bndrs)
-- 2. Adjust usage details of each RHS, taking into account the
-- join-point-hood decision
@@ -3210,12 +3216,12 @@ setBinderOcc occ_info bndr
--
-- See Note [Invariants on join points] in "GHC.Core".
decideJoinPointHood :: TopLevelFlag -> UsageDetails
- -> [CoreBndr]
+ -> NonEmpty CoreBndr
-> Bool
decideJoinPointHood TopLevel _ _
= False
decideJoinPointHood NotTopLevel usage bndrs
- | isJoinId (head bndrs)
+ | isJoinId (NE.head bndrs)
= warnPprTrace (not all_ok)
"OccurAnal failed to rediscover join point(s)" (ppr bndrs)
all_ok
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 02cd2bf8af..2dc3432ddd 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -2152,14 +2152,17 @@ diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
diffBinds top env binds1 = go (length binds1) env binds1
where go _ env [] []
= ([], env)
- go fuel env binds1 binds2
- -- No binds left to compare? Bail out early.
- | null binds1 || null binds2
- = (warn env binds1 binds2, env)
+ go _fuel env [] binds2
+ -- No binds remaining to compare on the left? Bail out early.
+ = (warn env [] binds2, env)
+ go _fuel env binds1 []
+ -- No binds remaining to compare on the right? Bail out early.
+ = (warn env binds1 [], env)
+ go fuel env binds1@(bind1:_) binds2@(_:_)
-- Iterated over all binds without finding a match? Then
-- try speculatively matching binders by order.
| fuel == 0
- = if not $ env `inRnEnvL` fst (head binds1)
+ = if not $ env `inRnEnvL` fst bind1
then let env' = uncurry (rnBndrs2 env) $ unzip $
zip (sort $ map fst binds1) (sort $ map fst binds2)
in go (length binds1) env' binds1 binds2
@@ -2175,7 +2178,6 @@ diffBinds top env binds1 = go (length binds1) env binds1
binds1 (binds2l ++ binds2r)
| otherwise -- No match, so push back (FIXME O(n^2))
= go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2
- go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough
-- We have tried everything, but couldn't find a good match. So
-- now we just return the comparison results when we pair up
View Lorry Controller Status