Move Hooks into HscEnv

17 files changed, 143 insertions, 86 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index fb63b10785..9e247012cf 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -663,7 +663,7 @@ setSessionDynFlags dflags0 = do
             , iservConfOpts     = getOpts dflags opt_i
             , iservConfProfiled = profiled
             , iservConfDynamic  = dynamic
-            , iservConfHook     = createIservProcessHook (hooks dflags)
+            , iservConfHook     = createIservProcessHook (hsc_hooks hsc_env)
             , iservConfTrace    = tr
             }
          s <- liftIO $ newMVar IServPending
diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs
index 1ba59130db..ab40687878 100644
--- a/compiler/GHC/Data/IOEnv.hs
+++ b/compiler/GHC/Data/IOEnv.hs
@@ -36,6 +36,7 @@ module GHC.Data.IOEnv (
 import GHC.Prelude
 
 import GHC.Driver.Session
+import {-# SOURCE #-} GHC.Driver.Hooks
 import GHC.Utils.Exception
 import GHC.Unit.Module
 import GHC.Utils.Panic
@@ -111,6 +112,10 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
     getDynFlags = do env <- getEnv
                      return $! extractDynFlags env
 
+instance ContainsHooks env => HasHooks (IOEnv env) where
+    getHooks = do env <- getEnv
+                  return $! extractHooks env
+
 instance ContainsLogger env => HasLogger (IOEnv env) where
     getLogger = do env <- getEnv
                    return $! extractLogger env
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index cbd63c27cb..e541dfe544 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -4,6 +4,7 @@ module GHC.Driver.Env.Types
   , HscEnv(..)
   ) where
 
+import {-# SOURCE #-} GHC.Driver.Hooks
 import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )
 import GHC.Linker.Types ( Loader )
 import GHC.Prelude
@@ -155,5 +156,8 @@ data HscEnv
 
         , hsc_logger :: !Logger
                 -- ^ Logger
+
+        , hsc_hooks :: !Hooks
+                -- ^ Hooks
  }
 
diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs
index 432297b735..cb21072bd6 100644
--- a/compiler/GHC/Driver/Hooks.hs
+++ b/compiler/GHC/Driver/Hooks.hs
@@ -7,9 +7,9 @@
 
 module GHC.Driver.Hooks
    ( Hooks
+   , HasHooks (..)
+   , ContainsHooks (..)
    , emptyHooks
-   , lookupHook
-   , getHooked
      -- the hooks:
    , DsForeignsHook
    , dsForeignsHook
@@ -68,7 +68,6 @@ import GHCi.RemoteTypes
 import GHC.Data.Stream
 import GHC.Data.Bag
 
-import Data.Maybe
 import qualified Data.Kind
 import System.Process
 
@@ -125,33 +124,33 @@ virtually no difference for plugin authors that want to write a foreign hook.
 type family DsForeignsHook :: Data.Kind.Type
 
 data Hooks = Hooks
-  { dsForeignsHook         :: Maybe DsForeignsHook
+  { dsForeignsHook         :: !(Maybe DsForeignsHook)
   -- ^ Actual type:
   -- @Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))@
-  , tcForeignImportsHook   :: Maybe ([LForeignDecl GhcRn]
-                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
-  , tcForeignExportsHook   :: Maybe ([LForeignDecl GhcRn]
-            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-  , hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)
+  , tcForeignImportsHook   :: !(Maybe ([LForeignDecl GhcRn]
+                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)))
+  , tcForeignExportsHook   :: !(Maybe ([LForeignDecl GhcRn]
+            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))
+  , hscFrontendHook        :: !(Maybe (ModSummary -> Hsc FrontendResult))
   , hscCompileCoreExprHook ::
-               Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
-  , ghcPrimIfaceHook       :: Maybe ModIface
-  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath))
-  , runMetaHook            :: Maybe (MetaHook TcM)
-  , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool
-                                         -> HomePackageTable -> IO SuccessFlag)
-  , runRnSpliceHook        :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
-  , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type
-                                                          -> IO (Maybe HValue))
-  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
-  , stgToCmmHook           :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)
-  , cmmToRawCmmHook        :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
-                                 -> IO (Stream IO RawCmmGroup a))
+               !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))
+  , ghcPrimIfaceHook       :: !(Maybe ModIface)
+  , runPhaseHook           :: !(Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)))
+  , runMetaHook            :: !(Maybe (MetaHook TcM))
+  , linkHook               :: !(Maybe (GhcLink -> DynFlags -> Bool
+                                         -> HomePackageTable -> IO SuccessFlag))
+  , runRnSpliceHook        :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))
+  , getValueSafelyHook     :: !(Maybe (HscEnv -> Name -> Type
+                                                          -> IO (Maybe HValue)))
+  , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
+  , stgToCmmHook           :: !(Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
+                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))
+  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
+                                 -> IO (Stream IO RawCmmGroup a)))
   }
 
-getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a
-getHooked hook def = fmap (lookupHook hook def) getDynFlags
+class HasHooks m where
+    getHooks :: m Hooks
 
-lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a
-lookupHook hook def = fromMaybe def . hook . hooks
+class ContainsHooks a where
+    extractHooks :: a -> Hooks
diff --git a/compiler/GHC/Driver/Hooks.hs-boot b/compiler/GHC/Driver/Hooks.hs-boot
index 48d6cdb1bc..efc6f5a32d 100644
--- a/compiler/GHC/Driver/Hooks.hs-boot
+++ b/compiler/GHC/Driver/Hooks.hs-boot
@@ -5,3 +5,9 @@ import GHC.Prelude ()
 data Hooks
 
 emptyHooks :: Hooks
+
+class HasHooks m where
+    getHooks :: m Hooks
+
+class ContainsHooks a where
+    extractHooks :: a -> Hooks
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index ab877f6f48..6c80c6827c 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -264,6 +264,7 @@ newHscEnv dflags = do
                   ,  hsc_plugins        = []
                   ,  hsc_static_plugins = []
                   ,  hsc_unit_dbs       = Nothing
+                  ,  hsc_hooks          = emptyHooks
                   }
 
 -- -----------------------------------------------------------------------------
@@ -718,10 +719,9 @@ hscIncrementalFrontend
 
         compile mb_old_hash reason = do
             liftIO $ msg reason
-            tc_result <- do
-                let def ms = FrontendTypecheck . fst <$> hsc_typecheck False ms Nothing
-                action <- getHooked hscFrontendHook def
-                action mod_summary
+            tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of
+              Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing
+              Just h  -> h mod_summary
             return $ Right (tc_result, mb_old_hash)
 
         stable = case source_modified of
@@ -1524,6 +1524,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                     cg_hpc_info = hpc_info } = cgguts
             dflags = hsc_dflags hsc_env
             logger = hsc_logger hsc_env
+            hooks  = hsc_hooks hsc_env
             data_tycons = filter isDataTyCon tycons
             -- cg_tycons includes newtypes, for the benefit of External Core,
             -- but we don't generate any code for newtypes
@@ -1563,8 +1564,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do
 
             ------------------  Code output -----------------------
             rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
-                      lookupHook (\a -> cmmToRawCmmHook a)
-                        (\dflg _ -> cmmToRawCmm logger dflg) dflags dflags (Just this_mod) cmms
+                        case cmmToRawCmmHook hooks of
+                            Nothing -> cmmToRawCmm logger dflags cmms
+                            Just h  -> h dflags (Just this_mod) cmms
 
             let dump a = do
                   unless (null a) $
@@ -1617,6 +1619,7 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     let dflags   = hsc_dflags hsc_env
     let logger   = hsc_logger hsc_env
+    let hooks    = hsc_hooks hsc_env
         home_unit = hsc_home_unit hsc_env
         platform  = targetPlatform dflags
     cmm <- ioMsgMaybe
@@ -1643,8 +1646,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
         unless (null cmmgroup) $
           dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm"
             FormatCMM (pdoc platform cmmgroup)
-        rawCmms <- lookupHook (\x -> cmmToRawCmmHook x)
-                     (\dflgs _ -> cmmToRawCmm logger dflgs) dflags dflags Nothing (Stream.yield cmmgroup)
+
+        rawCmms <- case cmmToRawCmmHook hooks of
+          Nothing -> cmmToRawCmm logger dflags         (Stream.yield cmmgroup)
+          Just h  -> h                  dflags Nothing (Stream.yield cmmgroup)
+
         _ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] []
              rawCmms
         return ()
@@ -1686,17 +1692,21 @@ doCodeGen hsc_env this_mod data_tycons
               cost_centre_info stg_binds hpc_info = do
     let dflags = hsc_dflags hsc_env
     let logger = hsc_logger hsc_env
+    let hooks  = hsc_hooks hsc_env
         platform = targetPlatform dflags
 
     let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
 
     dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
 
+    let stg_to_cmm = case stgToCmmHook hooks of
+                        Nothing -> StgToCmm.codeGen logger
+                        Just h  -> h
+
     let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
         -- See Note [Forcing of stg_binds]
         cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
-            lookupHook stgToCmmHook (StgToCmm.codeGen logger) dflags dflags this_mod data_tycons
-                           cost_centre_info stg_binds_w_fvs hpc_info
+            stg_to_cmm dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info
 
         -- codegen consumes a stream of CmmGroup, and produces a new
         -- stream of CmmGroup (not necessarily synchronised: one
@@ -2023,8 +2033,10 @@ hscParseThingWithLocation source linenumber parser str = do
 %********************************************************************* -}
 
 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
-hscCompileCoreExpr hsc_env =
-  lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
+hscCompileCoreExpr hsc_env loc expr =
+  case hscCompileCoreExprHook (hsc_hooks hsc_env) of
+      Nothing -> hscCompileCoreExpr' hsc_env loc expr
+      Just h  -> h                   hsc_env loc expr
 
 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
 hscCompileCoreExpr' hsc_env srcspan ds_expr
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index c36e11914e..f13d13b198 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -617,8 +617,14 @@ load' how_much mHscMessage mod_graph = do
             do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
 
           -- link everything together
-          unit_env <- hsc_unit_env <$> getSession
-          linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env do_linking (hsc_HPT hsc_env1)
+          hsc_env <- getSession
+          linkresult <- liftIO $ link (ghcLink dflags)
+                                      logger
+                                      (hsc_hooks hsc_env)
+                                      dflags
+                                      (hsc_unit_env hsc_env)
+                                      do_linking
+                                      (hsc_HPT hsc_env1)
 
           if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
              then do
@@ -677,8 +683,14 @@ load' how_much mHscMessage mod_graph = do
           ASSERT( just_linkables ) do
 
           -- Link everything together
-          unit_env <- hsc_unit_env <$> getSession
-          linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env False hpt5
+          hsc_env <- getSession
+          linkresult <- liftIO $ link (ghcLink dflags)
+                                      logger
+                                      (hsc_hooks hsc_env)
+                                      dflags
+                                      (hsc_unit_env hsc_env)
+                                      False
+                                      hpt5
 
           modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
           loadFinish Failed linkresult
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index f5cbebee51..df54f35e04 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -484,6 +484,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
 -- libraries.
 link :: GhcLink                 -- ^ interactive or batch
      -> Logger                  -- ^ Logger
+     -> Hooks
      -> DynFlags                -- ^ dynamic flags
      -> UnitEnv                 -- ^ unit environment
      -> Bool                    -- ^ attempt linking in batch mode?
@@ -497,20 +498,20 @@ link :: GhcLink                 -- ^ interactive or batch
 -- exports main, i.e., we have good reason to believe that linking
 -- will succeed.
 
-link ghcLink logger dflags unit_env
-  = lookupHook linkHook l dflags ghcLink dflags
-  where
-    l k dflags batch_attempt_linking hpt = case k of
-        NoLink        -> return Succeeded
-        LinkBinary    -> link' logger dflags unit_env batch_attempt_linking hpt
-        LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt
-        LinkDynLib    -> link' logger dflags unit_env batch_attempt_linking hpt
-        LinkInMemory
-            | platformMisc_ghcWithInterpreter $ platformMisc dflags
-            -> -- Not Linking...(demand linker will do the job)
-               return Succeeded
-            | otherwise
-            -> panicBadLink LinkInMemory
+link ghcLink logger hooks dflags unit_env batch_attempt_linking hpt =
+  case linkHook hooks of
+      Nothing -> case ghcLink of
+          NoLink        -> return Succeeded
+          LinkBinary    -> link' logger dflags unit_env batch_attempt_linking hpt
+          LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt
+          LinkDynLib    -> link' logger dflags unit_env batch_attempt_linking hpt
+          LinkInMemory
+              | platformMisc_ghcWithInterpreter $ platformMisc dflags
+              -> -- Not Linking...(demand linker will do the job)
+                 return Succeeded
+              | otherwise
+              -> panicBadLink LinkInMemory
+      Just h  -> h ghcLink dflags batch_attempt_linking hpt
 
 
 panicBadLink :: GhcLink -> a
@@ -937,8 +938,10 @@ pipeLoop phase input_fn = do
 
 runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)
 runHookedPhase pp input = do
-  dflags <- hsc_dflags <$> getPipeSession
-  lookupHook runPhaseHook runPhase dflags pp input
+  hooks <- hsc_hooks <$> getPipeSession
+  case runPhaseHook hooks of
+    Nothing -> runPhase pp input
+    Just h  -> h pp input
 
 -- -----------------------------------------------------------------------------
 -- In each phase, we need to know into what filename to generate the
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 5e76da3490..7afcf7309c 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -231,7 +231,6 @@ import GHC.Unit.Types
 import GHC.Unit.Parser
 import GHC.Unit.Module
 import GHC.Builtin.Names ( mAIN_NAME )
-import {-# SOURCE #-} GHC.Driver.Hooks
 import GHC.Driver.Phases ( Phase(..), phaseInputExt )
 import GHC.Driver.Flags
 import GHC.Driver.Backend
@@ -551,9 +550,6 @@ data DynFlags = DynFlags {
     -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
     -- order that they're specified on the command line.
 
-  -- GHC API hooks
-  hooks                 :: Hooks,
-
   --  For ghc -M
   depMakefile           :: FilePath,
   depIncludePkgDeps     :: Bool,
@@ -1172,7 +1168,6 @@ defaultDynFlags mySettings llvmConfig =
         pluginModNames          = [],
         pluginModNameOpts       = [],
         frontendPluginOpts      = [],
-        hooks                   = emptyHooks,
 
         outputFile_             = Nothing,
         dynOutputFile_          = Nothing,
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index f6de90de64..4249204615 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -82,9 +82,12 @@ so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with thes
 type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
                               -- the occurrence analyser will sort it all out
 
-dsForeigns :: [LForeignDecl GhcTc]
-           -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns fos = do
+    hooks <- getHooks
+    case dsForeignsHook hooks of
+        Nothing -> dsForeigns' fos
+        Just h  -> h fos
 
 dsForeigns' :: [LForeignDecl GhcTc]
             -> DsM (ForeignStubs, OrdList Binding)
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 8a1750909b..e8f1c62592 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -840,9 +840,11 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
        -- TODO: make this check a function
        if mod `installedModuleEq` gHC_PRIM
            then do
-               iface <- getHooked ghcPrimIfaceHook ghcPrimIface
-               return (Succeeded (iface,
-                                   "<built in interface for GHC.Prim>"))
+               hooks <- getHooks
+               let iface = case ghcPrimIfaceHook hooks of
+                            Nothing -> ghcPrimIface
+                            Just h  -> h
+               return (Succeeded (iface, "<built in interface for GHC.Prim>"))
            else do
                dflags <- getDynFlags
                -- Look for the file
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 30698d0f98..885fdf17fd 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -20,6 +20,7 @@ import GHC.Types.Name.Set
 import GHC.Hs
 import GHC.Types.Name.Reader
 import GHC.Tc.Utils.Monad
+import GHC.Driver.Env.Types
 
 import GHC.Rename.Env
 import GHC.Rename.Utils   ( HsDocContext(..), newLocalBndrRn )
@@ -314,7 +315,10 @@ runRnSplice :: UntypedSpliceFlavour
             -> HsSplice GhcRn   -- Always untyped
             -> TcRn (res, [ForeignRef (TH.Q ())])
 runRnSplice flavour run_meta ppr_res splice
-  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
+  = do { hooks <- hsc_hooks <$> getTopEnv
+       ; splice' <- case runRnSpliceHook hooks of
+            Nothing -> return splice
+            Just h  -> h splice
 
        ; let the_expr = case splice' of
                 HsUntypedSplice _ _ _ e   ->  e
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 683860ff20..73ad45c246 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -188,7 +188,9 @@ forceLoadTyCon hsc_env con_name = do
 
 getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
 getValueSafely hsc_env val_name expected_type = do
-  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
+  mb_hval <- case getValueSafelyHook hooks of
+    Nothing -> getHValueSafely hsc_env val_name expected_type
+    Just h  -> h               hsc_env val_name expected_type
   case mb_hval of
     Nothing   -> return Nothing
     Just hval -> do
@@ -197,6 +199,7 @@ getValueSafely hsc_env val_name expected_type = do
   where
     dflags = hsc_dflags hsc_env
     logger = hsc_logger hsc_env
+    hooks  = hsc_hooks hsc_env
 
 getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
 getHValueSafely hsc_env val_name expected_type = do
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index b40386e513..47d6e62997 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -216,8 +216,11 @@ to the module's usages.
 
 tcForeignImports :: [LForeignDecl GhcRn]
                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
-tcForeignImports decls
-  = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
+tcForeignImports decls = do
+    hooks <- getHooks
+    case tcForeignImportsHook hooks of
+        Nothing -> tcForeignImports' decls
+        Just h  -> h decls
 
 tcForeignImports' :: [LForeignDecl GhcRn]
                   -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
@@ -359,8 +362,11 @@ checkMissingAmpersand dflags arg_tys res_ty
 
 tcForeignExports :: [LForeignDecl GhcRn]
              -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-tcForeignExports decls =
-  getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
+tcForeignExports decls = do
+    hooks <- getHooks
+    case tcForeignExportsHook hooks of
+        Nothing -> tcForeignExports' decls
+        Just h  -> h decls
 
 tcForeignExports' :: [LForeignDecl GhcRn]
              -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index fab5a13c9b..ab45f3f373 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -870,9 +870,11 @@ runQResult show_th f runQ expr_span hval
 runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
         -> LHsExpr GhcTc
         -> TcM hs_syn
-runMeta unwrap e
-  = do { h <- getHooked runMetaHook defaultRunMeta
-       ; unwrap h e }
+runMeta unwrap e = do
+    hooks <- getHooks
+    case runMetaHook hooks of
+        Nothing -> unwrap defaultRunMeta e
+        Just h  -> unwrap h e
 
 defaultRunMeta :: MetaHook TcM
 defaultRunMeta (MetaE r)
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 2a54afc570..d70474393f 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -89,6 +89,7 @@ import GHC.Platform
 
 import GHC.Driver.Env
 import GHC.Driver.Session
+import {-# SOURCE #-} GHC.Driver.Hooks
 
 import GHC.Hs
 
@@ -237,6 +238,9 @@ data Env gbl lcl
 instance ContainsDynFlags (Env gbl lcl) where
     extractDynFlags env = hsc_dflags (env_top env)
 
+instance ContainsHooks (Env gbl lcl) where
+    extractHooks env = hsc_hooks (env_top env)
+
 instance ContainsLogger (Env gbl lcl) where
     extractLogger env = hsc_logger (env_top env)
 
diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
index 7d8a6b909c..33c1ab78be 100644
--- a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
+++ b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
@@ -15,12 +15,9 @@ plugin = defaultPlugin { driverPlugin = hooksP }
 
 hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv
 hooksP opts hsc_env = do
-    let dflags  = hsc_dflags hsc_env
-        dflags' = dflags
-            { hooks = (hooks dflags)
-                { runMetaHook = Just (fakeRunMeta opts) }
-            }
-        hsc_env' = hsc_env { hsc_dflags = dflags' }
+    let hooks  = hsc_hooks hsc_env
+        hooks' = hooks { runMetaHook = Just (fakeRunMeta opts) }
+        hsc_env' = hsc_env { hsc_hooks = hooks' }
     return hsc_env'
 
 -- This meta hook doesn't actually care running code in splices,