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 files changed, 140 insertions, 147 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)) =
diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T
index 5401a11e73..a35885361d 100644
--- a/testsuite/tests/dependent/should_compile/all.T
+++ b/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, [''])
diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T
index 43bccab16e..5e8f58de4a 100644
--- a/testsuite/tests/rep-poly/all.T
+++ b/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, [''])
 
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 7ef8cc4fa6..44a068de7a 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/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, [''])
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index e3b3fb4817..43bf6bce17 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/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'])