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