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
  14 import CoreFVs
  15 import CoreLint
  16 import CoreSyn
  17 import Type
  18 import Demand
  19 import Var      ( TyVar, setTyVarUnique )
  20 import VarSet
  21 import IdInfo
  22 import Id
  23 import PrimOp
  24 import UniqSupply
  25 import Maybes
  26 import ErrUtils
  27 import CmdLineOpts
  28 import Outputable
  29 \end{code}
  30
  31 -- ---------------------------------------------------------------------------
  32 -- Overview
  33 -- ---------------------------------------------------------------------------
  34
  35 Most of the contents of this pass used to be in CoreToStg.  The
  36 primary goals here are:
  37
  38 1.  Get the program into "A-normal form". In particular:
  39
  40         f E        ==>  let x = E in f x
  41                 OR ==>  case E of x -> f x
  42
  43
  44     if E is a non-trivial expression.
  45     Which transformation is used depends on whether f is strict or not.
  46     [Previously the transformation to case used to be done by the
  47      simplifier, but it's better done here.  It does mean that f needs
  48      to have its strictness info correct!.]
  49
  50 2.  Similarly, convert any unboxed lets into cases.
  51     [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
  52      right up to this point.]
  53
  54     This is all done modulo type applications and abstractions, so that
  55     when type erasure is done for conversion to STG, we don't end up with
  56     any trivial or useless bindings.
  57
  58 3.  Ensure that lambdas only occur as the RHS of a binding
  59     (The code generator can't deal with anything else.)
  60
  61 4.  Saturate constructor and primop applications.
  62
  63
  64
  65 -- -----------------------------------------------------------------------------
  66 -- Top level stuff
  67 -- -----------------------------------------------------------------------------
  68
  69 \begin{code}
  70 coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
  71 coreSatPgm dflags binds
  72   = do  showPass dflags "CoreSat"
  73         us <- mkSplitUniqSupply 's'
  74         let new_binds = initUs_ us (coreSatBinds binds)
  75         endPass dflags "CoreSat" Opt_D_dump_sat new_binds
  76
  77 coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
  78 coreSatExpr dflags expr
  79   = do showPass dflags "CoreSat"
  80        us <- mkSplitUniqSupply 's'
  81        let new_expr = initUs_ us (coreSatAnExpr expr)
  82        dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
  83           (ppr new_expr)
  84        return new_expr
  85
  86 -- ---------------------------------------------------------------------------
  87 -- Dealing with bindings
  88 -- ---------------------------------------------------------------------------
  89
  90 data FloatingBind
  91    = RecF [(Id, CoreExpr)]
  92    | NonRecF Id
  93              CoreExpr           -- *Can* be a Lam
  94              RhsDemand
  95              [FloatingBind]
  96
  97 coreSatBinds :: [CoreBind] -> UniqSM [CoreBind]
  98 coreSatBinds [] = returnUs []
  99 coreSatBinds (b:bs)
 100   = coreSatBind b       `thenUs` \ float ->
 101     coreSatBinds bs     `thenUs` \ new_bs ->
 102     case float of
 103         NonRecF bndr rhs dem floats
 104                 -> ASSERT2( not (isStrictDem dem) &&
 105                             not (isUnLiftedType (idType bndr)),
 106                             ppr b )             -- No top-level cases!
 107
 108                    mkBinds floats rhs           `thenUs` \ new_rhs ->
 109                    returnUs (NonRec bndr new_rhs : new_bs)
 110                                 -- Keep all the floats inside...
 111                                 -- Some might be cases etc
 112                                 -- We might want to revisit this decision
 113
 114         RecF prs -> returnUs (Rec prs : new_bs)
 115
 116 coreSatBind :: CoreBind -> UniqSM FloatingBind
 117 coreSatBind (NonRec binder rhs)
 118   = coreSatExprFloat rhs                `thenUs` \ (floats, new_rhs) ->
 119     returnUs (NonRecF binder new_rhs (bdrDem binder) floats)
 120 coreSatBind (Rec pairs)
 121   = mapUs do_rhs pairs                  `thenUs` \ new_rhss ->
 122     returnUs (RecF (binders `zip` new_rhss))
 123   where
 124     binders = map fst pairs
 125     do_rhs (bndr,rhs) =
 126         coreSatExprFloat rhs            `thenUs` \ (floats, new_rhs) ->
 127         mkBinds floats new_rhs          `thenUs` \ new_rhs' ->
 128                 -- NB: new_rhs' might still be a Lam (and we want that)
 129         returnUs new_rhs'
 130
 131 -- ---------------------------------------------------------------------------
 132 -- Making arguments atomic (function args & constructor args)
 133 -- ---------------------------------------------------------------------------
 134
 135 -- This is where we arrange that a non-trivial argument is let-bound
 136 coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg)
 137 coreSatArg arg dem
 138   = coreSatExprFloat arg                `thenUs` \ (floats, arg') ->
 139     if exprIsTrivial arg'
 140         then returnUs (floats, arg')
 141         else newVar (exprType arg')     `thenUs` \ v ->
 142              returnUs ([NonRecF v arg' dem floats], Var v)
 143
 144 -- ---------------------------------------------------------------------------
 145 -- Dealing with expressions
 146 -- ---------------------------------------------------------------------------
 147
 148 coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
 149 coreSatAnExpr expr
 150   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 151     mkBinds floats expr
 152
 153
 154 coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
 155 -- If
 156 --      e  ===>  (bs, e')
 157 -- then
 158 --      e = let bs in e'        (semantically, that is!)
 159 --
 160 -- For example
 161 --      f (g x)   ===>   ([v = g x], f v)
 162
 163 coreSatExprFloat (Var v)
 164   = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
 165     returnUs ([], app)
 166
 167 coreSatExprFloat (Lit lit)
 168   = returnUs ([], Lit lit)
 169
 170 coreSatExprFloat (Let bind body)
 171   = coreSatBind bind                    `thenUs` \ new_bind ->
 172     coreSatExprFloat body               `thenUs` \ (floats, new_body) ->
 173     returnUs (new_bind:floats, new_body)
 174
 175 coreSatExprFloat (Note n@(SCC _) expr)
 176   = coreSatAnExpr expr                  `thenUs` \ expr ->
 177     deLam expr                          `thenUs` \ expr ->
 178     returnUs ([], Note n expr)
 179
 180 coreSatExprFloat (Note other_note expr)
 181   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 182     returnUs (floats, Note other_note expr)
 183
 184 coreSatExprFloat expr@(Type _)
 185   = returnUs ([], expr)
 186
 187 coreSatExprFloat (Lam v e)
 188   = coreSatAnExpr e                     `thenUs` \ e' ->
 189     returnUs ([], Lam v e')
 190
 191 coreSatExprFloat (Case scrut bndr alts)
 192   = coreSatExprFloat scrut              `thenUs` \ (floats, scrut) ->
 193     mapUs sat_alt alts                  `thenUs` \ alts ->
 194     returnUs (floats, Case scrut bndr alts)
 195   where
 196     sat_alt (con, bs, rhs)
 197           = coreSatAnExpr rhs            `thenUs` \ rhs ->
 198             deLam rhs                    `thenUs` \ rhs ->
 199             returnUs (con, bs, rhs)
 200
 201 coreSatExprFloat expr@(App _ _)
 202   = collect_args expr 0  `thenUs` \ (app,(head,depth),ty,floats,ss) ->
 203     ASSERT(null ss)     -- make sure we used all the strictness info
 204
 205         -- Now deal with the function
 206     case head of
 207       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 208                    returnUs (floats, app')
 209
 210       _other    -> returnUs (floats, app)
 211
 212   where
 213
 214     -- Deconstruct and rebuild the application, floating any non-atomic
 215     -- arguments to the outside.  We collect the type of the expression,
 216     -- the head of the applicaiton, and the number of actual value arguments,
 217     -- all of which are used to possibly saturate this application if it
 218     -- has a constructor or primop at the head.
 219
 220     collect_args
 221         :: CoreExpr
 222         -> Int                          -- current app depth
 223         -> UniqSM (CoreExpr,            -- the rebuilt expression
 224                    (CoreExpr,Int),      -- the head of the application,
 225                                           -- and no. of args it was applied to
 226                    Type,                -- type of the whole expr
 227                    [FloatingBind],      -- any floats we pulled out
 228                    [Demand])            -- remaining argument demands
 229
 230     collect_args (App fun arg@(Type arg_ty)) depth
 231         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 232           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 233
 234     collect_args (App fun arg) depth
 235         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 236           let
 237               (ss1, ss_rest)   = case ss of
 238                                    (ss1:ss_rest) -> (ss1, ss_rest)
 239                                    []          -> (wwLazy, [])
 240               (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
 241                                  splitFunTy_maybe fun_ty
 242           in
 243           coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
 244           returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
 245
 246     collect_args (Var v) depth
 247         = returnUs (Var v, (Var v, depth), idType v, [], stricts)
 248         where
 249           stricts = case idStrictness v of
 250                         StrictnessInfo demands _
 251                             | depth >= length demands -> demands
 252                             | otherwise               -> []
 253                         other                         -> []
 254                 -- If depth < length demands, then we have too few args to
 255                 -- satisfy strictness  info so we have to  ignore all the
 256                 -- strictness info, e.g. + (error "urk")
 257                 -- Here, we can't evaluate the arg  strictly, because this
 258                 -- partial  application might be seq'd
 259
 260     collect_args (Note (Coerce ty1 ty2) fun) depth
 261         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 262           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 263
 264     collect_args (Note note fun) depth
 265         | ignore_note note
 266         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 267           returnUs (Note note fun', hd, fun_ty, floats, ss)
 268
 269         -- non-variable fun, better let-bind it
 270     collect_args fun depth
 271         = newVar ty                     `thenUs` \ fn_id ->
 272           coreSatExprFloat fun          `thenUs` \ (fun_floats, fun) ->
 273           returnUs (Var fn_id, (Var fn_id, depth), ty,
 274                     [NonRecF fn_id fun onceDem fun_floats], [])
 275         where ty = exprType fun
 276
 277     ignore_note InlineCall = True
 278     ignore_note InlineMe   = True
 279     ignore_note _other     = False
 280         -- we don't ignore SCCs, since they require some code generation
 281
 282 ------------------------------------------------------------------------------
 283 -- Generating new binders
 284 -- ---------------------------------------------------------------------------
 285
 286 newVar :: Type -> UniqSM Id
 287 newVar ty
 288  = getUniqueUs                  `thenUs` \ uniq ->
 289    seqType ty                   `seq`
 290    returnUs (mkSysLocal SLIT("sat") uniq ty)
 291
 292 cloneTyVar :: TyVar -> UniqSM TyVar
 293 cloneTyVar tv
 294  = getUniqueUs                  `thenUs` \ uniq ->
 295    returnUs (setTyVarUnique tv uniq)
 296
 297 ------------------------------------------------------------------------------
 298 -- Building the saturated syntax
 299 -- ---------------------------------------------------------------------------
 300
 301 -- maybeSaturate deals with saturating primops and constructors
 302 -- The type is the type of the entire application
 303 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 304 maybeSaturate fn expr n_args ty
 305   = case idFlavour fn of
 306       PrimOpId op  -> saturate_it
 307       DataConId dc -> saturate_it
 308       other        -> returnUs expr
 309   where
 310     fn_arity     = idArity fn
 311     excess_arity = fn_arity - n_args
 312     saturate_it  = getUs        `thenUs` \ us ->
 313                    returnUs (etaExpand excess_arity us expr ty)
 314
 315 -- ---------------------------------------------------------------------------
 316 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 317 -- ---------------------------------------------------------------------------
 318
 319 deLam (Note n e)
 320   = deLam e `thenUs` \ e ->
 321     returnUs (Note n e)
 322
 323    -- types will all disappear, so that's ok
 324 deLam (Lam x e) | isTyVar x
 325   = deLam e `thenUs` \ e ->
 326     returnUs (Lam x e)
 327
 328 deLam expr@(Lam _ _)
 329         -- Try for eta reduction
 330   | Just e <- eta body
 331   = returnUs e
 332
 333         -- Eta failed, so let-bind the lambda
 334   | otherwise
 335   = newVar (exprType expr) `thenUs` \ fn ->
 336     returnUs (Let (NonRec fn expr) (Var fn))
 337
 338   where
 339     (bndrs, body) = collectBinders expr
 340
 341     eta expr@(App _ _)
 342         | ok_to_eta_reduce f &&
 343           n_remaining >= 0 &&
 344           and (zipWith ok bndrs last_args) &&
 345           not (any (`elemVarSet` fvs_remaining) bndrs)
 346         = Just remaining_expr
 347         where
 348           (f, args) = collectArgs expr
 349           remaining_expr = mkApps f remaining_args
 350           fvs_remaining = exprFreeVars remaining_expr
 351           (remaining_args, last_args) = splitAt n_remaining args
 352           n_remaining = length args - length bndrs
 353
 354           ok bndr (Var arg) = bndr == arg
 355           ok bndr other     = False
 356
 357           -- we can't eta reduce something which must be saturated.
 358           ok_to_eta_reduce (Var f)
 359                  = case idFlavour f of
 360                       PrimOpId op  -> False
 361                       DataConId dc -> False
 362                       other        -> True
 363           ok_to_eta_reduce _ = False --safe. ToDo: generalise
 364
 365     eta (Let bind@(NonRec b r) body)
 366         | not (any (`elemVarSet` fvs) bndrs)
 367                  = case eta body of
 368                         Just e -> Just (Let bind e)
 369                         Nothing -> Nothing
 370         where fvs = exprFreeVars r
 371
 372     eta _ = Nothing
 373
 374 deLam expr = returnUs expr
 375
 376 -- ---------------------------------------------------------------------------
 377 -- Precipitating the floating bindings
 378 -- ---------------------------------------------------------------------------
 379
 380 mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
 381 mkBinds []     body = returnUs body
 382 mkBinds (b:bs) body
 383   = deLam body          `thenUs` \ body' ->
 384     go (b:bs) body'
 385   where
 386     go []     body = returnUs body
 387     go (b:bs) body = go bs body         `thenUs` \ body' ->
 388                      mkBind  b body'
 389
 390 -- body can't be Lam
 391 mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
 392
 393 mkBind (NonRecF bndr rhs dem floats) body
 394 #ifdef DEBUG
 395   -- We shouldn't get let or case of the form v=w
 396   = if exprIsTrivial rhs
 397         then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
 398              (mk_let bndr rhs dem floats body)
 399         else mk_let bndr rhs dem floats body
 400
 401 mk_let bndr rhs dem floats body
 402 #endif
 403   | isUnLiftedType bndr_rep_ty
 404   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 405     mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
 406
 407   | is_whnf
 408   = if is_strict then
 409         -- Strict let with WHNF rhs
 410         mkBinds floats $
 411         Let (NonRec bndr rhs) body
 412     else
 413         -- Lazy let with WHNF rhs; float until we find a strict binding
 414         let
 415             (floats_out, floats_in) = splitFloats floats
 416         in
 417         mkBinds floats_in rhs   `thenUs` \ new_rhs ->
 418         mkBinds floats_out $
 419         Let (NonRec bndr new_rhs) body
 420
 421   | otherwise   -- Not WHNF
 422   = if is_strict then
 423         -- Strict let with non-WHNF rhs
 424         mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
 425     else
 426         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 427         mkBinds floats rhs              `thenUs` \ new_rhs ->
 428         returnUs (Let (NonRec bndr new_rhs) body)
 429
 430   where
 431     bndr_rep_ty = repType (idType bndr)
 432     is_strict   = isStrictDem dem
 433     is_whnf     = exprIsValue rhs
 434
 435 splitFloats fs@(NonRecF _ _ dem _ : _)
 436   | isStrictDem dem = ([], fs)
 437
 438 splitFloats (f : fs) = case splitFloats fs of
 439                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 440
 441 splitFloats [] = ([], [])
 442
 443 -- -----------------------------------------------------------------------------
 444 -- Demands
 445 -- -----------------------------------------------------------------------------
 446
 447 data RhsDemand
 448      = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
 449                    isOnceDem   :: Bool   -- True => used at most once
 450                  }
 451
 452 mkDem :: Demand -> Bool -> RhsDemand
 453 mkDem strict once = RhsDemand (isStrict strict) once
 454
 455 mkDemTy :: Demand -> Type -> RhsDemand
 456 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
 457
 458 isOnceTy :: Type -> Bool
 459 isOnceTy ty
 460   =
 461 #ifdef USMANY
 462     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 463 #endif
 464     once
 465   where
 466     u = uaUTy ty
 467     once | u == usOnce  = True
 468          | u == usMany  = False
 469          | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
 470
 471 bdrDem :: Id -> RhsDemand
 472 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
 473
 474 safeDem, onceDem :: RhsDemand
 475 safeDem = RhsDemand False False  -- always safe to use this
 476 onceDem = RhsDemand False True   -- used at most once
 477 \end{code}