Commit a76b8e27 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Retab CoreToStg, and remove trailing whitespace

parent 2b64626e
......@@ -12,22 +12,22 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( exprType, findDefault )
import CoreArity ( manifestArity )
import CoreUtils ( exprType, findDefault )
import CoreArity ( manifestArity )
import StgSyn
import Type
import TyCon
import Id
import Var ( Var )
import Var ( Var )
import IdInfo
import DataCon
import CostCentre ( noCCS )
import CostCentre ( noCCS )
import VarSet
import VarEnv
import Maybes ( maybeToBool )
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import Maybes ( maybeToBool )
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
import Module
import Outputable
......@@ -35,13 +35,13 @@ import MonadUtils
import FastString
import Util
import ForeignCall
import PrimOp ( PrimCall(..) )
import PrimOp ( PrimCall(..) )
\end{code}
%************************************************************************
%* *
%* *
\subsection[live-vs-free-doc]{Documentation}
%* *
%* *
%************************************************************************
(There is other relevant documentation in codeGen/CgLetNoEscape.)
......@@ -61,25 +61,25 @@ may be reused for something else.
There ought to be a better way to say this. Here are some examples:
\begin{verbatim}
let v = [q] \[x] -> e
in
...v... (but no q's)
let v = [q] \[x] -> e
in
...v... (but no q's)
\end{verbatim}
Just after the `in', v is live, but q is dead. If the whole of that
Just after the `in', v is live, but q is dead. If the whole of that
let expression was enclosed in a case expression, thus:
\begin{verbatim}
case (let v = [q] \[x] -> e in ...v...) of
alts[...q...]
case (let v = [q] \[x] -> e in ...v...) of
alts[...q...]
\end{verbatim}
(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
we'll return later to the @alts@ and need it.
Let-no-escapes make this a bit more interesting:
\begin{verbatim}
let-no-escape v = [q] \ [x] -> e
in
...v...
let-no-escape v = [q] \ [x] -> e
in
...v...
\end{verbatim}
Here, @q@ is still live at the `in', because @v@ is represented not by
a closure but by the current stack state. In other words, if @v@ is
......@@ -88,19 +88,19 @@ let-no-escaped variable, then {\em its} free variables are also live
if @v@ is.
%************************************************************************
%* *
%* *
\subsection[caf-info]{Collecting live CAF info}
%* *
%* *
%************************************************************************
In this pass we also collect information on which CAFs are live for
constructing SRTs (see SRT.lhs).
In this pass we also collect information on which CAFs are live for
constructing SRTs (see SRT.lhs).
A top-level Id has CafInfo, which is
- MayHaveCafRefs, if it may refer indirectly to
one or more CAFs, or
- NoCafRefs if it definitely doesn't
- MayHaveCafRefs, if it may refer indirectly to
one or more CAFs, or
- NoCafRefs if it definitely doesn't
The CafInfo has already been calculated during the CoreTidy pass.
......@@ -118,11 +118,11 @@ Interaction of let-no-escape with SRTs [Sept 01]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
let-no-escape x = ...caf1...caf2...
in
...x...x...x...
let-no-escape x = ...caf1...caf2...
in
...x...x...x...
where caf1,caf2 are CAFs. Since x doesn't have a closure, we
where caf1,caf2 are CAFs. Since x doesn't have a closure, we
build SRTs just as if x's defn was inlined at each call site, and
that means that x's CAF refs get duplicated in the overall SRT.
......@@ -133,9 +133,9 @@ for x, solely to put in the SRTs lower down.
%************************************************************************
%* *
%* *
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
%* *
%* *
%************************************************************************
\begin{code}
......@@ -145,13 +145,13 @@ coreToStg this_pkg pgm
where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreExprToStg expr
= new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
coreTopBindsToStg
:: PackageId
-> IdEnv HowBound -- environment for the bindings
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
......@@ -159,30 +159,30 @@ coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
coreTopBindsToStg this_pkg env (b:bs)
= (env2, fvs2, b':bs')
where
-- Notice the mutually-recursive "knot" here:
-- env accumulates down the list of binds,
-- fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
-- Notice the mutually-recursive "knot" here:
-- env accumulates down the list of binds,
-- fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
coreTopBindToStg
:: PackageId
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
:: PackageId
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') =
initLne env $ do
(stg_rhs, fvs') =
initLne env $ do
(stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
return (stg_rhs, fvs')
bind = StgNonRec id stg_rhs
bind = StgNonRec id stg_rhs
in
ASSERT2(consistentCafInfo id bind, ppr id )
-- NB: previously the assertion printed 'rhs' and 'bind'
......@@ -193,20 +193,20 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
= ASSERT( not (null pairs) )
let
binders = map fst pairs
let
binders = map fst pairs
extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
(stg_rhss, fvs')
= initLne env' $ do
(stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
let fvs' = unionFVInfos fvss'
return (stg_rhss, fvs')
= initLne env' $ do
(stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
let fvs' = unionFVInfos fvss'
return (stg_rhss, fvs')
bind = StgRec (zip binders stg_rhss)
bind = StgRec (zip binders stg_rhss)
in
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
(env', fvs' `unionFVInfo` body_fvs, bind)
......@@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
= WARN( not (exact || is_sat_thing) , ppr id )
= WARN( not (exact || is_sat_thing) , ppr id )
safe
where
safe = id_marked_caffy || not binding_is_caffy
......@@ -230,10 +230,10 @@ consistentCafInfo id bind
\begin{code}
coreToTopStgRhs
:: PackageId
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
:: PackageId
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
......@@ -241,40 +241,40 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
; let stg_rhs = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) }
where
bndr_info = lookupFVInfo scope_fv_info bndr
-- It's vital that the arity on a top-level Id matches
-- the arity of the generated STG binding, else an importing
-- module will use the wrong calling convention
-- (Trac #2844 was an example where this happened)
-- NB1: we can't move the assertion further out without
-- blocking the "knot" tied in coreTopBindsToStg
-- NB2: the arity check is only needed for Ids with External
-- Names, because they are externally visible. The CorePrep
-- pass introduces "sat" things with Local Names and does
-- not bother to set their Arity info, so don't fail for those
-- It's vital that the arity on a top-level Id matches
-- the arity of the generated STG binding, else an importing
-- module will use the wrong calling convention
-- (Trac #2844 was an example where this happened)
-- NB1: we can't move the assertion further out without
-- blocking the "knot" tied in coreTopBindsToStg
-- NB2: the arity check is only needed for Ids with External
-- Names, because they are externally visible. The CorePrep
-- pass introduces "sat" things with Local Names and does
-- not bother to set their Arity info, so don't fail for those
arity_ok stg_arity
| isExternalName (idName bndr) = id_arity == stg_arity
| otherwise = True
| otherwise = True
id_arity = idArity bndr
mk_arity_msg stg_arity
= vcat [ppr bndr,
= vcat [ppr bndr,
ptext (sLit "Id arity:") <+> ppr id_arity,
ptext (sLit "STG arity:") <+> ppr stg_arity]
mkTopStgRhs :: PackageId -> FreeVarsInfo
-> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
-> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt
bndrs body
(getFVs rhs_fvs)
ReEntrant
srt
bndrs body
mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
| not (isDllConApp this_pkg con args) -- Dynamic StgConApps are updatable
......@@ -282,10 +282,10 @@ mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
mkTopStgRhs _ rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
srt
[] rhs
(getFVs rhs_fvs)
Updatable
srt
[] rhs
\end{code}
......@@ -295,14 +295,14 @@ mkTopStgRhs _ rhs_fvs srt binder_info rhs
\begin{code}
coreToStgExpr
:: CoreExpr
-> LneM (StgExpr, -- Decorated STG expr
FreeVarsInfo, -- Its free vars (NB free, not live)
EscVarsSet) -- Its escapees, a subset of its free vars;
-- also a subset of the domain of the envt
-- because we are only interested in the escapees
-- for vars which might be turned into
-- let-no-escaped ones.
:: CoreExpr
-> LneM (StgExpr, -- Decorated STG expr
FreeVarsInfo, -- Its free vars (NB free, not live)
EscVarsSet) -- Its escapees, a subset of its free vars;
-- also a subset of the domain of the envt
-- because we are only interested in the escapees
-- for vars which might be turned into
-- let-no-escaped ones.
\end{code}
The second and third components can be derived in a simple bottom up pass, not
......@@ -322,16 +322,16 @@ coreToStgExpr expr@(App _ _)
coreToStgExpr expr@(Lam _ _)
= let
(args, body) = myCollectBinders expr
args' = filterStgBinders args
(args, body) = myCollectBinders expr
args' = filterStgBinders args
in
extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
(body, body_fvs, body_escs) <- coreToStgExpr body
let
fvs = args' `minusFVBinders` body_fvs
escs = body_escs `delVarSetList` args'
result_expr | null args' = body
| otherwise = StgLam (exprType expr) args' body
fvs = args' `minusFVBinders` body_fvs
escs = body_escs `delVarSetList` args'
result_expr | null args' = body
| otherwise = StgLam (exprType expr) args' body
return (result_expr, fvs, escs)
......@@ -360,22 +360,22 @@ coreToStgExpr (Case scrut bndr _ alts) = do
unionFVInfos fvs_s,
unionVarSets escs_s )
let
-- Determine whether the default binder is dead or not
-- This helps the code generator to avoid generating an assignment
-- for the case binder (is extremely rare cases) ToDo: remove.
bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
| otherwise = bndr `setIdOccInfo` IAmDead
-- Don't consider the default binder as being 'live in alts',
-- since this is from the point of view of the case expr, where
-- the default binder is not free.
alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
alts_escs_wo_bndr = alts_escs `delVarSet` bndr
-- Determine whether the default binder is dead or not
-- This helps the code generator to avoid generating an assignment
-- for the case binder (is extremely rare cases) ToDo: remove.
bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
| otherwise = bndr `setIdOccInfo` IAmDead
-- Don't consider the default binder as being 'live in alts',
-- since this is from the point of view of the case expr, where
-- the default binder is not free.
alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
alts_escs_wo_bndr = alts_escs `delVarSet` bndr
alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
(scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
<- setVarsLiveInCont alts_lv_info $ do
(scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
......@@ -384,33 +384,33 @@ coreToStgExpr (Case scrut bndr _ alts) = do
return (
StgCase scrut2 (getLiveVars scrut_lv_info)
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
(mkStgAltType bndr alts)
alts2,
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
(mkStgAltType bndr alts)
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not
-- (getFVSet scrut_fvs), but actually we can't call, and
-- then return from, a let-no-escape thing.
-- You might think we should have scrut_escs, not
-- (getFVSet scrut_fvs), but actually we can't call, and
-- then return from, a let-no-escape thing.
)
where
vars_alt (con, binders, rhs)
= let -- Remove type variables
binders' = filterStgBinders binders
in
= let -- Remove type variables
binders' = filterStgBinders binders
in
extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
(rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
let
-- Records whether each param is used in the RHS
good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
-- Records whether each param is used in the RHS
good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
return ( (con, binders', good_use_mask, rhs2),
binders' `minusFVBinders` rhs_fvs,
rhs_escs `delVarSetList` binders' )
-- ToDo: remove the delVarSet;
-- since escs won't include any of these binders
-- ToDo: remove the delVarSet;
-- since escs won't include any of these binders
\end{code}
Lets not only take quite a bit of work, but this is where we convert
......@@ -433,34 +433,34 @@ coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType bndr alts
= case splitTyConApp_maybe (repType (idType bndr)) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
where
_is_poly_alt_tycon tc
= isFunTyCon tc
= isFunTyCon tc
|| isPrimTyCon tc -- "Any" is lifted but primitive
|| isFamilyTyCon tc -- Type family; e.g. arising from strict
-- function application where argument has a
-- type-family type
|| isFamilyTyCon tc -- Type family; e.g. arising from strict
-- function application where argument has a
-- type-family type
-- Sometimes, the TyCon is a HiBootTyCon which may not have any
-- constructors inside it. Then we can get a better TyCon by
-- Sometimes, the TyCon is a HiBootTyCon which may not have any
-- constructors inside it. Then we can get a better TyCon by
-- grabbing the one from a constructor alternative
-- if one exists.
look_for_better_tycon
| ((DataAlt con, _, _) : _) <- data_alts =
AlgAlt (dataConTyCon con)
| otherwise =
ASSERT(null data_alts)
PolyAlt
where
(data_alts, _deflt) = findDefault alts
| ((DataAlt con, _, _) : _) <- data_alts =
AlgAlt (dataConTyCon con)
| otherwise =
ASSERT(null data_alts)
PolyAlt
where
(data_alts, _deflt) = findDefault alts
\end{code}
......@@ -470,13 +470,13 @@ mkStgAltType bndr alts
\begin{code}
coreToStgApp
:: Maybe UpdateFlag -- Just upd <=> this application is
-- the rhs of a thunk binding
-- x = [...] \upd [] -> the_app
-- with specified update flag
-> Id -- Function
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
:: Maybe UpdateFlag -- Just upd <=> this application is
-- the rhs of a thunk binding
-- x = [...] \upd [] -> the_app
-- with specified update flag
-> Id -- Function
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
coreToStgApp _ f args = do
......@@ -484,73 +484,73 @@ coreToStgApp _ f args = do
how_bound <- lookupVarLne f
let
n_val_args = valArgCount args
not_letrec_bound = not (isLetBound how_bound)
fun_fvs = singletonFVInfo f how_bound fun_occ
-- e.g. (f :: a -> int) (x :: a)
n_val_args = valArgCount args
not_letrec_bound = not (isLetBound how_bound)
fun_fvs = singletonFVInfo f how_bound fun_occ
-- e.g. (f :: a -> int) (x :: a)
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
-- Mostly, the arity info of a function is in the fn's IdInfo
-- But new bindings introduced by CoreSat may not have no
-- arity info; it would do us no good anyway. For example:
-- let f = \ab -> e in f
-- No point in having correct arity info for f!
-- Hence the hasArity stuff below.
-- NB: f_arity is only consulted for LetBound things
f_arity = stgArity f how_bound
saturated = f_arity <= n_val_args
fun_occ
| not_letrec_bound = noBinderInfo -- Uninteresting variable
| f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
| otherwise = stgUnsatOcc -- Unsaturated function or thunk
fun_escs
| not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
| f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
-- saturated call doesn't escape
-- (let-no-escape applies to 'thunks' too)
| otherwise = unitVarSet f -- Inexact application; it does escape
-- At the moment of the call:
-- either the function is *not* let-no-escaped, in which case
-- nothing is live except live_in_cont
-- or the function *is* let-no-escaped in which case the
-- variables it uses are live, but still the function
-- itself is not. PS. In this case, the function's
-- live vars should already include those of the
-- continuation, but it does no harm to just union the
-- two regardless.
res_ty = exprType (mkApps (Var f) args)
app = case idDetails f of
DataConWorkId dc | saturated -> StgConApp dc args'
-- Some primitive operator that might be implemented as a library call.
PrimOpId op -> ASSERT( saturated )
StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
-> ASSERT( saturated )
StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
-- A regular foreign call.
FCallId call -> ASSERT( saturated )
StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
-- Mostly, the arity info of a function is in the fn's IdInfo
-- But new bindings introduced by CoreSat may not have no
-- arity info; it would do us no good anyway. For example:
-- let f = \ab -> e in f
-- No point in having correct arity info for f!
-- Hence the hasArity stuff below.
-- NB: f_arity is only consulted for LetBound things
f_arity = stgArity f how_bound
saturated = f_arity <= n_val_args
fun_occ
| not_letrec_bound = noBinderInfo -- Uninteresting variable
| f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
| otherwise = stgUnsatOcc -- Unsaturated function or thunk
fun_escs
| not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
| f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
-- saturated call doesn't escape
-- (let-no-escape applies to 'thunks' too)
| otherwise = unitVarSet f -- Inexact application; it does escape
-- At the moment of the call:
-- either the function is *not* let-no-escaped, in which case
-- nothing is live except live_in_cont
-- or the function *is* let-no-escaped in which case the
-- variables it uses are live, but still the function
-- itself is not. PS. In this case, the function's
-- live vars should already include those of the
-- continuation, but it does no harm to just union the
-- two regardless.
res_ty = exprType (mkApps (Var f) args)
app = case idDetails f of
DataConWorkId dc | saturated -> StgConApp dc args'
-- Some primitive operator that might be implemented as a library call.
PrimOpId op -> ASSERT( saturated )
StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
-> ASSERT( saturated )
StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty