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 )
  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 = FloatBind CoreBind
 104                   | FloatCase Id CoreExpr
 105
 106 coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind]
 107 -- Very careful to preserve the arity of top-level functions
 108 coreSatTopBinds bs
 109   = mapUs do_bind bs
 110   where
 111     do_bind (NonRec b r) = coreSatAnExpr r      `thenUs` \ r' ->
 112                            returnUs (NonRec b r')
 113     do_bind (Rec prs)    = mapUs do_pair prs    `thenUs` \ prs' ->
 114                            returnUs (Rec prs')
 115     do_pair (b,r)        = coreSatAnExpr r      `thenUs` \ r' ->
 116                            returnUs (b, r')
 117
 118
 119 coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind)
 120 -- Used for non-top-level bindings
 121 -- We return a *list* of bindings because we may start with
 122 --      x* = f (g y)
 123 -- where x is demanded, in which case we want to finish with
 124 --      a = g y
 125 --      x* = f a
 126 -- And then x will actually end up case-bound
 127
 128 coreSatBind (NonRec binder rhs)
 129   = coreSatExprFloat rhs        `thenUs` \ (floats, new_rhs) ->
 130     mkNonRec binder new_rhs (bdrDem binder) floats
 131         -- NB: if there are any lambdas at the top of the RHS,
 132         -- the floats will be empty, so the arity won't be affected
 133
 134 coreSatBind (Rec pairs)
 135   = mapUs do_rhs pairs                  `thenUs` \ new_pairs ->
 136     returnUs (unitOL (FloatBind (Rec new_pairs)))
 137   where
 138     do_rhs (bndr,rhs) = coreSatAnExpr rhs       `thenUs` \ new_rhs' ->
 139                         returnUs (bndr,new_rhs')
 140
 141
 142 -- ---------------------------------------------------------------------------
 143 -- Making arguments atomic (function args & constructor args)
 144 -- ---------------------------------------------------------------------------
 145
 146 -- This is where we arrange that a non-trivial argument is let-bound
 147 coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg)
 148 coreSatArg arg dem
 149   = coreSatExprFloat arg                `thenUs` \ (floats, arg') ->
 150     if needs_binding arg'
 151         then returnUs (floats, arg')
 152         else newVar (exprType arg')     `thenUs` \ v ->
 153              mkNonRec v arg' dem floats `thenUs` \ floats' ->
 154              returnUs (floats', Var v)
 155
 156 needs_binding | opt_KeepStgTypes = exprIsAtom
 157               | otherwise        = exprIsTrivial
 158
 159 -- ---------------------------------------------------------------------------
 160 -- Dealing with expressions
 161 -- ---------------------------------------------------------------------------
 162
 163 coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
 164 coreSatAnExpr expr
 165   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 166     mkBinds floats expr
 167
 168
 169 coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 170 -- If
 171 --      e  ===>  (bs, e')
 172 -- then
 173 --      e = let bs in e'        (semantically, that is!)
 174 --
 175 -- For example
 176 --      f (g x)   ===>   ([v = g x], f v)
 177
 178 coreSatExprFloat (Var v)
 179   = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
 180     returnUs (nilOL, app)
 181
 182 coreSatExprFloat (Lit lit)
 183   = returnUs (nilOL, Lit lit)
 184
 185 coreSatExprFloat (Let bind body)
 186   = coreSatBind bind                    `thenUs` \ new_binds ->
 187     coreSatExprFloat body               `thenUs` \ (floats, new_body) ->
 188     returnUs (new_binds `appOL` floats, new_body)
 189
 190 coreSatExprFloat (Note n@(SCC _) expr)
 191   = coreSatAnExpr expr                  `thenUs` \ expr ->
 192     deLam expr                          `thenUs` \ expr ->
 193     returnUs (nilOL, Note n expr)
 194
 195 coreSatExprFloat (Note other_note expr)
 196   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 197     returnUs (floats, Note other_note expr)
 198
 199 coreSatExprFloat expr@(Type _)
 200   = returnUs (nilOL, expr)
 201
 202 coreSatExprFloat expr@(Lam _ _)
 203   = coreSatAnExpr body                  `thenUs` \ body' ->
 204     returnUs (nilOL, mkLams bndrs body')
 205   where
 206     (bndrs,body) = collectBinders expr
 207
 208 coreSatExprFloat (Case scrut bndr alts)
 209   = coreSatExprFloat scrut              `thenUs` \ (floats, scrut) ->
 210     mapUs sat_alt alts                  `thenUs` \ alts ->
 211     returnUs (floats, Case scrut bndr alts)
 212   where
 213     sat_alt (con, bs, rhs)
 214           = coreSatAnExpr rhs           `thenUs` \ rhs ->
 215             deLam rhs                   `thenUs` \ rhs ->
 216             returnUs (con, bs, rhs)
 217
 218 coreSatExprFloat expr@(App _ _)
 219   = collect_args expr 0  `thenUs` \ (app,(head,depth),ty,floats,ss) ->
 220     ASSERT(null ss)     -- make sure we used all the strictness info
 221
 222         -- Now deal with the function
 223     case head of
 224       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 225                    returnUs (floats, app')
 226
 227       _other    -> returnUs (floats, app)
 228
 229   where
 230
 231     -- Deconstruct and rebuild the application, floating any non-atomic
 232     -- arguments to the outside.  We collect the type of the expression,
 233     -- the head of the application, and the number of actual value arguments,
 234     -- all of which are used to possibly saturate this application if it
 235     -- has a constructor or primop at the head.
 236
 237     collect_args
 238         :: CoreExpr
 239         -> Int                            -- current app depth
 240         -> UniqSM (CoreExpr,              -- the rebuilt expression
 241                    (CoreExpr,Int),        -- the head of the application,
 242                                           -- and no. of args it was applied to
 243                    Type,                  -- type of the whole expr
 244                    OrdList FloatingBind,  -- any floats we pulled out
 245                    [Demand])              -- remaining argument demands
 246
 247     collect_args (App fun arg@(Type arg_ty)) depth
 248         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 249           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 250
 251     collect_args (App fun arg) depth
 252         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 253           let
 254               (ss1, ss_rest)   = case ss of
 255                                    (ss1:ss_rest) -> (ss1, ss_rest)
 256                                    []          -> (wwLazy, [])
 257               (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
 258                                  splitFunTy_maybe fun_ty
 259           in
 260           coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
 261           returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
 262
 263     collect_args (Var v) depth
 264         = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts)
 265         where
 266           stricts = case idStrictness v of
 267                         StrictnessInfo demands _
 268                             | depth >= length demands -> demands
 269                             | otherwise               -> []
 270                         other                         -> []
 271                 -- If depth < length demands, then we have too few args to
 272                 -- satisfy strictness  info so we have to  ignore all the
 273                 -- strictness info, e.g. + (error "urk")
 274                 -- Here, we can't evaluate the arg  strictly, because this
 275                 -- partial  application might be seq'd
 276
 277     collect_args (Note (Coerce ty1 ty2) fun) depth
 278         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 279           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 280
 281     collect_args (Note note fun) depth
 282         | ignore_note note
 283         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 284           returnUs (Note note fun', hd, fun_ty, floats, ss)
 285
 286         -- non-variable fun, better let-bind it
 287     collect_args fun depth
 288         = coreSatExprFloat fun                  `thenUs` \ (fun_floats, fun) ->
 289           newVar ty                             `thenUs` \ fn_id ->
 290           mkNonRec fn_id fun onceDem fun_floats `thenUs` \ floats ->
 291           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 292         where
 293           ty = exprType fun
 294
 295     ignore_note InlineCall = True
 296     ignore_note InlineMe   = True
 297     ignore_note _other     = False
 298         -- we don't ignore SCCs, since they require some code generation
 299
 300 ------------------------------------------------------------------------------
 301 -- Generating new binders
 302 -- ---------------------------------------------------------------------------
 303
 304 newVar :: Type -> UniqSM Id
 305 newVar ty
 306  = getUniqueUs                  `thenUs` \ uniq ->
 307    seqType ty                   `seq`
 308    returnUs (mkSysLocal SLIT("sat") uniq ty)
 309
 310 cloneTyVar :: TyVar -> UniqSM TyVar
 311 cloneTyVar tv
 312  = getUniqueUs                  `thenUs` \ uniq ->
 313    returnUs (setTyVarUnique tv uniq)
 314
 315 ------------------------------------------------------------------------------
 316 -- Building the saturated syntax
 317 -- ---------------------------------------------------------------------------
 318
 319 -- maybeSaturate deals with saturating primops and constructors
 320 -- The type is the type of the entire application
 321 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 322 maybeSaturate fn expr n_args ty
 323   = case idFlavour fn of
 324       PrimOpId op  -> saturate_it
 325       DataConId dc -> saturate_it
 326       other        -> returnUs expr
 327   where
 328     fn_arity     = idArity fn
 329     excess_arity = fn_arity - n_args
 330     saturate_it  = getUs        `thenUs` \ us ->
 331                    returnUs (etaExpand excess_arity us expr ty)
 332
 333 -- ---------------------------------------------------------------------------
 334 -- Precipitating the floating bindings
 335 -- ---------------------------------------------------------------------------
 336
 337 -- mkNonrec is used for local bindings only, not top level
 338 mkNonRec bndr rhs dem floats
 339   |  isUnLiftedType bndr_rep_ty
 340   || isStrictDem dem && not (exprIsValue rhs)
 341   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 342     returnUs (floats `snocOL` FloatCase bndr rhs)
 343   where
 344     bndr_rep_ty = repType (idType bndr)
 345
 346 mkNonRec bndr rhs dem floats
 347   = mkBinds floats rhs  `thenUs` \ rhs' ->
 348     returnUs (unitOL (FloatBind (NonRec bndr rhs')))
 349
 350 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 351 mkBinds binds body
 352   | isNilOL binds = returnUs body
 353   | otherwise     = deLam body          `thenUs` \ body' ->
 354                     returnUs (foldOL mk_bind body' binds)
 355   where
 356     mk_bind (FloatCase bndr rhs) body = Case rhs bndr [(DEFAULT, [], body)]
 357     mk_bind (FloatBind bind)     body = Let bind body
 358
 359 -- ---------------------------------------------------------------------------
 360 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 361 -- We arrange that they only show up as the RHS of a let(rec)
 362 -- ---------------------------------------------------------------------------
 363
 364 deLam :: CoreExpr -> UniqSM CoreExpr
 365 -- Remove top level lambdas by let-bindinig
 366 deLam expr
 367   | null bndrs = returnUs expr
 368   | otherwise  = case tryEta bndrs body of
 369                    Just no_lam_result -> returnUs no_lam_result
 370                    Nothing            -> newVar (exprType expr) `thenUs` \ fn ->
 371                                          returnUs (Let (NonRec fn expr) (Var fn))
 372   where
 373     (bndrs,body) = collectBinders expr
 374
 375 tryEta bndrs expr@(App _ _)
 376   | ok_to_eta_reduce f &&
 377     n_remaining >= 0 &&
 378     and (zipWith ok bndrs last_args) &&
 379     not (any (`elemVarSet` fvs_remaining) bndrs)
 380   = Just remaining_expr
 381   where
 382     (f, args) = collectArgs expr
 383     remaining_expr = mkApps f remaining_args
 384     fvs_remaining = exprFreeVars remaining_expr
 385     (remaining_args, last_args) = splitAt n_remaining args
 386     n_remaining = length args - length bndrs
 387
 388     ok bndr (Var arg) = bndr == arg
 389     ok bndr other           = False
 390
 391           -- we can't eta reduce something which must be saturated.
 392     ok_to_eta_reduce (Var f)
 393          = case idFlavour f of
 394               PrimOpId op  -> False
 395               DataConId dc -> False
 396               other        -> True
 397     ok_to_eta_reduce _ = False --safe. ToDo: generalise
 398
 399 tryEta bndrs (Let bind@(NonRec b r) body)
 400   | not (any (`elemVarSet` fvs) bndrs)
 401   = case tryEta bndrs body of
 402         Just e -> Just (Let bind e)
 403         Nothing -> Nothing
 404   where
 405     fvs = exprFreeVars r
 406
 407 tryEta bndrs _ = Nothing
 408
 409 -- -----------------------------------------------------------------------------
 410 -- Demands
 411 -- -----------------------------------------------------------------------------
 412
 413 data RhsDemand
 414      = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
 415                    isOnceDem   :: Bool   -- True => used at most once
 416                  }
 417
 418 mkDem :: Demand -> Bool -> RhsDemand
 419 mkDem strict once = RhsDemand (isStrict strict) once
 420
 421 mkDemTy :: Demand -> Type -> RhsDemand
 422 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
 423
 424 isOnceTy :: Type -> Bool
 425 isOnceTy ty
 426   =
 427 #ifdef USMANY
 428     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 429 #endif
 430     once
 431   where
 432     u = uaUTy ty
 433     once | u == usOnce  = True
 434          | u == usMany  = False
 435          | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
 436
 437 bdrDem :: Id -> RhsDemand
 438 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
 439
 440 safeDem, onceDem :: RhsDemand
 441 safeDem = RhsDemand False False  -- always safe to use this
 442 onceDem = RhsDemand False True   -- used at most once
 443 \end{code}