summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2022-06-14 16:36:04 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-06-22 22:01:22 -0400
commit531205ac090be2dc0c544c1a34c6d3b665aa558a (patch)
tree1133ec150ab9530bed1c7f59321b2e08ff1efea9
parent5d45aa97d0a7f4c5994bf942b0774505bd799714 (diff)
downloadhaskell-531205ac090be2dc0c544c1a34c6d3b665aa558a.tar.gz
TagCheck.hs: Properly check if arguments are boxed types.
For one by mistake I had been checking against the kind of runtime rep instead of the boxity. This uncovered another bug, namely that we tried to generate the checking code before we had associated the function arguments with a register, so this could never have worked to begin with. This fixes #21729 and both of the above issues.
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs4
-rw-r--r--compiler/GHC/StgToCmm/TagCheck.hs9
2 files changed, 6 insertions, 7 deletions
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index cf54ef4be0..2ddba8ad18 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -221,7 +221,6 @@ cgRhs id (StgRhsCon cc con mn _ts args)
{- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
cgRhs id (StgRhsClosure fvs cc upd_flag args body)
= do
- checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args
profile <- getProfile
check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig
@@ -490,6 +489,7 @@ closureCodeBody top_lvl bndr cl_info cc [] body fv_details
lf_info = closureLFInfo cl_info
info_tbl = mkCmmInfo cl_info bndr cc
+-- Functions
closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
= let nv_args = nonVoidIds args
arity = length args
@@ -531,7 +531,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
-- Load free vars out of closure *after*
-- heap check, to reduce live vars over check
; when node_points $ load_fvs node lf_info fv_bindings
- ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr (map fromNonVoid nv_args)
+ ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args
; void $ cgExpr body
}}}
diff --git a/compiler/GHC/StgToCmm/TagCheck.hs b/compiler/GHC/StgToCmm/TagCheck.hs
index 26a207c814..afa3fef426 100644
--- a/compiler/GHC/StgToCmm/TagCheck.hs
+++ b/compiler/GHC/StgToCmm/TagCheck.hs
@@ -43,17 +43,16 @@ import GHC.Data.FastString (mkFastString)
import qualified Data.Map as M
--- | Check all arguments marked as already tagged for a function
--- are tagged by inserting runtime checks.
+-- | Check all arguments marked as cbv for the presence of a tag *at runtime*.
checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()
checkFunctionArgTags msg f args = whenCheckTags $ do
onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do
-- Only check args marked as strict, and only lifted ones.
- let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args
+ let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args
-- Get their (cmm) address
arg_infos <- mapM getCgIdInfo cbv_args
let arg_cmms = map idInfoToAmode arg_infos
- mapM_ (emitTagAssertion (showPprUnsafe msg)) (arg_cmms)
+ mapM_ (\(cmm,arg) -> emitTagAssertion (showPprUnsafe $ msg <+> ppr arg) cmm) (zip arg_cmms cbv_args)
-- | Check all required-tagged arguments of a constructor are tagged *at compile time*.
checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()
@@ -133,7 +132,7 @@ needsArgTag closure fail lpass = do
emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()
emitArgTagCheck info marks args = whenCheckTags $ do
mod <- getModuleName
- let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args
+ 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)