summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs16
-rw-r--r--compiler/GHC/Core/Opt/CprAnal.hs33
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs26
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs2
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs9
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs5
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs32
-rw-r--r--compiler/GHC/HsToCore/Binds.hs2
-rw-r--r--compiler/GHC/HsToCore/Quote.hs1
-rw-r--r--compiler/GHC/Parser.y6
-rw-r--r--compiler/GHC/Parser/Lexer.x2
-rw-r--r--compiler/GHC/Parser/PostProcess.hs15
-rw-r--r--compiler/GHC/ThToHs.hs11
-rw-r--r--compiler/GHC/Types/Basic.hs68
-rw-r--r--compiler/GHC/Types/Demand.hs26
15 files changed, 233 insertions, 21 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index 0c1d626581..f5dbc4fdc9 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -594,10 +594,11 @@ quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
-- data Inline = ...
-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
+noInlineDataConName, inlineDataConName, inlinableDataConName, opaqueDataConName :: Name
noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
+opaqueDataConName = thCon (fsLit "Opaque") opaqueDataConKey
-- data RuleMatch = ...
conLikeDataConName, funLikeDataConName :: Name
@@ -700,21 +701,22 @@ modNameTyConKey = mkPreludeTyConUnique 239
-- If you want to change this, make sure you check in GHC.Builtin.Names
-- data Inline = ...
-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
+noInlineDataConKey, inlineDataConKey, inlinableDataConKey, opaqueDataConKey :: Unique
noInlineDataConKey = mkPreludeDataConUnique 200
inlineDataConKey = mkPreludeDataConUnique 201
inlinableDataConKey = mkPreludeDataConUnique 202
+opaqueDataConKey = mkPreludeDataConUnique 203
-- data RuleMatch = ...
conLikeDataConKey, funLikeDataConKey :: Unique
-conLikeDataConKey = mkPreludeDataConUnique 203
-funLikeDataConKey = mkPreludeDataConUnique 204
+conLikeDataConKey = mkPreludeDataConUnique 204
+funLikeDataConKey = mkPreludeDataConUnique 205
-- data Phases = ...
allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
-allPhasesDataConKey = mkPreludeDataConUnique 205
-fromPhaseDataConKey = mkPreludeDataConUnique 206
-beforePhaseDataConKey = mkPreludeDataConUnique 207
+allPhasesDataConKey = mkPreludeDataConUnique 206
+fromPhaseDataConKey = mkPreludeDataConUnique 207
+beforePhaseDataConKey = mkPreludeDataConUnique 208
-- data Overlap = ..
overlappableDataConKey,
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index 51bc507a20..3f6455c9cf 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -428,6 +428,31 @@ cprFix orig_env orig_pairs
where
(id', rhs', env') = cprAnalBind env id rhs
+{-
+Note [The OPAQUE pragma and avoiding the reboxing of results]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+
+ {-# OPAQUE f #-}
+ f x = (x,y)
+
+ g True = f 2 x
+ g False = (0,0)
+
+Where if we didn't strip the CPR info from 'f' we would end up with the
+following W/W pair for 'g':
+
+ $wg True = case f 2 of (x, y) -> (# x, y #)
+ $wg False = (# 0, 0 #)
+
+ g b = case wg$ b of (# x, y #) -> (x, y)
+
+Where the worker unboxes the result of 'f', only for wrapper to box it again.
+That's because the non-stripped CPR signature of 'f' is saying to W/W-transform
+'f'. However, OPAQUE-annotated binders aren't W/W transformed (see
+Note [OPAQUE pragma]), so we should strip 'f's CPR signature.
+-}
+
-- | Process the RHS of the binding for a sensible arity, add the CPR signature
-- to the Id, and augment the environment with the signature as well.
cprAnalBind
@@ -452,8 +477,12 @@ cprAnalBind env id rhs
| otherwise = rhs_ty
-- See Note [Arity trimming for CPR signatures]
sig = mkCprSigForArity (idArity id) rhs_ty'
- id' = setIdCprSig id sig
- env' = extendSigEnv env id sig
+ -- See Note [OPAQUE pragma]
+ -- See Note [The OPAQUE pragma and avoiding the reboxing of results]
+ sig' | isOpaquePragma (idInlinePragma id) = topCprSig
+ | otherwise = sig
+ id' = setIdCprSig id sig'
+ env' = extendSigEnv env id sig'
-- See Note [CPR for thunks]
stays_thunk = is_thunk && not_strict
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 93c7e38ef9..347cc4228d 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -1516,6 +1516,24 @@ next layer, using that depleted budget.
To achieve this, we use the classic almost-circular programming technique in
which we we write one pass that takes a lazy list of the Budgets for every
layer.
+
+Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when
+a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for
+'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.
+
+That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a
+W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments
+that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of
+reboxing does not happen.
+
+But now we have functions with OPAQUE pragmas, which by definition (See Note
+[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing
+workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity
+information from 'f' in the demand analysis. This will inform the
+W/W-transformation code that boxed arguments of 'f' must definitely be passed
+along in boxed form and as such dissuade the creation of reboxing workers.
-}
data Budgets = MkB Arity Budgets -- An infinite list of arity budgets
@@ -1560,10 +1578,14 @@ finaliseArgBoxities env fn arity rhs div
mk_triple :: Id -> (Type,StrictnessMark,Demand)
mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)
| is_bot_fn = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)
+ -- See Note [OPAQUE pragma]
+ -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+ | is_opaque = (ty, NotMarkedStrict, trimBoxity dmd)
| otherwise = (ty, NotMarkedStrict, dmd)
where
- ty = idType bndr
- dmd = idDemandInfo bndr
+ ty = idType bndr
+ dmd = idDemandInfo bndr
+ is_opaque = isOpaquePragma (idInlinePragma fn)
-- is_cls_arg: see Note [Do not unbox class dictionaries]
is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 3c3854bf41..a5b40879b1 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -624,6 +624,8 @@ tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co)
, isConcrete (typeKind rhs_ty) -- Don't peel off a cast if doing so would
-- lose the underlying runtime representation.
-- See Note [Preserve RuntimeRep info in cast w/w]
+ , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings
+ -- See Note [OPAQUE pragma]
= do { (rhs_floats, work_rhs) <- prepareRhs env top_lvl occ_fs rhs
; uniq <- getUniqueM
; let work_name = mkSystemVarName uniq occ_fs
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index aec343508e..a5579108e6 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1650,7 +1650,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
= -- pprTrace "specialise bot" (ppr fn) $
return (nullUsage, spec_info)
- | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
+ | not (isNeverActive (idInlineActivation fn))
+ -- See Note [Transfer activation]
+ --
+ --
+ -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].
+ -- Since OPAQUE things are always never-active (see
+ -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for
+ -- OPAQUE things.
, not (null arg_bndrs) -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it
= -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index d80e78f685..d9cc090d3d 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1431,6 +1431,11 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
&& not (isNeverActive (idInlineActivation fn))
-- Don't specialise NOINLINE things
-- See Note [Auto-specialisation and RULES]
+ --
+ -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].
+ -- Since OPAQUE things are always never-active (see
+ -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for
+ -- OPAQUE things.
-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small
-- See Note [Inline specialisations] for why we do not
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 092fdbb7a7..a6e583a210 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -534,9 +534,6 @@ tryWW :: WwOpts
-- if two, then a worker and a
-- wrapper.
tryWW ww_opts is_rec fn_id rhs
- -- Do this even if there is a NOINLINE pragma
- -- See Note [Worker/wrapper for NOINLINE functions]
-
-- See Note [Drop absent bindings]
| isAbsDmd (demandInfo fn_info)
, not (isJoinId fn_id)
@@ -551,6 +548,35 @@ tryWW ww_opts is_rec fn_id rhs
| isRecordSelector fn_id
= return [ (new_fn_id, rhs ) ]
+ -- Don't w/w OPAQUE things
+ -- See Note [OPAQUE pragma]
+ --
+ -- Whilst this check might seem superfluous, since we strip boxity
+ -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and
+ -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually
+ -- isn't. That is because we would still perform w/w when:
+ --
+ -- * An argument is used strictly, and -fworker-wrapper-cbv is
+ -- enabled, or,
+ -- * When demand analysis marks an argument as absent.
+ --
+ -- In a debug build we do assert that boxity and CPR information
+ -- are actually stripped, since we want to prevent callers of OPAQUE
+ -- things to do reboxing. See:
+ -- * Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+ -- * Note [The OPAQUE pragma and avoiding the reboxing of results]
+ | isOpaquePragma (inlinePragInfo fn_info)
+ = assertPpr (onlyBoxedArguments (dmdSigInfo fn_info) &&
+ isTopCprSig (cprSigInfo fn_info))
+ (text "OPAQUE fun with boxity" $$
+ ppr new_fn_id $$
+ ppr (dmdSigInfo fn_info) $$
+ ppr (cprSigInfo fn_info) $$
+ ppr rhs) $
+ return [ (new_fn_id, rhs) ]
+
+ -- Do this even if there is a NOINLINE pragma
+ -- See Note [Worker/wrapper for NOINLINE functions]
| is_fun
= splitFun ww_opts new_fn_id rhs
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 9220326258..793f8c9ffb 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -399,6 +399,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
= case inlinePragmaSpec inline_prag of
NoUserInlinePrag -> (gbl_id, rhs)
NoInline {} -> (gbl_id, rhs)
+ Opaque {} -> (gbl_id, rhs)
Inlinable {} -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
Inline {} -> inline_pair
where
@@ -769,6 +770,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- phase specification in the SPECIALISE pragma
no_act_spec = case inlinePragmaSpec spec_inl of
NoInline _ -> isNeverActive spec_prag_act
+ Opaque _ -> isNeverActive spec_prag_act
_ -> isAlwaysActive spec_prag_act
rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
| otherwise = spec_prag_act -- Specified by user
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 38dc46364e..22fc242e87 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1118,6 +1118,7 @@ rep_specialiseInst ty loc
repInline :: InlineSpec -> MetaM (Core TH.Inline)
repInline (NoInline _ ) = dataCon noInlineDataConName
+repInline (Opaque _ ) = dataCon opaqueDataConName
repInline (Inline _ ) = dataCon inlineDataConName
repInline (Inlinable _ ) = dataCon inlinableDataConName
repInline NoUserInlinePrag = notHandled ThNoUserInline
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 418d67dc67..225eabd212 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -622,6 +622,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
'dependency' { L _ ITdependency }
'{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE
+ '{-# OPAQUE' { L _ (ITopaque_prag _) }
'{-# SPECIALISE' { L _ (ITspec_prag _) }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) }
'{-# SOURCE' { L _ (ITsource_prag _) }
@@ -2575,7 +2576,9 @@ sigdecl :: { LHsDecl GhcPs }
{% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3
(mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
(snd $2))))) }
-
+ | '{-# OPAQUE' qvar '#-}'
+ {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2
+ (mkOpaquePragma (getOPAQUE_PRAGs $1))))) }
| '{-# SCC' qvar '#-}'
{% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) }
@@ -3914,6 +3917,7 @@ getPRIMWORDs (L _ (ITprimword src _)) = src
-- See Note [Pragma source text] in "GHC.Types.Basic" for the following
getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl
+getOPAQUE_PRAGs (L _ (ITopaque_prag src)) = src
getSPEC_PRAGs (L _ (ITspec_prag src)) = src
getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src
getSOURCE_PRAGs (L _ (ITsource_prag src)) = src
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 02717c7dae..b1d8f43350 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -761,6 +761,7 @@ data Token
-- Pragmas, see Note [Pragma source text] in "GHC.Types.Basic"
| ITinline_prag SourceText InlineSpec RuleMatchInfo
+ | ITopaque_prag SourceText
| ITspec_prag SourceText -- SPECIALISE
| ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE)
| ITsource_prag SourceText
@@ -3446,6 +3447,7 @@ oneWordPrags = Map.fromList [
-- Spelling variant
("notinline",
strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),
+ ("opaque", strtoken (\s -> ITopaque_prag (SourceText s))),
("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
("source", strtoken (\s -> ITsource_prag (SourceText s))),
("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 444471abca..e6daea8fe8 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -30,6 +30,7 @@ module GHC.Parser.PostProcess (
mkTyFamInst,
mkFamDecl,
mkInlinePragma,
+ mkOpaquePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate,
mkTyClD, mkInstD,
@@ -2559,8 +2560,22 @@ mkInlinePragma src (inl, match_info) mb_act
Nothing -> -- No phase specified
case inl of
NoInline _ -> NeverActive
+ Opaque _ -> NeverActive
_other -> AlwaysActive
+mkOpaquePragma :: SourceText -> InlinePragma
+mkOpaquePragma src
+ = InlinePragma { inl_src = src
+ , inl_inline = Opaque src
+ , inl_sat = Nothing
+ -- By marking the OPAQUE pragma NeverActive we stop
+ -- (constructor) specialisation on OPAQUE things.
+ --
+ -- See Note [OPAQUE pragma]
+ , inl_act = NeverActive
+ , inl_rule = FunLike
+ }
+
-----------------------------------------------------------------------------
-- utilities for foreign declarations
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index d90ef38341..ebcaad926a 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -780,6 +780,17 @@ cvtPragmaD (InlineP nm inline rm phases)
toSrcTxt a = SourceText $ src a
; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
+cvtPragmaD (OpaqueP nm)
+ = do { nm' <- vNameN nm
+ ; let ip = InlinePragma { inl_src = srcTxt
+ , inl_inline = Opaque srcTxt
+ , inl_rule = Hs.FunLike
+ , inl_act = NeverActive
+ , inl_sat = Nothing }
+ where
+ srcTxt = SourceText "{-# OPAQUE"
+ ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
+
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 2e234c383b..3843e2c880 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -88,7 +88,7 @@ module GHC.Types.Basic (
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma,
isDefaultInlinePragma,
- isInlinePragma, isInlinablePragma, isNoInlinePragma,
+ isInlinePragma, isInlinablePragma, isNoInlinePragma, isOpaquePragma,
isAnyInlinePragma, alwaysInlineConLikePragma,
inlinePragmaSource,
inlinePragmaName, inlineSpecSource,
@@ -1438,6 +1438,7 @@ data InlineSpec -- What the user's INLINE pragma looked like
= Inline SourceText -- User wrote INLINE
| Inlinable SourceText -- User wrote INLINABLE
| NoInline SourceText -- User wrote NOINLINE
+ | Opaque SourceText -- User wrote OPAQUE
-- Each of the above keywords is accompanied with
-- a string of type SourceText written by the user
| NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE
@@ -1465,7 +1466,7 @@ If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.
Note [inl_inline and inl_act]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* inl_inline says what the user wrote: did they say INLINE, NOINLINE,
- INLINABLE, or nothing at all
+ INLINABLE, OPAQUE, or nothing at all
* inl_act says in what phases the unfolding is active or inactive
E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1
@@ -1514,6 +1515,52 @@ The main effects of CONLIKE are:
- The rule matcher consults this field. See
Note [Expanding variables] in GHC.Core.Rules.
+
+Note [OPAQUE pragma]
+~~~~~~~~~~~~~~~~~~~~
+Suppose a function `f` is marked {-# OPAQUE f #-}. Then every call of `f`
+should remain a call of `f` throughout optimisation; it should not be turned
+into a call of a name-mangled variant of `f` (e.g by worker/wrapper).
+
+The motivation for the OPAQUE pragma is discussed in GHC proposal 0415:
+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0415-opaque-pragma.rst
+Basically it boils down to the desire of GHC API users and GHC RULE writers for
+calls to certain binders to be left completely untouched by GHCs optimisations.
+
+What this entails at the time of writing, is that for every binder annotated
+with the OPAQUE pragma we:
+
+* Do not do worker/wrapper via cast W/W:
+ See the guard in GHC.Core.Opt.Simplify.tryCastWorkerWrapper
+
+* Do not any worker/wrapper after demand/CPR analysis. To that end add a guard
+ in GHC.Core.Opt.WorkWrap.tryWW to disable worker/wrapper
+
+* It is important that the demand signature and CPR signature do not lie, else
+ clients of the function will believe that it has the CPR property etc. But it
+ won't, because we've disabled worker/wrapper. To avoid the signatures lying:
+ * Strip boxity information from the demand signature
+ in GHC.Core.Opt.DmdAnal.finaliseArgBoxities
+ See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+ * Strip CPR information from the CPR signature
+ in GHC.Core.Opt.CprAnal.cprAnalBind
+ See Note [The OPAQUE pragma and avoiding the reboxing of results]
+
+* Do create specialised versions of the function in
+ * Specialise: see GHC.Core.Opt.Specialise.specCalls
+ * SpecConstr: see GHC.Core.Opt.SpecConstr.specialise
+ Both are accomplished easily: these passes already skip NOINLINE
+ functions with NeverActive activation, and an OPAQUE function is
+ also NeverActive.
+
+At the moment of writing, the major difference between the NOINLINE pragma and
+the OPAQUE pragma is that binders annoted with the NOINLINE pragma _are_ W/W
+transformed (see also Note [Worker/wrapper for NOINLINE functions]) where
+binders annoted with the OPAQUE pragma are _not_ W/W transformed.
+
+Future "name-mangling" optimisations should respect the OPAQUE pragma and
+update the list of moving parts referenced in this note.
+
-}
isConLike :: RuleMatchInfo -> Bool
@@ -1550,6 +1597,7 @@ inlinePragmaSource prag = case inl_inline prag of
Inline x -> x
Inlinable y -> y
NoInline z -> z
+ Opaque q -> q
NoUserInlinePrag -> NoSourceText
inlineSpecSource :: InlineSpec -> SourceText
@@ -1557,6 +1605,7 @@ inlineSpecSource spec = case spec of
Inline x -> x
Inlinable y -> y
NoInline z -> z
+ Opaque q -> q
NoUserInlinePrag -> NoSourceText
-- A DFun has an always-active inline activation so that
@@ -1594,6 +1643,11 @@ isAnyInlinePragma prag = case inl_inline prag of
Inlinable _ -> True
_ -> False
+isOpaquePragma :: InlinePragma -> Bool
+isOpaquePragma prag = case inl_inline prag of
+ Opaque _ -> True
+ _ -> False
+
inlinePragmaSat :: InlinePragma -> Maybe Arity
inlinePragmaSat = inl_sat
@@ -1660,6 +1714,7 @@ instance Outputable InlineSpec where
ppr (Inline src) = text "INLINE" <+> pprWithSourceText src empty
ppr (NoInline src) = text "NOINLINE" <+> pprWithSourceText src empty
ppr (Inlinable src) = text "INLINABLE" <+> pprWithSourceText src empty
+ ppr (Opaque src) = text "OPAQUE" <+> pprWithSourceText src empty
ppr NoUserInlinePrag = empty
instance Binary InlineSpec where
@@ -1670,6 +1725,8 @@ instance Binary InlineSpec where
put_ bh s
put_ bh (NoInline s) = do putByte bh 3
put_ bh s
+ put_ bh (Opaque s) = do putByte bh 4
+ put_ bh s
get bh = do h <- getByte bh
case h of
@@ -1680,9 +1737,12 @@ instance Binary InlineSpec where
2 -> do
s <- get bh
return (Inlinable s)
- _ -> do
+ 3 -> do
s <- get bh
return (NoInline s)
+ _ -> do
+ s <- get bh
+ return (Opaque s)
instance Outputable InlinePragma where
ppr = pprInline
@@ -1710,6 +1770,7 @@ inlinePragmaName :: InlineSpec -> SDoc
inlinePragmaName (Inline _) = text "INLINE"
inlinePragmaName (Inlinable _) = text "INLINABLE"
inlinePragmaName (NoInline _) = text "NOINLINE"
+inlinePragmaName (Opaque _) = text "OPAQUE"
inlinePragmaName NoUserInlinePrag = empty
pprInline :: InlinePragma -> SDoc
@@ -1732,6 +1793,7 @@ pprInline' emptyInline (InlinePragma
pp_act Inline {} AlwaysActive = empty
pp_act NoInline {} NeverActive = empty
+ pp_act Opaque {} NeverActive = empty
pp_act _ act = ppr act
pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar)
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index 98db1c38b8..4163e9a525 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -31,7 +31,7 @@ module GHC.Types.Demand (
-- ** Predicates on @Card@inalities and @Demand@s
isAbs, isUsedOnce, isStrict,
isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,
- isTopDmd, isWeakDmd,
+ isTopDmd, isWeakDmd, onlyBoxedArguments,
-- ** Special demands
evalDmd,
-- *** Demands used in PrimOp signatures
@@ -66,7 +66,7 @@ module GHC.Types.Demand (
-- * Demand signatures
DmdSig(..), mkDmdSigForArity, mkClosedDmdSig,
splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,
- nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd,
+ nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd, trimBoxityDmdSig,
-- ** Handling arity adjustments
prependArgsDmdSig, etaConvertDmdSig,
@@ -103,6 +103,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import Data.Coerce (coerce)
import Data.Function
import GHC.Utils.Trace
@@ -1955,6 +1956,20 @@ isTopSig (DmdSig ty) = isTopDmdType ty
isDeadEndSig :: DmdSig -> Bool
isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res
+-- | True when the signature indicates all arguments are boxed
+onlyBoxedArguments :: DmdSig -> Bool
+onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds
+ where
+ demandIsBoxed BotDmd = True
+ demandIsBoxed AbsDmd = True
+ demandIsBoxed (_ :* sd) = subDemandIsboxed sd
+
+ subDemandIsboxed (Poly Unboxed _) = False
+ subDemandIsboxed (Poly _ _) = True
+ subDemandIsboxed (Call _ sd) = subDemandIsboxed sd
+ subDemandIsboxed (Prod Unboxed _) = False
+ subDemandIsboxed (Prod _ ds) = all demandIsBoxed ds
+
-- | Returns true if an application to n args would diverge or throw an
-- exception.
--
@@ -1966,6 +1981,13 @@ appIsDeadEnd :: DmdSig -> Int -> Bool
appIsDeadEnd (DmdSig (DmdType _ ds res)) n
= isDeadEndDiv res && not (lengthExceeds ds n)
+trimBoxityDmdType :: DmdType -> DmdType
+trimBoxityDmdType (DmdType fvs ds res) =
+ DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res
+
+trimBoxityDmdSig :: DmdSig -> DmdSig
+trimBoxityDmdSig = coerce trimBoxityDmdType
+
prependArgsDmdSig :: Int -> DmdSig -> DmdSig
-- ^ Add extra ('topDmd') arguments to a strictness signature.
-- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument
View Lorry Controller Status