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