compiler/stgSyn/StgLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
   5
   6 \begin{code}
   7 module StgLint ( lintStgBindings ) where
   8
   9 import StgSyn
  10
  11 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
  12 import Id               ( Id, idType, isLocalId )
  13 import VarSet
  14 import DataCon          ( DataCon, dataConInstArgTys, dataConRepType )
  15 import CoreSyn          ( AltCon(..) )
  16 import PrimOp           ( primOpType )
  17 import Literal          ( literalType )
  18 import Maybes
  19 import Name             ( getSrcLoc )
  20 import ErrUtils         ( Message, mkLocMessage )
  21 import TypeRep
  22 import Type             ( mkFunTys, splitFunTys, splitTyConApp_maybe,
  23                           isUnLiftedType, isTyVarTy, dropForAlls, Type
  24                         )
  25 import TyCon            ( isAlgTyCon, isNewTyCon, tyConDataCons )
  26 import Util             ( zipEqual, equalLength )
  27 import SrcLoc
  28 import Outputable
  29 import FastString
  30 import Control.Monad
  31 \end{code}
  32
  33 Checks for
  34         (a) *some* type errors
  35         (b) locally-defined variables used but not defined
  36
  37
  38 Note: unless -dverbose-stg is on, display of lint errors will result
  39 in "panic: bOGUS_LVs".
  40
  41 WARNING:
  42 ~~~~~~~~
  43
  44 This module has suffered bit-rot; it is likely to yield lint errors
  45 for Stg code that is currently perfectly acceptable for code
  46 generation.  Solution: don't use it!  (KSW 2000-05).
  47
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{``lint'' for various constructs}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 @lintStgBindings@ is the top-level interface function.
  56
  57 \begin{code}
  58 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
  59
  60 lintStgBindings whodunnit binds
  61   = {-# SCC "StgLint" #-}
  62     case (initL (lint_binds binds)) of
  63       Nothing  -> binds
  64       Just msg -> pprPanic "" (vcat [
  65                         ptext (sLit "*** Stg Lint ErrMsgs: in") <+>
  66                               text whodunnit <+> ptext (sLit "***"),
  67                         msg,
  68                         ptext (sLit "*** Offending Program ***"),
  69                         pprStgBindings binds,
  70                         ptext (sLit "*** End of Offense ***")])
  71   where
  72     lint_binds :: [StgBinding] -> LintM ()
  73
  74     lint_binds [] = return ()
  75     lint_binds (bind:binds) = do
  76         binders <- lintStgBinds bind
  77         addInScopeVars binders $
  78             lint_binds binds
  79 \end{code}
  80
  81
  82 \begin{code}
  83 lintStgArg :: StgArg -> LintM (Maybe Type)
  84 lintStgArg (StgLitArg lit) = return (Just (literalType lit))
  85 lintStgArg (StgVarArg v)   = lintStgVar v
  86 lintStgArg a               = pprPanic "lintStgArg" (ppr a)
  87
  88 lintStgVar :: Id -> LintM (Maybe Kind)
  89 lintStgVar v = do checkInScope v
  90                   return (Just (idType v))
  91 \end{code}
  92
  93 \begin{code}
  94 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
  95 lintStgBinds (StgNonRec binder rhs) = do
  96     lint_binds_help (binder,rhs)
  97     return [binder]
  98
  99 lintStgBinds (StgRec pairs)
 100   = addInScopeVars binders $ do
 101         mapM_ lint_binds_help pairs
 102         return binders
 103   where
 104     binders = [b | (b,_) <- pairs]
 105
 106 lint_binds_help :: (Id, StgRhs) -> LintM ()
 107 lint_binds_help (binder, rhs)
 108   = addLoc (RhsOf binder) $ do
 109         -- Check the rhs
 110         maybe_rhs_ty <- lintStgRhs rhs
 111
 112         -- Check binder doesn't have unlifted type
 113         checkL (not (isUnLiftedType binder_ty))
 114                (mkUnLiftedTyMsg binder rhs)
 115
 116         -- Check match to RHS type
 117         case maybe_rhs_ty of
 118           Nothing     -> return ()
 119           Just rhs_ty -> checkTys binder_ty
 120                                   rhs_ty
 121                                   (mkRhsMsg binder rhs_ty)
 122
 123         return ()
 124   where
 125     binder_ty = idType binder
 126 \end{code}
 127
 128 \begin{code}
 129 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 130
 131 lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
 132   = lintStgExpr expr
 133
 134 lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
 135   = addLoc (LambdaBodyOf binders) $
 136       addInScopeVars binders $ runMaybeT $ do
 137         body_ty <- MaybeT $ lintStgExpr expr
 138         return (mkFunTys (map idType binders) body_ty)
 139
 140 lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
 141     arg_tys <- mapM (MaybeT . lintStgArg) args
 142     MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
 143   where
 144     con_ty = dataConRepType con
 145 \end{code}
 146
 147 \begin{code}
 148 lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found
 149
 150 lintStgExpr (StgLit l) = return (Just (literalType l))
 151
 152 lintStgExpr e@(StgApp fun args) = runMaybeT $ do
 153     fun_ty <- MaybeT $ lintStgVar fun
 154     arg_tys <- mapM (MaybeT . lintStgArg) args
 155     MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 156
 157 lintStgExpr e@(StgConApp con args) = runMaybeT $ do
 158     arg_tys <- mapM (MaybeT . lintStgArg) args
 159     MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
 160   where
 161     con_ty = dataConRepType con
 162
 163 lintStgExpr (StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
 164         -- We don't have enough type information to check
 165         -- the application; ToDo
 166     _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
 167     return res_ty
 168
 169 lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
 170     arg_tys <- mapM (MaybeT . lintStgArg) args
 171     MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
 172   where
 173     op_ty = primOpType op
 174
 175 lintStgExpr (StgLam _ bndrs _) = do
 176     addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs)
 177     return Nothing
 178
 179 lintStgExpr (StgLet binds body) = do
 180     binders <- lintStgBinds binds
 181     addLoc (BodyOfLetRec binders) $
 182       addInScopeVars binders $
 183         lintStgExpr body
 184
 185 lintStgExpr (StgLetNoEscape _ _ binds body) = do
 186     binders <- lintStgBinds binds
 187     addLoc (BodyOfLetRec binders) $
 188       addInScopeVars binders $
 189         lintStgExpr body
 190
 191 lintStgExpr (StgSCC _ expr) = lintStgExpr expr
 192
 193 lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
 194     _ <- MaybeT $ lintStgExpr scrut
 195
 196     MaybeT $ liftM Just $
 197      case alts_type of
 198         AlgAlt tc    -> check_bndr tc
 199         PrimAlt tc   -> check_bndr tc
 200         UbxTupAlt tc -> check_bndr tc
 201         PolyAlt      -> return ()
 202
 203     MaybeT $ trace (showSDoc (ppr e)) $ do
 204         -- we only allow case of tail-call or primop.
 205      case scrut of
 206         StgApp _ _     -> return ()
 207         StgConApp _ _  -> return ()
 208         StgOpApp _ _ _ -> return ()
 209         _              -> addErrL (mkCaseOfCaseMsg e)
 210
 211      addInScopeVars [bndr] $
 212         lintStgAlts alts scrut_ty
 213   where
 214     scrut_ty      = idType bndr
 215     bad_bndr      = mkDefltMsg bndr
 216     check_bndr tc = case splitTyConApp_maybe scrut_ty of
 217                         Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
 218                         Nothing           -> addErrL bad_bndr
 219
 220 lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
 221
 222 lintStgAlts :: [StgAlt]
 223             -> Type               -- Type of scrutinee
 224             -> LintM (Maybe Type) -- Type of alternatives
 225
 226 lintStgAlts alts scrut_ty = do
 227     maybe_result_tys <- mapM (lintAlt scrut_ty) alts
 228
 229     -- Check the result types
 230     case catMaybes (maybe_result_tys) of
 231       []             -> return Nothing
 232
 233       (first_ty:tys) -> do mapM_ check tys
 234                            return (Just first_ty)
 235         where
 236           check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 237
 238 lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type)
 239 lintAlt _ (DEFAULT, _, _, rhs)
 240  = lintStgExpr rhs
 241
 242 lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do
 243    checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
 244    lintStgExpr rhs
 245
 246 lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
 247     case splitTyConApp_maybe scrut_ty of
 248       Just (tycon, tys_applied) | isAlgTyCon tycon &&
 249                                   not (isNewTyCon tycon) -> do
 250          let
 251            cons    = tyConDataCons tycon
 252            arg_tys = dataConInstArgTys con tys_applied
 253                 -- This almost certainly does not work for existential constructors
 254
 255          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
 256          checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
 257          mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
 258          return ()
 259       _ ->
 260          addErrL (mkAltMsg1 scrut_ty)
 261
 262     addInScopeVars args $
 263          lintStgExpr rhs
 264   where
 265     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 266
 267     -- elem: yes, the elem-list here can sometimes be long-ish,
 268     -- but as it's use-once, probably not worth doing anything different
 269     -- We give it its own copy, so it isn't overloaded.
 270     elem _ []       = False
 271     elem x (y:ys)   = x==y || elem x ys
 272 \end{code}
 273
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection[lint-monad]{The Lint monad}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 \begin{code}
 282 newtype LintM a = LintM
 283     { unLintM :: [LintLocInfo]      -- Locations
 284               -> IdSet              -- Local vars in scope
 285               -> Bag Message        -- Error messages so far
 286               -> (a, Bag Message)   -- Result and error messages (if any)
 287     }
 288
 289 data LintLocInfo
 290   = RhsOf Id            -- The variable bound
 291   | LambdaBodyOf [Id]   -- The lambda-binder
 292   | BodyOfLetRec [Id]   -- One of the binders
 293
 294 dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
 295 dumpLoc (RhsOf v) =
 296   (srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' )
 297 dumpLoc (LambdaBodyOf bs) =
 298   (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of lambda with binders ") <> pp_binders bs <> char ']' )
 299
 300 dumpLoc (BodyOfLetRec bs) =
 301   (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' )
 302
 303
 304 pp_binders :: [Id] -> SDoc
 305 pp_binders bs
 306   = sep (punctuate comma (map pp_binder bs))
 307   where
 308     pp_binder b
 309       = hsep [ppr b, dcolon, ppr (idType b)]
 310 \end{code}
 311
 312 \begin{code}
 313 initL :: LintM a -> Maybe Message
 314 initL (LintM m)
 315   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
 316     if isEmptyBag errs then
 317         Nothing
 318     else
 319         Just (vcat (punctuate (text "") (bagToList errs)))
 320     }
 321
 322 instance Monad LintM where
 323     return a = LintM $ \_loc _scope errs -> (a, errs)
 324     (>>=) = thenL
 325     (>>)  = thenL_
 326
 327 thenL :: LintM a -> (a -> LintM b) -> LintM b
 328 thenL m k = LintM $ \loc scope errs
 329   -> case unLintM m loc scope errs of
 330       (r, errs') -> unLintM (k r) loc scope errs'
 331
 332 thenL_ :: LintM a -> LintM b -> LintM b
 333 thenL_ m k = LintM $ \loc scope errs
 334   -> case unLintM m loc scope errs of
 335       (_, errs') -> unLintM k loc scope errs'
 336 \end{code}
 337
 338 \begin{code}
 339 checkL :: Bool -> Message -> LintM ()
 340 checkL True  _   = return ()
 341 checkL False msg = addErrL msg
 342
 343 addErrL :: Message -> LintM ()
 344 addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
 345
 346 addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 347 addErr errs_so_far msg locs
 348   = errs_so_far `snocBag` mk_msg locs
 349   where
 350     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
 351                      in  mkLocMessage l (hdr $$ msg)
 352     mk_msg []      = msg
 353
 354 addLoc :: LintLocInfo -> LintM a -> LintM a
 355 addLoc extra_loc m = LintM $ \loc scope errs
 356    -> unLintM m (extra_loc:loc) scope errs
 357
 358 addInScopeVars :: [Id] -> LintM a -> LintM a
 359 addInScopeVars ids m = LintM $ \loc scope errs
 360  -> -- We check if these "new" ids are already
 361     -- in scope, i.e., we have *shadowing* going on.
 362     -- For now, it's just a "trace"; we may make
 363     -- a real error out of it...
 364     let
 365         new_set = mkVarSet ids
 366     in
 367 --  After adding -fliberate-case, Simon decided he likes shadowed
 368 --  names after all.  WDP 94/07
 369 --  (if isEmptyVarSet shadowed
 370 --  then id
 371 --  else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
 372     unLintM m loc (scope `unionVarSet` new_set) errs
 373 \end{code}
 374
 375 Checking function applications: we only check that the type has the
 376 right *number* of arrows, we don't actually compare the types.  This
 377 is because we can't expect the types to be equal - the type
 378 applications and type lambdas that we use to calculate accurate types
 379 have long since disappeared.
 380
 381 \begin{code}
 382 checkFunApp :: Type                 -- The function type
 383             -> [Type]               -- The arg type(s)
 384             -> Message              -- Error messgae
 385             -> LintM (Maybe Type)   -- The result type
 386
 387 checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
 388  where
 389   checkFunApp' loc _scope errs
 390    = cfa res_ty expected_arg_tys arg_tys
 391    where
 392     (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
 393
 394     cfa res_ty expected []      -- Args have run out; that's fine
 395       = (Just (mkFunTys expected res_ty), errs)
 396
 397     cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
 398                                 -- first see if res_ty is a tyvar template;
 399                                 -- otherwise, maybe res_ty is a
 400                                 -- dictionary type which is actually a function?
 401       | isTyVarTy res_ty
 402       = (Just res_ty, errs)
 403       | otherwise
 404       = case splitFunTys res_ty of
 405           ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
 406           (new_expected, new_res) -> cfa new_res new_expected arg_tys
 407
 408     cfa res_ty (_:expected_arg_tys) (_:arg_tys)
 409       = cfa res_ty expected_arg_tys arg_tys
 410 \end{code}
 411
 412 \begin{code}
 413 checkInScope :: Id -> LintM ()
 414 checkInScope id = LintM $ \loc scope errs
 415  -> if isLocalId id && not (id `elemVarSet` scope) then
 416         ((), addErr errs (hsep [ppr id, ptext (sLit "is out of scope")]) loc)
 417     else
 418         ((), errs)
 419
 420 checkTys :: Type -> Type -> Message -> LintM ()
 421 checkTys _ty1 _ty2 _msg = LintM $ \_loc _scope errs
 422  -> -- if (ty1 == ty2) then
 423     ((), errs)
 424     -- else ((), addErr errs msg loc)
 425 \end{code}
 426
 427 \begin{code}
 428 mkCaseAltMsg :: [StgAlt] -> Message
 429 mkCaseAltMsg _alts
 430   = ($$) (text "In some case alternatives, type of alternatives not all same:")
 431             (empty) -- LATER: ppr alts
 432
 433 mkDefltMsg :: Id -> Message
 434 mkDefltMsg _bndr
 435   = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:"))
 436             (panic "mkDefltMsg")
 437
 438 mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message
 439 mkFunAppMsg fun_ty arg_tys expr
 440   = vcat [text "In a function application, function type doesn't match arg types:",
 441               hang (ptext (sLit "Function type:")) 4 (ppr fun_ty),
 442               hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)),
 443               hang (ptext (sLit "Expression:")) 4 (ppr expr)]
 444
 445 mkRhsConMsg :: Type -> [Type] -> Message
 446 mkRhsConMsg fun_ty arg_tys
 447   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
 448               hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty),
 449               hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))]
 450
 451 mkAltMsg1 :: Type -> Message
 452 mkAltMsg1 ty
 453   = ($$) (text "In a case expression, type of scrutinee does not match patterns")
 454          (ppr ty)
 455
 456 mkAlgAltMsg2 :: Type -> DataCon -> Message
 457 mkAlgAltMsg2 ty con
 458   = vcat [
 459         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 460         ppr ty,
 461         ppr con
 462     ]
 463
 464 mkAlgAltMsg3 :: DataCon -> [Id] -> Message
 465 mkAlgAltMsg3 con alts
 466   = vcat [
 467         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 468         ppr con,
 469         ppr alts
 470     ]
 471
 472 mkAlgAltMsg4 :: Type -> Id -> Message
 473 mkAlgAltMsg4 ty arg
 474   = vcat [
 475         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 476         ppr ty,
 477         ppr arg
 478     ]
 479
 480 mkCaseOfCaseMsg :: StgExpr -> Message
 481 mkCaseOfCaseMsg e
 482   = text "Case of non-tail-call:" $$ ppr e
 483
 484 mkRhsMsg :: Id -> Type -> Message
 485 mkRhsMsg binder ty
 486   = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
 487                      ppr binder],
 488               hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
 489               hsep [ptext (sLit "Rhs type:"), ppr ty]
 490              ]
 491
 492 mkUnLiftedTyMsg :: Id -> StgRhs -> SDoc
 493 mkUnLiftedTyMsg binder rhs
 494   = (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+>
 495      ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
 496     $$
 497     (ptext (sLit "RHS:") <+> ppr rhs)
 498 \end{code}