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