summaryrefslogtreecommitdiff
path: root/compiler/stgSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/stgSyn')
-rw-r--r--compiler/stgSyn/CoreToStg.hs111
-rw-r--r--compiler/stgSyn/StgLint.hs12
-rw-r--r--compiler/stgSyn/StgSyn.hs14
3 files changed, 80 insertions, 57 deletions
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 671f3eb5b5..47aefd899e 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -18,7 +18,7 @@ module CoreToStg ( coreToStg ) where
import GhcPrelude
import CoreSyn
-import CoreUtils ( exprType, findDefault, isJoinBind )
+import CoreUtils ( exprType, findDefault, isJoinBind, exprIsBottom )
import CoreArity ( manifestArity )
import StgSyn
@@ -34,7 +34,7 @@ import VarEnv
import Module
import Name ( isExternalName, nameOccName, nameModule_maybe )
import OccName ( occNameFS )
-import BasicTypes ( Arity )
+import BasicTypes ( Arity, neverFreq, defFreq )
import TysWiredIn ( unboxedUnitDataCon )
import Literal
import Outputable
@@ -348,7 +348,7 @@ coreToTopStgRhs
-> CtsM (StgRhs, FreeVarsInfo, CollectedCCs)
coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs)
- = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs
+ = do { (new_rhs, rhs_fvs) <- coreToStgExpr dflags rhs
; let (stg_rhs, ccs') =
mkTopStgRhs dflags this_mod ccs rhs_fvs bndr bndr_info new_rhs
@@ -385,7 +385,7 @@ coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs)
-- ---------------------------------------------------------------------------
coreToStgExpr
- :: CoreExpr
+ :: DynFlags -> CoreExpr
-> CtsM (StgExpr, -- Decorated STG expr
FreeVarsInfo) -- Its free vars (NB free, not live)
@@ -397,23 +397,23 @@ coreToStgExpr
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
-coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
-coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo)
-coreToStgExpr (Var v) = coreToStgApp Nothing v [] []
-coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
+coreToStgExpr _df (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr _df (Lit l) = return (StgLit l, emptyFVInfo)
+coreToStgExpr df (Var v) = coreToStgApp df Nothing v [] []
+coreToStgExpr df (Coercion _) = coreToStgApp df Nothing coercionTokenId [] []
-coreToStgExpr expr@(App _ _)
- = coreToStgApp Nothing f args ticks
+coreToStgExpr df expr@(App _ _)
+ = coreToStgApp df Nothing f args ticks
where
(f, args, ticks) = myCollectArgs expr
-coreToStgExpr expr@(Lam _ _)
+coreToStgExpr df expr@(Lam _ _)
= let
(args, body) = myCollectBinders expr
args' = filterStgBinders args
in
extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
- (body, body_fvs) <- coreToStgExpr body
+ (body, body_fvs) <- coreToStgExpr df body
let
fvs = args' `minusFVBinders` body_fvs
result_expr | null args' = body
@@ -421,22 +421,22 @@ coreToStgExpr expr@(Lam _ _)
return (result_expr, fvs)
-coreToStgExpr (Tick tick expr)
+coreToStgExpr df (Tick tick expr)
= do case tick of
HpcTick{} -> return ()
ProfNote{} -> return ()
SourceNote{} -> return ()
Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
- (expr2, fvs) <- coreToStgExpr expr
+ (expr2, fvs) <- coreToStgExpr df expr
return (StgTick tick expr2, fvs)
-coreToStgExpr (Cast expr _)
- = coreToStgExpr expr
+coreToStgExpr df (Cast expr _)
+ = coreToStgExpr df expr
-- Cases require a little more real work.
-coreToStgExpr (Case scrut _ _ [])
- = coreToStgExpr scrut
+coreToStgExpr df (Case scrut _ _ [])
+ = coreToStgExpr df scrut
-- See Note [Empty case alternatives] in CoreSyn If the case
-- alternatives are empty, the scrutinee must diverge or raise an
-- exception, so we can just dive into it.
@@ -447,7 +447,7 @@ coreToStgExpr (Case scrut _ _ [])
-- runtime system error function.
-coreToStgExpr (Case scrut bndr _ alts) = do
+coreToStgExpr df (Case scrut bndr _ alts) = do
(alts2, alts_fvs)
<- extendVarEnvCts [(bndr, LambdaBound)] $ do
(alts2, fvs_s) <- mapAndUnzipM vars_alt alts
@@ -467,34 +467,43 @@ coreToStgExpr (Case scrut bndr _ alts) = do
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
- (scrut2, scrut_fvs) <- coreToStgExpr scrut
+ (scrut2, scrut_fvs) <- coreToStgExpr df scrut
return (
StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr
)
where
+ alt_freq rhs
+ | gopt Opt_UnlikelyBottoms df
+ , exprIsBottom rhs
+ = -- If a expression is bottom we can safely assume it's
+ -- alternative is rarely taken. Hence we set the
+ -- branch weight to zero/never.
+ -- For details see Note [Branch weights] in BasicTypes
+ neverFreq
+ | otherwise = defFreq
vars_alt (con, binders, rhs)
| DataAlt c <- con, c == unboxedUnitDataCon
= -- This case is a bit smelly.
-- See Note [Nullary unboxed tuple] in Type.hs
-- where a nullary tuple is mapped to (State# World#)
ASSERT( null binders )
- do { (rhs2, rhs_fvs) <- coreToStgExpr rhs
- ; return ((DEFAULT, [], rhs2), rhs_fvs) }
+ do { (rhs2, rhs_fvs) <- coreToStgExpr df rhs
+ ; return ((DEFAULT, [], rhs2, alt_freq rhs), rhs_fvs) }
| otherwise
= let -- Remove type variables
binders' = filterStgBinders binders
in
extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
- (rhs2, rhs_fvs) <- coreToStgExpr rhs
- return ( (con, binders', rhs2),
+ (rhs2, rhs_fvs) <- coreToStgExpr df rhs
+ return ( (con, binders', rhs2, alt_freq rhs),
binders' `minusFVBinders` rhs_fvs )
-coreToStgExpr (Let bind body) = do
- coreToStgLet bind body
+coreToStgExpr df (Let bind body) = do
+ coreToStgLet df bind body
-coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
+coreToStgExpr _ e = pprPanic "coreToStgExpr" (ppr e)
mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType bndr alts
@@ -541,7 +550,8 @@ mkStgAltType bndr alts
-- ---------------------------------------------------------------------------
coreToStgApp
- :: Maybe UpdateFlag -- Just upd <=> this application is
+ :: DynFlags
+ -> Maybe UpdateFlag -- Just upd <=> this application is
-- the rhs of a thunk binding
-- x = [...] \upd [] -> the_app
-- with specified update flag
@@ -551,8 +561,8 @@ coreToStgApp
-> CtsM (StgExpr, FreeVarsInfo)
-coreToStgApp _ f args ticks = do
- (args', args_fvs, ticks') <- coreToStgArgs args
+coreToStgApp df _ f args ticks = do
+ (args', args_fvs, ticks') <- coreToStgArgs df args
how_bound <- lookupVarCts f
let
@@ -618,26 +628,27 @@ coreToStgApp _ f args ticks = do
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------
-coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], FreeVarsInfo, [Tickish Id])
-coreToStgArgs []
+coreToStgArgs :: DynFlags -> [CoreArg]
+ -> CtsM ([StgArg], FreeVarsInfo, [Tickish Id])
+coreToStgArgs _ []
= return ([], emptyFVInfo, [])
-coreToStgArgs (Type _ : args) = do -- Type argument
- (args', fvs, ts) <- coreToStgArgs args
+coreToStgArgs df (Type _ : args) = do -- Type argument
+ (args', fvs, ts) <- coreToStgArgs df args
return (args', fvs, ts)
-coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder
- = do { (args', fvs, ts) <- coreToStgArgs args
+coreToStgArgs df (Coercion _ : args) -- Coercion argument; replace with place holder
+ = do { (args', fvs, ts) <- coreToStgArgs df args
; return (StgVarArg coercionTokenId : args', fvs, ts) }
-coreToStgArgs (Tick t e : args)
+coreToStgArgs df (Tick t e : args)
= ASSERT( not (tickishIsCode t) )
- do { (args', fvs, ts) <- coreToStgArgs (e : args)
+ do { (args', fvs, ts) <- coreToStgArgs df (e : args)
; return (args', fvs, t:ts) }
-coreToStgArgs (arg : args) = do -- Non-type argument
- (stg_args, args_fvs, ticks) <- coreToStgArgs args
- (arg', arg_fvs) <- coreToStgExpr arg
+coreToStgArgs df (arg : args) = do -- Non-type argument
+ (stg_args, args_fvs, ticks) <- coreToStgArgs df args
+ (arg', arg_fvs) <- coreToStgExpr df arg
let
fvs = args_fvs `unionFVInfo` arg_fvs
@@ -677,12 +688,13 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- ---------------------------------------------------------------------------
coreToStgLet
- :: CoreBind -- bindings
+ :: DynFlags
+ -> CoreBind -- bindings
-> CoreExpr -- body
-> CtsM (StgExpr, -- new let
FreeVarsInfo) -- variables free in the whole let
-coreToStgLet bind body = do
+coreToStgLet df bind body = do
(bind2, bind_fvs,
body2, body_fvs)
<- mfix $ \ ~(_, _, _, rec_body_fvs) -> do
@@ -692,7 +704,7 @@ coreToStgLet bind body = do
-- Do the body
extendVarEnvCts env_ext $ do
- (body2, body_fvs) <- coreToStgExpr body
+ (body2, body_fvs) <- coreToStgExpr df body
return (bind2, bind_fvs,
body2, body_fvs)
@@ -724,7 +736,7 @@ coreToStgLet bind body = do
vars_bind body_fvs (NonRec binder rhs) = do
- (rhs2, bind_fvs) <- coreToStgRhs body_fvs (binder,rhs)
+ (rhs2, bind_fvs) <- coreToStgRhs df body_fvs (binder,rhs)
let
env_ext_item = mk_binding binder rhs
@@ -742,19 +754,20 @@ coreToStgLet bind body = do
in
extendVarEnvCts env_ext $ do
(rhss2, fvss)
- <- mapAndUnzipM (coreToStgRhs rec_scope_fvs) pairs
+ <- mapAndUnzipM (coreToStgRhs df rec_scope_fvs) pairs
let
bind_fvs = unionFVInfos fvss
return (StgRec (binders `zip` rhss2),
bind_fvs, env_ext)
-coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
+coreToStgRhs :: DynFlags
+ -> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> CtsM (StgRhs, FreeVarsInfo)
-coreToStgRhs scope_fv_info (bndr, rhs) = do
- (new_rhs, rhs_fvs) <- coreToStgExpr rhs
+coreToStgRhs df scope_fv_info (bndr, rhs) = do
+ (new_rhs, rhs_fvs) <- coreToStgExpr df rhs
return (mkStgRhs rhs_fvs bndr bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index bb2064ab48..30b2b991a3 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -36,6 +36,8 @@ module StgLint ( lintStgTopBindings ) where
import GhcPrelude
+import BasicTypes (BranchWeight)
+
import StgSyn
import DynFlags
@@ -184,18 +186,20 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = do
addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
-lintAlt :: (AltCon, [Id], StgExpr) -> LintM ()
+lintAlt :: (AltCon, [Id], StgExpr, BranchWeight) -> LintM ()
-lintAlt (DEFAULT, _, rhs) =
+lintAlt (DEFAULT, _, rhs, _) =
lintStgExpr rhs
-lintAlt (LitAlt _, _, rhs) =
+lintAlt (LitAlt _, _, rhs, _) =
lintStgExpr rhs
-lintAlt (DataAlt _, bndrs, rhs) = do
+lintAlt (DataAlt _, bndrs, rhs, _) = do
mapM_ checkPostUnariseBndr bndrs
addInScopeVars bndrs (lintStgExpr rhs)
+
+
{-
************************************************************************
* *
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 29d544103f..3f7cbc0f46 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -47,6 +47,7 @@ module StgSyn (
import GhcPrelude
+import BasicTypes (BranchWeight)
import CoreSyn ( AltCon, Tickish )
import CostCentre ( CostCentreStack )
import Data.ByteString ( ByteString )
@@ -479,7 +480,7 @@ rhsHasCafRefs (StgRhsCon _ _ args)
= any stgArgHasCafRefs args
altHasCafRefs :: GenStgAlt bndr Id -> Bool
-altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
+altHasCafRefs (_, _, rhs, _) = exprHasCafRefs rhs
stgArgHasCafRefs :: GenStgArg Id -> Bool
stgArgHasCafRefs (StgVarArg id)
@@ -543,7 +544,9 @@ rather than from the scrutinee type.
type GenStgAlt bndr occ
= (AltCon, -- alts: data constructor,
[bndr], -- constructor's parameters,
- GenStgExpr bndr occ) -- ...right-hand side.
+ GenStgExpr bndr occ, -- ..right-hand side,
+ BranchWeight) -- relative chance to take this alt, see
+ -- Note [Branch weights] in BasicTypes
data AltType
= PolyAlt -- Polymorphic (a lifted type variable)
@@ -784,8 +787,11 @@ pprStgExpr (StgCase expr bndr alt_type alts)
pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
=> GenStgAlt bndr occ -> SDoc
-pprStgAlt (con, params, expr)
- = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+pprStgAlt (con, params, expr, f)
+ = hang (hsep [ppr con,
+ sep (map (pprBndr CasePatBind) params),
+ parens (text "likely:" <> ppr f) ,
+ text "->"])
4 (ppr expr <> semi)
pprStgOp :: StgOp -> SDoc
View Lorry Controller Status