Make tcIfaceCompleteMatch lazier.

Insufficient lazyness causes a loop while typechecking
COMPLETE pragmas from interfaces (#19744).

6 files changed, 40 insertions, 2 deletions

diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 66a143b0b4..bf40b2947c 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1291,13 +1291,24 @@ tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
 tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch
 
 tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch
-tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = do
-  conlikes <- mkUniqDSet <$> mapM (forkM doc . tcIfaceConLike) ms
+tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = forkM doc $ do -- See Note [Positioning of forkM]
+  conlikes <- mkUniqDSet <$> mapM tcIfaceConLike ms
   mtc' <- traverse tcIfaceTyCon mtc
   return (CompleteMatch conlikes mtc')
   where
     doc = text "COMPLETE sig" <+> ppr ms
 
+{- Note [Positioning of forkM]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to be lazy when type checking the interface, since these functions are
+called when the interface itself is being loaded, which means it is not in the
+PIT yet. If we are not lazy enough, in certain cases we might recursively try to
+load the same interface in an infinite loop.
+
+For this reason, the forkM should be around as much of the computation as
+possible.
+-}
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/driver/T19744/Client.hs b/testsuite/tests/driver/T19744/Client.hs
new file mode 100644
index 0000000000..4c291f6221
--- /dev/null
+++ b/testsuite/tests/driver/T19744/Client.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+module Client where
+
+import Mod
+
+f :: T -> T
+f D = D
diff --git a/testsuite/tests/driver/T19744/Makefile b/testsuite/tests/driver/T19744/Makefile
new file mode 100644
index 0000000000..58917564e3
--- /dev/null
+++ b/testsuite/tests/driver/T19744/Makefile
@@ -0,0 +1,8 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T19744:
+	'$(TEST_HC)' Mod.hs
+	'$(TEST_HC)' Client.hs
+	
diff --git a/testsuite/tests/driver/T19744/Mod.hs b/testsuite/tests/driver/T19744/Mod.hs
new file mode 100644
index 0000000000..f40a9c6fb4
--- /dev/null
+++ b/testsuite/tests/driver/T19744/Mod.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Mod where
+
+data T = C
+
+pattern D = C
+
+{-# COMPLETE D :: T #-}
diff --git a/testsuite/tests/driver/T19744/T19744.stdout b/testsuite/tests/driver/T19744/T19744.stdout
new file mode 100644
index 0000000000..80cc624f31
--- /dev/null
+++ b/testsuite/tests/driver/T19744/T19744.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling Mod              ( Mod.hs, Mod.o )
+[2 of 2] Compiling Client           ( Client.hs, Client.o )
diff --git a/testsuite/tests/driver/T19744/all.T b/testsuite/tests/driver/T19744/all.T
new file mode 100644
index 0000000000..ccc410dfc2
--- /dev/null
+++ b/testsuite/tests/driver/T19744/all.T
@@ -0,0 +1,2 @@
+srcs = ['Mod.hs', 'Client.hs']
+test('T19744', [run_timeout_multiplier(0.1),extra_files(srcs)], makefile_test, [])