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