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