diff options
Diffstat (limited to 'compiler/GHC/Stg')
-rw-r--r-- | compiler/GHC/Stg/CSE.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Stg/Debug.hs | 122 | ||||
-rw-r--r-- | compiler/GHC/Stg/DepAnal.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Stg/FVs.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift/Analysis.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift/Monad.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lint.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Stg/Stats.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 34 | ||||
-rw-r--r-- | compiler/GHC/Stg/Unarise.hs | 12 |
11 files changed, 175 insertions, 44 deletions
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index b9e6782f77..bc266d20ba 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -292,8 +292,8 @@ stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body) = let body' = stgCseExpr (initEnv in_scope) body in StgRhsClosure ext ccs upd args body' -stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args) - = StgRhsCon ccs dataCon args +stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args) + = StgRhsCon ccs dataCon mu ticks args ------------------------------ -- The actual AST traversal -- @@ -326,11 +326,11 @@ stgCseExpr env (StgCase scrut bndr ty alts) -- A constructor application. -- To be removed by a variable use when found in the CSE environment -stgCseExpr env (StgConApp dataCon args tys) +stgCseExpr env (StgConApp dataCon n args tys) | Just bndr' <- envLookup dataCon args' env = StgApp bndr' [] | otherwise - = StgConApp dataCon args' tys + = StgConApp dataCon n args' tys where args' = substArgs env args -- Let bindings @@ -395,7 +395,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 args) +stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args) | Just other_bndr <- envLookup dataCon args' env , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] = let env' = addSubst bndr other_bndr env @@ -403,7 +403,7 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args) | otherwise = let env' = addDataCon bndr dataCon args' env -- see note [Case 1: CSEing allocated closures] - pair = (bndr, StgRhsCon ccs dataCon args') + pair = (bndr, StgRhsCon ccs dataCon mu ticks args') in (Just pair, env') where args' = substArgs env args diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs index e6e85f7db7..823334e2aa 100644 --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -16,7 +16,6 @@ import GHC.Unit.Module import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan) import GHC.Data.FastString import GHC.Driver.Session -import GHC.Driver.Ppr import Control.Monad (when) import Control.Monad.Trans.Reader @@ -25,6 +24,8 @@ import Control.Monad.Trans.Class import GHC.Types.Unique.Map import GHC.Types.SrcLoc import Control.Applicative +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) data SpanWithLabel = SpanWithLabel RealSrcSpan String @@ -64,9 +65,9 @@ collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do e' <- collectExpr e recordInfo bndr e' return $ StgRhsClosure ext cc us bs e' -collectStgRhs _bndr (StgRhsCon cc dc args) = do - --n' <- incDc dc ticks - return (StgRhsCon cc dc args) +collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do + n' <- numberDataCon dc ticks + return (StgRhsCon cc dc n' ticks args) recordInfo :: Id -> StgExpr -> M () @@ -86,9 +87,9 @@ collectExpr = go where go (StgApp occ as) = return $ StgApp occ as go (StgLit lit) = return $ StgLit lit - go (StgConApp dc as tys) = do --- n' <- incDc dc [] - return (StgConApp dc as tys) + go (StgConApp dc _mn as tys) = do + n' <- numberDataCon dc [] + return (StgConApp dc n' as tys) go (StgOpApp op as ty) = return (StgOpApp op as ty) go (StgCase scrut bndr ty alts) = StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts @@ -129,7 +130,6 @@ recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M () recordStgIdPosition id best_span ss = do dflags <- asks rDynFlags when (gopt Opt_InfoTableMap dflags) $ do - let tyString = showPpr dflags (idType id) cc <- asks rSpan --Useful for debugging why a certain Id gets given a certain span --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss) @@ -138,3 +138,109 @@ recordStgIdPosition id best_span ss = do Just (SpanWithLabel rss d) -> lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, rss, d)}) +numberDataCon :: DataCon -> [Tickish Id] -> M ConstructorNumber +-- Unboxed tuples and sums do not allocate so they +-- have no info tables. +numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber +numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber +numberDataCon dc ts = do + dflags <- asks rDynFlags + if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do + env <- lift get + mcc <- asks rSpan + let mbest_span = selectTick ts <|> mcc + case mbest_span of + Nothing -> return NoNumber + Just (SpanWithLabel rss l) -> do + let best_span = (rss, l) + let dcMap' = alterUniqMap (maybe (Just ((0, best_span) :| [] )) + (\xs@((k, _):|_) -> Just ((k + 1, best_span) `NE.cons` xs))) (provDC env) dc + lift $ put (env { provDC = dcMap' }) + let r = lookupUniqMap dcMap' dc + return $ case r of + Nothing -> NoNumber + Just res -> Numbered (fst (NE.head res)) + +selectTick :: [Tickish Id] -> Maybe SpanWithLabel +selectTick [] = Nothing +selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d) +selectTick (_:ts) = selectTick ts + +{- +Note [Mapping Info Tables to Source Positions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This note describes what the `-finfo-table-map` flag achieves. + +When debugging memory issues it is very useful to be able to map a specific closure +to a position in the source. The prime example is being able to map a THUNK to +a specific place in the source program, the mapping is usually quite precise because +a fresh info table is created for each distinct THUNK. + +There are three parts to the implementation + +1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to +some specific closures. +2. In StgToCmm, the actually used info tables are recorded in an IORef, this +is important as it's hard to predict beforehand what code generation will do +and which ids will end up in the generated program. +3. During code generation, a mapping from the info table to the statically +determined location is emitted which can then be queried at runtime by +various tools. + +-- Giving Source Locations to Closures + +At the moment thunk and constructor closures are added to the map. This information +is collected in the `InfoTableProvMap` which provides a mapping from: + +1. Data constructors to a list of where they are used. +2. `Name`s and where they originate from. + +During the CoreToStg phase, this map is populated whenever something is turned into +a StgRhsClosure or an StgConApp. The current source position is recorded +depending on the location indicated by the surrounding SourceNote. + +The functions which add information to the map are `recordStgIdPosition` and +`numberDataCon`. + +When the -fdistinct-constructor-tables` flag is turned on then every +usage of a data constructor gets its own distinct info table. This is orchestrated +in `collectExpr` where an incrementing number is used to distinguish each +occurrence of a data constructor. + +-- StgToCmm + +The info tables which are actually used in the generated program are recorded during the +conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function. +All the used info tables are recorded in the `cgs_used_info` field. This step +is necessary because when the information about names is collected in the previous +phase it's unpredictable about which names will end up needing info tables. If +you don't record which ones are actually used then you end up generating code +which references info tables which don't exist. + +-- Code Generation + +The output of these two phases is combined together during code generation. +A C stub is generated which +creates the static map from info table pointer to the information about where that +info table was created from. This is created by `ipInitCode` in the same manner as a +C stub is generated for cost centres. + +This information can be consumed in two ways. + +1. The complete mapping is emitted into the eventlog so that external tools such +as eventlog2html can use the information with the heap profile by info table mode. +2. The `lookupIPE` function can be used via the `whereFrom#` primop to introspect +information about a closure in a running Haskell program. + +Note [Distinct Info Tables for Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the old times, each usage of a data constructor used the same info table. +This made it impossible to distinguish which actual usuage of a data constructor was +contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you +can cause code generation to generate a distinct info table for each usage of +a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor +was responsible for each allocation. + +-} diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs index 9bf4249f6f..0e53ffcca1 100644 --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -62,7 +62,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs) rhs bounds (StgRhsClosure _ _ _ as e) = expr (extendVarSetList bounds as) e - rhs bounds (StgRhsCon _ _ as) = + rhs bounds (StgRhsCon _ _ _ _ as) = args bounds as var :: BVs -> Var -> FVs @@ -87,7 +87,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs) expr _ StgLit{} = emptyVarSet - expr bounds (StgConApp _ as _) = + expr bounds (StgConApp _ _ as _) = args bounds as expr bounds (StgOpApp _ as _) = args bounds as diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index bd699a1fe1..ce40307420 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -124,7 +124,7 @@ expr env = go go (StgApp occ as) = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ])) go (StgLit lit) = (StgLit lit, emptyDVarSet) - go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) + go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as) go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) where @@ -156,7 +156,7 @@ rhs env (StgRhsClosure _ ccs uf bndrs body) -- See Note [Tracking local binders] (body', body_fvs) = expr (addLocals bndrs env) body fvs = delDVarSetList body_fvs bndrs -rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) +rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as) alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index 8f2337120e..4e7b66f23d 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -199,9 +199,9 @@ liftRhs -- as lambda binders, discarding all free vars. -> LlStgRhs -> LiftM OutStgRhs -liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args) +liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args) = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) - StgRhsCon ccs con <$> traverse liftArgs args + StgRhsCon ccs con mn ts <$> traverse liftArgs args liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> @@ -227,7 +227,7 @@ liftExpr (StgApp f args) = do fvs' <- formerFreeVars f let top_lvl_args = map StgVarArg fvs' ++ args' pure (StgApp f' top_lvl_args) -liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys +liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty liftExpr (StgCase scrut info ty alts) = do scrut' <- liftExpr scrut diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 314e010ead..884489e0f7 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -114,9 +114,10 @@ type instance BinderP 'LiftLams = BinderInfo type instance XRhsClosure 'LiftLams = DIdSet type instance XLet 'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton +type instance XConApp 'LiftLams = ConstructorNumber freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet -freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] +freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs -- | Captures details of the syntax tree relevant to the cost model, such as @@ -210,8 +211,8 @@ tagSkeletonTopBind bind = bind' tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr) tagSkeletonExpr (StgLit lit) = (NilSk, emptyVarSet, StgLit lit) -tagSkeletonExpr (StgConApp con args tys) - = (NilSk, mkArgOccs args, StgConApp con args tys) +tagSkeletonExpr (StgConApp con mn args tys) + = (NilSk, mkArgOccs args, StgConApp con mn args tys) tagSkeletonExpr (StgOpApp op args ty) = (NilSk, mkArgOccs args, StgOpApp op args ty) tagSkeletonExpr (StgApp f args) @@ -314,8 +315,8 @@ 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 args) - = (NilSk, mkArgOccs args, StgRhsCon ccs dc args) +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') where diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 4b99521066..e43bda363d 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -194,9 +194,9 @@ removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body) | isCurrentCCS ccs = StgRhsClosure ext dontCareCCS upd bndrs body -removeRhsCCCS (StgRhsCon ccs con args) +removeRhsCCCS (StgRhsCon ccs con mu ts args) | isCurrentCCS ccs - = StgRhsCon dontCareCCS con args + = StgRhsCon dontCareCCS con mu ts args 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 0ee7381fe0..bf52840f5c 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -150,7 +150,7 @@ checkNoCurrentCCS rhs = do 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 () @@ -165,7 +165,7 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr) addInScopeVars binders $ lintStgExpr expr -lintStgRhs rhs@(StgRhsCon _ con args) = do +lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do opts <- getStgPprOpts addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ @@ -181,7 +181,7 @@ lintStgExpr (StgApp fun args) = do lintStgVar fun mapM_ lintStgArg args -lintStgExpr app@(StgConApp con args _arg_tys) = do +lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags when (lf_unarised lf && isUnboxedSumDataCon con) $ do diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs index 0f806a3175..debe53201f 100644 --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -124,7 +124,7 @@ statBinding top (StgRec pairs) statRhs :: Bool -> (Id, StgRhs) -> StatEnv -statRhs top (_, StgRhsCon _ _ _) +statRhs top (_, StgRhsCon _ _ _ _ _) = countOne (ConstructorBinds top) statRhs top (_, StgRhsClosure _ _ u _ body) @@ -148,7 +148,7 @@ statExpr :: StgExpr -> StatEnv statExpr (StgApp _ _) = countOne Applications statExpr (StgLit _) = countOne Literals -statExpr (StgConApp _ _ _)= countOne ConstructorApps +statExpr (StgConApp _ _ _ _)= countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e) = statExpr e diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 25d01079df..185433100a 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -25,12 +25,14 @@ module GHC.Stg.Syntax ( GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgAlt, AltType(..), - StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, + StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, XConApp, NoExtFieldSilent, noExtFieldSilent, OutputablePass, UpdateFlag(..), isUpdatable, + ConstructorNumber(..), + -- a set of synonyms for the vanilla parameterisation StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, @@ -242,6 +244,7 @@ literals. -- StgConApp is vital for returning unboxed tuples or sums -- which can't be let-bound | StgConApp DataCon + (XConApp pass) [StgArg] -- Saturated [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise @@ -416,6 +419,8 @@ important): -- from static closure. DataCon -- Constructor. Never an unboxed tuple or sum, as those -- are not allocated. + ConstructorNumber + [Tickish Id] [StgArg] -- Args {- @@ -478,6 +483,20 @@ type family XLet (pass :: StgPass) type instance XLet 'Vanilla = NoExtFieldSilent type instance XLet 'CodeGen = NoExtFieldSilent +type family XConApp (pass :: StgPass) +type instance XConApp 'Vanilla = ConstructorNumber +type instance XConApp 'CodeGen = ConstructorNumber + +-- | When `-fdistinct-constructor-tables` is turned on then +-- each usage of a constructor is given an unique number and +-- an info table is generated for each different constructor. +data ConstructorNumber = + NoNumber | Numbered Int + +instance Outputable ConstructorNumber where + ppr NoNumber = empty + ppr (Numbered n) = text "#" <> ppr n + type family XLetNoEscape (pass :: StgPass) type instance XLetNoEscape 'Vanilla = NoExtFieldSilent type instance XLetNoEscape 'CodeGen = NoExtFieldSilent @@ -486,7 +505,7 @@ stgRhsArity :: StgRhs -> Int 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 +stgRhsArity (StgRhsCon _ _ _ _ _) = 0 {- ************************************************************************ @@ -648,6 +667,7 @@ likes terminators instead... Ditto for case alternatives. type OutputablePass pass = ( Outputable (XLet pass) + , Outputable (XConApp pass) , Outputable (XLetNoEscape pass) , Outputable (XRhsClosure pass) , OutputableBndr (BinderP pass) @@ -713,7 +733,7 @@ pprStgExpr opts e = case e of StgLit lit -> ppr lit -- general case StgApp func args -> hang (ppr func) 4 (interppSP args) - StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ] + StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ] StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)] -- special case: let v = <very specific thing> @@ -816,5 +836,9 @@ pprStgRhs opts rhs = case rhs of ]) 4 (pprStgExpr opts body) - StgRhsCon cc con args - -> hcat [ ppr cc, space, ppr con, text "! ", brackets (sep (map pprStgArg args))] + StgRhsCon cc con mid _ticks args + -> hcat [ ppr cc, space + , case mid of + NoNumber -> empty + Numbered n -> hcat [ppr n, space] + , ppr con, text "! ", brackets (sep (map pprStgArg args))] diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 40dff5f33b..c9160ff72a 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -293,9 +293,9 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr) expr' <- unariseExpr rho' expr return (StgRhsClosure ext ccs update_flag args1 expr') -unariseRhs rho (StgRhsCon ccs con args) +unariseRhs rho (StgRhsCon ccs con mu ts args) = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) - return (StgRhsCon ccs con (unariseConArgs rho args)) + return (StgRhsCon ccs con mu ts (unariseConArgs rho args)) -------------------------------------------------------------------------------- @@ -325,13 +325,13 @@ unariseExpr rho e@(StgApp f args) unariseExpr _ (StgLit l) = return (StgLit l) -unariseExpr rho (StgConApp dc args ty_args) +unariseExpr rho (StgConApp dc n args ty_args) | Just args' <- unariseMulti_maybe rho dc args ty_args = return (mkTuple args') | otherwise , let args' = unariseConArgs rho args - = return (StgConApp dc args' (map stgArgType args')) + = return (StgConApp dc n args' (map stgArgType args')) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -345,7 +345,7 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts) -- Handle strict lets for tuples and sums: -- case (# a,b #) of r -> rhs -- and analogously for sums - | StgConApp dc args ty_args <- scrut + | StgConApp dc _n args ty_args <- scrut , Just args' <- unariseMulti_maybe rho dc args ty_args = elimCase rho args' bndr alt_ty alts @@ -756,7 +756,7 @@ isUnboxedTupleBndr :: Id -> Bool isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) tagAltTy :: AltType tagAltTy = PrimAlt IntRep |