[Git][ghc/ghc][wip/T23783] Make STG rewriter produce updatable closures

[Jaro Reinders (@Noughtmare)]

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


Commits:
23791936 by Jaro Reinders at 2023-08-10T14:20:53+02:00
Make STG rewriter produce updatable closures

- - - - -


3 changed files:

- compiler/GHC/Stg/InferTags/Rewrite.hs
- + testsuite/tests/simplStg/should_run/T23783.hs
- + testsuite/tests/simplStg/should_run/T23783a.hs


Changes:

=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -368,7 +368,10 @@ rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewrit
             fvs <- fvArgs args
             -- lcls <- getFVs
             -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)
-            return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) typ
+
+            -- We mark the closure updatable to retain sharing in the case that
+            -- conExpr is an infinite recursive data type. See #23783.
+            return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ
 rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do
     withBinders NotTopLevel args $
         withClosureLcls fvs $


=====================================
testsuite/tests/simplStg/should_run/T23783.hs
=====================================
@@ -0,0 +1,18 @@
+module Main where
+import T23783a
+import GHC.Conc
+
+expensive :: Int -> Int
+{-# OPAQUE expensive #-}
+expensive x = x
+
+{-# OPAQUE f #-}
+f xs = let ys = expensive xs
+           h zs = let t = wombat t ys in ys `seq` (zs, t, ys)
+        in h
+
+main :: IO ()
+main = do
+  setAllocationCounter 100000
+  enableAllocationLimit
+  case f 0 () of (_, t, _) -> seqT 16 t `seq` pure ()


=====================================
testsuite/tests/simplStg/should_run/T23783a.hs
=====================================
@@ -0,0 +1,8 @@
+module T23783a where
+import Debug.Trace
+data T a = MkT (T a) (T a) !a !Int
+wombat t x = MkT t t x 2
+
+seqT :: Int -> T a -> ()
+seqT 0 _ = ()
+seqT n (MkT x y _ _) = seqT (n - 1) x `seq` seqT (n - 1) y `seq` ()



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2379193661f72a7f1199d440b488b58530d6542e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2379193661f72a7f1199d440b488b58530d6542e
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/20230810/4d94f3e3/attachment-0001.html>