summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/ByteCode/Instr.hs2
-rw-r--r--compiler/GHC/CoreToStg.hs24
-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
-rw-r--r--compiler/GHC/StgToByteCode.hs6
-rw-r--r--compiler/GHC/StgToCmm.hs4
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs4
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs4
-rw-r--r--compiler/GHC/StgToJS/CodeGen.hs10
-rw-r--r--compiler/GHC/StgToJS/Expr.hs49
-rw-r--r--compiler/GHC/StgToJS/Sinker.hs20
-rw-r--r--compiler/GHC/StgToJS/StgUtils.hs20
23 files changed, 136 insertions, 143 deletions
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
index 4fbfaa76a6..a35c4d1fd9 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -252,7 +252,7 @@ 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
-pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) =
+pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body _typ) =
hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ])
4 (pprStgExprShort opts body)
pprStgRhsShort opts rhs = pprStgRhs opts rhs
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index d70d8acc65..f1ff9088dc 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -691,7 +691,7 @@ coreToStgRhs (bndr, rhs) = do
return (mkStgRhs bndr new_rhs)
-- Represents the RHS of a binding for use with mk(Top)StgRhs.
-data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks
+data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks
-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
@@ -699,7 +699,7 @@ coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
coreToPreStgRhs expr
= extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
do { body' <- coreToStgExpr body
- ; return (PreStgRhs args' body') }
+ ; return (PreStgRhs args' body' (exprType body)) }
where
(args, body) = myCollectBinders expr
args' = filterStgBinders args
@@ -713,13 +713,13 @@ mkTopStgRhs CoreToStgOpts
{ coreToStg_platform = platform
, coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
, coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
- } this_mod ccs bndr (PreStgRhs bndrs rhs)
+ } this_mod ccs bndr (PreStgRhs bndrs rhs typ)
| not (null bndrs)
= -- The list of arguments is non-empty, so not CAF
( StgRhsClosure noExtFieldSilent
dontCareCCS
ReEntrant
- bndrs rhs
+ bndrs rhs typ
, ccs )
-- After this point we know that `bndrs` is empty,
@@ -730,19 +730,19 @@ mkTopStgRhs CoreToStgOpts
= -- CorePrep does this right, but just to make sure
assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
(ppr bndr $$ ppr con $$ ppr args)
- ( StgRhsCon dontCareCCS con mn ticks args, ccs )
+ ( StgRhsCon dontCareCCS con mn ticks args typ, ccs )
-- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
| opt_AutoSccsOnIndividualCafs
= ( StgRhsClosure noExtFieldSilent
caf_ccs
- upd_flag [] rhs
+ upd_flag [] rhs typ
, collectCC caf_cc caf_ccs ccs )
| otherwise
= ( StgRhsClosure noExtFieldSilent
all_cafs_ccs
- upd_flag [] rhs
+ upd_flag [] rhs typ
, ccs )
where
@@ -766,12 +766,12 @@ mkTopStgRhs CoreToStgOpts
-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
-- see Note [Cost-centre initialization plan].
mkStgRhs :: Id -> PreStgRhs -> StgRhs
-mkStgRhs bndr (PreStgRhs bndrs rhs)
+mkStgRhs bndr (PreStgRhs bndrs rhs typ)
| not (null bndrs)
= StgRhsClosure noExtFieldSilent
currentCCS
ReEntrant
- bndrs rhs
+ bndrs rhs typ
-- After this point we know that `bndrs` is empty,
-- so this is not a function binding
@@ -782,15 +782,15 @@ mkStgRhs bndr (PreStgRhs bndrs rhs)
StgRhsClosure noExtFieldSilent
currentCCS
ReEntrant -- ignored for LNE
- [] rhs
+ [] rhs typ
| StgConApp con mn args _ <- unticked_rhs
- = StgRhsCon currentCCS con mn ticks args
+ = StgRhsCon currentCCS con mn ticks args typ
| otherwise
= StgRhsClosure noExtFieldSilent
currentCCS
- upd_flag [] rhs
+ upd_flag [] rhs typ
where
(ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
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)
--------------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index da3c055411..a6eebe9bc9 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -350,8 +350,8 @@ schemeR fvs (nm, rhs)
-- underlying expression
collect :: CgStgRhs -> ([Var], CgStgExpr)
-collect (StgRhsClosure _ _ _ args body) = (args, body)
-collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args [])
+collect (StgRhsClosure _ _ _ args body _) = (args, body)
+collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args [])
schemeR_wrk
:: [Id]
@@ -534,7 +534,7 @@ schemeE d s p e@(StgOpApp {}) = schemeT d s p e
schemeE d s p (StgLetNoEscape xlet bnd body)
= schemeE d s p (StgLet xlet bnd body)
schemeE d s p (StgLet _xlet
- (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args))
+ (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args _typ))
body)
= do -- Special case for a non-recursive let whose RHS is a
-- saturated constructor application.
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 428512b805..e33844aa67 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -199,12 +199,12 @@ cgTopBinding logger tmpfs cfg = \case
cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
-cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args)
+cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args _typ)
= cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args)
-- con args are always non-void,
-- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
-cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body)
+cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body _typ)
= assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $ -- There should be no free variables
cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 57cdb1d3f9..1181ed0597 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -250,14 +250,14 @@ cgRhs :: Id
-- (see above)
)
-cgRhs id (StgRhsCon cc con mn _ts args)
+cgRhs id (StgRhsCon cc con mn _ts args _typ)
= withNewTickyCounterCon id con mn $
buildDynCon id mn True cc con (assertNonVoidStgArgs args)
-- con args are always non-void,
-- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
{- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
-cgRhs id (StgRhsClosure fvs cc upd_flag args body)
+cgRhs id (StgRhsClosure fvs cc upd_flag args body _typ)
= do
profile <- getProfile
check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 2450792426..b2d44a0d98 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -200,9 +200,9 @@ cgLetNoEscapeRhsBody
-> Id
-> CgStgRhs
-> FCode (CgIdInfo, FCode ())
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body _typ)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args _typ)
= cgLetNoEscapeClosure bndr local_cc cc []
(StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $
text "StgRhsCon doesn't have type args"))
diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs
index 55be51df9d..fdc431ef4c 100644
--- a/compiler/GHC/StgToJS/CodeGen.hs
+++ b/compiler/GHC/StgToJS/CodeGen.hs
@@ -290,10 +290,10 @@ genToplevelDecl i rhs = do
genToplevelConEntry :: Id -> CgStgRhs -> G JStat
genToplevelConEntry i rhs = case rhs of
- StgRhsCon _cc con _mu _ts _args
+ StgRhsCon _cc con _mu _ts _args _typ
| isDataConWorkId i
-> genSetConInfo i con (stgRhsLive rhs) -- NoSRT
- StgRhsClosure _ _cc _upd_flag _args _body
+ StgRhsClosure _ _cc _upd_flag _args _body _typ
| Just dc <- isDataConWorkId_maybe i
-> genSetConInfo i dc (stgRhsLive rhs) -- srt
_ -> pure mempty
@@ -321,11 +321,11 @@ mkDataEntry = ValExpr $ JFunc [] returnStack
genToplevelRhs :: Id -> CgStgRhs -> G JStat
-- general cases:
genToplevelRhs i rhs = case rhs of
- StgRhsCon cc con _mu _tys args -> do
+ StgRhsCon cc con _mu _tys args _typ -> do
ii <- identForId i
allocConStatic ii cc con args
return mempty
- StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do
+ StgRhsClosure _ext cc _upd_flag {- srt -} args body typ -> do
{-
algorithm:
- collect all Id refs that are in the global id cache
@@ -335,7 +335,7 @@ genToplevelRhs i rhs = case rhs of
-}
eid@(TxtI eidt) <- identForEntryId i
(TxtI idt) <- identForId i
- body <- genBody (initExprCtx i) i R2 args body
+ body <- genBody (initExprCtx i) R2 args body typ
global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body)
let lidents = map global_ident global_occs
let lids = map global_id global_occs
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs
index 9f5a1f6d0a..0b8e34e14b 100644
--- a/compiler/GHC/StgToJS/Expr.hs
+++ b/compiler/GHC/StgToJS/Expr.hs
@@ -74,7 +74,6 @@ import GHC.Core.Type hiding (typeSize)
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
import qualified Control.Monad.Trans.State.Strict as State
import GHC.Data.FastString
@@ -148,7 +147,7 @@ genBind ctx bndr =
ctx' = ctxClearLneFrame ctx
assign :: Id -> CgStgRhs -> G (Maybe JStat)
- assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr)
+ assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr _typ)
| let strip = snd . stripStgTicksTop (not . tickishIsCode)
, StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr
, StgApp selectee [] <- strip sel_expr
@@ -168,7 +167,7 @@ genBind ctx bndr =
([tgt], [the_fvj]) -> return $ Just
(tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])
_ -> panic "genBind.assign: invalid size"
- assign b (StgRhsClosure _ext _ccs _upd [] expr)
+ assign b (StgRhsClosure _ext _ccs _upd [] expr _typ)
| snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do
d <- declVarsForId b
tgt <- varsForId b
@@ -180,9 +179,9 @@ genBind ctx bndr =
addEvalRhs c [] = c
addEvalRhs c ((b,r):xs)
- | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs
- | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs
- | otherwise = addEvalRhs c xs
+ | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs
+ | (StgRhsClosure _ _ ReEntrant _ _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs
+ | otherwise = addEvalRhs c xs
genBindLne :: HasDebugCallStack
=> ExprCtx
@@ -223,7 +222,7 @@ genBindLne ctx bndr = do
-- is initially set to null, changed to h$blackhole when the thunk is being evaluated.
--
genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
-genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
+genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) =
resetSlots $ do
let payloadSize = ctxLneFrameSize ctx
vars = ctxLneFrameVars ctx
@@ -238,7 +237,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
])
| otherwise = mempty
lvs <- popLneFrame True payloadSize ctx
- body <- genBody ctx i R1 args body
+ body <- genBody ctx R1 args body typ
ei@(TxtI eii) <- identForEntryId i
sr <- genStaticRefsRhs rhs
let f = JFunc [] (bh <> lvs <> body)
@@ -251,7 +250,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
CIStackFrame
sr
emitToplevel (ei ||= toJExpr f)
-genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do
+genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do
let payloadSize = ctxLneFrameSize ctx
ei@(TxtI _eii) <- identForEntryId i
-- di <- varForDataConWorker con
@@ -265,12 +264,12 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do
-- | Generate the entry function for a local closure
genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
genEntry _ _i StgRhsCon {} = return ()
-genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do
+genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = resetSlots $ do
let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body
ll <- loadLiveFun live
llv <- verifyRuntimeReps live
upd <- genUpdFrame upd_flag i
- body <- genBody entryCtx i R2 args body
+ body <- genBody entryCtx R2 args body typ
ei@(TxtI eii) <- identForEntryId i
et <- genEntryType args
setcc <- ifProfiling $
@@ -302,12 +301,12 @@ genEntryType args0 = do
-- | Generate the body of an object
genBody :: HasDebugCallStack
=> ExprCtx
- -> Id
-> StgReg
-> [Id]
-> CgStgExpr
+ -> Type
-> G JStat
-genBody ctx i startReg args e = do
+genBody ctx startReg args e typ = do
-- load arguments into local variables
la <- do
args' <- concatMapM genIdArgI args
@@ -318,7 +317,7 @@ genBody ctx i startReg args e = do
-- compute PrimReps and their number of slots required to return the result of
-- i applied to args.
- let res_vars = resultSize args i
+ let res_vars = resultSize typ
-- compute typed expressions for each slot and assign registers
let go_var regs = \case
@@ -359,22 +358,12 @@ genBody ctx i startReg args e = do
-- In case of failure to determine the type, we default to LiftedRep as it's
-- probably what it is.
--
-resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)]
-resultSize args i = result
+resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)]
+resultSize ty = result
where
result = result_reps `zip` result_slots
result_slots = fmap (slotCount . primRepSize) result_reps
- result_reps = trim_args (unwrapType (idType i)) (length args)
-
- trim_args t 0 = typePrimRep t
- trim_args t n
- | Just (_af, _mult, arg, res) <- splitFunTy_maybe t
- , nargs <- length (typePrimRepArgs arg)
- , assert (n >= nargs) True
- = trim_args (unwrapType res) (n - nargs)
- | otherwise
- = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t)
- [LiftedRep]
+ result_reps = typePrimRep ty
-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function
-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False.
@@ -540,19 +529,19 @@ allocCls dynMiddle xs = do
toCl (i, StgRhsCon cc con []) = do
ii <- identForId i
Left <$> (return (decl ii) <> allocCon ii con cc []) -}
- toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do
+ toCl (i, StgRhsCon cc con _mui _ticjs [a] _typ) | isUnboxableCon con = do
ii <- identForId i
ac <- allocCon ii con cc =<< genArg a
pure (Left (decl ii <> ac))
-- dynamics
- toCl (i, StgRhsCon cc con _mu _ticks ar) =
+ toCl (i, StgRhsCon cc con _mu _ticks ar _typ) =
-- fixme do we need to handle unboxed?
Right <$> ((,,,) <$> identForId i
<*> varForDataConWorker con
<*> concatMapM genArg ar
<*> pure cc)
- toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) =
+ toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body _typ)) =
let live = stgLneLiveExpr cl
in Right <$> ((,,,) <$> identForId i
<*> varForEntryId i
diff --git a/compiler/GHC/StgToJS/Sinker.hs b/compiler/GHC/StgToJS/Sinker.hs
index 6df58d4fcf..f758a7ac94 100644
--- a/compiler/GHC/StgToJS/Sinker.hs
+++ b/compiler/GHC/StgToJS/Sinker.hs
@@ -64,11 +64,11 @@ sinkPgm' m pgm =
alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)]
alwaysSinkable (StgRec {}) = []
alwaysSinkable (StgNonRec b rhs) = case rhs of
- StgRhsClosure _ _ _ _ e@(StgLit l)
+ StgRhsClosure _ _ _ _ e@(StgLit l) _
| isSmallSinkableLit l
, isLocal b
-> [(b,e)]
- StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l]
+ StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ
| isSmallSinkableLit l
, isLocal b
, isUnboxableCon dc
@@ -88,9 +88,9 @@ onceSinkable _m (StgNonRec b rhs)
, isLocal b = [(b,e)]
where
getSinkable = \case
- StgRhsCon _ccs dc cnum _ticks args -> Just (StgConApp dc cnum args [])
- StgRhsClosure _ _ _ _ e@(StgLit{}) -> Just e
- _ -> Nothing
+ StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args [])
+ StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e
+ _ -> Nothing
onceSinkable _ _ = []
-- | collect all idents used only once in an argument at the top level
@@ -115,8 +115,8 @@ collectArgsTop = \case
collectArgsTopRhs :: CgStgRhs -> [Id]
collectArgsTopRhs = \case
- StgRhsCon _ccs _dc _mu _ticks args -> concatMap collectArgsA args
- StgRhsClosure {} -> []
+ StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args
+ StgRhsClosure {} -> []
-- | fold over all Id in StgArg in the AST
collectArgs :: CgStgBinding -> [Id]
@@ -126,8 +126,8 @@ collectArgs = \case
collectArgsR :: CgStgRhs -> [Id]
collectArgsR = \case
- StgRhsClosure _x0 _x1 _x2 _x3 e -> collectArgsE e
- StgRhsCon _ccs _con _mu _ticks args -> concatMap collectArgsA args
+ StgRhsClosure _x0 _x1 _x2 _x3 e _typ -> collectArgsE e
+ StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args
collectArgsAlt :: CgStgAlt -> [Id]
collectArgsAlt alt = collectArgsE (alt_rhs alt)
@@ -171,7 +171,7 @@ topSortDecls _m binds = rest ++ nr'
keys = mkUniqSet (map node_key vs)
getV e@(StgNonRec b _) = DigraphNode e b []
getV _ = error "topSortDecls: getV, unexpected binding"
- collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args)) =
+ collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) =
[ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ]
collectDeps _ = []
g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr)
diff --git a/compiler/GHC/StgToJS/StgUtils.hs b/compiler/GHC/StgToJS/StgUtils.hs
index 62c494c3a7..0632ce8fe6 100644
--- a/compiler/GHC/StgToJS/StgUtils.hs
+++ b/compiler/GHC/StgToJS/StgUtils.hs
@@ -67,8 +67,8 @@ bindingRefs u = \case
rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id
rhsRefs u = \case
- StgRhsClosure _ _ _ _ body -> exprRefs u body
- StgRhsCon _ccs d _mu _ticks args -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
+ StgRhsClosure _ _ _ _ body _ -> exprRefs u body
+ StgRhsCon _ccs d _mu _ticks args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
exprRefs u = \case
@@ -97,7 +97,7 @@ hasExport bnd =
StgNonRec b e -> isExportedBind b e
StgRec bs -> any (uncurry isExportedBind) bs
where
- isExportedBind _i (StgRhsCon _cc con _ _ _) =
+ isExportedBind _i (StgRhsCon _cc con _ _ _ _) =
getUnique con == staticPtrDataConKey
isExportedBind _ _ = False
@@ -152,8 +152,8 @@ stgBindRhsLive b =
stgRhsLive :: CgStgRhs -> LiveVars
stgRhsLive = \case
- StgRhsClosure _ _ _ args e -> delDVarSetList (stgExprLive True e) args
- StgRhsCon _ _ _ _ args -> unionDVarSets (map stgArgLive args)
+ StgRhsClosure _ _ _ args e _ -> delDVarSetList (stgExprLive True e) args
+ StgRhsCon _ _ _ _ args _ -> unionDVarSets (map stgArgLive args)
stgArgLive :: StgArg -> LiveVars
stgArgLive = \case
@@ -189,8 +189,8 @@ bindees = \case
StgRec bs -> map fst bs
isUpdatableRhs :: CgStgRhs -> Bool
-isUpdatableRhs (StgRhsClosure _ _ u _ _) = isUpdatable u
-isUpdatableRhs _ = False
+isUpdatableRhs (StgRhsClosure _ _ u _ _ _) = isUpdatable u
+isUpdatableRhs _ = False
stgLneLive' :: CgStgBinding -> [Id]
stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b)
@@ -241,9 +241,9 @@ inspectInlineBinding v = \case
inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id
inspectInlineRhs v i = \case
- StgRhsCon{} -> addOneToUniqSet v i
- StgRhsClosure _ _ ReEntrant _ _ -> addOneToUniqSet v i
- _ -> v
+ StgRhsCon{} -> addOneToUniqSet v i
+ StgRhsClosure _ _ ReEntrant _ _ _ -> addOneToUniqSet v i
+ _ -> v
isInlineForeignCall :: ForeignCall -> Bool
isInlineForeignCall (CCall (CCallSpec _ cconv safety)) =
View Lorry Controller Status