diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/TagCheck.hs | 9 |
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) |