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-05-05
  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 (TermUsg u)      e) = pprTrace "usgInfCE: ignoring extra TermUsg:" (ppr u) $
 360                                        usgInfCE e
 361
 362 usgInfCE (Type ty)                 = panic "usgInfCE: unexpected Type"
 363 \end{code}
 364
 365 ======================================================================
 366
 367 Helper functions
 368 ~~~~~~~~~~~~~~~~
 369
 370 If a variable appears more than once in an fv set, force its usage to be Many.
 371
 372 \begin{code}
 373 occChkUConSet :: IdOrTyVar
 374               -> VarMultiset
 375               -> UConSet
 376
 377 occChkUConSet v fv = if occInMS v fv > 1
 378                      then eqManyUConSet ((tyUsg . varType) v)
 379                      else emptyUConSet
 380
 381 occChksUConSet :: [IdOrTyVar]
 382                -> VarMultiset
 383                -> UConSet
 384
 385 occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
 386 \end{code}
 387
 388
 389 Subtyping and equal-typing relations.  These generate constraint sets.
 390 Both assume their arguments are annotated correctly, and are either
 391 both tau-types or both sigma-types (in fact, are both exactly the same
 392 shape).
 393
 394 \begin{code}
 395 usgSubTy ty1 ty2  = genUsgCmpTy cmp ty1 ty2
 396   where cmp u1 u2 = leqUConSet u2 u1
 397
 398 usgEqTy  ty1 ty2  = genUsgCmpTy cmp ty1 ty2  -- **NB** doesn't equate tyconargs that
 399                                              -- don't appear (see below)
 400   where cmp u1 u2 = eqUConSet u1 u2
 401
 402 genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet)  -- constraint (u1 REL u2), respectively
 403             -> Type
 404             -> Type
 405             -> UConSet
 406
 407 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
 408   = cmp u1     u2     `unionUCS` genUsgCmpTy cmp ty1 ty2
 409
 410 #ifndef USMANY
 411 -- deal with omitted == UsMany
 412 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
 413   = cmp u1     UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
 414 genUsgCmpTy cmp ty1                       (NoteTy (UsgNote u2) ty2)
 415   = cmp UsMany u2     `unionUCS` genUsgCmpTy cmp ty1 ty2
 416 #endif
 417
 418 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
 419   = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
 420     -- **! is this right? or should I throw away synonyms, or sth else?
 421
 422 -- if SynNote only on one side, throw it out
 423 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
 424   = genUsgCmpTy cmp ty1 ty2
 425 genUsgCmpTy cmp ty1                         (NoteTy (SynNote sty2) ty2)
 426   = genUsgCmpTy cmp ty1 ty2
 427
 428 -- ignore FTVNotes
 429 genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
 430   = genUsgCmpTy cmp ty1 ty2
 431 genUsgCmpTy cmp ty1                      (NoteTy (FTVNote _) ty2)
 432   = genUsgCmpTy cmp ty1 ty2
 433
 434 genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
 435   = emptyUConSet
 436
 437 genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
 438   = unionUCSs [genUsgCmpTy cmp tya1 tya2,
 439                genUsgCmpTy cmp tyb1 tyb2,  -- note, *both* ways for arg, since fun (prob) unknown
 440                genUsgCmpTy cmp tyb2 tyb1]
 441
 442 genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
 443   = case tyConArgVrcs_maybe tc1 of
 444       Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
 445                                         -- strictly this is wasteful (and possibly dangerous) for
 446                                         -- usgEqTy, but I think it's OK.  KSW 1999-04.
 447                                        (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
 448                                        `unionUCS`
 449                                        (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
 450                                      ty1s ty2s oi)
 451       Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
 452
 453 genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
 454   = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2  -- contravariance of arrow
 455
 456 genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
 457   = genUsgCmpTy cmp ty1 ty2
 458
 459 genUsgCmpTy cmp ty1 ty2
 460   = pprPanic "genUsgCmpTy: type shapes don't match" $
 461       vcat [ppr ty1, ppr ty2]
 462 \end{code}
 463
 464
 465 Applying a substitution to all @UVar@s.  This also moves @TermUsg@
 466 notes on lambdas into the @lbvarInfo@ field of the binder.  This
 467 latter is a hack.  KSW 1999-04.
 468
 469 \begin{code}
 470 appUSubstTy :: (UVar -> UsageAnn)
 471             -> Type
 472             -> Type
 473
 474 appUSubstTy s    (NoteTy      (UsgNote (UsVar uv)) ty)
 475                                                 = mkUsgTy (s uv) (appUSubstTy s ty)
 476 appUSubstTy s    (NoteTy note@(UsgNote _) ty)   = NoteTy note (appUSubstTy s ty)
 477 appUSubstTy s    (NoteTy note@(SynNote _) ty)   = NoteTy note (appUSubstTy s ty)
 478 appUSubstTy s    (NoteTy note@(FTVNote _) ty)   = NoteTy note (appUSubstTy s ty)
 479 appUSubstTy s ty@(TyVarTy _)                    = ty
 480 appUSubstTy s    (AppTy ty1 ty2)                = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
 481 appUSubstTy s    (TyConApp tc tys)              = TyConApp tc (map (appUSubstTy s) tys)
 482 appUSubstTy s    (FunTy ty1 ty2)                = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
 483 appUSubstTy s    (ForAllTy tyv ty)              = ForAllTy tyv (appUSubstTy s ty)
 484
 485
 486 appUSubstBinds :: (UVar -> UsageAnn)
 487                -> [CoreBind]
 488                -> [CoreBind]
 489
 490 appUSubstBinds s binds = fst $ initAnnotM () $
 491                            genAnnotBinds mungeType mungeTerm binds
 492   where mungeType _ ty = -- simply perform substitution
 493                          return (appUSubstTy s ty)
 494
 495         mungeTerm   (Note (TermUsg (UsVar uv)) (Lam v e))
 496           -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
 497           = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
 498                 v' = modifyIdInfo (`setLBVarInfo` lb) v  -- HACK ALERT!
 499                      -- see comment in IdInfo.lhs; this is because the info is easier to
 500                      -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
 501             in  return (Lam v' e)
 502                 -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
 503         mungeTerm e@(Lam _ _)                     = return e
 504         mungeTerm e                               = panic "appUSubstBinds: mungeTerm:" (ppr e)
 505 \end{code}
 506
 507
 508 A @VarMultiset@ is what it says: a set of variables with counts
 509 attached to them.  We build one out of a @VarEnv@.
 510
 511 \begin{code}
 512 type VarMultiset = VarEnv (IdOrTyVar,Int)  -- I guess 536 870 911 occurrences is enough
 513
 514 emptyMS      =  emptyVarEnv
 515 unitMS v     =  unitVarEnv v (v,1)
 516 delFromMS    =  delVarEnv
 517 plusMS       :: VarMultiset -> VarMultiset -> VarMultiset
 518 plusMS       =  plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
 519 maxMS        :: VarMultiset -> VarMultiset -> VarMultiset
 520 maxMS        =  plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
 521 mapMS f      =  mapVarEnv (\ (v,n) -> f v n)
 522 foldMS f     =  foldVarEnv (\ (v,n) a -> f v n a)
 523 occInMS v ms =  case lookupVarEnv ms v of
 524                   Just (_,n) -> n
 525                   Nothing    -> 0
 526 \end{code}
 527
 528 And a function used in debugging.  It may give false positives with -DUSMANY turned off.
 529
 530 \begin{code}
 531 isUnAnnotated :: Type -> Bool
 532
 533 isUnAnnotated (NoteTy (UsgNote _  ) _ ) = False
 534 isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
 535 isUnAnnotated (NoteTy (FTVNote _  ) ty) = isUnAnnotated ty
 536 isUnAnnotated (TyVarTy _)               = True
 537 isUnAnnotated (AppTy ty1 ty2)           = isUnAnnotated ty1 && isUnAnnotated ty2
 538 isUnAnnotated (TyConApp tc tys)         = all isUnAnnotated tys
 539 isUnAnnotated (FunTy ty1 ty2)           = isUnAnnotated ty1 && isUnAnnotated ty2
 540 isUnAnnotated (ForAllTy tyv ty)         = isUnAnnotated ty
 541 \end{code}
 542
 543 ======================================================================
 544
 545 EOF