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