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