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-06-25
  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 Type             ( Type(..), TyNote(..), UsageAnn(..),
  22                           applyTy, applyTys,
  23                           splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
  24                           mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
  25                           mkFunTy, mkForAllTy )
  26 import TyCon            ( tyConArgVrcs_maybe )
  27 import DataCon          ( dataConType )
  28 import Const            ( Con(..), Literal(..), literalType )
  29 import Var              ( IdOrTyVar, UVar, varType, mkUVar, modifyIdInfo )
  30 import IdInfo           ( setLBVarInfo, LBVarInfo(..) )
  31 import VarEnv
  32 import UniqSupply       ( UniqSupply, UniqSM,
  33                           initUs, splitUniqSupply )
  34 import Outputable
  35 import CmdLineOpts      ( opt_D_dump_usagesp, opt_DoUSPLinting )
  36 import ErrUtils         ( doIfSet, dumpIfSet )
  37 import PprCore          ( pprCoreBindings )
  38 \end{code}
  39
  40 ======================================================================
  41
  42 The whole inference
  43 ~~~~~~~~~~~~~~~~~~~
  44
  45 For full details, see _Once Upon a Polymorphic Type_, University of
  46 Glasgow Department of Computing Science Technical Report TR-1998-19,
  47 December 1998, or the summary in POPL'99.
  48
  49 Inference is performed as follows:
  50
  51   1.  Remove all manipulable[*] annotations and add fresh @UVar@
  52       annotations.
  53
  54   2.  Walk over the resulting term applying the type rules and
  55       collecting the constraints.
  56
  57   3.  Find the solution to the constraints and apply the substitution
  58       to the annotations, leaving a @UVar@-free term.
  59
  60 [*] A manipulable annotation is one derived from the current source
  61 module, as opposed to one derived from an import, which we are clearly
  62 not allowed to alter.
  63
  64 As in the paper, a ``tau-type'' is a type that does *not* have an
  65 annotation on top (although it may have some inside), and a
  66 ``sigma-type'' is one that does (i.e., is a tau-type with an
  67 annotation added).  This conflicts with the totally unrelated usage of
  68 these terms in the remainder of GHC.  Caveat lector!  KSW 1999-04.
  69
  70
  71 The inference is done over a set of @CoreBind@s, and inside the IO
  72 monad.
  73
  74 \begin{code}
  75 doUsageSPInf :: UniqSupply
  76              -> [CoreBind]
  77              -> IO [CoreBind]
  78
  79 doUsageSPInf us binds = do
  80                            let binds1      = doUnAnnotBinds binds
  81
  82                                (us1,us2)   = splitUniqSupply us
  83                                (binds2,_)  = doAnnotBinds us1 binds1
  84
  85                            dumpIfSet opt_D_dump_usagesp "UsageSPInf reannot'd" $
  86                              pprCoreBindings binds2
  87
  88                            doIfSet opt_DoUSPLinting $
  89                               doLintUSPAnnotsBinds binds2       -- lint check 0
  90
  91                            let ((ucs,_),_) = initUs us2 (uniqSMMToUs (usgInfBinds binds2))
  92                                ms          = solveUCS ucs
  93                                s           = case ms of
  94                                                Just s  -> s
  95                                                Nothing -> panic "doUsageSPInf: insol. conset!"
  96                                binds3      = appUSubstBinds s binds2
  97
  98                            doIfSet opt_DoUSPLinting $
  99                              do doLintUSPAnnotsBinds binds3     -- lint check 1
 100                                 doLintUSPConstBinds  binds3     -- lint check 2 (force solution)
 101                                 doCheckIfWorseUSP binds binds3  -- check for worsening of usages
 102
 103                            dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
 104                              pprCoreBindings binds3
 105
 106                            return binds3
 107 \end{code}
 108
 109 ======================================================================
 110
 111 Inferring an expression
 112 ~~~~~~~~~~~~~~~~~~~~~~~
 113
 114 When we infer types for an expression, we expect it to be already
 115 annotated - normally with usage variables everywhere (or possibly
 116 constants).  No context is required since variables already know their
 117 types.
 118
 119 \begin{code}
 120 usgInfBinds :: [CoreBind]
 121             -> UniqSMM (UConSet,
 122                         VarMultiset)
 123
 124 usgInfBinds [] = return (emptyUConSet,
 125                          emptyMS)
 126
 127 usgInfBinds (b:bs) = do { (ucs2,fv2) <- usgInfBinds bs    -- careful of scoping here
 128                         ; (ucs1,fv1) <- usgInfBind b fv2
 129                         ; return (ucs1 `unionUCS` ucs2,
 130                                   fv1)
 131                         }
 132
 133 usgInfBind :: CoreBind                      -- CoreBind to infer for
 134            -> VarMultiset                   -- fvs of `body' (later CoreBinds)
 135            -> UniqSMM (UConSet,             -- constraints generated by this CoreBind
 136                        VarMultiset)         -- fvs of this CoreBind and later ones
 137
 138 usgInfBind (NonRec v1 e1) fv0 = do { (ty1u,ucs1,fv1) <- usgInfCE e1
 139                                    ; let ty2u = varType v1
 140                                          ucs2 = usgSubTy ty1u ty2u
 141                                          ucs3 = occChkUConSet v1 fv0
 142                                    ; return (unionUCSs [ucs1,ucs2,ucs3],
 143                                              fv1 `plusMS` (fv0 `delFromMS` v1))
 144                                    }
 145
 146 usgInfBind (Rec ves)      fv0 = do { tuf1s <- mapM (usgInfCE . snd) ves
 147                                    ; let (ty1us,ucs1s,fv1s) = unzip3 tuf1s
 148                                          vs    = map fst ves
 149                                          ucs2s = zipWith usgSubTy ty1us (map varType vs)
 150                                          fv3   = foldl plusMS fv0 fv1s
 151                                          ucs3  = occChksUConSet vs fv3
 152                                    ; return (unionUCSs (ucs1s ++ ucs2s ++ [ucs3]),
 153                                              foldl delFromMS fv3 vs)
 154                                    }
 155
 156 usgInfCE :: CoreExpr
 157          -> UniqSMM (Type,UConSet,VarMultiset)
 158          -- ^- in the unique supply monad for new uvars
 159          --          ^- type of the @CoreExpr@ (always a sigma type)
 160          --               ^- set of constraints arising
 161          --                       ^- variable appearances for occur()
 162
 163 usgInfCE e0@(Var v) | isTyVar v    = panic "usgInfCE: unexpected TyVar"
 164                     | otherwise    = return (ASSERT( isUsgTy (varType v) )
 165                                              varType v,
 166                                              emptyUConSet,
 167                                              unitMS v)
 168
 169 usgInfCE e0@(Con (Literal lit) args) = ASSERT( null args )
 170                                        do { u1 <- newVarUSMM (Left e0)
 171                                           ; return (mkUsgTy u1 (literalType lit),
 172                                                     emptyUConSet,
 173                                                     emptyMS)
 174                                           }
 175
 176 usgInfCE (Con DEFAULT _) = panic "usgInfCE: DEFAULT"
 177
 178 usgInfCE e0@(Con con args) = -- constant or primop.  guaranteed saturated.
 179                           do { let (ety1s,e1s) = span isTypeArg args
 180                                    ty1s = map (\ (Type ty) -> ty) ety1s  -- univ. + exist.
 181                              ; (ty3us,ty3u) <- case con of
 182                                                  DataCon c -> do { u4 <- newVarUSMM (Left e0)
 183                                                                  ; return $ dataConTys c u4 ty1s
 184                                                                      -- ty1s is exdicts + args
 185                                                                  }
 186                                                  PrimOp  p -> return $ primOpUsgTys p ty1s
 187                                                  otherwise -> panic "usgInfCE: unrecognised Con"
 188                              ; tuf4s <- mapM usgInfCE e1s
 189                              ; let (ty4us,ucs4s,fv4s) = unzip3 tuf4s
 190                                    ucs5s = zipWith usgSubTy
 191                                                    ty4us ty3us
 192                              ; return (ty3u,
 193                                          -- note ty3 is T ty1s, so it already
 194                                          -- has annotations inside where they
 195                                          -- should be (for datacons); for
 196                                          -- primops we assume types are
 197                                          -- appropriately annotated already.
 198                                        unionUCSs (ucs4s ++ ucs5s),
 199                                        foldl plusMS emptyMS fv4s)
 200                              }
 201   where dataConTys c u tys = -- compute argtys of a datacon
 202                              let rawCTy      = dataConType c
 203                                  cTy         = ASSERT( isUnAnnotated rawCTy )
 204                                              -- algebraic data types are defined entirely
 205                                              -- unannotated; we place Many annotations inside
 206                                              -- them to get the required tau-types (p20(fn) TR)
 207                                                annotManyN rawCTy
 208                                              -- we really don't want annots on top of the
 209                                              -- funargs, but we can't easily avoid
 210                                              -- this so we use unUsgTy later
 211                                  (ty3us,ty3) = ASSERT( all isNotUsgTy tys )
 212                                                splitFunTys (applyTys cTy tys)
 213                                              -- safe 'cos a DataCon always returns a
 214                                              -- value of type (TyCon tys), not an
 215                                              -- arrow type
 216                                  ty3u        = if null ty3us then mkUsgTy u ty3 else ty3
 217                                              -- if no args, ty3 is tau; else already sigma
 218                                  reUsg       = mkUsgTy u . unUsgTy
 219                              in  (map reUsg ty3us,
 220                                   reUsg ty3u)
 221
 222 usgInfCE (App e1 (Type ty2)) = do { (ty1u,ucs,fv) <- usgInfCE e1
 223                                   ; let (u,ty1) = splitUsgTy ty1u
 224                                   ; ASSERT( isNotUsgTy ty2 )
 225                                     return (mkUsgTy u (applyTy ty1 ty2),
 226                                             ucs,
 227                                             fv)
 228                                   }
 229
 230 usgInfCE (App e1 e2) = do { (ty1u,ucs1,fv1) <- usgInfCE e1
 231                           ; (ty2u,ucs2,fv2) <- usgInfCE e2
 232                           ; let (u1,ty1)    = splitUsgTy ty1u
 233                                 (ty3u,ty4u) = case splitFunTy_maybe ty1 of
 234                                                 Just tys -> tys
 235                                                 Nothing  -> panic "usgInfCE: app of non-funty"
 236                                 ucs5        = usgSubTy ty2u ty3u
 237                           ; return (ASSERT( isUsgTy ty4u )
 238                                     ty4u,
 239                                     unionUCSs [ucs1,ucs2,ucs5],
 240                                     fv1 `plusMS` fv2)
 241                           }
 242
 243 usgInfCE (Lam v e) | isTyVar v = do { (ty1u,ucs,fv) <- usgInfCE e  -- safe to ignore free v here
 244                                     ; let (u,ty1) = splitUsgTy ty1u
 245                                     ; return (mkUsgTy u (mkForAllTy v ty1),
 246                                               ucs,
 247                                               fv)
 248                                     }
 249                    | otherwise = panic "usgInfCE: missing lambda usage annot"
 250                      -- if used for checking also, may need to extend this case to
 251                      -- look in lbvarInfo instead.
 252
 253 usgInfCE (Note (TermUsg u) (Lam v e))
 254   = ASSERT( not (isTyVar v) )
 255     do { (ty1u,ucs1,fv) <- usgInfCE e
 256        ; let ty2u   = varType v
 257              ucs2   = occChkUConSet v fv
 258              fv'    = fv `delFromMS` v
 259              ucs3s  = foldMS (\v _ ucss -> (leqUConSet u ((tyUsg . varType) v)
 260                                             : ucss))  -- in reverse order!
 261                              []
 262                              fv'
 263        ; return (mkUsgTy u (mkFunTy ty2u ty1u),
 264                  unionUCSs ([ucs1,ucs2] ++ ucs3s),
 265                  fv')
 266        }
 267
 268 usgInfCE (Let bind e0) = do { (ty0u,ucs0,fv0) <- usgInfCE e0
 269                             ; (ucs1,fv1) <- usgInfBind bind fv0
 270                             ; return (ASSERT( isUsgTy ty0u )
 271                                       ty0u,
 272                                       ucs0 `unionUCS` ucs1,
 273                                       fv1)
 274                             }
 275
 276 usgInfCE (Case e0 v0 [(DEFAULT,[],e1)])
 277   = -- pure strict let, no selection (could be at polymorphic or function type)
 278     do { (ty0u,ucs0,fv0) <- usgInfCE e0
 279        ; (ty1u,ucs1,fv1) <- usgInfCE e1
 280        ; let (u0,ty0)   = splitUsgTy ty0u
 281              ucs2       = usgEqTy ty0u (varType v0)  -- messy! but OK
 282        ; ty4u <- freshannotTy ty1u
 283        ; let ucs5 = usgSubTy ty1u ty4u
 284              ucs7 = occChkUConSet v0 (fv1 `plusMS` (unitMS v0))
 285        ; return (ASSERT( isUsgTy ty4u )
 286                  ty4u,
 287                  unionUCSs [ucs0,ucs1,ucs2,ucs5,ucs7],
 288                  fv0 `plusMS` (fv1 `delFromMS` v0))
 289        }
 290
 291 usgInfCE expr@(Case e0 v0 alts)
 292   = -- general case (tycon of scrutinee must be known)
 293     do { let (cs,vss,es) = unzip3 alts
 294        ; (ty0u,ucs0,fv0) <- usgInfCE e0
 295        ; tuf2s <- mapM usgInfCE es
 296        ; let (u0,ty0)   = splitUsgTy ty0u
 297              ucs1       = usgEqTy ty0u (varType v0)  -- messy! but OK
 298              (tc,ty0ks) = case splitTyConApp_maybe ty0 of
 299                             Just tcks -> tcks
 300                             Nothing   -> pprPanic "usgInfCE: weird:" $
 301                                            vcat [text "scrutinee:" <+> ppr e0,
 302                                                  text "type:" <+> ppr ty0u]
 303        ; let (ty2us,ucs2s,fv2s) = unzip3 tuf2s
 304              ucs3ss = ASSERT2( all isNotUsgTy ty0ks, text "expression" <+> ppr e0 $$ text "has type" <+> ppr ty0u )
 305                       zipWith (\ c vs -> zipWith (\ty v ->
 306                                                    usgSubTy (mkUsgTy u0 ty)
 307                                                             (varType v))
 308                                                  (caseAltArgs ty0ks c)
 309                                                  vs)
 310                               cs
 311                               vss
 312        ; ty4u <- freshannotTy (head ty2us) -- assume at least one alt
 313        ; let ucs5s = zipWith usgSubTy ty2us (repeat ty4u)
 314              ucs6s = zipWith occChksUConSet vss fv2s
 315              fv7   = ASSERT( not (null fv2s) && (length fv2s == length vss) )
 316                      foldl1 maxMS (zipWith (foldl delFromMS) fv2s vss)
 317              ucs7  = occChkUConSet v0 (fv7 `plusMS` (unitMS v0))
 318        ; return (ASSERT( isUsgTy ty4u )
 319                  ty4u,
 320                  unionUCSs ([ucs0,ucs1] ++ ucs2s
 321                             ++ (concat ucs3ss)
 322                             ++ ucs5s
 323                             ++ ucs6s
 324                             ++ [ucs7]),
 325                  fv0 `plusMS` (fv7 `delFromMS` v0))
 326        }
 327   where caseAltArgs                 :: [Type] -> Con -> [Type]
 328         -- compute list of tau-types required by a case-alt
 329         caseAltArgs tys (DataCon dc) = let rawCTy = dataConType dc
 330                                            cTy    = ASSERT2( isUnAnnotated rawCTy, (text "caseAltArgs: rawCTy annotated!:" <+> ppr rawCTy <+> text "in" <+> ppr expr) )
 331                                                     annotManyN rawCTy
 332                                        in  ASSERT( all isNotUsgTy tys )
 333                                            map unUsgTy (fst (splitFunTys (applyTys cTy tys)))
 334         caseAltArgs tys (Literal _)  = []
 335         caseAltArgs tys DEFAULT      = []
 336         caseAltArgs tys (PrimOp _)   = panic "caseAltArgs: unexpected PrimOp"
 337
 338 usgInfCE (Note (SCC _)          e) = usgInfCE e
 339
 340 usgInfCE (Note (Coerce ty1 ty0) e)
 341   = do { (ty2u,ucs2,fv2) <- usgInfCE e
 342        ; let (u2,ty2) = splitUsgTy ty2u
 343              ucs3     = usgEqTy ty0 ty2  -- messy but OK
 344              ty0'     = (annotManyN . unannotTy) ty0  -- really nasty type
 345              ucs4     = usgEqTy ty0 ty0'
 346              ucs5     = emptyUConSet
 347              -- What this says is that a Coerce does the most general possible
 348              -- annotation to what's inside it (nasty, nasty), because no information
 349              -- can pass through a Coerce.  It of course simply ignores the info
 350              -- that filters down through into ty1, because it can do nothing with it.
 351              -- It does still pass through the topmost usage annotation, though.
 352        ; return (mkUsgTy u2 ty1,
 353                  unionUCSs [ucs2,ucs3,ucs4,ucs5],
 354                  fv2)
 355        }
 356
 357 usgInfCE (Note InlineCall       e) = usgInfCE e
 358
 359 usgInfCE (Note InlineMe         e) = usgInfCE e
 360
 361 usgInfCE (Note (TermUsg u)      e) = pprTrace "usgInfCE: ignoring extra TermUsg:" (ppr u) $
 362                                        usgInfCE e
 363
 364 usgInfCE (Type ty)                 = panic "usgInfCE: unexpected Type"
 365 \end{code}
 366
 367 ======================================================================
 368
 369 Helper functions
 370 ~~~~~~~~~~~~~~~~
 371
 372 If a variable appears more than once in an fv set, force its usage to be Many.
 373
 374 \begin{code}
 375 occChkUConSet :: IdOrTyVar
 376               -> VarMultiset
 377               -> UConSet
 378
 379 occChkUConSet v fv = if occInMS v fv > 1
 380                      then eqManyUConSet ((tyUsg . varType) v)
 381                      else emptyUConSet
 382
 383 occChksUConSet :: [IdOrTyVar]
 384                -> VarMultiset
 385                -> UConSet
 386
 387 occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
 388 \end{code}
 389
 390
 391 Subtyping and equal-typing relations.  These generate constraint sets.
 392 Both assume their arguments are annotated correctly, and are either
 393 both tau-types or both sigma-types (in fact, are both exactly the same
 394 shape).
 395
 396 \begin{code}
 397 usgSubTy ty1 ty2  = genUsgCmpTy cmp ty1 ty2
 398   where cmp u1 u2 = leqUConSet u2 u1
 399
 400 usgEqTy  ty1 ty2  = genUsgCmpTy cmp ty1 ty2  -- **NB** doesn't equate tyconargs that
 401                                              -- don't appear (see below)
 402   where cmp u1 u2 = eqUConSet u1 u2
 403
 404 genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet)  -- constraint (u1 REL u2), respectively
 405             -> Type
 406             -> Type
 407             -> UConSet
 408
 409 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
 410   = cmp u1     u2     `unionUCS` genUsgCmpTy cmp ty1 ty2
 411
 412 #ifndef USMANY
 413 -- deal with omitted == UsMany
 414 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
 415   = cmp u1     UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
 416 genUsgCmpTy cmp ty1                       (NoteTy (UsgNote u2) ty2)
 417   = cmp UsMany u2     `unionUCS` genUsgCmpTy cmp ty1 ty2
 418 #endif
 419
 420 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
 421   = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
 422     -- **! is this right? or should I throw away synonyms, or sth else?
 423
 424 -- if SynNote only on one side, throw it out
 425 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
 426   = genUsgCmpTy cmp ty1 ty2
 427 genUsgCmpTy cmp ty1                         (NoteTy (SynNote sty2) ty2)
 428   = genUsgCmpTy cmp ty1 ty2
 429
 430 -- ignore FTVNotes
 431 genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
 432   = genUsgCmpTy cmp ty1 ty2
 433 genUsgCmpTy cmp ty1                      (NoteTy (FTVNote _) ty2)
 434   = genUsgCmpTy cmp ty1 ty2
 435
 436 genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
 437   = emptyUConSet
 438
 439 genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
 440   = unionUCSs [genUsgCmpTy cmp tya1 tya2,
 441                genUsgCmpTy cmp tyb1 tyb2,  -- note, *both* ways for arg, since fun (prob) unknown
 442                genUsgCmpTy cmp tyb2 tyb1]
 443
 444 genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
 445   = case tyConArgVrcs_maybe tc1 of
 446       Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
 447                                         -- strictly this is wasteful (and possibly dangerous) for
 448                                         -- usgEqTy, but I think it's OK.  KSW 1999-04.
 449                                        (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
 450                                        `unionUCS`
 451                                        (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
 452                                      ty1s ty2s oi)
 453       Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
 454
 455 genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
 456   = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2  -- contravariance of arrow
 457
 458 genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
 459   = genUsgCmpTy cmp ty1 ty2
 460
 461 genUsgCmpTy cmp ty1 ty2
 462   = pprPanic "genUsgCmpTy: type shapes don't match" $
 463       vcat [ppr ty1, ppr ty2]
 464 \end{code}
 465
 466
 467 Applying a substitution to all @UVar@s.  This also moves @TermUsg@
 468 notes on lambdas into the @lbvarInfo@ field of the binder.  This
 469 latter is a hack.  KSW 1999-04.
 470
 471 \begin{code}
 472 appUSubstTy :: (UVar -> UsageAnn)
 473             -> Type
 474             -> Type
 475
 476 appUSubstTy s    (NoteTy      (UsgNote (UsVar uv)) ty)
 477                                                 = mkUsgTy (s uv) (appUSubstTy s ty)
 478 appUSubstTy s    (NoteTy note@(UsgNote _) ty)   = NoteTy note (appUSubstTy s ty)
 479 appUSubstTy s    (NoteTy note@(SynNote _) ty)   = NoteTy note (appUSubstTy s ty)
 480 appUSubstTy s    (NoteTy note@(FTVNote _) ty)   = NoteTy note (appUSubstTy s ty)
 481 appUSubstTy s ty@(TyVarTy _)                    = ty
 482 appUSubstTy s    (AppTy ty1 ty2)                = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
 483 appUSubstTy s    (TyConApp tc tys)              = TyConApp tc (map (appUSubstTy s) tys)
 484 appUSubstTy s    (FunTy ty1 ty2)                = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
 485 appUSubstTy s    (ForAllTy tyv ty)              = ForAllTy tyv (appUSubstTy s ty)
 486
 487
 488 appUSubstBinds :: (UVar -> UsageAnn)
 489                -> [CoreBind]
 490                -> [CoreBind]
 491
 492 appUSubstBinds s binds = fst $ initAnnotM () $
 493                            genAnnotBinds mungeType mungeTerm binds
 494   where mungeType _ ty = -- simply perform substitution
 495                          return (appUSubstTy s ty)
 496
 497         mungeTerm   (Note (TermUsg (UsVar uv)) (Lam v e))
 498           -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
 499           = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
 500                 v' = modifyIdInfo (`setLBVarInfo` lb) v  -- HACK ALERT!
 501                      -- see comment in IdInfo.lhs; this is because the info is easier to
 502                      -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
 503             in  return (Lam v' e)
 504                 -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
 505         mungeTerm e@(Lam _ _)                     = return e
 506         mungeTerm e                               = panic "appUSubstBinds: mungeTerm:" (ppr e)
 507 \end{code}
 508
 509
 510 A @VarMultiset@ is what it says: a set of variables with counts
 511 attached to them.  We build one out of a @VarEnv@.
 512
 513 \begin{code}
 514 type VarMultiset = VarEnv (IdOrTyVar,Int)  -- I guess 536 870 911 occurrences is enough
 515
 516 emptyMS      =  emptyVarEnv
 517 unitMS v     =  unitVarEnv v (v,1)
 518 delFromMS    =  delVarEnv
 519 plusMS       :: VarMultiset -> VarMultiset -> VarMultiset
 520 plusMS       =  plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
 521 maxMS        :: VarMultiset -> VarMultiset -> VarMultiset
 522 maxMS        =  plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
 523 mapMS f      =  mapVarEnv (\ (v,n) -> f v n)
 524 foldMS f     =  foldVarEnv (\ (v,n) a -> f v n a)
 525 occInMS v ms =  case lookupVarEnv ms v of
 526                   Just (_,n) -> n
 527                   Nothing    -> 0
 528 \end{code}
 529
 530 And a function used in debugging.  It may give false positives with -DUSMANY turned off.
 531
 532 \begin{code}
 533 isUnAnnotated :: Type -> Bool
 534
 535 isUnAnnotated (NoteTy (UsgNote _  ) _ ) = False
 536 isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
 537 isUnAnnotated (NoteTy (FTVNote _  ) ty) = isUnAnnotated ty
 538 isUnAnnotated (TyVarTy _)               = True
 539 isUnAnnotated (AppTy ty1 ty2)           = isUnAnnotated ty1 && isUnAnnotated ty2
 540 isUnAnnotated (TyConApp tc tys)         = all isUnAnnotated tys
 541 isUnAnnotated (FunTy ty1 ty2)           = isUnAnnotated ty1 && isUnAnnotated ty2
 542 isUnAnnotated (ForAllTy tyv ty)         = isUnAnnotated ty
 543 \end{code}
 544
 545 ======================================================================
 546
 547 EOF