ghc/compiler/coreSyn/CoreSat.lhs

   1 %
   2 % (c) The University of Glasgow, 1994-2000
   3 %
   4 \section{Core pass to saturate constructors and PrimOps}
   5
   6 \begin{code}
   7 module CoreSat (
   8       coreSatPgm, coreSatExpr
   9   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity )
  14 import CoreFVs  ( exprFreeVars )
  15 import CoreLint ( endPass )
  16 import CoreSyn
  17 import Type     ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
  18                   isUnLiftedType, isUnboxedTupleType, repType,
  19                   uaUTy, usOnce, usMany, seqType )
  20 import Demand   ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
  21 import PrimOp   ( PrimOp(..) )
  22 import Var      ( Id, TyVar, setTyVarUnique )
  23 import VarSet
  24 import Id       ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
  25                   isDeadBinder, setIdType, isPrimOpId_maybe, hasNoBinding
  26                 )
  27
  28 import UniqSupply
  29 import Maybes
  30 import OrdList
  31 import ErrUtils
  32 import CmdLineOpts
  33 import Outputable
  34 \end{code}
  35
  36 -- ---------------------------------------------------------------------------
  37 -- Overview
  38 -- ---------------------------------------------------------------------------
  39
  40 MAJOR CONSTRAINT:
  41         By the time this pass happens, we have spat out tidied Core into
  42         the interface file, including all IdInfo.
  43
  44         So we must not change the arity of any top-level function,
  45         because we've already fixed it and put it out into the interface file.
  46         Nor must we change a value (e.g. constructor) into a thunk.
  47
  48         It's ok to introduce extra bindings, which don't appear in the
  49         interface file.  We don't put arity info on these extra bindings,
  50         because they are never fully applied, so there's no chance of
  51         compiling just-a-fast-entry point for them.
  52
  53 Most of the contents of this pass used to be in CoreToStg.  The
  54 primary goals here are:
  55
  56 1.  Saturate constructor and primop applications.
  57
  58 2.  Convert to A-normal form:
  59
  60     * Use case for strict arguments:
  61         f E ==> case E of x -> f x
  62         (where f is strict)
  63
  64     * Use let for non-trivial lazy arguments
  65         f E ==> let x = E in f x
  66         (were f is lazy and x is non-trivial)
  67
  68 3.  Similarly, convert any unboxed lets into cases.
  69     [I'm experimenting with leaving 'ok-for-speculation'
  70      rhss in let-form right up to this point.]
  71
  72 4.  Ensure that lambdas only occur as the RHS of a binding
  73     (The code generator can't deal with anything else.)
  74
  75 5.  Do the seq/par munging.  See notes with mkCase below.
  76
  77 This is all done modulo type applications and abstractions, so that
  78 when type erasure is done for conversion to STG, we don't end up with
  79 any trivial or useless bindings.
  80
  81
  82
  83 -- -----------------------------------------------------------------------------
  84 -- Top level stuff
  85 -- -----------------------------------------------------------------------------
  86
  87 \begin{code}
  88 coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
  89 coreSatPgm dflags binds
  90   = do  showPass dflags "CoreSat"
  91         us <- mkSplitUniqSupply 's'
  92         let new_binds = initUs_ us (coreSatTopBinds binds)
  93         endPass dflags "CoreSat" Opt_D_dump_sat new_binds
  94
  95 coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
  96 coreSatExpr dflags expr
  97   = do showPass dflags "CoreSat"
  98        us <- mkSplitUniqSupply 's'
  99        let new_expr = initUs_ us (coreSatAnExpr expr)
 100        dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
 101                      (ppr new_expr)
 102        return new_expr
 103
 104 -- ---------------------------------------------------------------------------
 105 -- Dealing with bindings
 106 -- ---------------------------------------------------------------------------
 107
 108 data FloatingBind = FloatLet CoreBind
 109                   | FloatCase Id CoreExpr
 110
 111 allLazy :: OrdList FloatingBind -> Bool
 112 allLazy floats = foldOL check True floats
 113                where
 114                  check (FloatLet _)    y = y
 115                  check (FloatCase _ _) y = False
 116
 117 coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind]
 118 -- Very careful to preserve the arity of top-level functions
 119 coreSatTopBinds [] = returnUs []
 120
 121 coreSatTopBinds (NonRec b r : binds)
 122   = coreSatTopRhs b r           `thenUs` \ (floats, r') ->
 123     coreSatTopBinds binds       `thenUs` \ binds' ->
 124     returnUs (floats ++ NonRec b r' : binds')
 125
 126 coreSatTopBinds (Rec prs : binds)
 127   = mapAndUnzipUs do_pair prs   `thenUs` \ (floats_s, prs') ->
 128     coreSatTopBinds binds       `thenUs` \ binds' ->
 129     returnUs (Rec (flattenBinds (concat floats_s) ++ prs') : binds')
 130   where
 131     do_pair (b,r) = coreSatTopRhs b r   `thenUs` \ (floats, r') ->
 132                     returnUs (floats, (b, r'))
 133
 134 coreSatTopRhs :: Id -> CoreExpr -> UniqSM ([CoreBind], CoreExpr)
 135 -- The trick here is that if we see
 136 --      x = $wC p $wJust q
 137 -- we want to transform to
 138 --      sat = \a -> $wJust a
 139 --      x = $wC p sat q
 140 -- and NOT to
 141 --      x = let sat = \a -> $wJust a in $wC p sat q
 142 --
 143 -- The latter is bad because the thing was a value before, but
 144 -- is a thunk now, and that's wrong because now x may need to
 145 -- be in other bindings' SRTs.
 146 -- This has to be right for recursive as well as non-recursive bindings
 147 --
 148 -- Notice that it's right to give sat vanilla IdInfo; in particular NoCafRefs
 149 --
 150 -- You might worry that arity might increase, thus
 151 --      x = $wC a  ==>  x = \ b c -> $wC a b c
 152 -- but the simpifier does eta expansion vigorously, so I don't think this
 153 -- can occur.  If it did, it would be a problem, because x's arity changes,
 154 -- so we have an ASSERT to check.  (I use WARN so we can see the output.)
 155
 156 coreSatTopRhs b rhs
 157   = coreSatExprFloat rhs        `thenUs` \ (floats, rhs1) ->
 158     if exprIsValue rhs then
 159         ASSERT( allLazy floats )
 160         WARN( idArity b /= exprArity rhs1, ptext SLIT("Disaster!") <+> ppr b )
 161         returnUs ([bind | FloatLet bind <- fromOL floats], rhs1)
 162     else
 163         mkBinds floats rhs1     `thenUs` \ rhs2 ->
 164         WARN( idArity b /= exprArity rhs2, ptext SLIT("Disaster!") <+> ppr b )
 165         returnUs ([], rhs2)
 166
 167
 168 coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind)
 169 -- Used for non-top-level bindings
 170 -- We return a *list* of bindings because we may start with
 171 --      x* = f (g y)
 172 -- where x is demanded, in which case we want to finish with
 173 --      a = g y
 174 --      x* = f a
 175 -- And then x will actually end up case-bound
 176
 177 coreSatBind (NonRec binder rhs)
 178   = coreSatExprFloat rhs        `thenUs` \ (floats, new_rhs) ->
 179     mkNonRec binder (bdrDem binder) floats new_rhs
 180         -- NB: if there are any lambdas at the top of the RHS,
 181         -- the floats will be empty, so the arity won't be affected
 182
 183 coreSatBind (Rec pairs)
 184         -- Don't bother to try to float bindings out of RHSs
 185         -- (compare mkNonRec, which does try)
 186   = mapUs do_rhs pairs                  `thenUs` \ new_pairs ->
 187     returnUs (unitOL (FloatLet (Rec new_pairs)))
 188   where
 189     do_rhs (bndr,rhs) = coreSatAnExpr rhs       `thenUs` \ new_rhs' ->
 190                         returnUs (bndr,new_rhs')
 191
 192
 193 -- ---------------------------------------------------------------------------
 194 -- Making arguments atomic (function args & constructor args)
 195 -- ---------------------------------------------------------------------------
 196
 197 -- This is where we arrange that a non-trivial argument is let-bound
 198 coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg)
 199 coreSatArg arg dem
 200   = coreSatExprFloat arg                `thenUs` \ (floats, arg') ->
 201     if needs_binding arg'
 202         then returnUs (floats, arg')
 203         else newVar (exprType arg')     `thenUs` \ v ->
 204              mkNonRec v dem floats arg' `thenUs` \ floats' ->
 205              returnUs (floats', Var v)
 206
 207 needs_binding | opt_KeepStgTypes = exprIsAtom
 208               | otherwise        = exprIsTrivial
 209
 210 -- ---------------------------------------------------------------------------
 211 -- Dealing with expressions
 212 -- ---------------------------------------------------------------------------
 213
 214 coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
 215 coreSatAnExpr expr
 216   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 217     mkBinds floats expr
 218
 219
 220 coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 221 -- If
 222 --      e  ===>  (bs, e')
 223 -- then
 224 --      e = let bs in e'        (semantically, that is!)
 225 --
 226 -- For example
 227 --      f (g x)   ===>   ([v = g x], f v)
 228
 229 coreSatExprFloat (Var v)
 230   = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
 231     returnUs (nilOL, app)
 232
 233 coreSatExprFloat (Lit lit)
 234   = returnUs (nilOL, Lit lit)
 235
 236 coreSatExprFloat (Let bind body)
 237   = coreSatBind bind                    `thenUs` \ new_binds ->
 238     coreSatExprFloat body               `thenUs` \ (floats, new_body) ->
 239     returnUs (new_binds `appOL` floats, new_body)
 240
 241 coreSatExprFloat (Note n@(SCC _) expr)
 242   = coreSatAnExpr expr                  `thenUs` \ expr ->
 243     deLam expr                          `thenUs` \ expr ->
 244     returnUs (nilOL, Note n expr)
 245
 246 coreSatExprFloat (Note other_note expr)
 247   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 248     returnUs (floats, Note other_note expr)
 249
 250 coreSatExprFloat expr@(Type _)
 251   = returnUs (nilOL, expr)
 252
 253 coreSatExprFloat expr@(Lam _ _)
 254   = coreSatAnExpr body                  `thenUs` \ body' ->
 255     returnUs (nilOL, mkLams bndrs body')
 256   where
 257     (bndrs,body) = collectBinders expr
 258
 259 coreSatExprFloat (Case scrut bndr alts)
 260   = coreSatExprFloat scrut              `thenUs` \ (floats, scrut) ->
 261     mapUs sat_alt alts                  `thenUs` \ alts ->
 262     returnUs (floats, mkCase scrut bndr alts)
 263   where
 264     sat_alt (con, bs, rhs)
 265           = coreSatAnExpr rhs           `thenUs` \ rhs ->
 266             deLam rhs                   `thenUs` \ rhs ->
 267             returnUs (con, bs, rhs)
 268
 269 coreSatExprFloat expr@(App _ _)
 270   = collect_args expr 0  `thenUs` \ (app,(head,depth),ty,floats,ss) ->
 271     ASSERT(null ss)     -- make sure we used all the strictness info
 272
 273         -- Now deal with the function
 274     case head of
 275       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 276                    returnUs (floats, app')
 277
 278       _other    -> returnUs (floats, app)
 279
 280   where
 281
 282     -- Deconstruct and rebuild the application, floating any non-atomic
 283     -- arguments to the outside.  We collect the type of the expression,
 284     -- the head of the application, and the number of actual value arguments,
 285     -- all of which are used to possibly saturate this application if it
 286     -- has a constructor or primop at the head.
 287
 288     collect_args
 289         :: CoreExpr
 290         -> Int                            -- current app depth
 291         -> UniqSM (CoreExpr,              -- the rebuilt expression
 292                    (CoreExpr,Int),        -- the head of the application,
 293                                           -- and no. of args it was applied to
 294                    Type,                  -- type of the whole expr
 295                    OrdList FloatingBind,  -- any floats we pulled out
 296                    [Demand])              -- remaining argument demands
 297
 298     collect_args (App fun arg@(Type arg_ty)) depth
 299         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 300           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 301
 302     collect_args (App fun arg) depth
 303         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 304           let
 305               (ss1, ss_rest)   = case ss of
 306                                    (ss1:ss_rest) -> (ss1, ss_rest)
 307                                    []          -> (wwLazy, [])
 308               (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
 309                                  splitFunTy_maybe fun_ty
 310           in
 311           coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
 312           returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
 313
 314     collect_args (Var v) depth
 315         = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts)
 316         where
 317           stricts = case idStrictness v of
 318                         StrictnessInfo demands _
 319                             | depth >= length demands -> demands
 320                             | otherwise               -> []
 321                         other                         -> []
 322                 -- If depth < length demands, then we have too few args to
 323                 -- satisfy strictness  info so we have to  ignore all the
 324                 -- strictness info, e.g. + (error "urk")
 325                 -- Here, we can't evaluate the arg  strictly, because this
 326                 -- partial  application might be seq'd
 327
 328     collect_args (Note (Coerce ty1 ty2) fun) depth
 329         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 330           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 331
 332     collect_args (Note note fun) depth
 333         | ignore_note note
 334         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 335           returnUs (Note note fun', hd, fun_ty, floats, ss)
 336
 337         -- non-variable fun, better let-bind it
 338     collect_args fun depth
 339         = coreSatExprFloat fun                  `thenUs` \ (fun_floats, fun) ->
 340           newVar ty                             `thenUs` \ fn_id ->
 341           mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
 342           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 343         where
 344           ty = exprType fun
 345
 346     ignore_note InlineCall = True
 347     ignore_note InlineMe   = True
 348     ignore_note _other     = False
 349         -- we don't ignore SCCs, since they require some code generation
 350
 351 ------------------------------------------------------------------------------
 352 -- Generating new binders
 353 -- ---------------------------------------------------------------------------
 354
 355 newVar :: Type -> UniqSM Id
 356 newVar ty
 357  = getUniqueUs                  `thenUs` \ uniq ->
 358    seqType ty                   `seq`
 359    returnUs (mkSysLocal SLIT("sat") uniq ty)
 360
 361 cloneTyVar :: TyVar -> UniqSM TyVar
 362 cloneTyVar tv
 363  = getUniqueUs                  `thenUs` \ uniq ->
 364    returnUs (setTyVarUnique tv uniq)
 365
 366 ------------------------------------------------------------------------------
 367 -- Building the saturated syntax
 368 -- ---------------------------------------------------------------------------
 369
 370 -- maybeSaturate deals with saturating primops and constructors
 371 -- The type is the type of the entire application
 372 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 373 maybeSaturate fn expr n_args ty
 374   | hasNoBinding fn = saturate_it
 375   | otherwise       = returnUs expr
 376   where
 377     fn_arity     = idArity fn
 378     excess_arity = fn_arity - n_args
 379     saturate_it  = getUs        `thenUs` \ us ->
 380                    returnUs (etaExpand excess_arity us expr ty)
 381
 382 -- ---------------------------------------------------------------------------
 383 -- Precipitating the floating bindings
 384 -- ---------------------------------------------------------------------------
 385
 386 -- mkNonRec is used for local bindings only, not top level
 387 mkNonRec :: Id  -> RhsDemand                    -- Lhs: id with demand
 388          -> OrdList FloatingBind -> CoreExpr    -- Rhs: let binds in body
 389          -> UniqSM (OrdList FloatingBind)
 390 mkNonRec bndr dem floats rhs
 391   | exprIsValue rhs && allLazy floats           -- Notably constructor applications
 392   =     -- Why the test for allLazy? You might think that the only
 393         -- floats we can get out of a value are eta expansions
 394         -- e.g.  C $wJust ==> let s = \x -> $wJust x in C s
 395         -- Here we want to float the s binding.
 396         --
 397         -- But if the programmer writes this:
 398         --      f x = case x of { (a,b) -> \y -> a }
 399         -- then the strictness analyser may say that f has strictness "S"
 400         -- Later the eta expander will transform to
 401         --      f x y = case x of { (a,b) -> a }
 402         -- So now f has arity 2.  Now CoreSat may see
 403         --      v = f E
 404         -- so the E argument will turn into a FloatCase.
 405         -- Indeed we should end up with
 406         --      v = case E of { r -> f r }
 407         -- That is, we should not float, even though (f r) is a value
 408     returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
 409
 410   |  isUnLiftedType bndr_rep_ty || isStrictDem dem
 411   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 412     returnUs (floats `snocOL` FloatCase bndr rhs)
 413
 414   | otherwise
 415   = mkBinds floats rhs  `thenUs` \ rhs' ->
 416     returnUs (unitOL (FloatLet (NonRec bndr rhs')))
 417
 418   where
 419     bndr_rep_ty  = repType (idType bndr)
 420
 421 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 422 mkBinds binds body
 423   | isNilOL binds = returnUs body
 424   | otherwise     = deLam body          `thenUs` \ body' ->
 425                     returnUs (foldOL mk_bind body' binds)
 426   where
 427     mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
 428     mk_bind (FloatLet bind)      body = Let bind body
 429
 430 -- ---------------------------------------------------------------------------
 431 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 432 -- We arrange that they only show up as the RHS of a let(rec)
 433 -- ---------------------------------------------------------------------------
 434
 435 deLam :: CoreExpr -> UniqSM CoreExpr
 436 -- Remove top level lambdas by let-bindinig
 437
 438 deLam (Note n expr)
 439   =     -- You can get things like
 440         --      case e of { p -> coerce t (\s -> ...) }
 441     deLam expr  `thenUs` \ expr' ->
 442     returnUs (Note n expr')
 443
 444 deLam expr
 445   | null bndrs = returnUs expr
 446   | otherwise  = case tryEta bndrs body of
 447                    Just no_lam_result -> returnUs no_lam_result
 448                    Nothing            -> newVar (exprType expr) `thenUs` \ fn ->
 449                                          returnUs (Let (NonRec fn expr) (Var fn))
 450   where
 451     (bndrs,body) = collectBinders expr
 452
 453 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 454 -- But the simplifier only eta reduces if that leaves something
 455 -- trivial (like f, or f Int).  But for deLam it would be enough to
 456 -- get to a partial application, like (map f).
 457
 458 tryEta bndrs expr@(App _ _)
 459   | ok_to_eta_reduce f &&
 460     n_remaining >= 0 &&
 461     and (zipWith ok bndrs last_args) &&
 462     not (any (`elemVarSet` fvs_remaining) bndrs)
 463   = Just remaining_expr
 464   where
 465     (f, args) = collectArgs expr
 466     remaining_expr = mkApps f remaining_args
 467     fvs_remaining = exprFreeVars remaining_expr
 468     (remaining_args, last_args) = splitAt n_remaining args
 469     n_remaining = length args - length bndrs
 470
 471     ok bndr (Var arg) = bndr == arg
 472     ok bndr other           = False
 473
 474           -- we can't eta reduce something which must be saturated.
 475     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 476     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 477
 478 tryEta bndrs (Let bind@(NonRec b r) body)
 479   | not (any (`elemVarSet` fvs) bndrs)
 480   = case tryEta bndrs body of
 481         Just e -> Just (Let bind e)
 482         Nothing -> Nothing
 483   where
 484     fvs = exprFreeVars r
 485
 486 tryEta bndrs _ = Nothing
 487 \end{code}
 488
 489
 490 -- -----------------------------------------------------------------------------
 491 --      Do the seq and par transformation
 492 -- -----------------------------------------------------------------------------
 493
 494 Here we do two pre-codegen transformations:
 495
 496 1.      case seq# a of {
 497           0       -> seqError ...
 498           DEFAULT -> rhs }
 499   ==>
 500         case a of { DEFAULT -> rhs }
 501
 502
 503 2.      case par# a of {
 504           0       -> parError ...
 505           DEFAULT -> rhs }
 506   ==>
 507         case par# a of {
 508           DEFAULT -> rhs }
 509
 510 NB:     seq# :: a -> Int#       -- Evaluate value and return anything
 511         par# :: a -> Int#       -- Spark value and return anything
 512
 513 These transformations can't be done earlier, or else we might
 514 think that the expression was strict in the variables in which
 515 rhs is strict --- but that would defeat the purpose of seq and par.
 516
 517
 518 \begin{code}
 519 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
 520   = case isPrimOpId_maybe fn of
 521         Just ParOp -> Case scrut bndr     [deflt_alt]
 522         Just SeqOp ->
 523                       Case arg   new_bndr [deflt_alt]
 524         other      -> Case scrut bndr alts
 525   where
 526     (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
 527
 528         -- The binder shouldn't be used in the expression!
 529     new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
 530                setIdType bndr (exprType arg)
 531         -- NB:  SeqOp :: forall a. a -> Int#
 532         -- So bndr has type Int#
 533         -- But now we are going to scrutinise the SeqOp's argument directly,
 534         -- so we must change the type of the case binder to match that
 535         -- of the argument expression e.
 536
 537 mkCase scrut bndr alts = Case scrut bndr alts
 538 \end{code}
 539
 540
 541 -- -----------------------------------------------------------------------------
 542 -- Demands
 543 -- -----------------------------------------------------------------------------
 544
 545 \begin{code}
 546 data RhsDemand
 547      = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
 548                    isOnceDem   :: Bool   -- True => used at most once
 549                  }
 550
 551 mkDem :: Demand -> Bool -> RhsDemand
 552 mkDem strict once = RhsDemand (isStrict strict) once
 553
 554 mkDemTy :: Demand -> Type -> RhsDemand
 555 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
 556
 557 isOnceTy :: Type -> Bool
 558 isOnceTy ty
 559   =
 560 #ifdef USMANY
 561     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 562 #endif
 563     once
 564   where
 565     u = uaUTy ty
 566     once | u == usOnce  = True
 567          | u == usMany  = False
 568          | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
 569
 570 bdrDem :: Id -> RhsDemand
 571 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
 572
 573 safeDem, onceDem :: RhsDemand
 574 safeDem = RhsDemand False False  -- always safe to use this
 575 onceDem = RhsDemand False True   -- used at most once
 576 \end{code}
 577
 578