GitLab

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
  -- ---------------------------------------------------------------------