summaryrefslogtreecommitdiff
path: root/compiler/simplStg
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/simplStg')
-rw-r--r--compiler/simplStg/StgCse.hs12
-rw-r--r--compiler/simplStg/StgStats.hs2
-rw-r--r--compiler/simplStg/UnariseStg.hs38
3 files changed, 28 insertions, 24 deletions
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index 6e896176f9..4924b508c7 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -330,16 +330,16 @@ stgCseExpr env (StgLetNoEscape binds body)
-- Case alternatives
-- Extend the CSE environment
stgCseAlt :: CseEnv -> OutId -> InStgAlt -> OutStgAlt
-stgCseAlt env case_bndr (DataAlt dataCon, args, rhs)
+stgCseAlt env case_bndr (DataAlt dataCon, args, rhs, freq)
= let (env1, args') = substBndrs env args
env2 = addDataCon case_bndr dataCon (map StgVarArg args') env1
-- see note [Case 2: CSEing case binders]
rhs' = stgCseExpr env2 rhs
- in (DataAlt dataCon, args', rhs')
-stgCseAlt env _ (altCon, args, rhs)
+ in (DataAlt dataCon, args', rhs', freq)
+stgCseAlt env _ (altCon, args, rhs, freq)
= let (env1, args') = substBndrs env args
rhs' = stgCseExpr env1 rhs
- in (altCon, args', rhs')
+ in (altCon, args', rhs', freq)
-- Bindings
stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
@@ -390,8 +390,8 @@ mkStgCase scrut bndr ty alts | all isBndr alts = scrut
where
-- see Note [All alternatives are the binder]
- isBndr (_, _, StgApp f []) = f == bndr
- isBndr _ = False
+ isBndr (_, _, StgApp f [], _) = f == bndr
+ isBndr _ = False
-- Utilities
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 712ec2d22e..8dd5630932 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -172,6 +172,6 @@ statExpr (StgCase expr _ _ alts)
countOne StgCases
where
stat_alts alts
- = combineSEs (map statExpr [ e | (_,_,e) <- alts ])
+ = combineSEs (map statExpr [ e | (_,_,e,_) <- alts ])
statExpr (StgLam {}) = panic "statExpr StgLam"
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 57dd699f70..b72e24b3a7 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -382,7 +382,7 @@ elimCase :: UnariseEnv
-> [OutStgArg] -- non-void args
-> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
-elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
+elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs, _freq)]
= do let rho1 = extendRho rho bndr (MultiVal args)
rho2
| isUnboxedTupleBndr bndr
@@ -414,47 +414,51 @@ elimCase _ args bndr alt_ty alts
--------------------------------------------------------------------------------
unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
-unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e, f)]
| isUnboxedTupleBndr bndr
= do (rho', ys) <- unariseConArgBinder rho bndr
e' <- unariseExpr rho' e
- return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
+ return [(DataAlt (tupleDataCon Unboxed n), ys, e', f)]
-unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
+unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e, f)]
| isUnboxedTupleBndr bndr
= do (rho', ys1) <- unariseConArgBinders rho ys
MASSERT(ys1 `lengthIs` n)
let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
e' <- unariseExpr rho'' e
- return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
+ return [(DataAlt (tupleDataCon Unboxed n), ys1, e', f)]
unariseAlts _ (MultiValAlt _) bndr alts
| isUnboxedTupleBndr bndr
= pprPanic "unariseExpr: strange multi val alts" (ppr alts)
-- In this case we don't need to scrutinize the tag bit
-unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs, f)]
| isUnboxedSumBndr bndr
= do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
rhs' <- unariseExpr rho_sum_bndrs rhs
- return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
+ return
+ [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)),
+ sum_bndrs, rhs', f)]
unariseAlts rho (MultiValAlt _) bndr alts
| isUnboxedSumBndr bndr
- = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
+ = do (rho_sum_bndrs,
+ scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
scrt_bndrs,
- inner_case) ]
+ inner_case, defFreq) ]
unariseAlts rho _ _ alts
= mapM (\alt -> unariseAlt rho alt) alts
unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
-unariseAlt rho (con, xs, e)
+unariseAlt rho (con, xs, e, f)
= do (rho', xs') <- unariseConArgBinders rho xs
- (con, xs',) <$> unariseExpr rho' e
+ e' <- unariseExpr rho' e
+ return (con, xs', e', f)
--------------------------------------------------------------------------------
@@ -472,13 +476,13 @@ unariseSumAlt :: UnariseEnv
-> [StgArg] -- sum components _excluding_ the tag bit.
-> StgAlt -- original alternative with sum LHS
-> UniqSM StgAlt
-unariseSumAlt rho _ (DEFAULT, _, e)
- = ( DEFAULT, [], ) <$> unariseExpr rho e
+unariseSumAlt rho _ (DEFAULT, _, e, f)
+ = unariseExpr rho e >>= \e -> return ( DEFAULT, [], e, f)
-unariseSumAlt rho args (DataAlt sumCon, bs, e)
+unariseSumAlt rho args (DataAlt sumCon, bs, e, f)
= do let rho' = mapSumIdBinders bs args rho
e' <- unariseExpr rho' e
- return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
+ return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e', f)
unariseSumAlt _ scrt alt
= pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
@@ -780,6 +784,6 @@ mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
-- Since they are exhaustive, we can replace one with DEFAULT, to avoid
-- generating a final test. Remember, the DEFAULT comes first if it exists.
mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
-mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
-mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
+mkDefaultLitAlt alts@((DEFAULT, _, _, _) : _) = alts
+mkDefaultLitAlt ((LitAlt{}, [], rhs, f) : alts) = (DEFAULT, [], rhs, f) : alts
mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
View Lorry Controller Status