summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/ByteCode/Instr.hs2
-rw-r--r--compiler/GHC/CoreToStg.hs11
-rw-r--r--compiler/GHC/Stg/BcPrep.hs2
-rw-r--r--compiler/GHC/Stg/CSE.hs12
-rw-r--r--compiler/GHC/Stg/Debug.hs3
-rw-r--r--compiler/GHC/Stg/FVs.hs5
-rw-r--r--compiler/GHC/Stg/InferTags.hs15
-rw-r--r--compiler/GHC/Stg/InferTags/Rewrite.hs34
-rw-r--r--compiler/GHC/Stg/Lift.hs6
-rw-r--r--compiler/GHC/Stg/Lift/Analysis.hs4
-rw-r--r--compiler/GHC/Stg/Lint.hs17
-rw-r--r--compiler/GHC/Stg/Stats.hs3
-rw-r--r--compiler/GHC/Stg/Syntax.hs24
-rw-r--r--compiler/GHC/Stg/Unarise.hs63
-rw-r--r--compiler/GHC/Stg/Utils.hs13
-rw-r--r--compiler/GHC/StgToByteCode.hs33
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs4
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs15
18 files changed, 154 insertions, 112 deletions
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
index 1950289f79..ebbce3ef50 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -223,7 +223,7 @@ pprStgBindShort (StgRec bs) =
char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"
pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc
-pprStgAltShort opts (con, args, expr) =
+pprStgAltShort opts GenStgAlt{alt_con=con, alt_bndrs=args, alt_rhs=expr} =
ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr
pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 6e0e4600dd..79be8e6e11 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
@@ -455,7 +456,7 @@ coreToStgExpr (Case scrut bndr _ alts)
; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }
where
- vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)
+ vars_alt :: CoreAlt -> CtsM StgAlt
vars_alt (Alt con binders rhs)
| DataAlt c <- con, c == unboxedUnitDataCon
= -- This case is a bit smelly.
@@ -463,14 +464,18 @@ coreToStgExpr (Case scrut bndr _ alts)
-- where a nullary tuple is mapped to (State# World#)
assert (null binders) $
do { rhs2 <- coreToStgExpr rhs
- ; return (DEFAULT, [], rhs2) }
+ ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2}
+ }
| otherwise
= let -- Remove type variables
binders' = filterStgBinders binders
in
extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
rhs2 <- coreToStgExpr rhs
- return (con, binders', rhs2)
+ return $! GenStgAlt{ alt_con = con
+ , alt_bndrs = binders'
+ , alt_rhs = rhs2
+ }
coreToStgExpr (Let bind body) = coreToStgLet bind body
coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs
index 1b5f2b37b6..c1fd67d484 100644
--- a/compiler/GHC/Stg/BcPrep.hs
+++ b/compiler/GHC/Stg/BcPrep.hs
@@ -96,7 +96,7 @@ bcPrepExpr app@StgConApp{} = pure app
bcPrepExpr app@StgOpApp{} = pure app
bcPrepAlt :: StgAlt -> BcPrepM StgAlt
-bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr
+bcPrepAlt (GenStgAlt con bndrs rhs) = GenStgAlt con bndrs <$> bcPrepExpr rhs
bcPrepBind :: StgBinding -> BcPrepM StgBinding
-- explicitly match all constructors so we get a warning if we miss any
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index 8062337192..a4d92ad500 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -374,7 +374,7 @@ stgCseExpr env (StgLetNoEscape ext binds body)
-- Case alternatives
-- Extend the CSE environment
stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
-stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
+stgCseAlt env ty case_bndr GenStgAlt{alt_con=DataAlt dataCon, alt_bndrs=args, alt_rhs=rhs}
= let (env1, args') = substBndrs env args
env2
-- To avoid dealing with unboxed sums StgCse runs after unarise and
@@ -389,11 +389,11 @@ stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
= env1
-- see Note [Case 2: CSEing case binders]
rhs' = stgCseExpr env2 rhs
- in (DataAlt dataCon, args', rhs')
-stgCseAlt env _ _ (altCon, args, rhs)
+ in GenStgAlt (DataAlt dataCon) args' rhs'
+stgCseAlt env _ _ g@GenStgAlt{alt_con=_, alt_bndrs=args, alt_rhs=rhs}
= let (env1, args') = substBndrs env args
rhs' = stgCseExpr env1 rhs
- in (altCon, args', rhs')
+ in g {alt_bndrs=args', alt_rhs=rhs'}
-- Bindings
stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
@@ -445,8 +445,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 GenStgAlt{alt_con=_,alt_bndrs=_,alt_rhs=StgApp f []} = f == bndr
+ isBndr _ = False
{- Note [Care with loop breakers]
diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
index 7eb4155068..678f95e50e 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ b/compiler/GHC/Stg/Debug.hs
@@ -124,7 +124,8 @@ collectExpr = go
return (StgTick tick e')
collectAlt :: StgAlt -> M StgAlt
-collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e
+collectAlt alt = do e' <- collectExpr $ alt_rhs alt
+ return $! alt { alt_rhs = e' }
-- | Try to find the best source position surrounding a 'StgExpr'. The
-- heuristic strips ticks from the current expression until it finds one which
diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs
index 636ec5eb61..b954933a30 100644
--- a/compiler/GHC/Stg/FVs.hs
+++ b/compiler/GHC/Stg/FVs.hs
@@ -270,7 +270,8 @@ argsFVs env = foldl' f (emptyVarSet, emptyDVarSet)
f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids)
altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)
-altFVs env (con,bndrs,e)
+altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e}
| (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e
, let lcl_fvs' = delDVarSetList lcl_fvs bndrs
- = ((con,bndrs, e'), top_fvs, lcl_fvs')
+ , let newAlt = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'}
+ = (newAlt, top_fvs, lcl_fvs')
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
index 477650da3c..2a42b4c7de 100644
--- a/compiler/GHC/Stg/InferTags.hs
+++ b/compiler/GHC/Stg/InferTags.hs
@@ -333,7 +333,7 @@ inferTagExpr env (StgLetNoEscape ext bind body)
inferTagExpr in_env (StgCase scrut bndr ty alts)
-- Unboxed tuples get their info from the expression we scrutinise if any
- | [(DataAlt con, bndrs, rhs)] <- alts
+ | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts
, isUnboxedTupleDataCon con
, Just infos <- scrut_infos bndrs
, let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos
@@ -350,7 +350,9 @@ inferTagExpr in_env (StgCase scrut bndr ty alts)
-- text "bndr:" <> ppr bndr $$
-- text "infos" <> ppr infos $$
-- text "out_bndrs" <> ppr bndrs') $
- (info, StgCase scrut' (noSig in_env bndr) ty [(DataAlt con, bndrs', rhs')])
+ (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con
+ , alt_bndrs=bndrs'
+ , alt_rhs=rhs'}])
| null alts -- Empty case, but I might just be paranoid.
= -- pprTrace "inferCase2" empty $
@@ -362,11 +364,14 @@ inferTagExpr in_env (StgCase scrut bndr ty alts)
case_env = extendSigEnv in_env [bndr']
(infos, alts')
- = unzip [ (info, (con, bndrs', rhs'))
- | (con, bndrs, rhs) <- alts
+ = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})
+ | g@GenStgAlt{ alt_con = con
+ , alt_bndrs = bndrs
+ , alt_rhs = rhs
+ } <- alts
, let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs
(info, rhs') = inferTagExpr alt_env rhs
- ]
+ ]
alt_info = foldr combineAltInfo TagTagged infos
in ( alt_info, StgCase scrut' bndr' ty alts')
where
diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
index 099fbc54d5..87b519006c 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -2,18 +2,19 @@
-- Copyright (c) 2019 Andreas Klebinger
--
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
where
@@ -49,7 +50,6 @@ import GHC.Stg.InferTags.Types
import Control.Monad
import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel)
import GHC.Types.Var.Set
-
-- import GHC.Utils.Trace
-- import GHC.Driver.Ppr
@@ -371,10 +371,10 @@ rewriteCase (StgCase scrut bndr alt_type alts) =
rewriteCase _ = panic "Impossible: nodeCase"
rewriteAlt :: InferStgAlt -> RM TgStgAlt
-rewriteAlt (altCon, bndrs, rhs) = do
+rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =
withBinders NotTopLevel bndrs $ do
!rhs' <- rewriteExpr False rhs
- return $! (altCon, map fst bndrs, rhs')
+ return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}
rewriteLet :: InferStgExpr -> RM TgStgExpr
rewriteLet (StgLet xt bind expr) = do
@@ -450,9 +450,9 @@ rewriteApp _ _ = panic "Impossible"
mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr
mkSeq id bndr !expr =
-- pprTrace "mkSeq" (ppr (id,bndr)) $
- let altTy = mkStgAltTypeFromStgAlts bndr [(DEFAULT, [], panic "Not used")]
- in
- StgCase (StgApp id []) bndr altTy [(DEFAULT, [], expr)]
+ let altTy = mkStgAltTypeFromStgAlts bndr alt
+ alt = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]
+ in StgCase (StgApp id []) bndr altTy alt
-- `mkSeqs args vs mkExpr` will force all vs, and construct
-- an argument list args' where each v is replaced by it's evaluated
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index 8155cd734e..876b44fe3f 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -249,5 +249,7 @@ liftExpr (StgLetNoEscape scope bind body)
Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')
liftAlt :: LlStgAlt -> LiftM OutStgAlt
-liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
- (,,) con bndrs' <$> liftExpr rhs
+liftAlt alt@GenStgAlt{alt_con=_, alt_bndrs=infos, alt_rhs=rhs} =
+ withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+ do !rhs' <- liftExpr rhs
+ return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'}
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index c2eb9dbb2d..6fc116c8bc 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -333,8 +333,8 @@ rhsCard bndr
n :* cd = idDemandInfo bndr
tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
-tagSkeletonAlt (con, bndrs, rhs)
- = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))
+tagSkeletonAlt old@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}
+ = (alt_skel, arg_occs, old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'})
where
(alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs
arg_occs = alt_arg_occs `delVarSetList` bndrs
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 405abdd1f4..0ec0650693 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -245,15 +245,20 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = do
lintAlt
:: (OutputablePass a, BinderP a ~ Id)
- => (AltCon, [Id], GenStgExpr a) -> LintM ()
+ => GenStgAlt a -> LintM ()
-lintAlt (DEFAULT, _, rhs) =
- lintStgExpr rhs
+lintAlt GenStgAlt{ alt_con = DEFAULT
+ , alt_bndrs = _
+ , alt_rhs = rhs} = lintStgExpr rhs
-lintAlt (LitAlt _, _, rhs) =
- lintStgExpr rhs
+lintAlt GenStgAlt{ alt_con = LitAlt _
+ , alt_bndrs = _
+ , alt_rhs = rhs} = lintStgExpr rhs
-lintAlt (DataAlt _, bndrs, rhs) = do
+lintAlt GenStgAlt{ alt_con = DataAlt _
+ , alt_bndrs = bndrs
+ , alt_rhs = rhs} =
+ do
mapM_ checkPostUnariseBndr bndrs
addInScopeVars bndrs (lintStgExpr rhs)
diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs
index 7c7df34f27..4f35d1af92 100644
--- a/compiler/GHC/Stg/Stats.hs
+++ b/compiler/GHC/Stg/Stats.hs
@@ -164,5 +164,4 @@ statExpr (StgCase expr _ _ alts)
stat_alts alts `combineSE`
countOne StgCases
where
- stat_alts alts
- = combineSEs (map statExpr [ e | (_,_,e) <- alts ])
+ stat_alts = combineSEs . fmap (statExpr . alt_rhs)
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 6726bbe526..779ddf8d56 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -1,10 +1,10 @@
-
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE UndecidableInstances #-}
{-
@@ -23,7 +23,7 @@ module GHC.Stg.Syntax (
StgArg(..),
GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
- GenStgAlt, AltType(..),
+ GenStgAlt(..), AltType(..),
StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
NoExtFieldSilent, noExtFieldSilent,
@@ -457,10 +457,11 @@ the TyCon from the constructors or literals (which are guaranteed to have the
Real McCoy) rather than from the scrutinee type.
-}
-type GenStgAlt pass
- = (AltCon, -- alts: data constructor,
- [BinderP pass], -- constructor's parameters,
- GenStgExpr pass) -- ...right-hand side.
+data GenStgAlt pass = GenStgAlt
+ { alt_con :: !AltCon -- alts: data constructor,
+ , alt_bndrs :: ![BinderP pass] -- constructor's parameters,
+ , alt_rhs :: !(GenStgExpr pass) -- right-hand side.
+ }
data AltType
= PolyAlt -- Polymorphic (a boxed type variable, lifted or unlifted)
@@ -836,11 +837,14 @@ pprStgExpr opts e = case e of
pprStgAlt :: OutputablePass pass => StgPprOpts -> Bool -> GenStgAlt pass -> SDoc
-pprStgAlt opts indent (con, params, expr)
- | indent = hang altPattern 4 (pprStgExpr opts expr <> semi)
- | otherwise = sep [altPattern, pprStgExpr opts expr <> semi]
+pprStgAlt opts indent GenStgAlt{alt_con, alt_bndrs, alt_rhs}
+ | indent = hang altPattern 4 (pprStgExpr opts alt_rhs <> semi)
+ | otherwise = sep [altPattern, pprStgExpr opts alt_rhs <> semi]
where
- altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+ altPattern = hsep [ ppr alt_con
+ , sep (map (pprBndr CasePatBind) alt_bndrs)
+ , text "->"
+ ]
pprStgOp :: StgOp -> SDoc
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)
diff --git a/compiler/GHC/Stg/Utils.hs b/compiler/GHC/Stg/Utils.hs
index 62aa89f0ff..95f70a86ce 100644
--- a/compiler/GHC/Stg/Utils.hs
+++ b/compiler/GHC/Stg/Utils.hs
@@ -42,10 +42,13 @@ mkUnarisedId s t = mkSysLocalM s Many t
-- | Extract the default case alternative
-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))
-findDefaultStg :: [GenStgAlt p] -> ([(AltCon, [BinderP p], GenStgExpr p)],
- Maybe (GenStgExpr p))
-findDefaultStg ((DEFAULT, args, rhs) : alts) = assert( null args ) (alts, Just rhs)
-findDefaultStg alts = (alts, Nothing)
+findDefaultStg
+ :: [GenStgAlt p]
+ -> ([GenStgAlt p], Maybe (GenStgExpr p))
+findDefaultStg (GenStgAlt{ alt_con = DEFAULT
+ , alt_bndrs = args
+ , alt_rhs = rhs} : alts) = assert( null args ) (alts, Just rhs)
+findDefaultStg alts = (alts, Nothing)
mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType
mkStgAltTypeFromStgAlts bndr alts
@@ -80,7 +83,7 @@ mkStgAltTypeFromStgAlts bndr alts
-- grabbing the one from a constructor alternative
-- if one exists.
look_for_better_tycon
- | (((DataAlt con) ,_, _) : _) <- data_alts =
+ | (DataAlt con : _) <- alt_con <$> data_alts =
AlgAlt (dataConTyCon con)
| otherwise =
assert(null data_alts)
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index a5931c2dd6..0d6af799de 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -884,11 +884,11 @@ doCase d s p scrut bndr alts
-- given an alt, return a discr and code for it.
codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
- codeAlt (DEFAULT, _, rhs)
+ codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}
= do rhs_code <- schemeE d_alts s p_alts rhs
return (NoDiscr, rhs_code)
- codeAlt alt@(_, bndrs, rhs)
+ codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}
-- primitive or nullary constructor alt: no need to UNPACK
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
@@ -939,24 +939,25 @@ doCase d s p scrut bndr alts
where
real_bndrs = filterOut isTyVar bndrs
- my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
- my_discr (DataAlt dc, _, _)
- | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
- = NoDiscr
- | otherwise
- = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
- my_discr (LitAlt l, _, _)
- = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i)
- LitNumber LitNumWord w -> DiscrW (fromInteger w)
- LitFloat r -> DiscrF (fromRational r)
- LitDouble r -> DiscrD (fromRational r)
- LitChar i -> DiscrI (ord i)
- _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
+ my_discr alt = case alt_con alt of
+ DEFAULT -> NoDiscr {-shouldn't really happen-}
+ DataAlt dc
+ | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
+ -> NoDiscr
+ | otherwise
+ -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
+ LitAlt l -> case l of
+ LitNumber LitNumInt i -> DiscrI (fromInteger i)
+ LitNumber LitNumWord w -> DiscrW (fromInteger w)
+ LitFloat r -> DiscrF (fromRational r)
+ LitDouble r -> DiscrD (fromRational r)
+ LitChar i -> DiscrI (ord i)
+ _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
maybe_ncons
| not isAlgCase = Nothing
| otherwise
- = case [dc | (DataAlt dc, _, _) <- alts] of
+ = case [dc | DataAlt dc <- alt_con <$> alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 5507173dc7..e8539d80f5 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -285,7 +285,9 @@ mkRhsClosure profile _ _check_tags bndr _cc
, StgCase (StgApp scrutinee [{-no args-}])
_ -- ignore bndr
(AlgAlt _)
- [(DataAlt _, params, sel_expr)] <- strip expr
+ [GenStgAlt{ alt_con = DataAlt _
+ , alt_bndrs = params
+ , alt_rhs = sel_expr}] <- strip expr
, StgApp selectee [{-no args-}] <- strip sel_expr
, the_fv == scrutinee -- Scrutinee is the only free variable
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 55892b8789..7992e34417 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -459,7 +459,7 @@ job we deleted the hacks.
cgCase (StgApp v []) _ (PrimAlt _) alts
| isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep]
- , [(DEFAULT, _, rhs)] <- alts
+ , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts
= cgExpr rhs
{- Note [Dodgy unsafeCoerce 1]
@@ -652,9 +652,10 @@ chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
chooseReturnBndrs bndr (PrimAlt _) _alts
= assertNonVoidIds [bndr]
-chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]
+chooseReturnBndrs _bndr (MultiValAlt n) [alt]
= assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $
assertNonVoidIds ids -- 'bndr' is not assigned!
+ where ids = alt_bndrs alt
chooseReturnBndrs bndr (AlgAlt _) _alts
= assertNonVoidIds [bndr] -- Only 'bndr' is assigned
@@ -669,11 +670,11 @@ chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
-> FCode ReturnKind
-- At this point the result of the case are in the binders
-cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]
- = maybeAltHeapCheck gc_plan (cgExpr rhs)
+cgAlts gc_plan _bndr PolyAlt [alt]
+ = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)
-cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]
- = maybeAltHeapCheck gc_plan (cgExpr rhs)
+cgAlts gc_plan _bndr (MultiValAlt _) [alt]
+ = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)
-- Here bndrs are *already* in scope, so don't rebind them
cgAlts gc_plan bndr (PrimAlt _) alts
@@ -942,7 +943,7 @@ cgAltRhss gc_plan bndr alts = do
let
base_reg = idToReg platform bndr
cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
- cg_alt (con, bndrs, rhs)
+ cg_alt GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=rhs}
= getCodeScoped $
maybeAltHeapCheck gc_plan $
do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)
View Lorry Controller Status