summaryrefslogtreecommitdiff
path: root/compiler/GHC/Stg
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Stg')
-rw-r--r--compiler/GHC/Stg/BcPrep.hs14
-rw-r--r--compiler/GHC/Stg/CSE.hs16
-rw-r--r--compiler/GHC/Stg/Debug.hs8
-rw-r--r--compiler/GHC/Stg/FVs.hs8
-rw-r--r--compiler/GHC/Stg/InferTags.hs12
-rw-r--r--compiler/GHC/Stg/InferTags/Rewrite.hs12
-rw-r--r--compiler/GHC/Stg/Lift.hs12
-rw-r--r--compiler/GHC/Stg/Lift/Analysis.hs12
-rw-r--r--compiler/GHC/Stg/Lift/Monad.hs8
-rw-r--r--compiler/GHC/Stg/Lint.hs10
-rw-r--r--compiler/GHC/Stg/Stats.hs4
-rw-r--r--compiler/GHC/Stg/Syntax.hs12
-rw-r--r--compiler/GHC/Stg/Unarise.hs8
13 files changed, 70 insertions, 66 deletions
diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs
index b99a0ab8c1..629e9bdd70 100644
--- a/compiler/GHC/Stg/BcPrep.hs
+++ b/compiler/GHC/Stg/BcPrep.hs
@@ -37,14 +37,14 @@ type BcPrepM a = State BcPrepM_State a
bcPrepRHS :: StgRhs -> BcPrepM StgRhs
-- explicitly match all constructors so we get a warning if we miss any
-bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr) typ) = do
{- If we have a breakpoint directly under an StgRhsClosure we don't
need to introduce a new binding for it.
-}
expr' <- bcPrepExpr expr
- pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
-bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
- StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
+ pure (StgRhsClosure fvs cc upd args (StgTick bp expr') typ)
+bcPrepRHS (StgRhsClosure fvs cc upd args expr typ) =
+ StgRhsClosure fvs cc upd args <$> bcPrepExpr expr <*> pure typ
bcPrepRHS con@StgRhsCon{} = pure con
bcPrepExpr :: StgExpr -> BcPrepM StgExpr
@@ -59,6 +59,7 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
ReEntrant
[]
expr'
+ tick_ty
)
letExp = StgLet noExtFieldSilent bnd (StgApp id [])
pure letExp
@@ -71,6 +72,7 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
ReEntrant
[voidArgId]
expr'
+ tick_ty
)
pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])
bcPrepExpr (StgTick tick rhs) =
@@ -110,10 +112,10 @@ bcPrepBind (StgRec bnds) =
bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
-- See Note [Not-necessarily-lifted join points], step 2.
-bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
+bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body typ)
| isNNLJoinPoint x
= ( protectNNLJoinPointId x
- , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
+ , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body typ)
bcPrepSingleBind bnd = bnd
bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index 73fb7617a0..eb52d6f8d2 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -319,11 +319,11 @@ stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
-stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body typ)
= let body' = stgCseExpr (initEnv in_scope) body
- in StgRhsClosure ext ccs upd args body'
-stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args)
- = StgRhsCon ccs dataCon mu ticks args
+ in StgRhsClosure ext ccs upd args body' typ
+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args typ)
+ = StgRhsCon ccs dataCon mu ticks args typ
------------------------------
-- The actual AST traversal --
@@ -427,7 +427,7 @@ stgCsePairs env0 ((b,e):pairs)
-- The RHS of a binding.
-- If it is a constructor application, either short-cut it or extend the environment
stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
-stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args)
+stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args typ)
| Just other_bndr <- envLookup dataCon args' env
, not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers]
= let env' = addSubst bndr other_bndr env
@@ -435,15 +435,15 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args)
| otherwise
= let env' = addDataCon bndr dataCon args' env
-- see Note [Case 1: CSEing allocated closures]
- pair = (bndr, StgRhsCon ccs dataCon mu ticks args')
+ pair = (bndr, StgRhsCon ccs dataCon mu ticks args' typ)
in (Just pair, env')
where args' = substArgs env args
-stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
+stgCseRhs env bndr (StgRhsClosure ext ccs upd args body typ)
= let (env1, args') = substBndrs env args
env2 = forgetCse env1 -- See Note [Free variables of an StgClosure]
body' = stgCseExpr env2 body
- in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
+ in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body' typ), env)
mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
index 4dbd5af526..39a559cb73 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ b/compiler/GHC/Stg/Debug.hs
@@ -68,7 +68,7 @@ collectStgBind (StgRec pairs) = do
return (StgRec es)
collectStgRhs :: Id -> StgRhs -> M StgRhs
-collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do
+collectStgRhs bndr (StgRhsClosure ext cc us bs e t) = do
let
name = idName bndr
-- If the name has a span, use that initially as the source position in-case
@@ -78,10 +78,10 @@ collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do
_ -> id
e' <- with_span $ collectExpr e
recordInfo bndr e'
- return $ StgRhsClosure ext cc us bs e'
-collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do
+ return $ StgRhsClosure ext cc us bs e' t
+collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args typ) = do
n' <- numberDataCon dc ticks
- return (StgRhsCon cc dc n' ticks args)
+ return (StgRhsCon cc dc n' ticks args typ)
recordInfo :: Id -> StgExpr -> M ()
diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs
index b954933a30..801ac1fed2 100644
--- a/compiler/GHC/Stg/FVs.hs
+++ b/compiler/GHC/Stg/FVs.hs
@@ -255,13 +255,13 @@ exprFVs env = go
rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs)
-rhsFVs env (StgRhsClosure _ ccs uf bs body)
+rhsFVs env (StgRhsClosure _ ccs uf bs body typ)
| (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body
, let lcl_fvs' = delDVarSetList lcl_fvs bs
- = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs')
-rhsFVs env (StgRhsCon ccs dc mu ts bs)
+ = (StgRhsClosure lcl_fvs' ccs uf bs body' typ, top_fvs, lcl_fvs')
+rhsFVs env (StgRhsCon ccs dc mu ts bs typ)
| (top_fvs, lcl_fvs) <- argsFVs env bs
- = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs)
+ = (StgRhsCon ccs dc mu ts bs typ, top_fvs, lcl_fvs)
argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs)
argsFVs env = foldl' f (emptyVarSet, emptyDVarSet)
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
index e4316beab5..3a055a2201 100644
--- a/compiler/GHC/Stg/InferTags.hs
+++ b/compiler/GHC/Stg/InferTags.hs
@@ -481,7 +481,7 @@ inferTagBind in_env (StgRec pairs)
initSig :: forall p. (Id, GenStgRhs p) -> TagSig
-- Initial signature for the fixpoint loop
initSig (_bndr, StgRhsCon {}) = TagSig TagTagged
-initSig (bndr, StgRhsClosure _ _ _ _ _) =
+initSig (bndr, StgRhsClosure _ _ _ _ _ _) =
fromMaybe defaultSig (idTagSig_maybe bndr)
where defaultSig = (TagSig TagTagged)
@@ -516,13 +516,13 @@ inferTagRhs :: forall p.
-> TagEnv p -- ^
-> GenStgRhs p -- ^
-> (TagSig, GenStgRhs 'InferTaggedBinders)
-inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body)
+inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ)
| isDeadEndId bnd_id && (notNull) bndrs
-- See Note [Bottom functions are TagTagged]
- = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body')
+ = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ)
| otherwise
= --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $
- (TagSig info', StgRhsClosure ext cc upd out_bndrs body')
+ (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ)
where
out_bndrs
| Just marks <- idCbvMarks_maybe bnd_id
@@ -553,11 +553,11 @@ inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body)
| otherwise -> TagDunno
in (id, TagSig tag)
-inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args)
+inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ)
-- Constructors, which have untagged arguments to strict fields
-- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno
= --pprTrace "inferTagRhsCon" (ppr grp_ids) $
- (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args)
+ (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ)
-- Adjust let semantics to the targeted backend.
-- See Note [Tag inference for interpreted code]
diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
index fac784d5fc..6c85475a4a 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -1,4 +1,4 @@
---
+
-- Copyright (c) 2019 Andreas Klebinger
--
@@ -343,7 +343,7 @@ rewriteBinds top_flag b@(StgRec binds) =
-- Rewrite a RHS
rewriteRhs :: (Id,TagSig) -> InferStgRhs
-> RM (TgStgRhs)
-rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs_ #-} do
+rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewriteRhs_ #-} do
-- pprTraceM "rewriteRhs" (ppr _id)
-- Look up the nodes representing the constructor arguments.
@@ -359,7 +359,7 @@ rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs
let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]
if (null evalArgs)
- then return $! (StgRhsCon ccs con cn ticks args)
+ then return $! (StgRhsCon ccs con cn ticks args typ)
else do
--assert not (isTaggedSig tagSig)
-- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id
@@ -373,11 +373,11 @@ rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs
fvs <- fvArgs args
-- lcls <- getFVs
-- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)
- return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr)
-rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do
+ return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) typ
+rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do
withBinders NotTopLevel args $
withClosureLcls fvs $
- StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body
+ StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ
-- return (closure)
fvArgs :: [StgArg] -> RM DVarSet
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index 876b44fe3f..f6576c20ab 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -198,20 +198,20 @@ liftRhs
-- as lambda binders, discarding all free vars.
-> LlStgRhs
-> LiftM OutStgRhs
-liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)
+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args typ)
= assertPpr (isNothing mb_former_fvs)
(text "Should never lift a constructor"
$$ pprStgRhs panicStgPprOpts rhs) $
- StgRhsCon ccs con mn ts <$> traverse liftArgs args
-liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =
+ StgRhsCon ccs con mn ts <$> traverse liftArgs args <*> pure typ
+liftRhs Nothing (StgRhsClosure _ ccs upd infos body typ) =
-- This RHS wasn't lifted.
withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
- StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body
-liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) =
+ StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body <*> pure typ
+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body typ) =
-- This RHS was lifted. Insert extra binders for @former_fvs@.
withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do
let bndrs'' = dVarSetElems former_fvs ++ bndrs'
- StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body
+ StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body <*> pure typ
liftArgs :: InStgArg -> LiftM OutStgArg
liftArgs a@(StgLitArg _) = pure a
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index abc4c69ca0..cf3db0b752 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -241,10 +241,10 @@ tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
-tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args)
- = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args)
-tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
- = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
+tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args typ)
+ = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args typ)
+tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body typ)
+ = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body' typ)
where
bndrs' = map BoringBinder bndrs
(body_skel, body_arg_occs, body') = tagSkeletonExpr body
@@ -330,7 +330,7 @@ goodToLift cfg top_lvl rec_flag expander pairs scope = decide
-- We don't lift updatable thunks or constructors
any_memoized = any is_memoized_rhs rhss
is_memoized_rhs StgRhsCon{} = True
- is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd
+ is_memoized_rhs (StgRhsClosure _ _ upd _ _ _) = isUpdatable upd
-- Don't lift binders occurring as arguments. This would result in complex
-- argument expressions which would have to be given a name, reintroducing
@@ -399,7 +399,7 @@ goodToLift cfg top_lvl rec_flag expander pairs scope = decide
rhsLambdaBndrs :: LlStgRhs -> [Id]
rhsLambdaBndrs StgRhsCon{} = []
-rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs
+rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _ _) = map binderInfoBndr bndrs
-- | The size in words of a function closure closing over the given 'Id's,
-- including the header.
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
index 930c3963b2..6a8e0f49f8 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -197,12 +197,12 @@ collectFloats = go (0 :: Int) []
-- | Omitting this makes for strange closure allocation schemes that crash the
-- GC.
removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
-removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
+removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body typ)
| isCurrentCCS ccs
- = StgRhsClosure ext dontCareCCS upd bndrs body
-removeRhsCCCS (StgRhsCon ccs con mu ts args)
+ = StgRhsClosure ext dontCareCCS upd bndrs body typ
+removeRhsCCCS (StgRhsCon ccs con mu ts args typ)
| isCurrentCCS ccs
- = StgRhsCon dontCareCCS con mu ts args
+ = StgRhsCon dontCareCCS con mu ts args typ
removeRhsCCCS rhs = rhs
-- | The analysis monad consists of the following 'RWST' components:
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 535c16f3a8..8315e185e0 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -222,25 +222,25 @@ checkNoCurrentCCS rhs = do
opts <- getStgPprOpts
let rhs' = pprStgRhs opts rhs
case rhs of
- StgRhsClosure _ ccs _ _ _
+ StgRhsClosure _ ccs _ _ _ _
| isCurrentCCS ccs
-> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
- StgRhsCon ccs _ _ _ _
+ StgRhsCon ccs _ _ _ _ _
| isCurrentCCS ccs
-> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
_ -> return ()
lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
-lintStgRhs (StgRhsClosure _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ [] expr _)
= lintStgExpr expr
-lintStgRhs (StgRhsClosure _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ binders expr _)
= addLoc (LambdaBodyOf binders) $
addInScopeVars binders $
lintStgExpr expr
-lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do
+lintStgRhs rhs@(StgRhsCon _ con _ _ args _) = do
opts <- getStgPprOpts
when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs
index 4f35d1af92..6cf7a2cfcc 100644
--- a/compiler/GHC/Stg/Stats.hs
+++ b/compiler/GHC/Stg/Stats.hs
@@ -122,10 +122,10 @@ statBinding top (StgRec pairs)
statRhs :: Bool -> (Id, StgRhs) -> StatEnv
-statRhs top (_, StgRhsCon _ _ _ _ _)
+statRhs top (_, StgRhsCon _ _ _ _ _ _)
= countOne (ConstructorBinds top)
-statRhs top (_, StgRhsClosure _ _ u _ body)
+statRhs top (_, StgRhsClosure _ _ u _ body _)
= statExpr body `combineSE`
countOne (
case u of
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 8b0ae6af54..7a4bcbc1f3 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -393,6 +393,7 @@ data GenStgRhs pass
[BinderP pass] -- ^ arguments; if empty, then not a function;
-- as above, order is important.
(GenStgExpr pass) -- ^ body
+ Type -- ^ result type
{-
An example may be in order. Consider:
@@ -422,6 +423,7 @@ important):
ConstructorNumber
[StgTickish]
[StgArg] -- Args
+ Type -- Type, for rewriting to an StgRhsClosure
-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that
-- returns 'empty'.
@@ -439,14 +441,14 @@ noExtFieldSilent = NoExtFieldSilent
-- implications on build time...
stgRhsArity :: StgRhs -> Int
-stgRhsArity (StgRhsClosure _ _ _ bndrs _)
+stgRhsArity (StgRhsClosure _ _ _ bndrs _ _)
= assert (all isId bndrs) $ length bndrs
-- The arity never includes type parameters, but they should have gone by now
stgRhsArity (StgRhsCon {}) = 0
freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
-freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
-freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs
+freeVarsOfRhs (StgRhsCon _ _ _ _ args _) = mkDVarSet [ id | StgVarArg id <- args ]
+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _ _) = fvs
{-
************************************************************************
@@ -892,14 +894,14 @@ instance Outputable AltType where
pprStgRhs :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc
pprStgRhs opts rhs = case rhs of
- StgRhsClosure ext cc upd_flag args body
+ StgRhsClosure ext cc upd_flag args body _
-> hang (hsep [ if stgSccEnabled opts then ppr cc else empty
, ppUnlessOption sdocSuppressStgExts (ppr ext)
, char '\\' <> ppr upd_flag, brackets (interppSP args)
])
4 (pprStgExpr opts body)
- StgRhsCon cc con mid _ticks args
+ StgRhsCon cc con mid _ticks args _
-> hcat [ if stgSccEnabled opts then ppr cc <> space else empty
, case mid of
NoNumber -> empty
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index c7d7ebcc6a..de0a9cf519 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -483,14 +483,14 @@ unariseBinding rho (StgRec xrhss)
= StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
-unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr typ)
= do (rho', args1) <- unariseFunArgBinders rho args
expr' <- unariseExpr rho' expr
- return (StgRhsClosure ext ccs update_flag args1 expr')
+ return (StgRhsClosure ext ccs update_flag args1 expr' typ)
-unariseRhs rho (StgRhsCon ccs con mu ts args)
+unariseRhs rho (StgRhsCon ccs con mu ts args typ)
= assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
- return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
+ return (StgRhsCon ccs con mu ts (unariseConArgs rho args) typ)
--------------------------------------------------------------------------------
View Lorry Controller Status