From df893f6667b31946ae7995150a6a5920602f7b0b Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Tue, 5 Apr 2022 13:48:49 +0200 Subject: StgLint: Lint constructor applications and strict workers for arity. This will mean T9208 when run with lint will return a lint error instead of resulting in a panic. Fixes #21117 --- compiler/GHC/Stg/InferTags/Rewrite.hs | 10 ++++++++-- compiler/GHC/Stg/Lint.hs | 29 ++++++++++++++++++++++++---- testsuite/tests/stranal/should_compile/all.T | 4 ++-- 3 files changed, 35 insertions(+), 8 deletions(-) diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs index 1d2d280f2c..e35f700377 100644 --- a/compiler/GHC/Stg/InferTags/Rewrite.hs +++ b/compiler/GHC/Stg/InferTags/Rewrite.hs @@ -480,14 +480,20 @@ mkSeqs args untaggedIds mkExpr = do -- Out of all arguments passed at runtime only return these ending up in a -- strict field -getStrictConArgs :: DataCon -> [a] -> [a] +getStrictConArgs :: Outputable a => DataCon -> [a] -> [a] getStrictConArgs con args -- These are always lazy in their arguments. | isUnboxedTupleDataCon con = [] | isUnboxedSumDataCon con = [] -- For proper data cons we have to check. | otherwise = + assertPpr (length args == length (dataConRuntimeRepStrictness con)) + (text "Missmatched con arg and con rep strictness lengths:" $$ + text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$ + text "But seems to have arity" <> ppr (length repStrictness)) $ [ arg | (arg,MarkedStrict) <- zipEqual "getStrictConArgs" args - (dataConRuntimeRepStrictness con)] + repStrictness] + where + repStrictness = (dataConRuntimeRepStrictness con) diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 657aa1603f..45e7b38471 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -47,7 +47,7 @@ import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Core.Type -import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) +import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) ) import GHC.Types.Id @@ -69,6 +69,7 @@ import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Control.Applicative ((<|>)) import Control.Monad import Data.Maybe +import GHC.Utils.Misc lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) => Logger @@ -179,10 +180,13 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr) lintStgExpr expr lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do + opts <- getStgPprOpts when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do - opts <- getStgPprOpts addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ pprStgRhs opts rhs) + + lintConApp con args (pprStgRhs opts rhs) + mapM_ lintStgArg args mapM_ checkPostUnariseConArg args @@ -200,7 +204,7 @@ lintStgExpr e@(StgApp fun args) = do -- always needs to be applied to n arguments. -- See Note [Strict Worker Ids]. let marks = fromMaybe [] $ idCbvMarks_maybe fun - if length marks > length args + if length (dropWhileEndLE (not . isMarkedCbv) marks) > length args then addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $ (text "marks" <> ppr marks $$ text "args" <> ppr args $$ @@ -211,10 +215,15 @@ lintStgExpr e@(StgApp fun args) = do lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags - when (lf_unarised lf && isUnboxedSumDataCon con) $ do + let !unarised = lf_unarised lf + when (unarised && isUnboxedSumDataCon con) $ do opts <- getStgPprOpts addErrL (text "Unboxed sum after unarise:" $$ pprStgExpr opts app) + + opts <- getStgPprOpts + lintConApp con args (pprStgExpr opts app) + mapM_ lintStgArg args mapM_ checkPostUnariseConArg args @@ -262,6 +271,18 @@ lintAlt GenStgAlt{ alt_con = DataAlt _ mapM_ checkPostUnariseBndr bndrs addInScopeVars bndrs (lintStgExpr rhs) +-- Post unarise check we apply constructors to the right number of args. +-- This can be violated by invalid use of unsafeCoerce as showcased by test +-- T9208 +lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM () +lintConApp con args app = do + unarised <- lf_unarised <$> getLintFlags + when (unarised && + not (isUnboxedTupleDataCon con) && + length (dataConRuntimeRepStrictness con) /= length args) $ do + addErrL (text "Constructor applied to incorrect number of arguments:" $$ + text "Application:" <> app) + {- ************************************************************************ * * diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index 47d2130346..e9ae6e11ba 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -30,9 +30,9 @@ test('T8743', [], multimod_compile, ['T8743', '-v0']) test('T10482', [ grep_errmsg(r'wfoo.*Int#') ], compile, ['-dppr-cols=200 -ddump-simpl']) test('T10482a', [ grep_errmsg(r'wf.*Int#') ], compile, ['-dppr-cols=200 -ddump-simpl']) -test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, ['']) +test('T9208', normal, compile_fail, ['-dstg-lint -O -ddebug-output']) # T9208 fails (and should do so) if you have assertion checking on in the compiler -# Hence the above expect_broken. See comments in the ticket +# It now also fails with stgLint, hence the above compile_fail. See comments in the ticket test('T10694', [ grep_errmsg(r'(Str|Cpr)=') ], compile, ['-dppr-cols=200 -ddump-simpl -dsuppress-uniques']) test('T11770', [ check_errmsg('OneShot') ], compile, ['-ddump-simpl']) -- cgit v1.2.1