[Git][ghc/ghc][wip/T24551] Simplifier: Re-do dependency analysis in abstractFloats (#24551)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Thu Mar 21 14:19:46 UTC 2024
Sebastian Graf pushed to branch wip/T24551 at Glasgow Haskell Compiler / GHC
Commits:
5950745d by Sebastian Graf at 2024-03-21T15:19:33+01:00
Simplifier: Re-do dependency analysis in abstractFloats (#24551)
In #24551, we abstracted a string literal binding over a type variable,
triggering a CoreLint error when that binding floated to top-level.
The solution implemented in this patch fixes this by re-doing dependency
analysis on a simplified recursive let binding that is about to be type
abstracted, in order to find the minimal set of type variables to abstract over.
See wrinkle (AB5) of Note [Floating and type abstraction] for more details.
Fixes #24551
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- + testsuite/tests/simplCore/should_compile/T24551.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -85,6 +85,8 @@ import GHC.Utils.Panic
import Control.Monad ( when )
import Data.List ( sortBy )
+import GHC.Types.Name.Env
+import Data.Graph
{- *********************************************************************
* *
@@ -2108,6 +2110,27 @@ new binding is abstracted. Several points worth noting
which showed that it's harder to do polymorphic specialisation well
if there are dictionaries abstracted over unnecessary type variables.
See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise
+
+(AB5) We do dependency analysis on recursive groups prior to determining
+ which variables to abstract over.
+ This is useful, because ANFisation in prepareBinding may float out
+ values out of a complex recursive binding, e.g.,
+ letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...
+ ==> { prepareBinding }
+ letrec { foo = "blah"#
+ bar = [42]
+ xs = g @a foo bar xs } in
+ ...
+ and we don't want to abstract foo and bar over @a.
+
+ (Why is it OK to float the unlifted `foo` there?
+ See Note [Core top-level string literals] in GHC.Core;
+ it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)
+
+ It is also necessary to do dependency analysis, because
+ otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the
+ top-level, and that triggers a CoreLint error because `foo` is *not*
+ manifestly a literal string.
-}
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
@@ -2115,15 +2138,27 @@ abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
abstractFloats uf_opts top_lvl main_tvs floats body
= assert (notNull body_floats) $
assert (isNilOL (sfJoinFloats floats)) $
- do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+ do { let sccs = concatMap to_sccs body_floats
+ ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs
; return (float_binds, GHC.Core.Subst.substExpr subst body) }
where
is_top_lvl = isTopLevel top_lvl
body_floats = letFloatBinds (sfLetFloats floats)
empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)
- abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)
- abstract subst (NonRec id rhs)
+ -- See wrinkle (AB5) in Note [Which type variables to abstract over]
+ -- for why we need to re-do dependency analysis
+ to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]
+ to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it
+ to_sccs (Rec prs) = sccs
+ where
+ (ids,rhss) = unzip prs
+ sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])
+ (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
+ (zip3 ids rhss (map exprFreeVars rhss))
+
+ abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
+ abstract subst (AcyclicSCC (id, rhs, _empty_var_set))
= do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
!subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
@@ -2134,7 +2169,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
-- tvs_here: see Note [Which type variables to abstract over]
tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')
- abstract subst (Rec prs)
+ abstract subst (CyclicSCC trpls)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
@@ -2142,15 +2177,15 @@ abstractFloats uf_opts top_lvl main_tvs floats body
, let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
; return (subst', Rec poly_pairs) }
where
- (ids,rhss) = unzip prs
-
+ (ids,rhss,_fvss) = unzip3 trpls
-- tvs_here: see Note [Which type variables to abstract over]
- tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)
+ tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)
-- See wrinkle (AB4) in Note [Which type variables to abstract over]
- get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs
- get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)
+ get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs
+ get_rec_rhs_tvs rhs_fvs = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs
+ -- nonDet is safe because of wrinkle (AB3)
get_tvs :: Var -> VarSet -> VarSet
get_tvs var free_tvs
=====================================
testsuite/tests/simplCore/should_compile/T24551.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+module T24551 (f) where
+
+import GHC.Exts
+
+f :: a -> a
+f = repeatFB g
+
+repeatFB :: (Addr# -> (a -> a) -> a -> a) -> a -> a
+repeatFB c = let xs = c "missing"# xs in xs
+{-# INLINE [0] repeatFB #-}
+
+g :: Addr# -> (a -> a) -> a -> a
+g _ _ x = x
+{-# NOINLINE g #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -514,3 +514,4 @@ test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-
test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
+test('T24551', normal, compile, ['-O -dcore-lint'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5950745d193b5516efba539313fde8e3c36cf99e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5950745d193b5516efba539313fde8e3c36cf99e
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/20240321/a2325047/attachment-0001.html>
More information about the ghc-commits
mailing list