[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Fix VoidRep handling in ghci debugger
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jan 5 00:57:28 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
76a83aed by Krzysztof Gogolewski at 2024-01-04T19:57:09-05:00
Fix VoidRep handling in ghci debugger
'go' inside extractSubTerms was giving a bad result given a VoidRep,
attempting to round towards the next multiple of 0.
I don't understand much about the debugger but the code should be better
than it was.
Fixes #24306
- - - - -
c89c7490 by Krzysztof Gogolewski at 2024-01-04T19:57:09-05:00
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.
- - - - -
13 changed files:
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/RepType.hs
- + testsuite/tests/ghci.debugger/scripts/T24306.hs
- + testsuite/tests/ghci.debugger/scripts/T24306.script
- + testsuite/tests/ghci.debugger/scripts/T24306.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
Changes:
=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -888,13 +888,13 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
(ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
| otherwise
- = case typePrimRepArgs ty of
- rep_ty :| [] -> do
+ = case typePrimRep ty of
+ [rep_ty] -> do
(ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty
(ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
return (ptr_i, arr_i, term0 : terms1)
- rep_ty :| rep_tys -> do
- (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys)
+ rep_tys -> do
+ (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
(ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
=====================================
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
=====================================
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
=====================================
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 at . Return the values which the stack
=====================================
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
=====================================
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)
-------------------------------------------------------------------------
--
=====================================
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
=====================================
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
=====================================
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)
=====================================
testsuite/tests/ghci.debugger/scripts/T24306.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE UnboxedTuples, UnliftedNewtypes, DataKinds, MagicHash #-}
+module T24306 where
+
+import GHC.Exts
+
+newtype A = MkA (# #)
+data T = T Int# A Int#
+
+x = T 1# (MkA (# #)) 2#
=====================================
testsuite/tests/ghci.debugger/scripts/T24306.script
=====================================
@@ -0,0 +1,2 @@
+:load T24306
+:force x
=====================================
testsuite/tests/ghci.debugger/scripts/T24306.stdout
=====================================
@@ -0,0 +1 @@
+x = T 1 (MkA (##)) 2
=====================================
testsuite/tests/ghci.debugger/scripts/all.T
=====================================
@@ -140,3 +140,4 @@ test('break030',
['break030.script'],
)
test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script'])
+test('T24306', normal, ghci_script, ['T24306.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff515cd42501eb4cb20a5ff63f2cf8637d9f7bd5...c89c74905dc197b3931b23aafe04b5c79c7439dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff515cd42501eb4cb20a5ff63f2cf8637d9f7bd5...c89c74905dc197b3931b23aafe04b5c79c7439dd
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/20240104/9c65179b/attachment-0001.html>
More information about the ghc-commits
mailing list