diff options
author | doyougnu <jeffrey.young@iohk.io> | 2022-02-23 11:08:22 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-03-02 14:11:43 -0500 |
commit | 91a10cb06aa9ace905adeff3cc795de9c40f64a9 (patch) | |
tree | 3eb2f47f21226678faa8fd602d2b51ac5984f253 /compiler/GHC/Stg/Unarise.hs | |
parent | c8652a0afc3d8b56d39f39ff587271dcc46b17ba (diff) | |
download | haskell-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.hs | 63 |
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) |