[Git][ghc/ghc][master] Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Apr 26 18:51:54 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00
Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364)
Carry the actual type of an expression through the PreStgRhs and into GenStgRhs
for use in later stages. Currently this is used in the JavaScript backend to fix
some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2,
T13822, T14749.
- - - - -
27 changed files:
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/BcPrep.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/Stg/FVs.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/Lift.hs
- compiler/GHC/Stg/Lift/Analysis.hs
- compiler/GHC/Stg/Lift/Monad.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Stats.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Sinker.hs
- compiler/GHC/StgToJS/StgUtils.hs
- testsuite/tests/dependent/should_compile/all.T
- testsuite/tests/rep-poly/all.T
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_run/all.T
Changes:
=====================================
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
=====================================
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
=====================================
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 at Breakpoint{} expr)) = do
+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp at 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 at 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
=====================================
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
=====================================
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 ()
=====================================
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)
=====================================
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]
=====================================
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
=====================================
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 at .
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
=====================================
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.
=====================================
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:
=====================================
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" $$
=====================================
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
=====================================
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
=====================================
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)
--------------------------------------------------------------------------------
=====================================
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.
=====================================
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
=====================================
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
=====================================
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"))
=====================================
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
=====================================
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
=====================================
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)
=====================================
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)) =
=====================================
testsuite/tests/dependent/should_compile/all.T
=====================================
@@ -40,7 +40,7 @@ test('T13938', [req_th, extra_files(['T13938a.hs'])], makefile_test, ['T13938'])
test('T14556', normal, compile, [''])
test('T14720', normal, compile, [''])
test('T14066a', normal, compile, [''])
-test('T14749', js_broken(22364), compile, [''])
+test('T14749', normal, compile, [''])
test('T14991', normal, compile, [''])
test('DkNameRes', normal, compile, [''])
test('T15346', normal, compile, [''])
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -85,7 +85,7 @@ test('RepPolyUnliftedNewtype', normal, compile,
['-fno-warn-partial-type-signatures -fno-warn-deprecated-flags'])
test('RepPolyWildcardPattern', normal, compile_fail, [''])
test('RepPolyWrappedVar', normal, compile_fail, [''])
-test('RepPolyWrappedVar2', js_broken(23280), compile, [''])
+test('RepPolyWrappedVar2', normal, compile, [''])
test('UnliftedNewtypesCoerceFail', normal, compile_fail, [''])
test('UnliftedNewtypesLevityBinder', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -587,7 +587,7 @@ test('T13651a', normal, compile, [''])
test('T13680', normal, compile, [''])
test('T13785', normal, compile, [''])
test('T13804', normal, compile, [''])
-test('T13822', js_broken(22364), compile, [''])
+test('T13822', normal, compile, [''])
test('T13848', normal, compile, [''])
test('T13879', normal, compile, [''])
test('T13881', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -126,7 +126,7 @@ test('KindInvariant', normal, ghci_script, ['KindInvariant.script'])
# unboxed sums and ghci does not support those yet.
test('StrictPats', omit_ways(['ghci']), compile_and_run, [''])
test('T12809', omit_ways(['ghci']), compile_and_run, [''])
-test('EtaExpandLevPoly', [omit_ways(['ghci']), js_broken(22576)], compile_and_run, [''])
+test('EtaExpandLevPoly', [omit_ways(['ghci'])], compile_and_run, [''])
test('TestTypeableBinary', normal, compile_and_run, [''])
test('Typeable1', normal, compile_fail, ['-Werror'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77f506b888624b4fd30205fb8512f39435055a27
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77f506b888624b4fd30205fb8512f39435055a27
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230426/4bece9e5/attachment-0001.html>
More information about the ghc-commits
mailing list