diff options
| author | Christiaan Baaij <christiaan.baaij@gmail.com> | 2021-11-15 18:09:09 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-03-25 11:35:49 -0400 |
| commit | 1d673aa25205084d3973a3e9c7b7cd84a8b3171c (patch) | |
| tree | 46091c83ce0c11d0f010e3a6096dbc3564de7127 | |
| parent | 5ff690b8474c74e9c968ef31e568c1ad0fe719a1 (diff) | |
| download | haskell-1d673aa25205084d3973a3e9c7b7cd84a8b3171c.tar.gz | |
Add the OPAQUE pragma
A new pragma, `OPAQUE`, that ensures that every call of a named
function annotated with an `OPAQUE` pragma remains a call of that
named function, not some name-mangled variant.
Implements GHC proposal 0415:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0415-opaque-pragma.rst
This commit also updates the haddock submodule to handle the newly
introduced lexer tokens corresponding to the OPAQUE pragma.
52 files changed, 1342 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 diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst index caac4e9362..39ab943356 100644 --- a/docs/users_guide/9.4.1-notes.rst +++ b/docs/users_guide/9.4.1-notes.rst @@ -67,6 +67,9 @@ Compiler - The way GHC checks for representation polymorphism has been overhauled: all the checks are now done during typechecking. The error messages now contain more detailed information about the specific check that was performed. +- A new pragma, :pragma:`OPAQUE`, that ensures that every call of a named function + annotated with an :pragma:`OPAQUE` pragma remains a call of that named function, + not some name-mangled variant. - The parsing of implicit parameters is slightly more permissive, as GHC now allows :: diff --git a/docs/users_guide/exts/pragmas.rst b/docs/users_guide/exts/pragmas.rst index f533dd834e..5aa4e9a783 100644 --- a/docs/users_guide/exts/pragmas.rst +++ b/docs/users_guide/exts/pragmas.rst @@ -454,6 +454,30 @@ arguments etc). Another way to understand the semantics is this: The same phase-numbering control is available for :pragma:`RULE <RULES>`\s (:ref:`rewrite-rules`). +.. _opaque-pragma: + +``OPAQUE`` pragma +----------------- + +.. pragma:: OPAQUE ⟨name⟩ + + :where: top-level + + Instructs the compiler to ensure that every call of ``name`` remains a + call of ``name``, and not some name-mangled variant. + +The :pragma:`OPAQUE` pragma is an even stronger variant of the :pragma:`NOINLINE` +pragma. Like the :pragma:`NOINLINE`, named functions annotated with a +:pragma:`OPAQUE` pragma are not inlined, nor will they be be specialized. +Unlike the :pragma:`NOINLINE`, named functions annotated with a +:pragma:`OPAQUE` pragma are left untouched by the Worker/Wrapper transformation. +Unlike :pragma:`NOINLINE`, :pragma:`OPAQUE` has no phase control. + +In effect, every call of a named function annotated with an :pragma:`OPAQUE` +pragma remains a call of that named function, not some name-mangled variant. +You shouldn't ever need to use the :pragma:`OPAQUE` pragma, unless you have a +reason to care about name-mangling. + .. _line-pragma: ``LINE`` pragma diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 95ccf39447..e960f35bb3 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -484,6 +484,9 @@ pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec pragInlD name inline rm phases = pure $ PragmaD $ InlineP name inline rm phases +pragOpaqueD :: Quote m => Name -> m Dec +pragOpaqueD name = pure $ PragmaD $ OpaqueP name + pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec pragSpecD n ty phases = do diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 449a6e5087..51e89fda2a 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -593,6 +593,8 @@ instance Ppr Pragma where <+> ppr phases <+> pprName' Applied n <+> text "#-}" + ppr (OpaqueP n) + = text "{-# OPAQUE" <+> pprName' Applied n <+> text "#-}" ppr (SpecialiseP n ty inline phases) = text "{-# SPECIALISE" <+> maybe empty ppr inline diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 3d3f46d2c4..5acf96e011 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2499,6 +2499,7 @@ data Safety = Unsafe | Safe | Interruptible deriving( Show, Eq, Ord, Data, Generic ) data Pragma = InlineP Name Inline RuleMatch Phases + | OpaqueP Name | SpecialiseP Name Type (Maybe Inline) Phases | SpecialiseInstP Type | RuleP String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases diff --git a/testsuite/tests/parser/should_compile/OpaqueParseWarn1.hs b/testsuite/tests/parser/should_compile/OpaqueParseWarn1.hs new file mode 100644 index 0000000000..d4307a463c --- /dev/null +++ b/testsuite/tests/parser/should_compile/OpaqueParseWarn1.hs @@ -0,0 +1,6 @@ +module OpaqueParseWarn1 where + +f :: Num a => a -> a +f = (+1) +{-# OPAQUE f #-} +{-# SPECIALISE f :: Int -> Int #-} diff --git a/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr b/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr new file mode 100644 index 0000000000..49682aae19 --- /dev/null +++ b/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr @@ -0,0 +1,2 @@ +OpaqueParseWarn1.hs:6:1: warning: + Ignoring useless SPECIALISE pragma for NOINLINE function: ‘f’ diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index 21787b3794..5412557d10 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -184,3 +184,4 @@ test('DumpSemis', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) test('T20846', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) test('T20551', normal, compile, ['']) +test('OpaqueParseWarn1', normal, compile, ['']) diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail1.hs b/testsuite/tests/parser/should_fail/OpaqueParseFail1.hs new file mode 100644 index 0000000000..368b73f2d7 --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail1.hs @@ -0,0 +1,4 @@ +module OpaqueParseFail1 where + +f = id +{-# OPAQUE[1] f #-} diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail1.stderr b/testsuite/tests/parser/should_fail/OpaqueParseFail1.stderr new file mode 100644 index 0000000000..057b3a8f92 --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail1.stderr @@ -0,0 +1,2 @@ +OpaqueParseFail1.hs:4:11: error: + parse error on input ‘[’ diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail2.hs b/testsuite/tests/parser/should_fail/OpaqueParseFail2.hs new file mode 100644 index 0000000000..e9685581e8 --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail2.hs @@ -0,0 +1,4 @@ +module OpaqueParseFail2 where + +f = id +{-# OPAQUE SPECIALISE f :: Int -> Int #-} diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail2.stderr b/testsuite/tests/parser/should_fail/OpaqueParseFail2.stderr new file mode 100644 index 0000000000..5c4063bd23 --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail2.stderr @@ -0,0 +1,2 @@ +OpaqueParseFail2.hs:4:12: error: + parse error on input ‘SPECIALISE’ diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail3.hs b/testsuite/tests/parser/should_fail/OpaqueParseFail3.hs new file mode 100644 index 0000000000..a3a13aeba0 --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail3.hs @@ -0,0 +1,4 @@ +module OpaqueParseFail2 where + +f = id +{-# OPAQUE CONLIKE f #-} diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail3.stderr b/testsuite/tests/parser/should_fail/OpaqueParseFail3.stderr new file mode 100644 index 0000000000..7680f18ead --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail3.stderr @@ -0,0 +1,2 @@ +OpaqueParseFail3.hs:4:12: error: + parse error on input ‘CONLIKE’ diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail4.hs b/testsuite/tests/parser/should_fail/OpaqueParseFail4.hs new file mode 100644 index 0000000000..aecd866fb9 --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail4.hs @@ -0,0 +1,6 @@ +module OpaqueParseWarn2 where + +f :: Num a => a -> a +f = (+1) +{-# OPAQUE f #-} +{-# INLINE f #-} diff --git a/testsuite/tests/parser/should_fail/OpaqueParseFail4.stderr b/testsuite/tests/parser/should_fail/OpaqueParseFail4.stderr new file mode 100644 index 0000000000..413b4fcc0c --- /dev/null +++ b/testsuite/tests/parser/should_fail/OpaqueParseFail4.stderr @@ -0,0 +1,4 @@ +OpaqueParseFail4.hs:6:12: error: + Duplicate INLINE pragmas for ‘f’ + at OpaqueParseFail4.hs:5:12 + OpaqueParseFail4.hs:6:12 diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index b3a79e38c4..1d90ab407e 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -201,3 +201,7 @@ test('ParserNoTH2', normal, compile_fail, ['']) test('T17865', normal, compile_fail, ['']) test('T20654a', normal, compile_fail, ['']) test('T20654b', normal, compile_fail, ['']) +test('OpaqueParseFail1', normal, compile_fail, ['']) +test('OpaqueParseFail2', normal, compile_fail, ['']) +test('OpaqueParseFail3', normal, compile_fail, ['']) +test('OpaqueParseFail4', normal, compile_fail, ['']) diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoAbsentArgWW.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoAbsentArgWW.hs new file mode 100644 index 0000000000..6dfb874e3c --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoAbsentArgWW.hs @@ -0,0 +1,5 @@ +module OpaqueNoAbsentArgWW where + +f :: Int -> Int -> Bool +f _ i = i == 0 +{-# OPAQUE f #-} diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoAbsentArgWW.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoAbsentArgWW.stderr new file mode 100644 index 0000000000..023dd7d502 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoAbsentArgWW.stderr @@ -0,0 +1,54 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 26, types: 13, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoAbsentArgWW.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoAbsentArgWW.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoAbsentArgWW.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoAbsentArgWW.$trModule3 + = GHC.Types.TrNameS OpaqueNoAbsentArgWW.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoAbsentArgWW.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 60 0}] +OpaqueNoAbsentArgWW.$trModule2 = "OpaqueNoAbsentArgWW"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoAbsentArgWW.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoAbsentArgWW.$trModule1 + = GHC.Types.TrNameS OpaqueNoAbsentArgWW.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoAbsentArgWW.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoAbsentArgWW.$trModule + = GHC.Types.Module + OpaqueNoAbsentArgWW.$trModule3 OpaqueNoAbsentArgWW.$trModule1 + +-- RHS size: {terms: 11, types: 5, coercions: 0, joins: 0/0} +f [InlPrag=OPAQUE] :: Int -> Int -> Bool +[GblId, Arity=2, Str=<A><1P(1L)>, Unf=OtherCon []] +f = / _ [Occ=Dead] (i :: Int) -> + case i of { GHC.Types.I# x -> + case x of { + __DEFAULT -> GHC.Types.False; + 0# -> GHC.Types.True + } + }
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.hs new file mode 100644 index 0000000000..068ac4d4af --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -O0 #-} +module OpaqueNoCastWW where + +import GHC.TypeNats + +newtype Signed (n :: Nat) = S { unsafeToInteger :: Integer} + +-- Normally introduces a worker of type: Signed m -> Signed n -> Integer +times :: Signed m -> Signed n -> Signed (m + n) +times (S a) (S b) = S (a * b) +{-# OPAQUE times #-} diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr new file mode 100644 index 0000000000..00a0421915 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr @@ -0,0 +1,153 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 82, types: 52, coercions: 29, joins: 0/0} + +-- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0} +unsafeToInteger1 :: forall {n :: Nat}. Signed n -> Signed n +[GblId, Arity=1, Unf=OtherCon []] +unsafeToInteger1 = \ (@(n :: Nat)) (ds :: Signed n) -> ds + +-- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0} +unsafeToInteger :: forall (n :: Nat). Signed n -> Integer +[GblId[[RecSel]], Arity=1, Unf=OtherCon []] +unsafeToInteger + = unsafeToInteger1 + `cast` (forall (n :: <Nat>_N). + <Signed n>_R %<'Many>_N ->_R OpaqueNoCastWW.N:Signed[0] <n>_P + :: (forall {n :: Nat}. Signed n -> Signed n) + ~R# (forall {n :: Nat}. Signed n -> Integer)) + +-- RHS size: {terms: 8, types: 7, coercions: 21, joins: 0/0} +times [InlPrag=OPAQUE] + :: forall (m :: Nat) (n :: Nat). + Signed m -> Signed n -> Signed (m + n) +[GblId, Arity=2, Unf=OtherCon []] +times + = (\ (@(m :: Nat)) + (@(n :: Nat)) + (ds :: Signed m) + (ds1 :: Signed n) -> + * @Integer + GHC.Num.$fNumInteger + (ds + `cast` (OpaqueNoCastWW.N:Signed[0] <m>_P :: Signed m ~R# Integer)) + (ds1 + `cast` (OpaqueNoCastWW.N:Signed[0] <n>_P :: Signed n ~R# Integer))) + `cast` (forall (m :: <Nat>_N) (n :: <Nat>_N). + <Signed m>_R + %<'Many>_N ->_R <Signed n>_R + %<'Many>_N ->_R Sym (OpaqueNoCastWW.N:Signed[0] <m + n>_P) + :: (forall {m :: Nat} {n :: Nat}. Signed m -> Signed n -> Integer) + ~R# (forall {m :: Nat} {n :: Nat}. + Signed m -> Signed n -> Signed (m + n))) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule1 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +$trModule1 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule2 :: GHC.Types.TrName +[GblId, Unf=OtherCon []] +$trModule2 = GHC.Types.TrNameS $trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule3 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +$trModule3 = "OpaqueNoCastWW"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule4 :: GHC.Types.TrName +[GblId, Unf=OtherCon []] +$trModule4 = GHC.Types.TrNameS $trModule3 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoCastWW.$trModule :: GHC.Types.Module +[GblId, Unf=OtherCon []] +OpaqueNoCastWW.$trModule = GHC.Types.Module $trModule2 $trModule4 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep1 :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep1 + = GHC.Types.KindRepTyConApp + GHC.Num.Integer.$tcInteger (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep2 :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep2 + = GHC.Types.KindRepTyConApp + GHC.Num.Natural.$tcNatural (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep3 :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep3 = GHC.Types.KindRepFun $krep2 GHC.Types.krep$* + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tcSigned1 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +$tcSigned1 = "Signed"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tcSigned2 :: GHC.Types.TrName +[GblId, Unf=OtherCon []] +$tcSigned2 = GHC.Types.TrNameS $tcSigned1 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +OpaqueNoCastWW.$tcSigned :: GHC.Types.TyCon +[GblId, Unf=OtherCon []] +OpaqueNoCastWW.$tcSigned + = GHC.Types.TyCon + 12374680438872388605## + 16570143229152367467## + OpaqueNoCastWW.$trModule + $tcSigned2 + 0# + $krep3 + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep4 :: [GHC.Types.KindRep] +[GblId, Unf=OtherCon []] +$krep4 + = GHC.Types.: + @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep5 :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep5 = GHC.Types.KindRepTyConApp OpaqueNoCastWW.$tcSigned $krep4 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep6 :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep6 = GHC.Types.KindRepFun $krep1 $krep5 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tc'S1 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +$tc'S1 = "'S"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tc'S2 :: GHC.Types.TrName +[GblId, Unf=OtherCon []] +$tc'S2 = GHC.Types.TrNameS $tc'S1 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +OpaqueNoCastWW.$tc'S :: GHC.Types.TyCon +[GblId, Unf=OtherCon []] +OpaqueNoCastWW.$tc'S + = GHC.Types.TyCon + 9801584576887380300## + 5757617350287545124## + OpaqueNoCastWW.$trModule + $tc'S2 + 1# + $krep6 diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.hs new file mode 100644 index 0000000000..4728c03046 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.hs @@ -0,0 +1,24 @@ +module OpaqueNoRebox where + +f :: (Int,Int) -> Int +f (x,y) = x + y +{-# OPAQUE f #-} + +-- No W/W happens for f because it is OPAQUE, and by design its Boxity +-- information is stripped, which is good! +-- +-- If we hadn't stripped the boxity information, we would make a worker +-- for g that would just rebox its arguments: +-- +-- $wg :: Int# -> Int# -> Int +-- $wg ww ww1 = +-- let x = I# ww in +-- let y = I# ww1 in +-- let p = (x,y) in +-- case f (f p, f p) of { I# z -> ww +# z} +-- +-- as $wg was expecting that a worker for f that would be inlined. +-- +-- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] +g :: (Int, Int) -> Int +g p = fst p + f (f p, f p) diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr new file mode 100644 index 0000000000..ad82c9e16c --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr @@ -0,0 +1,75 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 42, types: 35, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoRebox.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox.$trModule3 + = GHC.Types.TrNameS OpaqueNoRebox.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}] +OpaqueNoRebox.$trModule2 = "OpaqueNoRebox"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox.$trModule1 + = GHC.Types.TrNameS OpaqueNoRebox.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox.$trModule + = GHC.Types.Module + OpaqueNoRebox.$trModule3 OpaqueNoRebox.$trModule1 + +-- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0} +f [InlPrag=OPAQUE] :: (Int, Int) -> Int +[GblId, Arity=1, Str=<1P(1L,1L)>, Unf=OtherCon []] +f = / (ds :: (Int, Int)) -> + case ds of { (x, y) -> GHC.Num.$fNumInt_$c+ x y } + +-- RHS size: {terms: 19, types: 14, coercions: 0, joins: 0/0} +g [InlPrag=[2]] :: (Int, Int) -> Int +[GblId, + Arity=1, + Str=<1P(SL,SL)>, + Cpr=1, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= / (p [Occ=Once1!] :: (Int, Int)) -> + case p of wild { (x [Occ=Once1!], _ [Occ=Dead]) -> + case x of { GHC.Types.I# x1 [Occ=Once1] -> + case f (f wild, f wild) of { GHC.Types.I# y [Occ=Once1] -> + GHC.Types.I# (GHC.Prim.+# x1 y) + } + } + }}] +g = / (p :: (Int, Int)) -> + case p of wild { (x, ds1) -> + case x of { GHC.Types.I# x1 -> + case f (f wild, f wild) of { GHC.Types.I# y -> + GHC.Types.I# (GHC.Prim.+# x1 y) + } + } + } diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox2.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox2.hs new file mode 100644 index 0000000000..1384eea1d6 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox2.hs @@ -0,0 +1,23 @@ +module OpaqueNoRebox2 where + +{-# OPAQUE f #-} +f :: Int -> Int -> (Int, Int) +f x y = (x,y) + +-- No W/W happens for f because it is OPAQUE, and by design its CPR +-- information is stripped, which is good! +-- +-- If we hadn't stripped the CPR information, we would make a worker/wrapper +-- for g that would rebox the result of 'g': +-- +-- $wg :: Bool -> Int -> (# Int, Int #) +-- $wg True a = case f 2 a of (x, y) -> (# x, y #) +-- $wg False a = $wg True (a + 1) +-- +-- g ds a = case $wg ds a of (# x, y#) -> (x, y) +-- +-- as $wg was expecting that a worker for f that would be inlined. +-- +-- See Note [The OPAQUE pragma and avoiding the reboxing of results] +g True a = f 2 a +g False a = g True (a+1) diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox2.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox2.stderr new file mode 100644 index 0000000000..a790f1047f --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox2.stderr @@ -0,0 +1,66 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 42, types: 25, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 5, types: 4, coercions: 0, joins: 0/0} +f [InlPrag=OPAQUE] :: Int -> Int -> (Int, Int) +[GblId, Arity=2, Str=<L><L>, Unf=OtherCon []] +f = / (x :: Int) (y :: Int) -> (x, y) + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +[GblId, Unf=OtherCon []] +lvl = GHC.Types.I# 2# + +Rec { +-- RHS size: {terms: 18, types: 5, coercions: 0, joins: 0/0} +g [Occ=LoopBreaker] :: Bool -> Int -> (Int, Int) +[GblId, Arity=2, Str=<1L><L>, Unf=OtherCon []] +g = / (ds :: Bool) (a :: Int) -> + case ds of { + False -> + g GHC.Types.True + (case a of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 1#) }); + True -> f lvl a + } +end Rec } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox2.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoRebox2.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox2.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox2.$trModule3 + = GHC.Types.TrNameS OpaqueNoRebox2.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox2.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}] +OpaqueNoRebox2.$trModule2 = "OpaqueNoRebox2"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox2.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox2.$trModule1 + = GHC.Types.TrNameS OpaqueNoRebox2.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox2.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox2.$trModule + = GHC.Types.Module + OpaqueNoRebox2.$trModule3 OpaqueNoRebox2.$trModule1
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox3.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox3.hs new file mode 100644 index 0000000000..887e40a432 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox3.hs @@ -0,0 +1,43 @@ +module OpaqueNoRebox3 where + +f :: Int -> Int +f x = x `seq` (x + 1) +{-# OPAQUE f #-} + +-- Historical note: +-- +-- Since no W/W happens for f because it is OPAQUE, currently, the worker for g +-- does the dreaded reboxing of p similar to what is mentioned in +-- https://gitlab.haskell.org/ghc/ghc/-/issues/13143 +-- +-- 16-Nov-2021, Sebastian Graf says: +-- "Right, this is again not related to correct handling of OPAQUE but rather a +-- weakness in boxity analysis at the moment. this is because when boxity +-- analysis sees a `Case`, it will look at its `Alt`s. If one of the `Alt` +-- says `Unboxed`, we let the `Unboxed` win. We'd only say Boxed if all the Alts +-- had Boxed occs or if the scrutinee (or any of the occurrences that happen as +-- part of the same trace, guaranteed) had a Boxed occ. It's kind of a necessary +-- work-around until we have boxity analysis integrate with CPR analysis." +-- +-- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] +-- +-- 16-Mar-2022: +-- With https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7609 merged, we no +-- longer get a reboxing worker for g +g :: Bool -> Bool -> Bool -> Int -> Int +g = \w w1 w2 p -> + let fail_ = case w1 of + False -> case w2 of + False -> g w True w2 p + True -> f (f p) + True -> error "patError" + in case w of + False -> case w1 of + False -> fail_ + True -> case w2 of + False -> p + 1 + True -> fail_ + True -> case w1 of + False -> fail_ + True -> case w2 of + _ -> f p diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox3.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox3.stderr new file mode 100644 index 0000000000..a74980ed99 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox3.stderr @@ -0,0 +1,161 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 120, types: 47, coercions: 4, joins: 1/1} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox3.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoRebox3.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox3.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox3.$trModule3 + = GHC.Types.TrNameS OpaqueNoRebox3.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox3.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}] +OpaqueNoRebox3.$trModule2 = "OpaqueNoRebox3"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox3.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox3.$trModule1 + = GHC.Types.TrNameS OpaqueNoRebox3.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoRebox3.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoRebox3.$trModule + = GHC.Types.Module + OpaqueNoRebox3.$trModule3 OpaqueNoRebox3.$trModule1 + +-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} +f [InlPrag=OPAQUE] :: Int -> Int +[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] +f = / (x :: Int) -> + case x of { GHC.Types.I# ipv -> GHC.Types.I# (GHC.Prim.+# ipv 1#) } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +lvl = "error"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl1 :: [Char] +[GblId] +lvl1 = GHC.CString.unpackCString# lvl + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl2 :: [Char] +[GblId] +lvl2 = GHC.CString.unpackCString# OpaqueNoRebox3.$trModule4 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl3 :: [Char] +[GblId] +lvl3 = GHC.CString.unpackCString# OpaqueNoRebox3.$trModule2 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl4 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +lvl4 = "OpaqueNoRebox3.hs"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl5 :: [Char] +[GblId] +lvl5 = GHC.CString.unpackCString# lvl4 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl6 :: Int +[GblId, Unf=OtherCon []] +lvl6 = GHC.Types.I# 33# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl7 :: Int +[GblId, Unf=OtherCon []] +lvl7 = GHC.Types.I# 23# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl8 :: Int +[GblId, Unf=OtherCon []] +lvl8 = GHC.Types.I# 28# + +-- RHS size: {terms: 8, types: 0, coercions: 0, joins: 0/0} +lvl9 :: GHC.Stack.Types.SrcLoc +[GblId, Unf=OtherCon []] +lvl9 = GHC.Stack.Types.SrcLoc lvl2 lvl3 lvl5 lvl6 lvl7 lvl6 lvl8 + +-- RHS size: {terms: 4, types: 0, coercions: 0, joins: 0/0} +lvl10 :: GHC.Stack.Types.CallStack +[GblId, Unf=OtherCon []] +lvl10 + = GHC.Stack.Types.PushCallStack + lvl1 lvl9 GHC.Stack.Types.EmptyCallStack + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl11 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +lvl11 = "patError"# + +-- RHS size: {terms: 4, types: 2, coercions: 4, joins: 0/0} +lvl12 :: Int +[GblId, Str=b, Cpr=b] +lvl12 + = error + @GHC.Types.LiftedRep + @Int + (lvl10 + `cast` (Sym (GHC.Classes.N:IP[0] + <"callStack">_N <GHC.Stack.Types.CallStack>_N) + :: GHC.Stack.Types.CallStack + ~R# (?callStack::GHC.Stack.Types.CallStack))) + (GHC.CString.unpackCString# lvl11) + +Rec { +-- RHS size: {terms: 50, types: 13, coercions: 0, joins: 1/1} +g [Occ=LoopBreaker] :: Bool -> Bool -> Bool -> Int -> Int +[GblId, Arity=4, Str=<SL><SL><L><1L>, Unf=OtherCon []] +g = / (w :: Bool) (w1 :: Bool) (w2 :: Bool) (p :: Int) -> + join { + fail_ [Dmd=M!P(L)] :: Int + [LclId[JoinId(0)(Nothing)]] + fail_ + = case w1 of { + False -> + case w2 of { + False -> g w GHC.Types.True GHC.Types.False p; + True -> f (f p) + }; + True -> lvl12 + } } in + case w of { + False -> + case w1 of { + False -> jump fail_; + True -> + case w2 of { + False -> + case p of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 1#) }; + True -> jump fail_ + } + }; + True -> + case w1 of { + False -> jump fail_; + True -> f p + } + } +end Rec }
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoSpecConstr.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecConstr.hs new file mode 100644 index 0000000000..e0c1617923 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecConstr.hs @@ -0,0 +1,12 @@ +module OpaqueNoSpecConstr where + +import GHC.Exts ( SpecConstrAnnotation(..) ) + +data SPEC = SPEC | SPEC2 +{-# ANN type SPEC ForceSpecConstr #-} + +-- Would normally induce a SpecConstr on the constructors of SPEC +loop :: SPEC -> [Int] -> [Int] -> [Int] +loop SPEC z [] = z +loop SPEC z (x:xs) = loop SPEC (x:z) xs +{-# OPAQUE loop #-} diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoSpecConstr.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecConstr.stderr new file mode 100644 index 0000000000..e2a51a21b3 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecConstr.stderr @@ -0,0 +1,172 @@ + +==================== Simplified expression ==================== +GHC.Desugar.toAnnotationWrapper + @GHC.Exts.SpecConstrAnnotation + GHC.Exts.$fDataSpecConstrAnnotation + GHC.Exts.ForceSpecConstr + + + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 83, types: 40, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +lvl = "OpaqueNoSpecConstr.hs:(10,1)-(11,39)|function loop"# + +-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} +lvl1 :: () +[GblId, Str=b, Cpr=b] +lvl1 = Control.Exception.Base.patError @GHC.Types.LiftedRep @() lvl + +Rec { +-- RHS size: {terms: 20, types: 13, coercions: 0, joins: 0/0} +loop [InlPrag=OPAQUE, Occ=LoopBreaker] + :: SPEC -> [Int] -> [Int] -> [Int] +[GblId, Arity=3, Str=<1L><L><1L>, Unf=OtherCon []] +loop + = \ (ds :: SPEC) (z :: [Int]) (ds1 :: [Int]) -> + case ds of { + SPEC -> + case ds1 of { + [] -> z; + : x xs -> loop OpaqueNoSpecConstr.SPEC (GHC.Types.: @Int x z) xs + }; + SPEC2 -> case lvl1 of wild1 { } + } +end Rec } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoSpecConstr.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$trModule3 + = GHC.Types.TrNameS OpaqueNoSpecConstr.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 60 0}] +OpaqueNoSpecConstr.$trModule2 = "OpaqueNoSpecConstr"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$trModule1 + = GHC.Types.TrNameS OpaqueNoSpecConstr.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$trModule + = GHC.Types.Module + OpaqueNoSpecConstr.$trModule3 OpaqueNoSpecConstr.$trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tcSPEC2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoSpecConstr.$tcSPEC2 = "SPEC"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tcSPEC1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$tcSPEC1 + = GHC.Types.TrNameS OpaqueNoSpecConstr.$tcSPEC2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tcSPEC :: GHC.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$tcSPEC + = GHC.Types.TyCon + 1794519131116102988## + 1536993820726345194## + OpaqueNoSpecConstr.$trModule + OpaqueNoSpecConstr.$tcSPEC1 + 0# + GHC.Types.krep$* + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC1 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +OpaqueNoSpecConstr.$tc'SPEC1 + = GHC.Types.KindRepTyConApp + OpaqueNoSpecConstr.$tcSPEC (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +OpaqueNoSpecConstr.$tc'SPEC4 = "'SPEC"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$tc'SPEC3 + = GHC.Types.TrNameS OpaqueNoSpecConstr.$tc'SPEC4 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC :: GHC.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$tc'SPEC + = GHC.Types.TyCon + 9648911419523887824## + 4100179153648933145## + OpaqueNoSpecConstr.$trModule + OpaqueNoSpecConstr.$tc'SPEC3 + 0# + OpaqueNoSpecConstr.$tc'SPEC1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC6 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +OpaqueNoSpecConstr.$tc'SPEC6 = "'SPEC2"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC5 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$tc'SPEC5 + = GHC.Types.TrNameS OpaqueNoSpecConstr.$tc'SPEC6 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecConstr.$tc'SPEC2 :: GHC.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecConstr.$tc'SPEC2 + = GHC.Types.TyCon + 4214136204857816792## + 17253701793498718125## + OpaqueNoSpecConstr.$trModule + OpaqueNoSpecConstr.$tc'SPEC5 + 0# + OpaqueNoSpecConstr.$tc'SPEC1 diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoSpecialise.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecialise.hs new file mode 100644 index 0000000000..cc538980b1 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecialise.hs @@ -0,0 +1,7 @@ +module OpaqueNoSpecialise where + +f x = x : f (x-1) +{-# OPAQUE f #-} + +-- This would normally induce a specialisation of f on Int +g (x :: Int) = f x diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoSpecialise.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecialise.stderr new file mode 100644 index 0000000000..b3d76cde24 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoSpecialise.stderr @@ -0,0 +1,74 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 41, types: 29, coercions: 0, joins: 0/2} + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Integer +[GblId, Unf=OtherCon []] +lvl = GHC.Num.Integer.IS 1# + +-- RHS size: {terms: 18, types: 12, coercions: 0, joins: 0/2} +f [InlPrag=OPAQUE] :: forall {t}. Num t => t -> [t] +[GblId, + Arity=2, + Str=<LP(A,LCL(C1(L)),A,A,A,A,MCM(L))><L>, + Unf=OtherCon []] +f = \ (@t) ($dNum :: Num t) (eta :: t) -> + let { + lvl1 :: t + [LclId] + lvl1 = fromInteger @t $dNum lvl } in + letrec { + f1 [Occ=LoopBreaker, Dmd=SCS(L)] :: t -> [t] + [LclId, Arity=1, Str=<L>, Unf=OtherCon []] + f1 = \ (x :: t) -> GHC.Types.: @t x (f1 (- @t $dNum x lvl1)); } in + f1 eta + +-- RHS size: {terms: 4, types: 2, coercions: 0, joins: 0/0} +g :: Int -> [Int] +[GblId, + Arity=1, + Str=<L>, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}] +g = \ (ds :: Int) -> f @Int GHC.Num.$fNumInt ds + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecialise.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoSpecialise.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecialise.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecialise.$trModule3 + = GHC.Types.TrNameS OpaqueNoSpecialise.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecialise.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 60 0}] +OpaqueNoSpecialise.$trModule2 = "OpaqueNoSpecialise"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecialise.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecialise.$trModule1 + = GHC.Types.TrNameS OpaqueNoSpecialise.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoSpecialise.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoSpecialise.$trModule + = GHC.Types.Module + OpaqueNoSpecialise.$trModule3 OpaqueNoSpecialise.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoStrictArgWW.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoStrictArgWW.hs new file mode 100644 index 0000000000..d4112cf12e --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoStrictArgWW.hs @@ -0,0 +1,5 @@ +module OpaqueNoStrictArgWW where + +f :: Int -> Int +f x = x + 1 +{-# OPAQUE f #-} diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoStrictArgWW.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoStrictArgWW.stderr new file mode 100644 index 0000000000..c99e729976 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoStrictArgWW.stderr @@ -0,0 +1,49 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 23, types: 10, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoStrictArgWW.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoStrictArgWW.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoStrictArgWW.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoStrictArgWW.$trModule3 + = GHC.Types.TrNameS OpaqueNoStrictArgWW.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoStrictArgWW.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 60 0}] +OpaqueNoStrictArgWW.$trModule2 = "OpaqueNoStrictArgWW"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoStrictArgWW.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoStrictArgWW.$trModule1 + = GHC.Types.TrNameS OpaqueNoStrictArgWW.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoStrictArgWW.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoStrictArgWW.$trModule + = GHC.Types.Module + OpaqueNoStrictArgWW.$trModule3 OpaqueNoStrictArgWW.$trModule1 + +-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} +f [InlPrag=OPAQUE] :: Int -> Int +[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] +f = / (x :: Int) -> + case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoWW.hs b/testsuite/tests/simplCore/should_compile/OpaqueNoWW.hs new file mode 100644 index 0000000000..7d617e891f --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoWW.hs @@ -0,0 +1,12 @@ +module OpaqueNoWW where + +-- Would normally result in a worker of type Int# -> Int# +f :: Int -> Int +f 0 = 0 +f x = f (x + 1) +{-# OPAQUE f #-} + +g :: Bool -> Bool -> Int -> Int +g True True p = f p +g False True p = p + 1 +g b False p = g b True p diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoWW.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoWW.stderr new file mode 100644 index 0000000000..77d820f9dd --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/OpaqueNoWW.stderr @@ -0,0 +1,78 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 65, types: 24, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoWW.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +OpaqueNoWW.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoWW.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoWW.$trModule3 = GHC.Types.TrNameS OpaqueNoWW.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +OpaqueNoWW.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 0}] +OpaqueNoWW.$trModule2 = "OpaqueNoWW"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +OpaqueNoWW.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoWW.$trModule1 = GHC.Types.TrNameS OpaqueNoWW.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +OpaqueNoWW.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +OpaqueNoWW.$trModule + = GHC.Types.Module OpaqueNoWW.$trModule3 OpaqueNoWW.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +[GblId, Unf=OtherCon []] +lvl = GHC.Types.I# 0# + +Rec { +-- RHS size: {terms: 14, types: 4, coercions: 0, joins: 0/0} +f [InlPrag=OPAQUE, Occ=LoopBreaker] :: Int -> Int +[GblId, Arity=1, Str=<1P(1L)>, Unf=OtherCon []] +f = / (ds :: Int) -> + case ds of { GHC.Types.I# ds1 -> + case ds1 of ds2 { + __DEFAULT -> f (GHC.Types.I# (GHC.Prim.+# ds2 1#)); + 0# -> lvl + } + } +end Rec } + +Rec { +-- RHS size: {terms: 32, types: 8, coercions: 0, joins: 0/0} +g [Occ=LoopBreaker] :: Bool -> Bool -> Int -> Int +[GblId, Arity=3, Str=<1L><1L><1L>, Unf=OtherCon []] +g = / (ds :: Bool) (ds1 :: Bool) (p :: Int) -> + case ds of { + False -> + case ds1 of { + False -> g GHC.Types.False GHC.Types.True p; + True -> + case p of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 1#) } + }; + True -> + case ds1 of { + False -> g GHC.Types.True GHC.Types.True p; + True -> f p + } + } +end Rec }
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 034a76fadd..f0b361b3f8 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -379,3 +379,13 @@ test('T19790', normal, compile, ['-O -ddump-rule-firings']) # -O0 is needed to trigger it because that switches rules off, # which (before the fix) lost crucial dependencies test('T20820', normal, compile, ['-O0']) + +test('OpaqueNoAbsentArgWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoCastWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoRebox', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoRebox2', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoRebox3', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoSpecConstr', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoSpecialise', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoStrictArgWW', normal, compile, ['-O -fworker-wrapper-cbv -ddump-simpl -dsuppress-uniques']) +test('OpaqueNoWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) diff --git a/utils/haddock b/utils/haddock -Subproject d2779a3e659d4e9f7044c346a566e5fe4edbdb9 +Subproject 559e41505e81d93939e9afa6aa9793b0a428924 |