compiler/stgSyn/CoreToStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[CoreToStg]{Converts Core to STG Syntax}
   5
   6 And, as we have the info in hand, we may convert some lets to
   7 let-no-escapes.
   8
   9 \begin{code}
  10 module CoreToStg ( coreToStg, coreExprToStg ) where
  11
  12 #include "HsVersions.h"
  13
  14 import CoreSyn
  15 import CoreUtils        ( rhsIsStatic, manifestArity, exprType, findDefault )
  16 import StgSyn
  17
  18 import Type
  19 import TyCon
  20 import Id
  21 import Var              ( Var, globalIdDetails, idType )
  22 import IdInfo
  23 import DataCon
  24 import CostCentre       ( noCCS )
  25 import VarSet
  26 import VarEnv
  27 import Maybes           ( maybeToBool )
  28 import Name             ( getOccName, isExternalName, nameOccName )
  29 import OccName          ( occNameString, occNameFS )
  30 import BasicTypes       ( Arity )
  31 import Module
  32 import Outputable
  33 import MonadUtils
  34 import FastString
  35 import Util
  36 \end{code}
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection[live-vs-free-doc]{Documentation}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 (There is other relevant documentation in codeGen/CgLetNoEscape.)
  45
  46 The actual Stg datatype is decorated with {\em live variable}
  47 information, as well as {\em free variable} information.  The two are
  48 {\em not} the same.  Liveness is an operational property rather than a
  49 semantic one.  A variable is live at a particular execution point if
  50 it can be referred to {\em directly} again.  In particular, a dead
  51 variable's stack slot (if it has one):
  52 \begin{enumerate}
  53 \item
  54 should be stubbed to avoid space leaks, and
  55 \item
  56 may be reused for something else.
  57 \end{enumerate}
  58
  59 There ought to be a better way to say this.  Here are some examples:
  60 \begin{verbatim}
  61         let v = [q] \[x] -> e
  62         in
  63         ...v...  (but no q's)
  64 \end{verbatim}
  65
  66 Just after the `in', v is live, but q is dead.  If the whole of that
  67 let expression was enclosed in a case expression, thus:
  68 \begin{verbatim}
  69         case (let v = [q] \[x] -> e in ...v...) of
  70                 alts[...q...]
  71 \end{verbatim}
  72 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
  73 we'll return later to the @alts@ and need it.
  74
  75 Let-no-escapes make this a bit more interesting:
  76 \begin{verbatim}
  77         let-no-escape v = [q] \ [x] -> e
  78         in
  79         ...v...
  80 \end{verbatim}
  81 Here, @q@ is still live at the `in', because @v@ is represented not by
  82 a closure but by the current stack state.  In other words, if @v@ is
  83 live then so is @q@.  Furthermore, if @e@ mentions an enclosing
  84 let-no-escaped variable, then {\em its} free variables are also live
  85 if @v@ is.
  86
  87 %************************************************************************
  88 %*                                                                      *
  89 \subsection[caf-info]{Collecting live CAF info}
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 In this pass we also collect information on which CAFs are live for
  94 constructing SRTs (see SRT.lhs).
  95
  96 A top-level Id has CafInfo, which is
  97
  98         - MayHaveCafRefs, if it may refer indirectly to
  99           one or more CAFs, or
 100         - NoCafRefs if it definitely doesn't
 101
 102 The CafInfo has already been calculated during the CoreTidy pass.
 103
 104 During CoreToStg, we then pin onto each binding and case expression, a
 105 list of Ids which represents the "live" CAFs at that point.  The meaning
 106 of "live" here is the same as for live variables, see above (which is
 107 why it's convenient to collect CAF information here rather than elsewhere).
 108
 109 The later SRT pass takes these lists of Ids and uses them to construct
 110 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
 111 pairs.
 112
 113
 114 Interaction of let-no-escape with SRTs   [Sept 01]
 115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 116 Consider
 117
 118         let-no-escape x = ...caf1...caf2...
 119         in
 120         ...x...x...x...
 121
 122 where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
 123 build SRTs just as if x's defn was inlined at each call site, and
 124 that means that x's CAF refs get duplicated in the overall SRT.
 125
 126 This is unlike ordinary lets, in which the CAF refs are not duplicated.
 127
 128 We could fix this loss of (static) sharing by making a sort of pseudo-closure
 129 for x, solely to put in the SRTs lower down.
 130
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 \begin{code}
 139 coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
 140 coreToStg this_pkg pgm
 141   = return pgm'
 142   where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
 143
 144 coreExprToStg :: CoreExpr -> StgExpr
 145 coreExprToStg expr
 146   = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
 147
 148
 149 coreTopBindsToStg
 150     :: PackageId
 151     -> IdEnv HowBound           -- environment for the bindings
 152     -> [CoreBind]
 153     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 154
 155 coreTopBindsToStg _        env [] = (env, emptyFVInfo, [])
 156 coreTopBindsToStg this_pkg env (b:bs)
 157   = (env2, fvs2, b':bs')
 158   where
 159         -- env accumulates down the list of binds, fvs accumulates upwards
 160         (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
 161         (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
 162
 163
 164 coreTopBindToStg
 165         :: PackageId
 166         -> IdEnv HowBound
 167         -> FreeVarsInfo         -- Info about the body
 168         -> CoreBind
 169         -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 170
 171 coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
 172   = let
 173         env'      = extendVarEnv env id how_bound
 174         how_bound = LetBound TopLet $! manifestArity rhs
 175
 176         (stg_rhs, fvs') =
 177             initLne env $ do
 178               (stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
 179               return (stg_rhs, fvs')
 180
 181         bind = StgNonRec id stg_rhs
 182     in
 183     ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext (sLit "rhs:")) <+> ppr rhs $$ (ptext (sLit "stg_rhs:"))<+> ppr stg_rhs $$ (ptext (sLit "Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext (sLit "STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
 184     ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind)
 185 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
 186     (env', fvs' `unionFVInfo` body_fvs, bind)
 187
 188 coreTopBindToStg this_pkg env body_fvs (Rec pairs)
 189   = let
 190         (binders, rhss) = unzip pairs
 191
 192         extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
 193                      | (b, rhs) <- pairs ]
 194         env' = extendVarEnvList env extra_env'
 195
 196         (stg_rhss, fvs')
 197           = initLne env' $ do
 198                (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
 199                let fvs' = unionFVInfos fvss'
 200                return (stg_rhss, fvs')
 201
 202         bind = StgRec (zip binders stg_rhss)
 203     in
 204     ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
 205     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
 206     (env', fvs' `unionFVInfo` body_fvs, bind)
 207
 208 -- Assertion helper: this checks that the CafInfo on the Id matches
 209 -- what CoreToStg has figured out about the binding's SRT.  The
 210 -- CafInfo will be exact in all cases except when CorePrep has
 211 -- floated out a binding, in which case it will be approximate.
 212 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
 213 consistentCafInfo id bind
 214   | occNameFS (nameOccName (idName id)) == fsLit "sat"
 215   = safe
 216   | otherwise
 217   = WARN (not exact, ppr id) safe
 218   where
 219         safe  = id_marked_caffy || not binding_is_caffy
 220         exact = id_marked_caffy == binding_is_caffy
 221         id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
 222         binding_is_caffy = stgBindHasCafRefs bind
 223 \end{code}
 224
 225 \begin{code}
 226 coreToTopStgRhs
 227         :: PackageId
 228         -> FreeVarsInfo         -- Free var info for the scope of the binding
 229         -> (Id,CoreExpr)
 230         -> LneM (StgRhs, FreeVarsInfo)
 231
 232 coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) = do
 233     (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
 234     lv_info <- freeVarsToLiveVars rhs_fvs
 235     return (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
 236   where
 237     bndr_info = lookupFVInfo scope_fv_info bndr
 238     is_static = rhsIsStatic this_pkg rhs
 239
 240 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
 241         -> StgRhs
 242
 243 mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
 244   = ASSERT( is_static )
 245     StgRhsClosure noCCS binder_info
 246                   (getFVs rhs_fvs)
 247                   ReEntrant
 248                   srt
 249                   bndrs body
 250
 251 mkTopStgRhs is_static _ _ _ (StgConApp con args)
 252   | is_static    -- StgConApps can be updatable (see isCrossDllConApp)
 253   = StgRhsCon noCCS con args
 254
 255 mkTopStgRhs is_static rhs_fvs srt binder_info rhs
 256   = ASSERT2( not is_static, ppr rhs )
 257     StgRhsClosure noCCS binder_info
 258                   (getFVs rhs_fvs)
 259                   Updatable
 260                   srt
 261                   [] rhs
 262 \end{code}
 263
 264
 265 -- ---------------------------------------------------------------------------
 266 -- Expressions
 267 -- ---------------------------------------------------------------------------
 268
 269 \begin{code}
 270 coreToStgExpr
 271         :: CoreExpr
 272         -> LneM (StgExpr,       -- Decorated STG expr
 273                  FreeVarsInfo,  -- Its free vars (NB free, not live)
 274                  EscVarsSet)    -- Its escapees, a subset of its free vars;
 275                                 -- also a subset of the domain of the envt
 276                                 -- because we are only interested in the escapees
 277                                 -- for vars which might be turned into
 278                                 -- let-no-escaped ones.
 279 \end{code}
 280
 281 The second and third components can be derived in a simple bottom up pass, not
 282 dependent on any decisions about which variables will be let-no-escaped or
 283 not.  The first component, that is, the decorated expression, may then depend
 284 on these components, but it in turn is not scrutinised as the basis for any
 285 decisions.  Hence no black holes.
 286
 287 \begin{code}
 288 coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
 289 coreToStgExpr (Var v) = coreToStgApp Nothing v []
 290
 291 coreToStgExpr expr@(App _ _)
 292   = coreToStgApp Nothing f args
 293   where
 294     (f, args) = myCollectArgs expr
 295
 296 coreToStgExpr expr@(Lam _ _)
 297   = let
 298         (args, body) = myCollectBinders expr
 299         args'        = filterStgBinders args
 300     in
 301     extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
 302     (body, body_fvs, body_escs) <- coreToStgExpr body
 303     let
 304         fvs             = args' `minusFVBinders` body_fvs
 305         escs            = body_escs `delVarSetList` args'
 306         result_expr | null args' = body
 307                     | otherwise  = StgLam (exprType expr) args' body
 308
 309     return (result_expr, fvs, escs)
 310
 311 coreToStgExpr (Note (SCC cc) expr) = do
 312     (expr2, fvs, escs) <- coreToStgExpr expr
 313     return (StgSCC cc expr2, fvs, escs)
 314
 315 coreToStgExpr (Case (Var id) _bndr _ty [(DEFAULT,[],expr)])
 316   | Just (TickBox m n) <- isTickBoxOp_maybe id = do
 317     (expr2, fvs, escs) <- coreToStgExpr expr
 318     return (StgTick m n expr2, fvs, escs)
 319
 320 coreToStgExpr (Note _ expr)
 321   = coreToStgExpr expr
 322
 323 coreToStgExpr (Cast expr _)
 324   = coreToStgExpr expr
 325
 326 -- Cases require a little more real work.
 327
 328 coreToStgExpr (Case scrut bndr _ alts) = do
 329     (alts2, alts_fvs, alts_escs)
 330        <- extendVarEnvLne [(bndr, LambdaBound)] $ do
 331             (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
 332             return ( alts2,
 333                      unionFVInfos fvs_s,
 334                      unionVarSets escs_s )
 335     let
 336         -- Determine whether the default binder is dead or not
 337         -- This helps the code generator to avoid generating an assignment
 338         -- for the case binder (is extremely rare cases) ToDo: remove.
 339         bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
 340               | otherwise                       = bndr `setIdOccInfo` IAmDead
 341
 342         -- Don't consider the default binder as being 'live in alts',
 343         -- since this is from the point of view of the case expr, where
 344         -- the default binder is not free.
 345         alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
 346         alts_escs_wo_bndr = alts_escs `delVarSet` bndr
 347
 348     alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
 349
 350         -- We tell the scrutinee that everything
 351         -- live in the alts is live in it, too.
 352     (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
 353        <- setVarsLiveInCont alts_lv_info $ do
 354             (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
 355             scrut_lv_info <- freeVarsToLiveVars scrut_fvs
 356             return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
 357
 358     return (
 359       StgCase scrut2 (getLiveVars scrut_lv_info)
 360                      (getLiveVars alts_lv_info)
 361                      bndr'
 362                      (mkSRT alts_lv_info)
 363                      (mkStgAltType bndr alts)
 364                      alts2,
 365       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
 366       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
 367                 -- You might think we should have scrut_escs, not
 368                 -- (getFVSet scrut_fvs), but actually we can't call, and
 369                 -- then return from, a let-no-escape thing.
 370       )
 371   where
 372     vars_alt (con, binders, rhs)
 373       = let     -- Remove type variables
 374             binders' = filterStgBinders binders
 375         in
 376         extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
 377         (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
 378         let
 379                 -- Records whether each param is used in the RHS
 380             good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
 381
 382         return ( (con, binders', good_use_mask, rhs2),
 383                  binders' `minusFVBinders` rhs_fvs,
 384                  rhs_escs `delVarSetList` binders' )
 385                 -- ToDo: remove the delVarSet;
 386                 -- since escs won't include any of these binders
 387 \end{code}
 388
 389 Lets not only take quite a bit of work, but this is where we convert
 390 then to let-no-escapes, if we wish.
 391
 392 (Meanwhile, we don't expect to see let-no-escapes...)
 393 \begin{code}
 394 coreToStgExpr (Let bind body) = do
 395     (new_let, fvs, escs, _)
 396        <- mfix (\ ~(_, _, _, no_binder_escapes) ->
 397              coreToStgLet no_binder_escapes bind body
 398           )
 399
 400     return (new_let, fvs, escs)
 401
 402 coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
 403 \end{code}
 404
 405 \begin{code}
 406 mkStgAltType :: Id -> [CoreAlt] -> AltType
 407 mkStgAltType bndr alts
 408   = case splitTyConApp_maybe (repType (idType bndr)) of
 409         Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
 410                     | isUnLiftedTyCon tc     -> PrimAlt tc
 411                     | isHiBootTyCon tc       -> look_for_better_tycon
 412                     | isAlgTyCon tc          -> AlgAlt tc
 413                     | otherwise              -> ASSERT( _is_poly_alt_tycon tc )
 414                                                 PolyAlt
 415         Nothing                              -> PolyAlt
 416
 417   where
 418    _is_poly_alt_tycon tc
 419         =  isFunTyCon tc
 420         || isPrimTyCon tc   -- "Any" is lifted but primitive
 421         || isOpenTyCon tc   -- Type family; e.g. arising from strict
 422                             -- function application where argument has a
 423                             -- type-family type
 424
 425    -- Sometimes, the TyCon is a HiBootTyCon which may not have any
 426    -- constructors inside it.  Then we can get a better TyCon by
 427    -- grabbing the one from a constructor alternative
 428    -- if one exists.
 429    look_for_better_tycon
 430         | ((DataAlt con, _, _) : _) <- data_alts =
 431                 AlgAlt (dataConTyCon con)
 432         | otherwise =
 433                 ASSERT(null data_alts)
 434                 PolyAlt
 435         where
 436                 (data_alts, _deflt) = findDefault alts
 437 \end{code}
 438
 439
 440 -- ---------------------------------------------------------------------------
 441 -- Applications
 442 -- ---------------------------------------------------------------------------
 443
 444 \begin{code}
 445 coreToStgApp
 446          :: Maybe UpdateFlag            -- Just upd <=> this application is
 447                                         -- the rhs of a thunk binding
 448                                         --      x = [...] \upd [] -> the_app
 449                                         -- with specified update flag
 450         -> Id                           -- Function
 451         -> [CoreArg]                    -- Arguments
 452         -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
 453
 454
 455 coreToStgApp _ f args = do
 456     (args', args_fvs) <- coreToStgArgs args
 457     how_bound <- lookupVarLne f
 458
 459     let
 460         n_val_args       = valArgCount args
 461         not_letrec_bound = not (isLetBound how_bound)
 462         fun_fvs = singletonFVInfo f how_bound fun_occ
 463             -- e.g. (f :: a -> int) (x :: a)
 464             -- Here the free variables are "f", "x" AND the type variable "a"
 465             -- coreToStgArgs will deal with the arguments recursively
 466
 467         -- Mostly, the arity info of a function is in the fn's IdInfo
 468         -- But new bindings introduced by CoreSat may not have no
 469         -- arity info; it would do us no good anyway.  For example:
 470         --      let f = \ab -> e in f
 471         -- No point in having correct arity info for f!
 472         -- Hence the hasArity stuff below.
 473         -- NB: f_arity is only consulted for LetBound things
 474         f_arity   = stgArity f how_bound
 475         saturated = f_arity <= n_val_args
 476
 477         fun_occ
 478          | not_letrec_bound         = noBinderInfo      -- Uninteresting variable
 479          | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
 480          | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk
 481
 482         fun_escs
 483          | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
 484          | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
 485                                                 -- saturated call doesn't escape
 486                                                 -- (let-no-escape applies to 'thunks' too)
 487
 488          | otherwise         = unitVarSet f     -- Inexact application; it does escape
 489
 490         -- At the moment of the call:
 491
 492         --  either the function is *not* let-no-escaped, in which case
 493         --         nothing is live except live_in_cont
 494         --      or the function *is* let-no-escaped in which case the
 495         --         variables it uses are live, but still the function
 496         --         itself is not.  PS.  In this case, the function's
 497         --         live vars should already include those of the
 498         --         continuation, but it does no harm to just union the
 499         --         two regardless.
 500
 501         res_ty = exprType (mkApps (Var f) args)
 502         app = case globalIdDetails f of
 503                 DataConWorkId dc | saturated -> StgConApp dc args'
 504                 PrimOpId op      -> ASSERT( saturated )
 505                                     StgOpApp (StgPrimOp op) args' res_ty
 506                 FCallId call     -> ASSERT( saturated )
 507                                     StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
 508                 TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
 509                 _other           -> StgApp f args'
 510
 511     return (
 512         app,
 513         fun_fvs  `unionFVInfo` args_fvs,
 514         fun_escs `unionVarSet` (getFVSet args_fvs)
 515                                 -- All the free vars of the args are disqualified
 516                                 -- from being let-no-escaped.
 517      )
 518
 519
 520
 521 -- ---------------------------------------------------------------------------
 522 -- Argument lists
 523 -- This is the guy that turns applications into A-normal form
 524 -- ---------------------------------------------------------------------------
 525
 526 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
 527 coreToStgArgs []
 528   = return ([], emptyFVInfo)
 529
 530 coreToStgArgs (Type _ : args) = do     -- Type argument
 531     (args', fvs) <- coreToStgArgs args
 532     return (args', fvs)
 533
 534 coreToStgArgs (arg : args) = do         -- Non-type argument
 535     (stg_args, args_fvs) <- coreToStgArgs args
 536     (arg', arg_fvs, _escs) <- coreToStgExpr arg
 537     let
 538         fvs = args_fvs `unionFVInfo` arg_fvs
 539         stg_arg = case arg' of
 540                        StgApp v []      -> StgVarArg v
 541                        StgConApp con [] -> StgVarArg (dataConWorkId con)
 542                        StgLit lit       -> StgLitArg lit
 543                        _                -> pprPanic "coreToStgArgs" (ppr arg)
 544
 545         -- WARNING: what if we have an argument like (v `cast` co)
 546         --          where 'co' changes the representation type?
 547         --          (This really only happens if co is unsafe.)
 548         -- Then all the getArgAmode stuff in CgBindery will set the
 549         -- cg_rep of the CgIdInfo based on the type of v, rather
 550         -- than the type of 'co'.
 551         -- This matters particularly when the function is a primop
 552         -- or foreign call.
 553         -- Wanted: a better solution than this hacky warning
 554     let
 555         arg_ty = exprType arg
 556         stg_arg_ty = stgArgType stg_arg
 557         bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
 558                 || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
 559         -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
 560         -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
 561         -- we can treat an unlifted value as lifted.  But the other way round
 562         -- we complain.
 563         -- We also want to check if a pointer is cast to a non-ptr etc
 564
 565     WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
 566      return (stg_arg : stg_args, fvs)
 567
 568
 569 -- ---------------------------------------------------------------------------
 570 -- The magic for lets:
 571 -- ---------------------------------------------------------------------------
 572
 573 coreToStgLet
 574          :: Bool        -- True <=> yes, we are let-no-escaping this let
 575          -> CoreBind    -- bindings
 576          -> CoreExpr    -- body
 577          -> LneM (StgExpr,      -- new let
 578                   FreeVarsInfo, -- variables free in the whole let
 579                   EscVarsSet,   -- variables that escape from the whole let
 580                   Bool)         -- True <=> none of the binders in the bindings
 581                                 -- is among the escaping vars
 582
 583 coreToStgLet let_no_escape bind body = do
 584     (bind2, bind_fvs, bind_escs, bind_lvs,
 585      body2, body_fvs, body_escs, body_lvs)
 586        <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
 587
 588           -- Do the bindings, setting live_in_cont to empty if
 589           -- we ain't in a let-no-escape world
 590           live_in_cont <- getVarsLiveInCont
 591           ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
 592                 <- setVarsLiveInCont (if let_no_escape
 593                                           then live_in_cont
 594                                           else emptyLiveInfo)
 595                                      (vars_bind rec_body_fvs bind)
 596
 597           -- Do the body
 598           extendVarEnvLne env_ext $ do
 599              (body2, body_fvs, body_escs) <- coreToStgExpr body
 600              body_lv_info <- freeVarsToLiveVars body_fvs
 601
 602              return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
 603                      body2, body_fvs, body_escs, getLiveVars body_lv_info)
 604
 605
 606         -- Compute the new let-expression
 607     let
 608         new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
 609                 | otherwise     = StgLet bind2 body2
 610
 611         free_in_whole_let
 612           = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
 613
 614         live_in_whole_let
 615           = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
 616
 617         real_bind_escs = if let_no_escape then
 618                             bind_escs
 619                          else
 620                             getFVSet bind_fvs
 621                             -- Everything escapes which is free in the bindings
 622
 623         let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
 624
 625         all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
 626                                                         -- this let(rec)
 627
 628         no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
 629
 630         -- Debugging code as requested by Andrew Kennedy
 631         checked_no_binder_escapes
 632                 | debugIsOn && not no_binder_escapes && any is_join_var binders
 633                 = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
 634                   False
 635                 | otherwise = no_binder_escapes
 636
 637                 -- Mustn't depend on the passed-in let_no_escape flag, since
 638                 -- no_binder_escapes is used by the caller to derive the flag!
 639     return (
 640         new_let,
 641         free_in_whole_let,
 642         let_escs,
 643         checked_no_binder_escapes
 644       )
 645   where
 646     set_of_binders = mkVarSet binders
 647     binders        = bindersOf bind
 648
 649     mk_binding bind_lv_info binder rhs
 650         = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
 651         where
 652            live_vars | let_no_escape = addLiveVar bind_lv_info binder
 653                      | otherwise     = unitLiveVar binder
 654                 -- c.f. the invariant on NestedLet
 655
 656     vars_bind :: FreeVarsInfo           -- Free var info for body of binding
 657               -> CoreBind
 658               -> LneM (StgBinding,
 659                        FreeVarsInfo,
 660                        EscVarsSet,        -- free vars; escapee vars
 661                        LiveInfo,          -- Vars and CAFs live in binding
 662                        [(Id, HowBound)])  -- extension to environment
 663
 664
 665     vars_bind body_fvs (NonRec binder rhs) = do
 666         (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
 667         let
 668             env_ext_item = mk_binding bind_lv_info binder rhs
 669
 670         return (StgNonRec binder rhs2,
 671                 bind_fvs, escs, bind_lv_info, [env_ext_item])
 672
 673
 674     vars_bind body_fvs (Rec pairs)
 675       = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
 676            let
 677                 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
 678                 binders = map fst pairs
 679                 env_ext = [ mk_binding bind_lv_info b rhs
 680                           | (b,rhs) <- pairs ]
 681            in
 682            extendVarEnvLne env_ext $ do
 683               (rhss2, fvss, lv_infos, escss)
 684                      <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
 685               let
 686                         bind_fvs = unionFVInfos fvss
 687                         bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
 688                         escs     = unionVarSets escss
 689
 690               return (StgRec (binders `zip` rhss2),
 691                       bind_fvs, escs, bind_lv_info, env_ext)
 692
 693
 694 is_join_var :: Id -> Bool
 695 -- A hack (used only for compiler debuggging) to tell if
 696 -- a variable started life as a join point ($j)
 697 is_join_var j = occNameString (getOccName j) == "$j"
 698 \end{code}
 699
 700 \begin{code}
 701 coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
 702              -> [Id]
 703              -> (Id,CoreExpr)
 704              -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
 705
 706 coreToStgRhs scope_fv_info binders (bndr, rhs) = do
 707     (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
 708     lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
 709     return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
 710             rhs_fvs, lv_info, rhs_escs)
 711   where
 712     bndr_info = lookupFVInfo scope_fv_info bndr
 713
 714 mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
 715
 716 mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
 717
 718 mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
 719   = StgRhsClosure noCCS binder_info
 720                   (getFVs rhs_fvs)
 721                   ReEntrant
 722                   srt bndrs body
 723
 724 mkStgRhs rhs_fvs srt binder_info rhs
 725   = StgRhsClosure noCCS binder_info
 726                   (getFVs rhs_fvs)
 727                   upd_flag srt [] rhs
 728   where
 729    upd_flag = Updatable
 730   {-
 731     SDM: disabled.  Eval/Apply can't handle functions with arity zero very
 732     well; and making these into simple non-updatable thunks breaks other
 733     assumptions (namely that they will be entered only once).
 734
 735     upd_flag | isPAP env rhs  = ReEntrant
 736              | otherwise      = Updatable
 737   -}
 738
 739 {- ToDo:
 740           upd = if isOnceDem dem
 741                     then (if isNotTop toplev
 742                             then SingleEntry    -- HA!  Paydirt for "dem"
 743                             else
 744 #ifdef DEBUG
 745                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 746 #endif
 747                      Updatable)
 748                 else Updatable
 749         -- For now we forbid SingleEntry CAFs; they tickle the
 750         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 751         -- and I don't understand why.  There's only one SE_CAF (well,
 752         -- only one that tickled a great gaping bug in an earlier attempt
 753         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 754         -- specifically Main.lvl6 in spectral/cryptarithm2.
 755         -- So no great loss.  KSW 2000-07.
 756 -}
 757 \end{code}
 758
 759 Detect thunks which will reduce immediately to PAPs, and make them
 760 non-updatable.  This has several advantages:
 761
 762         - the non-updatable thunk behaves exactly like the PAP,
 763
 764         - the thunk is more efficient to enter, because it is
 765           specialised to the task.
 766
 767         - we save one update frame, one stg_update_PAP, one update
 768           and lots of PAP_enters.
 769
 770         - in the case where the thunk is top-level, we save building
 771           a black hole and futhermore the thunk isn't considered to
 772           be a CAF any more, so it doesn't appear in any SRTs.
 773
 774 We do it here, because the arity information is accurate, and we need
 775 to do it before the SRT pass to save the SRT entries associated with
 776 any top-level PAPs.
 777
 778 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
 779                           where
 780                             arity = stgArity f (lookupBinding env f)
 781 isPAP env _               = False
 782
 783
 784 %************************************************************************
 785 %*                                                                      *
 786 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
 787 %*                                                                      *
 788 %************************************************************************
 789
 790 There's a lot of stuff to pass around, so we use this @LneM@ monad to
 791 help.  All the stuff here is only passed *down*.
 792
 793 \begin{code}
 794 newtype LneM a = LneM
 795     { unLneM :: IdEnv HowBound
 796              -> LiveInfo                -- Vars and CAFs live in continuation
 797              -> a
 798     }
 799
 800 type LiveInfo = (StgLiveVars,   -- Dynamic live variables;
 801                                 -- i.e. ones with a nested (non-top-level) binding
 802                  CafSet)        -- Static live variables;
 803                                 -- i.e. top-level variables that are CAFs or refer to them
 804
 805 type EscVarsSet = IdSet
 806 type CafSet     = IdSet
 807
 808 data HowBound
 809   = ImportBound         -- Used only as a response to lookupBinding; never
 810                         -- exists in the range of the (IdEnv HowBound)
 811
 812   | LetBound            -- A let(rec) in this module
 813         LetInfo         -- Whether top level or nested
 814         Arity           -- Its arity (local Ids don't have arity info at this point)
 815
 816   | LambdaBound         -- Used for both lambda and case
 817
 818 data LetInfo
 819   = TopLet              -- top level things
 820   | NestedLet LiveInfo  -- For nested things, what is live if this
 821                         -- thing is live?  Invariant: the binder
 822                         -- itself is always a member of
 823                         -- the dynamic set of its own LiveInfo
 824
 825 isLetBound :: HowBound -> Bool
 826 isLetBound (LetBound _ _) = True
 827 isLetBound _              = False
 828
 829 topLevelBound :: HowBound -> Bool
 830 topLevelBound ImportBound         = True
 831 topLevelBound (LetBound TopLet _) = True
 832 topLevelBound _                   = False
 833 \end{code}
 834
 835 For a let(rec)-bound variable, x, we record LiveInfo, the set of
 836 variables that are live if x is live.  This LiveInfo comprises
 837         (a) dynamic live variables (ones with a non-top-level binding)
 838         (b) static live variabes (CAFs or things that refer to CAFs)
 839
 840 For "normal" variables (a) is just x alone.  If x is a let-no-escaped
 841 variable then x is represented by a code pointer and a stack pointer
 842 (well, one for each stack).  So all of the variables needed in the
 843 execution of x are live if x is, and are therefore recorded in the
 844 LetBound constructor; x itself *is* included.
 845
 846 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
 847 variables in it.
 848
 849 \begin{code}
 850 emptyLiveInfo :: LiveInfo
 851 emptyLiveInfo = (emptyVarSet,emptyVarSet)
 852
 853 unitLiveVar :: Id -> LiveInfo
 854 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
 855
 856 unitLiveCaf :: Id -> LiveInfo
 857 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
 858
 859 addLiveVar :: LiveInfo -> Id -> LiveInfo
 860 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
 861
 862 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
 863 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
 864
 865 mkSRT :: LiveInfo -> SRT
 866 mkSRT (_, cafs) = SRTEntries cafs
 867
 868 getLiveVars :: LiveInfo -> StgLiveVars
 869 getLiveVars (lvs, _) = lvs
 870 \end{code}
 871
 872
 873 The std monad functions:
 874 \begin{code}
 875 initLne :: IdEnv HowBound -> LneM a -> a
 876 initLne env m = unLneM m env emptyLiveInfo
 877
 878
 879
 880 {-# INLINE thenLne #-}
 881 {-# INLINE returnLne #-}
 882
 883 returnLne :: a -> LneM a
 884 returnLne e = LneM $ \_ _ -> e
 885
 886 thenLne :: LneM a -> (a -> LneM b) -> LneM b
 887 thenLne m k = LneM $ \env lvs_cont
 888   -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
 889
 890 instance Monad LneM where
 891     return = returnLne
 892     (>>=)  = thenLne
 893
 894 instance MonadFix LneM where
 895     mfix expr = LneM $ \env lvs_cont ->
 896                        let result = unLneM (expr result) env lvs_cont
 897                        in  result
 898 \end{code}
 899
 900 Functions specific to this monad:
 901
 902 \begin{code}
 903 getVarsLiveInCont :: LneM LiveInfo
 904 getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
 905
 906 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
 907 setVarsLiveInCont new_lvs_cont expr
 908    =    LneM $   \env _lvs_cont
 909    -> unLneM expr env new_lvs_cont
 910
 911 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
 912 extendVarEnvLne ids_w_howbound expr
 913    =    LneM $   \env lvs_cont
 914    -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
 915
 916 lookupVarLne :: Id -> LneM HowBound
 917 lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
 918
 919 lookupBinding :: IdEnv HowBound -> Id -> HowBound
 920 lookupBinding env v = case lookupVarEnv env v of
 921                         Just xx -> xx
 922                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 923
 924
 925 -- The result of lookupLiveVarsForSet, a set of live variables, is
 926 -- only ever tacked onto a decorated expression. It is never used as
 927 -- the basis of a control decision, which might give a black hole.
 928
 929 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
 930 freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
 931  where
 932   freeVarsToLiveVars' _env live_in_cont = live_info
 933    where
 934     live_info    = foldr unionLiveInfo live_in_cont lvs_from_fvs
 935     lvs_from_fvs = map do_one (allFreeIds fvs)
 936
 937     do_one (v, how_bound)
 938       = case how_bound of
 939           ImportBound                     -> unitLiveCaf v      -- Only CAF imports are
 940                                                                 -- recorded in fvs
 941           LetBound TopLet _
 942                 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
 943                 | otherwise                    -> emptyLiveInfo
 944
 945           LetBound (NestedLet lvs) _      -> lvs        -- lvs already contains v
 946                                                         -- (see the invariant on NestedLet)
 947
 948           _lambda_or_case_binding         -> unitLiveVar v      -- Bound by lambda or case
 949 \end{code}
 950
 951 %************************************************************************
 952 %*                                                                      *
 953 \subsection[Free-var info]{Free variable information}
 954 %*                                                                      *
 955 %************************************************************************
 956
 957 \begin{code}
 958 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
 959         -- The Var is so we can gather up the free variables
 960         -- as a set.
 961         --
 962         -- The HowBound info just saves repeated lookups;
 963         -- we look up just once when we encounter the occurrence.
 964         -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
 965         --            Imported Ids without CAF refs are simply
 966         --            not put in the FreeVarsInfo for an expression.
 967         --            See singletonFVInfo and freeVarsToLiveVars
 968         --
 969         -- StgBinderInfo records how it occurs; notably, we
 970         -- are interested in whether it only occurs in saturated
 971         -- applications, because then we don't need to build a
 972         -- curried version.
 973         -- If f is mapped to noBinderInfo, that means
 974         -- that f *is* mentioned (else it wouldn't be in the
 975         -- IdEnv at all), but perhaps in an unsaturated applications.
 976         --
 977         -- All case/lambda-bound things are also mapped to
 978         -- noBinderInfo, since we aren't interested in their
 979         -- occurence info.
 980         --
 981         -- For ILX we track free var info for type variables too;
 982         -- hence VarEnv not IdEnv
 983 \end{code}
 984
 985 \begin{code}
 986 emptyFVInfo :: FreeVarsInfo
 987 emptyFVInfo = emptyVarEnv
 988
 989 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
 990 -- Don't record non-CAF imports at all, to keep free-var sets small
 991 singletonFVInfo id ImportBound info
 992    | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
 993    | otherwise                     = emptyVarEnv
 994 singletonFVInfo id how_bound info  = unitVarEnv id (id, how_bound, info)
 995
 996 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
 997 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
 998
 999 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1000 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1001
1002 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1003 minusFVBinders vs fv = foldr minusFVBinder fv vs
1004
1005 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1006 minusFVBinder v fv = fv `delVarEnv` v
1007         -- When removing a binder, remember to add its type variables
1008         -- c.f. CoreFVs.delBinderFV
1009
1010 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1011 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1012
1013 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1014 -- Find how the given Id is used.
1015 -- Externally visible things may be used any old how
1016 lookupFVInfo fvs id
1017   | isExternalName (idName id) = noBinderInfo
1018   | otherwise = case lookupVarEnv fvs id of
1019                         Nothing         -> noBinderInfo
1020                         Just (_,_,info) -> info
1021
1022 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)]   -- Both top level and non-top-level Ids
1023 allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
1024       where
1025         ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
1026
1027 -- Non-top-level things only, both type variables and ids
1028 getFVs :: FreeVarsInfo -> [Var]
1029 getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
1030                     not (topLevelBound how_bound) ]
1031
1032 getFVSet :: FreeVarsInfo -> VarSet
1033 getFVSet fvs = mkVarSet (getFVs fvs)
1034
1035 plusFVInfo :: (Var, HowBound, StgBinderInfo)
1036            -> (Var, HowBound, StgBinderInfo)
1037            -> (Var, HowBound, StgBinderInfo)
1038 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1039   = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1040     (id1, hb1, combineStgBinderInfo info1 info2)
1041
1042 -- The HowBound info for a variable in the FVInfo should be consistent
1043 check_eq_how_bound :: HowBound -> HowBound -> Bool
1044 check_eq_how_bound ImportBound        ImportBound        = True
1045 check_eq_how_bound LambdaBound        LambdaBound        = True
1046 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1047 check_eq_how_bound _                  _                  = False
1048
1049 check_eq_li :: LetInfo -> LetInfo -> Bool
1050 check_eq_li (NestedLet _) (NestedLet _) = True
1051 check_eq_li TopLet        TopLet        = True
1052 check_eq_li _             _             = False
1053 \end{code}
1054
1055 Misc.
1056 \begin{code}
1057 filterStgBinders :: [Var] -> [Var]
1058 filterStgBinders bndrs = filter isId bndrs
1059 \end{code}
1060
1061
1062 \begin{code}
1063         -- Ignore all notes except SCC
1064 myCollectBinders :: Expr Var -> ([Var], Expr Var)
1065 myCollectBinders expr
1066   = go [] expr
1067   where
1068     go bs (Lam b e)          = go (b:bs) e
1069     go bs e@(Note (SCC _) _) = (reverse bs, e)
1070     go bs (Cast e _)         = go bs e
1071     go bs (Note _ e)         = go bs e
1072     go bs e                  = (reverse bs, e)
1073
1074 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1075         -- We assume that we only have variables
1076         -- in the function position by now
1077 myCollectArgs expr
1078   = go expr []
1079   where
1080     go (Var v)          as = (v, as)
1081     go (App f a) as        = go f (a:as)
1082     go (Note (SCC _) _) _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1083     go (Cast e _)       as = go e as
1084     go (Note _ e)       as = go e as
1085     go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1086 \end{code}
1087
1088 \begin{code}
1089 stgArity :: Id -> HowBound -> Arity
1090 stgArity _ (LetBound _ arity) = arity
1091 stgArity f ImportBound        = idArity f
1092 stgArity _ LambdaBound        = 0
1093 \end{code}