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