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