summaryrefslogtreecommitdiff
path: root/compiler/GHC/Stg/Unarise.hs
diff options
context:
space:
mode:
authordoyougnu <jeffrey.young@iohk.io>2022-02-23 11:08:22 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-03-02 14:11:43 -0500
commit91a10cb06aa9ace905adeff3cc795de9c40f64a9 (patch)
tree3eb2f47f21226678faa8fd602d2b51ac5984f253 /compiler/GHC/Stg/Unarise.hs
parentc8652a0afc3d8b56d39f39ff587271dcc46b17ba (diff)
downloadhaskell-91a10cb06aa9ace905adeff3cc795de9c40f64a9.tar.gz
GenStgAlt 3-tuple synonym --> Record type
This commit alters GenStgAlt from a type synonym to a Record with field accessors. In pursuit of #21078, this is not a required change but cleans up several areas for nicer code in the upcoming js-backend, and in GHC itself. GenStgAlt: 3-tuple -> record Stg.Utils: GenStgAlt 3-tuple -> record Stg.Stats: StgAlt 3-tuple --> record Stg.InferTags.Rewrite: StgAlt 3-tuple -> record Stg.FVs: GenStgAlt 3-tuple -> record Stg.CSE: GenStgAlt 3-tuple -> record Stg.InferTags: GenStgAlt 3-tuple --> record Stg.Debug: GenStgAlt 3-tuple --> record Stg.Lift.Analysis: GenStgAlt 3-tuple --> record Stg.Lift: GenStgAlt 3-tuple --> record ByteCode.Instr: GenStgAlt 3-tuple --> record Stg.Syntax: add GenStgAlt helper functions Stg.Unarise: GenStgAlt 3-tuple --> record Stg.BcPrep: GenStgAlt 3-tuple --> record CoreToStg: GenStgAlt 3-tuple --> record StgToCmm.Expr: GenStgAlt 3-tuple --> record StgToCmm.Bind: GenStgAlt 3-tuple --> record StgToByteCode: GenStgAlt 3-tuple --> record Stg.Lint: GenStgAlt 3-tuple --> record Stg.Syntax: strictify GenStgAlt GenStgAlt: add haddock, some cleanup fixup: remove calls to pure, single ViewPattern StgToByteCode: use case over viewpatterns
Diffstat (limited to 'compiler/GHC/Stg/Unarise.hs')
-rw-r--r--compiler/GHC/Stg/Unarise.hs63
1 files changed, 38 insertions, 25 deletions
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 25b9c5e582..d46719298e 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -447,7 +447,9 @@ elimCase :: UnariseEnv
-> [OutStgArg] -- non-void args
-> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
-elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
+elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _
+ , alt_bndrs = bndrs
+ , alt_rhs = rhs}]
= do let rho1 = extendRho rho bndr (MultiVal args)
rho2
| isUnboxedTupleBndr bndr
@@ -479,47 +481,55 @@ 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 [GenStgAlt{ alt_con = DEFAULT
+ , alt_bndrs = []
+ , alt_rhs = e}]
| isUnboxedTupleBndr bndr
= do (rho', ys) <- unariseConArgBinder rho bndr
- e' <- unariseExpr rho' e
- return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
+ !e' <- unariseExpr rho' e
+ return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e']
-unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con = DataAlt _
+ , alt_bndrs = ys
+ , alt_rhs = e}]
| 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')]
+ !e' <- unariseExpr rho'' e
+ return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e']
unariseAlts _ (MultiValAlt _) bndr alts
| isUnboxedTupleBndr bndr
= pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)
-- In this case we don't need to scrutinize the tag bit
-unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
+unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con = DEFAULT
+ , alt_bndrs = []
+ , alt_rhs = rhs}]
| 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 [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs']
unariseAlts rho (MultiValAlt _) bndr alts
| isUnboxedSumBndr 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) ]
+ return [GenStgAlt{ alt_con = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))
+ , alt_bndrs = scrt_bndrs
+ , alt_rhs = inner_case
+ }]
unariseAlts rho _ _ alts
= mapM (\alt -> unariseAlt rho alt) alts
unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
-unariseAlt rho (con, xs, e)
+unariseAlt rho alt@GenStgAlt{alt_con=_,alt_bndrs=xs,alt_rhs=e}
= do (rho', xs') <- unariseConArgBinders rho xs
- (con, xs',) <$> unariseExpr rho' e
+ !e' <- unariseExpr rho' e
+ return $! alt {alt_bndrs = xs', alt_rhs = e'}
--------------------------------------------------------------------------------
@@ -537,13 +547,16 @@ 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 _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e}
+ = GenStgAlt DEFAULT mempty <$> unariseExpr rho e
-unariseSumAlt rho args (DataAlt sumCon, bs, e)
- = do let rho' = mapSumIdBinders bs args rho
- e' <- unariseExpr rho' e
- return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )
+unariseSumAlt rho args GenStgAlt{ alt_con = DataAlt sumCon
+ , alt_bndrs = bs
+ , alt_rhs = e
+ }
+ = do let rho' = mapSumIdBinders bs args rho
+ lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)))
+ GenStgAlt lit_case mempty <$> unariseExpr rho' e
unariseSumAlt _ scrt alt
= pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)
@@ -840,12 +853,12 @@ 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@(GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=_} : _) = alts
+mkDefaultLitAlt (alt@GenStgAlt{alt_con=LitAlt{}, alt_bndrs=[]} : alts) = alt {alt_con = DEFAULT} : alts
mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts)
-pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc
+pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc
pprPanicAlts alts = ppr (map pprPanicAlt alts)
-pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc
-pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)
+pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
+pprPanicAlt GenStgAlt{alt_con=c,alt_bndrs=b,alt_rhs=e} = ppr (c,b,pprStgExpr panicStgPprOpts e)