[Git][ghc/ghc][wip/T21694a] Wibbles

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Wed Aug 24 16:47:35 UTC 2022



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


Commits:
32ea1c9c by Simon Peyton Jones at 2022-08-24T17:48:51+01:00
Wibbles

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -1135,25 +1135,15 @@ andArityType env at1 (AT [] div2) = andWithTail env div2 at1
 
 andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType
 andWithTail env div1 at2@(AT lams2 _)
-  | isDeadEndDiv div1     -- case x of { T -> error; F -> \y.e }
-  = at2        -- Note [ABot branches: max arity wins]
-
-  | pedanticBottoms env  -- Note [Combining case branches: andWithTail]
+  | isDeadEndDiv div1    -- case x of { T -> error; F -> \y.e }
+  = at2                  -- See Note
+  | pedanticBottoms env  --    [Combining case branches: andWithTail]
   = AT [] topDiv
 
   | otherwise  -- case x of { T -> plusInt <expensive>; F -> \y.e }
   = AT (map add_work lams2) topDiv    -- We know div1 = topDiv
     -- See Note [Combining case branches: andWithTail]
 
-{- Note [ABot branches: max arity wins]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   case x of
-             True  -> \x.  error "urk"
-             False -> \xy. error "urk2"
-
-Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge".
-So we need \??.⊥ for the whole thing, the /max/ of both arities.
-
 Note [Combining case branches: optimistic one-shot-ness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When combining the ArityTypes for two case branches (with andArityType)
@@ -1171,6 +1161,21 @@ of the lattice.
 
 Hence the call to `bestOneShot` in `andArityType`.
 
+Here's an example:
+  go = \x. let z = go e0
+               go2 = \x. case x of
+                           True  -> z
+                           False -> \s(one-shot). e1
+           in go2 x
+We *really* want to respect the one-shot annotation provided by the
+user and eta-expand go and go2.
+
+When combining the branches of the case we have
+     T `andAT` \1.T
+and we want to get \1.T.
+But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.
+(We need a usage analysis to justify that.)
+
 Note [Combining case branches: andWithTail]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When combining the ArityTypes for two case branches (with andArityType)
@@ -1178,7 +1183,13 @@ and one side or the other has run out of ATLamInfo; then we get
 into `andWithTail`.
 
 * If one branch is guaranteed bottom (isDeadEndDiv), we just take
-  the other; see Note [ABot branches: max arity wins]
+  the other. Consider   case x of
+             True  -> \x.  error "urk"
+             False -> \xy. error "urk2"
+
+  Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely
+  diverge".  So we need \??.⊥ for the whole thing, the /max/ of both
+  arities.
 
 * Otherwise, if pedantic-bottoms is on, we just have to return
   AT [] topDiv.  E.g. if we have
@@ -1195,20 +1206,6 @@ into `andWithTail`.
   Note [Combining case branches: optimistic one-shot-ness],
   we just add work to ever ATLamInfo, keeping the one-shot-ness.
 
-Here's an example:
-  go = \x. let z = go e0
-               go2 = \x. case x of
-                           True  -> z
-                           False -> \s(one-shot). e1
-           in go2 x
-We *really* want to respect the one-shot annotation provided by the
-user and eta-expand go and go2.
-When combining the branches of the case we have
-     T `andAT` \1.T
-and we want to get \1.T.
-But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.
-(We need a usage analysis to justify that.)
-
 Note [Eta expanding through CallStacks]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Just as it's good to eta-expand through dictionaries, so it is good to
@@ -1243,13 +1240,15 @@ dictionary-typed expression, but that's more work.
 ---------------------------
 
 data ArityEnv
-  = AE { am_opts       :: !ArityOpts
+  = AE { am_opts :: !ArityOpts
+
+       , am_sigs :: !(IdEnv SafeArityType)
+         -- NB `SafeArityType` so we can use this in myIsCheapApp
+         -- See Note [Arity analysis] for details about fixed-point iteration.
+ 
        , am_free_joins :: !Bool  -- True <=> free join points allowed
-       , am_sigs       :: !(IdEnv SafeArityType) }
-  -- ^ See Note [Arity analysis] for details about fixed-point iteration.
-  -- am_sigs:   NB `SafeArityType` so we can use this in myIsCheapApp
-  -- am_free_joins: see Note [Arity for recursive join bindings]
-  --            point 5, in GHC.Core.Opt.Simplify.Utils
+         -- Used /only/ to support assertion checks
+       }
 
 instance Outputable ArityEnv where
   ppr (AE { am_sigs = sigs, am_free_joins = free_joins })
@@ -1452,15 +1451,16 @@ cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType
 -- A fast and cheap version of arityType.
 -- Returns an ArityType with IsCheap everywhere
 -- c.f. GHC.Core.Utils.exprIsDeadEnd
--- Does not expect to encounter a free join-point Id
--- See Note [No free join points in arityType]
+--
+-- /Can/ encounter a free join-point Id; e.g. via the call
+--   in exprBotStrictness_maybe, which is called in lots
+--   of places
 --
 -- Returns ArityType, not SafeArityType.  The caller must do
 -- trimArityType if necessary.
 cheapArityType e = go e
   where
-    go (Var v)                  = assertPpr( not (isJoinId v) ) (ppr v) $
-                                  idArityType v
+    go (Var v)                  = idArityType v
     go (Cast e _)               = go e
     go (Lam x e)  | isId x      = arityLam x (go e)
                   | otherwise   = go e
@@ -1472,12 +1472,15 @@ cheapArityType e = go e
     -- Null alts: see Note [Empty case alternatives] in GHC.Core
     go (Case _ _ _ alts) | null alts = botArityType
 
-    -- Give up on let, case
+    -- Give up on let, case.  In particular, unlike arityType,
+    -- we make no attempt to look inside let's.
     go _ = topArityType
 
     -- Specialised version of arityApp; all costs in ArityType are IsCheap
     -- See Note [exprArity for applications]
-    -- NB: coercions count as a value argument
+    -- NB: (1) coercions count as a value argument
+    --     (2) we use the super-cheap exprIsTrivial rather than the
+    --         more complicated and expensive exprIsCheap
     arity_app _ at@(AT [] _) = at
     arity_app arg at@(AT ((cost,_):lams) div)
        | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $
@@ -1487,7 +1490,10 @@ cheapArityType e = go e
 
 ---------------
 exprArity :: CoreExpr -> Arity
--- ^ An approximate, fast, version of 'exprEtaExpandArity'
+-- ^ An approximate, even faster, version of 'cheapArityType'
+-- Roughly   exprArity e = arityTypeArity (cheapArityType e)
+-- But it's a bit less clever about bottoms
+--
 -- We do /not/ guarantee that exprArity e <= typeArity e
 -- You may need to do arity trimming after calling exprArity
 -- See Note [Arity trimming]
@@ -1507,6 +1513,7 @@ exprArity e = go e
 
     go _                           = 0
 
+---------------
 exprIsDeadEnd :: CoreExpr -> Bool
 -- See Note [Bottoming expressions]
 -- This function is, in effect, just a specialised (and hence cheap)


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1949,7 +1949,8 @@ Obviously `f` should get arity 4.  But it's a bit tricky:
    idArity=4, via the findRhsArity fixpoint.  Then when we are doing findRhsArity
    for `f`, we'll call arityType on f's RHS:
     - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType
-      for `j` (See Note [arityType for let-bindings] in GHC.Core.Opt.Arity)
+      for `j` (See Note [arityType for non-recursive let-bindings]
+      in GHC.Core.Opt.Arity)b
     - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3
       result.
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32ea1c9c1eb66ca2dc4c7a86e7c5bee4fa73250a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32ea1c9c1eb66ca2dc4c7a86e7c5bee4fa73250a
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/20220824/64e0464a/attachment-0001.html>


More information about the ghc-commits mailing list