Krzysztof Gogolewski pushed to branch wip/krzysztof-cleanup at Glasgow Haskell Compiler / GHC Commits: 101068c6 by Krzysztof Gogolewski at 2025-06-09T17:13:34+02:00 Minor misc cleanup - Remove outdated comments - Change mkFastString "literal" to fsLit "literal" so that the rule fires, and move "literal" right next to fsLit in StgToCmm/Layout.hs - Simplify code - Add missing cases to rnfRuntimeRep No functional change, except for the missing cases in rnfRuntimeRep. - - - - - 8 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/Stg/Utils.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/Types/RepType.hs - docs/users_guide/ghc_config.py.in - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -425,13 +425,11 @@ coreToStgExpr expr@(App _ _) coreToStgExpr expr@(Lam _ _) = let (args, body) = myCollectBinders expr - in - case filterStgBinders args of - - [] -> coreToStgExpr body + in assertPpr + (null (filterStgBinders args)) + (text "coreToStgExpr: unexpected value lambda: " $$ ppr expr) + (coreToStgExpr body) - _ -> pprPanic "coretoStgExpr" $ - text "Unexpected value lambda:" $$ ppr expr coreToStgExpr (Tick tick expr) = do ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -391,7 +391,7 @@ import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Data.FastString (FastString, mkFastString, fsLit) +import GHC.Data.FastString (FastString, fsLit) import GHC.Types.Id import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) @@ -681,7 +681,7 @@ elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _ elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts | isUnboxedSumBndr bndr - = do tag_bndr <- mkId (mkFastString "tag") tagTy + = do tag_bndr <- mkId (fsLit "tag") tagTy -- this won't be used but we need a binder anyway let rho1 = extendRho rho bndr (MultiVal args) scrut' = case tag_arg of @@ -871,10 +871,9 @@ mapSumIdBinders alt_bndr args rhs rho0 -- text "rhs" <+> ppr rhs $$ -- text "rhs_with_casts" <+> ppr rhs_with_casts -- ) $ - if isMultiValBndr alt_bndr - then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) - else assert (typed_id_args `lengthIs` 1) $ - return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs) + case typed_id_args of + [arg] -> return (extendRho rho0 alt_bndr (UnaryVal arg), rhs_with_casts rhs) + _ -> return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) -- Convert the argument to the given type, and wrap the conversion -- around the given expression. Use the given Id as a name for the @@ -923,7 +922,7 @@ mkUbxSum dc ty_args args0 us = let _ :| sum_slots = ubxSumRepType ty_args -- drop tag slot - field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) + field_slots = (mapMaybe (repSlotTy . stgArgRep1) args0) tag = dataConTag dc layout' = layoutUbxSum sum_slots field_slots @@ -1076,13 +1075,13 @@ unariseArgBinder is_con_arg rho x = -- break the post-unarisation invariant that says unboxed tuple/sum -- binders should vanish. See Note [Post-unarisation invariants]. | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x) - -> do x' <- mkId (mkFastString "us") (primRepToType rep) + -> do x' <- mkId (fsLit "us") (primRepToType rep) return (extendRho rho x (MultiVal [StgVarArg x']), [x']) | otherwise -> return (extendRhoWithoutValue rho x, [x]) reps -> do - xs <- mkIds (mkFastString "us") (map primRepToType reps) + xs <- mkIds (fsLit "us") (map primRepToType reps) return (extendRho rho x (MultiVal (map StgVarArg xs)), xs) -------------------------------------------------------------------------------- @@ -1150,13 +1149,6 @@ mkIds fs tys = mkUnarisedIds fs tys mkId :: FastString -> NvUnaryType -> UniqSM Id mkId s t = mkUnarisedId s t -isMultiValBndr :: Id -> Bool -isMultiValBndr id - | [_] <- typePrimRep (idType id) - = False - | otherwise - = True - isUnboxedSumBndr :: Id -> Bool isUnboxedSumBndr = isUnboxedSumType . idType ===================================== compiler/GHC/Stg/Utils.hs ===================================== @@ -41,9 +41,6 @@ mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id mkUnarisedId s t = mkSysLocalM s ManyTy t --- Checks if id is a top level error application. --- isErrorAp_maybe :: Id -> - -- | Extract the default case alternative -- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b)) findDefaultStg ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -390,12 +390,12 @@ slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V), stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)] - save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit $ "stg_restore_cccs_" ++ arg_reps) - arg_reps = case maximum (fmap fst args1) of - V64 -> "v64" - V32 -> "v32" - V16 -> "v16" - _ -> "d" + save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId label_name + label_name = case maximum (fmap fst args1) of + V64 -> fsLit "stg_restore_cccs_v64" + V32 -> fsLit "stg_restore_cccs_v32" + V16 -> fsLit "stg_restore_cccs_v16" + _ -> fsLit "stg_restore_cccs_d" ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -295,11 +295,9 @@ instance Outputable SlotTy where ppr FloatSlot = text "FloatSlot" ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e -repSlotTy :: [PrimRep] -> Maybe SlotTy -repSlotTy reps = case reps of - [] -> Nothing - [rep] -> Just (primRepSlot rep) - _ -> pprPanic "repSlotTy" (ppr reps) +repSlotTy :: PrimOrVoidRep -> Maybe SlotTy +repSlotTy VoidRep = Nothing +repSlotTy (NVRep rep) = Just (primRepSlot rep) primRepSlot :: PrimRep -> SlotTy primRepSlot (BoxedRep mlev) = case mlev of ===================================== docs/users_guide/ghc_config.py.in ===================================== @@ -15,8 +15,6 @@ else: libs_base_uri = '../libraries' -# N.B. If you add a package to this list be sure to also add a corresponding -# LIBRARY_VERSION macro call to configure.ac. lib_versions = { 'base': '@LIBRARY_base_UNIT_ID@', 'ghc-prim': '@LIBRARY_ghc_prim_UNIT_ID@', ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs ===================================== @@ -167,6 +167,9 @@ rnfKindRep (KindRepTypeLitD _ t) = rnfString t rnfRuntimeRep :: RuntimeRep -> () rnfRuntimeRep (VecRep !_ !_) = () +rnfRuntimeRep (TupleRep rs) = rnfList rnfRuntimeRep rs +rnfRuntimeRep (SumRep rs) = rnfList rnfRuntimeRep rs +rnfRuntimeRep (BoxedRep !_) = () rnfRuntimeRep !_ = () rnfList :: (a -> ()) -> [a] -> () ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2294,7 +2294,7 @@ instance ExactPrint (HsBind GhcPs) where bind' <- markAnnotated bind return (PatSynBind x bind') - exact x = error $ "HsBind: exact for " ++ showAst x + exact (VarBind x _ _) = dataConCantHappen x -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/101068c6fa26e0192dd91e44f63e347a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/101068c6fa26e0192dd91e44f63e347a... You're receiving this email because of your account on gitlab.haskell.org.