[Git][ghc/ghc][wip/torsten.schmits/23272] Filter out nontrivial substituted expressions in substTickish

[Torsten Schmits (@torsten.schmits)]

Torsten Schmits pushed to branch wip/torsten.schmits/23272 at Glasgow Haskell Compiler / GHC


Commits:
e3e5c6c7 by Torsten Schmits at 2023-06-02T14:47:15+02:00
Filter out nontrivial substituted expressions in substTickish

Fixes #23272

- - - - -


6 changed files:

- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Subst.hs
- testsuite/tests/ghci/scripts/T8042recomp.script
- + testsuite/tests/simplCore/should_compile/T23272.hs
- + testsuite/tests/simplCore/should_compile/T23272.script
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -64,7 +64,7 @@ import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
 import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
 import GHC.Builtin.Names( runRWKey )
 
-import GHC.Data.Maybe   ( isNothing, orElse )
+import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )
 import GHC.Data.FastString
 import GHC.Unit.Module ( moduleName )
 import GHC.Utils.Outputable
@@ -1436,7 +1436,7 @@ simplTick env tickish expr cont
 
   simplTickish env tickish
     | Breakpoint ext n ids <- tickish
-          = Breakpoint ext n (map (getDoneId . substId env) ids)
+          = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids)
     | otherwise = tickish
 
   -- Push type application and coercion inside a tick
@@ -1447,8 +1447,9 @@ simplTick env tickish expr cont
     where (inc,outc) = splitCont c
   splitCont other = (mkBoringStop (contHoleType other), other)
 
-  getDoneId (DoneId id)  = id
-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst
+  getDoneId (DoneId id)  = Just id
+  getDoneId (DoneEx (Var id) _) = Just id
+  getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst
   getDoneId other = pprPanic "getDoneId" (ppr other)
 
 -- Note [case-of-scc-of-case]


=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -592,9 +592,10 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs
 ------------------
 substTickish :: Subst -> CoreTickish -> CoreTickish
 substTickish subst (Breakpoint ext n ids)
-   = Breakpoint ext n (map do_one ids)
+   -- = Breakpoint ext n [i | Var i <- lookupIdSubst subst <$> ids]
+   = Breakpoint ext n (mapMaybe do_one ids)
  where
-    do_one = getIdFromTrivialExpr . lookupIdSubst subst
+    do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst
 substTickish _subst other = other
 
 {- Note [Substitute lazily]


=====================================
testsuite/tests/ghci/scripts/T8042recomp.script
=====================================
@@ -1,7 +1,7 @@
 :set -v1
 System.IO.writeFile "T8042B.hs" "module T8042B where { fooB = \"T8042B\"; }"
 System.IO.writeFile "T8042A.hs" "module T8042A where { import T8042B; run = putStrLn fooB }"
-:set -fobject-code
+:set -fobject-code -fbreak-points
 :load T8042A
 :load *T8042A
 :break run


=====================================
testsuite/tests/simplCore/should_compile/T23272.hs
=====================================
@@ -0,0 +1,9 @@
+module T23272 where
+
+class C a where
+instance C () where
+
+bug :: (forall a. C a => a -> a) -> ()
+bug g = f ()
+  where
+    f x = seq (g x) undefined


=====================================
testsuite/tests/simplCore/should_compile/T23272.script
=====================================
@@ -0,0 +1 @@
+:load T23272


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -484,3 +484,5 @@ test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppres
 test('T23307b', normal, compile, ['-O'])
 test('T23307c', normal, compile, ['-O'])
 test('T23426', normal, compile, ['-O'])
+test('T23272', [only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['T23272.script'])
+# test('T23272', normal, compile, ['-O -fbreak-points'])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3e5c6c79860f80859876625d5ec25c46b784601
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/20230602/6d795412/attachment-0001.html>