From b60d65769d4f29c5b7d820af45807419c8d097f6 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Mon, 28 Aug 2023 22:10:51 +0200
Subject: [PATCH] Misc cleanup
- Builtin.PrimOps: ReturnsAlg was used only for unboxed tuples.
Rename to ReturnsTuple.
- Builtin.Utils: use SDoc for a panic message.
The comment about <<details unavailable>> was obsoleted by e8d356773b56.
- TagCheck: fix wrong logic. It was zipping a list 'args' with its
version 'args_cmm' after filtering.
- Core.Type: remove an outdated 1999 comment about unlifted polymorphic types
- hadrian: remove leftover debugging print
---
compiler/GHC/Builtin/PrimOps.hs | 8 ++++---
compiler/GHC/Builtin/Types/Prim.hs | 6 +++--
compiler/GHC/Builtin/Utils.hs | 37 +++++++++++++-----------------
compiler/GHC/Core/Type.hs | 2 --
compiler/GHC/StgToCmm/Prim.hs | 4 +---
compiler/GHC/StgToCmm/TagCheck.hs | 8 +++----
compiler/GHC/Types/Id.hs | 3 +--
hadrian/src/Rules/Test.hs | 1 -
8 files changed, 31 insertions(+), 38 deletions(-)
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index b414006a9bcc..93692b09a280 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -35,7 +35,7 @@ import GHC.Builtin.Types
import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )
import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
-import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
+import GHC.Core.TyCon ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) )
import GHC.Core.Type
import GHC.Cmm.Type
@@ -55,6 +55,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
import GHC.Utils.Outputable
+import GHC.Utils.Panic
import GHC.Data.FastString
@@ -857,7 +858,7 @@ primOpSig op
data PrimOpResultInfo
= ReturnsPrim PrimRep
- | ReturnsAlg TyCon
+ | ReturnsTuple
-- Some PrimOps need not return a manifest primitive or algebraic value
-- (i.e. they might return a polymorphic value). These PrimOps *must*
@@ -868,7 +869,8 @@ getPrimOpResultInfo op
= case (primOpInfo op) of
Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)
GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)
- | otherwise -> ReturnsAlg tc
+ | isUnboxedTupleTyCon tc -> ReturnsTuple
+ | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op)
where
tc = tyConAppTyCon ty
-- All primops return a tycon-app result
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 42478295ccba..323d033279e0 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -758,8 +758,10 @@ Wrinkles
are not /apart/: see Note [Type and Constraint are not apart]
(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and
- aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint. Ditto noInlineId
- vs noInlineConstraintId in GHC.Types.Id.Make; see Note [inlineId magic].
+ aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.
+ See Note [Type vs Constraint for error ids] in GHC.Core.Make.
+ Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make;
+ see Note [inlineId magic].
(W3) We need a TypeOrConstraint flag in LitRubbish.
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index 10fb52675232..dff11aacc8f4 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -67,7 +67,7 @@ import GHC.Types.Id.Make
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.TyThing
-import GHC.Types.Unique ( isValidKnownKeyUnique )
+import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )
import GHC.Utils.Outputable
import GHC.Utils.Misc as Utils
@@ -79,7 +79,7 @@ import GHC.Unit.Module.ModIface (IfaceExport)
import GHC.Data.List.SetOps
import Control.Applicative ((<|>))
-import Data.List ( intercalate , find )
+import Data.List ( find )
import Data.Maybe
{-
@@ -116,12 +116,8 @@ Note [About wired-in things]
knownKeyNames :: [Name]
knownKeyNames
| debugIsOn
- , Just badNamesStr <- knownKeyNamesOkay all_names
- = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
- -- NB: We can't use ppr here, because this is sometimes evaluated in a
- -- context where there are no DynFlags available, leading to a cryptic
- -- "<<details unavailable>>" error. (This seems to happen only in the
- -- stage 2 compiler, for reasons I [Richard] have no clue of.)
+ , Just badNamesDoc <- knownKeyNamesOkay all_names
+ = pprPanic "badAllKnownKeyNames" badNamesDoc
| otherwise
= all_names
where
@@ -161,16 +157,15 @@ knownKeyNames
Nothing -> []
-- | Check the known-key names list of consistency.
-knownKeyNamesOkay :: [Name] -> Maybe String
+knownKeyNamesOkay :: [Name] -> Maybe SDoc
knownKeyNamesOkay all_names
| ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
- = Just $ " Out-of-range known-key uniques: ["
- ++ intercalate ", " (map (occNameString . nameOccName) ns) ++
- "]"
+ = Just $ text " Out-of-range known-key uniques: " <>
+ brackets (pprWithCommas (ppr . nameOccName) ns)
| null badNamesPairs
= Nothing
| otherwise
- = Just badNamesStr
+ = Just badNamesDoc
where
namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)
emptyUFM all_names
@@ -178,14 +173,14 @@ knownKeyNamesOkay all_names
badNamesPairs = nonDetUFMToList badNamesEnv
-- It's OK to use nonDetUFMToList here because the ordering only affects
-- the message when we get a panic
- badNamesStrs = map pairToStr badNamesPairs
- badNamesStr = unlines badNamesStrs
-
- pairToStr (uniq, ns) = " " ++
- show uniq ++
- ": [" ++
- intercalate ", " (map (occNameString . nameOccName) ns) ++
- "]"
+ badNamesDoc :: SDoc
+ badNamesDoc = vcat $ map pairToDoc badNamesPairs
+
+ pairToDoc :: (Unique, [Name]) -> SDoc
+ pairToDoc (uniq, ns) = text " " <>
+ pprUniqueAlways uniq <>
+ text ": " <>
+ brackets (pprWithCommas (ppr . nameOccName) ns)
-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
-- known-key thing.
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 9c1b40394858..124ad34a1edb 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -2302,8 +2302,6 @@ isUnliftedType :: HasDebugCallStack => Type -> Bool
-- isUnliftedType returns True for forall'd unlifted types:
-- x :: forall a. Int#
-- I found bindings like these were getting floated to the top level.
- -- They are pretty bogus types, mind you. It would be better never to
- -- construct them
isUnliftedType ty =
case typeLevity_maybe ty of
Just Lifted -> False
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 6f038d0dc47d..d5bd90aa280a 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1717,11 +1717,9 @@ emitPrimOp cfg primop =
-> do reg <- newTemp (primRepCmmType platform rep)
pure [reg]
- ReturnsAlg tycon | isUnboxedTupleTyCon tycon
+ ReturnsTuple
-> do (regs, _hints) <- newUnboxedTupleRegs res_ty
pure regs
-
- _ -> panic "cgOpApp"
f regs
pure $ map (CmmReg . CmmLocal) regs
diff --git a/compiler/GHC/StgToCmm/TagCheck.hs b/compiler/GHC/StgToCmm/TagCheck.hs
index c83b4de5d4ab..f1ef40a803cc 100644
--- a/compiler/GHC/StgToCmm/TagCheck.hs
+++ b/compiler/GHC/StgToCmm/TagCheck.hs
@@ -133,10 +133,10 @@ emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()
emitArgTagCheck info marks args = whenCheckTags $ do
mod <- getModuleName
let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args
- arg_infos <- mapM getCgIdInfo cbv_args
- let arg_cmms = map idInfoToAmode arg_infos
- mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
- zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)
+ forM_ cbv_args $ \arg -> do
+ cginfo <- getCgIdInfo arg
+ let msg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
+ emitTagAssertion msg (idInfoToAmode cginfo)
taggedCgInfo :: CgIdInfo -> Bool
taggedCgInfo cg_info
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 5053245396b3..4f860e87ba89 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -563,8 +563,7 @@ isJoinId id
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
- | isId id = assertPpr (isId id) (ppr id) $
- case Var.idDetails id of
+ | isId id = case Var.idDetails id of
JoinId arity _marks -> JoinPoint arity
_ -> NotJoinPoint
| otherwise = NotJoinPoint
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index e70c604fcfc8..8366e5a23704 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -345,7 +345,6 @@ needTestsuitePackages stg = do
cross <- flag CrossCompiling
when (not cross) $ needIservBins stg
root <- buildRoot
- liftIO $ print stg
-- require the shims for testing stage1
when (stg == stage0InTree) $ do
-- Windows not supported as the wrapper scripts don't work on windows.. we could
--
GitLab