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