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