{- |
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

A lint pass to check basic STG invariants:

- Variables should be defined before used.

- Let bindings should not have unboxed types (unboxed bindings should only
  appear in case), except when they're join points (see Note [Core let/app
  invariant] and #14117).

- If linting after unarisation, invariants listed in Note [Post-unarisation
  invariants].

Because we don't have types and coercions in STG we can't really check types
here.

Some history:

StgLint used to check types, but it never worked and so it was disabled in 2000
with this note:

    WARNING:
    ~~~~~~~~

    This module has suffered bit-rot; it is likely to yield lint errors
    for Stg code that is currently perfectly acceptable for code
    generation.  Solution: don't use it!  (KSW 2000-05).

Since then there were some attempts at enabling it again, as summarised in #14787.
It's finally decided that we remove all type checking and only look for
basic properties listed above.

Note [Linting StgApp]
~~~~~~~~~~~~~~~~~~~~~
To lint an application of the form `f a_1 ... a_n`, we check that
the representations of the arguments `a_1`, ..., `a_n` match those
that the function expects.

More precisely, suppose the types in the application `f a_1 ... a_n`
are as follows:

  f :: t_1 -> ... -> t_n -> res
  a_1 :: s_1, ..., a_n :: s_n

  t_1 :: TYPE r_1, ..., t_n :: TYPE r_n
  s_1 :: TYPE p_1, ..., a_n :: TYPE p_n

Before unarisation, we must check that each r_i is compatible with s_i.
Compatibility is weaker than on-the-nose equality: for example,
IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.

After unarisation, a single type might correspond to multiple arguments, e.g.

  (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ])

will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep]
This means post unarise we potentially have to match up multiple arguments with
the reps of a single argument in the type's definition, because the type of the function
is *not* in unarised form.

Wrinkle: it can sometimes happen that an argument type in the type of
the function does not have a fixed runtime representation, i.e.
there is an r_i such that runtimeRepPrimRep r_i crashes.
See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example.
Fixing this issue would require significant changes to the type system
of STG, so for now we simply skip the Lint check when we detect such
representation-polymorphic situations.

Note [Typing the STG language]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Core, programs must be /well-typed/.  So if f :: ty1 -> ty2,
then in the application (f e), we must have  e :: ty1

STG is still a statically typed language, but the type system
is much coarser. In particular, STG programs must be /well-kinded/.
More precisely, if f :: ty1 -> ty2, then in the application (f e)
where e :: ty1', we must have kind(ty1) = kind(ty1').

So the STG type system does not distinguish beteen Int and Bool,
but it /does/ distinguish beteen Int and Int#, because they have
different kinds.  Actually, since all terms have kind (TYPE rep),
we might say that the STG language is well-runtime-rep'd.

This coarser type system makes fewer distinctions, and that allows
many nonsensical programs (such as ('x' && "foo")) -- but all type
systems accept buggy programs!  But the coarseness also permits
some optimisations that are ill-typed in Core.  For example, see
the module STG.CSE, which is all about doing CSE in STG that would
be ill-typed in Core.  But it must still be well-kinded!

-}

{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
  DeriveFunctor #-}

module GHC.Stg.Lint ( lintStgTopBindings ) where

import GHC.Prelude

import GHC.Stg.Syntax
import GHC.Stg.Utils

import GHC.Core.Lint        ( interactiveInScope )
import GHC.Core.DataCon
import GHC.Core             ( AltCon(..) )
import GHC.Core.Type

import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
import GHC.Types.CostCentre ( isCurrentCCS )
import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
import GHC.Types.RepType
import GHC.Types.SrcLoc

import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Error      ( mkLocMessage, DiagOpts )
import qualified GHC.Utils.Error as Err

import GHC.Unit.Module            ( Module )
import GHC.Runtime.Context        ( InteractiveContext )

import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )

import Control.Applicative ((<|>))
import Control.Monad
import Data.Maybe
import GHC.Utils.Misc
import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
import GHC.Utils.Panic.Plain (panic)

lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                   => Platform
                   -> Logger
                   -> DiagOpts
                   -> StgPprOpts
                   -> InteractiveContext
                   -> Module -- ^ module being compiled
                   -> Bool   -- ^ have we run Unarise yet?
                   -> String -- ^ who produced the STG?
                   -> [GenStgTopBinding a]
                   -> IO ()

lintStgTopBindings :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
Platform
-> Logger
-> DiagOpts
-> StgPprOpts
-> InteractiveContext
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings Platform
platform Logger
logger DiagOpts
diag_opts StgPprOpts
opts InteractiveContext
ictxt Module
this_mod Bool
unarised String
whodunnit [GenStgTopBinding a]
binds
  = {-# SCC "StgLint" #-}
    case forall a.
Platform
-> DiagOpts
-> Module
-> Bool
-> StgPprOpts
-> IdSet
-> LintM a
-> Maybe SDoc
initL Platform
platform DiagOpts
diag_opts Module
this_mod Bool
unarised StgPprOpts
opts IdSet
top_level_binds ([GenStgTopBinding a] -> LintM ()
lint_binds [GenStgTopBinding a]
binds) of
      Maybe SDoc
Nothing  ->
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just SDoc
msg -> do
        Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
Err.MCDump SrcSpan
noSrcSpan
          forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
          ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"*** Stg Lint ErrMsgs: in" SDoc -> SDoc -> SDoc
<+>
                        String -> SDoc
text String
whodunnit SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"***",
                  SDoc
msg,
                  String -> SDoc
text String
"*** Offending Program ***",
                  forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings StgPprOpts
opts [GenStgTopBinding a]
binds,
                  String -> SDoc
text String
"*** End of Offense ***"])
        Logger -> Int -> IO ()
Err.ghcExit Logger
logger Int
1
  where
    -- Bring all top-level binds into scope because CoreToStg does not generate
    -- bindings in dependency order (so we may see a use before its definition).
    top_level_binds :: IdSet
top_level_binds = IdSet -> [Id] -> IdSet
extendVarSetList ([Id] -> IdSet
mkVarSet (forall (a :: StgPass).
(BinderP a ~ Id) =>
[GenStgTopBinding a] -> [Id]
bindersOfTopBinds [GenStgTopBinding a]
binds))
                                       (InteractiveContext -> [Id]
interactiveInScope InteractiveContext
ictxt)

    lint_binds :: [GenStgTopBinding a] -> LintM ()

    lint_binds :: [GenStgTopBinding a] -> LintM ()
lint_binds [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    lint_binds (GenStgTopBinding a
bind:[GenStgTopBinding a]
binds) = do
        [Id]
binders <- forall {a :: StgPass}.
(BinderP a ~ Id, Outputable (XLet a), Outputable (XLetNoEscape a),
 Outputable (XRhsClosure a), OutputableBndr (BinderP a)) =>
GenStgTopBinding a -> LintM [Id]
lint_bind GenStgTopBinding a
bind
        forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders forall a b. (a -> b) -> a -> b
$
            [GenStgTopBinding a] -> LintM ()
lint_binds [GenStgTopBinding a]
binds

    lint_bind :: GenStgTopBinding a -> LintM [Id]
lint_bind (StgTopLifted GenStgBinding a
bind) = forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
TopLevel GenStgBinding a
bind
    lint_bind (StgTopStringLit Id
v ByteString
_) = forall (m :: * -> *) a. Monad m => a -> m a
return [Id
v]

lintStgArg :: StgArg -> LintM ()
lintStgArg :: StgArg -> LintM ()
lintStgArg (StgLitArg Literal
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintStgArg (StgVarArg Id
v) = Id -> LintM ()
lintStgVar Id
v

lintStgVar :: Id -> LintM ()
lintStgVar :: Id -> LintM ()
lintStgVar Id
id = Id -> LintM ()
checkInScope Id
id

lintStgBinds
    :: (OutputablePass a, BinderP a ~ Id)
    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
lintStgBinds :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
top_lvl (StgNonRec BinderP a
binder GenStgRhs a
rhs) = do
    forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (BinderP a
binder,GenStgRhs a
rhs)
    forall (m :: * -> *) a. Monad m => a -> m a
return [BinderP a
binder]

lintStgBinds TopLevelFlag
top_lvl (StgRec [(BinderP a, GenStgRhs a)]
pairs)
  = forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl) [(BinderP a, GenStgRhs a)]
pairs
        forall (m :: * -> *) a. Monad m => a -> m a
return [Id]
binders
  where
    binders :: [Id]
binders = [Id
b | (Id
b,GenStgRhs a
_) <- [(BinderP a, GenStgRhs a)]
pairs]

lint_binds_help
    :: (OutputablePass a, BinderP a ~ Id)
    => TopLevelFlag
    -> (Id, GenStgRhs a)
    -> LintM ()
lint_binds_help :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (Id
binder, GenStgRhs a
rhs)
  = forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Id -> LintLocInfo
RhsOf Id
binder) forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) (forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
checkNoCurrentCCS GenStgRhs a
rhs)
        forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
lintStgRhs GenStgRhs a
rhs
        StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
        -- Check binder doesn't have unlifted type or it's a join point
        Bool -> SDoc -> LintM ()
checkL ( Id -> Bool
isJoinId Id
binder
              Bool -> Bool -> Bool
|| Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
binder))
              Bool -> Bool -> Bool
|| Id -> Bool
isDataConWorkId Id
binder Bool -> Bool -> Bool
|| Id -> Bool
isDataConWrapId Id
binder) -- until #17521 is fixed
          (forall (a :: StgPass).
OutputablePass a =>
StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg StgPprOpts
opts Id
binder GenStgRhs a
rhs)

-- | Top-level bindings can't inherit the cost centre stack from their
-- (static) allocation site.
checkNoCurrentCCS
    :: (OutputablePass a, BinderP a ~ Id)
    => GenStgRhs a
    -> LintM ()
checkNoCurrentCCS :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
checkNoCurrentCCS GenStgRhs a
rhs = do
   StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
   let rhs' :: SDoc
rhs' = forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs
   case GenStgRhs a
rhs of
      StgRhsClosure XRhsClosure a
_ CostCentreStack
ccs UpdateFlag
_ [BinderP a]
_ GenStgExpr a
_
         | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
         -> SDoc -> LintM ()
addErrL (String -> SDoc
text String
"Top-level StgRhsClosure with CurrentCCS" SDoc -> SDoc -> SDoc
$$ SDoc
rhs')
      StgRhsCon CostCentreStack
ccs DataCon
_ ConstructorNumber
_ [StgTickish]
_ [StgArg]
_
         | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
         -> SDoc -> LintM ()
addErrL (String -> SDoc
text String
"Top-level StgRhsCon with CurrentCCS" SDoc -> SDoc -> SDoc
$$ SDoc
rhs')
      GenStgRhs a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()

lintStgRhs :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
lintStgRhs (StgRhsClosure XRhsClosure a
_ CostCentreStack
_ UpdateFlag
_ [] GenStgExpr a
expr)
  = forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr

lintStgRhs (StgRhsClosure XRhsClosure a
_ CostCentreStack
_ UpdateFlag
_ [BinderP a]
binders GenStgExpr a
expr)
  = forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Id] -> LintLocInfo
LambdaBodyOf [BinderP a]
binders) forall a b. (a -> b) -> a -> b
$
      forall a. [Id] -> LintM a -> LintM a
addInScopeVars [BinderP a]
binders forall a b. (a -> b) -> a -> b
$
        forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr

lintStgRhs rhs :: GenStgRhs a
rhs@(StgRhsCon CostCentreStack
_ DataCon
con ConstructorNumber
_ [StgTickish]
_ [StgArg]
args) = do
    StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con) forall a b. (a -> b) -> a -> b
$ do
      SDoc -> LintM ()
addErrL (String -> SDoc
text String
"StgRhsCon is an unboxed tuple or sum application" SDoc -> SDoc -> SDoc
$$
               forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)

    forall (t :: * -> *) a.
Foldable t =>
DataCon -> t a -> SDoc -> LintM ()
lintConApp DataCon
con [StgArg]
args (forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
checkPostUnariseConArg [StgArg]
args

lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()

lintStgExpr :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr (StgLit Literal
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()

lintStgExpr e :: GenStgExpr a
e@(StgApp Id
fun [StgArg]
args) = do
  Id -> LintM ()
lintStgVar Id
fun
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args

  forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> LintM ()
lintAppCbvMarks GenStgExpr a
e
  Id -> [StgArg] -> LintM ()
lintStgAppReps Id
fun [StgArg]
args

lintStgExpr app :: GenStgExpr a
app@(StgConApp DataCon
con ConstructorNumber
_n [StgArg]
args [Kind]
_arg_tys) = do
    -- unboxed sums should vanish during unarise
    LintFlags
lf <- LintM LintFlags
getLintFlags
    StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf Bool -> Bool -> Bool
&& DataCon -> Bool
isUnboxedSumDataCon DataCon
con) forall a b. (a -> b) -> a -> b
$ do
      SDoc -> LintM ()
addErrL (String -> SDoc
text String
"Unboxed sum after unarise:" SDoc -> SDoc -> SDoc
$$
               forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
opts GenStgExpr a
app)

    forall (t :: * -> *) a.
Foldable t =>
DataCon -> t a -> SDoc -> LintM ()
lintConApp DataCon
con [StgArg]
args (forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
opts GenStgExpr a
app)

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
checkPostUnariseConArg [StgArg]
args

lintStgExpr (StgOpApp StgOp
_ [StgArg]
args Kind
_) =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgArg [StgArg]
args

lintStgExpr (StgLet XLet a
_ GenStgBinding a
binds GenStgExpr a
body) = do
    [Id]
binders <- forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
NotTopLevel GenStgBinding a
binds
    forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Id] -> LintLocInfo
BodyOfLetRec [Id]
binders) forall a b. (a -> b) -> a -> b
$
      forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders forall a b. (a -> b) -> a -> b
$
        forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
body

lintStgExpr (StgLetNoEscape XLetNoEscape a
_ GenStgBinding a
binds GenStgExpr a
body) = do
    [Id]
binders <- forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds TopLevelFlag
NotTopLevel GenStgBinding a
binds
    forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Id] -> LintLocInfo
BodyOfLetRec [Id]
binders) forall a b. (a -> b) -> a -> b
$
      forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders forall a b. (a -> b) -> a -> b
$
        forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
body

lintStgExpr (StgTick StgTickish
_ GenStgExpr a
expr) = forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
expr

lintStgExpr (StgCase GenStgExpr a
scrut BinderP a
bndr AltType
alts_type [GenStgAlt a]
alts) = do
    forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
scrut

    LintFlags
lf <- LintM LintFlags
getLintFlags
    let in_scope :: Bool
in_scope = AltType -> Bool -> Bool
stgCaseBndrInScope AltType
alts_type (LintFlags -> Bool
lf_unarised LintFlags
lf)

    forall a. [Id] -> LintM a -> LintM a
addInScopeVars [BinderP a
bndr | Bool
in_scope] (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgAlt a -> LintM ()
lintAlt [GenStgAlt a]
alts)

lintAlt
    :: (OutputablePass a, BinderP a ~ Id)
    => GenStgAlt a -> LintM ()

lintAlt :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgAlt a -> LintM ()
lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = AltCon
DEFAULT
                 , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP a]
_
                 , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr a
rhs} = forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs

lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = LitAlt Literal
_
                 , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP a]
_
                 , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr a
rhs} = forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs

lintAlt GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = DataAlt DataCon
_
                 , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP a]
bndrs
                 , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = GenStgExpr a
rhs} =
  do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> LintM ()
checkPostUnariseBndr [BinderP a]
bndrs
    forall a. [Id] -> LintM a -> LintM a
addInScopeVars [BinderP a]
bndrs (forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
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 :: forall (t :: * -> *) a.
Foldable t =>
DataCon -> t a -> SDoc -> LintM ()
lintConApp DataCon
con t a
args SDoc
app = do
    Bool
unarised <- LintFlags -> Bool
lf_unarised forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
unarised Bool -> Bool -> Bool
&&
          Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con) Bool -> Bool -> Bool
&&
          forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasDebugCallStack => DataCon -> [StrictnessMark]
dataConRuntimeRepStrictness DataCon
con) forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args) forall a b. (a -> b) -> a -> b
$ do
      SDoc -> LintM ()
addErrL (String -> SDoc
text String
"Constructor applied to incorrect number of arguments:" SDoc -> SDoc -> SDoc
$$
               String -> SDoc
text String
"Application:" SDoc -> SDoc -> SDoc
<> SDoc
app)

-- See Note [Linting StgApp]
-- See Note [Typing the STG language]
lintStgAppReps :: Id -> [StgArg] -> LintM ()
lintStgAppReps :: Id -> [StgArg] -> LintM ()
lintStgAppReps Id
_fun [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
lintStgAppReps Id
fun [StgArg]
args = do
  LintFlags
lf <- LintM LintFlags
getLintFlags
  let platform :: Platform
platform = LintFlags -> Platform
lf_platform LintFlags
lf

      ([Scaled Kind]
fun_arg_tys, Kind
_res) = Kind -> ([Scaled Kind], Kind)
splitFunTys (Id -> Kind
idType Id
fun)
      fun_arg_tys' :: [Kind]
fun_arg_tys' = forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Kind]
fun_arg_tys :: [Type]

      -- Might be "wrongly" typed as polymorphic. See #21399
      -- In these cases typePrimRep_maybe will return Nothing
      -- and we abort kind checking.
      fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
      fun_arg_tys_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = forall a b. (a -> b) -> [a] -> [b]
map Kind -> Maybe [PrimRep]
typePrimRep_maybe [Kind]
fun_arg_tys'
      actual_arg_reps :: [Maybe [PrimRep]]
actual_arg_reps = forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Maybe [PrimRep]
typePrimRep_maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Kind
stgArgType) [StgArg]
args

      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args (Maybe [PrimRep]
Nothing:[Maybe [PrimRep]]
_) [Maybe [PrimRep]]
_   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      match_args ([Maybe [PrimRep]]
_) (Maybe [PrimRep]
Nothing:[Maybe [PrimRep]]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      match_args (Just [PrimRep]
actual_rep:[Maybe [PrimRep]]
actual_reps_left) (Just [PrimRep]
expected_rep:[Maybe [PrimRep]]
expected_reps_left)
        -- Common case, reps are exactly the same
        | [PrimRep]
actual_rep forall a. Eq a => a -> a -> Bool
== [PrimRep]
expected_rep
        = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_reps_left [Maybe [PrimRep]]
expected_reps_left

        -- Check for void rep which can be either an empty list *or* [VoidRep]
        | [PrimRep] -> Bool
isVoidRep [PrimRep]
actual_rep Bool -> Bool -> Bool
&& [PrimRep] -> Bool
isVoidRep [PrimRep]
expected_rep
        = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_reps_left [Maybe [PrimRep]]
expected_reps_left

        -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.
        -- We check for that here with primRepCompatible
        | Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible Platform
platform [PrimRep]
actual_rep [PrimRep]
expected_rep
        = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_reps_left [Maybe [PrimRep]]
expected_reps_left

        -- We might distribute args from within one unboxed sum over multiple
        -- single rep args. This means we might need to match up things like:
        -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]]
        -- which happens here.
        -- See Note [Linting StgApp].
        | Just (PrimRep
actual,[Maybe [PrimRep]]
actuals) <- [PrimRep]
-> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [PrimRep]
actual_rep [Maybe [PrimRep]]
actual_reps_left
        , Just (PrimRep
expected,[Maybe [PrimRep]]
expecteds) <- [PrimRep]
-> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [PrimRep]
expected_rep [Maybe [PrimRep]]
expected_reps_left
        , Platform -> PrimRep -> PrimRep -> Bool
primRepCompatible Platform
platform PrimRep
actual PrimRep
expected
        = [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actuals [Maybe [PrimRep]]
expecteds

        | Bool
otherwise = SDoc -> LintM ()
addErrL forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Function type reps and function argument reps mismatched") Int
2 forall a b. (a -> b) -> a -> b
$
            (String -> SDoc
text String
"In application " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text String
"argument rep:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [Maybe [PrimRep]]
actual_arg_reps SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text String
"expected rep:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [Maybe [PrimRep]]
fun_arg_tys_reps SDoc -> SDoc -> SDoc
$$
              -- text "expected reps:" <> ppr arg_ty_reps $$
              String -> SDoc
text String
"unarised?:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (LintFlags -> Bool
lf_unarised LintFlags
lf))
        where
          isVoidRep :: [PrimRep] -> Bool
isVoidRep [] = Bool
True
          isVoidRep [PrimRep
VoidRep] = Bool
True
          isVoidRep [PrimRep]
_ = Bool
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
          -- will result in a lint failure in match_args.
          getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
          getOneRep :: [PrimRep]
-> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [] [Maybe [PrimRep]]
_rest = forall a. Maybe a
Nothing -- Void rep args are invalid at this point.
          getOneRep [PrimRep
rep] [Maybe [PrimRep]]
rest = forall a. a -> Maybe a
Just (PrimRep
rep,[Maybe [PrimRep]]
rest) -- A single arg rep arg
          getOneRep (PrimRep
rep:[PrimRep]
reps) [Maybe [PrimRep]]
rest = forall a. a -> Maybe a
Just (PrimRep
rep,forall a. a -> Maybe a
Just [PrimRep]
repsforall a. a -> [a] -> [a]
:[Maybe [PrimRep]]
rest) -- Multi rep arg.

      match_args [Maybe [PrimRep]]
_ [Maybe [PrimRep]]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return () -- Functions are allowed to be over/under applied.

  [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args [Maybe [PrimRep]]
actual_arg_reps [Maybe [PrimRep]]
fun_arg_tys_reps

lintAppCbvMarks :: OutputablePass pass
                => GenStgExpr pass -> LintM ()
lintAppCbvMarks :: forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> LintM ()
lintAppCbvMarks e :: GenStgExpr pass
e@(StgApp Id
fun [StgArg]
args) = do
  LintFlags
lf <- LintM LintFlags
getLintFlags
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf) forall a b. (a -> b) -> a -> b
$ do
    -- A function which expects a unlifted argument as n'th argument
    -- always needs to be applied to n arguments.
    -- See Note [CBV Function Ids].
    let marks :: [CbvMark]
marks = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fun
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CbvMark -> Bool
isMarkedCbv) [CbvMark]
marks) forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args) forall a b. (a -> b) -> a -> b
$ do
      SDoc -> LintM ()
addErrL forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Undersatured cbv marked ID in App" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
e ) Int
2 forall a b. (a -> b) -> a -> b
$
        (String -> SDoc
text String
"marks" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [CbvMark]
marks SDoc -> SDoc -> SDoc
$$
        String -> SDoc
text String
"args" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
$$
        String -> SDoc
text String
"arity" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Id -> Int
idArity Id
fun) SDoc -> SDoc -> SDoc
$$
        String -> SDoc
text String
"join_arity" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe Int
isJoinId_maybe Id
fun))
lintAppCbvMarks GenStgExpr pass
_ = forall a. String -> a
panic String
"impossible - lintAppCbvMarks"

{-
************************************************************************
*                                                                      *
The Lint monad
*                                                                      *
************************************************************************
-}

newtype LintM a = LintM
    { forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM :: Module
              -> LintFlags
              -> DiagOpts          -- Diagnostic options
              -> StgPprOpts        -- Pretty-printing options
              -> [LintLocInfo]     -- Locations
              -> IdSet             -- Local vars in scope
              -> Bag SDoc        -- Error messages so far
              -> (a, Bag SDoc)   -- Result and error messages (if any)
    }
    deriving (forall a b. a -> LintM b -> LintM a
forall a b. (a -> b) -> LintM a -> LintM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> LintM b -> LintM a
$c<$ :: forall a b. a -> LintM b -> LintM a
fmap :: forall a b. (a -> b) -> LintM a -> LintM b
$cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
Functor)

data LintFlags = LintFlags { LintFlags -> Bool
lf_unarised :: !Bool
                           , LintFlags -> Platform
lf_platform :: !Platform
                             -- ^ have we run the unariser yet?
                           }

data LintLocInfo
  = RhsOf Id            -- The variable bound
  | LambdaBodyOf [Id]   -- The lambda-binder
  | BodyOfLetRec [Id]   -- One of the binders

dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc (RhsOf Id
v) =
  (SrcLoc -> SrcSpan
srcLocSpan (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Id
v), String -> SDoc
text String
" [RHS of " SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
pp_binders [Id
v] SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
']' )
dumpLoc (LambdaBodyOf [Id]
bs) =
  (SrcLoc -> SrcSpan
srcLocSpan (forall a. NamedThing a => a -> SrcLoc
getSrcLoc (forall a. [a] -> a
head [Id]
bs)), String -> SDoc
text String
" [in body of lambda with binders " SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
pp_binders [Id]
bs SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
']' )

dumpLoc (BodyOfLetRec [Id]
bs) =
  (SrcLoc -> SrcSpan
srcLocSpan (forall a. NamedThing a => a -> SrcLoc
getSrcLoc (forall a. [a] -> a
head [Id]
bs)), String -> SDoc
text String
" [in body of letrec with binders " SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
pp_binders [Id]
bs SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
']' )


pp_binders :: [Id] -> SDoc
pp_binders :: [Id] -> SDoc
pp_binders [Id]
bs
  = [SDoc] -> SDoc
sep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma (forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
pp_binder [Id]
bs))
  where
    pp_binder :: Id -> SDoc
pp_binder Id
b
      = [SDoc] -> SDoc
hsep [forall a. Outputable a => a -> SDoc
ppr Id
b, SDoc
dcolon, forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
b)]

initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
initL :: forall a.
Platform
-> DiagOpts
-> Module
-> Bool
-> StgPprOpts
-> IdSet
-> LintM a
-> Maybe SDoc
initL Platform
platform DiagOpts
diag_opts Module
this_mod Bool
unarised StgPprOpts
opts IdSet
locals (LintM Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
m) = do
  let (a
_, Bag SDoc
errs) = Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
m Module
this_mod (Bool -> Platform -> LintFlags
LintFlags Bool
unarised Platform
platform) DiagOpts
diag_opts StgPprOpts
opts [] IdSet
locals forall a. Bag a
emptyBag
  if forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs then
      forall a. Maybe a
Nothing
  else
      forall a. a -> Maybe a
Just ([SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
blankLine (forall a. Bag a -> [a]
bagToList Bag SDoc
errs)))

instance Applicative LintM where
      pure :: forall a. a -> LintM a
pure a
a = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf DiagOpts
_df StgPprOpts
_opts [LintLocInfo]
_loc IdSet
_scope Bag SDoc
errs -> (a
a, Bag SDoc
errs)
      <*> :: forall a b. LintM (a -> b) -> LintM a -> LintM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
      *> :: forall a b. LintM a -> LintM b -> LintM b
(*>)  = forall a b. LintM a -> LintM b -> LintM b
thenL_

instance Monad LintM where
    >>= :: forall a b. LintM a -> (a -> LintM b) -> LintM b
(>>=) = forall a b. LintM a -> (a -> LintM b) -> LintM b
thenL
    >> :: forall a b. LintM a -> LintM b -> LintM b
(>>)  = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL :: forall a b. LintM a -> (a -> LintM b) -> LintM b
thenL LintM a
m a -> LintM b
k = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
  -> case forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs of
      (a
r, Bag SDoc
errs') -> forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM (a -> LintM b
k a
r) Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs'

thenL_ :: LintM a -> LintM b -> LintM b
thenL_ :: forall a b. LintM a -> LintM b -> LintM b
thenL_ LintM a
m LintM b
k = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
  -> case forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs of
      (a
_, Bag SDoc
errs') -> forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM b
k Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs'

checkL :: Bool -> SDoc -> LintM ()
checkL :: Bool -> SDoc -> LintM ()
checkL Bool
True  SDoc
_   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkL Bool
False SDoc
msg = SDoc -> LintM ()
addErrL SDoc
msg

-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr Id
bndr = do
    LintFlags
lf <- LintM LintFlags
getLintFlags
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf) forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Id -> Maybe String
checkPostUnariseId Id
bndr) forall a b. (a -> b) -> a -> b
$ \String
unexpected ->
        SDoc -> LintM ()
addErrL forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"After unarisation, binder " SDoc -> SDoc -> SDoc
<>
          forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" has " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
unexpected SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" type " SDoc -> SDoc -> SDoc
<>
          forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
bndr)

-- Arguments shouldn't have sum, tuple, or void types.
checkPostUnariseConArg :: StgArg -> LintM ()
checkPostUnariseConArg :: StgArg -> LintM ()
checkPostUnariseConArg StgArg
arg = case StgArg
arg of
    StgLitArg Literal
_ ->
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
    StgVarArg Id
id -> do
      LintFlags
lf <- LintM LintFlags
getLintFlags
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LintFlags -> Bool
lf_unarised LintFlags
lf) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Id -> Maybe String
checkPostUnariseId Id
id) forall a b. (a -> b) -> a -> b
$ \String
unexpected ->
          SDoc -> LintM ()
addErrL forall a b. (a -> b) -> a -> b
$
            String -> SDoc
text String
"After unarisation, arg " SDoc -> SDoc -> SDoc
<>
            forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" has " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
unexpected SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" type " SDoc -> SDoc -> SDoc
<>
            forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id)

-- Post-unarisation args and case alt binders should not have unboxed tuple,
-- unboxed sum, or void types. Return what the binder is if it is one of these.
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId Id
id =
    let
      id_ty :: Kind
id_ty = Id -> Kind
idType Id
id
      is_sum, is_tuple, is_void :: Maybe String
      is_sum :: Maybe String
is_sum = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Kind -> Bool
isUnboxedSumType Kind
id_ty) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return String
"unboxed sum"
      is_tuple :: Maybe String
is_tuple = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Kind -> Bool
isUnboxedTupleType Kind
id_ty) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return String
"unboxed tuple"
      is_void :: Maybe String
is_void = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (HasDebugCallStack => Kind -> Bool
isZeroBitTy Kind
id_ty) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return String
"void"
    in
      Maybe String
is_sum forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
is_tuple forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
is_void

addErrL :: SDoc -> LintM ()
addErrL :: SDoc -> LintM ()
addErrL SDoc
msg = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf DiagOpts
df StgPprOpts
_opts [LintLocInfo]
loc IdSet
_scope Bag SDoc
errs -> ((), DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr DiagOpts
df Bag SDoc
errs SDoc
msg [LintLocInfo]
loc)

addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr DiagOpts
diag_opts Bag SDoc
errs_so_far SDoc
msg [LintLocInfo]
locs
  = Bag SDoc
errs_so_far forall a. Bag a -> a -> Bag a
`snocBag` [LintLocInfo] -> SDoc
mk_msg [LintLocInfo]
locs
  where
    mk_msg :: [LintLocInfo] -> SDoc
mk_msg (LintLocInfo
loc:[LintLocInfo]
_) = let (SrcSpan
l,SDoc
hdr) = LintLocInfo -> (SrcSpan, SDoc)
dumpLoc LintLocInfo
loc
                     in  MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage (DiagOpts -> DiagnosticReason -> MessageClass
Err.mkMCDiagnostic DiagOpts
diag_opts DiagnosticReason
WarningWithoutFlag)
                                      SrcSpan
l (SDoc
hdr SDoc -> SDoc -> SDoc
$$ SDoc
msg)
    mk_msg []      = SDoc
msg

addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc :: forall a. LintLocInfo -> LintM a -> LintM a
addLoc LintLocInfo
extra_loc LintM a
m = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
   -> forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts (LintLocInfo
extra_locforall a. a -> [a] -> [a]
:[LintLocInfo]
loc) IdSet
scope Bag SDoc
errs

addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars :: forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
ids LintM a
m = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
 -> let
        new_set :: IdSet
new_set = [Id] -> IdSet
mkVarSet [Id]
ids
    in forall a.
LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc (IdSet
scope IdSet -> IdSet -> IdSet
`unionVarSet` IdSet
new_set) Bag SDoc
errs

getLintFlags :: LintM LintFlags
getLintFlags :: LintM LintFlags
getLintFlags = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
lf DiagOpts
_df StgPprOpts
_opts [LintLocInfo]
_loc IdSet
_scope Bag SDoc
errs -> (LintFlags
lf, Bag SDoc
errs)

getStgPprOpts :: LintM StgPprOpts
getStgPprOpts :: LintM StgPprOpts
getStgPprOpts = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf DiagOpts
_df StgPprOpts
opts [LintLocInfo]
_loc IdSet
_scope Bag SDoc
errs -> (StgPprOpts
opts, Bag SDoc
errs)

checkInScope :: Id -> LintM ()
checkInScope :: Id -> LintM ()
checkInScope Id
id = forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
_lf DiagOpts
diag_opts StgPprOpts
_opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
 -> if Module -> Name -> Bool
nameIsLocalOrFrom Module
mod (Id -> Name
idName Id
id) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id
id Id -> IdSet -> Bool
`elemVarSet` IdSet
scope) then
        ((), DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr DiagOpts
diag_opts Bag SDoc
errs ([SDoc] -> SDoc
hsep [forall a. Outputable a => a -> SDoc
ppr Id
id, SDoc
dcolon, forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id),
                                    String -> SDoc
text String
"is out of scope"]) [LintLocInfo]
loc)
    else
        ((), Bag SDoc
errs)

mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg :: forall (a :: StgPass).
OutputablePass a =>
StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg StgPprOpts
opts Id
binder GenStgRhs a
rhs
  = (String -> SDoc
text String
"Let(rec) binder" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
binder) SDoc -> SDoc -> SDoc
<+>
     String -> SDoc
text String
"has unlifted type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
binder)))
    SDoc -> SDoc -> SDoc
$$
    (String -> SDoc
text String
"RHS:" SDoc -> SDoc -> SDoc
<+> forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)