[Git][ghc/ghc][master] Misc cleanup
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 29 16:09:11 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b60d6576 by Krzysztof Gogolewski at 2023-08-29T12:08:29-04:00
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
- - - - -
8 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToCmm/TagCheck.hs
- compiler/GHC/Types/Id.hs
- hadrian/src/Rules/Test.hs
Changes:
=====================================
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
=====================================
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.
=====================================
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.
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b60d65769d4f29c5b7d820af45807419c8d097f6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b60d65769d4f29c5b7d820af45807419c8d097f6
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/20230829/7f1312a0/attachment-0001.html>
More information about the ghc-commits
mailing list