[Git][ghc/ghc][wip/no-let-hnf] Change exprIsHNF

[Jaro Reinders (@Noughtmare)]

Jaro Reinders pushed to branch wip/no-let-hnf at Glasgow Haskell Compiler / GHC


Commits:
3b0b9b50 by Jaro Reinders at 2023-08-02T21:46:20+02:00
Change exprIsHNF

- - - - -


2 changed files:

- compiler/GHC/Core.hs
- compiler/GHC/Core/Utils.hs


Changes:

=====================================
compiler/GHC/Core.hs
=====================================
@@ -43,7 +43,7 @@ module GHC.Core (
         collectBinders, collectTyBinders, collectTyAndValBinders,
         collectNBinders, collectNValBinders_maybe,
         collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
-        collectFunSimple,
+        collectArgsSimple, collectFunSimple,
 
         exprToType,
         wrapLamBody,
@@ -2091,6 +2091,20 @@ collectArgs expr
     go (App f a) as = go f (a:as)
     go e         as = (e, as)
 
+-- | Takes a nested application expression and returns the function
+-- being applied and the arguments to which it is applied. Looking
+-- through casts and ticks to find it.
+collectArgsSimple :: Expr b -> (Expr b, [Arg b])
+collectArgsSimple expr
+  = go expr []
+  where
+    go expr' as =
+      case expr' of
+        App f a    -> go f (a : as)
+        Tick _t e   -> go e as
+        Cast e _co  -> go e as
+        e           -> (e, as)
+
 -- | Takes a nested application expression and returns the function
 -- being applied. Looking through casts and ticks to find it.
 collectFunSimple :: Expr b -> Expr b


=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1972,29 +1972,26 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
                                    && is_hnf_like e
                                       -- See Note [exprIsHNF Tick]
     is_hnf_like (Cast e _)       = is_hnf_like e
-    is_hnf_like (App e a)
-      | isValArg a               = app_is_value e 1
-      | otherwise                = is_hnf_like e
-    is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us
+    is_hnf_like e@(App e' a)
+      | isValArg a
+      = case collectArgsSimple e of
+          (Var f, as) ->
+            id_app_is_value f (length as)
+            && or
+              (zipWith
+                (\strict a -> if strict then is_hnf_like a else not (needsCaseBinding (exprType a) a))
+                (case isDataConId_maybe f of
+                  Just dc -> map isMarkedStrict (dataConRepStrictness dc)
+                  _ -> repeat False)
+                (filter isValArg as))
+            -- For example  f (x /# y)  where f has arity two, and the first
+            -- argument is unboxed. This is not a value!
+            -- But  f 34#  is a value.
+            -- NB: Check id_app_is_value first, the arity check is cheaper
+          _ -> False
+      | otherwise                = is_hnf_like e'
     is_hnf_like _                = False
 
-    -- 'n' is the number of value args to which the expression is applied
-    -- And n>0: there is at least one value argument
-    app_is_value :: CoreExpr -> Int -> Bool
-    app_is_value (Var f)    nva = id_app_is_value f nva
-    app_is_value (Tick _ f) nva = app_is_value f nva
-    app_is_value (Cast f _) nva = app_is_value f nva
-    app_is_value (App f a)  nva
-      | isValArg a              =
-        app_is_value f (nva + 1) &&
-        not (needsCaseBinding (exprType a) a)
-          -- For example  f (x /# y)  where f has arity two, and the first
-          -- argument is unboxed. This is not a value!
-          -- But  f 34#  is a value.
-          -- NB: Check app_is_value first, the arity check is cheaper
-      | otherwise               = app_is_value f nva
-    app_is_value _          _   = False
-
     id_app_is_value id n_val_args
        = is_con id
        || idArity id > n_val_args



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b0b9b50fe8c50207211809be462e9f3892664aa

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b0b9b50fe8c50207211809be462e9f3892664aa
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/20230802/0e0473f9/attachment-0001.html>