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 other_note expr)
 176   = coreSatExprFloat expr               `thenUs` \ (floats, expr) ->
 177     returnUs (floats, Note other_note expr)
 178
 179 coreSatExprFloat expr@(Type _)
 180   = returnUs ([], expr)
 181
 182 coreSatExprFloat (Lam v e)
 183   = coreSatAnExpr e                     `thenUs` \ e' ->
 184     returnUs ([], Lam v e')
 185
 186 coreSatExprFloat (Case scrut bndr alts)
 187   = coreSatExprFloat scrut              `thenUs` \ (floats, scrut) ->
 188     mapUs sat_alt alts                  `thenUs` \ alts ->
 189     returnUs (floats, Case scrut bndr alts)
 190   where
 191     sat_alt (con, bs, rhs)
 192           = coreSatAnExpr rhs            `thenUs` \ rhs ->
 193             deLam rhs                    `thenUs` \ rhs ->
 194             returnUs (con, bs, rhs)
 195
 196 coreSatExprFloat expr@(App _ _)
 197   = collect_args expr 0  `thenUs` \ (app,(head,depth),ty,floats,ss) ->
 198     ASSERT(null ss)     -- make sure we used all the strictness info
 199
 200         -- Now deal with the function
 201     case head of
 202       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 203                    returnUs (floats, app')
 204
 205       _other    -> returnUs (floats, app)
 206
 207   where
 208
 209     -- Deconstruct and rebuild the application, floating any non-atomic
 210     -- arguments to the outside.  We collect the type of the expression,
 211     -- the head of the applicaiton, and the number of actual value arguments,
 212     -- all of which are used to possibly saturate this application if it
 213     -- has a constructor or primop at the head.
 214
 215     collect_args
 216         :: CoreExpr
 217         -> Int                          -- current app depth
 218         -> UniqSM (CoreExpr,            -- the rebuilt expression
 219                    (CoreExpr,Int),      -- the head of the application,
 220                                           -- and no. of args it was applied to
 221                    Type,                -- type of the whole expr
 222                    [FloatingBind],      -- any floats we pulled out
 223                    [Demand])            -- remaining argument demands
 224
 225     collect_args (App fun arg@(Type arg_ty)) depth
 226         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 227           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 228
 229     collect_args (App fun arg) depth
 230         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 231           let
 232               (ss1, ss_rest)   = case ss of
 233                                    (ss1:ss_rest) -> (ss1, ss_rest)
 234                                    []          -> (wwLazy, [])
 235               (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
 236                                  splitFunTy_maybe fun_ty
 237           in
 238           coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
 239           returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
 240
 241     collect_args (Var v) depth
 242         = returnUs (Var v, (Var v, depth), idType v, [], stricts)
 243         where
 244           stricts = case idStrictness v of
 245                         StrictnessInfo demands _
 246                             | depth >= length demands -> demands
 247                             | otherwise               -> []
 248                         other                         -> []
 249                 -- If depth < length demands, then we have too few args to
 250                 -- satisfy strictness  info so we have to  ignore all the
 251                 -- strictness info, e.g. + (error "urk")
 252                 -- Here, we can't evaluate the arg  strictly, because this
 253                 -- partial  application might be seq'd
 254
 255     collect_args (Note (Coerce ty1 ty2) fun) depth
 256         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 257           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 258
 259     collect_args (Note note fun) depth
 260         | ignore_note note
 261         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 262           returnUs (Note note fun', hd, fun_ty, floats, ss)
 263
 264         -- non-variable fun, better let-bind it
 265     collect_args fun depth
 266         = newVar ty                     `thenUs` \ fn_id ->
 267           coreSatExprFloat fun          `thenUs` \ (fun_floats, fun) ->
 268           returnUs (Var fn_id, (Var fn_id, depth), ty,
 269                     [NonRecF fn_id fun onceDem fun_floats], [])
 270         where ty = exprType fun
 271
 272     ignore_note InlineCall = True
 273     ignore_note InlineMe   = True
 274     ignore_note _other     = False
 275         -- we don't ignore SCCs, since they require some code generation
 276
 277 ------------------------------------------------------------------------------
 278 -- Generating new binders
 279 -- ---------------------------------------------------------------------------
 280
 281 newVar :: Type -> UniqSM Id
 282 newVar ty
 283  = getUniqueUs                  `thenUs` \ uniq ->
 284    seqType ty                   `seq`
 285    returnUs (mkSysLocal SLIT("sat") uniq ty)
 286
 287 cloneTyVar :: TyVar -> UniqSM TyVar
 288 cloneTyVar tv
 289  = getUniqueUs                  `thenUs` \ uniq ->
 290    returnUs (setTyVarUnique tv uniq)
 291
 292 ------------------------------------------------------------------------------
 293 -- Building the saturated syntax
 294 -- ---------------------------------------------------------------------------
 295
 296 -- maybeSaturate deals with saturating primops and constructors
 297 -- The type is the type of the entire application
 298 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 299 maybeSaturate fn expr n_args ty
 300   = case idFlavour fn of
 301       PrimOpId op  -> saturate_it
 302       DataConId dc -> saturate_it
 303       other        -> returnUs expr
 304   where
 305     fn_arity     = idArity fn
 306     excess_arity = fn_arity - n_args
 307     saturate_it  = getUs        `thenUs` \ us ->
 308                    returnUs (etaExpand excess_arity us expr ty)
 309
 310 -- ---------------------------------------------------------------------------
 311 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 312 -- ---------------------------------------------------------------------------
 313
 314 deLam (Note n e)
 315   = deLam e `thenUs` \ e ->
 316     returnUs (Note n e)
 317
 318    -- types will all disappear, so that's ok
 319 deLam (Lam x e) | isTyVar x
 320   = deLam e `thenUs` \ e ->
 321     returnUs (Lam x e)
 322
 323 deLam expr@(Lam _ _)
 324         -- Try for eta reduction
 325   | Just e <- eta body
 326   = returnUs e
 327
 328         -- Eta failed, so let-bind the lambda
 329   | otherwise
 330   = newVar (exprType expr) `thenUs` \ fn ->
 331     returnUs (Let (NonRec fn expr) (Var fn))
 332
 333   where
 334     (bndrs, body) = collectBinders expr
 335
 336     eta expr@(App _ _)
 337         | ok_to_eta_reduce f &&
 338           n_remaining >= 0 &&
 339           and (zipWith ok bndrs last_args) &&
 340           not (any (`elemVarSet` fvs_remaining) bndrs)
 341         = Just remaining_expr
 342         where
 343           (f, args) = collectArgs expr
 344           remaining_expr = mkApps f remaining_args
 345           fvs_remaining = exprFreeVars remaining_expr
 346           (remaining_args, last_args) = splitAt n_remaining args
 347           n_remaining = length args - length bndrs
 348
 349           ok bndr (Var arg) = bndr == arg
 350           ok bndr other     = False
 351
 352           -- we can't eta reduce something which must be saturated.
 353           ok_to_eta_reduce (Var f)
 354                  = case idFlavour f of
 355                       PrimOpId op  -> False
 356                       DataConId dc -> False
 357                       other        -> True
 358           ok_to_eta_reduce _ = False --safe. ToDo: generalise
 359
 360     eta (Let bind@(NonRec b r) body)
 361         | not (any (`elemVarSet` fvs) bndrs)
 362                  = case eta body of
 363                         Just e -> Just (Let bind e)
 364                         Nothing -> Nothing
 365         where fvs = exprFreeVars r
 366
 367     eta _ = Nothing
 368
 369 deLam expr = returnUs expr
 370
 371 -- ---------------------------------------------------------------------------
 372 -- Precipitating the floating bindings
 373 -- ---------------------------------------------------------------------------
 374
 375 mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
 376 mkBinds []     body = returnUs body
 377 mkBinds (b:bs) body
 378   = deLam body          `thenUs` \ body' ->
 379     go (b:bs) body'
 380   where
 381     go []     body = returnUs body
 382     go (b:bs) body = go bs body         `thenUs` \ body' ->
 383                      mkBind  b body'
 384
 385 -- body can't be Lam
 386 mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
 387
 388 mkBind (NonRecF bndr rhs dem floats) body
 389 #ifdef DEBUG
 390   -- We shouldn't get let or case of the form v=w
 391   = if exprIsTrivial rhs
 392         then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
 393              (mk_let bndr rhs dem floats body)
 394         else mk_let bndr rhs dem floats body
 395
 396 mk_let bndr rhs dem floats body
 397 #endif
 398   | isUnLiftedType bndr_rep_ty
 399   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 400     mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
 401
 402   | is_whnf
 403   = if is_strict then
 404         -- Strict let with WHNF rhs
 405         mkBinds floats $
 406         Let (NonRec bndr rhs) body
 407     else
 408         -- Lazy let with WHNF rhs; float until we find a strict binding
 409         let
 410             (floats_out, floats_in) = splitFloats floats
 411         in
 412         mkBinds floats_in rhs   `thenUs` \ new_rhs ->
 413         mkBinds floats_out $
 414         Let (NonRec bndr new_rhs) body
 415
 416   | otherwise   -- Not WHNF
 417   = if is_strict then
 418         -- Strict let with non-WHNF rhs
 419         mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
 420     else
 421         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 422         mkBinds floats rhs              `thenUs` \ new_rhs ->
 423         returnUs (Let (NonRec bndr new_rhs) body)
 424
 425   where
 426     bndr_rep_ty = repType (idType bndr)
 427     is_strict   = isStrictDem dem
 428     is_whnf     = exprIsValue rhs
 429
 430 splitFloats fs@(NonRecF _ _ dem _ : _)
 431   | isStrictDem dem = ([], fs)
 432
 433 splitFloats (f : fs) = case splitFloats fs of
 434                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 435
 436 splitFloats [] = ([], [])
 437
 438 -- -----------------------------------------------------------------------------
 439 -- Demands
 440 -- -----------------------------------------------------------------------------
 441
 442 data RhsDemand
 443      = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
 444                    isOnceDem   :: Bool   -- True => used at most once
 445                  }
 446
 447 mkDem :: Demand -> Bool -> RhsDemand
 448 mkDem strict once = RhsDemand (isStrict strict) once
 449
 450 mkDemTy :: Demand -> Type -> RhsDemand
 451 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
 452
 453 isOnceTy :: Type -> Bool
 454 isOnceTy ty
 455   =
 456 #ifdef USMANY
 457     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 458 #endif
 459     once
 460   where
 461     u = uaUTy ty
 462     once | u == usOnce  = True
 463          | u == usMany  = False
 464          | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
 465
 466 bdrDem :: Id -> RhsDemand
 467 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
 468
 469 safeDem, onceDem :: RhsDemand
 470 safeDem = RhsDemand False False  -- always safe to use this
 471 onceDem = RhsDemand False True   -- used at most once
 472 \end{code}