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