diff options
-rw-r--r-- | compiler/GHC/Core/Lint.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 110 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/CallArity.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/CoreToStg.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 142 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 2 |
9 files changed, 227 insertions, 79 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 9275229375..76d961c91e 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -670,10 +670,11 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- Check that the binder's arity is within the bounds imposed by -- the type and the strictness signature. See Note [exprArity invariant] -- and Note [Trimming arity] - ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) + + ; checkL (typeArity (idType binder) >= idArity binder) (text "idArity" <+> ppr (idArity binder) <+> text "exceeds typeArity" <+> - ppr (length (typeArity (idType binder))) <> colon <+> + ppr (typeArity (idType binder)) <> colon <+> ppr binder) ; case splitDmdSig (idDmdSig binder) of diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index b615202e65..ed08f6c70d 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -11,7 +11,8 @@ -- | Arity and eta expansion module GHC.Core.Opt.Arity - ( manifestArity, joinRhsArity, exprArity, typeArity + ( manifestArity, joinRhsArity, exprArity + , typeArity, typeOneShots , exprEtaExpandArity, findRhsArity , etaExpand, etaExpandAT , exprBotStrictness_maybe @@ -19,7 +20,7 @@ module GHC.Core.Opt.Arity -- ** ArityType , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType - , arityTypeArity, maxWithArity, idArityType + , arityTypeArity, maxWithArity, minWithArity, idArityType -- ** Join points , etaExpandToJoinPoint, etaExpandToJoinPointRule @@ -119,14 +120,17 @@ joinRhsArity _ = 0 --------------- exprArity :: CoreExpr -> Arity -- ^ An approximate, fast, version of 'exprEtaExpandArity' +-- We do /not/ guarantee that exprArity e <= typeArity e +-- You may need to do arity trimming after calling exprArity +-- See Note [Arity trimming] +-- (If we do arity trimming here we have to do it at every cast. exprArity e = go e where go (Var v) = idArity v go (Lam x e) | isId x = go e + 1 | otherwise = go e go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e co) = trim_arity (go e) (coercionRKind co) - -- See Note [exprArity invariant] + go (Cast e _) = go e go (App e (Type _)) = go e go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 -- See Note [exprArity for applications] @@ -134,15 +138,15 @@ exprArity e = go e go _ = 0 - trim_arity :: Arity -> Type -> Arity - trim_arity arity ty = arity `min` length (typeArity ty) - --------------- -typeArity :: Type -> [OneShotInfo] +typeArity :: Type -> Arity +typeArity = length . typeOneShots + +typeOneShots :: Type -> [OneShotInfo] -- How many value arrows are visible in the type? -- We look through foralls, and newtypes --- See Note [exprArity invariant] -typeArity ty +-- See Note [typeArity invariants] +typeOneShots ty = go initRecTc ty where go rec_nts ty @@ -183,33 +187,64 @@ exprBotStrictness_maybe e sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv {- -Note [exprArity invariant] +Note [typeArity invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprArity has the following invariants: +We have the following invariants around typeArity + + (1) In any binding x = e, + idArity f <= typeArity (idType f) - (1) If typeArity (exprType e) = n, + (2) If typeArity (exprType e) = n, then manifestArity (etaExpand e n) = n That is, etaExpand can always expand as much as typeArity says So the case analysis in etaExpand and in typeArity must match - (2) exprArity e <= typeArity (exprType e) - - (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n - - That is, if exprArity says "the arity is n" then etaExpand really - can get "n" manifest lambdas to the top. - Why is this important? Because + - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas actually match that arity, which in turn means that the StgRhs has the right number of lambdas -An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least -for top-level bindings, in which case we would not need the trim_arity -in exprArity. That is a less local change, so I'm going to leave it for today! +Suppose we have + f :: Int -> Int -> Int + f x y = x+y -- Arity 2 + + g :: F Int + g = case x of { True -> f |> co1 + ; False -> g |> co2 } + +Now, we can't eta-expand g to have arity 2, because etaExpand, which works +off the /type/ of the expression, doesn't know how to make an eta-expanded +binding + g = (\a b. case x of ...) |> co +because can't make up `co` or the types of `a` and `b`. + +So invariant (1) ensures that every binding has an arity that is no greater +than the typeArity of the RHS; and invariant (2) ensures that etaExpand +and handle what typeArity says. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Arity trimming, implemented by minWithArity, directly implements +invariant (1) of Note [typeArity invariants]. Failing to do so, and +hence breaking invariant (1) led to #5441. + +How to trim? If we end in topDiv, it's easy. But we must take great care with +dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), +we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that +claims that ((\x y. error "urk") |> co) diverges when given one argument, +which it absolutely does not. And Bad Things happen if we think something +returns bottom when it doesn't (#16066). + +So, if we need to trim a dead-ending arity type, switch (conservatively) to +topDiv. + +Historical note: long ago, we unconditionally switched to topDiv when we +encountered a cast, but that is far too conservative: see #5475 Note [Newtype classes and eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -601,6 +636,9 @@ expandableArityType at = arityTypeArity at > 0 isDeadEndArityType :: ArityType -> Bool isDeadEndArityType (AT _ div) = isDeadEndDiv div +----------------------- +infixl 2 `maxWithArity`, `minWithArity` + -- | Expand a non-bottoming arity type so that it has at least the given arity. maxWithArity :: ArityType -> Arity -> ArityType maxWithArity at@(AT oss div) !ar @@ -610,12 +648,13 @@ maxWithArity at@(AT oss div) !ar -- | Trim an arity type so that it has at most the given arity. -- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in --- 'ABot'. +-- 'ABot'. See Note [Arity trimming] minWithArity :: ArityType -> Arity -> ArityType minWithArity at@(AT oss _) ar | oss `lengthAtMost` ar = at | otherwise = AT (take ar oss) topDiv +---------------------- takeWhileOneShot :: ArityType -> ArityType takeWhileOneShot (AT oss div) | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv @@ -669,7 +708,9 @@ findRhsArity opts bndr rhs old_arity next_at = step cur_at step :: ArityType -> ArityType - step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $ + step at = -- pprTrace "step" (vcat [ ppr bndr <+> ppr at <+> ppr (arityType env rhs) + -- , ppr (idType bndr) + -- , ppr (typeArity (idType bndr)) ]) $ arityType env rhs where env = extendSigEnv (findRhsArityEnv opts) bndr at @@ -1010,15 +1051,6 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of ---------------- arityType :: ArityEnv -> CoreExpr -> ArityType -arityType env (Cast e co) - = minWithArity (arityType env e) co_arity -- See Note [Arity trimming] - where - co_arity = length (typeArity (coercionRKind co)) - -- See Note [exprArity invariant] (2); must be true of - -- arityType too, since that is how we compute the arity - -- of variables, and they in turn affect result of exprArity - -- #5441 is a nice demo - arityType env (Var v) | v `elemVarSet` ae_joins env = botArityType -- See Note [Eta-expansion and join points] @@ -1027,6 +1059,9 @@ arityType env (Var v) | otherwise = idArityType v +arityType env (Cast e _) + = arityType env e + -- Lambdas; increase arity arityType env (Lam x e) | isId x = arityLam x (arityType env' e) @@ -1051,14 +1086,17 @@ arityType env (App fun arg ) arityType env (Case scrut bndr _ alts) | exprIsDeadEnd scrut || null alts = botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] + | not (pedanticBottoms env) -- See (2) in Note [Dealing with bottom] , myExprIsCheap env scrut (Just (idType bndr)) = alts_type + | exprOkForSpeculation scrut = alts_type | otherwise -- In the remaining cases we may not push = takeWhileOneShot alts_type -- evaluation of the scrutinee in + where env' = delInScope env bndr arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs @@ -1168,7 +1206,7 @@ idArityType v = AT (take (idArity v) one_shots) topDiv where one_shots :: [OneShotInfo] -- One-shot-ness derived from the type - one_shots = typeArity (idType v) + one_shots = typeOneShots (idType v) {- %************************************************************************ @@ -1277,7 +1315,7 @@ Consider We'll get an ArityType for foo of \?1.T. Then we want to eta-expand to - foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co + foo = (\x. \eta{os}. (case x of ...as before...) eta)) |> some_co That 'eta' binder is fresh, and we really want it to have the one-shot flag from the inner \s{os}. By expanding with the diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index 656d6a9fc1..67b9a88875 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -17,7 +17,7 @@ import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Core import GHC.Types.Id -import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Opt.Arity ( typeArity, typeOneShots ) import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) import GHC.Data.Graph.UnVar import GHC.Types.Demand @@ -544,7 +544,7 @@ callArityAnal arity int (Let bind e) -- Which bindings should we look at? -- See Note [Which variables are interesting] isInteresting :: Var -> Bool -isInteresting v = not $ null (typeArity (idType v)) +isInteresting v = not $ null $ typeOneShots $ idType v interestingBinds :: CoreBind -> [Var] interestingBinds = filter isInteresting . bindersOf @@ -700,7 +700,7 @@ callArityRecEnv any_boring ae_rhss ae_body trimArity :: Id -> Arity -> Arity trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] where - max_arity_by_type = length (typeArity (idType v)) + max_arity_by_type = typeArity (idType v) max_arity_by_strsig | isDeadEndDiv result_info = length demands | otherwise = a diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index b01e6f502a..59d18fefaf 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -125,8 +125,7 @@ isInterestingTopLevelFn :: Id -> Bool -- If there was a gain, that regression might be acceptable. -- Plus, we could use LetUp for thunks and share some code with local let -- bindings. -isInterestingTopLevelFn id = - typeArity (idType id) `lengthExceeds` 0 +isInterestingTopLevelFn id = typeArity (idType id) > 0 {- Note [Stamp out space leaks in demand analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 0ea3c1f3f6..d83f7f7719 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -38,7 +38,7 @@ import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils -import GHC.Core.Opt.Arity ( ArityType(..) +import GHC.Core.Opt.Arity ( ArityType(..), typeArity , pushCoTyArg, pushCoValArg , etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) @@ -605,7 +605,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) -- See Note [OPAQUE pragma] = do { uniq <- getUniqueM ; let work_name = mkSystemVarName uniq occ_fs - work_id = mkLocalIdWithInfo work_name Many rhs_ty worker_info + work_id = mkLocalIdWithInfo work_name Many work_ty work_info is_strict = isStrictId bndr ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict @@ -636,14 +636,15 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) where mode = getMode env occ_fs = getOccFS bndr - rhs_ty = coercionLKind co + work_ty = coercionLKind co info = idInfo bndr + work_arity = arityInfo info `min` typeArity work_ty - worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info - `setCprSigInfo` cprSigInfo info - `setDemandInfo` demandInfo info - `setInlinePragInfo` inlinePragInfo info - `setArityInfo` arityInfo info + work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` work_arity -- We do /not/ want to transfer OccInfo, Rules -- Note [Preserve strictness in cast w/w] -- and Wrinkle 2 of Note [Cast worker/wrapper] diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index ac85ebb623..8b26945d05 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -1807,9 +1807,13 @@ tryEtaExpandRhs env bndr rhs dflags = sm_dflags mode arityOpts = initArityOpts dflags old_arity = exprArity rhs + ty_arity = typeArity (idType bndr) arity_type = findRhsArity arityOpts bndr rhs old_arity `maxWithArity` idCallArity bndr + `minWithArity` ty_arity + -- minWithArity: see Note [Arity trimming] in GHC.Core.Opt.Arity + new_arity = arityTypeArity arity_type -- See Note [Which RHSs do we eta-expand?] diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 053fd2dcf9..d6fd70e8db 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -697,16 +697,13 @@ data PreStgRhs = PreStgRhs [Id] StgExpr -- 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. coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs -coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr -coreToPreStgRhs expr@(Lam _ _) = - let - (args, body) = myCollectBinders expr - args' = filterStgBinders args - in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - body' <- coreToStgExpr body - return (PreStgRhs args' body') -coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr +coreToPreStgRhs expr + = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ + do { body' <- coreToStgExpr body + ; return (PreStgRhs args' body') } + where + (args, body) = myCollectBinders expr + args' = filterStgBinders args -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 7616c9458c..f7282faa83 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -28,9 +28,9 @@ import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq (seqBinds) -import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) +import GHC.Core.Opt.Arity ( exprArity, typeArity,, exprBotStrictness_maybe ) import GHC.Core.InstEnv -import GHC.Core.Type ( tidyTopType ) +import GHC.Core.Type ( Type, tidyTopType ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class @@ -1218,8 +1218,8 @@ tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs) details = idDetails cbv_bndr -- Preserve the IdDetails ty' = tidyTopType (idType cbv_bndr) rhs1 = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr) - show_unfold + idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' ty' + rhs rhs1 (idInfo cbv_bndr) show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. The delicate piece: @@ -1228,27 +1228,27 @@ tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs) -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. -- -tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr - -> IdInfo -> Bool -> IdInfo -tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold +tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> Type + -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo +tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. GHC.Core.Tidy.tidyLetBndr `setArityInfo` arity - `setDmdSigInfo` final_sig - `setCprSigInfo` final_cpr - `setUnfoldingInfo` minimal_unfold_info -- See Note [Preserve evaluatedness] + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr + `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] -- in GHC.Core.Tidy | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setArityInfo` arity - `setDmdSigInfo` final_sig - `setCprSigInfo` final_cpr - `setOccInfo` robust_occ_info - `setInlinePragInfo` (inlinePragInfo idinfo) - `setUnfoldingInfo` unfold_info + `setArityInfo` arity + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr + `setOccInfo` robust_occ_info + `setInlinePragInfo` inlinePragInfo idinfo + `setUnfoldingInfo` unfold_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules where @@ -1311,4 +1311,112 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to -- fix it here. - arity = exprArity orig_rhs + arity = exprArity orig_rhs `min` typeArity rhs_ty + -- orig_rhs: using tidy_rhs would make a black hole, since + -- exprArity uses the arities of Ids inside the rhs + -- typeArity: see Note [typeArity invariants] + -- in GHC.Core.Opt.Arity + +{- +************************************************************************ +* * + Old, dead, type-trimming code +* * +************************************************************************ + +We used to try to "trim off" the constructors of data types that are +not exported, to reduce the size of interface files, at least without +-O. But that is not always possible: see the old Note [When we can't +trim types] below for exceptions. + +Then (#7445) I realised that the TH problem arises for any data type +that we have deriving( Data ), because we can invoke + Language.Haskell.TH.Quote.dataToExpQ +to get a TH Exp representation of a value built from that data type. +You don't even need {-# LANGUAGE TemplateHaskell #-}. + +At this point I give up. The pain of trimming constructors just +doesn't seem worth the gain. So I've dumped all the code, and am just +leaving it here at the end of the module in case something like this +is ever resurrected. + + +Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (#2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declaration of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (#5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) + = True + + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in GHC.Core.TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False + where + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) +-} +>>>>>>> Do arity trimming at bindings, rather than in exprArity diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index d562d0937f..b93289c519 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -364,7 +364,7 @@ bestOneShot NoOneShotInfo os = os bestOneShot OneShotLam _ = OneShotLam pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo NoOneShotInfo = text "NoOS" pprOneShotInfo OneShotLam = text "OneShot" instance Outputable OneShotInfo where |