1{- | 2(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 3 4A lint pass to check basic STG invariants: 5 6- Variables should be defined before used. 7 8- Let bindings should not have unboxed types (unboxed bindings should only 9 appear in case), except when they're join points (see Note [CoreSyn let/app 10 invariant] and #14117). 11 12- If linting after unarisation, invariants listed in Note [Post-unarisation 13 invariants]. 14 15Because we don't have types and coercions in STG we can't really check types 16here. 17 18Some history: 19 20StgLint used to check types, but it never worked and so it was disabled in 2000 21with this note: 22 23 WARNING: 24 ~~~~~~~~ 25 26 This module has suffered bit-rot; it is likely to yield lint errors 27 for Stg code that is currently perfectly acceptable for code 28 generation. Solution: don't use it! (KSW 2000-05). 29 30Since then there were some attempts at enabling it again, as summarised in 31#14787. It's finally decided that we remove all type checking and only look for 32basic properties listed above. 33-} 34 35{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, 36 DeriveFunctor #-} 37 38module StgLint ( lintStgTopBindings ) where 39 40import GhcPrelude 41 42import StgSyn 43 44import DynFlags 45import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) 46import BasicTypes ( TopLevelFlag(..), isTopLevel ) 47import CostCentre ( isCurrentCCS ) 48import Id ( Id, idType, isJoinId, idName ) 49import VarSet 50import DataCon 51import CoreSyn ( AltCon(..) ) 52import Name ( getSrcLoc, nameIsLocalOrFrom ) 53import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) 54import Type 55import RepType 56import SrcLoc 57import Outputable 58import Module ( Module ) 59import qualified ErrUtils as Err 60import Control.Applicative ((<|>)) 61import Control.Monad 62 63lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) 64 => DynFlags 65 -> Module -- ^ module being compiled 66 -> Bool -- ^ have we run Unarise yet? 67 -> String -- ^ who produced the STG? 68 -> [GenStgTopBinding a] 69 -> IO () 70 71lintStgTopBindings dflags this_mod unarised whodunnit binds 72 = {-# SCC "StgLint" #-} 73 case initL this_mod unarised top_level_binds (lint_binds binds) of 74 Nothing -> 75 return () 76 Just msg -> do 77 putLogMsg dflags NoReason Err.SevDump noSrcSpan 78 (defaultDumpStyle dflags) 79 (vcat [ text "*** Stg Lint ErrMsgs: in" <+> 80 text whodunnit <+> text "***", 81 msg, 82 text "*** Offending Program ***", 83 pprGenStgTopBindings binds, 84 text "*** End of Offense ***"]) 85 Err.ghcExit dflags 1 86 where 87 -- Bring all top-level binds into scope because CoreToStg does not generate 88 -- bindings in dependency order (so we may see a use before its definition). 89 top_level_binds = mkVarSet (bindersOfTopBinds binds) 90 91 lint_binds :: [GenStgTopBinding a] -> LintM () 92 93 lint_binds [] = return () 94 lint_binds (bind:binds) = do 95 binders <- lint_bind bind 96 addInScopeVars binders $ 97 lint_binds binds 98 99 lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind 100 lint_bind (StgTopStringLit v _) = return [v] 101 102lintStgArg :: StgArg -> LintM () 103lintStgArg (StgLitArg _) = return () 104lintStgArg (StgVarArg v) = lintStgVar v 105 106lintStgVar :: Id -> LintM () 107lintStgVar id = checkInScope id 108 109lintStgBinds 110 :: (OutputablePass a, BinderP a ~ Id) 111 => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders 112lintStgBinds top_lvl (StgNonRec binder rhs) = do 113 lint_binds_help top_lvl (binder,rhs) 114 return [binder] 115 116lintStgBinds top_lvl (StgRec pairs) 117 = addInScopeVars binders $ do 118 mapM_ (lint_binds_help top_lvl) pairs 119 return binders 120 where 121 binders = [b | (b,_) <- pairs] 122 123lint_binds_help 124 :: (OutputablePass a, BinderP a ~ Id) 125 => TopLevelFlag 126 -> (Id, GenStgRhs a) 127 -> LintM () 128lint_binds_help top_lvl (binder, rhs) 129 = addLoc (RhsOf binder) $ do 130 when (isTopLevel top_lvl) (checkNoCurrentCCS rhs) 131 lintStgRhs rhs 132 -- Check binder doesn't have unlifted type or it's a join point 133 checkL (isJoinId binder || not (isUnliftedType (idType binder))) 134 (mkUnliftedTyMsg binder rhs) 135 136-- | Top-level bindings can't inherit the cost centre stack from their 137-- (static) allocation site. 138checkNoCurrentCCS 139 :: (OutputablePass a, BinderP a ~ Id) 140 => GenStgRhs a 141 -> LintM () 142checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _) 143 | isCurrentCCS ccs 144 = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs) 145checkNoCurrentCCS rhs@(StgRhsCon ccs _ _) 146 | isCurrentCCS ccs 147 = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs) 148checkNoCurrentCCS _ 149 = return () 150 151lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () 152 153lintStgRhs (StgRhsClosure _ _ _ [] expr) 154 = lintStgExpr expr 155 156lintStgRhs (StgRhsClosure _ _ _ binders expr) 157 = addLoc (LambdaBodyOf binders) $ 158 addInScopeVars binders $ 159 lintStgExpr expr 160 161lintStgRhs rhs@(StgRhsCon _ con args) = do 162 when (isUnboxedTupleCon con || isUnboxedSumCon con) $ 163 addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ 164 ppr rhs) 165 mapM_ lintStgArg args 166 mapM_ checkPostUnariseConArg args 167 168lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM () 169 170lintStgExpr (StgLit _) = return () 171 172lintStgExpr (StgApp fun args) = do 173 lintStgVar fun 174 mapM_ lintStgArg args 175 176lintStgExpr app@(StgConApp con args _arg_tys) = do 177 -- unboxed sums should vanish during unarise 178 lf <- getLintFlags 179 when (lf_unarised lf && isUnboxedSumCon con) $ 180 addErrL (text "Unboxed sum after unarise:" $$ 181 ppr app) 182 mapM_ lintStgArg args 183 mapM_ checkPostUnariseConArg args 184 185lintStgExpr (StgOpApp _ args _) = 186 mapM_ lintStgArg args 187 188lintStgExpr lam@(StgLam _ _) = 189 addErrL (text "Unexpected StgLam" <+> ppr lam) 190 191lintStgExpr (StgLet _ binds body) = do 192 binders <- lintStgBinds NotTopLevel binds 193 addLoc (BodyOfLetRec binders) $ 194 addInScopeVars binders $ 195 lintStgExpr body 196 197lintStgExpr (StgLetNoEscape _ binds body) = do 198 binders <- lintStgBinds NotTopLevel binds 199 addLoc (BodyOfLetRec binders) $ 200 addInScopeVars binders $ 201 lintStgExpr body 202 203lintStgExpr (StgTick _ expr) = lintStgExpr expr 204 205lintStgExpr (StgCase scrut bndr alts_type alts) = do 206 lintStgExpr scrut 207 208 lf <- getLintFlags 209 let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf) 210 211 addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts) 212 213lintAlt 214 :: (OutputablePass a, BinderP a ~ Id) 215 => (AltCon, [Id], GenStgExpr a) -> LintM () 216 217lintAlt (DEFAULT, _, rhs) = 218 lintStgExpr rhs 219 220lintAlt (LitAlt _, _, rhs) = 221 lintStgExpr rhs 222 223lintAlt (DataAlt _, bndrs, rhs) = do 224 mapM_ checkPostUnariseBndr bndrs 225 addInScopeVars bndrs (lintStgExpr rhs) 226 227{- 228************************************************************************ 229* * 230Utilities 231* * 232************************************************************************ 233-} 234 235bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] 236bindersOf (StgNonRec binder _) = [binder] 237bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] 238 239bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] 240bindersOfTop (StgTopLifted bind) = bindersOf bind 241bindersOfTop (StgTopStringLit binder _) = [binder] 242 243bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] 244bindersOfTopBinds = foldr ((++) . bindersOfTop) [] 245 246{- 247************************************************************************ 248* * 249The Lint monad 250* * 251************************************************************************ 252-} 253 254newtype LintM a = LintM 255 { unLintM :: Module 256 -> LintFlags 257 -> [LintLocInfo] -- Locations 258 -> IdSet -- Local vars in scope 259 -> Bag MsgDoc -- Error messages so far 260 -> (a, Bag MsgDoc) -- Result and error messages (if any) 261 } 262 deriving (Functor) 263 264data LintFlags = LintFlags { lf_unarised :: !Bool 265 -- ^ have we run the unariser yet? 266 } 267 268data LintLocInfo 269 = RhsOf Id -- The variable bound 270 | LambdaBodyOf [Id] -- The lambda-binder 271 | BodyOfLetRec [Id] -- One of the binders 272 273dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) 274dumpLoc (RhsOf v) = 275 (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) 276dumpLoc (LambdaBodyOf bs) = 277 (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) 278 279dumpLoc (BodyOfLetRec bs) = 280 (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) 281 282 283pp_binders :: [Id] -> SDoc 284pp_binders bs 285 = sep (punctuate comma (map pp_binder bs)) 286 where 287 pp_binder b 288 = hsep [ppr b, dcolon, ppr (idType b)] 289 290initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc 291initL this_mod unarised locals (LintM m) = do 292 let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag 293 if isEmptyBag errs then 294 Nothing 295 else 296 Just (vcat (punctuate blankLine (bagToList errs))) 297 298instance Applicative LintM where 299 pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs) 300 (<*>) = ap 301 (*>) = thenL_ 302 303instance Monad LintM where 304 (>>=) = thenL 305 (>>) = (*>) 306 307thenL :: LintM a -> (a -> LintM b) -> LintM b 308thenL m k = LintM $ \mod lf loc scope errs 309 -> case unLintM m mod lf loc scope errs of 310 (r, errs') -> unLintM (k r) mod lf loc scope errs' 311 312thenL_ :: LintM a -> LintM b -> LintM b 313thenL_ m k = LintM $ \mod lf loc scope errs 314 -> case unLintM m mod lf loc scope errs of 315 (_, errs') -> unLintM k mod lf loc scope errs' 316 317checkL :: Bool -> MsgDoc -> LintM () 318checkL True _ = return () 319checkL False msg = addErrL msg 320 321-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders. 322checkPostUnariseBndr :: Id -> LintM () 323checkPostUnariseBndr bndr = do 324 lf <- getLintFlags 325 when (lf_unarised lf) $ 326 forM_ (checkPostUnariseId bndr) $ \unexpected -> 327 addErrL $ 328 text "After unarisation, binder " <> 329 ppr bndr <> text " has " <> text unexpected <> text " type " <> 330 ppr (idType bndr) 331 332-- Arguments shouldn't have sum, tuple, or void types. 333checkPostUnariseConArg :: StgArg -> LintM () 334checkPostUnariseConArg arg = case arg of 335 StgLitArg _ -> 336 return () 337 StgVarArg id -> do 338 lf <- getLintFlags 339 when (lf_unarised lf) $ 340 forM_ (checkPostUnariseId id) $ \unexpected -> 341 addErrL $ 342 text "After unarisation, arg " <> 343 ppr id <> text " has " <> text unexpected <> text " type " <> 344 ppr (idType id) 345 346-- Post-unarisation args and case alt binders should not have unboxed tuple, 347-- unboxed sum, or void types. Return what the binder is if it is one of these. 348checkPostUnariseId :: Id -> Maybe String 349checkPostUnariseId id = 350 let 351 id_ty = idType id 352 is_sum, is_tuple, is_void :: Maybe String 353 is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" 354 is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple" 355 is_void = guard (isVoidTy id_ty) >> return "void" 356 in 357 is_sum <|> is_tuple <|> is_void 358 359addErrL :: MsgDoc -> LintM () 360addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc) 361 362addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc 363addErr errs_so_far msg locs 364 = errs_so_far `snocBag` mk_msg locs 365 where 366 mk_msg (loc:_) = let (l,hdr) = dumpLoc loc 367 in mkLocMessage SevWarning l (hdr $$ msg) 368 mk_msg [] = msg 369 370addLoc :: LintLocInfo -> LintM a -> LintM a 371addLoc extra_loc m = LintM $ \mod lf loc scope errs 372 -> unLintM m mod lf (extra_loc:loc) scope errs 373 374addInScopeVars :: [Id] -> LintM a -> LintM a 375addInScopeVars ids m = LintM $ \mod lf loc scope errs 376 -> let 377 new_set = mkVarSet ids 378 in unLintM m mod lf loc (scope `unionVarSet` new_set) errs 379 380getLintFlags :: LintM LintFlags 381getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs) 382 383checkInScope :: Id -> LintM () 384checkInScope id = LintM $ \mod _lf loc scope errs 385 -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then 386 ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), 387 text "is out of scope"]) loc) 388 else 389 ((), errs) 390 391mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc 392mkUnliftedTyMsg binder rhs 393 = (text "Let(rec) binder" <+> quotes (ppr binder) <+> 394 text "has unlifted type" <+> quotes (ppr (idType binder))) 395 $$ 396 (text "RHS:" <+> ppr rhs) 397