[Git][ghc/ghc][master] Avoid desugaring non-recursive lets into recursive lets
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Jun 20 07:20:02 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3e80c2b4 by Arnaud Spiwack at 2023-06-20T03:19:41-04:00
Avoid desugaring non-recursive lets into recursive lets
This prepares for having linear let expressions in the frontend.
When desugaring lets, SPECIALISE statements create more copies of a
let binding. Because of the rewrite rules attached to the bindings,
there are dependencies between the generated binds.
Before this commit, we simply wrapped all these in a mutually
recursive let block, and left it to the simplified to sort it out.
With this commit: we are careful to generate the bindings in
dependency order, so that we can wrap them in consecutive lets (if the
source is non-recursive).
- - - - -
3 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- testsuite/tests/ghci/should_run/T16096.stdout
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -117,10 +117,56 @@ dsTopLHsBinds binds
top_level_err bindsType (L loc bind)
= putSrcSpanDs (locA loc) $
diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
+{-
+Note [Return bindings in dependency order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The desugarer tries to desugar a non-recursive let-binding to a collection of
+one or more non-recursive let-bindings. The alternative is to generate a letrec
+and wait for the occurrence analyser to sort it out later, but it is pretty easy
+to arrange that the [(Id,CoreExpr)] pairs returned by dsLHsBinds are returned in
+dependency order
+
+It's most important for linear types, where 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].
+
+This only matters when the source binding is non-recursive as recursive bindings
+are always desugared to a single mutually recursive block.
+
+-}
-- | 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 bindings in dependency order]
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { ds_bs <- mapBagM dsLHsBind binds
@@ -134,6 +180,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 bindings in dependency order]
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
@@ -263,7 +312,7 @@ 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
@@ -322,7 +371,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)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -160,17 +160,20 @@ 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 bindings in dependency order]
+
+-- | 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/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/-/commit/3e80c2b40213bebe302b1bd239af48b33f1b30ef
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e80c2b40213bebe302b1bd239af48b33f1b30ef
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/20230620/47516922/attachment-0001.html>
More information about the ghc-commits
mailing list