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