TagCheck.hs: Properly check if arguments are boxed types.wip/andrask/fix_tagcheck

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.

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)