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