{- |
(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.
-}

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

module GHC.Stg.Lint ( lintStgTopBindings ) where

import GHC.Prelude

import GHC.Stg.Syntax

import GHC.Driver.Session
import GHC.Core.Lint        ( interactiveInScope )
import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )
import GHC.Types.CostCentre ( isCurrentCCS )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Core.DataCon
import GHC.Core             ( AltCon(..) )
import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
import GHC.Utils.Error      ( Severity(..), mkLocMessage )
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Types.SrcLoc
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Unit.Module            ( Module )
import GHC.Runtime.Context        ( InteractiveContext )
import qualified GHC.Utils.Error as Err
import Control.Applicative ((<|>))
import Control.Monad

lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
                   => Logger
                   -> DynFlags
                   -> 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) =>
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod Bool
unarised String
whodunnit [GenStgTopBinding a]
binds
  = {-# SCC "StgLint" #-}
    case forall a.
Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
initL 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 -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
Err.SevDump 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 -> DynFlags -> Int -> IO ()
Err.ghcExit Logger
logger DynFlags
dflags Int
1
  where
    opts :: StgPprOpts
opts = DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags
    -- 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 (XConApp 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
    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
      StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
      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 :: * -> *) (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 (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

lintStgExpr app :: GenStgExpr a
app@(StgConApp DataCon
con XConApp a
_n [StgArg]
args [Kind]
_arg_tys) = do
    -- unboxed sums should vanish during unarise
    LintFlags
lf <- LintM LintFlags
getLintFlags
    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
      StgPprOpts
opts <- LintM StgPprOpts
getStgPprOpts
      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 :: * -> *) (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) =>
(AltCon, [Id], GenStgExpr a) -> LintM ()
lintAlt [GenStgAlt a]
alts)

lintAlt
    :: (OutputablePass a, BinderP a ~ Id)
    => (AltCon, [Id], GenStgExpr a) -> LintM ()

lintAlt :: forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
(AltCon, [Id], GenStgExpr a) -> LintM ()
lintAlt (AltCon
DEFAULT, [Id]
_, GenStgExpr a
rhs) =
    forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs

lintAlt (LitAlt Literal
_, [Id]
_, GenStgExpr a
rhs) =
    forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs

lintAlt (DataAlt DataCon
_, [Id]
bndrs, GenStgExpr a
rhs) = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> LintM ()
checkPostUnariseBndr [Id]
bndrs
    forall a. [Id] -> LintM a -> LintM a
addInScopeVars [Id]
bndrs (forall (a :: StgPass).
(OutputablePass a, BinderP a ~ Id) =>
GenStgExpr a -> LintM ()
lintStgExpr GenStgExpr a
rhs)

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

newtype LintM a = LintM
    { forall a.
LintM a
-> Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM :: Module
              -> LintFlags
              -> 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
                             -- ^ 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 :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
initL :: forall a.
Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
initL Module
this_mod Bool
unarised StgPprOpts
opts IdSet
locals (LintM Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
m) = do
  let (a
_, Bag SDoc
errs) = Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
m Module
this_mod (Bool -> LintFlags
LintFlags Bool
unarised) 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
  -> case forall a.
LintM a
-> Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs of
      (a
r, Bag SDoc
errs') -> forall a.
LintM a
-> Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM (a -> LintM b
k a
r) Module
mod LintFlags
lf 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
  -> case forall a.
LintM a
-> Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs of
      (a
_, Bag SDoc
errs') -> forall a.
LintM a
-> Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM b
k Module
mod LintFlags
lf 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 (Kind -> Bool
isVoidTy 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf StgPprOpts
_opts [LintLocInfo]
loc IdSet
_scope Bag SDoc
errs -> ((), Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr Bag SDoc
errs SDoc
msg [LintLocInfo]
loc)

addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr 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  Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevWarning 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf StgPprOpts
opts [LintLocInfo]
loc IdSet
scope Bag SDoc
errs
   -> forall a.
LintM a
-> Module
-> LintFlags
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
lf 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
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
unLintM LintM a
m Module
mod LintFlags
lf 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
lf 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
_mod LintFlags
_lf 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
 -> StgPprOpts
 -> [LintLocInfo]
 -> IdSet
 -> Bag SDoc
 -> (a, Bag SDoc))
-> LintM a
LintM forall a b. (a -> b) -> a -> b
$ \Module
mod LintFlags
_lf 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
        ((), Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr 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)