Add dynamically-linked plugins (see Trac #3843)

This patch was originally developed by Max Bolingbroke, and worked on
further by Austin Seipp.  It allows you to write a Core-to-Core pass
and have it dynamically linked into an otherwise-unmodified GHC, and
run at a place you specify in the Core optimisation pipeline.

Main components:
  - CoreMonad: new types Plugin, PluginPass
               plus a new constructor CoreDoPluginPass in CoreToDo

  - SimplCore: stuff to dynamically load any plugins, splice
    them into the core-to-core pipeline, and invoke them

  - Move "getCoreToDo :: DynFlags -> [CoreToDo]"
      which constructs the main core-to-core pipeline
      from CoreMonad to SimplCore
    SimplCore is the driver for the optimisation pipeline, and it
    makes more sense to have the pipeline construction in the driver
    not in the infrastructure module.

  - New module DynamicLoading: invoked by SimplCore to load any plugins
    Some consequential changes in Linker.

  - New module GhcPlugins: this should be imported by plugin modules; it
    it not used by GHC itself.

9 files changed, 669 insertions, 215 deletions

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 89b3eddfd7..6e566a23ad 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -39,7 +39,8 @@ module Module
         dphSeqPackageId,
         dphParPackageId,
 	mainPackageId,
-
+        thisGhcPackageId,
+        
 	-- * The Module type
 	Module,
 	modulePackageId, moduleName,
@@ -342,7 +343,7 @@ packageIdString = unpackFS . packageIdFS
 integerPackageId, primPackageId,
   basePackageId, rtsPackageId,
   thPackageId, dphSeqPackageId, dphParPackageId,
-  mainPackageId  :: PackageId
+  mainPackageId, thisGhcPackageId  :: PackageId
 primPackageId      = fsToPackageId (fsLit "ghc-prim")
 integerPackageId   = fsToPackageId (fsLit cIntegerLibrary)
 basePackageId      = fsToPackageId (fsLit "base")
@@ -350,6 +351,7 @@ rtsPackageId       = fsToPackageId (fsLit "rts")
 thPackageId        = fsToPackageId (fsLit "template-haskell")
 dphSeqPackageId    = fsToPackageId (fsLit "dph-seq")
 dphParPackageId    = fsToPackageId (fsLit "dph-par")
+thisGhcPackageId   = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion))
 
 -- | This is the package Id for the current program.  It is the default
 -- package Id if you don't specify a package name.  We don't add this prefix
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 841d85e6c0..2711c1b20e 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -314,6 +314,8 @@ Library
         Finder
         GHC
         GhcMake
+        GhcPlugins
+        DynamicLoading
         HeaderInfo
         HscMain
         HscStats
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index eaf452199e..ef349ebb10 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -15,8 +15,8 @@ module Linker ( HValue, getHValue, showLinkerState,
 		linkExpr, unload, withExtendedLinkEnv,
                 extendLinkEnv, deleteFromLinkEnv,
                 extendLoadedPkgs, 
-		linkPackages,initDynLinker,
-                dataConInfoPtrToName
+		linkPackages,initDynLinker,linkModule,
+                dataConInfoPtrToName, lessUnsafeCoerce
 	) where
 
 #include "HsVersions.h"
@@ -55,6 +55,8 @@ import Constants
 import FastString
 import Config
 
+import GHC.Exts (unsafeCoerce#)
+
 -- Standard libraries
 import Control.Monad
 
@@ -264,6 +266,7 @@ dataConInfoPtrToName x = do
 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
 getHValue :: HscEnv -> Name -> IO HValue
 getHValue hsc_env name = do
+  initDynLinker (hsc_dflags hsc_env)
   pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
            if (isExternalName name) then do
              (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
@@ -277,6 +280,7 @@ linkDependencies :: HscEnv -> PersistentLinkerState
                  -> SrcSpan -> [Module]
                  -> IO (PersistentLinkerState, SuccessFlag)
 linkDependencies hsc_env pls span needed_mods = do
+--   initDynLinker (hsc_dflags hsc_env)
    let hpt = hsc_HPT hsc_env
        dflags = hsc_dflags hsc_env
 	-- The interpreter and dynamic linker can only handle object code built
@@ -696,6 +700,38 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
 	    adjust_ul _ _ = panic "adjust_ul"
 \end{code}
 
+%************************************************************************
+%*									*
+              Loading a single module
+%*									*
+%************************************************************************
+\begin{code}
+
+-- | Link a single module
+linkModule :: HscEnv -> Module -> IO ()
+linkModule hsc_env mod = do
+  initDynLinker (hsc_dflags hsc_env)
+  modifyMVar v_PersistentLinkerState $ \pls -> do
+    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
+    if (failed ok) then ghcError (ProgramError "could not link module")
+      else return (pls',())
+
+-- | Coerce a value as usual, but:
+--
+-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
+--
+-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
+--    if it /does/ segfault
+lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
+lessUnsafeCoerce dflags context what = do
+    debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...")
+    output <- evaluate (unsafeCoerce# what)
+    debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion"
+    return output
+
+
+
+\end{code}
 
 %************************************************************************
 %*									*
@@ -997,6 +1033,7 @@ linkPackages :: DynFlags -> [PackageId] -> IO ()
 linkPackages dflags new_pkgs = do
   -- It's probably not safe to try to load packages concurrently, so we take
   -- a lock.
+  initDynLinker dflags
   modifyMVar_ v_PersistentLinkerState $ \pls -> do
     linkPackages' dflags new_pkgs pls
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5ce56f5016..167177703e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -163,6 +163,7 @@ data DynFlag
    | Opt_D_dump_occur_anal
    | Opt_D_dump_parsed
    | Opt_D_dump_rn
+   | Opt_D_dump_core_pipeline -- TODO FIXME: dump after simplifier stats
    | Opt_D_dump_simpl
    | Opt_D_dump_simpl_iterations
    | Opt_D_dump_simpl_phases
@@ -469,6 +470,10 @@ data DynFlags = DynFlags {
 
   hpcDir                :: String,      -- ^ Path to store the .mix files
 
+  -- Plugins
+  pluginModNames        :: [ModuleName],
+  pluginModNameOpts     :: [(ModuleName,String)],
+
   settings              :: Settings,
 
   --  For ghc -M
@@ -788,6 +793,9 @@ defaultDynFlags mySettings =
         hcSuf                   = phaseInputExt HCc,
         hiSuf                   = "hi",
 
+        pluginModNames          = [],
+        pluginModNameOpts       = [],
+
         outputFile              = Nothing,
         outputHi                = Nothing,
         dynLibLoader            = SystemDependent,
@@ -979,6 +987,16 @@ setHcSuf      f d = d{ hcSuf      = f}
 setOutputFile f d = d{ outputFile = f}
 setOutputHi   f d = d{ outputHi   = f}
 
+addPluginModuleName :: String -> DynFlags -> DynFlags
+addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
+
+addPluginModuleNameOption :: String -> DynFlags -> DynFlags
+addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }
+  where (m, rest) = break (== ':') optflag
+        option = case rest of
+          [] -> "" -- should probably signal an error
+          (_:plug_opt) -> plug_opt -- ignore the ':' from break
+
 parseDynLibLoaderMode f d =
  case splitAt 8 f of
    ("deploy", "")       -> d{ dynLibLoader = Deployable }
@@ -1319,6 +1337,7 @@ dynamic_flags = [
   , Flag "ddump-occur-anal"        (setDumpFlag Opt_D_dump_occur_anal)
   , Flag "ddump-parsed"            (setDumpFlag Opt_D_dump_parsed)
   , Flag "ddump-rn"                (setDumpFlag Opt_D_dump_rn)
+  , Flag "ddump-core-pipeline"     (setDumpFlag Opt_D_dump_core_pipeline)
   , Flag "ddump-simpl"             (setDumpFlag Opt_D_dump_simpl)
   , Flag "ddump-simpl-iterations"  (setDumpFlag Opt_D_dump_simpl_iterations)
   , Flag "ddump-simpl-phases"      (OptPrefix setDumpSimplPhases)
@@ -1377,7 +1396,11 @@ dynamic_flags = [
   , Flag "Wnot"   (NoArg (do { mapM_ unSetDynFlag minusWallOpts
                              ; deprecate "Use -w instead" }))
   , Flag "w"      (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
-
+        
+        ------ Plugin flags ------------------------------------------------
+  , Flag "fplugin"     (hasArg addPluginModuleName)
+  , Flag "fplugin-opt" (hasArg addPluginModuleNameOption)
+    
         ------ Optimisation flags ------------------------------------------
   , Flag "O"      (noArgM (setOptLevel 1))
   , Flag "Onot"   (noArgM (\dflags -> do deprecate "Use -O0 instead"
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
new file mode 100644
index 0000000000..5c7f6c7f0a
--- /dev/null
+++ b/compiler/main/DynamicLoading.hs
@@ -0,0 +1,150 @@
+-- | Dynamically lookup up values from modules and loading them.
+module DynamicLoading (
+#ifdef GHCI
+        -- * Force loading information
+        forceLoadModuleInterfaces,
+        forceLoadNameModuleInterface,
+        forceLoadTyCon,
+        
+        -- * Finding names
+        lookupRdrNameInModule,
+        
+        -- * Loading values
+        getValueSafely,
+        lessUnsafeCoerce
+#endif
+    ) where
+
+#ifdef GHCI
+import Linker           ( linkModule, getHValue, lessUnsafeCoerce )
+import OccName          ( occNameSpace )
+import Name             ( nameOccName )
+import SrcLoc           ( noSrcSpan )
+import Finder           ( findImportedModule, cannotFindModule )
+import DriverPhases     ( HscSource(HsSrcFile) )
+import TcRnDriver       ( getModuleExports )
+import TcRnMonad        ( initTc, initIfaceTcRn )
+import LoadIface        ( loadUserInterface )
+import RdrName          ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), 
+                          mkGlobalRdrEnv, lookupGRE_RdrName, gre_name, rdrNameSpace )
+import RnNames          ( gresFromAvails )
+import PrelNames        ( iNTERACTIVE )
+
+import HscTypes         ( HscEnv(..), FindResult(..), lookupTypeHscEnv )
+import TypeRep          ( TyThing(..), pprTyThingCategory )
+import Type             ( Type, eqType )
+import TyCon            ( TyCon )
+import Name             ( Name, nameModule_maybe )
+import Id               ( idType )
+import Module           ( Module, ModuleName )
+import Panic            ( GhcException(..), throwGhcException )
+import FastString
+import Outputable
+
+import Data.Maybe        ( mapMaybe )
+
+
+-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
+forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
+forceLoadModuleInterfaces hsc_env doc modules
+    = (initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ mapM_ (loadUserInterface False doc) modules) >> return ()
+
+-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
+forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
+forceLoadNameModuleInterface hsc_env reason name = do
+    let name_modules = mapMaybe nameModule_maybe [name]
+    forceLoadModuleInterfaces hsc_env reason name_modules
+
+-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
+--
+-- * The interface could not be loaded
+-- * The name is not that of a 'TyCon'
+-- * The name did not exist in the loaded module
+forceLoadTyCon :: HscEnv -> Name -> IO TyCon
+forceLoadTyCon hsc_env con_name = do
+    forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name
+    
+    mb_con_thing <- lookupTypeHscEnv hsc_env con_name
+    case mb_con_thing of
+        Nothing -> throwCmdLineErrorS $ missingTyThingError con_name
+        Just (ATyCon tycon) -> return tycon
+        Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing
+
+-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
+-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
+--
+-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
+--
+-- * If we could not load the names module
+-- * If the thing being loaded is not a value
+-- * If the Name does not exist in the module
+-- * If the link failed
+
+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
+    
+    -- 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
+        Nothing -> throwCmdLineErrorS $ missingTyThingError val_name
+        Just (AnId id) -> do
+            -- Check the value type in the interface against the type recovered from the type constructor
+            -- before finally casting the value to the type we assume corresponds to that constructor
+            if expected_type `eqType` idType id
+             then do
+                -- Link in the module that contains the value, if it has such a module
+                case nameModule_maybe val_name of
+                    Just mod -> do linkModule hsc_env mod
+                                   return ()
+                    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
+             else return Nothing
+        Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing
+
+-- | Finds the 'Name' corresponding to the given 'RdrName' in the context of the 'ModuleName'. Returns @Nothing@ if no
+-- such 'Name' could be found. Any other condition results in an exception:
+--
+-- * If the module could not be found
+-- * If we could not determine the imports of the module
+lookupRdrNameInModule :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
+lookupRdrNameInModule hsc_env mod_name rdr_name = do
+    -- First find the package the module resides in by searching exposed packages and home modules
+    found_module <- findImportedModule hsc_env mod_name Nothing
+    case found_module of
+        Found _ mod -> do
+            -- Find the exports of the module
+            (_, mb_avail_info) <- getModuleExports hsc_env mod
+            case mb_avail_info of
+                Just avail_info -> do
+                    -- Try and find the required name in the exports
+                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = noSrcSpan }
+                        provenance = Imported [ImpSpec decl_spec ImpAll]
+                        env = mkGlobalRdrEnv (gresFromAvails provenance avail_info)
+                    case [name | gre <- lookupGRE_RdrName rdr_name env, let name = gre_name gre, rdrNameSpace rdr_name == occNameSpace (nameOccName name)] of
+                        [name] -> return (Just name)
+                        []     -> return Nothing
+                        _      -> panic "lookupRdrNameInModule"
+                Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
+        err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err
+  where
+    dflags = hsc_dflags hsc_env
+
+
+wrongTyThingError :: Name -> TyThing -> SDoc
+wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
+
+missingTyThingError :: Name -> SDoc
+missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
+
+throwCmdLineErrorS :: SDoc -> IO a
+throwCmdLineErrorS = throwCmdLineError . showSDoc
+
+throwCmdLineError :: String -> IO a
+throwCmdLineError = throwGhcException . CmdLineError
+#endif
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
new file mode 100644
index 0000000000..0fc87f0fd0
--- /dev/null
+++ b/compiler/main/GhcPlugins.hs
@@ -0,0 +1,83 @@
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+
+-- | This module is not used by GHC itself.  Rather, it exports all of
+-- the functions and types you are likely to need when writing a
+-- plugin for GHC. So authors of plugins can probably get away simply
+-- with saying "import GhcPlugins".
+-- 
+-- Particularly interesting modules for plugin writers include
+-- "CoreSyn" and "CoreMonad".
+module GhcPlugins(
+        module CoreMonad,
+        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,
+        module CoreSyn, module Literal, module DataCon, 
+        module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,
+        module Rules, module Annotations,
+        module DynFlags, module Packages,
+        module Module, module Type, module TyCon, module Coercion, 
+        module TysWiredIn, module HscTypes, module BasicTypes,
+        module VarSet, module VarEnv, module NameSet, module NameEnv, 
+        module UniqSet, module UniqFM, module FiniteMap,
+        module Util, module Serialized, module SrcLoc, module Outputable, 
+        module UniqSupply, module Unique, module FastString, module FastTypes
+    ) where
+
+-- Plugin stuff itself
+import CoreMonad
+
+-- Variable naming
+import RdrName
+import OccName  hiding  ( varName {- conflicts with Var.varName -} )
+import Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )
+import Var
+import Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )
+import IdInfo
+
+-- Core
+import CoreSyn
+import Literal
+import DataCon
+import CoreUtils
+import MkCore
+import CoreFVs
+import CoreSubst
+
+-- Core "extras"
+import Rules
+import Annotations
+
+-- Pipeline-related stuff
+import DynFlags
+import Packages
+
+-- Important GHC types
+import Module
+import Type     hiding {- conflict with CoreSubst -}
+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )
+import Coercion hiding {- conflict with CoreSubst -}
+                ( substTy, extendTvSubst, substCo, substTyVarBndr, lookupTyVar )
+import TyCon
+import TysWiredIn
+import HscTypes
+import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )
+
+-- Collections and maps
+import VarSet
+import VarEnv
+import NameSet
+import NameEnv
+import UniqSet
+import UniqFM
+-- Conflicts with UniqFM:
+--import LazyUniqFM
+import FiniteMap
+
+-- Common utilities
+import Util
+import Serialized
+import SrcLoc
+import Outputable
+import UniqSupply
+import Unique           ( Unique, Uniquable(..) )
+import FastString
+import FastTypes
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index d226cbebdc..4fd23ee712 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -219,6 +219,9 @@ basicKnownKeyNames
 	-- The Either type
 	, eitherTyConName, leftDataConName, rightDataConName
 
+        -- Plugins
+        , pluginTyConName
+                                            
 	-- dotnet interop
 	, objectTyConName, marshalObjectName, unmarshalObjectName
 	, marshalStringName, unmarshalStringName, checkDotnetResName
@@ -371,6 +374,12 @@ mkBaseModule m = mkModule basePackageId (mkModuleNameFS m)
 mkBaseModule_ :: ModuleName -> Module
 mkBaseModule_ m = mkModule basePackageId m
 
+mkThisGhcModule :: FastString -> Module
+mkThisGhcModule m = mkModule thisGhcPackageId (mkModuleNameFS m)
+
+mkThisGhcModule_ :: ModuleName -> Module
+mkThisGhcModule_ m = mkModule thisGhcPackageId m
+
 mkMainModule :: FastString -> Module
 mkMainModule m = mkModule mainPackageId (mkModuleNameFS m)
 
@@ -973,6 +982,12 @@ marshalObjectName   = varQual  dOTNET (fsLit "marshalObject") marshalObjectIdKey
 marshalStringName   = varQual  dOTNET (fsLit "marshalString") marshalStringIdKey
 unmarshalStringName = varQual  dOTNET (fsLit "unmarshalString") unmarshalStringIdKey
 checkDotnetResName  = varQual  dOTNET (fsLit "checkResult")     checkDotnetResNameIdKey
+
+-- plugins
+cORE_MONAD :: Module
+cORE_MONAD = mkThisGhcModule (fsLit "CoreMonad")
+pluginTyConName :: Name
+pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey
 \end{code}
 
 %************************************************************************
@@ -1193,6 +1208,9 @@ csel1CoercionTyConKey                   = mkPreludeTyConUnique 99
 csel2CoercionTyConKey                   = mkPreludeTyConUnique 100
 cselRCoercionTyConKey                   = mkPreludeTyConUnique 101
 
+pluginTyConKey :: Unique
+pluginTyConKey                          = mkPreludeTyConUnique 102
+
 unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey,
     opaqueTyConKey :: Unique
 unknownTyConKey				= mkPreludeTyConUnique 129
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 6ddcff2b26..8e6ec5c870 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -8,10 +8,16 @@
 
 module CoreMonad (
     -- * Configuration of the core-to-core passes
-    CoreToDo(..),
+    CoreToDo(..), runWhen, runMaybe,
     SimplifierMode(..),
     FloatOutSwitches(..),
-    getCoreToDo, dumpSimplPhase,
+    dumpSimplPhase,
+
+    defaultGentleSimplToDo,
+    
+    -- * Plugins
+    PluginPass, Plugin(..), CommandLineOption, 
+    defaultPlugin, bindsOnlyPass,
 
     -- * Counting
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
@@ -198,6 +204,7 @@ showLintWarnings _ = True
 %************************************************************************
 
 \begin{code}
+
 data CoreToDo           -- These are diff core-to-core passes,
                         -- which may be invoked in any order,
                         -- as many times as you like.
@@ -205,7 +212,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   = CoreDoSimplify      -- The core-to-core simplifier.
         Int                    -- Max iterations
         SimplifierMode
-
+  | CoreDoPluginPass String PluginPass
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
@@ -229,8 +236,12 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreTidy
   | CorePrep
 
+\end{code}
+
+\begin{code}
 coreDumpFlag :: CoreToDo -> Maybe DynFlag
 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
 coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
@@ -255,6 +266,7 @@ instance Outputable CoreToDo where
   ppr (CoreDoSimplify n md)  = ptext (sLit "Simplifier")
                                <+> ppr md
                                  <+> ptext (sLit "max-iterations=") <> int n
+  ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
@@ -327,200 +339,17 @@ pprFloatOutSwitches sw
      [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
      , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
      , ptext (sLit "PAPs =")   <+> ppr (floatOutPartialApplications sw) ])
-\end{code}
-
 
-%************************************************************************
-%*									*
-           Generating the main optimisation pipeline
-%*									*
-%************************************************************************
-
-\begin{code}
-getCoreToDo :: DynFlags -> [CoreToDo]
-getCoreToDo dflags
-  = core_todo
-  where
-    opt_level     = optLevel           dflags
-    phases        = simplPhases        dflags
-    max_iter      = maxSimplIterations dflags
-    rule_check    = ruleCheck          dflags
-    strictness    = dopt Opt_Strictness   		  dflags
-    full_laziness = dopt Opt_FullLaziness 		  dflags
-    do_specialise = dopt Opt_Specialise   		  dflags
-    do_float_in   = dopt Opt_FloatIn      		  dflags          
-    cse           = dopt Opt_CSE                          dflags
-    spec_constr   = dopt Opt_SpecConstr                   dflags
-    liberate_case = dopt Opt_LiberateCase                 dflags
-    static_args   = dopt Opt_StaticArgumentTransformation dflags
-    rules_on      = dopt Opt_EnableRewriteRules           dflags
-    eta_expand_on = dopt Opt_DoLambdaEtaExpansion         dflags
-
-    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
-
-    maybe_strictness_before phase
-      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
-
-    base_mode = SimplMode { sm_phase      = panic "base_mode"
-                          , sm_names      = []
-                          , sm_rules      = rules_on
-                          , sm_eta_expand = eta_expand_on
-                          , sm_inline     = True
-                          , sm_case_case  = True }
-
-    simpl_phase phase names iter
-      = CoreDoPasses
-      $   [ maybe_strictness_before phase
-          , CoreDoSimplify iter
-                (base_mode { sm_phase = Phase phase
-                           , sm_names = names })
-
-          , maybe_rule_check (Phase phase) ]
-
-          -- Vectorisation can introduce a fair few common sub expressions involving 
-          --  DPH primitives. For example, see the Reverse test from dph-examples.
-          --  We need to eliminate these common sub expressions before their definitions
-          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings, 
-          --  so we also run simpl_gently to inline them.
-      ++  (if dopt Opt_Vectorise dflags && phase == 3
-	    then [CoreCSE, simpl_gently]
-	    else [])
-
-    vectorisation
-      = runWhen (dopt Opt_Vectorise dflags) $
-          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
-
-                -- By default, we have 2 phases before phase 0.
-
-                -- Want to run with inline phase 2 after the specialiser to give
-                -- maximum chance for fusion to work before we inline build/augment
-                -- in phase 1.  This made a difference in 'ansi' where an
-                -- overloaded function wasn't inlined till too late.
-
-                -- Need phase 1 so that build/augment get
-                -- inlined.  I found that spectral/hartel/genfft lost some useful
-                -- strictness in the function sumcode' if augment is not inlined
-                -- before strictness analysis runs
-    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
-                                | phase <- [phases, phases-1 .. 1] ]
-
-
-        -- initial simplify: mk specialiser happy: minimum effort please
-    simpl_gently = CoreDoSimplify max_iter
-                       (base_mode { sm_phase = InitialPhase
+-- | A reasonably gentle simplification pass for doing "obvious" simplifications
+defaultGentleSimplToDo :: CoreToDo
+defaultGentleSimplToDo = CoreDoSimplify 4 -- 4 is the default maxSimpleIterations
+                       (SimplMode { sm_phase = InitialPhase
                                   , sm_names = ["Gentle"]
-                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
+                                  , sm_rules = True     -- Note [RULEs enabled in SimplGently]
                                   , sm_inline = False
-                                  , sm_case_case = False })
-                          -- Don't do case-of-case transformations.
-                          -- This makes full laziness work better
-
-    core_todo =
-     if opt_level == 0 then
-       [vectorisation,
-        simpl_phase 0 ["final"] max_iter]
-     else {- opt_level >= 1 -} [
-
-    -- We want to do the static argument transform before full laziness as it
-    -- may expose extra opportunities to float things outwards. However, to fix
-    -- up the output of the transformation we need at do at least one simplify
-    -- after this before anything else
-        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
-
-        -- We run vectorisation here for now, but we might also try to run
-        -- it later
-        vectorisation,
-
-        -- initial simplify: mk specialiser happy: minimum effort please
-        simpl_gently,
-
-        -- Specialisation is best done before full laziness
-        -- so that overloaded functions have all their dictionary lambdas manifest
-        runWhen do_specialise CoreDoSpecialising,
-
-        runWhen full_laziness $
-           CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas   = Just 0,
-                                 floatOutConstants = True,
-                                 floatOutPartialApplications = False },
-      		-- Was: gentleFloatOutSwitches	
-                --
-		-- I have no idea why, but not floating constants to
-		-- top level is very bad in some cases.
-                --
-		-- Notably: p_ident in spectral/rewrite
-		-- 	    Changing from "gentle" to "constantsOnly"
-		-- 	    improved rewrite's allocation by 19%, and
-		-- 	    made 0.0% difference to any other nofib
-		-- 	    benchmark
-                --
-                -- Not doing floatOutPartialApplications yet, we'll do
-                -- that later on when we've had a chance to get more
-                -- accurate arity information.  In fact it makes no
-                -- difference at all to performance if we do it here,
-                -- but maybe we save some unnecessary to-and-fro in
-                -- the simplifier.
-
-        runWhen do_float_in CoreDoFloatInwards,
-
-        simpl_phases,
-
-                -- Phase 0: allow all Ids to be inlined now
-                -- This gets foldr inlined before strictness analysis
-
-                -- At least 3 iterations because otherwise we land up with
-                -- huge dead expressions because of an infelicity in the
-                -- simpifier.
-                --      let k = BIG in foldr k z xs
-                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
-                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
-                -- Don't stop now!
-        simpl_phase 0 ["main"] (max max_iter 3),
-
-        runWhen strictness (CoreDoPasses [
-                CoreDoStrictness,
-                CoreDoWorkerWrapper,
-                CoreDoGlomBinds,
-                simpl_phase 0 ["post-worker-wrapper"] max_iter
-                ]),
-
-        runWhen full_laziness $
-           CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas   = floatLamArgs dflags,
-                                 floatOutConstants = True,
-                                 floatOutPartialApplications = True },
-                -- nofib/spectral/hartel/wang doubles in speed if you
-                -- do full laziness late in the day.  It only happens
-                -- after fusion and other stuff, so the early pass doesn't
-                -- catch it.  For the record, the redex is
-                --        f_el22 (f_el21 r_midblock)
-
-
-        runWhen cse CoreCSE,
-                -- We want CSE to follow the final full-laziness pass, because it may
-                -- succeed in commoning up things floated out by full laziness.
-                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
-
-        runWhen do_float_in CoreDoFloatInwards,
-
-        maybe_rule_check (Phase 0),
-
-                -- Case-liberation for -O2.  This should be after
-                -- strictness analysis and the simplification which follows it.
-        runWhen liberate_case (CoreDoPasses [
-            CoreLiberateCase,
-            simpl_phase 0 ["post-liberate-case"] max_iter
-            ]),         -- Run the simplifier after LiberateCase to vastly
-                        -- reduce the possiblility of shadowing
-                        -- Reason: see Note [Shadowing] in SpecConstr.lhs
-
-        runWhen spec_constr CoreDoSpecConstr,
-
-        maybe_rule_check (Phase 0),
-
-        -- Final clean-up simplification:
-        simpl_phase 0 ["final"] max_iter
-     ]
+                                  , sm_eta_expand = False
+                                  , sm_case_case = False 
+                                  })
 
 -- The core-to-core pass ordering is derived from the DynFlags:
 runWhen :: Bool -> CoreToDo -> CoreToDo
@@ -531,6 +360,7 @@ runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
 runMaybe (Just x) f = f x
 runMaybe Nothing  _ = CoreDoNothing
 
+
 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
 dumpSimplPhase dflags mode
    | Just spec_string <- shouldDumpSimplPhase dflags
@@ -579,6 +409,47 @@ to switch off those rules until after floating.
 
 %************************************************************************
 %*									*
+             Types for Plugins
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
+type CommandLineOption = String
+
+-- | 'Plugin' is the core compiler plugin data type. Try to avoid
+-- constructing one of these directly, and just modify some fields of
+-- 'defaultPlugin' instead: this is to try and preserve source-code
+-- compatability when we add fields to this.
+--
+-- Nonetheless, this API is preliminary and highly likely to change in the future.
+data Plugin = Plugin { 
+        installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+                -- ^ Modify the Core pipeline that will be used for compilation. 
+                -- This is called as the Core pipeline is built for every module
+                --  being compiled, and plugins get the opportunity to modify 
+                -- the pipeline in a nondeterministic order.
+     }
+
+-- | Default plugin: does nothing at all! For compatability reasons you should base all your
+-- plugin definitions on this default value.
+defaultPlugin :: Plugin
+defaultPlugin = Plugin {
+        installCoreToDos = const return
+    }
+
+-- | A description of the plugin pass itself
+type PluginPass = ModGuts -> CoreM ModGuts
+
+bindsOnlyPass :: ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
+bindsOnlyPass pass guts
+  = do { binds' <- pass (mg_binds guts)
+       ; return (guts { mg_binds = binds' }) }
+\end{code}
+
+
+%************************************************************************
+%*									*
              Counting and logging
 %*									*
 %************************************************************************
@@ -955,7 +826,6 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
 %************************************************************************
 
 \begin{code}
-
 getHscEnv :: CoreM HscEnv
 getHscEnv = read cr_hsc_env
 
@@ -979,7 +849,6 @@ getOrigNameCache :: CoreM OrigNameCache
 getOrigNameCache = do
     nameCacheRef <- fmap hsc_NC getHscEnv
     liftIO $ fmap nsNames $ readIORef nameCacheRef
-
 \end{code}
 
 
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 59aba4b030..34ffacb208 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -8,7 +8,7 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
-import DynFlags		( DynFlags, DynFlag(..), dopt )
+import DynFlags
 import CoreSyn
 import CoreSubst
 import HscTypes
@@ -29,7 +29,7 @@ import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FamInstEnv
 import Id
-import BasicTypes
+import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )
 import VarSet
 import VarEnv
 import LiberateCase	( liberateCase )
@@ -45,6 +45,16 @@ import Util
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import Outputable
 import Control.Monad
+
+#ifdef GHCI
+import Type		( mkTyConTy )
+import RdrName		( mkRdrQual )
+import OccName		( mkVarOcc )
+import PrelNames	( pluginTyConName )
+import DynamicLoading   ( forceLoadTyCon, lookupRdrNameInModule, getValueSafely )
+import Module		( ModuleName )
+import Panic
+#endif
 \end{code}
 
 %************************************************************************
@@ -57,9 +67,18 @@ import Control.Monad
 core2core :: HscEnv -> ModGuts -> IO ModGuts
 core2core hsc_env guts 
   = do { us <- mkSplitUniqSupply 's'
-       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ 
-                           doCorePasses (getCoreToDo dflags) guts
-
+       -- make sure all plugins are loaded 
+
+       ; let builtin_passes = getCoreToDo dflags
+       ; 
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
+                        do { all_passes <- addPluginPasses dflags builtin_passes
+                           ; runCorePasses all_passes guts }
+
+{--                           
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline
+             "Plugin information" "" -- TODO FIXME: dump plugin info
+--}
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
              "Grand total simplifier statistics"
              (pprSimplCount stats)
@@ -75,16 +94,262 @@ core2core hsc_env guts
     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
+\end{code}
+
+
+%************************************************************************
+%*									*
+           Generating the main optimisation pipeline
+%*									*
+%************************************************************************
+
+\begin{code}
+getCoreToDo :: DynFlags -> [CoreToDo]
+getCoreToDo dflags
+  = core_todo
+  where
+    opt_level     = optLevel           dflags
+    phases        = simplPhases        dflags
+    max_iter      = maxSimplIterations dflags
+    rule_check    = ruleCheck          dflags
+    strictness    = dopt Opt_Strictness   		  dflags
+    full_laziness = dopt Opt_FullLaziness 		  dflags
+    do_specialise = dopt Opt_Specialise   		  dflags
+    do_float_in   = dopt Opt_FloatIn      		  dflags          
+    cse           = dopt Opt_CSE                          dflags
+    spec_constr   = dopt Opt_SpecConstr                   dflags
+    liberate_case = dopt Opt_LiberateCase                 dflags
+    static_args   = dopt Opt_StaticArgumentTransformation dflags
+    rules_on      = dopt Opt_EnableRewriteRules           dflags
+    eta_expand_on = dopt Opt_DoLambdaEtaExpansion         dflags
+
+    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
+
+    maybe_strictness_before phase
+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
+
+    base_mode = SimplMode { sm_phase      = panic "base_mode"
+                          , sm_names      = []
+                          , sm_rules      = rules_on
+                          , sm_eta_expand = eta_expand_on
+                          , sm_inline     = True
+                          , sm_case_case  = True }
+
+    simpl_phase phase names iter
+      = CoreDoPasses
+      $   [ maybe_strictness_before phase
+          , CoreDoSimplify iter
+                (base_mode { sm_phase = Phase phase
+                           , sm_names = names })
+
+          , maybe_rule_check (Phase phase) ]
+
+          -- Vectorisation can introduce a fair few common sub expressions involving 
+          --  DPH primitives. For example, see the Reverse test from dph-examples.
+          --  We need to eliminate these common sub expressions before their definitions
+          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings, 
+          --  so we also run simpl_gently to inline them.
+      ++  (if dopt Opt_Vectorise dflags && phase == 3
+	    then [CoreCSE, simpl_gently]
+	    else [])
+
+    vectorisation
+      = runWhen (dopt Opt_Vectorise dflags) $
+          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
+
+                -- By default, we have 2 phases before phase 0.
+
+                -- Want to run with inline phase 2 after the specialiser to give
+                -- maximum chance for fusion to work before we inline build/augment
+                -- in phase 1.  This made a difference in 'ansi' where an
+                -- overloaded function wasn't inlined till too late.
+
+                -- Need phase 1 so that build/augment get
+                -- inlined.  I found that spectral/hartel/genfft lost some useful
+                -- strictness in the function sumcode' if augment is not inlined
+                -- before strictness analysis runs
+    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
+                                | phase <- [phases, phases-1 .. 1] ]
+
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+    simpl_gently = CoreDoSimplify max_iter
+                       (base_mode { sm_phase = InitialPhase
+                                  , sm_names = ["Gentle"]
+                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
+                                  , sm_inline = False
+                                  , sm_case_case = False })
+                          -- Don't do case-of-case transformations.
+                          -- This makes full laziness work better
+
+    core_todo =
+     if opt_level == 0 then
+       [vectorisation,
+        simpl_phase 0 ["final"] max_iter]
+     else {- opt_level >= 1 -} [
+
+    -- We want to do the static argument transform before full laziness as it
+    -- may expose extra opportunities to float things outwards. However, to fix
+    -- up the output of the transformation we need at do at least one simplify
+    -- after this before anything else
+        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
+
+        -- We run vectorisation here for now, but we might also try to run
+        -- it later
+        vectorisation,
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+        simpl_gently,
+
+        -- Specialisation is best done before full laziness
+        -- so that overloaded functions have all their dictionary lambdas manifest
+        runWhen do_specialise CoreDoSpecialising,
+
+        runWhen full_laziness $
+           CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas   = Just 0,
+                                 floatOutConstants = True,
+                                 floatOutPartialApplications = False },
+      		-- Was: gentleFloatOutSwitches	
+                --
+		-- I have no idea why, but not floating constants to
+		-- top level is very bad in some cases.
+                --
+		-- Notably: p_ident in spectral/rewrite
+		-- 	    Changing from "gentle" to "constantsOnly"
+		-- 	    improved rewrite's allocation by 19%, and
+		-- 	    made 0.0% difference to any other nofib
+		-- 	    benchmark
+                --
+                -- Not doing floatOutPartialApplications yet, we'll do
+                -- that later on when we've had a chance to get more
+                -- accurate arity information.  In fact it makes no
+                -- difference at all to performance if we do it here,
+                -- but maybe we save some unnecessary to-and-fro in
+                -- the simplifier.
+
+        runWhen do_float_in CoreDoFloatInwards,
+
+        simpl_phases,
+
+                -- Phase 0: allow all Ids to be inlined now
+                -- This gets foldr inlined before strictness analysis
+
+                -- At least 3 iterations because otherwise we land up with
+                -- huge dead expressions because of an infelicity in the
+                -- simpifier.
+                --      let k = BIG in foldr k z xs
+                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
+                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
+                -- Don't stop now!
+        simpl_phase 0 ["main"] (max max_iter 3),
+
+        runWhen strictness (CoreDoPasses [
+                CoreDoStrictness,
+                CoreDoWorkerWrapper,
+                CoreDoGlomBinds,
+                simpl_phase 0 ["post-worker-wrapper"] max_iter
+                ]),
+
+        runWhen full_laziness $
+           CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas   = floatLamArgs dflags,
+                                 floatOutConstants = True,
+                                 floatOutPartialApplications = True },
+                -- nofib/spectral/hartel/wang doubles in speed if you
+                -- do full laziness late in the day.  It only happens
+                -- after fusion and other stuff, so the early pass doesn't
+                -- catch it.  For the record, the redex is
+                --        f_el22 (f_el21 r_midblock)
+
+
+        runWhen cse CoreCSE,
+                -- We want CSE to follow the final full-laziness pass, because it may
+                -- succeed in commoning up things floated out by full laziness.
+                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+        runWhen do_float_in CoreDoFloatInwards,
+
+        maybe_rule_check (Phase 0),
+
+                -- Case-liberation for -O2.  This should be after
+                -- strictness analysis and the simplification which follows it.
+        runWhen liberate_case (CoreDoPasses [
+            CoreLiberateCase,
+            simpl_phase 0 ["post-liberate-case"] max_iter
+            ]),         -- Run the simplifier after LiberateCase to vastly
+                        -- reduce the possiblility of shadowing
+                        -- Reason: see Note [Shadowing] in SpecConstr.lhs
+
+        runWhen spec_constr CoreDoSpecConstr,
+
+        maybe_rule_check (Phase 0),
+
+        -- Final clean-up simplification:
+        simpl_phase 0 ["final"] max_iter
+     ]
+\end{code}
 
 
-type CorePass = CoreToDo
+Loading plugins
 
-doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
-doCorePasses passes guts 
+\begin{code}
+addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo]
+#ifndef GHCI
+addPluginPasses _ builtin_passes = return builtin_passes
+#else
+addPluginPasses dflags builtin_passes
+  = do { hsc_env <- getHscEnv 
+       ; named_plugins <- liftIO (loadPlugins hsc_env)
+       ; foldM query_plug builtin_passes named_plugins }
+  where
+    query_plug todos (mod_nm, plug) 
+       = installCoreToDos plug options todos
+       where 
+         options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
+                            , opt_mod_nm == mod_nm ]
+
+loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)]
+loadPlugins hsc_env
+  = do { let to_load = pluginModNames (hsc_dflags hsc_env)
+       ; plugins <- mapM (loadPlugin hsc_env) to_load
+       ; return $ to_load `zip` plugins }
+
+loadPlugin :: HscEnv -> ModuleName -> IO Plugin
+loadPlugin hsc_env mod_name
+  = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
+       ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name
+       ; case mb_name of {
+            Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep 
+                          [ ptext (sLit "The module"), ppr mod_name
+                          , ptext (sLit "did not export the plugin name")
+                          , ppr plugin_rdr_name ]) ;
+            Just name -> 
+
+     do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
+        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
+        ; case mb_plugin of
+            Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep
+                          [ ptext (sLit "The value"), ppr name 
+                          , ptext (sLit "did not have the type")
+                          , ppr pluginTyConName, ptext (sLit "as required")])
+            Just plugin -> return plugin } } }
+#endif
+\end{code}
+
+%************************************************************************
+%*									*
+                  The CoreToDo interpreter
+%*									*
+%************************************************************************
+
+\begin{code}
+runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
+runCorePasses passes guts 
   = foldM do_pass guts passes
   where
     do_pass guts CoreDoNothing = return guts
-    do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
+    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
     do_pass guts pass 
        = do { dflags <- getDynFlags
        	    ; liftIO $ showPass dflags pass
@@ -92,7 +357,7 @@ doCorePasses passes guts
        	    ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
        	    ; return guts' }
 
-doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
+doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
 doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                        simplifyPgm pass
 
@@ -128,9 +393,14 @@ doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
 
 doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
 doCorePass CoreDoPrintCore              = observe   printCore
-doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
 doCorePass CoreDoNothing                = return
-doCorePass (CoreDoPasses passes)        = doCorePasses passes
+doCorePass (CoreDoPasses passes)        = runCorePasses passes
+
+#ifdef GHCI
+doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
+#endif
+
 doCorePass pass = pprPanic "doCorePass" (ppr pass)
 \end{code}
 
@@ -144,8 +414,8 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass)
 printCore :: a -> [CoreBind] -> IO ()
 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
 
-ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
-ruleCheck current_phase pat guts = do
+ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
+ruleCheckPass current_phase pat guts = do
     rb <- getRuleBase
     dflags <- getDynFlags
     liftIO $ Err.showPass dflags "RuleCheck"