[Git][ghc/ghc][wip/T17521] Refactor

[Jaro Reinders (@Noughtmare)]

Jaro Reinders pushed to branch wip/T17521 at Glasgow Haskell Compiler / GHC


Commits:
12ff18c4 by Jaro Reinders at 2023-08-08T18:08:27+02:00
Refactor

- - - - -


2 changed files:

- compiler/GHC/Core/Utils.hs
- testsuite/tests/unlifted-datatypes/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -2026,31 +2026,43 @@ exprIsTopLevelBindable expr ty
     -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType',
     -- as the latter would panic.
   || exprIsTickedString expr
-  || isBoxedType ty && exprIsNestedTrivialConApp expr
+  || isBoxedType ty && exprIsDefinitelyWHNF expr
 
 -- | Check if the expression is zero or more Ticks wrapped around a literal
 -- string.
 exprIsTickedString :: CoreExpr -> Bool
 exprIsTickedString = isJust . exprIsTickedString_maybe
 
--- | Check if the expression is a constructor worker application to arguments
--- which are either trivial or themselves constructor worker applications, etc.
-exprIsNestedTrivialConApp :: CoreExpr -> Bool
-exprIsNestedTrivialConApp x
-  | (Var v, xs) <- collectArgs x
-  , Just dc <- isDataConWorkId_maybe v
-  = and (zipWith field_ok (map isMarkedStrict (dataConRepStrictness dc)) xs)
+-- | This function is a very conservative approximation that only deals with
+-- trivial expressions and datacon worker applications. Additionally, this
+-- conservatively rejects data constructors that are applied to lifted variables
+-- in argument positions that are marked strict.
+-- In the future, we hope to loosen this requirement (See #23811).
+exprIsDefinitelyWHNF :: CoreExpr -> Bool
+exprIsDefinitelyWHNF x = is_definitely_whnf False x
   where
-    field_ok strict x
-      | not strict
-      , exprIsTrivial x
-      = True
-      | (Var v, xs) <- collectArgs x
+    -- The first argument of 'is_definitely_whnf' indicates whether the
+    -- expression is forced due to being a strict argument of an enclosing data
+    -- constructor. If that is the case and the expression is a variable, then
+    -- we are only sure it is fully evaluated if the variable has an unlifted
+    -- type.
+    is_definitely_whnf True v at Var{} = definitelyUnliftedType (exprType v)
+    is_definitely_whnf _ x
+      | (Var v, xs) <- collect_args x
       , Just dc <- isDataConWorkId_maybe v
-      = and (zipWith field_ok (map isMarkedStrict (dataConRepStrictness dc)) xs)
-      | otherwise
-      = False
-exprIsNestedTrivialConApp _ = False
+      = and (zipWith is_definitely_whnf (map isMarkedStrict (dataConRepStrictness dc)) xs)
+      | otherwise = exprIsTrivial x
+
+    -- This is slightly different from 'collectArgs' as it looks through ticks and casts
+    -- and it only collects run-time arguments.
+    collect_args expr = go expr []
+      where
+        go (App f a)  as 
+          | isRuntimeArg a = go f (a:as)
+          | otherwise      = go f as
+        go (Tick _ e) as   = go e as
+        go (Cast e _) as   = go e as
+        go e          as   = (e, as)
 
 -- | Extract a literal string from an expression that is zero or more Ticks
 -- wrapped around a literal string. Returns Nothing if the expression has a


=====================================
testsuite/tests/unlifted-datatypes/should_compile/all.T
=====================================
@@ -3,7 +3,7 @@ test('UnlDataPolySigs', normal, compile, [''])
 test('UnlDataFams', normal, compile, [''])
 test('UnlDataUsersGuide', normal, compile, [''])
 test('TopLevel', normal, compile, ['-O -v0'])
-test('TopLevelMixBangs', normal, compile, ['-O -v0'])
+test('TopLevelMixBangs', expect_broken(23811), compile, ['-O -v0'])
 test('TopLevelStgRewrite', normal, multimod_compile, ['TopLevelStgRewrite', '-v0'])
 test('TopLevelStgRewriteBoot', normal, multimod_compile, ['TopLevelStgRewriteBoot', '-O -v0'])
 test('TopLevelSGraf', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12ff18c42769df354454e14040ba049851dd9b5a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12ff18c42769df354454e14040ba049851dd9b5a
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/20230808/fbf0f2fc/attachment-0001.html>