Ticket #3843: ghc_plugins_support_2010_11_19.dpatch

1 patch for repository /home/a/src/ghc-head:

Fri Nov 19 20:37:47 CST 2010  austin seipp <as@hacks.yi.org>
  * Implement support for writing and loading plugins for GHC
  Based on Max Bolingbroke's original patch for implementing plugin support in GHC,
  which can be gotten from here: http://hackage.haskell.org/trac/ghc/ticket/3843
  
  A little bit of the linker interface changed and the simplifier interface changed
  inbetween now and then. This patch brings most of the work Max did up to date although
  there may be a few loose ends. The interface for plugins that rewrite core hasn't changed
  (that is, most people will be writing passes of type [CoreBind] -> CoreM [CoreBind])
  
  Plugins are registered the same way as they were previously: plugin modules provide an installation
  function of type [CoreToDo] -> CoreM [CoreToDo]
  
  Changes:
   * -plg and -P flags replaced by -fplugin and -fplugin-arg (consistent with what GCC uses)
  


New patches:

[Implement support for writing and loading plugins for GHC
austin seipp <as@hacks.yi.org>**20101120023747
 Ignore-this: c396164d4bab5305df35df654e27fb55
 Based on Max Bolingbroke's original patch for implementing plugin support in GHC,
 which can be gotten from here: http://hackage.haskell.org/trac/ghc/ticket/3843
 
 A little bit of the linker interface changed and the simplifier interface changed
 inbetween now and then. This patch brings most of the work Max did up to date although
 there may be a few loose ends. The interface for plugins that rewrite core hasn't changed
 (that is, most people will be writing passes of type [CoreBind] -> CoreM [CoreBind])
 
 Plugins are registered the same way as they were previously: plugin modules provide an installation
 function of type [CoreToDo] -> CoreM [CoreToDo]
 
 Changes:
  * -plg and -P flags replaced by -fplugin and -fplugin-arg (consistent with what GCC uses)
 
] {
hunk ./compiler/basicTypes/Module.lhs 42
         dphSeqPackageId,
         dphParPackageId,
        mainPackageId,
-
+        thisGhcPackageId,
+        
        -- * The Module type
        Module,
        modulePackageId, moduleName,
hunk ./compiler/basicTypes/Module.lhs 351
 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")
hunk ./compiler/basicTypes/Module.lhs 359
 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
hunk ./compiler/ghc.cabal.in 325
         ErrUtils
         Finder
         GHC
+        Plugins
+        GHCPlugins
+        LoadPlugins
+        DynamicLoading
         HeaderInfo
         HscMain
         HscStats
hunk ./compiler/ghci/Linker.lhs 18
                linkExpr, unload, withExtendedLinkEnv,
                 extendLinkEnv, deleteFromLinkEnv,
                 extendLoadedPkgs, 
-               linkPackages,initDynLinker,
-                dataConInfoPtrToName
+               linkPackages,initDynLinker,linkModule,
+                dataConInfoPtrToName, lessUnsafeCoerce
        ) where
 
 #include "HsVersions.h"
hunk ./compiler/ghci/Linker.lhs 58
 import FastString
 import Config
 
+import GHC.Exts (unsafeCoerce#)
+
 -- Standard libraries
 import Control.Monad
 
hunk ./compiler/ghci/Linker.lhs 262
 -- 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]
hunk ./compiler/ghci/Linker.lhs 276
                  -> 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
hunk ./compiler/ghci/Linker.lhs 696
            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 "")
+      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}
 
 %************************************************************************
 %*                                                                     *
hunk ./compiler/ghci/Linker.lhs 1029
 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
 
hunk ./compiler/main/DynFlags.hs 139
    | 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
hunk ./compiler/main/DynFlags.hs 446
 
   hpcDir                :: String,      -- ^ Path to store the .mix files
 
+  -- Plugins
+  pluginModNames        :: [ModuleName],
+  pluginModNameOpts     :: [(ModuleName,String)],
+
   -- options for particular phases
   opt_L                 :: [String],
   opt_P                 :: [String],
hunk ./compiler/main/DynFlags.hs 686
         hcSuf                   = phaseInputExt HCc,
         hiSuf                   = "hi",
 
+        pluginModNames          = [],
+        pluginModNameOpts       = [],
+
         outputFile              = Nothing,
         outputHi                = Nothing,
         dynLibLoader            = SystemDependent,
hunk ./compiler/main/DynFlags.hs 899
 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 }
hunk ./compiler/main/DynFlags.hs 1252
   , 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)
hunk ./compiler/main/DynFlags.hs 1309
   , 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"      (noArg (setOptLevel 1))
   , Flag "Onot"   (noArgDF (setOptLevel 0) "Use -O0 instead")
addfile ./compiler/main/DynamicLoading.hs
hunk ./compiler/main/DynamicLoading.hs 1
+-- | 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, coreEqType )
+import TyCon            ( TyCon )
+import Name             ( Name, nameModule_maybe )
+import Id               ( idType )
+import Module           ( Module, ModuleName )
+import Panic            ( GhcException(..), throwGhcException, panic )
+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 `coreEqType` 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
addfile ./compiler/main/GHCPlugins.hs
hunk ./compiler/main/GHCPlugins.hs 1
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+
+-- | Re-exports all of the functions and types you are likely to need when 
+-- writing a plugin for GHC. Particularly interesting modules for plugin writers
+-- include "Plugins", "CoreSyn" and "CoreMonad".
+module GHCPlugins(
+#ifdef GHCI
+        -- This must be under #ifdef GHCI since it exports nothing when GHCI is disabled and hence generates a warning
+        module Plugins,
+#endif
+        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
+#ifdef GHCI
+-- As with the export
+import Plugins
+#endif
+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 ( substTy, extendTvSubst, extendTvSubstList, isInScope {- conflict with CoreSubst -} )
+import TyCon
+import Coercion
+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
addfile ./compiler/main/LoadPlugins.lhs
hunk ./compiler/main/LoadPlugins.lhs 1
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-2008
+%
+\begin{code}
+
+-- | Code relating purely to the administration of plugins, i.e. no code that would actually
+-- be useful to plugins!
+module LoadPlugins (
+#ifdef GHCI
+        loadPlugins
+#endif
+    ) where
+
+#ifdef GHCI
+import DynamicLoading
+
+import OccName          ( mkVarOcc )
+import RdrName          ( mkRdrQual )
+
+import DynFlags         ( DynFlags, pluginModNames )
+import HscTypes         ( HscEnv(..) )
+import Type             ( mkTyConTy )
+import PrelNames        ( pluginTyConName )
+import Module           ( ModuleName )
+import Panic            ( GhcException(..), throwGhcException )
+import FastString
+import Outputable
+
+import Plugins
+\end{code}
+
+\begin{code}
+loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)]
+loadPlugins hsc_env = do
+    let to_load = pluginModNames dflags
+    plugins <- mapM (loadPlugin hsc_env) to_load
+    return $ to_load `zip` plugins
+  where dflags = hsc_dflags hsc_env
+
+loadPlugin :: HscEnv -> ModuleName -> IO Plugin
+loadPlugin hsc_env mod_name = do
+    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
+  where plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
+
+#endif
+\end{code}
addfile ./compiler/main/Plugins.lhs
hunk ./compiler/main/Plugins.lhs 1
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-2008
+%
+
+\section[Plugins]{Plugins for GHC}
+\begin{code}
+
+-- | Contains code and definitions that are used by both the compiler and the plugins themselves. All the
+-- functions likely to be useful for plugins are exported from 'GHCPlugins'.
+module Plugins (
+#ifdef GHCI
+        -- * Plugin data types
+       Plugin(..), CommandLineOption, defaultPlugin,
+       PluginPass(..),
+#endif
+  ) where
+
+#ifdef GHCI
+import HscTypes
+import CoreSyn          ( CoreBind )
+import CoreMonad
+\end{code}
+
+\subsection{Essential data type}
+
+\begin{code}
+-- | The kinds of core pass a plugin can install
+data PluginPass = BindsToBindsPluginPass ([CoreBind] -> CoreM [CoreBind]) -- ^ Simple pass just mutating the Core bindings
+                | ModGutsToBindsPluginPass (ModGuts -> CoreM [CoreBind])  -- ^ Pass that has access to the information from a 'ModGuts' 
+                                                                          -- from which to generate it's bindings
+                | ModGutsToModGutsPluginPass (ModGuts -> CoreM ModGuts)   -- ^ Pass that can change everything about the module being compiled.
+                                                                          -- Do not change any field other than 'HscTypes.mg_binds' unless you 
+                                                                          -- know what you're doing! Plugins using this are unlikely to be stable 
+                                                                          -- between GHC versions
+
+-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
+type CommandLineOption = String
+
+-- | 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
+}
+#endif
+\end{code}
addfile ./compiler/main/Plugins.lhs-boot
hunk ./compiler/main/Plugins.lhs-boot 1
+\begin{code}
+module Plugins where
+
+data Plugin
+data PluginPass
+\end{code}
hunk ./compiler/prelude/PrelNames.lhs 220
        -- The Either type
        , eitherTyConName, leftDataConName, rightDataConName
 
+        -- Plugins
+        , pluginTyConName
+                                            
        -- dotnet interop
        , objectTyConName, marshalObjectName, unmarshalObjectName
        , marshalStringName, unmarshalStringName, checkDotnetResName
hunk ./compiler/prelude/PrelNames.lhs 254
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
     gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
     dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE,
-    gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module
+    gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE, pLUGINS :: Module
 
 gHC_PRIM       = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
hunk ./compiler/prelude/PrelNames.lhs 309
 rANDOM         = mkBaseModule (fsLit "System.Random")
 gHC_EXTS       = mkBaseModule (fsLit "GHC.Exts")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
+pLUGINS         = mkThisGhcModule (fsLit "Plugins")
 
 mAIN, rOOT_MAIN :: Module
 mAIN           = mkMainModule_ mAIN_NAME
hunk ./compiler/prelude/PrelNames.lhs 338
 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)
 
hunk ./compiler/prelude/PrelNames.lhs 848
 marshalStringName   = varQual  dOTNET (fsLit "marshalString") marshalStringIdKey
 unmarshalStringName = varQual  dOTNET (fsLit "unmarshalString") unmarshalStringIdKey
 checkDotnetResName  = varQual  dOTNET (fsLit "checkResult")     checkDotnetResNameIdKey
+
+-- plugins
+pluginTyConName :: Name
+pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
+
+
 \end{code}
 
 %************************************************************************
hunk ./compiler/prelude/PrelNames.lhs 1082
 stringTyConKey :: Unique
 stringTyConKey                         = mkPreludeTyConUnique 134
 
+pluginTyConKey :: Unique
+pluginTyConKey                          = mkPreludeTyConUnique 135
+
 ---------------- Template Haskell -------------------
 --     USES TyConUniques 100-129
 -----------------------------------------------------
hunk ./compiler/simplCore/CoreMonad.lhs 16
     FloatOutSwitches(..),
     getCoreToDo, dumpSimplPhase,
 
+    defaultGentleSimplToDo,
+    
     -- * Counting
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
     pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
hunk ./compiler/simplCore/CoreMonad.lhs 99
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
 import qualified Language.Haskell.TH as TH
+
+import {-# SOURCE #-} Plugins 
 #endif
 \end{code}
 
hunk ./compiler/simplCore/CoreMonad.lhs 205
 %************************************************************************
 
 \begin{code}
+
 data CoreToDo           -- These are diff core-to-core passes,
                         -- which may be invoked in any order,
                         -- as many times as you like.
hunk ./compiler/simplCore/CoreMonad.lhs 213
   = CoreDoSimplify      -- The core-to-core simplifier.
         Int                    -- Max iterations
         SimplifierMode
-
+#ifdef GHCI
+  | CoreDoPluginPass String PluginPass
+#endif
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
hunk ./compiler/simplCore/CoreMonad.lhs 241
 
 coreDumpFlag :: CoreToDo -> Maybe DynFlag
 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
+#ifdef GHCI
+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
+#endif
 coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
hunk ./compiler/simplCore/CoreMonad.lhs 268
   ppr (CoreDoSimplify n md)  = ptext (sLit "Simplifier")
                                <+> ppr md
                                  <+> ptext (sLit "max-iterations=") <> int n
+#ifdef GHCI  
+  ppr (CoreDoPluginPass desc _) = ptext (sLit "Core plugin: ") <+> ptext (sLit desc)
+#endif
   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
hunk ./compiler/simplCore/CoreMonad.lhs 531
         simpl_phase 0 ["final"] max_iter
      ]
 
+-- | 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 = True     -- Note [RULEs enabled in SimplGently]
+                                  , sm_inline = False
+                                  , sm_eta_expand = False
+                                  , sm_case_case = False 
+                                  })
+
 -- The core-to-core pass ordering is derived from the DynFlags:
 runWhen :: Bool -> CoreToDo -> CoreToDo
 runWhen True  do_this = do_this
hunk ./compiler/simplCore/CoreMonad.lhs 551
 runMaybe (Just x) f = f x
 runMaybe Nothing  _ = CoreDoNothing
 
+
 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
 dumpSimplPhase dflags mode
    | Just spec_string <- shouldDumpSimplPhase dflags
hunk ./compiler/simplCore/SimplCore.lhs 11
 
 #include "HsVersions.h"
 
-import DynFlags                ( DynFlags, DynFlag(..), dopt )
+import DynFlags                ( DynFlags, DynFlag(..), dopt)
 import CoreSyn
 import CoreSubst
 import HscTypes
hunk ./compiler/simplCore/SimplCore.lhs 48
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import Outputable
 import Control.Monad
+
+#ifdef GHCI
+import Plugins
+import LoadPlugins      ( loadPlugins )
+#endif
+
 \end{code}
 
 %************************************************************************
hunk ./compiler/simplCore/SimplCore.lhs 66
 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 
+#ifdef GHCI
+      ; named_plugins <- loadPlugins hsc_env
+#endif
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
+         (do { let builtin_passes = getCoreToDo dflags
+#ifdef GHCI
+             ; let queryPlugin todos (mod_nm,plug) = installCoreToDos plug options todos
+                     where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
+                                              , opt_mod_nm == mod_nm ]
+             ; all_passes <- foldM queryPlugin builtin_passes named_plugins
+#else
+             ; let all_passes = builtin_passes
+#endif
+             ; doCorePasses all_passes guts })
 
hunk ./compiler/simplCore/SimplCore.lhs 82
+{--                           
+       ; 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)
hunk ./compiler/simplCore/SimplCore.lhs 157
 doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat
 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes
+#ifdef GHCI
+doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-}
+                                          doPluginPass pass
+   where doPluginPass (BindsToBindsPluginPass p)     = doPassM p
+         doPluginPass (ModGutsToBindsPluginPass p)   = doPassMG p
+         doPluginPass (ModGutsToModGutsPluginPass p) = p
+#endif
 doCorePass pass = pprPanic "doCorePass" (ppr pass)
hunk ./compiler/simplCore/SimplCore.lhs 165
+
 \end{code}
 
 %************************************************************************
hunk ./compiler/simplCore/SimplCore.lhs 212
     binds' <- bind_f (mg_binds guts)
     return (guts { mg_binds = binds' })
 
+#ifdef GHCI
+-- Only used by ModGutsToBindsPluginPass - it seems it was removed from when
+-- max originally wrote this patch. Do we still need/want this?
+doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
+doPassMG bind_f guts = do
+  binds' <- bind_f guts
+  return (guts { mg_binds = binds' })
+#endif
+
 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
 
}

Context:

[ForceSpecConstr now forces specialisation even for arguments which aren't scrutinised
Roman Leshchinskiy <rl@cse.unsw.edu.au>**20101118212839
 Ignore-this: db45721d29a694e53746f8b76513efa4
] 
[Move the superclass generation to the canonicaliser
simonpj@microsoft.com**20101118120533
 Ignore-this: 5e0e525402a240b709f2b8104c1682b2
 
 Doing superclass generation in the canonicaliser (rather than
 TcInteract) uses less code, and is generally more efficient.
 
 See Note [Adding superclasses] in TcCanonical.
 
 Fixes Trac #4497.
] 
[Fix the generation of in-scope variables for IfaceLint check
simonpj@microsoft.com**20101118090057
 Ignore-this: bbcdba61ddf89d07fe69ca99c2017e3f
] 
[Comments only
simonpj@microsoft.com**20101118090034
 Ignore-this: fa2936d35a0f7be4e4535ea9e2b7bf7b
] 
[Omit bogus test for -XDeriveFunctor
simonpj@microsoft.com**20101118090028
 Ignore-this: a534243011809ebbb788b910961601c5
 
 It was duplicated in the case of 'deriving( Functor )'
 and wrong for 'deriving( Foldable )'
] 
[Improve error message on advice from a user
simonpj@microsoft.com**20101118085306
 Ignore-this: bd4f3858ff24e602e985288f27d536f3
 
 See Trac #4499
] 
[TAG 2010-11-18
Ian Lynagh <igloo@earth.li>**20101118011554
 Ignore-this: ccadbe7fadd1148d2ee3caa8c8821ec5
] 
Patch bundle hash:
950bfeef80b9b436d180190850c507c846b6b876