diff options
Diffstat (limited to 'compiler/stgSyn/CoreToStg.hs')
| -rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 111 |
1 files changed, 62 insertions, 49 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 |