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)                   = mapM_ lintTyUSPConst tys
 214 lintTyUSPConst (FunTy ty1 ty2)                     = do { lintTyUSPConst ty1
 215                                                         ; lintTyUSPConst ty2
 216                                                         }
 217 lintTyUSPConst (ForAllTy _ ty)                     = do { lintTyUSPConst ty }
 218
 219 lintTyUSPConst ty0@(NoteTy (UsgNote (UsVar _)) ty) = do { errULM "unexpected usage variable" ty0
 220                                                         ; lintTyUSPConst ty
 221                                                         }
 222 lintTyUSPConst ty0@(NoteTy (UsgNote _)         ty) = do { lintTyUSPConst ty }
 223 lintTyUSPConst ty0@(NoteTy (SynNote sty)       ty) = do { lintTyUSPConst sty
 224                                                         ; lintTyUSPConst ty
 225                                                         }
 226 lintTyUSPConst ty0@(NoteTy (FTVNote _)         ty) = do { lintTyUSPConst ty }
 227 \end{code}
 228
 229
 230 Now the combined function and the invocation of @genAnnotBinds@ to do the real work.
 231
 232 \begin{code}
 233 lintUSPConstTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
 234
 235 lintUSPConstTyM mf ty = AnnotM $ \ m ve ->
 236                            (ty,
 237                             do { m
 238                                ; atLocULM (mfLoc mf) $
 239                                    lintTyUSPConst ty
 240                                },
 241                             ve)
 242
 243 lintUSPConstBinds :: [CoreBind]
 244                   -> ULintM ()
 245
 246 lintUSPConstBinds binds = case initAnnotM (return ()) $
 247                                  genAnnotBinds lintUSPConstTyM return binds of
 248                                            -- **! should check with mungeTerm too!
 249                             (_,m) -> m
 250 \end{code}
 251
 252 ======================================================================
 253
 254 Checking annotations don't get any worse
 255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 256
 257 It is assumed that all transformations in GHC are `work-safe', that
 258 is, they do not cause any work to be duplicated.  Thus they should
 259 also be safe wrt the UsageSP analysis: if an identifier has a
 260 used-once type at one point, the identifier should never become
 261 used-many after transformation.  This check verifies that this is the
 262 case.
 263
 264 The arguments are the CoreBinds before and after the inference.  They
 265 must have exactly the same shape apart from usage annotations.
 266
 267 We only bother checking binders; free variables *should* be fixed
 268 already since they are imported and not changeable.
 269
 270 First, the various kinds of worsenings we can have:
 271
 272 \begin{code}
 273 data WorseErr = WorseVar  Var Var  -- variable gets worse
 274               | WorseTerm CoreExpr  CoreExpr   -- term gets worse
 275               | WorseLam  Var Var  -- lambda gets worse
 276
 277 instance Outputable WorseErr where
 278   ppr (WorseVar v0 v)  = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon
 279                          <+> (   ptext SLIT("was") <+> ppr (varType v0)
 280                               $$ ptext SLIT("now") <+> ppr (varType v))
 281   ppr (WorseTerm e0 e) = ptext SLIT("Term:")
 282                          <+> (   ptext SLIT("was") <+> ppr e0
 283                               $$ ptext SLIT("now") <+> ppr e)
 284   ppr (WorseLam v0 v)  = ptext SLIT("Lambda:")
 285                          <+> (   ppr v0
 286                               $$ ptext SLIT("(lambda-bound var info for var worsened)"))
 287 \end{code}
 288
 289 Now the checker.
 290
 291 \begin{code}
 292 checkIfWorseUSP :: [CoreBind]  -- old binds
 293                 -> [CoreBind]  -- new binds
 294                 -> Maybe SDoc  -- maybe warnings
 295
 296 checkIfWorseUSP binds binds'
 297   = let vvs = checkBinds binds binds'
 298     in  if isEmptyBag vvs then
 299           Nothing
 300         else
 301           Just $ ptext SLIT("UsageSP warning: annotations worsen for")
 302                  $$ nest 4 (vcat (map ppr (bagToList vvs)))
 303
 304 checkBinds :: [CoreBind] -> [CoreBind] -> Bag WorseErr
 305 checkBinds binds binds' = unionManyBags $
 306                             zipWithEqual "UsageSPLint.checkBinds" checkBind binds binds'
 307
 308 checkBind :: CoreBind -> CoreBind -> Bag WorseErr
 309 checkBind (NonRec v e) (NonRec v' e') = (checkVar v v') `unionBags` (checkCE e e')
 310 checkBind (Rec ves)    (Rec ves')     = unionManyBags $
 311                                           zipWithEqual "UsageSPLint.checkBind"
 312                                             (\ (v,e) (v',e') -> (checkVar v v')
 313                                                                 `unionBags` (checkCE e e'))
 314                                             ves ves'
 315 checkBind _            _              = panic "UsageSPLint.checkBind"
 316
 317
 318 checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr
 319
 320 checkCE (Var _)               (Var _)                = emptyBag
 321 checkCE (Lit _)               (Lit _)                = emptyBag
 322
 323 checkCE (App e arg)           (App e' arg')          = (checkCE e e')
 324                                                        `unionBags` (checkCE arg arg')
 325
 326 checkCE (Lam v e)             (Lam v' e')            = (checkVar v v')
 327                                                        `unionBags` (checkLamVar v v')
 328                                                        `unionBags` (checkCE e e')
 329
 330 checkCE (Let bind e)          (Let bind' e')         = (checkBind bind bind')
 331                                                        `unionBags` (checkCE e e')
 332
 333 checkCE (Case e v alts)       (Case e' v' alts')
 334   = (checkCE e e')
 335     `unionBags` (checkVar v v')
 336     `unionBags` (unionManyBags $
 337                    zipWithEqual "usageSPLint.checkCE:Case"
 338                      checkAlts alts alts')
 339   where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
 340                                                            checkVar vs vs')
 341                                         `unionBags` (checkCE e e')
 342
 343 checkCE (Note (SCC _) e)      (Note (SCC _) e')      = checkCE e e'
 344
 345 checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
 346
 347 checkCE (Note InlineCall e)   (Note InlineCall e')   = checkCE e e'
 348
 349 checkCE (Note InlineMe   e)   (Note InlineMe   e')   = checkCE e e'
 350
 351 checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
 352                                                      = checkCE e e'
 353                                                        `unionBags` (checkUsg u u' (WorseTerm t t'))
 354
 355 checkCE (Type _)              (Type _)               = emptyBag
 356
 357 checkCE t                     t'                     = pprPanic "usageSPLint.checkCE:"
 358                                                          (ppr t $$ text "doesn't match" <+> ppr t')
 359
 360
 361 -- does binder change from Once to Many?
 362 -- notice we only check the top-level annotation; this is all that's necessary.  KSW 1999-04.
 363 checkVar :: Var -> Var -> Bag WorseErr
 364 checkVar v v' | isTyVar v       = emptyBag
 365               | not (isUsgTy y) = emptyBag  -- if initially no annot, definitely OK
 366               | otherwise       = checkUsg u u' (WorseVar v v')
 367   where y  = varType v
 368         y' = varType v'
 369         u  = tyUsg y
 370         u' = tyUsg y'
 371
 372 -- does lambda change from Once to Many?
 373 checkLamVar :: Var -> Var -> Bag WorseErr
 374 checkLamVar v v' | isTyVar v = emptyBag
 375                  | otherwise = case (idLBVarInfo v, idLBVarInfo v') of
 376                                  (NoLBVarInfo    , _              ) -> emptyBag
 377                                  (IsOneShotLambda, IsOneShotLambda) -> emptyBag
 378                                  (IsOneShotLambda, NoLBVarInfo    ) -> unitBag (WorseLam v v')
 379
 380 -- does term usage annotation change from Once to Many?
 381 checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
 382 checkUsg UsMany _      _   = emptyBag
 383 checkUsg UsOnce UsOnce _   = emptyBag
 384 checkUsg UsOnce UsMany err = unitBag err
 385 \end{code}
 386
 387 ======================================================================
 388
 389 Lint monad stuff
 390 ~~~~~~~~~~~~~~~~
 391
 392 The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
 393 also tracks the location of the current type being checked.
 394
 395 \begin{code}
 396 data ULintErr = ULintErr SDoc String Type
 397
 398 pprULintErr :: ULintErr -> SDoc
 399 pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
 400                                        4 (ppr ty)
 401
 402
 403 newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
 404 unULintM (ULintM f) = f
 405
 406 instance Monad ULintM where
 407   m >>= f  = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
 408                                    (a',errs') = (unULintM (f a)) loc
 409                                in  (a', errs `unionBags` errs')
 410   return a = ULintM $ \ _   -> (a,emptyBag)
 411
 412 atLocULM :: SDoc -> ULintM a -> ULintM a
 413 atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
 414
 415 errULM :: String -> Type -> ULintM ()
 416 errULM err ty
 417   = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
 418
 419 mayErrULM :: Bool -> String -> Type -> ULintM ()
 420 mayErrULM f err ty
 421   = if f then errULM err ty else return ()
 422
 423 runULM :: ULintM a -> Maybe SDoc
 424 runULM m = case (unULintM m) (panic "runULM: no location") of
 425              (_,errs) -> if isEmptyBag errs
 426                          then Nothing
 427                          else Just (vcat (map pprULintErr (bagToList errs)))
 428
 429 END OF ENTIRELY-COMMENTED-OUT FILE   -- KSW 2000-10-13 -}
 430 \end{code}
 431
 432 ======================================================================
 433
 434 EOF