[Git][ghc/ghc][wip/T22439] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22439 at Glasgow Haskell Compiler / GHC


Commits:
5c5092ac by Simon Peyton Jones at 2022-11-10T14:17:22+00:00
Wibbles

Fix up SetLevels

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/SetLevels.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -27,7 +27,8 @@ module GHC.Core.Opt.Arity
    , arityTypeArity, idArityType
 
    -- ** Bottoming things
-   , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe
+   , exprIsDeadEnd, arityTypeBotSigs_maybe
+   , exprBotStrictness_maybe, idBotStrictness_maybe
 
    -- ** typeArity and the state hack
    , typeArity, typeOneShots, typeOneShot
@@ -146,13 +147,21 @@ exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e)
 arityTypeBotSigs_maybe :: ArityType ->  Maybe (Arity, DmdSig, CprSig)
 -- Arity of a divergent function
 arityTypeBotSigs_maybe (AT lams div)
-  | isDeadEndDiv div = Just ( arity
-                            , mkVanillaDmdSig arity botDiv
+  | isDeadEndDiv div = Just (arity
+                            , mkVanillaDmdSig arity div
                             , mkCprSig arity botCpr)
   | otherwise        = Nothing
   where
     arity = length lams
 
+idBotStrictness_maybe :: Id ->  Maybe (Arity, DmdSig, CprSig)
+idBotStrictness_maybe id
+  | isDeadEndDiv div = Just (length dmds, dmd_sig, idCprSig id)
+  | otherwise        = Nothing
+  where
+    (dmds, div) = splitDmdSig dmd_sig
+    dmd_sig     = idDmdSig id
+
 
 {- Note [exprArity for applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -73,7 +73,7 @@ import GHC.Core.Utils   ( exprType, exprIsHNF
                         , collectMakeStaticArgs
                         , mkLamTypes, extendInScopeSetBndrs
                         )
-import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr )
+import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, idBotStrictness_maybe, isOneShotBndr )
 import GHC.Core.FVs     -- all of it
 import GHC.Core.Subst
 import GHC.Core.Make    ( sortQuantVars )
@@ -1128,6 +1128,7 @@ lvlBind env (AnnNonRec bndr rhs)
        ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
 
   where
+    deann_rhs  = deAnnotate rhs
     bndr_ty    = idType bndr
     ty_fvs     = tyCoVarsOfType bndr_ty
     rhs_fvs    = freeVarsOf rhs
@@ -1135,11 +1136,12 @@ lvlBind env (AnnNonRec bndr rhs)
     abs_vars   = abstractVars dest_lvl env bind_fvs
     dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam is_join
 
-    deann_rhs  = deAnnotate rhs
-    mb_bot_str = exprBotStrictness_maybe deann_rhs
+    mb_bot_str = idBotStrictness_maybe bndr
     is_bot_lam = isJust mb_bot_str
-        -- is_bot_lam: looks like (\xy. bot), maybe zero lams
-        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
+    -- The Simplifier pins on strictness info, based on a call to arityType
+    -- Using that is faster and more accurate than calling exprBotStrictness_maybe
+    -- is_bot_lam: looks like (\xy. bot), maybe zero lams
+    -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
 
     n_extra    = count isId abs_vars
     mb_join_arity = isJoinId_maybe bndr



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c5092ac4c9f2620b8cd38737040358781c99d54

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c5092ac4c9f2620b8cd38737040358781c99d54
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/20221110/ffc69121/attachment-0001.html>