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