ghc/compiler/usageSP/UsageSPLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[UsageSPLint]{UsageSP ``lint'' pass}
   5
   6 This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
   7 September 1998 .. May 1999.
   8
   9 Keith Wansbrough 1998-09-04..1999-06-25
  10
  11 \begin{code}
  12 module UsageSPLint ( doLintUSPAnnotsBinds,
  13                      doLintUSPConstBinds,
  14                      doLintUSPBinds,
  15                      doCheckIfWorseUSP,
  16                    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import UsageSPUtils
  21 import CoreSyn
  22 import TypeRep          ( Type(..), TyNote(..) )  -- friend
  23 import Type             ( UsageAnn(..), isUsgTy, tyUsg )
  24 import TyCon            ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
  25 import Var              ( Var, varType )
  26 import Id               ( idLBVarInfo )
  27 import IdInfo           ( LBVarInfo(..) )
  28 import SrcLoc           ( noSrcLoc )
  29 import ErrUtils         ( Message, ghcExit )
  30 import Util             ( zipWithEqual )
  31 import PprCore
  32 import Bag
  33 import Outputable
  34 \end{code}
  35
  36 ======================================================================
  37
  38 Interface
  39 ~~~~~~~~~
  40
  41 @doLintUSPAnnotsBinds@ checks that annotations are in the correct positions.
  42 @doLintUSPConstsBinds@ checks that no @UVar@s remain anywhere (i.e., all annots are constants).
  43 @doLintUSPBinds@ checks that the annotations are consistent.  [unimplemented!]
  44 @doCheckIfWorseUSP@ checks that annots on binders have not changed from Once to Many.
  45
  46 \begin{code}
  47 doLint :: ULintM a -> IO ()
  48
  49 doLint m = case runULM m of
  50              Nothing -> return ()
  51              Just bad_news -> do { printDump (display bad_news)
  52                                  ; ghcExit 1
  53                                  }
  54   where display bad_news = vcat [ text "*** LintUSP errors: ***"
  55                                 , bad_news
  56                                 , text "*** end of LintUSP errors ***"
  57                                 ]
  58
  59 doLintUSPAnnotsBinds, doLintUSPConstBinds :: [CoreBind] -> IO ()
  60
  61 doLintUSPAnnotsBinds = doLint . lintUSPAnnotsBinds
  62 doLintUSPConstBinds  = doLint . lintUSPConstBinds
  63
  64 -- doLintUSPBinds is defined below
  65
  66 doCheckIfWorseUSP :: [CoreBind] -> [CoreBind] -> IO ()
  67
  68 doCheckIfWorseUSP binds binds'
  69   = case checkIfWorseUSP binds binds' of
  70       Nothing    -> return ()
  71       Just warns -> printErrs warns
  72 \end{code}
  73
  74 ======================================================================
  75
  76 Verifying correct annotation positioning
  77 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  78
  79 The following functions check whether the usage annotations are
  80 correctly placed on a type.  They sit inside the lint monad.
  81 @lintUSPAnnots@ assumes there should be an outermost annotation,
  82 @lintUSPAnnotsN@ assumes there shouldn't.
  83
  84 The fact that no general catch-all pattern is given for @NoteTy@s is
  85 entirely intentional.  The meaning of future extensions here is
  86 entirely unknown, so you'll have to decide how to check them
  87 explicitly.
  88
  89 \begin{code}
  90 lintTyUSPAnnots :: Bool        -- die on omitted annotation?
  91                 -> Bool        -- die on extra annotation?
  92                 -> Type        -- type to check
  93                 -> ULintM ()
  94
  95 lintTyUSPAnnots fom fex = lint
  96   where
  97     lint     (NoteTy (UsgNote _) ty) = lintTyUSPAnnotsN fom fex ty
  98     lint ty0                         = do { mayErrULM fom "missing UsgNote" ty0
  99                                           ; lintTyUSPAnnotsN fom fex ty0
 100                                           }
 101
 102 lintTyUSPAnnotsN :: Bool        -- die on omitted annotation?
 103                  -> Bool        -- die on extra annotation?
 104                  -> Type        -- type to check
 105                  -> ULintM ()
 106
 107 lintTyUSPAnnotsN fom fex = lintN
 108   where
 109     lintN ty0@(NoteTy (UsgNote _)   ty) = do { mayErrULM fex "unexpected UsgNote" ty0
 110                                              ; lintN ty
 111                                              }
 112     lintN     (NoteTy (SynNote sty) ty) = do { lintN sty
 113                                              ; lintN ty
 114                                              }
 115     lintN     (NoteTy (FTVNote _)   ty) = do { lintN ty }
 116
 117     lintN     (TyVarTy _)               = do { return () }
 118     lintN     (AppTy ty1 ty2)           = do { lintN ty1
 119                                              ; lintN ty2
 120                                              }
 121     lintN     (TyConApp tc tys)         = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
 122                                           do { let thelint = if isFunTyCon tc
 123                                                              then lintTyUSPAnnots fom fex
 124                                                              else lintN
 125                                              ; mapM thelint tys
 126                                              ; return ()
 127                                              }
 128     lintN     (FunTy ty1 ty2)           = do { lintTyUSPAnnots fom fex ty1
 129                                              ; lintTyUSPAnnots fom fex ty2
 130                                              }
 131     lintN     (ForAllTy _ ty)           = do { lintN ty }
 132 \end{code}
 133
 134
 135 Now the combined function that takes a @MungeFlags@ to tell it what to
 136 do to a particular type.  This is passed to @genAnnotBinds@ to get the
 137 work done.
 138
 139 \begin{code}
 140 lintUSPAnnotsTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
 141
 142 lintUSPAnnotsTyM mf ty = AnnotM $ \ m ve ->
 143                            (ty, do { m
 144                                    ; atLocULM (mfLoc mf) $
 145                                        (if isSigma mf
 146                                         then lintTyUSPAnnots
 147                                         else lintTyUSPAnnotsN) checkOmitted True ty
 148                                    },
 149                             ve)
 150 #ifndef USMANY
 151   where checkOmitted = False  -- OK to omit Many if !USMANY
 152 #else
 153   where checkOmitted = True   -- require all annotations
 154 #endif
 155
 156 lintUSPAnnotsBinds :: [CoreBind]
 157                    -> ULintM ()
 158
 159 lintUSPAnnotsBinds binds = case initAnnotM (return ()) $
 160                                   genAnnotBinds lintUSPAnnotsTyM return binds of
 161                                            -- **! should check with mungeTerm too!
 162                              (_,m) -> m
 163 \end{code}
 164
 165 ======================================================================
 166
 167 Verifying correct usage typing
 168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 169
 170 The following function verifies that all usage annotations are
 171 consistent.  It assumes that there are no usage variables, only
 172 @UsOnce@ and @UsMany@ annotations.
 173
 174 This is very similar to usage inference, however, and so we could
 175 simply use that, with a little work.  For now, it's unimplemented.
 176
 177 \begin{code}
 178 doLintUSPBinds :: [CoreBind] -> IO ()
 179
 180 doLintUSPBinds binds = panic "doLintUSPBinds unimplemented"
 181                     {- case initUs us (uniqSMMToUs (usgInfBinds binds)) of
 182                          ((ucs,_),_) -> if isJust (solveUCS ucs)
 183                                         then return ()
 184                                         else do { printDump (text "*** LintUSPBinds failed ***")
 185                                                 ; ghcExit 1
 186                                                 }
 187                      -}
 188 \end{code}
 189
 190 ======================================================================
 191
 192 Verifying usage constants only (not vars)
 193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 194
 195 The following function checks that all usage annotations are ground,
 196 i.e., @UsOnce@ or @UsMany@: no @UVar@s remain.
 197
 198 \begin{code}
 199 lintTyUSPConst :: Type
 200                -> ULintM ()
 201
 202 lintTyUSPConst (TyVarTy _)                         = do { return () }
 203
 204 lintTyUSPConst (AppTy ty1 ty2)                     = do { lintTyUSPConst ty1
 205                                                         ; lintTyUSPConst ty2
 206                                                         }
 207 lintTyUSPConst (TyConApp tc tys)                   = do { mapM lintTyUSPConst tys
 208                                                         ; return ()
 209                                                         }
 210 lintTyUSPConst (FunTy ty1 ty2)                     = do { lintTyUSPConst ty1
 211                                                         ; lintTyUSPConst ty2
 212                                                         }
 213 lintTyUSPConst (ForAllTy _ ty)                     = do { lintTyUSPConst ty }
 214
 215 lintTyUSPConst ty0@(NoteTy (UsgNote (UsVar _)) ty) = do { errULM "unexpected usage variable" ty0
 216                                                         ; lintTyUSPConst ty
 217                                                         }
 218 lintTyUSPConst ty0@(NoteTy (UsgNote _)         ty) = do { lintTyUSPConst ty }
 219 lintTyUSPConst ty0@(NoteTy (SynNote sty)       ty) = do { lintTyUSPConst sty
 220                                                         ; lintTyUSPConst ty
 221                                                         }
 222 lintTyUSPConst ty0@(NoteTy (FTVNote _)         ty) = do { lintTyUSPConst ty }
 223 \end{code}
 224
 225
 226 Now the combined function and the invocation of @genAnnotBinds@ to do the real work.
 227
 228 \begin{code}
 229 lintUSPConstTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
 230
 231 lintUSPConstTyM mf ty = AnnotM $ \ m ve ->
 232                            (ty,
 233                             do { m
 234                                ; atLocULM (mfLoc mf) $
 235                                    lintTyUSPConst ty
 236                                },
 237                             ve)
 238
 239 lintUSPConstBinds :: [CoreBind]
 240                   -> ULintM ()
 241
 242 lintUSPConstBinds binds = case initAnnotM (return ()) $
 243                                  genAnnotBinds lintUSPConstTyM return binds of
 244                                            -- **! should check with mungeTerm too!
 245                             (_,m) -> m
 246 \end{code}
 247
 248 ======================================================================
 249
 250 Checking annotations don't get any worse
 251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 252
 253 It is assumed that all transformations in GHC are `work-safe', that
 254 is, they do not cause any work to be duplicated.  Thus they should
 255 also be safe wrt the UsageSP analysis: if an identifier has a
 256 used-once type at one point, the identifier should never become
 257 used-many after transformation.  This check verifies that this is the
 258 case.
 259
 260 The arguments are the CoreBinds before and after the inference.  They
 261 must have exactly the same shape apart from usage annotations.
 262
 263 We only bother checking binders; free variables *should* be fixed
 264 already since they are imported and not changeable.
 265
 266 First, the various kinds of worsenings we can have:
 267
 268 \begin{code}
 269 data WorseErr = WorseVar  Var Var  -- variable gets worse
 270               | WorseTerm CoreExpr  CoreExpr   -- term gets worse
 271               | WorseLam  Var Var  -- lambda gets worse
 272
 273 instance Outputable WorseErr where
 274   ppr (WorseVar v0 v)  = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon
 275                          <+> (   ptext SLIT("was") <+> ppr (varType v0)
 276                               $$ ptext SLIT("now") <+> ppr (varType v))
 277   ppr (WorseTerm e0 e) = ptext SLIT("Term:")
 278                          <+> (   ptext SLIT("was") <+> ppr e0
 279                               $$ ptext SLIT("now") <+> ppr e)
 280   ppr (WorseLam v0 v)  = ptext SLIT("Lambda:")
 281                          <+> (   ppr v0
 282                               $$ ptext SLIT("(lambda-bound var info for var worsened)"))
 283 \end{code}
 284
 285 Now the checker.
 286
 287 \begin{code}
 288 checkIfWorseUSP :: [CoreBind]  -- old binds
 289                 -> [CoreBind]  -- new binds
 290                 -> Maybe SDoc  -- maybe warnings
 291
 292 checkIfWorseUSP binds binds'
 293   = let vvs = checkBinds binds binds'
 294     in  if isEmptyBag vvs then
 295           Nothing
 296         else
 297           Just $ ptext SLIT("UsageSP warning: annotations worsen for")
 298                  $$ nest 4 (vcat (map ppr (bagToList vvs)))
 299
 300 checkBinds :: [CoreBind] -> [CoreBind] -> Bag WorseErr
 301 checkBinds binds binds' = unionManyBags $
 302                             zipWithEqual "UsageSPLint.checkBinds" checkBind binds binds'
 303
 304 checkBind :: CoreBind -> CoreBind -> Bag WorseErr
 305 checkBind (NonRec v e) (NonRec v' e') = (checkVar v v') `unionBags` (checkCE e e')
 306 checkBind (Rec ves)    (Rec ves')     = unionManyBags $
 307                                           zipWithEqual "UsageSPLint.checkBind"
 308                                             (\ (v,e) (v',e') -> (checkVar v v')
 309                                                                 `unionBags` (checkCE e e'))
 310                                             ves ves'
 311 checkBind _            _              = panic "UsageSPLint.checkBind"
 312
 313
 314 checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr
 315
 316 checkCE (Var _)               (Var _)                = emptyBag
 317 checkCE (Lit _)               (Lit _)                = emptyBag
 318
 319 checkCE (App e arg)           (App e' arg')          = (checkCE e e')
 320                                                        `unionBags` (checkCE arg arg')
 321
 322 checkCE (Lam v e)             (Lam v' e')            = (checkVar v v')
 323                                                        `unionBags` (checkLamVar v v')
 324                                                        `unionBags` (checkCE e e')
 325
 326 checkCE (Let bind e)          (Let bind' e')         = (checkBind bind bind')
 327                                                        `unionBags` (checkCE e e')
 328
 329 checkCE (Case e v alts)       (Case e' v' alts')
 330   = (checkCE e e')
 331     `unionBags` (checkVar v v')
 332     `unionBags` (unionManyBags $
 333                    zipWithEqual "usageSPLint.checkCE:Case"
 334                      checkAlts alts alts')
 335   where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
 336                                                            checkVar vs vs')
 337                                         `unionBags` (checkCE e e')
 338
 339 checkCE (Note (SCC _) e)      (Note (SCC _) e')      = checkCE e e'
 340
 341 checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
 342
 343 checkCE (Note InlineCall e)   (Note InlineCall e')   = checkCE e e'
 344
 345 checkCE (Note InlineMe   e)   (Note InlineMe   e')   = checkCE e e'
 346
 347 checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
 348                                                      = checkCE e e'
 349                                                        `unionBags` (checkUsg u u' (WorseTerm t t'))
 350
 351 checkCE (Type _)              (Type _)               = emptyBag
 352
 353 checkCE t                     t'                     = pprPanic "usageSPLint.checkCE:"
 354                                                          (ppr t $$ text "doesn't match" <+> ppr t')
 355
 356
 357 -- does binder change from Once to Many?
 358 -- notice we only check the top-level annotation; this is all that's necessary.  KSW 1999-04.
 359 checkVar :: Var -> Var -> Bag WorseErr
 360 checkVar v v' | isTyVar v       = emptyBag
 361               | not (isUsgTy y) = emptyBag  -- if initially no annot, definitely OK
 362               | otherwise       = checkUsg u u' (WorseVar v v')
 363   where y  = varType v
 364         y' = varType v'
 365         u  = tyUsg y
 366         u' = tyUsg y'
 367
 368 -- does lambda change from Once to Many?
 369 checkLamVar :: Var -> Var -> Bag WorseErr
 370 checkLamVar v v' | isTyVar v = emptyBag
 371                  | otherwise = case (idLBVarInfo v, idLBVarInfo v') of
 372                                  (NoLBVarInfo    , _              ) -> emptyBag
 373                                  (IsOneShotLambda, IsOneShotLambda) -> emptyBag
 374                                  (IsOneShotLambda, NoLBVarInfo    ) -> unitBag (WorseLam v v')
 375
 376 -- does term usage annotation change from Once to Many?
 377 checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
 378 checkUsg UsMany _      _   = emptyBag
 379 checkUsg UsOnce UsOnce _   = emptyBag
 380 checkUsg UsOnce UsMany err = unitBag err
 381 \end{code}
 382
 383 ======================================================================
 384
 385 Lint monad stuff
 386 ~~~~~~~~~~~~~~~~
 387
 388 The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
 389 also tracks the location of the current type being checked.
 390
 391 \begin{code}
 392 data ULintErr = ULintErr SDoc String Type
 393
 394 pprULintErr :: ULintErr -> SDoc
 395 pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
 396                                        4 (ppr ty)
 397
 398
 399 newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
 400 unULintM (ULintM f) = f
 401
 402 instance Monad ULintM where
 403   m >>= f  = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
 404                                    (a',errs') = (unULintM (f a)) loc
 405                                in  (a', errs `unionBags` errs')
 406   return a = ULintM $ \ _   -> (a,emptyBag)
 407
 408 atLocULM :: SDoc -> ULintM a -> ULintM a
 409 atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
 410
 411 errULM :: String -> Type -> ULintM ()
 412 errULM err ty
 413   = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
 414
 415 mayErrULM :: Bool -> String -> Type -> ULintM ()
 416 mayErrULM f err ty
 417   = if f then errULM err ty else return ()
 418
 419 runULM :: ULintM a -> Maybe SDoc
 420 runULM m = case (unULintM m) (panic "runULM: no location") of
 421              (_,errs) -> if isEmptyBag errs
 422                          then Nothing
 423                          else Just (vcat (map pprULintErr (bagToList errs)))
 424 \end{code}
 425
 426 ======================================================================
 427
 428 EOF