Make typechecking unfoldings from interfaces lazier

The old logic was unecessarily strict in loading unfoldings because when
reading the unfolding we would case on the result of attempting to load
the template before commiting to which type of unfolding we were
producing. Hence trying to inspect any of the information about an
unfolding would force the template to be loaded.

This also removes a potentially hard to discover bug where if the
template failed to be typechecked for some reason then we would just not
return an unfolding. Instead we now panic so these bad situations which
should never arise can be identified.

2 files changed, 48 insertions, 44 deletions

diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 2e98f45745..a2f18c0797 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1713,53 +1713,67 @@ tcLFInfo lfi = case lfi of
       return (LFUnknown fun_flag)
 
 tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+-- See Note [Lazily checking Unfoldings]
 tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
   = do  { uf_opts <- unfoldingOpts <$> getDynFlags
-        ; mb_expr <- tcPragExpr False toplvl name if_expr
+        ; expr <- tcUnfoldingRhs False toplvl name if_expr
         ; let unf_src | stable    = InlineStable
                       | otherwise = InlineRhs
-        ; return $ case mb_expr of
-            Nothing -> NoUnfolding
-            Just expr -> mkFinalUnfolding uf_opts unf_src strict_sig expr
-        }
+        ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr }
   where
     -- Strictness should occur before unfolding!
     strict_sig = dmdSigInfo info
 
 tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
-  = do  { mb_expr <- tcPragExpr True toplvl name if_expr
-        ; return (case mb_expr of
-                    Nothing   -> NoUnfolding
-                    Just expr -> mkCompulsoryUnfolding' expr) }
+  = do  { expr <- tcUnfoldingRhs True toplvl name if_expr
+        ; return $ mkCompulsoryUnfolding' expr }
 
 tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
-  = do  { mb_expr <- tcPragExpr False toplvl name if_expr
-        ; return (case mb_expr of
-                    Nothing   -> NoUnfolding
-                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
+  = do  { expr <- tcUnfoldingRhs False toplvl name if_expr
+        ; return $ mkCoreUnfolding InlineStable True expr guidance }
   where
     guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
 
 tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
   = bindIfaceBndrs bs $ \ bs' ->
-    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
-       ; return (case mb_ops1 of
-                    Nothing   -> noUnfolding
-                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
+    do { ops1 <- forkM doc $ mapM tcIfaceExpr ops
+       ; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 }
   where
     doc = text "Class ops for dfun" <+> ppr name
     (_, _, cls, _) = tcSplitDFunTy dfun_ty
 
-{-
-For unfoldings we try to do the job lazily, so that we never type check
+{- Note [Lazily checking Unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For unfoldings, we try to do the job lazily, so that we never typecheck
 an unfolding that isn't going to be looked at.
+
+The main idea is that if M.hi has a declaration
+   f :: Int -> Int
+   f = \x. ...A.g...   -- The unfolding for f
+
+then we don't even want to /read/ A.hi unless f's unfolding is actually used; say,
+if f is inlined. But we need to be careful. Even if we don't inline f, we might ask
+hasNoBinding of it (Core Lint does this in GHC.Core.Lint.checkCanEtaExpand),
+and hasNoBinding looks to see if f has a compulsory unfolding.
+So the root Unfolding constructor must be visible: we want to be able to read the 'uf_src'
+field which says whether it is a compulsory unfolding, without forcing the unfolding RHS
+which is stored in 'uf_tmpl'. This matters for efficiency, but not only: if g's unfolding
+mentions f, we must not look at the unfolding RHS for f, as this is precisely what we are
+in the middle of checking (so looking at it would cause a loop).
+
+Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without
+forcing the `uf_tmpl` field. In particular, all the functions used at the end of
+`tcUnfolding` (such as `mkFinalUnfolding`, `mkCompulsoryUnfolding'`, `mkCoreUnfolding`) must be
+lazy in `expr`.
+
+Ticket #21139
 -}
 
-tcPragExpr :: Bool  -- Is this unfolding compulsory?
-                    -- See Note [Checking for representation polymorphism] in GHC.Core.Lint
-           -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
-tcPragExpr is_compulsory toplvl name expr
-  = forkM_maybe doc $ do
+tcUnfoldingRhs :: Bool -- ^ Is this unfolding compulsory?
+                       -- See Note [Checking for representation polymorphism] in GHC.Core.Lint
+               -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr
+tcUnfoldingRhs is_compulsory toplvl name expr
+  = forkM doc $ do
     core_expr' <- tcIfaceExpr expr
 
     -- Check for type consistency in the unfolding
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index a2720bc4e1..75d6491bad 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -136,7 +136,6 @@ module GHC.Tc.Utils.Monad(
   initIfaceLoadModule,
   getIfModule,
   failIfM,
-  forkM_maybe,
   forkM,
   setImplicitEnvM,
 
@@ -2197,14 +2196,14 @@ failIfM msg = do
 -- | Run thing_inside in an interleaved thread.
 -- It shares everything with the parent thread, so this is DANGEROUS.
 --
--- It returns Nothing if the computation fails
+-- It throws an error if the computation fails
 --
 -- It's used for lazily type-checking interface
 -- signatures, which is pretty benign.
 --
--- See Note [Masking exceptions in forkM_maybe]
-forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
-forkM_maybe doc thing_inside
+-- See Note [Masking exceptions in forkM]
+forkM :: SDoc -> IfL a -> IfL a
+forkM doc thing_inside
  = unsafeInterleaveM $ uninterruptibleMaskM_ $
     do { traceIf (text "Starting fork {" <+> doc)
        ; mb_res <- tryM $
@@ -2212,11 +2211,11 @@ forkM_maybe doc thing_inside
                    thing_inside
        ; case mb_res of
             Right r  -> do  { traceIf (text "} ending fork" <+> doc)
-                            ; return (Just r) }
+                            ; return r }
             Left exn -> do {
                 -- Bleat about errors in the forked thread, if -ddump-if-trace is on
                 -- Otherwise we silently discard errors. Errors can legitimately
-                -- happen when compiling interface signatures (see tcInterfaceSigs)
+                -- happen when compiling interface signatures.
                   whenDOptM Opt_D_dump_if_trace $ do
                       logger <- getLogger
                       let msg = hang (text "forkM failed:" <+> doc)
@@ -2225,33 +2224,24 @@ forkM_maybe doc thing_inside
                                          MCFatal
                                          noSrcSpan
                                          $ withPprStyle defaultErrStyle msg
-
                 ; traceIf (text "} ending fork (badly)" <+> doc)
-                ; return Nothing }
+                ; pgmError "Cannot continue after interface file error" }
     }
 
-forkM :: SDoc -> IfL a -> IfL a
-forkM doc thing_inside
- = do   { mb_res <- forkM_maybe doc thing_inside
-        ; return (case mb_res of
-                        Nothing -> pgmError "Cannot continue after interface file error"
-                                   -- pprPanic "forkM" doc
-                        Just r  -> r) }
-
 setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
 setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
                                      { if_implicits_env = Just tenv }) m
 
 {-
-Note [Masking exceptions in forkM_maybe]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Masking exceptions in forkM]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 When using GHC-as-API it must be possible to interrupt snippets of code
 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
 by throwing an asynchronous interrupt to the GHC thread. However, there is a
 subtle problem: runStmt first typechecks the code before running it, and the
 exception might interrupt the type checker rather than the code. Moreover, the
-typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
+typechecker might be inside an unsafeInterleaveIO (through forkM), and
 more importantly might be inside an exception handler inside that
 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
 asynchronous exception as a synchronous exception, and the exception will end