{- |
(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-can-float
  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 between Int and Bool,
but it /does/ distinguish between 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.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.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )

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
                   -> [Var]  -- ^ extra vars in scope from GHCi
                   -> 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
-> [Id]
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings Platform
platform Logger
logger DiagOpts
diag_opts StgPprOpts
opts [Id]
extra_vars Module
this_mod Bool
unarised String
whodunit [GenStgTopBinding a]
binds
  = {-# SCC "StgLint" #-}
    case Platform
-> DiagOpts
-> Module
-> Bool
-> StgPprOpts
-> IdSet
-> LintM ()
-> Maybe SDoc
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  ->
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just SDoc
msg -> do
        Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
Err.MCInfo SrcSpan
noSrcSpan   -- See Note [MCInfo for Lint] in "GHC.Core.Lint"
          (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
          ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"*** Stg Lint ErrMsgs: in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
whodunit SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"***",
                  SDoc
msg,
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"*** Offending Program ***",
                  StgPprOpts -> [GenStgTopBinding a] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings StgPprOpts
opts [GenStgTopBinding a]
binds,
                  String -> SDoc
forall doc. IsLine doc => String -> doc
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 ([GenStgTopBinding a] -> [Id]
forall (a :: StgPass).
(BinderP a ~ Id) =>
[GenStgTopBinding a] -> [Id]
bindersOfTopBinds [GenStgTopBinding a]
binds))
                                       [Id]
extra_vars

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

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

    lint_bind :: GenStgTopBinding a -> LintM [Id]
lint_bind (StgTopLifted GenStgBinding a
bind) = TopLevelFlag -> GenStgBinding a -> LintM [Id]
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
_) = [Id] -> LintM [Id]
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Id
v]

lintStgConArg :: StgArg -> LintM ()
lintStgConArg :: StgArg -> LintM ()
lintStgConArg StgArg
arg = do
  unarised <- LintFlags -> Bool
lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
  when unarised $ case stgArgRep_maybe arg of
    -- Note [Post-unarisation invariants], invariant 4
    Just [PrimRep
_] -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe [PrimRep]
badRep   -> SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Non-unary constructor arg: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgArg
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Its PrimReps are: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Maybe [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe [PrimRep]
badRep

  case arg of
    StgLitArg Literal
_ -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    StgVarArg Id
v -> Id -> LintM ()
lintStgVar Id
v

lintStgFunArg :: StgArg -> LintM ()
lintStgFunArg :: StgArg -> LintM ()
lintStgFunArg StgArg
arg = do
  unarised <- LintFlags -> Bool
lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags
  when unarised $ case stgArgRep_maybe arg of
    -- Note [Post-unarisation invariants], invariant 3
    Just []  -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just [PrimRep
_] -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe [PrimRep]
badRep   -> SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Function arg is not unary or void: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgArg
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Its PrimReps are: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Maybe [PrimRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe [PrimRep]
badRep

  case arg of
    StgLitArg Literal
_ -> () -> LintM ()
forall a. a -> LintM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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
    TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl (Id
BinderP a
binder,GenStgRhs a
rhs)
    [Id] -> LintM [Id]
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Id
BinderP a
binder]

lintStgBinds TopLevelFlag
top_lvl (StgRec [(BinderP a, GenStgRhs a)]
pairs)
  = [Id] -> LintM [Id] -> LintM [Id]
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
binders (LintM [Id] -> LintM [Id]) -> LintM [Id] -> LintM [Id]
forall a b. (a -> b) -> a -> b
$ do
        ((Id, GenStgRhs a) -> LintM ()) -> [(Id, GenStgRhs a)] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
TopLevelFlag -> (Id, GenStgRhs a) -> LintM ()
lint_binds_help TopLevelFlag
top_lvl) [(Id, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs
        [Id] -> LintM [Id]
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Id]
binders
  where
    binders :: [Id]
binders = [Id
b | (Id
b,GenStgRhs a
_) <- [(Id, 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)
  = LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc (Id -> LintLocInfo
RhsOf Id
binder) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> LintM () -> LintM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl) (GenStgRhs a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
checkNoCurrentCCS GenStgRhs a
rhs)
        GenStgRhs a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgRhs a -> LintM ()
lintStgRhs GenStgRhs a
rhs
        opts <- LintM StgPprOpts
getStgPprOpts
        -- Check binder doesn't have unlifted type or it's a join point
        checkL ( isJoinId binder
              || not (isUnliftedType (idType binder))
              || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
          (mkUnliftedTyMsg opts binder 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
   opts <- LintM StgPprOpts
getStgPprOpts
   let rhs' = StgPprOpts -> GenStgRhs a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs
   case rhs of
      StgRhsClosure XRhsClosure a
_ CostCentreStack
ccs UpdateFlag
_ [BinderP a]
_ GenStgExpr a
_ Kind
_
         | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
         -> SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Top-level StgRhsClosure with CurrentCCS" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
rhs')
      StgRhsCon CostCentreStack
ccs DataCon
_ ConstructorNumber
_ [StgTickish]
_ [StgArg]
_ Kind
_
         | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
         -> SDoc -> LintM ()
addErrL (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Top-level StgRhsCon with CurrentCCS" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
rhs')
      GenStgRhs a
_ -> () -> LintM ()
forall a. a -> LintM 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 Kind
_)
  = GenStgExpr a -> LintM ()
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 Kind
_)
  = LintLocInfo -> LintM () -> LintM ()
forall a. LintLocInfo -> LintM a -> LintM a
addLoc ([Id] -> LintLocInfo
LambdaBodyOf [Id]
[BinderP a]
binders) (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
      [Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
[BinderP a]
binders (LintM () -> LintM ()) -> LintM () -> LintM ()
forall a b. (a -> b) -> a -> b
$
        GenStgExpr a -> LintM ()
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 Kind
_) = do
    opts <- LintM StgPprOpts
getStgPprOpts
    when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
               pprStgRhs opts rhs)

    lintConApp con args (pprStgRhs opts rhs)

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

lintStgExpr :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr (StgLit Literal
_) = () -> LintM ()
forall a. a -> LintM a
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
  (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgFunArg [StgArg]
args
  GenStgExpr a -> LintM ()
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 [[PrimRep]]
_arg_tys) = do
    -- unboxed sums should vanish during unarise
    lf <- LintM LintFlags
getLintFlags
    let !unarised = LintFlags -> Bool
lf_unarised LintFlags
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)

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

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

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

lintStgExpr (StgTick StgTickish
_ GenStgExpr a
expr) = GenStgExpr a -> LintM ()
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
    GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
scrut

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

    addInScopeVars [bndr | in_scope] (mapM_ lintAlt 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} = GenStgExpr a -> LintM ()
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} = GenStgExpr a -> LintM ()
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
    (Id -> LintM ()) -> [Id] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> LintM ()
checkPostUnariseBndr [Id]
[BinderP a]
bndrs
    [Id] -> LintM () -> LintM ()
forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
[BinderP a]
bndrs (GenStgExpr a -> LintM ()
forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs)

lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM ()
lintConApp :: DataCon -> [StgArg] -> SDoc -> LintM ()
lintConApp DataCon
con [StgArg]
args SDoc
app = do
    (StgArg -> LintM ()) -> [StgArg] -> LintM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StgArg -> LintM ()
lintStgConArg [StgArg]
args
    unarised <- LintFlags -> Bool
lf_unarised (LintFlags -> Bool) -> LintM LintFlags -> LintM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LintM LintFlags
getLintFlags

    -- 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; see also #23865
    when (unarised &&
          not (isUnboxedTupleDataCon con) &&
          length (dataConRuntimeRepStrictness con) /= length args) $ do
      addErrL (text "Constructor applied to incorrect number of arguments:" $$
               text "Application:" <> app)

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

      (fun_arg_tys, _res) = splitFunTys (idType fun)
      fun_arg_tys' = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
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 = (Kind -> Maybe [PrimRep]) -> [Kind] -> [Maybe [PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Maybe [PrimRep]
typePrimRep_maybe [Kind]
fun_arg_tys'
      actual_arg_reps = (StgArg -> Maybe [PrimRep]) -> [StgArg] -> [Maybe [PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> Maybe [PrimRep]
stgArgRep_maybe [StgArg]
args

      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
      match_args (Maybe [PrimRep]
Nothing:[Maybe [PrimRep]]
_) [Maybe [PrimRep]]
_   = () -> LintM ()
forall a. a -> LintM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      match_args ([Maybe [PrimRep]]
_) (Maybe [PrimRep]
Nothing:[Maybe [PrimRep]]
_) = () -> LintM ()
forall a. a -> LintM a
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 (perhaps void)
        | [PrimRep]
actual_rep [PrimRep] -> [PrimRep] -> Bool
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

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

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

  match_args actual_arg_reps 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
  lf <- LintM LintFlags
getLintFlags
  when (lf_unarised lf) $ 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] -> Maybe [CbvMark] -> [CbvMark]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
forall a b. (a -> b) -> a -> b
$ Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fun
    when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do
      addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $
        (text "marks" <> ppr marks $$
        text "args" <> ppr args $$
        text "arity" <> ppr (idArity fun) $$
        text "join_arity" <> ppr (idJoinPointHood fun))
lintAppCbvMarks GenStgExpr pass
_ = String -> LintM ()
forall a. HasCallStack => 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 -> b) -> LintM a -> LintM b)
-> (forall a b. a -> LintM b -> LintM a) -> Functor LintM
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
$cfmap :: forall a b. (a -> b) -> LintM a -> LintM b
fmap :: forall a b. (a -> b) -> LintM a -> LintM b
$c<$ :: forall a b. a -> LintM b -> LintM a
<$ :: forall a b. a -> LintM b -> LintM a
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
  | BodyOfLet [Id]      -- The binders of the let

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

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


pp_binders :: [Id] -> SDoc
pp_binders :: [Id] -> SDoc
pp_binders [Id]
bs
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((Id -> SDoc) -> [Id] -> [SDoc]
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
forall doc. IsLine doc => [doc] -> doc
hsep [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b, SDoc
dcolon, Kind -> SDoc
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 Bag SDoc
forall a. Bag a
emptyBag
  if Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
errs then
      Maybe SDoc
forall a. Maybe a
Nothing
  else
      SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
blankLine (Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
errs)))

instance Applicative LintM where
      pure :: forall a. a -> LintM a
pure a
a = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (a, Bag SDoc))
 -> LintM a)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc))
-> LintM a
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
(<*>) = 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
(*>)  = 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
(>>=) = 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
(>>)  = LintM a -> LintM b -> LintM b
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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (b, Bag SDoc))
-> LintM b
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (b, Bag SDoc))
 -> LintM b)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (b, Bag SDoc))
-> LintM b
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
  -> case LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
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') -> LintM b
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc)
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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (b, Bag SDoc))
-> LintM b
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (b, Bag SDoc))
 -> LintM b)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (b, Bag SDoc))
-> LintM b
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
  -> case LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
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') -> LintM b
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (b, Bag SDoc)
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
_   = () -> LintM ()
forall a. a -> LintM a
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
    lf <- LintM LintFlags
getLintFlags
    when (lf_unarised lf) $
      forM_ (checkPostUnariseId bndr) $ \String
unexpected ->
        SDoc -> LintM ()
addErrL (SDoc -> LintM ()) -> SDoc -> LintM ()
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"After unarisation, binder " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
          Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" has " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
unexpected SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
          Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
bndr)

-- 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
  | Kind -> Bool
isUnboxedSumType Kind
id_ty   = String -> Maybe String
forall a. a -> Maybe a
Just String
"unboxed sum"
  | Kind -> Bool
isUnboxedTupleType Kind
id_ty = String -> Maybe String
forall a. a -> Maybe a
Just String
"unboxed tuple"
  | HasDebugCallStack => Kind -> Bool
Kind -> Bool
isZeroBitTy Kind
id_ty        = String -> Maybe String
forall a. a -> Maybe a
Just String
"void"
  | Bool
otherwise                = Maybe String
forall a. Maybe a
Nothing
  where
    id_ty :: Kind
id_ty = Id -> Kind
idType Id
id

addErrL :: SDoc -> LintM ()
addErrL :: SDoc -> LintM ()
addErrL SDoc
msg = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> ((), Bag SDoc))
-> LintM ()
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> ((), Bag SDoc))
 -> LintM ())
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> ((), Bag SDoc))
-> 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 Bag SDoc -> SDoc -> Bag SDoc
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 -> Maybe DiagnosticCode -> MessageClass
Err.mkMCDiagnostic DiagOpts
diag_opts DiagnosticReason
WarningWithoutFlag Maybe DiagnosticCode
forall a. Maybe a
Nothing)
                                      SrcSpan
l (SDoc
hdr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (a, Bag SDoc))
 -> LintM a)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc))
-> LintM a
forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf DiagOpts
diag_opts StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
   -> LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
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_locLintLocInfo -> [LintLocInfo] -> [LintLocInfo]
forall 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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (a, Bag SDoc))
 -> LintM a)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (a, Bag SDoc))
-> LintM a
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 LintM a
-> Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (LintFlags, Bag SDoc))
-> LintM LintFlags
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (LintFlags, Bag SDoc))
 -> LintM LintFlags)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (LintFlags, Bag SDoc))
-> LintM LintFlags
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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (StgPprOpts, Bag SDoc))
-> LintM StgPprOpts
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> (StgPprOpts, Bag SDoc))
 -> LintM StgPprOpts)
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> (StgPprOpts, Bag SDoc))
-> LintM StgPprOpts
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 = (Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> ((), Bag SDoc))
-> LintM ()
forall a.
(Module
 -> LintFlags
 -> DiagOpts
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM ((Module
  -> LintFlags
  -> DiagOpts
  -> StgPprOpts
  -> [LintLocInfo]
  -> IdSet
  -> Bag SDoc
  -> ((), Bag SDoc))
 -> LintM ())
-> (Module
    -> LintFlags
    -> DiagOpts
    -> StgPprOpts
    -> [LintLocInfo]
    -> IdSet
    -> Bag SDoc
    -> ((), Bag SDoc))
-> 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
forall doc. IsLine doc => [doc] -> doc
hsep [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id, SDoc
dcolon, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id),
                                    String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Let(rec) binder" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
binder) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has unlifted type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
binder)))
    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RHS:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> StgPprOpts -> GenStgRhs a -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs StgPprOpts
opts GenStgRhs a
rhs)