[Git][ghc/ghc][master] 2 commits: Add test for #23550
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Aug 2 10:05:01 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
93a0d089 by Arnaud Spiwack at 2023-08-02T06:04:37-04:00
Add test for #23550
- - - - -
6a2f4a20 by Arnaud Spiwack at 2023-08-02T06:04:37-04:00
Desugar non-recursive lets to non-recursive lets (take 2)
This reverts commit 522bd584f71ddeda21efdf0917606ce3d81ec6cc. And
takes care of the case that I missed in my previous attempt. Namely
the case of an AbsBinds with no type variables and no dictionary
variable.
Ironically, the comment explaining why non-recursive lets were
desugared to recursive lets were pointing specifically at this case
as the reason. I just failed to understand that it was until Simon PJ
pointed it out to me.
See #23550 for more discussion.
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- + testsuite/tests/deSugar/should_compile/T23550.hs
- testsuite/tests/deSugar/should_compile/all.T
- testsuite/tests/ghci/should_run/T16096.stdout
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -117,10 +117,54 @@ dsTopLHsBinds binds
top_level_err bindsType (L loc bind)
= putSrcSpanDs (locA loc) $
diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
+{-
+Note [Return non-recursive bindings in dependency order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For recursive bindings, the desugarer has no choice: it returns a single big
+Rec{...} group.
+
+But for /non-recursive/ bindings, the desugarer guarantees to desugar them to
+a sequence of non-recurive Core bindings, in dependency order.
+
+Why is this important? Partly it saves a bit of work in the first run of the
+ocurrence analyser. But more importantly, for linear types, non-recursive lets
+can be linear whereas recursive-let can't. Since we check the output of the
+desugarer for linearity (see also Note [Linting linearity]), desugaring
+non-recursive lets to recursive lets would break linearity checks. An
+alternative is to refine the typing rule for recursive lets so that we don't
+have to care (see in particular #23218 and #18694), but the outcome of this line
+of work is still unclear. In the meantime, being a little precise in the
+desugarer is cheap. (paragraph written on 2023-06-09)
+
+In dsLHSBinds (and dependencies), a single binding can be desugared to multiple
+bindings. For instance because the source binding has the {-# SPECIALIZE #-}
+pragma. In:
+
+f _ = …
+ where
+ {-# SPECIALIZE g :: F Int -> F Int #-}
+ g :: C a => F a -> F a
+ g _ = …
+
+The g binding desugars to
+
+let {
+ $sg = … } in
+
+ g
+ [RULES: "SPEC g" g @Int $dC = $sg]
+ g = …
+In order to avoid generating a letrec that will immediately be reordered, we
+make sure to return the binding in dependency order [$sg, g].
+
+-}
-- | Desugar all other kind of bindings, Ids of strict binds are returned to
-- later be forced in the binding group body, see Note [Desugar Strict binds]
+--
+-- Invariant: the desugared bindings are returned in dependency order,
+-- see Note [Return non-recursive bindings in dependency order]
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { ds_bs <- mapBagM dsLHsBind binds
@@ -134,6 +178,9 @@ dsLHsBind (L loc bind) = do dflags <- getDynFlags
putSrcSpanDs (locA loc) $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
+--
+-- Invariant: the desugared bindings are returned in dependency order,
+-- see Note [Return non-recursive bindings in dependency order]
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
@@ -214,7 +261,7 @@ dsHsBind
; dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do
-- dsAbsBinds does the hard work
- { dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } }
+ { dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds (isSingletonBag binds) has_sig } }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
@@ -223,11 +270,12 @@ dsAbsBinds :: DynFlags
-> [TyVar] -> [EvVar] -> [ABExport]
-> [CoreBind] -- Desugared evidence bindings
-> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings
+ -> Bool -- Single source binding
-> Bool -- Single binding with signature
-> DsM ([Id], [(Id,CoreExpr)])
dsAbsBinds dflags tyvars dicts exports
- ds_ev_binds (force_vars, bind_prs) has_sig
+ ds_ev_binds (force_vars, bind_prs) is_singleton has_sig
-- A very important common case: one exported variable
-- Non-recursive bindings come through this way
@@ -263,14 +311,20 @@ dsAbsBinds dflags tyvars dicts exports
(isDefaultMethod prags)
(dictArity dicts) rhs
- ; return (force_vars', main_bind : fromOL spec_binds) } }
+ ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
-- lcl_id{inl-prag} = rhs -- Auxiliary binds
-- gbl_id = lcl_id |> co -- Main binds
+ --
+ -- See Note [The no-tyvar no-dict case]
| null tyvars, null dicts
- = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)
+ = do { let wrap_first_bind f ((main, main_rhs):other_binds) =
+ ((main, f main_rhs):other_binds)
+ wrap_first_bind _ [] = panic "dsAbsBinds received an empty binding list"
+
+ mk_main :: ABExport -> DsM (Id, CoreExpr)
mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
, abe_wrap = wrap })
-- No SpecPrags (no dicts)
@@ -278,15 +332,19 @@ dsAbsBinds dflags tyvars dicts exports
= do { dsHsWrapper wrap $ \core_wrap -> do
{ return ( gbl_id `setInlinePragma` defaultInlinePragma
, core_wrap (Var lcl_id)) } }
-
; main_prs <- mapM mk_main exports
- ; return (force_vars, flattenBinds ds_ev_binds
- ++ mk_aux_binds bind_prs ++ main_prs ) }
+ ; let bind_prs' = map mk_aux_bind bind_prs
+ -- When there's a single source binding, we wrap the evidence binding in a
+ -- separate let-rec (DSB1) inside the first desugared binding (DSB2).
+ -- See Note [The no-tyvar no-dict case].
+ final_prs | is_singleton = wrap_first_bind (mkCoreLets ds_ev_binds) bind_prs'
+ | otherwise = flattenBinds ds_ev_binds ++ bind_prs'
+ ; return (force_vars, final_prs ++ main_prs ) }
-- The general case
-- See Note [Desugaring AbsBinds]
| otherwise
- = do { let aux_binds = Rec (mk_aux_binds bind_prs)
+ = do { let aux_binds = Rec (map mk_aux_bind bind_prs)
-- Monomorphic recursion possible, hence Rec
new_force_vars = get_new_force_vars force_vars
@@ -322,7 +380,7 @@ dsAbsBinds dflags tyvars dicts exports
-- Kill the INLINE pragma because it applies to
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
- ; return ((global', rhs) : fromOL spec_binds) } }
+ ; return (fromOL spec_binds ++ [(global', rhs)]) } }
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
@@ -330,11 +388,11 @@ dsAbsBinds dflags tyvars dicts exports
, (poly_tup_id, poly_tup_rhs) :
concat export_binds_s) }
where
- mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
- mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs
- | (lcl_id, rhs) <- bind_prs
- , let lcl_w_inline = lookupVarEnv inline_env lcl_id
- `orElse` lcl_id ]
+ mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr)
+ mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id
+ `orElse` lcl_id
+ in
+ makeCorePair dflags lcl_w_inline False 0 rhs
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-- the inline pragma from the source
@@ -473,48 +531,71 @@ So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
The top-level AbsBinds for $cround has no tyvars or dicts (because the
instance does not). But the method is locally overloaded!
-Note [Abstracting over tyvars only]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When abstracting over type variable only (not dictionaries), we don't really need to
-built a tuple and select from it, as we do in the general case. Instead we can take
+Note [The no-tyvar no-dict case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are desugaring
+ AbsBinds { tyvars = []
+ , dicts = []
+ , exports = [ ABE f fm, ABE g gm ]
+ , binds = B
+ , ev_binds = EB }
+That is: no type variables or dictionary abstractions. Here, `f` and `fm` are
+the polymorphic and monomorphic versions of `f`; in this special case they will
+both have the same type.
+
+Specialising Note [Desugaring AbsBinds] for this case gives the desugaring
+
+ tup = letrec EB' in letrec B' in (fm,gm)
+ f = case tup of { (fm,gm) -> fm }
+ g = case tup of { (fm,gm) -> fm }
+
+where B' is the result of desugaring B. This desugaring is a little silly: we
+don't need the intermediate tuple (contrast with the general case where fm and f
+have different types). So instead, in this case, we desugar to
- AbsBinds [a,b] [ ([a,b], fg, fl, _),
- ([b], gg, gl, _) ]
- { fl = e1
- gl = e2
- h = e3 }
+ EB'; B'; f=fm; g=gm
-and desugar it to
+This is done in the `null tyvars, null dicts` case of `dsAbsBinds`.
- fg = /\ab. let B in e1
- gg = /\b. let a = () in let B in S(e2)
- h = /\ab. let B in e3
+But there is a wrinkle (DSB1). If the original binding group was
+/non-recursive/, we want to return a bunch of non-recursive bindings in
+dependency order: see Note [Return non-recursive bindings in dependency order].
-where B is the *non-recursive* binding
- fl = fg a b
- gl = gg b
- h = h a b -- See (b); note shadowing!
+But there is no guarantee that EB', the desugared evidence bindings, will be
+non-recursive. Happily, in the non-recursive case, B will have just a single
+binding (f = rhs), so we can wrap EB' around its RHS, thus:
-Notice (a) g has a different number of type variables to f, so we must
- use the mkArbitraryType thing to fill in the gaps.
- We use a type-let to do that.
+ fm = letrec EB' in rhs; f = fm
- (b) The local variable h isn't in the exports, and rather than
- clone a fresh copy we simply replace h by (h a b), where
- the two h's have different types! Shadowing happens here,
- which looks confusing but works fine.
+There is a sub-wrinkle (DSB2). If B is a /pattern/ bindings, it will desugar to
+a "main" binding followed by a bunch of selectors. The main binding always
+comes first, so we can pick it out and wrap EB' around its RHS. For example
- (c) The result is *still* quadratic-sized if there are a lot of
- small bindings. So if there are more than some small
- number (10), we filter the binding set B by the free
- variables of the particular RHS. Tiresome.
+ AbsBinds { tyvars = []
+ , dicts = []
+ , exports = [ ABE p pm, ABE q qm ]
+ , binds = PatBind (pm, Just qm) rhs
+ , ev_binds = EB }
+
+can desguar to
+
+ pt = let EB' in
+ case rhs of
+ (pm,Just qm) -> (pm,qm)
+ pm = case pt of (pm,qm) -> pm
+ qm = case pt of (pm,qm) -> qm
+
+ p = pm
+ q = qm
+
+The first three bindings come from desugaring the PatBind, and subsequently
+wrapping the RHS of the main binding in EB'.
Why got to this trouble? It's a common case, and it removes the
quadratic-sized tuple desugaring. Less clutter, hopefully faster
compilation, especially in a case where there are a *lot* of
bindings.
-
Note [Eta-expanding INLINE things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -163,17 +163,22 @@ ds_val_bind (is_rec, binds) body
-- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
case prs of
[] -> return body
- _ -> return (Let (Rec prs) body') }
- -- Use a Rec regardless of is_rec.
- -- Why? Because it allows the binds to be all
- -- mixed up, which is what happens in one rare case
- -- Namely, for an AbsBind with no tyvars and no dicts,
- -- but which does have dictionary bindings.
- -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
- -- It turned out that wrapping a Rec here was the easiest solution
- --
- -- NB The previous case dealt with unlifted bindings, so we
- -- only have to deal with lifted ones now; so Rec is ok
+ _ -> return (mkLets (mk_binds is_rec prs) body') }
+ -- We can make a non-recursive let because we make sure to return
+ -- the bindings in dependency order in dsLHsBinds,
+ -- see Note [Return non-recursive bindings in dependency order] in
+ -- GHC.HsToCore.Binds
+
+-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for
+-- instance.
+--
+-- * @'mk_binds' 'Recursive' binds@ makes a single mutually-recursive
+-- bindings with all the rhs/lhs pairs in @binds@
+-- * @'mk_binds' 'NonRecursive' binds@ makes one non-recursive binding
+-- for each rhs/lhs pairs in @binds@
+mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
+mk_binds Recursive binds = [Rec binds]
+mk_binds NonRecursive binds = map (uncurry NonRec) binds
------------------
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
=====================================
testsuite/tests/deSugar/should_compile/T23550.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- We didn't need -XMonoLocalBinds to trigger #T23550. But it is sufficient. And
+-- since it is the simpler case, to avoid confusing the issue, the test uses
+-- -XMonoLocalBinds.
+{-# LANGUAGE MonoLocalBinds #-}
+
+module T23550 where
+
+emptyGraph :: Int -> ()
+emptyGraph stms = undefined
+ where
+ -- The wildcard is important: it's a PatBind, and it's the case we're
+ -- testing. For some reason it also seems that binding no variable matters.
+ -- Otherwise the (mutually recursive) dictionaries are bound at toplevel
+ -- instead of locally.
+ _ = analyseStms stms
+
+
+class Aliased rep where
+instance AliasedOp (SOAC Aliases) => Aliased Aliases where
+
+class AliasedOp op where
+instance Aliased rep => AliasedOp (SOAC rep) where
+
+analyseStms :: AliasedOp (SOAC Aliases) => Int -> ()
+analyseStms = undefined
+
+data Aliases
+data SOAC rep
=====================================
testsuite/tests/deSugar/should_compile/all.T
=====================================
@@ -113,3 +113,4 @@ test('T18112', [grep_errmsg('cast')], compile, ['-ddump-ds'])
test('T19969', [grep_errmsg('LoopBreaker')], compile, ['-ddump-simpl -dsuppress-uniques']) # f should become loopbreaker
test('T19883', normal, compile, [''])
test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
+test('T23550', normal, compile, [''])
=====================================
testsuite/tests/ghci/should_run/T16096.stdout
=====================================
@@ -1,6 +1,6 @@
==================== Desugared ====================
-letrec {
+let {
x :: [GHC.Types.Int]
[LclId]
x = let {
@@ -11,7 +11,7 @@ letrec {
x :: [GHC.Types.Int]
[LclId]
x = GHC.Enum.enumFrom @GHC.Types.Int $dEnum (GHC.Types.I# 1#); } in
- x; } in
+ x } in
GHC.Base.returnIO
@[GHC.Types.Any]
(GHC.Types.:
@@ -27,7 +27,7 @@ GHC.Base.returnIO
==================== Desugared ====================
-letrec {
+let {
x :: [GHC.Types.Int]
[LclId]
x = let {
@@ -38,7 +38,7 @@ letrec {
x :: [GHC.Types.Int]
[LclId]
x = GHC.Enum.enumFrom @GHC.Types.Int $dEnum (GHC.Types.I# 1#); } in
- x; } in
+ x } in
GHC.Base.returnIO
@[GHC.Types.Any]
(GHC.Types.:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/453c0531f2edf49b75c73bc45944600d8d7bf767...6a2f4a204e8bb65c6711fefbafe6fcd5cd7c4c36
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/453c0531f2edf49b75c73bc45944600d8d7bf767...6a2f4a204e8bb65c6711fefbafe6fcd5cd7c4c36
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/20230802/4e4c323a/attachment-0001.html>
More information about the ghc-commits
mailing list