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