[Git][ghc/ghc][wip/par-simpl] Updates from Simon
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Dec 20 11:22:50 UTC 2022
Simon Peyton Jones pushed to branch wip/par-simpl at Glasgow Haskell Compiler / GHC
Commits:
52055a57 by Simon Peyton Jones at 2022-12-20T11:22:30+00:00
Updates from Simon
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -1060,30 +1060,29 @@ subst_id_bndr :: SimplEnv
-> SimplM (SimplEnv, OutBndr)
subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
old_id adjust_type
- = do
- -- See Note [Bangs in the Simplifier]
- new_unique <- getUniqueM
- let
- !id1 = setVarUnique old_id new_unique
- -- CHANGE1: Use fresh unique setVarUnique rather than uniqAway
--- !id1 = uniqAway in_scope old_id
- !id2 = substIdType env id1
- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
- -- and fragile OccInfo
- !new_id = adjust_type id3
-
- -- Extend the substitution if the unique has changed,
- -- or there's some useful occurrence information
- -- See the notes with substTyVarBndr for the delSubstEnv
- !new_subst | new_id /= old_id
- = extendVarEnv id_subst old_id (DoneId new_id)
- | otherwise
- = delVarEnv id_subst old_id
-
- !new_in_scope = in_scope `extendInScopeSet` new_id
- assertPpr (not (isCoVar old_id)) (ppr old_id) $
- return (env { seInScope = new_in_scope,
- seIdSubst = new_subst }, new_id)
+ = do { -- See Note [Bangs in the Simplifier]
+
+ -- CHANGE1: Use fresh unique setVarUnique rather than uniqAway
+-- new_unique <- getUniqueM; let !id1 = setVarUnique old_id new_unique
+ let !id1 = uniqAway in_scope old_id
+
+ ; let !id2 = substIdType env id1
+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ -- and fragile OccInfo
+ !new_id = adjust_type id3
+
+ -- Extend the substitution if the unique has changed,
+ -- or there's some useful occurrence information
+ -- See the notes with substTyVarBndr for the delSubstEnv
+ !new_subst | new_id /= old_id
+ = extendVarEnv id_subst old_id (DoneId new_id)
+ | otherwise
+ = delVarEnv id_subst old_id
+
+ !new_in_scope = in_scope `extendInScopeSet` new_id
+ ; assertPpr (not (isCoVar old_id)) (ppr old_id) $
+ return (env { seInScope = new_in_scope
+ , seIdSubst = new_subst }, new_id) }
-- It's important that both seInScope and seIdSubst are updated with
-- the new_id, /after/ applying adjust_type. That's why adjust_type
-- is done here. If we did adjust_type in simplJoinBndr (the only
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -501,17 +501,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
-- V3: Rely on fresh Unique in subst_id_bndr
; let (body_floats2a, body2a) = (body_floats2, body2)
- ; (rhs_floats, body3)
- <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating
- {-#SCC "simplLazyBind-simple-floating" #-}
- return (body_floats2a, body2a)
-
- else -- Non-empty floats, and non-empty tyvars: do type-abstraction first
- {-#SCC "simplLazyBind-type-abstraction-first" #-}
- do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl
- tvs' body_floats2a body2a
- ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds
- ; return (poly_floats, body3) }
+ ; (rhs_floats, body3) <- abstractFloats env top_lvl tvs' body_floats2a body2a
; let env' = env `setInScopeFromF` rhs_floats
; rhs' <- rebuildLam env' tvs' body3 rhs_cont
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1981,10 +1981,10 @@ uniqifyFloats_strict :: UnfoldingOpts -> TopLevelFlag -> SimplFloats
-> OutExpr -> SimplM (SimplFloats, OutExpr)
-- CHANGE 2: Uncomment to
--uniqifyFloats _ _ floats1 body = return (floats1, body)
-uniqifyFloats_strict uf_opts TopLevel floats1 body = do
-
- do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
- ; return (foldl' extendFloats (empty_floats (getSubstInScope subst)) float_binds, GHC.Core.Subst.substExpr subst body) }
+uniqifyFloats_strict uf_opts TopLevel floats1 body
+ = do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+ ; return ( foldl' extendFloats (empty_floats (getSubstInScope subst)) float_binds
+ , GHC.Core.Subst.substExprSC subst body) }
where
empty_floats in_scope = SimplFloats emptyLetFloats (sfJoinFloats floats1) in_scope
body_floats = letFloatBinds (sfLetFloats floats1)
@@ -2236,39 +2236,47 @@ new binding is abstracted. Note that
way) with CSE and/or the compiler-debugging experience
-}
-abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
- -> OutExpr -> SimplM ([OutBind], OutExpr)
-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
- ; return (float_binds, GHC.Core.Subst.substExpr subst body) }
+abstractFloats :: SimplEnv -> TopLevelFlag
+ -> [OutTyVar] -- Abstract over these
+ -> SimplFloats -- sfJoinFloats is empty
+ -> OutExpr -- Body
+ -> SimplM (SimplFloats, OutExpr)
+abstractFloats env top_lvl main_tvs body_floats body
+ | assert (isNilOL (sfJoinFloats body_floats)) $
+ isEmptyFloats body_floats || (null main_tvs && not (isTopLevel top_lvl))
+ = return (body_floats, body)
+ | otherwise
+ = do { (poly_floats, subst) <- foldlM abstract (empty_floats, empty_subst) $
+ letFloatBinds (sfLetFloats body_floats)
+ ; return (poly_floats, 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)
+ uf_opts = seUnfoldingOpts env
+ is_top_lvl = isTopLevel top_lvl
+ empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope body_floats)
+ empty_floats = emptyFloats env
- abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)
- abstract subst (NonRec id rhs)
+ abstract :: (SimplFloats, GHC.Core.Subst.Subst) -> OutBind -> SimplM (SimplFloats, GHC.Core.Subst.Subst)
+ abstract (poly_floats, subst) (NonRec id rhs)
= 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
- ; return (subst', NonRec poly_id2 poly_rhs) }
+ !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
+ !poly_floats' = extendFloats poly_floats (NonRec poly_id2 poly_rhs)
+ ; return (poly_floats', subst') }
where
rhs' = GHC.Core.Subst.substExpr subst rhs
-
-- tvs_here: see Note [Which type variables to abstract over]
tvs_here = filter (`elemVarSet` free_tvs) main_tvs
free_tvs = closeOverKinds $
exprSomeFreeVars isTyVar rhs'
- abstract subst (Rec prs)
+ abstract (poly_floats, subst) (Rec prs)
= 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'
| (poly_id, rhs) <- poly_ids `zip` rhss
, let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
- ; return (subst', Rec poly_pairs) }
+ !poly_floats' = extendFloats poly_floats (Rec poly_pairs)
+ ; return (poly_floats', subst') }
where
(ids,rhss) = unzip prs
-- For a recursive group, it's a bit of a pain to work out the minimal
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52055a575ab67f613d5d9a8d7bee9e9b26de73c1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52055a575ab67f613d5d9a8d7bee9e9b26de73c1
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/20221220/29f32cec/attachment-0001.html>
More information about the ghc-commits
mailing list