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