summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/BasicTypes.lhs11
-rw-r--r--compiler/deSugar/DsForeign.lhs17
-rw-r--r--compiler/deSugar/DsMonad.lhs-boot33
-rw-r--r--compiler/ghc.cabal.in2
-rw-r--r--compiler/ghc.mk2
-rw-r--r--compiler/ghci/ByteCodeLink.lhs3
-rw-r--r--compiler/ghci/ByteCodeLink.lhs-boot3
-rw-r--r--compiler/ghci/Linker.lhs2
-rw-r--r--compiler/ghci/RtClosureInspect.hs2
-rw-r--r--compiler/iface/LoadIface.lhs5
-rw-r--r--compiler/main/DriverPipeline.hs154
-rw-r--r--compiler/main/DynFlags.hs5
-rw-r--r--compiler/main/DynamicLoading.hs23
-rw-r--r--compiler/main/GHC.hs1
-rw-r--r--compiler/main/Hooks.lhs80
-rw-r--r--compiler/main/Hooks.lhs-boot9
-rw-r--r--compiler/main/HscMain.hs76
-rw-r--r--compiler/main/HscTypes.lhs56
-rw-r--r--compiler/main/InteractiveEval.hs1
-rw-r--r--compiler/main/InteractiveEvalTypes.hs2
-rw-r--r--compiler/main/PipelineMonad.hs109
-rw-r--r--compiler/typecheck/TcForeign.lhs30
-rw-r--r--compiler/typecheck/TcSplice.lhs7
-rw-r--r--docs/users_guide/7.8.1-notes.xml15
24 files changed, 458 insertions, 190 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index dfde994417..6fd038dcfa 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -75,7 +75,9 @@ module BasicTypes(
SuccessFlag(..), succeeded, failed, successIf,
- FractionalLit(..), negateFractionalLit, integralFractionalLit
+ FractionalLit(..), negateFractionalLit, integralFractionalLit,
+
+ HValue(..)
) where
import FastString
@@ -83,6 +85,7 @@ import Outputable
import Data.Data hiding (Fixity)
import Data.Function (on)
+import GHC.Exts (Any)
\end{code}
%************************************************************************
@@ -898,3 +901,9 @@ instance Ord FractionalLit where
instance Outputable FractionalLit where
ppr = text . fl_text
\end{code}
+
+\begin{code}
+
+newtype HValue = HValue Any
+
+\end{code}
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 1053b91aaa..c7cc13f598 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -6,7 +6,13 @@
Desugaring foreign declarations (see also DsCCall).
\begin{code}
-module DsForeign ( dsForeigns ) where
+module DsForeign ( dsForeigns
+ , dsForeigns'
+ , dsFImport, dsCImport, dsFCall, dsPrimCall
+ , dsFExport, dsFExportDynamic, mkFExportCBits
+ , toCType
+ , foreignExportInitialiser
+ ) where
#include "HsVersions.h"
import TcRnMonad -- temp
@@ -48,6 +54,7 @@ import Config
import OrdList
import Pair
import Util
+import Hooks
import Data.Maybe
import Data.List
@@ -72,9 +79,13 @@ type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
dsForeigns :: [LForeignDecl Id]
-> DsM (ForeignStubs, OrdList Binding)
-dsForeigns []
+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+
+dsForeigns' :: [LForeignDecl Id]
+ -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns' []
= return (NoStubs, nilOL)
-dsForeigns fos = do
+dsForeigns' fos = do
fives <- mapM do_ldecl fos
let
(hs, cs, idss, bindss) = unzip4 fives
diff --git a/compiler/deSugar/DsMonad.lhs-boot b/compiler/deSugar/DsMonad.lhs-boot
new file mode 100644
index 0000000000..081b048000
--- /dev/null
+++ b/compiler/deSugar/DsMonad.lhs-boot
@@ -0,0 +1,33 @@
+\begin{code}
+module DsMonad (DsM) where
+
+import TcRnTypes
+
+data DsGblEnv
+data DsLclEnv
+type DsM result = TcRnIf DsGblEnv DsLclEnv result
+
+\end{code}
+
+Some notes about this boot file (from Edsko):
+
+
+DsMonad has a (transitive) dependency on Hooks in at least two ways:
+once through Finder, which imports Packages, which imports Hooks; but
+that's easily solved, because Finder can import PackageState
+instead. However, it is less obvious to me how to resolve the
+following import cycle
+
+- DsMonad imports tcIfaceGlobal from TcIface
+- TcIface imports (loadWiredInHomeIface, loadInterface, loadDecls,
+findAndReadIface) from LoadIface
+- LoadIFace imports Hooks
+
+(There might be still others, this is the most direct one at the moment.)
+
+(Just to be clear, Hooks imports DsMonad because it needs the DsM type
+for the dsForeignsHook.)
+
+I'm sure this cycle can be broken somehow, but I'm not familiar enough
+with this part of the compiler to see if there is a natural point to
+do it.
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index a0f3e642f5..1ed7e2310e 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -134,6 +134,7 @@ Library
Demand
Exception
GhcMonad
+ Hooks
Id
IdInfo
Literal
@@ -276,6 +277,7 @@ Library
Constants
DriverMkDepend
DriverPhases
+ PipelineMonad
DriverPipeline
DynFlags
ErrUtils
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index bf0ecaa65a..4fdadd7c30 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -445,7 +445,7 @@ compiler_stage3_SplitObjs = NO
# We therefore need to split some of the modules off into a separate
# DLL. This clump are the modules reachable from DynFlags:
compiler_stage2_dll0_START_MODULE = DynFlags
-compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception ExtsCompat46 FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
+compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DsMonad DynFlags Encoding ErrUtils Exception ExtsCompat46 FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hooks Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic PipelineMonad Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
compiler_stage2_dll0_HS_OBJS = \
$(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES)))
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
index 06421dc1db..4c484097f0 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -8,7 +8,6 @@ ByteCodeLink: Bytecode assembler and linker
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module ByteCodeLink (
- HValue,
ClosureEnv, emptyClosureEnv, extendClosureEnv,
linkBCO, lookupStaticPtr, lookupName
,lookupIE
@@ -21,6 +20,7 @@ import ByteCodeAsm
import ObjLink
import DynFlags
+import BasicTypes
import Name
import NameEnv
import PrimOp
@@ -52,7 +52,6 @@ import GHC.Ptr ( castPtr )
\begin{code}
type ClosureEnv = NameEnv (Name, HValue)
-newtype HValue = HValue Any
emptyClosureEnv :: ClosureEnv
emptyClosureEnv = emptyNameEnv
diff --git a/compiler/ghci/ByteCodeLink.lhs-boot b/compiler/ghci/ByteCodeLink.lhs-boot
deleted file mode 100644
index 2b78c36293..0000000000
--- a/compiler/ghci/ByteCodeLink.lhs-boot
+++ /dev/null
@@ -1,3 +0,0 @@
->module ByteCodeLink where
->
->data HValue
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 192df2ee57..edc0db1295 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -11,7 +11,7 @@
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
-module Linker ( HValue, getHValue, showLinkerState,
+module Linker ( getHValue, showLinkerState,
linkExpr, linkDecls, unload, withExtendedLinkEnv,
extendLinkEnv, deleteFromLinkEnv,
extendLoadedPkgs,
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 746a547a5b..9a5edbdc01 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -35,8 +35,8 @@ module RtClosureInspect(
import DebuggerUtils
import ByteCodeItbls ( StgInfoTable, peekItbl )
import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
+import BasicTypes ( HValue )
import HscTypes
-import Linker
import DataCon
import Type
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index ac0b09c572..0fc8e68901 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -59,6 +59,7 @@ import Panic
import Util
import FastString
import Fingerprint
+import Hooks
import Control.Monad
import Data.IORef
@@ -516,7 +517,9 @@ findAndReadIface doc_str mod hi_boot_file
-- Check for GHC.Prim, and return its static interface
if mod == gHC_PRIM
- then return (Succeeded (ghcPrimIface,
+ then do
+ iface <- getHooked ghcPrimIfaceHook ghcPrimIface
+ return (Succeeded (iface,
"<built in interface for GHC.Prim>"))
else do
dflags <- getDynFlags
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 048896c009..035d5778d6 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -23,17 +23,26 @@ module DriverPipeline (
compileOne, compileOne',
link,
+ -- Exports for hooks to override runPhase and link
+ PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
+ phaseOutputFilename, getPipeState, getPipeEnv,
+ hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
+ runPhase, exeFileName,
+ mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
+ maybeCreateManifest, runPhase_MoveBinary,
+ linkingNeeded, checkLinkInfo
) where
#include "HsVersions.h"
+import PipelineMonad
import Packages
import HeaderInfo
import DriverPhases
import SysTools
import HscMain
import Finder
-import HscTypes
+import HscTypes hiding ( Hsc )
import Outputable
import Module
import UniqFM ( eltsUFM )
@@ -52,6 +61,7 @@ import LlvmCodeGen ( llvmFixupAsm )
import MonadUtils
import Platform
import TcRnTypes
+import Hooks
import Exception
import Data.IORef ( readIORef )
@@ -283,23 +293,26 @@ link :: GhcLink -- interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-link LinkInMemory _ _ _
- = if cGhcWithInterpreter == "YES"
- then -- Not Linking...(demand linker will do the job)
- return Succeeded
- else panicBadLink LinkInMemory
+link ghcLink dflags
+ = lookupHook linkHook l dflags ghcLink dflags
+ where
+ l LinkInMemory _ _ _
+ = if cGhcWithInterpreter == "YES"
+ then -- Not Linking...(demand linker will do the job)
+ return Succeeded
+ else panicBadLink LinkInMemory
-link NoLink _ _ _
- = return Succeeded
+ l NoLink _ _ _
+ = return Succeeded
-link LinkBinary dflags batch_attempt_linking hpt
- = link' dflags batch_attempt_linking hpt
+ l LinkBinary dflags batch_attempt_linking hpt
+ = link' dflags batch_attempt_linking hpt
-link LinkStaticLib dflags batch_attempt_linking hpt
- = link' dflags batch_attempt_linking hpt
+ l LinkStaticLib dflags batch_attempt_linking hpt
+ = link' dflags batch_attempt_linking hpt
-link LinkDynLib dflags batch_attempt_linking hpt
- = link' dflags batch_attempt_linking hpt
+ l LinkDynLib dflags batch_attempt_linking hpt
+ = link' dflags batch_attempt_linking hpt
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
@@ -499,20 +512,6 @@ doLink dflags stop_phase o_files
-- ---------------------------------------------------------------------------
-data PipelineOutput
- = Temporary
- -- ^ Output should be to a temporary file: we're going to
- -- run more compilation steps on this output later.
- | Persistent
- -- ^ We want a persistent file, i.e. a file in the current directory
- -- derived from the input filename, but with the appropriate extension.
- -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
- | SpecificFile
- -- ^ The output must go into the specific outputFile in DynFlags.
- -- We don't store the filename in the constructor as it changes
- -- when doing -dynamic-too.
- deriving Show
-
-- | Run a compilation pipeline, consisting of multiple phases.
--
-- This is the interface to the compilation pipeline, which runs
@@ -615,83 +614,6 @@ runPipeline' start_phase hsc_env env input_fn
evalP (pipeLoop start_phase input_fn) env state
--- -----------------------------------------------------------------------------
--- The pipeline uses a monad to carry around various bits of information
-
--- PipeEnv: invariant information passed down
-data PipeEnv = PipeEnv {
- pe_isHaskellishFile :: Bool,
- stop_phase :: Phase, -- ^ Stop just before this phase
- src_filename :: String, -- ^ basename of original input source
- src_basename :: String, -- ^ basename of original input source
- src_suffix :: String, -- ^ its extension
- output_spec :: PipelineOutput -- ^ says where to put the pipeline output
- }
-
--- PipeState: information that might change during a pipeline run
-data PipeState = PipeState {
- hsc_env :: HscEnv,
- -- ^ only the DynFlags change in the HscEnv. The DynFlags change
- -- at various points, for example when we read the OPTIONS_GHC
- -- pragmas in the Cpp phase.
- maybe_loc :: Maybe ModLocation,
- -- ^ the ModLocation. This is discovered during compilation,
- -- in the Hsc phase where we read the module header.
- maybe_stub_o :: Maybe FilePath
- -- ^ the stub object. This is set by the Hsc phase if a stub
- -- object was created. The stub object will be joined with
- -- the main compilation object using "ld -r" at the end.
- }
-
-getPipeEnv :: CompPipeline PipeEnv
-getPipeEnv = P $ \env state -> return (state, env)
-
-getPipeState :: CompPipeline PipeState
-getPipeState = P $ \_env state -> return (state, state)
-
-instance HasDynFlags CompPipeline where
- getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
-
-setDynFlags :: DynFlags -> CompPipeline ()
-setDynFlags dflags = P $ \_env state ->
- return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
-
-setModLocation :: ModLocation -> CompPipeline ()
-setModLocation loc = P $ \_env state ->
- return (state{ maybe_loc = Just loc }, ())
-
-setStubO :: FilePath -> CompPipeline ()
-setStubO stub_o = P $ \_env state ->
- return (state{ maybe_stub_o = Just stub_o }, ())
-
-newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
-
-evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
-evalP f env st = liftM snd $ unP f env st
-
-instance Functor CompPipeline where
- fmap = liftM
-
-instance Applicative CompPipeline where
- pure = return
- (<*>) = ap
-
-instance Monad CompPipeline where
- return a = P $ \_env state -> return (state, a)
- P m >>= k = P $ \env state -> do (state',a) <- m env state
- unP (k a) env state'
-
-instance MonadIO CompPipeline where
- liftIO m = P $ \_env state -> do a <- m; return (state, a)
-
-phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
-phaseOutputFilename next_phase = do
- PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
- PipeState{maybe_loc, hsc_env} <- getPipeState
- let dflags = hsc_dflags hsc_env
- liftIO $ getOutputFilename stop_phase output_spec
- src_basename dflags next_phase maybe_loc
-
-- ---------------------------------------------------------------------------
-- outer pipeline loop
@@ -735,7 +657,7 @@ pipeLoop phase input_fn = do
_
-> do liftIO $ debugTraceMsg dflags 4
(ptext (sLit "Running phase") <+> ppr phase)
- (next_phase, output_fn) <- runPhase phase input_fn dflags
+ (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
r <- pipeLoop next_phase output_fn
case phase of
HscOut {} ->
@@ -748,11 +670,24 @@ pipeLoop phase input_fn = do
return ()
return r
+runHookedPhase :: PhasePlus -> FilePath -> DynFlags
+ -> CompPipeline (PhasePlus, FilePath)
+runHookedPhase pp input dflags =
+ lookupHook runPhaseHook runPhase dflags pp input dflags
+
-- -----------------------------------------------------------------------------
-- In each phase, we need to know into what filename to generate the
-- output. All the logic about which filenames we generate output
-- into is embodied in the following function.
+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
+phaseOutputFilename next_phase = do
+ PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
+ PipeState{maybe_loc, hsc_env} <- getPipeState
+ let dflags = hsc_dflags hsc_env
+ liftIO $ getOutputFilename stop_phase output_spec
+ src_basename dflags next_phase maybe_loc
+
getOutputFilename
:: Phase -> PipelineOutput -> String
-> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
@@ -801,13 +736,6 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
| Just d <- odir = d </> persistent
| otherwise = persistent
-data PhasePlus = RealPhase Phase
- | HscOut HscSource ModuleName HscStatus
-
-instance Outputable PhasePlus where
- ppr (RealPhase p) = ppr p
- ppr (HscOut {}) = text "HscOut"
-
-- -----------------------------------------------------------------------------
-- | Each phase in the pipeline returns the next phase to execute, and the
-- name of the file in which the output was placed.
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6f528a28b4..63da5d6100 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -142,6 +142,7 @@ import Platform
import PlatformConstants
import Module
import PackageConfig
+import {-# SOURCE #-} Hooks
import {-# SOURCE #-} PrelNames ( mAIN )
import {-# SOURCE #-} Packages (PackageState)
import DriverPhases ( Phase(..), phaseInputExt )
@@ -671,6 +672,9 @@ data DynFlags = DynFlags {
pluginModNames :: [ModuleName],
pluginModNameOpts :: [(ModuleName,String)],
+ -- GHC API hooks
+ hooks :: Hooks,
+
-- For ghc -M
depMakefile :: FilePath,
depIncludePkgDeps :: Bool,
@@ -1314,6 +1318,7 @@ defaultDynFlags mySettings =
pluginModNames = [],
pluginModNameOpts = [],
+ hooks = emptyHooks,
outputFile = Nothing,
dynOutputFile = Nothing,
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 889a09de20..f26221282e 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -11,6 +11,7 @@ module DynamicLoading (
-- * Loading values
getValueSafely,
+ getHValueSafely,
lessUnsafeCoerce
#endif
) where
@@ -29,6 +30,7 @@ import PrelNames ( iNTERACTIVE )
import DynFlags
import HscTypes ( HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv )
+import BasicTypes ( HValue )
import TypeRep ( TyThing(..), pprTyThingCategory )
import Type ( Type, eqType )
import TyCon ( TyCon )
@@ -40,6 +42,7 @@ import FastString
import ErrUtils
import Outputable
import Exception
+import Hooks
import Data.Maybe ( mapMaybe )
import GHC.Exts ( unsafeCoerce# )
@@ -86,8 +89,18 @@ forceLoadTyCon hsc_env con_name = do
getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
- forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getValueSafely")) val_name
-
+ mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
+ case mb_hval of
+ Nothing -> return Nothing
+ Just hval -> do
+ value <- lessUnsafeCoerce dflags "getValueSafely" hval
+ return (Just value)
+ where
+ dflags = hsc_dflags hsc_env
+
+getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
+getHValueSafely hsc_env val_name expected_type = do
+ forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getHValueSafely")) val_name
-- Now look up the names for the value and type constructor in the type environment
mb_val_thing <- lookupTypeHscEnv hsc_env val_name
case mb_val_thing of
@@ -104,12 +117,10 @@ getValueSafely hsc_env val_name expected_type = do
Nothing -> return ()
-- Find the value that we just linked in and cast it given that we have proved it's type
hval <- getHValue hsc_env val_name
- value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval
- return $ Just value
+ return (Just hval)
else return Nothing
Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
- where dflags = hsc_dflags hsc_env
-
+ where dflags = hsc_dflags hsc_env
-- | Coerce a value as usual, but:
--
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 39e1e0a453..a54185bb1c 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -254,7 +254,6 @@ module GHC (
#include "HsVersions.h"
#ifdef GHCI
-import Linker ( HValue )
import ByteCodeInstr
import BreakArray
import InteractiveEval
diff --git a/compiler/main/Hooks.lhs b/compiler/main/Hooks.lhs
new file mode 100644
index 0000000000..24bfb104bc
--- /dev/null
+++ b/compiler/main/Hooks.lhs
@@ -0,0 +1,80 @@
+\section[Hooks]{Low level API hooks}
+
+\begin{code}
+module Hooks ( Hooks
+ , emptyHooks
+ , lookupHook
+ , getHooked
+ -- the hooks:
+ , dsForeignsHook
+ , tcForeignImportsHook
+ , tcForeignExportsHook
+ , hscFrontendHook
+ , hscCompileOneShotHook
+ , hscCompileCoreExprHook
+ , ghcPrimIfaceHook
+ , runPhaseHook
+ , linkHook
+ , runQuasiQuoteHook
+ , getValueSafelyHook
+ ) where
+
+import DynFlags
+import HsTypes
+import Name
+import PipelineMonad
+import HscTypes
+import HsDecls
+import HsBinds
+import {-# SOURCE #-} DsMonad
+import OrdList
+import Id
+import TcRnTypes
+import Bag
+import RdrName
+import CoreSyn
+import BasicTypes
+import Type
+import SrcLoc
+
+import Data.Maybe
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Hooks}
+%* *
+%************************************************************************
+
+\begin{code}
+
+-- | Hooks can be used by GHC API clients to replace parts of
+-- the compiler pipeline. If a hook is not installed, GHC
+-- uses the default built-in behaviour
+
+emptyHooks :: Hooks
+emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing Nothing Nothing
+
+data Hooks = Hooks
+ { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
+ , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt))
+ , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt))
+ , hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv)
+ , hscCompileOneShotHook :: Maybe (HscEnv -> FilePath -> ModSummary -> SourceModified -> IO HscStatus)
+ , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
+ , ghcPrimIfaceHook :: Maybe ModIface
+ , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
+ , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
+ , runQuasiQuoteHook :: Maybe (HsQuasiQuote Name -> RnM (HsQuasiQuote Name))
+ , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
+ }
+
+getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a
+getHooked hook def = fmap (lookupHook hook def) getDynFlags
+
+lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a
+lookupHook hook def = fromMaybe def . hook . hooks
+
+\end{code}
+
diff --git a/compiler/main/Hooks.lhs-boot b/compiler/main/Hooks.lhs-boot
new file mode 100644
index 0000000000..71b7bf2a7d
--- /dev/null
+++ b/compiler/main/Hooks.lhs-boot
@@ -0,0 +1,9 @@
+\begin{code}
+module Hooks where
+
+data Hooks
+
+emptyHooks :: Hooks
+
+\end{code}
+
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 774f5be488..39e483ef43 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -70,11 +70,18 @@ module HscMain
, hscDecls, hscDeclsWithLocation
, hscTcExpr, hscImport, hscKcType
, hscCompileCoreExpr
+ -- * Low-level exports for hooks
+ , hscCompileCoreExpr'
#endif
+ , hscParse', hscSimplify', hscDesugar', tcRnModule'
+ , hscSimpleIface', hscNormalIface'
+ , oneShotMsg
+ , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
) where
#ifdef GHCI
import Id
+import BasicTypes ( HValue )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy ( tidyExpr )
@@ -128,6 +135,7 @@ import NameSet ( emptyNameSet )
import InstEnv
import FamInstEnv
import Fingerprint ( Fingerprint )
+import Hooks
import DynFlags
import ErrUtils
@@ -190,38 +198,6 @@ knownKeyNames = -- where templateHaskellNames are defined
#endif
-- -----------------------------------------------------------------------------
--- The Hsc monad: Passing an enviornment and warning state
-
-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
-
-instance Functor Hsc where
- fmap = liftM
-
-instance Applicative Hsc where
- pure = return
- (<*>) = ap
-
-instance Monad Hsc where
- return a = Hsc $ \_ w -> return (a, w)
- Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
- case k a of
- Hsc k' -> k' e w1
-
-instance MonadIO Hsc where
- liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
-
-runHsc :: HscEnv -> Hsc a -> IO a
-runHsc hsc_env (Hsc hsc) = do
- (a, w) <- hsc hsc_env emptyBag
- printOrThrowWarnings (hsc_dflags hsc_env) w
- return a
-
--- A variant of runHsc that switches in the DynFlags from the
--- InteractiveContext before running the Hsc computation.
---
-runInteractiveHsc :: HscEnv -> Hsc a -> IO a
-runInteractiveHsc hsc_env =
- runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) })
getWarnings :: Hsc WarningMessages
getWarnings = Hsc $ \_ w -> return (w, w)
@@ -235,9 +211,6 @@ logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
getHscEnv :: Hsc HscEnv
getHscEnv = Hsc $ \e w -> return (e, w)
-instance HasDynFlags Hsc where
- getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
-
handleWarnings :: Hsc ()
handleWarnings = do
dflags <- getDynFlags
@@ -527,13 +500,6 @@ This is the only thing that isn't caught by the type-system.
-}
--- | Status of a compilation to hard-code
-data HscStatus
- = HscNotGeneratingCode
- | HscUpToDate
- | HscUpdateBoot
- | HscRecomp CgGuts ModSummary
-
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
genericHscCompileGetFrontendResult ::
@@ -607,23 +573,35 @@ genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_resu
return $ Right (tc_result, mb_old_hash)
genericHscFrontend :: ModSummary -> Hsc TcGblEnv
-genericHscFrontend mod_summary
+genericHscFrontend mod_summary =
+ getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
+
+genericHscFrontend' :: ModSummary -> Hsc TcGblEnv
+genericHscFrontend' mod_summary
| ExtCoreFile <- ms_hsc_src mod_summary =
panic "GHC does not currently support reading External Core files"
- | otherwise = do
+ | otherwise =
hscFileFrontEnd mod_summary
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
--- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: HscEnv
-> FilePath
-> ModSummary
-> SourceModified
-> IO HscStatus
-hscCompileOneShot hsc_env extCore_filename mod_summary src_changed
+hscCompileOneShot env =
+ lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env
+
+-- Compile Haskell, boot and extCore in OneShot mode.
+hscCompileOneShot' :: HscEnv
+ -> FilePath
+ -> ModSummary
+ -> SourceModified
+ -> IO HscStatus
+hscCompileOneShot' hsc_env extCore_filename mod_summary src_changed
= do
-- One-shot mode needs a knot-tying mutable variable for interface
-- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
@@ -1616,7 +1594,11 @@ mkModGuts mod safe binds =
#ifdef GHCI
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
-hscCompileCoreExpr hsc_env srcspan ds_expr
+hscCompileCoreExpr hsc_env =
+ lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
+
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
+hscCompileCoreExpr' hsc_env srcspan ds_expr
| rtsIsProfiled
= throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
-- Otherwise you get a seg-fault when you run it
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 33dbba2c21..27a7e211f5 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -12,6 +12,10 @@ module HscTypes (
FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
+ HscStatus(..),
+
+ -- * Hsc monad
+ Hsc(..), runHsc, runInteractiveHsc,
-- * Information about modules
ModDetails(..), emptyModDetails,
@@ -143,7 +147,7 @@ import DataCon
import PrelNames ( gHC_PRIM, ioTyConName, printName )
import Packages hiding ( Version(..) )
import DynFlags
-import DriverPhases
+import DriverPhases ( Phase, HscSource(..), isHsBoot, hscSourceString )
import BasicTypes
import IfaceSyn
import CoreSyn ( CoreRule, CoreVect )
@@ -164,7 +168,7 @@ import ErrUtils
import Platform
import Util
-import Control.Monad ( mplus, guard, liftM, when )
+import Control.Monad ( mplus, guard, liftM, when, ap )
import Data.Array ( Array, array )
import Data.IORef
import Data.Time
@@ -174,6 +178,54 @@ import Exception
import System.FilePath
-- -----------------------------------------------------------------------------
+-- Compilation state
+-- -----------------------------------------------------------------------------
+
+-- | Status of a compilation to hard-code
+data HscStatus
+ = HscNotGeneratingCode
+ | HscUpToDate
+ | HscUpdateBoot
+ | HscRecomp CgGuts ModSummary
+
+-- -----------------------------------------------------------------------------
+-- The Hsc monad: Passing an environment and warning state
+
+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
+
+instance Functor Hsc where
+ fmap = liftM
+
+instance Applicative Hsc where
+ pure = return
+ (<*>) = ap
+
+instance Monad Hsc where
+ return a = Hsc $ \_ w -> return (a, w)
+ Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
+ case k a of
+ Hsc k' -> k' e w1
+
+instance MonadIO Hsc where
+ liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
+
+instance HasDynFlags Hsc where
+ getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
+
+runHsc :: HscEnv -> Hsc a -> IO a
+runHsc hsc_env (Hsc hsc) = do
+ (a, w) <- hsc hsc_env emptyBag
+ printOrThrowWarnings (hsc_dflags hsc_env) w
+ return a
+
+-- A variant of runHsc that switches in the DynFlags from the
+-- InteractiveContext before running the Hsc computation.
+--
+runInteractiveHsc :: HscEnv -> Hsc a -> IO a
+runInteractiveHsc hsc_env =
+ runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) })
+
+-- -----------------------------------------------------------------------------
-- Source Errors
-- When the compiler (HscMain) discovers errors, it throws an
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 635c194a92..439cc0c87a 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -44,6 +44,7 @@ import GhcMonad
import HscMain
import HsSyn
import HscTypes
+import BasicTypes ( HValue )
import InstEnv
import FamInstEnv ( FamInst, orphNamesOfFamInst )
import TyCon
diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs
index 87027cf403..e3324a39a1 100644
--- a/compiler/main/InteractiveEvalTypes.hs
+++ b/compiler/main/InteractiveEvalTypes.hs
@@ -15,11 +15,11 @@ module InteractiveEvalTypes (
#ifdef GHCI
import Id
+import BasicTypes
import Name
import RdrName
import TypeRep
import ByteCodeInstr
-import ByteCodeLink
import SrcLoc
import Exception
import Control.Concurrent
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
new file mode 100644
index 0000000000..c81f1f20ae
--- /dev/null
+++ b/compiler/main/PipelineMonad.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE NamedFieldPuns #-}
+-- | The CompPipeline monad and associated ops
+--
+-- Defined in separate module so that it can safely be imported from Hooks
+module PipelineMonad (
+ CompPipeline(..), evalP
+ , PhasePlus(..)
+ , PipeEnv(..), PipeState(..), PipelineOutput(..)
+ , getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO
+ ) where
+
+import MonadUtils
+import Outputable
+import DynFlags
+import DriverPhases
+import HscTypes
+import Module
+
+import Control.Monad
+
+newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
+
+evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
+evalP f env st = liftM snd $ unP f env st
+
+instance Functor CompPipeline where
+ fmap = liftM
+
+instance Applicative CompPipeline where
+ pure = return
+ (<*>) = ap
+
+instance Monad CompPipeline where
+ return a = P $ \_env state -> return (state, a)
+ P m >>= k = P $ \env state -> do (state',a) <- m env state
+ unP (k a) env state'
+
+instance MonadIO CompPipeline where
+ liftIO m = P $ \_env state -> do a <- m; return (state, a)
+
+data PhasePlus = RealPhase Phase
+ | HscOut HscSource ModuleName HscStatus
+
+instance Outputable PhasePlus where
+ ppr (RealPhase p) = ppr p
+ ppr (HscOut {}) = text "HscOut"
+
+-- -----------------------------------------------------------------------------
+-- The pipeline uses a monad to carry around various bits of information
+
+-- PipeEnv: invariant information passed down
+data PipeEnv = PipeEnv {
+ pe_isHaskellishFile :: Bool,
+ stop_phase :: Phase, -- ^ Stop just before this phase
+ src_filename :: String, -- ^ basename of original input source
+ src_basename :: String, -- ^ basename of original input source
+ src_suffix :: String, -- ^ its extension
+ output_spec :: PipelineOutput -- ^ says where to put the pipeline output
+ }
+
+-- PipeState: information that might change during a pipeline run
+data PipeState = PipeState {
+ hsc_env :: HscEnv,
+ -- ^ only the DynFlags change in the HscEnv. The DynFlags change
+ -- at various points, for example when we read the OPTIONS_GHC
+ -- pragmas in the Cpp phase.
+ maybe_loc :: Maybe ModLocation,
+ -- ^ the ModLocation. This is discovered during compilation,
+ -- in the Hsc phase where we read the module header.
+ maybe_stub_o :: Maybe FilePath
+ -- ^ the stub object. This is set by the Hsc phase if a stub
+ -- object was created. The stub object will be joined with
+ -- the main compilation object using "ld -r" at the end.
+ }
+
+data PipelineOutput
+ = Temporary
+ -- ^ Output should be to a temporary file: we're going to
+ -- run more compilation steps on this output later.
+ | Persistent
+ -- ^ We want a persistent file, i.e. a file in the current directory
+ -- derived from the input filename, but with the appropriate extension.
+ -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
+ | SpecificFile
+ -- ^ The output must go into the specific outputFile in DynFlags.
+ -- We don't store the filename in the constructor as it changes
+ -- when doing -dynamic-too.
+ deriving Show
+
+getPipeEnv :: CompPipeline PipeEnv
+getPipeEnv = P $ \env state -> return (state, env)
+
+getPipeState :: CompPipeline PipeState
+getPipeState = P $ \_env state -> return (state, state)
+
+instance HasDynFlags CompPipeline where
+ getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
+
+setDynFlags :: DynFlags -> CompPipeline ()
+setDynFlags dflags = P $ \_env state ->
+ return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
+
+setModLocation :: ModLocation -> CompPipeline ()
+setModLocation loc = P $ \_env state ->
+ return (state{ maybe_loc = Just loc }, ())
+
+setStubO :: FilePath -> CompPipeline ()
+setStubO stub_o = P $ \_env state ->
+ return (state{ maybe_stub_o = Just stub_o }, ())
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index cf5ed0084a..63eb020ff1 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -13,9 +13,19 @@ module checks to see if a foreign declaration has got a legal type.
\begin{code}
module TcForeign
- (
- tcForeignImports
+ ( tcForeignImports
, tcForeignExports
+
+ -- Low-level exports for hooks
+ , isForeignImport, isForeignExport
+ , tcFImport, tcFExport
+ , tcForeignImports'
+ , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
+ , normaliseFfiType
+ , nonIOok, mustBeIO
+ , checkSafe, noCheckSafe
+ , tcForeignExports'
+ , tcCheckFEType
) where
#include "HsVersions.h"
@@ -29,7 +39,7 @@ import TcEnv
import FamInst
import FamInstEnv
-import Coercion
+import Coercion
import Type
import TypeRep
import ForeignCall
@@ -47,6 +57,7 @@ import Platform
import SrcLoc
import Bag
import FastString
+import Hooks
import Control.Monad
\end{code}
@@ -192,9 +203,13 @@ to the module's usages.
\begin{code}
tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
+tcForeignImports decls
+ = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
+
+tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
-- For the (Bag GlobalRdrElt) result,
-- see Note [Newtype constructor usage in foreign declarations]
-tcForeignImports decls
+tcForeignImports' decls
= do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
filter isForeignImport decls
; return (ids, decls, unionManyBags gres) }
@@ -323,9 +338,14 @@ checkMissingAmpersand dflags arg_tys res_ty
\begin{code}
tcForeignExports :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
+tcForeignExports decls =
+ getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
+
+tcForeignExports' :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
-- For the (Bag GlobalRdrElt) result,
-- see Note [Newtype constructor usage in foreign declarations]
-tcForeignExports decls
+tcForeignExports' decls
= foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
where
combine (binds, fs, gres1) (L loc fe) = do
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 968eb0d0e4..9f7ef4070c 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -49,6 +49,7 @@ import NameSet
import PrelNames
import HscTypes
import OccName
+import Hooks
import Var
import Module
import Annotations
@@ -722,10 +723,12 @@ runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
; checkTc (not is_local) (quoteStageError quoter')
; traceTc "runQQ" (ppr quoter <+> ppr is_local)
+ ; HsQuasiQuote quoter'' _ quote' <- getHooked runQuasiQuoteHook return >>=
+ ($ HsQuasiQuote quoter' q_span quote)
-- Build the expression
- ; let quoterExpr = L q_span $! HsVar $! quoter'
- ; let quoteExpr = L q_span $! HsLit $! HsString quote
+ ; let quoterExpr = L q_span $! HsVar $! quoter''
+ ; let quoteExpr = L q_span $! HsLit $! HsString quote'
; let expr = L q_span $
HsApp (L q_span $
HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
diff --git a/docs/users_guide/7.8.1-notes.xml b/docs/users_guide/7.8.1-notes.xml
index 0092cf4091..7db6f316a3 100644
--- a/docs/users_guide/7.8.1-notes.xml
+++ b/docs/users_guide/7.8.1-notes.xml
@@ -237,6 +237,21 @@
using the new flag <literal>-f[no-]warn-amp</literal>.
</para>
</listitem>
+ <listitem>
+ <para>
+ GHC's internal compiler pipeline is now exposed
+ through a <literal>Hooks</literal> module inside the
+ GHC API. These hooks allow you to control most of the
+ internal compiler phase machinery, including compiling
+ expressions, phase control, and linking.
+ </para>
+
+ <para>
+ Note: this interface will likely see continuous
+ refinment and API changes in future releases, so it
+ should be considered a preview.
+ </para>
+ </listitem>
</itemizedlist>
</sect2>
View Lorry Controller Status