From 90ea574e9cdac4c57e91ce7fdae7fbbccf344e24 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krz.gogolewski@gmail.com>
Date: Wed, 3 Jan 2024 12:52:09 +0100
Subject: [PATCH] VoidRep-related refactor
* In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep,
bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1.
All of them were duplicates.
* In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to
PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out.
* In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out
VoidRep from the result of typePrimRep. But typePrimRep never returns
VoidRep - remove the filtering.
---
compiler/GHC/Stg/Lint.hs | 7 ++---
compiler/GHC/Stg/Unarise.hs | 17 +++++-------
compiler/GHC/StgToByteCode.hs | 49 ++++++++++-----------------------
compiler/GHC/StgToCmm.hs | 2 +-
compiler/GHC/StgToCmm/Layout.hs | 17 ++++--------
compiler/GHC/StgToCmm/Ticky.hs | 8 +++---
compiler/GHC/Types/Id/Make.hs | 5 ++--
compiler/GHC/Types/RepType.hs | 23 +++++++---------
8 files changed, 48 insertions(+), 80 deletions(-)
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 0616fd0aa48e..3a6c45b9918e 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -381,9 +381,9 @@ lintStgAppReps fun args = do
| actual_rep == expected_rep
= match_args actual_reps_left expected_reps_left
- -- Check for void rep which can be either an empty list *or* [VoidRep]
- -- No, typePrimRep_maybe will never return a result containing VoidRep.
- -- We should refactor to make this obvious from the types.
+ -- Check for void rep (empty list)
+ -- Note typePrimRep_maybe will never return a result containing VoidRep.
+ -- We should refactor to make this obvious from the types.
| isVoidRep actual_rep && isVoidRep expected_rep
= match_args actual_reps_left expected_reps_left
@@ -410,7 +410,6 @@ lintStgAppReps fun args = do
text "unarised?:" <> ppr (lf_unarised lf))
where
isVoidRep [] = True
- isVoidRep [VoidRep] = True
isVoidRep _ = False
-- Try to strip one non-void arg rep from the current argument type returning
-- the remaining list of arguments. We return Nothing for invalid input which
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 5c850db995e9..886f4796f5d5 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -808,15 +808,13 @@ mapSumIdBinders alt_bndr args rhs rho0
-- Select only the args which contain parts of the current field.
id_arg_exprs = [ args !! i | i <- layout1 ]
id_vars = [v | StgVarArg v <- id_arg_exprs]
- -- Output types for the field binders based on their rep
- id_tys = map primRepToType fld_reps
- typed_id_arg_input = assert (equalLength id_vars id_tys) $
- zip3 id_vars id_tys uss
+ typed_id_arg_input = assert (equalLength id_vars fld_reps) $
+ zip3 id_vars fld_reps uss
- mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
- mkCastInput (id,tar_type,bndr_us) =
- let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type)
+ mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
+ mkCastInput (id,rep,bndr_us) =
+ let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep
cst_opts = zip3 ops types $ uniqsFromSupply bndr_us
out_id = case cst_opts of
[] -> id
@@ -834,7 +832,7 @@ mapSumIdBinders alt_bndr args rhs rho0
typed_id_args = map StgVarArg typed_ids
-- pprTrace "mapSumIdBinders"
- -- (text "id_tys" <+> ppr id_tys $$
+ -- (text "fld_reps" <+> ppr fld_reps $$
-- text "id_args" <+> ppr id_arg_exprs $$
-- text "rhs" <+> ppr rhs $$
-- text "rhs_with_casts" <+> ppr rhs_with_casts
@@ -925,8 +923,7 @@ mkUbxSum dc ty_args args0 us
castArg us slot_ty arg
-- Cast the argument to the type of the slot if required
| slotPrimRep slot_ty /= stgArgRep1 arg
- , out_ty <- primRepToType $ slotPrimRep slot_ty
- , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty
+ , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty
, not . null $ ops
= let (us1,us2) = splitUniqSupply us
cast_uqs = uniqsFromSupply us1
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index b55594562a8b..25a08dcf121d 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -57,7 +57,9 @@ import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Exception (evaluate)
-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep,
+ addIdReps, addArgReps,
+ nonVoidIds, nonVoidStgArgs )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
@@ -80,7 +82,6 @@ import Data.Coerce (coerce)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
-import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified GHC.Data.FiniteMap as Map
@@ -372,7 +373,7 @@ schemeR_wrk fvs nm original_body (args, body)
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
-- make the arg bitmap
- bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
+ bits = argBits platform (reverse (map (idArgRep platform) all_args))
bitmap_size = genericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -528,7 +529,7 @@ returnUnboxedTuple
returnUnboxedTuple d s p es = do
profile <- getProfile
let platform = profilePlatform profile
- arg_ty e = primRepCmmType platform (atomPrimRep e)
+ arg_ty e = primRepCmmType platform (stgArgRep1 e)
(call_info, tuple_components) = layoutNativeCall profile
NativeTupleReturn
d
@@ -544,7 +545,7 @@ returnUnboxedTuple d s p es = do
ret <- returnUnliftedReps d
s
(wordsToBytes platform $ nativeCallSize call_info)
- (filter non_void $ map atomPrimRep es)
+ (filter non_void $ map stgArgRep1 es)
return (mconcat pushes `appOL` ret)
-- Compile code to apply the given expression to the remaining args
@@ -745,11 +746,7 @@ mkConAppCode orig_d _ p con args = app_code
let platform = profilePlatform profile
non_voids =
- [ NonVoid (prim_rep, arg)
- | arg <- args
- , let prim_rep = atomPrimRep arg
- , not (isVoidRep prim_rep)
- ]
+ addArgReps (nonVoidStgArgs args)
(_, _, args_offsets) =
mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
@@ -931,7 +928,7 @@ doCase d s p scrut bndr alts
rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
| isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
- let bndr_ty = primRepCmmType platform . bcIdPrimRep
+ let bndr_ty = primRepCmmType platform . idPrimRep
tuple_start = d_bndr
(call_info, args_offsets) =
layoutNativeCall profile
@@ -947,7 +944,7 @@ doCase d s p scrut bndr alts
wordsToBytes platform (nativeCallSize call_info) +
offset)
| (arg, offset) <- args_offsets
- , not (isVoidRep $ bcIdPrimRep arg)]
+ , not (isVoidRep $ idPrimRep arg)]
p_alts
in do
rhs_code <- schemeE stack_bot s p' rhs
@@ -956,9 +953,7 @@ doCase d s p scrut bndr alts
| otherwise =
let (tot_wds, _ptrs_wds, args_offsets) =
mkVirtHeapOffsets profile NoHeader
- [ NonVoid (bcIdPrimRep id, id)
- | NonVoid id <- nonVoidIds real_bndrs
- ]
+ (addIdReps (nonVoidIds real_bndrs))
size = WordOff tot_wds
stack_bot = d_alts + wordsToBytes platform size
@@ -1052,7 +1047,7 @@ doCase d s p scrut bndr alts
rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p
spread id offset | isUnboxedTupleType (idType id) ||
isUnboxedSumType (idType id) = Nothing
- | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset)
+ | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset)
| otherwise = Nothing
where rel_offset = bytesToWords platform (d - offset)
@@ -1478,7 +1473,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
return ((code, AddrRep) : rest)
pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa
rest <- pargs (d + sz_a) az
- return ((code_a, atomPrimRep aa) : rest)
+ return ((code_a, stgArgRep1 aa) : rest)
code_n_reps <- pargs d0 args_r_to_l
let
@@ -2126,7 +2121,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe = Map.lookup
idSizeW :: Platform -> Id -> WordOff
-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
+idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon platform var
@@ -2136,17 +2131,7 @@ idSizeCon platform var
wordsToBytes platform .
WordOff . sum . map (argRepSizeW platform . toArgRep platform) .
typePrimRep . idType $ var
- | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))
-
-bcIdArgRep :: Platform -> Id -> ArgRep
-bcIdArgRep platform = toArgRep platform . bcIdPrimRep
-
-bcIdPrimRep :: Id -> PrimRep
-bcIdPrimRep id
- | rep :| [] <- typePrimRepArgs (idType id)
- = rep
- | otherwise
- = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
+ | otherwise = ByteOff (primRepSizeB platform (idPrimRep var))
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
@@ -2185,12 +2170,8 @@ mkSlideW !n !ws
-atomPrimRep :: StgArg -> PrimRep
-atomPrimRep (StgVarArg v) = bcIdPrimRep v
-atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
-
atomRep :: Platform -> StgArg -> ArgRep
-atomRep platform e = toArgRep platform (atomPrimRep e)
+atomRep platform e = toArgRep platform (stgArgRep1 e)
-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
-- has initial depth @original_depth@. Return the values which the stack
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 739b4c94963f..f50d591f8025 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -257,7 +257,7 @@ cgDataCon mn data_con
arg_reps = [ NonVoid rep_ty
| ty <- dataConRepArgTys data_con
, rep_ty <- typePrimRep (scaledThing ty)
- , not (isVoidRep rep_ty) ]
+ ]
; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
-- NB: the closure pointer is assumed *untagged* on
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index 13164241505b..58b1add95d41 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout (
mkVirtConstrSizes,
getHpRelOffset,
- ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
+ ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
getArgAmode, getNonVoidArgAmodes
) where
@@ -328,10 +328,10 @@ getArgRepsAmodes args = do
platform <- profilePlatform <$> getProfile
mapM (getArgRepAmode platform) args
where getArgRepAmode platform arg
- | V <- rep = return (V, Nothing)
- | otherwise = do expr <- getArgAmode (NonVoid arg)
- return (rep, Just expr)
- where rep = toArgRep platform (stgArgRep1 arg)
+ = case stgArgRep1 arg of
+ VoidRep -> return (V, Nothing)
+ rep -> do expr <- getArgAmode (NonVoid arg)
+ return (toArgRep platform rep, Just expr)
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [] = []
@@ -603,12 +603,7 @@ getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
-- so the result list may be shorter than the argument list
-getNonVoidArgAmodes [] = return []
-getNonVoidArgAmodes (arg:args)
- | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args
- | otherwise = do { amode <- getArgAmode (NonVoid arg)
- ; amodes <- getNonVoidArgAmodes args
- ; return ( amode : amodes ) }
+getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args)
-------------------------------------------------------------------------
--
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index c424e9f8bcc0..f3cd7dc327c6 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
tickyDirectCall arity args
| args `lengthIs` arity = tickyKnownCallExact
| otherwise = do tickyKnownCallExtraArgs
- tickySlowCallPat (map stgArgRep1 (drop arity args))
+ tickySlowCallPat (drop arity args)
tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
@@ -610,12 +610,12 @@ tickySlowCall lf_info args = do
if isKnownFun lf_info
then tickyKnownCallTooFewArgs
else tickyUnknownCall
- tickySlowCallPat (map stgArgRep1 args)
+ tickySlowCallPat args
-tickySlowCallPat :: [PrimRep] -> FCode ()
+tickySlowCallPat :: [StgArg] -> FCode ()
tickySlowCallPat args = ifTicky $ do
platform <- profilePlatform <$> getProfile
- let argReps = map (toArgRep platform) args
+ let argReps = map (toArgRep platform . stgArgRep1) args
(_, n_matched) = slowCallPattern argReps
if n_matched > 0 && args `lengthIs` n_matched
then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 0ff8a51cd1cf..d2cb4dea6c5f 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1525,11 +1525,10 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty
-- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]
is_small_rep =
let -- Neccesary to look through unboxed tuples.
+ -- Note typePrimRep never returns VoidRep
prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys
- -- Void types are erased when unpacked so we
- nv_prim_reps = filter (not . isVoidRep) prim_reps
-- And then get the actual size of the unpacked constructor.
- rep_size = sum $ map primRepSizeW64_B nv_prim_reps
+ rep_size = sum $ map primRepSizeW64_B prim_reps
in rep_size <= 8
is_sum :: [DataCon] -> Bool
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index f82e15e2ab7e..7a31b650d57a 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -160,21 +160,18 @@ dataConRuntimeRepStrictness dc =
go repMarks repTys []
where
go (mark:marks) (ty:types) out_marks
- -- Zero-width argument, mark is irrelevant at runtime.
- | -- pprTrace "VoidTy" (ppr ty) $
- (isZeroBitTy ty)
- = go marks types out_marks
- -- Single rep argument, e.g. Int
- -- Keep mark as-is
- | [_] <- reps
- = go marks types (mark:out_marks)
- -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)
- -- Make up one non-strict mark per runtime argument.
- | otherwise -- TODO: Assert real_reps /= null
- = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks)
+ = case reps of
+ -- Zero-width argument, mark is irrelevant at runtime.
+ [] -> -- pprTrace "VoidTy" (ppr ty) $
+ go marks types out_marks
+ -- Single rep argument, e.g. Int
+ -- Keep mark as-is
+ [_] -> go marks types (mark:out_marks)
+ -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)
+ -- Make up one non-strict mark per runtime argument.
+ _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks)
where
reps = typePrimRep ty
- real_reps = filter (not . isVoidRep) $ reps
go [] [] out_marks = reverse out_marks
go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o)
--
GitLab