ghc/compiler/usageSP/UsageSPInf.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[UsageSPInf]{UsageSP Inference Engine}
   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-07-06
  10
  11 \begin{code}
  12 module UsageSPInf ( doUsageSPInf ) where
  13
  14 #include "HsVersions.h"
  15
  16 import UsageSPUtils
  17 import UsageSPLint
  18 import UConSet
  19
  20 import CoreSyn
  21 import CoreFVs          ( mustHaveLocalBinding )
  22 import Rules            ( RuleBase )
  23 import TypeRep          ( Type(..), TyNote(..) ) -- friend
  24 import Type             ( UsageAnn(..),
  25                           applyTy, applyTys,
  26                           splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
  27                           mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
  28                           splitUsForAllTys, substUsTy,
  29                           mkFunTy, mkForAllTy )
  30 import TyCon            ( tyConArgVrcs_maybe, isFunTyCon )
  31 import Literal          ( Literal(..), literalType )
  32 import Var              ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
  33 import IdInfo           ( setLBVarInfo, LBVarInfo(..) )
  34 import Id               ( isExportedId )
  35 import VarEnv
  36 import VarSet
  37 import UniqSupply       ( UniqSupply, UniqSM,
  38                           initUs, splitUniqSupply )
  39 import Outputable
  40 import Maybes           ( expectJust )
  41 import List             ( unzip4 )
  42 import CmdLineOpts      ( DynFlags, DynFlag(..), dopt, opt_UsageSPOn )
  43 import CoreLint         ( beginPass, endPass )
  44 import ErrUtils         ( doIfSet_dyn, dumpIfSet_dyn )
  45 import PprCore          ( pprCoreBindings )
  46 \end{code}
  47
  48 ======================================================================
  49
  50 -- **!  wasn't I going to do something about not requiring annotations
  51 -- to be correct on unpointed types and/or those without haskell pointers
  52 -- inside?
  53
  54 The whole inference
  55 ~~~~~~~~~~~~~~~~~~~
  56
  57 For full details, see _Once Upon a Polymorphic Type_, University of
  58 Glasgow Department of Computing Science Technical Report TR-1998-19,
  59 December 1998, or the summary in POPL'99.
  60
  61 [** NEW VERSION NOW IMPLEMENTED; different from the papers
  62     above. Hopefully to appear in PLDI'00, and Keith Wansbrough's
  63     University of Cambridge PhD thesis, c. Sep 2000 **]
  64
  65
  66 Inference is performed as follows:
  67
  68   1.  Remove all manipulable[*] annotations.
  69
  70   2.  Walk over the resulting term adding fresh UVar annotations,
  71       applying the type rules and collecting the constraints.
  72
  73   3.  Find the solution to the constraints and apply the substitution
  74       to the annotations, leaving a @UVar@-free term.
  75
  76 [*] A manipulable annotation is one derived from the current source
  77 module, as opposed to one derived from an import, which we are clearly
  78 not allowed to alter.
  79
  80 As in the paper, a ``tau-type'' is a type that does *not* have an
  81 annotation on top (although it may have some inside), and a
  82 ``sigma-type'' is one that does (i.e., is a tau-type with an
  83 annotation added).  Also, a ``rho-type'' is one that may have initial
  84 ``\/u.''s.  This conflicts with the totally unrelated usage of these
  85 terms in the remainder of GHC.  Caveat lector!  KSW 1999-07.
  86
  87
  88 The inference is done over a set of @CoreBind@s, and inside the IO
  89 monad.
  90
  91 \begin{code}
  92 doUsageSPInf :: DynFlags
  93              -> UniqSupply
  94              -> [CoreBind]
  95              -> IO [CoreBind]
  96
  97 doUsageSPInf dflags us binds
  98   | not opt_UsageSPOn
  99   = do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
 100          return binds
 101     }
 102
 103   | otherwise
 104   = do
 105         let binds1 = doUnAnnotBinds binds
 106
 107         beginPass dflags "UsageSPInf"
 108
 109         dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
 110                              pprCoreBindings binds1
 111
 112         let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
 113
 114         dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf annot'd" $
 115           pprCoreBindings binds2
 116
 117         let ms     = solveUCS ucs
 118             s      = case ms of
 119                        Just s  -> s
 120                        Nothing -> panic "doUsageSPInf: insol. conset!"
 121             binds3 = appUSubstBinds s binds2
 122
 123         doIfSet_dyn dflags Opt_DoUSPLinting $
 124           do doLintUSPAnnotsBinds binds3     -- lint check 1
 125              doLintUSPConstBinds  binds3     -- lint check 2 (force solution)
 126              doCheckIfWorseUSP binds binds3  -- check for worsening of usages
 127
 128         endPass dflags "UsageSPInf" (dopt Opt_D_dump_usagesp dflags) binds3
 129
 130         return binds3
 131 \end{code}
 132
 133 ======================================================================
 134
 135 Inferring an expression
 136 ~~~~~~~~~~~~~~~~~~~~~~~
 137
 138 Inference takes an annotated (rho-typed) environment and an expression
 139 unannotated except for variables not appearing in the environment.  It
 140 returns an annotated expression, a type, a constraint set, and a
 141 multiset of free variables.  It is in the unique supply monad, which
 142 supplies fresh uvars for annotation.
 143
 144 We conflate usage metavariables and usage variables; the latter are
 145 distinguished by falling within the scope of a usage binder.
 146
 147 \begin{code}
 148 usgInfBinds :: VarEnv Var            -- incoming environment (usu. empty)
 149             -> [CoreBind]            -- CoreBinds in dependency order
 150             -> UniqSMM ([CoreBind],  -- annotated CoreBinds
 151                         UConSet,     -- constraint set
 152                         VarMultiset) -- usage of environment vars
 153
 154 usgInfBinds ve []
 155   = return ([],
 156             emptyUConSet,
 157             emptyMS)
 158
 159 usgInfBinds ve (b0:b0s)
 160 -- (this clause is almost the same as the Let clause)
 161   = do (v1s,ve1,b1,h1,fb1,fa1) <- usgInfBind  ve  b0
 162        (b2s,h2,f2)             <- usgInfBinds ve1 b0s
 163        let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
 164        return (b1:b2s,
 165                unionUCSs [h1,h2,h3],
 166                fa1 `plusMS` (f2 `delsFromMS` v1s))
 167
 168
 169 usgInfBind :: VarEnv Var
 170            -> CoreBind               -- CoreBind to infer for
 171            -> UniqSMM ([Var],        -- variables bound
 172                        VarEnv Var,   -- extended VarEnv
 173                        CoreBind,     -- annotated CoreBind
 174                        UConSet,      -- constraints generated by this CoreBind
 175                        VarMultiset,  -- this bd's use of vars bound in this bd
 176                                      --   (could be anything for other vars)
 177                        VarMultiset)  -- this bd's use of other vars
 178
 179 usgInfBind ve (NonRec v1 e1)
 180   = do (v1',y1u) <- annotVar v1
 181        (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v1 v1') e1
 182        let h3        = usgSubTy y2u y1u
 183            h4        = h2 `unionUCS` h3
 184            (y4r,h4') = usgClos ve y2u h4
 185            v1''      = setVarType v1 y4r
 186            h5        = if isExportedId v1 then pessimise y4r else emptyUConSet
 187        return ([v1''],
 188                extendVarEnv ve v1 v1'',
 189                NonRec v1'' e2,
 190                h4' `unionUCS` h5,
 191                emptyMS,
 192                f2)
 193
 194 usgInfBind ve (Rec ves)
 195   = do let (v1s,e1s) = unzip ves
 196        vy1s' <- mapM annotVar v1s
 197        let (v1s',y1us) = unzip vy1s'
 198            ve'  = ve `plusVarEnv` (zipVarEnv v1s v1s')
 199        eyhf2s <- mapM (usgInfCE ve') e1s
 200        let (e2s,y2us,h2s,f2s) = unzip4 eyhf2s
 201            h3s         = zipWith usgSubTy y2us y1us
 202            h4s         = zipWith unionUCS h2s h3s
 203            yh4s        = zipWith (usgClos ve) y2us h4s
 204            (y4rs,h4s') = unzip yh4s
 205            v1s''       = zipWith setVarType v1s y4rs
 206            f5          = foldl plusMS emptyMS f2s
 207            h6s         = zipWith (\ v y -> if isExportedId v then pessimise y else emptyUConSet)
 208                                  v1s y4rs
 209        return (v1s'',
 210                ve `plusVarEnv` (zipVarEnv v1s v1s''),
 211                Rec (zip v1s'' e2s),
 212                unionUCSs (h4s' ++ h6s),
 213                f5,
 214                f5 `delsFromMS` v1s')  -- we take pains that v1'==v1'' etc
 215
 216
 217 usgInfCE :: VarEnv Var               -- unannotated -> annotated vars
 218          -> CoreExpr                 -- expression to annotate / infer
 219          -> UniqSMM (CoreExpr,       -- annotated expression        (e)
 220                      Type,           -- (sigma) type of expression  (y)(u=sigma)(r=rho)
 221                      UConSet,        -- set of constraints arising  (h)
 222                      VarMultiset)    -- variable occurrences        (f)
 223
 224 usgInfCE ve e0@(Var v) | isTyVar v
 225   = panic "usgInfCE: unexpected TyVar"
 226                        | otherwise
 227   = do v' <- instVar (lookupVar ve v)
 228        return $ ASSERT( isUsgTy (varType v' {-'cpp-}) )
 229                 (Var v',
 230                  varType v',
 231                  emptyUConSet,
 232                  unitMS v')
 233
 234 usgInfCE ve e0@(Lit lit)
 235   = do u1 <- newVarUSMM (Left e0)
 236        return (e0,
 237                mkUsgTy u1 (literalType lit),
 238                emptyUConSet,
 239                emptyMS)
 240
 241 {-  ------------------------------------
 242         No Con form now; we rely on usage information in the constructor itself
 243
 244 usgInfCE ve e0@(Con con args)
 245   = -- constant or primop.  guaranteed saturated.
 246     do let (ey1s,e1s) = span isTypeArg args
 247        y1s <- mapM (\ (Type ty) -> annotTyN (Left e0) ty) ey1s  -- univ. + exist.
 248        (y2us,y2u) <- case con of
 249                          DataCon c -> do u2 <- newVarUSMM (Left e0)
 250                                          return $ dataConTys c u2 y1s
 251                                          -- y1s is exdicts + args
 252                          PrimOp  p -> return $ primOpUsgTys p y1s
 253                          otherwise -> panic "usgInfCE: unrecognised Con"
 254        eyhf3s <- mapM (usgInfCE ve) e1s
 255        let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
 256            h4s = zipWith usgSubTy y3us y2us
 257        return $ ASSERT( isUsgTy y2u )
 258                 (Con con (map Type y1s ++ e3s),
 259                  y2u,
 260                  unionUCSs (h3s ++ h4s),
 261                  foldl plusMS emptyMS f3s)
 262
 263   whered ataConTys c u y1s
 264         -- compute argtys of a datacon
 265           = let cTy        = annotMany (dataConType c)  -- extra (sigma) annots later replaced
 266                 (y2us,y2u) = splitFunTys (applyTys cTy y1s)
 267                              -- safe 'cos a DataCon always returns a value of type (TyCon tys),
 268                              -- not an arrow type.
 269                 reUsg      = mkUsgTy u . unUsgTy
 270              in (map reUsg y2us, reUsg y2u)
 271 --------------------------------------------  -}
 272
 273
 274 usgInfCE ve e0@(App ea (Type yb))
 275   = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
 276        let (u1,ya1) = splitUsgTy ya1u
 277        yb1 <- annotTyN (Left e0) yb
 278        return (App ea1 (Type yb1),
 279                mkUsgTy u1 (applyTy ya1 yb1),
 280                ha1,
 281                fa1)
 282
 283 usgInfCE ve (App ea eb)
 284   = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
 285        let ( u1,ya1) = splitUsgTy ya1u
 286            (y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
 287        (eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
 288        let h4 = usgSubTy yb1u y2u
 289        return $ ASSERT( isUsgTy y3u )
 290                 (App ea1 eb1,
 291                  y3u,
 292                  unionUCSs [ha1,hb1,h4],
 293                  fa1 `plusMS` fb1)
 294
 295 usgInfCE ve e0@(Lam v0 e) | isTyVar v0
 296   = do (e1,y1u,h1,f1) <- usgInfCE ve e
 297        let (u1,y1) = splitUsgTy y1u
 298        return (Lam v0 e1,
 299                mkUsgTy u1 (mkForAllTy v0 y1),
 300                h1,
 301                f1)
 302
 303                      -- [OLD COMMENT:]
 304                      -- if used for checking also, may need to extend this case to
 305                      -- look in lbvarInfo instead.
 306                           | otherwise
 307   = do u1  <- newVarUSMM (Left e0)
 308        (v1,y1u) <- annotVar v0
 309        (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v0 v1) e
 310        let h3  = occChkUConSet v1 f2
 311            f2' = f2 `delFromMS` v1
 312            h4s = foldMS (\ v _ hs -> (leqUConSet u1 ((tyUsg . varType . lookupVar ve) v)
 313                                       : hs))  -- in reverse order!
 314                         []
 315                         f2'
 316        return (Note (TermUsg u1) (Lam v1 e2),  -- add annot for lbVarInfo computation
 317                mkUsgTy u1 (mkFunTy y1u y2u),
 318                unionUCSs (h2:h3:h4s),
 319                f2')
 320
 321 usgInfCE ve (Let b0s e0)
 322   = do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
 323        (e2,y2u,h2,f2)           <- usgInfCE ve1 e0
 324        let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
 325        return $ ASSERT( isUsgTy y2u )
 326                 (Let b1s e2,
 327                  y2u,
 328                  unionUCSs [h1,h2,h3],
 329                  fa1 `plusMS` (f2 `delsFromMS` v1s))
 330
 331 usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
 332 -- pure strict let, no selection (could be at polymorphic or function type)
 333   = do (v1,y1u) <- annotVar v0
 334        (e2,y2u,h2,f2) <- usgInfCE ve e0
 335        (e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
 336        let h4 = usgEqTy y2u y1u -- **! why not subty?
 337            h5 = occChkUConSet v1 f3
 338        return $ ASSERT( isUsgTy y3u )
 339                 (Case e2 v1 [(DEFAULT,[],e3)],
 340                  y3u,
 341                  unionUCSs [h2,h3,h4,h5],
 342                  f2 `plusMS` (f3 `delFromMS` v1))
 343
 344 usgInfCE ve e0@(Case e1 v1 alts)
 345 -- general case (tycon of scrutinee must be known)
 346 -- (assumes well-typed already; so doesn't check constructor)
 347   = do (v2,y1u) <- annotVar v1
 348        (e2,y2u,h2,f2) <- usgInfCE ve e1
 349        let h3       = usgEqTy y2u y1u -- **! why not subty?
 350            (u2,y2)  = splitUsgTy y2u
 351            (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2
 352            (cs,v1ss,es) = unzip3 alts
 353            v2ss     = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
 354                           v1ss
 355            ve3      = extendVarEnv ve v1 v2
 356        eyhf4s <- mapM (\ (v1s,v2s,e) -> usgInfCE (ve3 `plusVarEnv` (zipVarEnv v1s v2s)) e)
 357                       (zip3 v1ss v2ss es)
 358        let (e4s,y4us,h4s,f4s) = unzip4 eyhf4s
 359        y5u <- annotTy (Left e0) (unannotTy (head y4us))
 360        let h5s      = zipWith usgSubTy y4us (repeat y5u)
 361            h6s      = zipWith occChksUConSet v2ss f4s
 362            f4       = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
 363            h7       = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
 364        return $ ASSERT( isUsgTy y5u )
 365                 (Case e2 v2 (zip3 cs v2ss e4s),
 366                  y5u,
 367                  unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
 368                  f2 `plusMS` (f4 `delFromMS` v2))
 369
 370 usgInfCE ve e0@(Note note ea)
 371   = do (e1,y1u,h1,f1) <- usgInfCE ve ea
 372        case note of
 373          Coerce yb ya -> do let (u1,y1) = splitUsgTy y1u
 374                                 ya3 = annotManyN ya   -- really nasty type
 375                                 h3  = usgEqTy y1 ya3  -- messy but OK
 376                             yb3 <- annotTyN (Left e0) yb
 377              -- What this says is that a Coerce does the most general possible
 378              -- annotation to what's inside it (nasty, nasty), because no information
 379              -- can pass through a Coerce.  It of course simply ignores the info
 380              -- that filters down through into ty1, because it can do nothing with it.
 381              -- It does still pass through the topmost usage annotation, though.
 382                             return (Note (Coerce yb3 ya3) e1,
 383                                     mkUsgTy u1 yb3,
 384                                     unionUCSs [h1,h3],
 385                                     f1)
 386
 387          SCC _      -> return (Note note e1, y1u, h1, f1)
 388
 389          InlineCall -> return (Note note e1, y1u, h1, f1)
 390
 391          InlineMe   -> return (Note note e1, y1u, h1, f1)
 392
 393          TermUsg _  -> pprPanic "usgInfCE:Note TermUsg" $ ppr e0
 394
 395 usgInfCE ve e0@(Type _)
 396   = pprPanic "usgInfCE:Type" $ ppr e0
 397 \end{code}
 398
 399
 400 \begin{code}
 401 lookupVar :: VarEnv Var -> Var -> Var
 402 -- if variable in VarEnv then return annotated version,
 403 -- otherwise it's imported and already annotated so leave alone.
 404 --lookupVar ve v = error "lookupVar unimplemented"
 405 lookupVar ve v = case lookupVarEnv ve v of
 406                    Just v' -> v'
 407                    Nothing -> ASSERT( not (mustHaveLocalBinding v) )
 408                               ASSERT( isUsgTy (varType v) )
 409                               v
 410
 411 instVar :: Var -> UniqSMM Var
 412 -- instantiate variable with rho-type, giving it a fresh sigma-type
 413 instVar v = do let (uvs,ty) = splitUsForAllTys (varType v)
 414                case uvs of
 415                  [] -> return v
 416                  _  -> do uvs' <- mapM (\_ -> newVarUSMM (Left (Var v))) uvs
 417                           let ty' = substUsTy (zipVarEnv uvs uvs') ty
 418                           return (setVarType v ty')
 419
 420 annotVar :: Var -> UniqSMM (Var,Type)
 421 -- freshly annotates a variable and returns it along with its new type
 422 annotVar v = do y1u <- annotTy (Left (Var v)) (varType v)
 423                 return (setVarType v y1u, y1u)
 424 \end{code}
 425
 426
 427 The closure operation, which does the generalisation at let bindings.
 428
 429 \begin{code}
 430 usgClos :: VarEnv Var        -- environment to close with respect to
 431         -> Type              -- type to close (sigma)
 432         -> UConSet           -- constraint set to reduce
 433         -> (Type,            -- closed type (rho)
 434             UConSet)         -- residual constraint set
 435
 436 usgClos zz_ve ty ucs = (ty,ucs)  -- dummy definition; no generalisation at all
 437
 438             -- hmm!  what if it sets some uvars to 1 or omega?
 439             --  (should it do substitution here, or return a substitution,
 440             --   or should it leave all that work to the end and just use
 441             --   an "=" constraint here for now?)
 442 \end{code}
 443
 444 The pessimise operation, which generates constraints to pessimise an
 445 id (applied to exported ids, to ensure that they have fully general
 446 types, since we don't know how they will be used in other modules).
 447
 448 \begin{code}
 449 pessimise :: Type -> UConSet
 450
 451 pessimise ty
 452   = pess True emptyVarEnv ty
 453
 454   where
 455     pess :: Bool -> UVarSet -> Type -> UConSet
 456     pess co ve     (NoteTy (UsgForAll uv) ty)
 457       = pess co (ve `extendVarSet` uv) ty
 458     pess co ve ty0@(NoteTy (UsgNote u)    ty)
 459       = pessN co ve ty `unionUCS`
 460           (case (co,u) of
 461              (False,_       ) -> emptyUConSet
 462              (True ,UsMany  ) -> emptyUConSet
 463              (True ,UsOnce  ) -> pprPanic "pessimise: can't force:" (ppr ty0)
 464              (True ,UsVar uv) -> if uv `elemVarSet` ve
 465                                  then emptyUConSet  -- if bound by \/u, no need to pessimise
 466                                  else eqManyUConSet u)
 467     pess _  _  ty0
 468       = pprPanic "pessimise: missing annot:" (ppr ty0)
 469
 470     pessN :: Bool -> UVarSet -> Type -> UConSet
 471     pessN co ve     (NoteTy (UsgForAll uv) ty) = pessN co (ve `extendVarSet` uv) ty
 472     pessN co ve ty0@(NoteTy (UsgNote _)    _ ) = pprPanic "pessimise: unexpected annot:" (ppr ty0)
 473     pessN co ve     (NoteTy (SynNote sty)  ty) = pessN co ve sty `unionUCS` pessN co ve ty
 474     pessN co ve     (NoteTy (FTVNote _)    ty) = pessN co ve ty
 475     pessN co ve     (TyVarTy _)                = emptyUConSet
 476     pessN co ve     (AppTy _ _)                = emptyUConSet
 477     pessN co ve     (TyConApp tc tys)          = ASSERT( not((isFunTyCon tc)&&(length tys > 1)) )
 478                                                  emptyUConSet
 479     pessN co ve     (FunTy ty1 ty2)            = pess (not co) ve ty1 `unionUCS` pess co ve ty2
 480     pessN co ve     (ForAllTy _ ty)            = pessN co ve ty
 481 \end{code}
 482
 483
 484
 485 ======================================================================
 486
 487 Helper functions
 488 ~~~~~~~~~~~~~~~~
 489
 490 If a variable appears more than once in an fv set, force its usage to be Many.
 491
 492 \begin{code}
 493 occChkUConSet :: Var
 494               -> VarMultiset
 495               -> UConSet
 496
 497 occChkUConSet v fv = if occInMS v fv > 1
 498                      then ASSERT2( isUsgTy (varType v), ppr v )
 499                           eqManyUConSet ((tyUsg . varType) v)
 500                      else emptyUConSet
 501
 502 occChksUConSet :: [Var]
 503                -> VarMultiset
 504                -> UConSet
 505
 506 occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
 507 \end{code}
 508
 509
 510 Subtyping and equal-typing relations.  These generate constraint sets.
 511 Both assume their arguments are annotated correctly, and are either
 512 both tau-types or both sigma-types (in fact, are both exactly the same
 513 shape).
 514
 515 \begin{code}
 516 usgSubTy ty1 ty2  = genUsgCmpTy cmp ty1 ty2
 517   where cmp u1 u2 = leqUConSet u2 u1
 518
 519 usgEqTy  ty1 ty2  = genUsgCmpTy cmp ty1 ty2  -- **NB** doesn't equate tyconargs that
 520                                              -- don't appear (see below)
 521   where cmp u1 u2 = eqUConSet u1 u2
 522
 523 genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet)  -- constraint (u1 REL u2), respectively
 524             -> Type
 525             -> Type
 526             -> UConSet
 527
 528 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
 529   = cmp u1     u2     `unionUCS` genUsgCmpTy cmp ty1 ty2
 530
 531 #ifndef USMANY
 532 -- deal with omitted == UsMany
 533 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
 534   = cmp u1     UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
 535 genUsgCmpTy cmp ty1                       (NoteTy (UsgNote u2) ty2)
 536   = cmp UsMany u2     `unionUCS` genUsgCmpTy cmp ty1 ty2
 537 #endif
 538
 539 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
 540   = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
 541     -- **! is this right? or should I throw away synonyms, or sth else?
 542
 543 -- if SynNote only on one side, throw it out
 544 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
 545   = genUsgCmpTy cmp ty1 ty2
 546 genUsgCmpTy cmp ty1                         (NoteTy (SynNote sty2) ty2)
 547   = genUsgCmpTy cmp ty1 ty2
 548
 549 -- ignore FTVNotes
 550 genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
 551   = genUsgCmpTy cmp ty1 ty2
 552 genUsgCmpTy cmp ty1                      (NoteTy (FTVNote _) ty2)
 553   = genUsgCmpTy cmp ty1 ty2
 554
 555 genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
 556   = emptyUConSet
 557
 558 genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
 559   = unionUCSs [genUsgCmpTy cmp tya1 tya2,
 560                genUsgCmpTy cmp tyb1 tyb2,  -- note, *both* ways for arg, since fun (prob) unknown
 561                genUsgCmpTy cmp tyb2 tyb1]
 562
 563 genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
 564   = case tyConArgVrcs_maybe tc1 of
 565       Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
 566                                         -- strictly this is wasteful (and possibly dangerous) for
 567                                         -- usgEqTy, but I think it's OK.  KSW 1999-04.
 568                                        (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
 569                                        `unionUCS`
 570                                        (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
 571                                      ty1s ty2s oi)
 572       Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
 573
 574 genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
 575   = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2  -- contravariance of arrow
 576
 577 genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
 578   = genUsgCmpTy cmp ty1 ty2
 579
 580 genUsgCmpTy cmp ty1 ty2
 581   = pprPanic "genUsgCmpTy: type shapes don't match" $
 582       vcat [ppr ty1, ppr ty2]
 583 \end{code}
 584
 585
 586 Applying a substitution to all @UVar@s.  This also moves @TermUsg@
 587 notes on lambdas into the @lbvarInfo@ field of the binder.  This
 588 latter is a hack.  KSW 1999-04.
 589
 590 \begin{code}
 591 appUSubstTy :: (UVar -> UsageAnn)
 592             -> Type
 593             -> Type
 594
 595 appUSubstTy s    (NoteTy      (UsgNote (UsVar uv)) ty)
 596                                                 = mkUsgTy (s uv) (appUSubstTy s ty)
 597 appUSubstTy s    (NoteTy note@(UsgNote _) ty)   = NoteTy note (appUSubstTy s ty)
 598 appUSubstTy s    (NoteTy note@(SynNote _) ty)   = NoteTy note (appUSubstTy s ty)
 599 appUSubstTy s    (NoteTy note@(FTVNote _) ty)   = NoteTy note (appUSubstTy s ty)
 600 appUSubstTy s ty@(TyVarTy _)                    = ty
 601 appUSubstTy s    (AppTy ty1 ty2)                = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
 602 appUSubstTy s    (TyConApp tc tys)              = TyConApp tc (map (appUSubstTy s) tys)
 603 appUSubstTy s    (FunTy ty1 ty2)                = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
 604 appUSubstTy s    (ForAllTy tyv ty)              = ForAllTy tyv (appUSubstTy s ty)
 605
 606
 607 appUSubstBinds :: (UVar -> UsageAnn)
 608                -> [CoreBind]
 609                -> [CoreBind]
 610
 611 appUSubstBinds s binds = fst $ initAnnotM () $
 612                            genAnnotBinds mungeType mungeTerm binds
 613   where mungeType _ ty = -- simply perform substitution
 614                          return (appUSubstTy s ty)
 615
 616         mungeTerm   (Note (TermUsg (UsVar uv)) (Lam v e))
 617           -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
 618           = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
 619                 v' = modifyIdInfo (`setLBVarInfo` lb) v  -- HACK ALERT!
 620                      -- see comment in IdInfo.lhs; this is because the info is easier to
 621                      -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
 622             in  return (Lam v' e)
 623                 -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
 624         mungeTerm e@(Lam _ _)                     = return e
 625         mungeTerm e                               = panic "appUSubstBinds: mungeTerm:" (ppr e)
 626 \end{code}
 627
 628
 629 A @VarMultiset@ is what it says: a set of variables with counts
 630 attached to them.  We build one out of a @VarEnv@.
 631
 632 \begin{code}
 633 type VarMultiset = VarEnv (Var,Int)  -- I guess 536 870 911 occurrences is enough
 634
 635 emptyMS      =  emptyVarEnv
 636 unitMS v     =  unitVarEnv v (v,1)
 637 delFromMS    =  delVarEnv
 638 delsFromMS   =  delVarEnvList
 639 plusMS       :: VarMultiset -> VarMultiset -> VarMultiset
 640 plusMS       =  plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
 641 maxMS        :: VarMultiset -> VarMultiset -> VarMultiset
 642 maxMS        =  plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
 643 mapMS f      =  mapVarEnv (\ (v,n) -> f v n)
 644 foldMS f     =  foldVarEnv (\ (v,n) a -> f v n a)
 645 occInMS v ms =  case lookupVarEnv ms v of
 646                   Just (_,n) -> n
 647                   Nothing    -> 0
 648 \end{code}
 649
 650 And a function used in debugging.  It may give false positives with -DUSMANY turned off.
 651
 652 \begin{code}
 653 isUnAnnotated :: Type -> Bool
 654
 655 isUnAnnotated (NoteTy (UsgNote _  ) _ ) = False
 656 isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
 657 isUnAnnotated (NoteTy (FTVNote _  ) ty) = isUnAnnotated ty
 658 isUnAnnotated (TyVarTy _)               = True
 659 isUnAnnotated (AppTy ty1 ty2)           = isUnAnnotated ty1 && isUnAnnotated ty2
 660 isUnAnnotated (TyConApp tc tys)         = all isUnAnnotated tys
 661 isUnAnnotated (FunTy ty1 ty2)           = isUnAnnotated ty1 && isUnAnnotated ty2
 662 isUnAnnotated (ForAllTy tyv ty)         = isUnAnnotated ty
 663 \end{code}
 664
 665 ======================================================================
 666
 667 EOF