[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: template-haskell: Improve documentation of strictness annotation types
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Oct 21 18:55:54 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
09ec7de2 by Teo Camarasu at 2022-10-21T13:23:07-04:00
template-haskell: Improve documentation of strictness annotation types
Before it was undocumentated that DecidedLazy can be returned by
reifyConStrictness for strict fields. This can happen when a field has
an unlifted type or its the single field of a newtype constructor.
Fixes #21380
- - - - -
88172069 by M Farkas-Dyck at 2022-10-21T13:23:51-04:00
Delete `eqExpr`, since GHC 9.4 has been released.
- - - - -
bcabce19 by Ömer Sinan Ağacan at 2022-10-21T14:55:11-04:00
Introduce a standard thunk for allocating strings
Currently for a top-level closure in the form
hey = unpackCString# x
we generate code like this:
Main.hey_entry() // [R1]
{ info_tbls: [(c2T4,
label: Main.hey_info
rep: HeapRep static { Thunk }
srt: Nothing)]
stack_info: arg_space: 8 updfr_space: Just 8
}
{offset
c2T4: // global
_rqm::P64 = R1;
if ((Sp + 8) - 24 < SpLim) (likely: False) goto c2T5; else goto c2T6;
c2T5: // global
R1 = _rqm::P64;
call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8;
c2T6: // global
(_c2T1::I64) = call "ccall" arg hints: [PtrHint,
PtrHint] result hints: [PtrHint] newCAF(BaseReg, _rqm::P64);
if (_c2T1::I64 == 0) goto c2T3; else goto c2T2;
c2T3: // global
call (I64[_rqm::P64])() args: 8, res: 0, upd: 8;
c2T2: // global
I64[Sp - 16] = stg_bh_upd_frame_info;
I64[Sp - 8] = _c2T1::I64;
R2 = hey1_r2Gg_bytes;
Sp = Sp - 16;
call GHC.CString.unpackCString#_info(R2) args: 24, res: 0, upd: 24;
}
}
This code is generated for every string literal. Only difference between
top-level closures like this is the argument for the bytes of the string
(hey1_r2Gg_bytes in the code above).
With this patch we introduce a standard thunk in the RTS, called
stg_MK_STRING_info, that does what `unpackCString# x` does, except it
gets the bytes address from the payload. Using this, for the closure
above, we generate this:
Main.hey_closure" {
Main.hey_closure:
const stg_MK_STRING_info;
const 0; // padding for indirectee
const 0; // static link
const 0; // saved info
const hey1_r1Gg_bytes; // the payload
}
This is much smaller in code.
Metric Decrease:
T10421
T11195
T12150
T12425
T16577
T18282
T18698a
T18698b
Co-Authored By: Ben Gamari <ben at well-typed.com>
- - - - -
6fd501a2 by Simon Peyton Jones at 2022-10-21T14:55:14-04:00
Fix binder-swap bug
This patch fixes #21229 properly, by avoiding doing a
binder-swap on dictionary Ids. This is pretty subtle, and explained
in Note [Care with binder-swap on dictionaries].
Test is already in simplCore/should_run/T21229
This allows us to restore a feature to the specialiser that we had
to revert: see Note [Specialising polymorphic dictionaries].
(This is done in a separate patch.)
I also modularised things, using a new function scrutBinderSwap_maybe
in all the places where we are (effectively) doing a binder-swap,
notably
* Simplify.Iteration.addAltUnfoldings
* SpecConstr.extendCaseBndrs
In Simplify.Iteration.addAltUnfoldings I also eliminated a guard
Many <- idMult case_bndr
because we concluded, in #22123, that it was doing no good.
- - - - -
e09780bd by Simon Peyton Jones at 2022-10-21T14:55:14-04:00
Make the specialiser handle polymorphic specialisation
Ticket #13873 unexpectedly showed that a SPECIALISE pragma made a
program run (a lot) slower, because less specialisation took place
overall. It turned out that the specialiser was missing opportunities
because of quantified type variables.
It was quite easy to fix. The story is given in
Note [Specialising polymorphic dictionaries]
Two other minor fixes in the specialiser
* There is no benefit in specialising data constructor /wrappers/.
(They can appear overloaded because they are given a dictionary
to store in the constructor.) Small guard in canSpecImport.
* There was a buglet in the UnspecArg case of specHeader, in the
case where there is a dead binder. We need a LitRubbish filler
for the specUnfolding stuff. I expanded
Note [Drop dead args from specialisations] to explain.
There is a 4% increase in compile time for T15164, because we generate
more specialised code. This seems OK.
Metric Increase:
T15164
- - - - -
27 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/StgToCmm/Utils.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- rts/Prelude.h
- rts/RtsSymbols.c
- rts/StgStdThunks.cmm
- rts/include/stg/MiscClosures.h
- testsuite/tests/linters/notes.stdout
- testsuite/tests/numeric/should_compile/T19641.stderr
- testsuite/tests/simplCore/should_compile/T8331.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -301,6 +301,9 @@ data GenCmmStatics (rawOnly :: Bool) where
-> CmmInfoTable
-> CostCentreStack
-> [CmmLit] -- Payload
+ -> [CmmLit] -- Non-pointers that go to the end of the closure
+ -- This is used by stg_unpack_cstring closures.
+ -- See Note [unpack_cstring closures] in StgStdThunks.cmm.
-> GenCmmStatics 'False
-- | Static data, after SRTs are generated
@@ -432,8 +435,8 @@ pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
--
pprStatics :: Platform -> GenCmmStatics a -> SDoc
-pprStatics platform (CmmStatics lbl itbl ccs payload) =
- pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload
+pprStatics platform (CmmStatics lbl itbl ccs payload extras) =
+ pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload <+> ppr extras
pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)
pprStatic :: Platform -> CmmStatic -> SDoc
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -72,6 +72,8 @@ module GHC.Cmm.CLabel (
mkCAFBlackHoleInfoTableLabel,
mkRtsPrimOpLabel,
mkRtsSlowFastTickyCtrLabel,
+ mkRtsUnpackCStringLabel,
+ mkRtsUnpackCStringUtf8Label,
mkSelectorInfoLabel,
mkSelectorEntryLabel,
@@ -562,6 +564,8 @@ data RtsLabelInfo
| RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks
| RtsApEntry Bool{-updatable-} Int{-arity-}
+ | RtsUnpackCStringInfoTable
+ | RtsUnpackCStringUtf8InfoTable
| RtsPrimOp PrimOp
| RtsApFast NonDetFastString -- ^ _fast versions of generic apply
| RtsSlowFastTickyCtr String
@@ -734,7 +738,6 @@ mkApEntryLabel platform upd arity =
assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $
RtsLabel (RtsApEntry upd arity)
-
-- A call to some primitive hand written Cmm code
mkPrimCallLabel :: PrimCall -> CLabel
mkPrimCallLabel (PrimCall str pkg)
@@ -852,6 +855,11 @@ mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))
mkRtsSlowFastTickyCtrLabel :: String -> CLabel
mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)
+-- | A standard string unpacking thunk. See Note [unpack_cstring closures] in
+-- StgStdThunks.cmm.
+mkRtsUnpackCStringLabel, mkRtsUnpackCStringUtf8Label :: CLabel
+mkRtsUnpackCStringLabel = RtsLabel RtsUnpackCStringInfoTable
+mkRtsUnpackCStringUtf8Label = RtsLabel RtsUnpackCStringUtf8InfoTable
-- Constructing Code Coverage Labels
mkHpcTicksLabel :: Module -> CLabel
@@ -958,6 +966,9 @@ hasIdLabelInfo _ = Nothing
hasCAF :: CLabel -> Bool
hasCAF (IdLabel _ _ (IdTickyInfo TickyRednCounts)) = False -- See Note [ticky for LNE]
hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF (RtsLabel RtsUnpackCStringInfoTable) = True
+hasCAF (RtsLabel RtsUnpackCStringUtf8InfoTable) = True
+ -- The info table stg_MK_STRING_info is for thunks
hasCAF _ = False
-- Note [ticky for LNE]
@@ -1195,6 +1206,9 @@ labelType (CmmLabel _ _ _ CmmRet) = CodeLabel
labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApFast _)) = CodeLabel
+labelType (RtsLabel RtsUnpackCStringInfoTable) = CodeLabel
+labelType (RtsLabel RtsUnpackCStringUtf8InfoTable)
+ = CodeLabel
labelType (RtsLabel _) = DataLabel
labelType (LocalBlockLabel _) = CodeLabel
labelType (SRTLabel _) = DataLabel
@@ -1525,6 +1539,11 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
RtsLabel (RtsSlowFastTickyCtr pat)
-> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"
+ RtsLabel RtsUnpackCStringInfoTable
+ -> maybe_underscore $ text "stg_unpack_cstring_info"
+ RtsLabel RtsUnpackCStringUtf8InfoTable
+ -> maybe_underscore $ text "stg_unpack_cstring_utf8_info"
+
LargeBitmapLabel u
-> maybe_underscore $ tempLabelPrefixOrUnderscore
<> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -576,7 +576,7 @@ cafAnalData
-> CAFSet
cafAnalData platform st = case st of
CmmStaticsRaw _lbl _data -> Set.empty
- CmmStatics _lbl _itbl _ccs payload ->
+ CmmStatics _lbl _itbl _ccs payload _extras ->
foldl' analyzeStatic Set.empty payload
where
analyzeStatic s lit =
@@ -741,7 +741,9 @@ getBlockLabels = mapMaybe getBlockLabel
getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)]
getLabelledBlocks platform decl = case decl of
CmmData _ (CmmStaticsRaw _ _) -> []
- CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]
+ CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl)
+ | not (isThunkRep (cit_rep info))
+ ]
CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl)
| (blockId, info) <- mapToList (info_tbls top_info)
, let rep = cit_rep info
@@ -786,28 +788,48 @@ depAnalSRTs platform cafEnv cafEnv_static decls =
graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
graph = stronglyConnCompFromEdgedVerticesOrd nodes
--- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.
--- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code
+-- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.
+-- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code
-- depends upon.
--
--- CAFs are treated differently from other labelled blocks:
+-- - The 'Label' represents the entry code of the closure. This may be
+-- 'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see
+-- Note [unpack_cstring closures] in StgStdThunks.cmm).
+-- - The 'CAFLabel' is the label of the CAF closure.
+-- - The @Set CAFLabel@ is the set of CAFfy closures which should be included
+-- in the closure's SRT.
+--
+-- Note that CAFs are treated differently from other labelled blocks:
--
-- - we never shortcut a reference to a CAF to the contents of its
-- SRT, since the point of SRTs is to keep CAFs alive.
--
-- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
-- instead we generate their SRTs after everything else.
---
-getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)]
-getCAFs platform cafEnv decls =
- [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)
- | CmmProc top_info topLbl _ g <- decls
- , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
- , let rep = cit_rep info
- , isStaticRep rep && isThunkRep rep
- , Just cafs <- [mapLookup (g_entry g) cafEnv]
- ]
+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]
+getCAFs platform cafEnv = mapMaybe getCAFLabel
+ where
+ getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel)
+
+ getCAFLabel (CmmProc top_info top_lbl _ g)
+ | Just info <- mapLookup (g_entry g) (info_tbls top_info)
+ , let rep = cit_rep info
+ , isStaticRep rep && isThunkRep rep
+ , Just cafs <- mapLookup (g_entry g) cafEnv
+ = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs)
+
+ | otherwise
+ = Nothing
+
+ getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras))
+ | isThunkRep (cit_rep info)
+ = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty)
+
+ | otherwise
+ = Nothing
+ getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload))
+ = Nothing
-- | Get the list of blocks that correspond to the entry points for
-- @FUN_STATIC@ closures. These are the blocks for which if we have an
@@ -882,7 +904,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
CmmData _ static ->
case static of
- CmmStatics lbl _ _ _ -> (lbl, set)
+ CmmStatics lbl _ _ _ _ -> (lbl, set)
CmmStaticsRaw lbl _ -> (lbl, set)
(proc_envs, procss) = unzip procs
@@ -902,7 +924,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls
- cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]
+ cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]
cafsWithSRTs = getCAFs platform cafEnv decls
srtTraceM "doSRTs" (text "data:" <+> pdoc platform data_ $$
@@ -925,7 +947,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
flip runStateT moduleSRTInfo $ do
nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs
cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
- oneSRT cfg staticFuns [BlockLabel l] [cafLbl]
+ oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl]
True{-is a CAF-} cafs static_data_env
return (nonCAFs ++ cAFs)
@@ -1248,6 +1270,7 @@ buildSRT profile refs = do
[] -- no padding
[mkIntCLit platform 0] -- link field
[] -- no saved info
+ [] -- no extras
return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
-- | Update info tables with references to their SRTs. Also generate
@@ -1263,10 +1286,10 @@ updInfoSRTs
updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
= [CmmData s (CmmStaticsRaw lbl statics)]
-updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras))
= [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
where
- field_lits = mkStaticClosureFields profile itbl ccs caffy payload
+ field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras
updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
| Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
@@ -1296,7 +1319,7 @@ updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
(info_tbl { cit_rep = new_rep }, res)
where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
- fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries
+ fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries []
new_rep = case cit_rep of
HeapRep sta ptrs nptrs ty ->
HeapRep sta (ptrs + length srtEntries) nptrs ty
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -435,7 +435,7 @@ static :: { CmmParse [CmmStatic] }
mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
- dontCareCCS (map getLit lits) [] [] [] } }
+ dontCareCCS (map getLit lits) [] [] [] [] } }
-- arrays of closures required for the CHARLIKE & INTLIKE arrays
lits :: { [CmmParse CmmExpr] }
@@ -1248,7 +1248,7 @@ profilingInfo profile desc_str ty_str
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do profile <- getProfile
- let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+ let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] []
code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits
foreignCall
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -211,10 +211,10 @@ However, the odds that we have two expressions that are identical save for the
'Type'/'Constraint' distinction are low. (Not impossible to do. But doubtful
anyone has ever done so in the history of Haskell.)
-And it's actually all OK: 'eqExpr' is conservative: if `eqExpr e1 e2` returns
+And it's actually all OK: 'eqCoreExpr' is conservative: if `eqCoreExpr e1 e2` returns
'True', thne it must be that `e1` behaves identically to `e2` in all contexts.
-But if `eqExpr e1 e2` returns 'False', then we learn nothing. The use of
-'tcView' where we expect 'coreView' means 'eqExpr' returns 'False' bit more
+But if `eqCoreExpr e1 e2` returns 'False', then we learn nothing. The use of
+'tcView' where we expect 'coreView' means 'eqCoreExpr' returns 'False' bit more
often that it should. This might, say, stop a `RULE` from firing or CSE from
optimizing an expression. Stopping `RULE` firing is good actually: `RULES` are
written in Haskell, where `Type /= Constraint`. Stopping CSE is unfortunate,
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -817,7 +817,7 @@ to transform
W y z -> e2
In the simplifier we use cheapEqExpr, because it is called a lot.
-But here in CSE we use the full eqExpr. After all, two alternatives usually
+But here in CSE we use the full eqCoreExpr. After all, two alternatives usually
differ near the root, so it probably isn't expensive to compare the full
alternative. It seems like the same kind of thing that CSE is supposed
to be doing, which is why I put it here.
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -19,7 +19,7 @@ core expression with (hopefully) improved usage information.
module GHC.Core.Opt.OccurAnal (
occurAnalysePgm,
occurAnalyseExpr,
- zapLambdaBndrs
+ zapLambdaBndrs, scrutBinderSwap_maybe
) where
import GHC.Prelude hiding ( head, init, last, tail )
@@ -27,11 +27,12 @@ import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp,
- stripTicksTopE, mkTicks )
+ mkCastMCo, mkTicks )
import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr )
import GHC.Core.Coercion
+import GHC.Core.Predicate ( isDictId )
import GHC.Core.Type
-import GHC.Core.TyCo.FVs( tyCoVarsOfMCo )
+import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo )
import GHC.Data.Maybe( isJust, orElse )
import GHC.Data.Graph.Directed ( SCC(..), Node(..)
@@ -2464,8 +2465,8 @@ data OccEnv
-- See Note [The binder-swap substitution]
-- If x :-> (y, co) is in the env,
- -- then please replace x by (y |> sym mco)
- -- Invariant of course: idType x = exprType (y |> sym mco)
+ -- then please replace x by (y |> mco)
+ -- Invariant of course: idType x = exprType (y |> mco)
, occ_bs_env :: !(VarEnv (OutId, MCoercion))
, occ_bs_rng :: !VarSet -- Vars free in the range of occ_bs_env
-- Domain is Global and Local Ids
@@ -2671,7 +2672,7 @@ The binder-swap is implemented by the occ_bs_env field of OccEnv.
There are two main pieces:
* Given case x |> co of b { alts }
- we add [x :-> (b, co)] to the occ_bs_env environment; this is
+ we add [x :-> (b, sym co)] to the occ_bs_env environment; this is
done by addBndrSwap.
* Then, at an occurrence of a variable, we look up in the occ_bs_env
@@ -2739,30 +2740,8 @@ Some tricky corners:
(BS5) We have to apply the occ_bs_env substitution uniformly,
including to (local) rules and unfoldings.
-Historical note
----------------
-We used to do the binder-swap transformation by introducing
-a proxy let-binding, thus;
-
- case x of b { pi -> ri }
- ==>
- case x of b { pi -> let x = b in ri }
-
-But that had two problems:
-
-1. If 'x' is an imported GlobalId, we'd end up with a GlobalId
- on the LHS of a let-binding which isn't allowed. We worked
- around this for a while by "localising" x, but it turned
- out to be very painful #16296,
-
-2. In CorePrep we use the occurrence analyser to do dead-code
- elimination (see Note [Dead code in CorePrep]). But that
- occasionally led to an unlifted let-binding
- case x of b { DEFAULT -> let x::Int# = b in ... }
- which disobeys one of CorePrep's output invariants (no unlifted
- let-bindings) -- see #5433.
-
-Doing a substitution (via occ_bs_env) is much better.
+(BS6) We must be very careful with dictionaries.
+ See Note [Care with binder-swap on dictionaries]
Note [Case of cast]
~~~~~~~~~~~~~~~~~~~
@@ -2772,6 +2751,54 @@ We'd like to eliminate the inner case. That is the motivation for
equation (2) in Note [Binder swap]. When we get to the inner case, we
inline x, cancel the casts, and away we go.
+Note [Care with binder-swap on dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note explains why we need isDictId in scrutBinderSwap_maybe.
+Consider this tricky example (#21229, #21470):
+
+ class Sing (b :: Bool) where sing :: Bool
+ instance Sing 'True where sing = True
+ instance Sing 'False where sing = False
+
+ f :: forall a. Sing a => blah
+
+ h = \ @(a :: Bool) ($dSing :: Sing a)
+ let the_co = Main.N:Sing[0] <a> :: Sing a ~R# Bool
+ case ($dSing |> the_co) of wild
+ True -> f @'True (True |> sym the_co)
+ False -> f @a dSing
+
+Now do a binder-swap on the case-expression:
+
+ h = \ @(a :: Bool) ($dSing :: Sing a)
+ let the_co = Main.N:Sing[0] <a> :: Sing a ~R# Bool
+ case ($dSing |> the_co) of wild
+ True -> f @'True (True |> sym the_co)
+ False -> f @a (wild |> sym the_co)
+
+And now substitute `False` for `wild` (since wild=False in the False branch):
+
+ h = \ @(a :: Bool) ($dSing :: Sing a)
+ let the_co = Main.N:Sing[0] <a> :: Sing a ~R# Bool
+ case ($dSing |> the_co) of wild
+ True -> f @'True (True |> sym the_co)
+ False -> f @a (False |> sym the_co)
+
+And now we have a problem. The specialiser will specialise (f @a d)a (for all
+vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using
+Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.
+
+The real problem is the binder-swap. It swaps a dictionary variable $dSing
+(of kind Constraint) for a term variable wild (of kind Type). And that is
+dangerous: a dictionary is a /singleton/ type whereas a general term variable is
+not. In this particular example, Bool is most certainly not a singleton type!
+
+Conclusion:
+ for a /dictionary variable/ do not perform
+ the clever cast version of the binder-swap
+
+Hence the subtle isDictId in scrutBinderSwap_maybe.
+
Note [Zap case binders in proxy bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
From the original
@@ -2786,8 +2813,87 @@ binding x = cb. See #5028.
NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier
doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.
+-}
+
+addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
+-- See Note [The binder-swap substitution]
+addBndrSwap scrut case_bndr
+ env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
+ | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut
+ , scrut_var /= case_bndr
+ -- Consider: case x of x { ... }
+ -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop
+ = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)
+ , occ_bs_rng = rng_vars `extendVarSet` case_bndr'
+ `unionVarSet` tyCoVarsOfMCo mco }
+
+ | otherwise
+ = env
+ where
+ case_bndr' = zapIdOccInfo case_bndr
+ -- See Note [Zap case binders in proxy bindings]
+
+scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion)
+-- If (scrutBinderSwap_maybe e = Just (v, mco), then
+-- v = e |> mco
+-- See Note [Case of cast]
+-- See Note [Care with binder-swap on dictionaries]
+--
+-- We use this same function in SpecConstr, and Simplify.Iteration,
+-- when something binder-swap-like is happening
+scrutBinderSwap_maybe (Var v) = Just (v, MRefl)
+scrutBinderSwap_maybe (Cast (Var v) co)
+ | not (isDictId v) = Just (v, MCo (mkSymCo co))
+ -- Cast: see Note [Case of cast]
+ -- isDictId: see Note [Care with binder-swap on dictionaries]
+ -- The isDictId rejects a Constraint/Constraint binder-swap, perhaps
+ -- over-conservatively. But I have never seen one, so I'm leaving
+ -- the code as simple as possible. Losing the binder-swap in a
+ -- rare case probably has very low impact.
+scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e -- Drop ticks
+scrutBinderSwap_maybe _ = Nothing
+
+lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
+-- See Note [The binder-swap substitution]
+-- Returns an expression of the same type as Id
+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr
+ = case lookupVarEnv bs_env bndr of {
+ Nothing -> (Var bndr, bndr) ;
+ Just (bndr1, mco) ->
+
+ -- Why do we iterate here?
+ -- See (BS2) in Note [The binder-swap substitution]
+ case lookupBndrSwap env bndr1 of
+ (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }
+
+
+{- Historical note [Proxy let-bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to do the binder-swap transformation by introducing
+a proxy let-binding, thus;
+
+ case x of b { pi -> ri }
+ ==>
+ case x of b { pi -> let x = b in ri }
+
+But that had two problems:
+
+1. If 'x' is an imported GlobalId, we'd end up with a GlobalId
+ on the LHS of a let-binding which isn't allowed. We worked
+ around this for a while by "localising" x, but it turned
+ out to be very painful #16296,
+
+2. In CorePrep we use the occurrence analyser to do dead-code
+ elimination (see Note [Dead code in CorePrep]). But that
+ occasionally led to an unlifted let-binding
+ case x of b { DEFAULT -> let x::Int# = b in ... }
+ which disobeys one of CorePrep's output invariants (no unlifted
+ let-bindings) -- see #5433.
+
+Doing a substitution (via occ_bs_env) is much better.
+
Historical Note [no-case-of-case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We *used* to suppress the binder-swap in case expressions when
-fno-case-of-case is on. Old remarks:
"This happens in the first simplifier pass,
@@ -2846,53 +2952,8 @@ binder-swap in OccAnal:
It's fixed by doing the binder-swap in OccAnal because we can do the
binder-swap unconditionally and still get occurrence analysis
information right.
--}
-addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
--- See Note [The binder-swap substitution]
-addBndrSwap scrut case_bndr
- env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
- | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) scrut)
- , scrut_var /= case_bndr
- -- Consider: case x of x { ... }
- -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop
- = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)
- , occ_bs_rng = rng_vars `extendVarSet` case_bndr'
- `unionVarSet` tyCoVarsOfMCo mco }
-
- | otherwise
- = env
- where
- get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion)
- get_scrut_var (Var v) = Just (v, MRefl)
- get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast]
- get_scrut_var _ = Nothing
-
- case_bndr' = zapIdOccInfo case_bndr
- -- See Note [Zap case binders in proxy bindings]
-lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
--- See Note [The binder-swap substitution]
--- Returns an expression of the same type as Id
-lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr
- = case lookupVarEnv bs_env bndr of {
- Nothing -> (Var bndr, bndr) ;
- Just (bndr1, mco) ->
-
- -- Why do we iterate here?
- -- See (BS2) in Note [The binder-swap substitution]
- case lookupBndrSwap env bndr1 of
- (fun, fun_id) -> (add_cast fun mco, fun_id) }
-
- where
- add_cast fun MRefl = fun
- add_cast fun (MCo co) = Cast fun (mkSymCo co)
- -- We must switch that 'co' to 'sym co';
- -- see the comment with occ_bs_env
- -- No need to test for isReflCo, because 'co' came from
- -- a (Cast e co) and hence is unlikely to be Refl
-
-{-
************************************************************************
* *
\subsection[OccurAnal-types]{OccEnv}
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -51,17 +51,6 @@
The simplifier tries to get rid of occurrences of x, in favour of wild,
in the hope that there will only be one remaining occurrence of x, namely
the scrutinee of the case, and we can inline it.
-
- This can only work if @wild@ is an unrestricted binder. Indeed, even with the
- extended typing rule (in the linter) for case expressions, if
- case x of wild % 1 { p -> e}
- is well-typed, then
- case x of wild % 1 { p -> e[wild\x] }
- is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@
- at all). In which case, it is, of course, pointless to do the substitution
- anyway. So for a linear binder (and really anything which isn't unrestricted),
- doing this substitution would either produce ill-typed terms or be the
- identity.
-}
module GHC.Core.Opt.SetLevels (
@@ -1602,7 +1591,9 @@ extendCaseBndrEnv :: LevelEnv
-> LevelEnv
extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
case_bndr (Var scrut_var)
- | Many <- varMult case_bndr
+ -- We could use OccurAnal. scrutBinderSwap_maybe here, and perhaps
+ -- get a bit more floating. But we didn't in the past and it's
+ -- an unforced change, so I'm leaving it.
= le { le_subst = extendSubstWithVar subst case_bndr scrut_var
, le_env = add_id id_env (case_bndr, scrut_var) }
extendCaseBndrEnv env _ _ = env
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -71,7 +71,8 @@ import GHC.Core.Make ( mkWildValBinder, mkCoreLet )
import GHC.Builtin.Types
import GHC.Core.TyCo.Rep ( TyCoBinder(..) )
import qualified GHC.Core.Type as Type
-import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst )
+import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo
+ , extendTvSubst, extendCvSubst )
import qualified GHC.Core.Coercion as Coercion
import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
import GHC.Platform ( Platform )
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -22,7 +22,7 @@ import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Utils
-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )
+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutBinderSwap_maybe )
import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
import qualified GHC.Core.Make
import GHC.Core.Coercion hiding ( substCo, substCoVar )
@@ -3286,19 +3286,21 @@ zapIdOccInfoAndSetEvald str v =
-- see Note [Case alternative occ info]
addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
-addAltUnfoldings env scrut case_bndr con_app
+addAltUnfoldings env mb_scrut case_bndr con_app
= do { let con_app_unf = mk_simple_unf con_app
env1 = addBinderUnfolding env case_bndr con_app_unf
-- See Note [Add unfolding for scrutinee]
- env2 | Many <- idMult case_bndr = case scrut of
- Just (Var v) -> addBinderUnfolding env1 v con_app_unf
- Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
- mk_simple_unf (Cast con_app (mkSymCo co))
- _ -> env1
+ env2 | Just scrut <- mb_scrut
+ , Just (v,mco) <- scrutBinderSwap_maybe scrut
+ = addBinderUnfolding env1 v $
+ if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf
+ then con_app_unf -- twice in the common case
+ else mk_simple_unf (mkCastMCo con_app mco)
+
| otherwise = env1
- ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
+ ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr mb_scrut, ppr con_app])
; return env2 }
where
-- Force the opts, so that the whole SimplEnv isn't retained
@@ -3361,9 +3363,6 @@ it's also good for case-elimination -- suppose that 'f' was inlined
and did multi-level case analysis, then we'd solve it in one
simplifier sweep instead of two.
-Exactly the same issue arises in GHC.Core.Opt.SpecConstr;
-see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr
-
HOWEVER, given
case x of y { Just a -> r1; Nothing -> r2 }
we do not want to add the unfolding x -> y to 'x', which might seem cool,
@@ -3374,8 +3373,11 @@ piece of information.
So instead we add the unfolding x -> Just a, and x -> Nothing in the
respective RHSs.
-Since this transformation is tantamount to a binder swap, the same caveat as in
-Note [Suppressing binder-swaps on linear case] in OccurAnal apply.
+Since this transformation is tantamount to a binder swap, we use
+GHC.Core.Opt.OccurAnal.scrutBinderSwap_maybe to do the check.
+
+Exactly the same issue arises in GHC.Core.Opt.SpecConstr;
+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr
************************************************************************
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Core.Unfold
import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars )
import GHC.Core.Opt.Monad
import GHC.Core.Opt.WorkWrap.Utils
+import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe )
import GHC.Core.DataCon
import GHC.Core.Class( classTyVars )
import GHC.Core.Coercion hiding( substCo )
@@ -1072,8 +1073,8 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
= (env2, alt_bndrs')
where
live_case_bndr = not (isDeadBinder case_bndr)
- env1 | Var v <- stripTicksTopE (const True) scrut
- = extendValEnv env v cval
+ env1 | Just (v, mco) <- scrutBinderSwap_maybe scrut
+ , isReflMCo mco = extendValEnv env v cval
| otherwise = env -- See Note [Add scrutinee to ValueEnv too]
env2 | live_case_bndr = extendValEnv env1 case_bndr cval
| otherwise = env1
@@ -1167,6 +1168,10 @@ though the simplifier has systematically replaced uses of 'x' with 'y'
and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came
from outside the case. See #4908 for the live example.
+It's very like the binder-swap story, so we use scrutBinderSwap_maybe
+to identify suitable scrutinees -- but only if there is no cast
+(isReflMCo) because that's all that the ValueEnv allows.
+
Note [Avoiding exponential blowup]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The sc_count field of the ScEnv says how many times we are prepared to
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -15,9 +15,7 @@ import GHC.Driver.Config
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
-import GHC.Tc.Utils.TcType hiding( substTy )
-
-import GHC.Core.Type hiding( substTy, extendTvSubstList, zapSubst )
+import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Core.Coercion( Coercion )
@@ -25,12 +23,15 @@ import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
import GHC.Core.Unfold.Make
import GHC.Core
+import GHC.Core.Make ( mkLitRubbish )
+import GHC.Core.Unify ( tcMatchTy )
import GHC.Core.Rules
import GHC.Core.Utils ( exprIsTrivial
, mkCast, exprType
, stripTicksTop, mkInScopeSetBndrs )
import GHC.Core.FVs
-import GHC.Core.TyCo.Rep (TyCoBinder (..))
+import GHC.Core.TyCo.Rep ( TyCoBinder (..) )
+import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
import GHC.Builtin.Types ( unboxedUnitTy )
@@ -531,6 +532,48 @@ like
f :: Eq [(a,b)] => ...
+Note [Specialisation and overlapping instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is at tricky case (see a comment in MR !8916):
+
+ module A where
+ class C a where
+ meth :: a -> String
+ instance {-# OVERLAPPABLE #-} C (Maybe a) where
+ meth _ = "Maybe"
+
+ {-# SPECIALISE f :: Maybe a -> Bool -> String #-}
+ f :: C a => a -> Bool -> String
+ f a True = f a False
+ f a _ = meth a
+
+ module B where
+ import A
+
+ instance C (Maybe Int) where
+ meth _ = "Int"
+
+ main = putStrLn $ f (Just 42 :: Maybe Int) True
+
+Running main without optimisations yields "Int", the correct answer.
+Activating optimisations yields "Maybe" due to a rewrite rule in module
+A generated by the SPECIALISE pragma:
+
+ RULE "USPEC f" forall a (d :: C a). f @a d = $sf
+
+In B we get the call (f @(Maybe Int) (d :: C (Maybe Int))), and
+that rewrites to $sf, but that isn't really right.
+
+Overlapping instances mean that `C (Maybe Int)` is not a singleton
+type: there two distinct dictionaries that have this type. And that
+spells trouble for specialistion, which really asssumes singleton
+types.
+
+For now, we just accept this problem, but it may bite us one day.
+One solution would be to decline to expose any specialisation rules
+to an importing module -- but that seems a bit drastic.
+
+
************************************************************************
* *
\subsubsection{The new specialiser}
@@ -804,8 +847,12 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _)
canSpecImport :: DynFlags -> Id -> Maybe CoreExpr
canSpecImport dflags fn
+ | isDataConWrapId fn
+ = Nothing -- Don't specialise data-con wrappers, even if they
+ -- have dict args; there is no benefit.
+
| CoreUnfolding { uf_tmpl = rhs } <- unf
- -- See Note [Specialising imported functions] point (1).
+ -- CoreUnfolding: see Note [Specialising imported functions] point (1).
, isAnyInlinePragma (idInlinePragma fn)
-- See Note [Specialising imported functions] point (2).
= Just rhs
@@ -1508,12 +1555,12 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)
- "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $
+ "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $
-- Note [Specialisation shape]
-- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $
return ([], [], emptyUDs)
where
- _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]
+ trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]
fn_type = idType fn
fn_arity = idArity fn
@@ -1577,8 +1624,16 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
else
do { -- Run the specialiser on the specialised RHS
-- The "1" suffix is before we maybe add the void arg
- ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body
- ; let spec_fn_ty1 = exprType spec_rhs1
+ ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body
+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ -- to the rhs_uds; see Note [Specialising Calls]
+ ; let rhs_uds_w_dx = foldr consDictBind rhs_uds dx_binds
+ spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs
+ (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
+ spec_rhs1 = mkLams spec_rhs_bndrs $
+ wrapDictBindsE dumped_dbs rhs_body'
+
+ spec_fn_ty1 = exprType spec_rhs1
-- Maybe add a void arg to the specialised function,
-- to avoid unlifted bindings
@@ -1612,10 +1667,6 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
herald fn rule_bndrs rule_lhs_args
(mkVarApps (Var spec_fn) spec_bndrs)
- -- Add the { d1' = dx1; d2' = dx2 } usage stuff
- -- See Note [Specialising Calls]
- spec_uds = foldr consDictBind rhs_uds dx_binds
-
simpl_opts = initSimpleOpts dflags
--------------------------------------
@@ -1798,11 +1849,23 @@ in the specialisation:
{-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}
This doesn’t save us much, since the arg would be removed later by
-worker/wrapper, anyway, but it’s easy to do. Note, however, that we
-only drop dead arguments if:
+worker/wrapper, anyway, but it’s easy to do.
- 1. We don’t specialise on them.
- 2. They come before an argument we do specialise on.
+Wrinkles
+
+* Note that we only drop dead arguments if:
+ 1. We don’t specialise on them.
+ 2. They come before an argument we do specialise on.
+ Doing the latter would require eta-expanding the RULE, which could
+ make it match less often, so it’s not worth it. Doing the former could
+ be more useful --- it would stop us from generating pointless
+ specialisations --- but it’s more involved to implement and unclear if
+ it actually provides much benefit in practice.
+
+* If the function has a stable unfolding, specHeader has to come up with
+ arguments to pass to that stable unfolding, when building the stable
+ unfolding of the specialised function: this is the last field in specHeader's
+ big result tuple.
The right thing to do is to produce a LitRubbish; it should rapidly
disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.
@@ -2253,11 +2316,11 @@ instance Outputable SpecArg where
ppr (SpecDict d) = text "SpecDict" <+> ppr d
ppr UnspecArg = text "UnspecArg"
-specArgFreeVars :: SpecArg -> VarSet
-specArgFreeVars (SpecType ty) = tyCoVarsOfType ty
-specArgFreeVars (SpecDict dx) = exprFreeVars dx
-specArgFreeVars UnspecType = emptyVarSet
-specArgFreeVars UnspecArg = emptyVarSet
+specArgFreeIds :: SpecArg -> IdSet
+specArgFreeIds (SpecType {}) = emptyVarSet
+specArgFreeIds (SpecDict dx) = exprFreeIds dx
+specArgFreeIds UnspecType = emptyVarSet
+specArgFreeIds UnspecArg = emptyVarSet
isSpecDict :: SpecArg -> Bool
isSpecDict (SpecDict {}) = True
@@ -2327,24 +2390,33 @@ specHeader
, [OutBndr] -- Binders for $sf
, [DictBind] -- Auxiliary dictionary bindings
, [OutExpr] -- Specialised arguments for unfolding
- -- Same length as "args for LHS of rule"
+ -- Same length as "Args for LHS of rule"
)
-- We want to specialise on type 'T1', and so we must construct a substitution
-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
-- details.
-specHeader env (bndr : bndrs) (SpecType t : args)
- = do { let env' = extendTvSubstList env [(bndr, t)]
- ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
+specHeader env (bndr : bndrs) (SpecType ty : args)
+ = do { -- Find qvars, the type variables to add to the binders for the rule
+ -- Namely those free in `ty` that aren't in scope
+ -- See (MP2) in Note [Specialising polymorphic dictionaries]
+ let in_scope = Core.getSubstInScope (se_subst env)
+ qvars = scopedSort $
+ filterOut (`elemInScopeSet` in_scope) $
+ tyCoVarsOfTypeList ty
+ (env1, qvars') = substBndrs env qvars
+ ty' = substTy env1 ty
+ env2 = extendTvSubst env1 bndr ty'
+ ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env2 bndrs args
; pure ( useful
- , env''
+ , env3
, leftover_bndrs
- , rule_bs
- , Type t : rule_es
- , bs'
+ , qvars' ++ rule_bs
+ , Type ty' : rule_es
+ , qvars' ++ bs'
, dx
- , Type t : spec_args
+ , Type ty' : spec_args
)
}
@@ -2371,6 +2443,7 @@ specHeader env (bndr : bndrs) (UnspecType : args)
-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
-- the nitty-gritty), as a LHS rule and unfolding details.
specHeader env (bndr : bndrs) (SpecDict d : args)
+ | not (isDeadBinder bndr)
= do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
@@ -2387,29 +2460,44 @@ specHeader env (bndr : bndrs) (SpecDict d : args)
)
}
--- Finally, we have the unspecialised argument 'i'. We need to produce
--- a binder, LHS and RHS argument for the RULE, and a binder for the
--- specialised body.
+-- Finally, we don't want to specialise on this argument 'i':
+-- - It's an UnSpecArg, or
+-- - It's a dead dictionary
+-- We need to produce a binder, LHS and RHS argument for the RULE, and
+-- a binder for the specialised body.
--
-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is
-- why 'i' doesn't appear in our RULE above. But we have no guarantee that
-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
-- this case must be here.
-specHeader env (bndr : bndrs) (UnspecArg : args)
+specHeader env (bndr : bndrs) (_ : args)
+ -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead
= do { -- see Note [Zap occ info in rule binders]
let (env', bndr') = substBndr env (zapIdOccInfo bndr)
; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
<- specHeader env' bndrs args
+
+ ; let bndr_ty = idType bndr'
+
+ -- See Note [Drop dead args from specialisations]
+ -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let
+ (mb_spec_bndr, spec_arg)
+ | isDeadBinder bndr
+ , Just lit_expr <- mkLitRubbish bndr_ty
+ = (Nothing, lit_expr)
+ | otherwise
+ = (Just bndr', varToCoreExpr bndr')
+
; pure ( useful
, env''
, leftover_bndrs
, bndr' : rule_bs
, varToCoreExpr bndr' : rule_es
- , if isDeadBinder bndr
- then bs' -- see Note [Drop dead args from specialisations]
- else bndr' : bs'
+ , case mb_spec_bndr of
+ Just b' -> b' : bs'
+ Nothing -> bs'
, dx
- , varToCoreExpr bndr' : spec_args
+ , spec_arg : spec_args
)
}
@@ -2535,6 +2623,88 @@ successfully specialise 'f'.
So the DictBinds in (ud_binds :: OrdList DictBind) may contain
non-dictionary bindings too.
+
+Note [Specialising polymorphic dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ class M a where { foo :: a -> Int }
+
+ instance M (ST s) where ...
+ -- dMST :: forall s. M (ST s)
+
+ wimwam :: forall a. M a => a -> Int
+ wimwam = /\a \(d::M a). body
+
+ f :: ST s -> Int
+ f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1
+
+We'd like to specialise wimwam at (ST s), thus
+ $swimwam :: forall s. ST s -> Int
+ $swimwam = /\s. body[ST s/a, (dMST @s)/d]
+
+ RULE forall s (d :: M (ST s)).
+ wimwam @(ST s) d = $swimwam @s
+
+Here are the moving parts:
+
+(MP1) We must /not/ dump the CallInfo
+ CIS wimwam (CI { ci_key = [@(ST s), dMST @s]
+ , ci_fvs = {dMST} })
+ when we come to the /\s. Instead, we simply let it continue to float
+ upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that
+ are free in the call, but not the /TyVars/. Hence using specArgFreeIds
+ in singleCall.
+
+ NB to be fully kosher we should explicitly quantifying the CallInfo
+ over 's', but we don't bother. This would matter if there was an
+ enclosing binding of the same 's', which I don't expect to happen.
+
+(MP2) When we come to specialise the call, we must remember to quantify
+ over 's'. That is done in the SpecType case of specHeader, where
+ we add 's' (called qvars) to the binders of the RULE and the specialised
+ function.
+
+(MP3) If we have f :: forall m. Monoid m => blah, and two calls
+ (f @(Endo b) (d :: Monoid (Endo b))
+ (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))
+ we want to generate a specialisation only for the first. The second
+ is just a substitution instance of the first, with no greater specialisation.
+ Hence the call to `remove_dups` in `filterCalls`.
+
+All this arose in #13873, in the unexpected form that a SPECIALISE
+pragma made the program slower! The reason was that the specialised
+function $sinsertWith arising from the pragma looked rather like `f`
+above, and failed to specialise a call in its body like wimwam.
+Without the pragma, the original call to `insertWith` was completely
+monomorpic, and specialised in one go.
+
+Wrinkles.
+
+* With -XOverlappingInstances you might worry about this:
+ class C a where ...
+ instance C (Maybe Int) where ... -- $df1 :: C (Maybe Int)
+ instance C (Maybe a) where ... -- $df2 :: forall a. C (Maybe a)
+
+ f :: C a => blah
+ f = rhs
+
+ g = /\a. ...(f @(Maybe a) ($df2 a))...
+ h = ...f @(Maybe Int) $df1
+
+ There are two calls to f, but with different evidence. This patch will
+ combine them into one. But it's OK: this code will never arise unless you
+ use -XIncoherentInstances. Even with -XOverlappingInstances, GHC tries hard
+ to keep dictionaries as singleton types. But that goes out of the window
+ with -XIncoherentInstances -- and that is true even with ordianry type-class
+ specialisation (at least if any inlining has taken place).
+
+ GHC makes very few guarantees when you use -XIncoherentInstances, and its
+ not worth crippling the normal case for the incoherent corner. (The best
+ thing might be to switch off specialisation altogether if incoherence is
+ involved... but incoherence is a property of an instance, not a class, so
+ it's a hard test to make.)
+
+ But see Note [Specialisation and overlapping instances].
-}
instance Outputable DictBind where
@@ -2573,8 +2743,9 @@ data CallInfoSet = CIS Id (Bag CallInfo)
data CallInfo
= CI { ci_key :: [SpecArg] -- All arguments
, ci_fvs :: IdSet -- Free Ids of the ci_key call
- -- _not_ including the main id itself, of course
+ -- /not/ including the main id itself, of course
-- NB: excluding tyvars:
+ -- See Note [Specialising polymorphic dictionaries]
}
type DictExpr = CoreExpr
@@ -2620,17 +2791,12 @@ singleCall :: Id -> [SpecArg] -> UsageDetails
singleCall id args
= MkUD {ud_binds = emptyFDBs,
ud_calls = unitDVarEnv id $ CIS id $
- unitBag (CI { ci_key = args -- used to be tys
+ unitBag (CI { ci_key = args
, ci_fvs = call_fvs }) }
where
- call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args
- -- The type args (tys) are guaranteed to be part of the dictionary
- -- types, because they are just the constrained types,
- -- and the dictionary is therefore sure to be bound
- -- inside the binding for any type variables free in the type;
- -- hence it's safe to neglect tyvars free in tys when making
- -- the free-var set for this call
- -- BUT I don't trust this reasoning; play safe and include tys_fvs
+ call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args
+ -- specArgFreeIds: we specifically look for free Ids, not TyVars
+ -- see (MP1) in Note [Specialising polymorphic dictionaries]
--
-- We don't include the 'id' itself.
@@ -2953,15 +3119,15 @@ callsForMe fn uds at MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
----------------------
filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
--- Remove dominated calls
+-- Remove dominated calls (Note [Specialising polymorphic dictionaries])
-- and loopy DFuns (Note [Avoiding loops (DFuns)])
filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
| isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns
- = filter ok_call unfiltered_calls
+ = filter ok_call de_dupd_calls
| otherwise -- Do not apply it to non-DFuns
- = unfiltered_calls -- See Note [Avoiding loops (non-DFuns)]
+ = de_dupd_calls -- See Note [Avoiding loops (non-DFuns)]
where
- unfiltered_calls = bagToList call_bag
+ de_dupd_calls = remove_dups call_bag
dump_set = foldl' go (unitVarSet fn) dbs
-- This dump-set could also be computed by splitDictBinds
@@ -2975,6 +3141,31 @@ filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
+remove_dups :: Bag CallInfo -> [CallInfo]
+-- Calls involving more generic instances beat more specific ones.
+-- See (MP3) in Note [Specialising polymorphic dictionaries]
+remove_dups calls = foldr add [] calls
+ where
+ add :: CallInfo -> [CallInfo] -> [CallInfo]
+ add ci [] = [ci]
+ add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis
+ | ci1 `beats_or_same` ci2 = ci1:cis
+ | otherwise = ci2 : add ci1 cis
+
+beats_or_same :: CallInfo -> CallInfo -> Bool
+beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
+ = go args1 args2
+ where
+ go [] _ = True
+ go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2
+ go (_:_) [] = False
+
+ go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)
+ go_arg UnspecType UnspecType = True
+ go_arg (SpecDict {}) (SpecDict {}) = True
+ go_arg UnspecArg UnspecArg = True
+ go_arg _ _ = False
+
----------------------
splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet)
-- splitDictBinds dbs bndrs returns
@@ -3005,15 +3196,18 @@ splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
----------------------
deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
--- Remove calls *mentioning* bs in any way
-deleteCallsMentioning bs calls
+-- Remove calls mentioning any Id in bndrs
+-- NB: The call is allowed to mention TyVars in bndrs
+-- Note [Specialising polymorphic dictionaries]
+-- ci_fvs are just the free /Ids/
+deleteCallsMentioning bndrs calls
= mapDVarEnv (ciSetFilter keep_call) calls
where
- keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs
+ keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
--- Remove calls *for* bs
-deleteCallsFor bs calls = delDVarEnvList calls bs
+-- Remove calls *for* bndrs
+deleteCallsFor bndrs calls = delDVarEnvList calls bndrs
{-
************************************************************************
@@ -3036,9 +3230,9 @@ mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
(ys, uds2) <- mapAndCombineSM f xs
return (y:ys, uds1 `thenUDs` uds2)
-extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
-extendTvSubstList env tv_binds
- = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds }
+extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv
+extendTvSubst env tv ty
+ = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }
extendInScope :: SpecEnv -> OutId -> SpecEnv
extendInScope env@(SE { se_subst = subst }) bndr
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -26,7 +26,8 @@ module GHC.Core.Subst (
extendIdSubstWithClone,
extendSubst, extendSubstList, extendSubstWithVar,
extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,
- isInScope, setInScope, extendTvSubst, extendCvSubst,
+ isInScope, setInScope, getSubstInScope,
+ extendTvSubst, extendCvSubst,
delBndr, delBndrs, zapSubst,
-- ** Substituting and cloning binders
@@ -41,7 +42,6 @@ import GHC.Core
import GHC.Core.FVs
import GHC.Core.Seq
import GHC.Core.Utils
-import GHC.Core.TyCo.Subst ( substCo )
-- We are defining local versions
import GHC.Core.Type hiding ( substTy )
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -219,7 +219,7 @@ module GHC.Core.Type (
substTyAddInScope,
substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,
substThetaUnchecked, substTyWithUnchecked,
- substCoUnchecked, substCoWithUnchecked,
+ substCo, substCoUnchecked, substCoWithUnchecked,
substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
substVarBndr, substVarBndrs,
substTyCoBndr,
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -34,8 +34,7 @@ module GHC.Core.Utils (
altsAreExhaustive, etaExpansionTick,
-- * Equality
- cheapEqExpr, cheapEqExpr', eqExpr,
- diffBinds,
+ cheapEqExpr, cheapEqExpr', diffBinds,
-- * Manipulating data constructors and types
exprToType,
@@ -79,7 +78,6 @@ import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.TyCon
import GHC.Core.Multiplicity
-import GHC.Core.Map.Expr ( eqCoreExpr )
import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )
import GHC.Builtin.PrimOps
@@ -2121,12 +2119,6 @@ cheapEqExpr' ignoreTick e1 e2
-eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
--- Compares for equality, modulo alpha
--- TODO: remove eqExpr once GHC 9.4 is released
-eqExpr _ = eqCoreExpr
-{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-}
-
-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -25,6 +25,8 @@ import GHC.Stg.Syntax
import GHC.Platform
import GHC.Platform.Profile
+import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name)
+
import GHC.StgToCmm.Config
import GHC.StgToCmm.Expr
import GHC.StgToCmm.Monad
@@ -87,6 +89,9 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args
in (cg_id_info, gen_code lf_info closure_label)
where
+
+ gen_code :: LambdaFormInfo -> CLabel -> FCode ()
+
-- special case for a indirection (f = g). We create an IND_STATIC
-- closure pointing directly to the indirectee. This is exactly
-- what the CAF will eventually evaluate to anyway, we're just
@@ -101,11 +106,44 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
-- concurrent/should_run/4030 fails, for instance.
--
gen_code _ closure_label
- | StgApp f [] <- body, null args, isNonRec rec
+ | StgApp f [] <- body
+ , null args
+ , isNonRec rec
= do
cg_info <- getCgIdInfo f
emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
+ -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks.
+ --
+ -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc
+ -- ticks) since we want to ensure that these ticks are not lost (e.g.
+ -- resulting in Strings being reported by hpc as uncovered). However, we
+ -- don't worry about standard profiling ticks since unpackCString tends not
+ -- be terribly interesting in profiles. See Note [unpack_cstring closures] in
+ -- StgStdThunks.cmm.
+ gen_code _ closure_label
+ | null args
+ , StgApp f [arg] <- stripStgTicksTopE (not . tickishIsCode) body
+ , Just unpack <- is_string_unpack_op f
+ = do arg' <- getArgAmode (NonVoid arg)
+ case arg' of
+ CmmLit lit -> do
+ let info = CmmInfoTable
+ { cit_lbl = unpack
+ , cit_rep = HeapRep True 0 1 Thunk
+ , cit_prof = NoProfilingInfo
+ , cit_srt = Nothing
+ , cit_clo = Nothing
+ }
+ emitDecl $ CmmData (Section Data closure_label) $
+ CmmStatics closure_label info ccs [] [lit]
+ _ -> panic "cgTopRhsClosure.gen_code"
+ where
+ is_string_unpack_op f
+ | idName f == unpackCStringName = Just mkRtsUnpackCStringLabel
+ | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label
+ | otherwise = Nothing
+
gen_code lf_info _closure_label
= do { profile <- getProfile
; let name = idName id
=====================================
compiler/GHC/StgToCmm/Heap.hs
=====================================
@@ -161,19 +161,20 @@ hpStore base vals = do
-- Layout of static closures
-----------------------------------------------------------
--- Make a static closure, adding on any extra padding needed for CAFs,
--- and adding a static link field if necessary.
-
+-- | Make a static closure, adding on any extra padding needed for CAFs, and
+-- adding a static link field if necessary.
mkStaticClosureFields
:: Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
- -> [CmmLit] -- Payload
+ -> [CmmLit] -- ^ Payload
+ -> [CmmLit] -- ^ Extra non-pointers that go to the end of the closure.
+ -- See Note [unpack_cstring closures] in StgStdThunks.cmm.
-> [CmmLit] -- The full closure
-mkStaticClosureFields profile info_tbl ccs caf_refs payload
+mkStaticClosureFields profile info_tbl ccs caf_refs payload extras
= mkStaticClosure profile info_lbl ccs payload padding
- static_link_field saved_info_field
+ static_link_field saved_info_field extras
where
platform = profilePlatform profile
info_lbl = cit_lbl info_tbl
@@ -218,14 +219,15 @@ mkStaticClosureFields profile info_tbl ccs caf_refs payload
-- in rts/sm/Storage.h
mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit]
- -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field
+ -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
+mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field extras
= [CmmLabel info_lbl]
++ staticProfHdr profile ccs
++ payload
++ padding
++ static_link_field
++ saved_info_field
+ ++ extras
-----------------------------------------------------------
-- Heap overflow checking
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -266,7 +266,7 @@ emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon lbl itbl ccs payload =
- emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
+ emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload []))
-------------------------------------------------------------------------
--
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -2617,24 +2617,36 @@ type Cxt = [Pred] -- ^ @(Eq a, Ord b)@
-- be tuples of other constraints.
type Pred = Type
+-- | 'SourceUnpackedness' corresponds to unpack annotations found in the source code.
+--
+-- This may not agree with the annotations returned by 'reifyConStrictness'.
+-- See 'reifyConStrictness' for more information.
data SourceUnpackedness
= NoSourceUnpackedness -- ^ @C a@
| SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@
| SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@
deriving (Show, Eq, Ord, Data, Generic)
+-- | 'SourceStrictness' corresponds to strictness annotations found in the source code.
+--
+-- This may not agree with the annotations returned by 'reifyConStrictness'.
+-- See 'reifyConStrictness' for more information.
data SourceStrictness = NoSourceStrictness -- ^ @C a@
| SourceLazy -- ^ @C {~}a@
| SourceStrict -- ^ @C {!}a@
deriving (Show, Eq, Ord, Data, Generic)
-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'
--- refers to the strictness that the compiler chooses for a data constructor
--- field, which may be different from what is written in source code. See
--- 'reifyConStrictness' for more information.
-data DecidedStrictness = DecidedLazy
- | DecidedStrict
- | DecidedUnpack
+-- refers to the strictness annotations that the compiler chooses for a data constructor
+-- field, which may be different from what is written in source code.
+--
+-- Note that non-unpacked strict fields are assigned 'DecidedLazy' when a bang would be inappropriate,
+-- such as the field of a newtype constructor and fields that have an unlifted type.
+--
+-- See 'reifyConStrictness' for more information.
+data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.
+ | DecidedStrict -- ^ Field inferred to have a bang.
+ | DecidedUnpack -- ^ Field inferred to be unpacked.
deriving (Show, Eq, Ord, Data, Generic)
-- | A single data constructor.
=====================================
rts/Prelude.h
=====================================
@@ -33,6 +33,7 @@ PRELUDE_CLOSURE(ghczmprim_GHCziTupleziPrim_Z0T_closure);
PRELUDE_CLOSURE(ghczmprim_GHCziTypes_True_closure);
PRELUDE_CLOSURE(ghczmprim_GHCziTypes_False_closure);
PRELUDE_CLOSURE(base_GHCziPack_unpackCString_closure);
+PRELUDE_CLOSURE(base_GHCziPack_unpackCStringUtf8_closure);
PRELUDE_CLOSURE(base_GHCziWeak_runFinalizzerBatch_closure);
PRELUDE_CLOSURE(base_GHCziWeakziFinalizze_runFinalizzerBatch_closure);
@@ -70,6 +71,7 @@ PRELUDE_CLOSURE(base_GHCziEventziWindows_processRemoteCompletion_closure);
PRELUDE_CLOSURE(base_GHCziTopHandler_flushStdHandles_closure);
PRELUDE_CLOSURE(base_GHCziTopHandler_runMainIO_closure);
+PRELUDE_INFO(ghczmprim_GHCziCString_unpackCStringzh_info);
PRELUDE_INFO(ghczmprim_GHCziTypes_Czh_con_info);
PRELUDE_INFO(ghczmprim_GHCziTypes_Izh_con_info);
PRELUDE_INFO(ghczmprim_GHCziTypes_Fzh_con_info);
=====================================
rts/RtsSymbols.c
=====================================
@@ -9,6 +9,7 @@
#include "ghcplatform.h"
#include "Rts.h"
#include "RtsSymbols.h"
+
#include "TopHandler.h"
#include "HsFFI.h"
#include "CloneStack.h"
@@ -713,7 +714,7 @@ extern char **environ;
SymI_HasProto(defaultRtsConfig) \
SymI_HasProto(initLinker) \
SymI_HasProto(initLinker_) \
- SymI_HasDataProto(stg_unpackClosurezh) \
+ SymI_HasDataProto(stg_unpackClosurezh) \
SymI_HasDataProto(stg_closureSizzezh) \
SymI_HasDataProto(stg_whereFromzh) \
SymI_HasDataProto(stg_getApStackValzh) \
@@ -976,6 +977,8 @@ extern char **environ;
SymI_HasDataProto(stg_sel_13_noupd_info) \
SymI_HasDataProto(stg_sel_14_noupd_info) \
SymI_HasDataProto(stg_sel_15_noupd_info) \
+ SymI_HasDataProto(stg_unpack_cstring_info) \
+ SymI_HasDataProto(stg_unpack_cstring_utf8_info) \
SymI_HasDataProto(stg_upd_frame_info) \
SymI_HasDataProto(stg_bh_upd_frame_info) \
SymI_HasProto(suspendThread) \
=====================================
rts/StgStdThunks.cmm
=====================================
@@ -13,6 +13,9 @@
#include "Cmm.h"
#include "Updates.h"
+import ghczmprim_GHCziCString_unpackCStringzh_info;
+import ghczmprim_GHCziCString_unpackCStringUtf8zh_info;
+
/* -----------------------------------------------------------------------------
The code for a thunk that simply extracts a field from a
single-constructor datatype depends only on the offset of the field
@@ -286,3 +289,100 @@ INFO_TABLE(stg_ap_7_upd,7,0,THUNK,"stg_ap_7_upd_info","stg_ap_7_upd_info")
StgThunk_payload(node,6));
}
}
+
+/* -----------------------------------------------------------------------------
+ Making strings
+ -------------------------------------------------------------------------- */
+
+/*
+ * Note [unpack_cstring closures]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * Strings are extremely common. In Core they will typically manifest as the
+ * a pair of top-level bindings:
+ *
+ * s :: String
+ * s = unpackCString# s#
+ *
+ * s# :: Addr#
+ * s# = "hello world"#
+ *
+ * It turns out that `s` is a non-trivial amount of code which is duplicated
+ * for every `String` literal. To avoid this duplicate, we have a standard
+ * string-unpacking closure, unpack_cstring. Note that currently we only do
+ * this for ASCII strings; strings mentioning non-ASCII characters are
+ * represented by CAF applications of unpackCStringUtf8# as before.
+ *
+ * unpack_cstring closures are similar to standard THUNK_STATIC closures but
+ * with a non-GC pointer to a C-string at the end (the "extra" pointer).
+ * We must place this extra pointer at the end of the closure to ensure that
+ * it has a similar layout to a normal THUNK_STATIC closure, which has no space
+ * for free variables (since these would be contained in the thunk's code and SRT).
+ *
+ * When it is evaluated, an stg_unpack_cstring closure is updated to be an
+ * indirection to the resulting [Char], just as a normal unpackCString# thunk
+ * would be.
+ *
+ * Closure layout:
+ *
+ * ┌───────────────────┐ ┌──► ┌──────────────────────────┐
+ * │ stg_unpack_cstring│ │ │ "hello world ..." │
+ * ├───────────────────┤ │ └──────────────────────────┘
+ * │ indirectee │ │
+ * ├───────────────────┤ │
+ * │ static_link │ │
+ * ├───────────────────┤ │
+ * │ saved_info │ │
+ * ├───────────────────┤ │
+ * │ the_string ─┼───────┘
+ * └───────────────────┘
+ *
+ */
+
+stg_do_unpack_cstring(P_ node, P_ newCAF_ret) {
+ STK_CHK_PP(WDS(SIZEOF_StgUpdateFrame), stg_do_unpack_cstring, node, newCAF_ret);
+ W_ str;
+ str = StgThunk_payload(node, 2);
+ push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
+ jump %ENTRY_CODE(ghczmprim_GHCziCString_unpackCStringzh_info)(node, str);
+ }
+}
+
+INFO_TABLE(stg_unpack_cstring, 0, 0, THUNK_STATIC, "stg_unpack_cstring", "stg_unpack_cstring")
+ (P_ node)
+{
+ W_ newCAF_ret;
+ (newCAF_ret) = ccall newCAF(BaseReg "ptr", node "ptr");
+
+ if (newCAF_ret == 0) {
+ // We raced with another thread to evaluate the CAF and they won;
+ // `node` should now be an indirection.
+ ENTER(node);
+ } else {
+ jump stg_do_unpack_cstring(node, newCAF_ret);
+ }
+}
+
+stg_do_unpack_cstring_utf8(P_ node, P_ newCAF_ret) {
+ STK_CHK_PP(WDS(SIZEOF_StgUpdateFrame), stg_do_unpack_cstring_utf8, node, newCAF_ret);
+ W_ str;
+ str = StgThunk_payload(node, 2);
+ push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
+ jump %ENTRY_CODE(ghczmprim_GHCziCString_unpackCStringUtf8zh_info)(node, str);
+ }
+}
+
+INFO_TABLE(stg_unpack_cstring_utf8, 0, 0, THUNK_STATIC, "stg_unpack_cstring_utf8", "stg_unpack_cstring_utf8")
+ (P_ node)
+{
+ W_ newCAF_ret;
+ (newCAF_ret) = ccall newCAF(BaseReg "ptr", node "ptr");
+
+ if (newCAF_ret == 0) {
+ // We raced with another thread to evaluate the CAF and they won;
+ // `node` should now be an indirection.
+ ENTER(node);
+ } else {
+ jump stg_do_unpack_cstring_utf8(node, newCAF_ret);
+ }
+}
+
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -318,6 +318,10 @@ RTS_THUNK(stg_ap_5_upd);
RTS_THUNK(stg_ap_6_upd);
RTS_THUNK(stg_ap_7_upd);
+// Standard entry for `unpackCString# str` thunks
+RTS_ENTRY(stg_unpack_cstring);
+RTS_ENTRY(stg_unpack_cstring_utf8);
+
/* standard application routines (see also utils/genapply,
* and GHC.StgToCmm.ArgRep).
*/
=====================================
testsuite/tests/linters/notes.stdout
=====================================
@@ -2,7 +2,6 @@ ref compiler/GHC/Core/Coercion/Axiom.hs:461:2: Note [RoughMap and rm_empt
ref compiler/GHC/Core/Opt/OccurAnal.hs:857:15: Note [Loop breaking]
ref compiler/GHC/Core/Opt/SetLevels.hs:1580:30: Note [Top level scope]
ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2675:13: Note [Case binder next]
-ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:3303:0: Note [Suppressing binder-swaps on linear case]
ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:3854:8: Note [Lambda-bound unfoldings]
ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1257:37: Note [Gentle mode]
ref compiler/GHC/Core/Opt/Specialise.hs:1623:28: Note [Arity decrease]
=====================================
testsuite/tests/numeric/should_compile/T19641.stderr
=====================================
@@ -3,30 +3,30 @@
Result size of Tidy Core
= {terms: 22, types: 20, coercions: 0, joins: 0/0}
-integer_to_int
+natural_to_word
= \ eta ->
case eta of {
- IS ipv -> Just (I# ipv);
- IP x1 -> Nothing;
- IN ds -> Nothing
+ NS x1 -> Just (W# x1);
+ NB ds -> Nothing
}
-natural_to_word
+integer_to_int
= \ eta ->
case eta of {
- NS x1 -> Just (W# x1);
- NB ds -> Nothing
+ IS ipv -> Just (I# ipv);
+ IP x1 -> Nothing;
+ IN ds -> Nothing
}
------ Local rules for imported ids --------
-"SPEC/Test toIntegralSized @Natural @Word"
- forall $dIntegral $dIntegral1 $dBits $dBits1.
- toIntegralSized $dIntegral $dIntegral1 $dBits $dBits1
- = natural_to_word
"SPEC/Test toIntegralSized @Integer @Int"
forall $dIntegral $dIntegral1 $dBits $dBits1.
toIntegralSized $dIntegral $dIntegral1 $dBits $dBits1
= integer_to_int
+"SPEC/Test toIntegralSized @Natural @Word"
+ forall $dIntegral $dIntegral1 $dBits $dBits1.
+ toIntegralSized $dIntegral $dIntegral1 $dBits $dBits1
+ = natural_to_word
=====================================
testsuite/tests/simplCore/should_compile/T8331.stderr
=====================================
@@ -1,5 +1,149 @@
==================== Tidy Core rules ====================
+"SPEC $c*> @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT_$c*> @(ST s) @r $dApplicative
+ = ($fApplicativeReaderT2 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <ReaderT r (ST s) a>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) b>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <b>_N)
+ :: Coercible
+ (forall {a} {b}.
+ ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s b)
+ (forall {a} {b}.
+ ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b))
+"SPEC $c<$ @(ST s) @_"
+ forall (@s) (@r) ($dFunctor :: Functor (ST s)).
+ $fFunctorReaderT_$c<$ @(ST s) @r $dFunctor
+ = ($fApplicativeReaderT6 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <a>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) b>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
+ :: Coercible
+ (forall {a} {b}. a -> ReaderT r (ST s) b -> r -> STRep s a)
+ (forall {a} {b}. a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
+"SPEC $c<* @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT_$c<* @(ST s) @r $dApplicative
+ = ($fApplicativeReaderT1 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <ReaderT r (ST s) a>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) b>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
+ :: Coercible
+ (forall {a} {b}.
+ ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s a)
+ (forall {a} {b}.
+ ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
+"SPEC $c<*> @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT9 @(ST s) @r $dApplicative
+ = ($fApplicativeReaderT4 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <ReaderT r (ST s) (a -> b)>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) a>_R
+ %<'Many>_N ->_R <r>_R
+ %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
+ :: Coercible
+ (forall {a} {b}.
+ ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
+ (forall {a} {b}.
+ ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b))
+"SPEC $c>> @(ST s) @_"
+ forall (@s) (@r) ($dMonad :: Monad (ST s)).
+ $fMonadReaderT1 @(ST s) @r $dMonad
+ = $fMonadAbstractIOSTReaderT_$s$c>> @s @r
+"SPEC $c>>= @(ST s) @_"
+ forall (@s) (@r) ($dMonad :: Monad (ST s)).
+ $fMonadReaderT2 @(ST s) @r $dMonad
+ = ($fMonadAbstractIOSTReaderT2 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <ReaderT r (ST s) a>_R
+ %<'Many>_N ->_R <a -> ReaderT r (ST s) b>_R
+ %<'Many>_N ->_R <r>_R
+ %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
+ :: Coercible
+ (forall {a} {b}.
+ ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> STRep s b)
+ (forall {a} {b}.
+ ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> ST s b))
+"SPEC $cfmap @(ST s) @_"
+ forall (@s) (@r) ($dFunctor :: Functor (ST s)).
+ $fFunctorReaderT_$cfmap @(ST s) @r $dFunctor
+ = ($fApplicativeReaderT7 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <a -> b>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) a>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <b>_N)
+ :: Coercible
+ (forall {a} {b}. (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
+ (forall {a} {b}.
+ (a -> b) -> ReaderT r (ST s) a -> ReaderT r (ST s) b))
+"SPEC $cliftA2 @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative
+ = ($fApplicativeReaderT3 @s @r)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N) (c :: <*>_N).
+ <a -> b -> c>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) a>_R
+ %<'Many>_N ->_R <ReaderT r (ST s) b>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <c>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <c>_N)
+ :: Coercible
+ (forall {a} {b} {c}.
+ (a -> b -> c)
+ -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s c)
+ (forall {a} {b} {c}.
+ (a -> b -> c)
+ -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) c))
+"SPEC $cp1Applicative @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT_$cp1Applicative @(ST s) @r $dApplicative
+ = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
+"SPEC $cp1Monad @(ST s) @_"
+ forall (@s) (@r) ($dMonad :: Monad (ST s)).
+ $fMonadReaderT_$cp1Monad @(ST s) @r $dMonad
+ = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
+"SPEC $cpure @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT_$cpure @(ST s) @r $dApplicative
+ = ($fApplicativeReaderT5 @s @r)
+ `cast` (forall (a :: <*>_N).
+ <a>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
+ :: Coercible
+ (forall {a}. a -> r -> STRep s a)
+ (forall {a}. a -> ReaderT r (ST s) a))
+"SPEC $creturn @(ST s) @_"
+ forall (@s) (@r) ($dMonad :: Monad (ST s)).
+ $fMonadReaderT_$creturn @(ST s) @r $dMonad
+ = ($fApplicativeReaderT5 @s @r)
+ `cast` (forall (a :: <*>_N).
+ <a>_R
+ %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
+ ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
+ :: Coercible
+ (forall {a}. a -> r -> STRep s a)
+ (forall {a}. a -> ReaderT r (ST s) a))
+"SPEC $fApplicativeReaderT @(ST s) @_"
+ forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
+ $fApplicativeReaderT @(ST s) @r $dApplicative
+ = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
+"SPEC $fFunctorReaderT @(ST s) @_"
+ forall (@s) (@r) ($dFunctor :: Functor (ST s)).
+ $fFunctorReaderT @(ST s) @r $dFunctor
+ = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
+"SPEC $fMonadReaderT @(ST s) @_"
+ forall (@s) (@r) ($dMonad :: Monad (ST s)).
+ $fMonadReaderT @(ST s) @r $dMonad
+ = $fMonadAbstractIOSTReaderT_$s$fMonadReaderT @s @r
"USPEC useAbstractMonad @(ReaderT Int (ST s))"
forall (@s)
($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))).
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -359,7 +359,6 @@ test('T19586', normal, compile, [''])
test('T19599', normal, compile, ['-O -ddump-rules'])
test('T19599a', normal, compile, ['-O -ddump-rules'])
-test('T13873', [expect_broken(21229), grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
# Look for a specialisation rule for wimwam
test('T19672', normal, compile, ['-O2 -ddump-rules'])
@@ -435,3 +434,6 @@ test('T21148', [grep_errmsg(r'Cpr=') ], compile, ['-O -ddump-simpl'])
test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques'])
# One module, T22097.hs, has OPTIONS_GHC -ddump-simpl
test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
+
+test('T13873', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5040cd8e76c9cbdbd0e87aac15087d36fc2afc3a...e09780bd70bd0c99283507ed3000d6c416c290ff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5040cd8e76c9cbdbd0e87aac15087d36fc2afc3a...e09780bd70bd0c99283507ed3000d6c416c290ff
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221021/c56ce6e1/attachment-0001.html>
More information about the ghc-commits
mailing list