PageRenderTime 60ms CodeModel.GetById 49ms app.highlight 4ms RepoModel.GetById 1ms app.codeStats 0ms

/compiler/simplCore/CoreMonad.lhs

https://github.com/crdueck/ghc
Haskell | 1079 lines | 792 code | 186 blank | 101 comment | 14 complexity | 235a1e87ed047e7d9735128ceb4c94e3 MD5 | raw file
   1%
   2% (c) The AQUA Project, Glasgow University, 1993-1998
   3%
   4\section[CoreMonad]{The core pipeline monad}
   5
   6\begin{code}
   7{-# OPTIONS -fno-warn-tabs #-}
   8-- The above warning supression flag is a temporary kludge.
   9-- While working on this module you are encouraged to remove it and
  10-- detab the module (please do the detabbing in a separate patch). See
  11--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
  12-- for details
  13
  14{-# LANGUAGE UndecidableInstances #-}
  15
  16module CoreMonad (
  17    -- * Configuration of the core-to-core passes
  18    CoreToDo(..), runWhen, runMaybe,
  19    SimplifierMode(..),
  20    FloatOutSwitches(..),
  21    dumpSimplPhase, pprPassDetails, 
  22
  23    -- * Plugins
  24    PluginPass, Plugin(..), CommandLineOption, 
  25    defaultPlugin, bindsOnlyPass,
  26
  27    -- * Counting
  28    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
  29    pprSimplCount, plusSimplCount, zeroSimplCount, 
  30    isZeroSimplCount, hasDetailedCounts, Tick(..),
  31
  32    -- * The monad
  33    CoreM, runCoreM,
  34    
  35    -- ** Reading from the monad
  36    getHscEnv, getRuleBase, getModule,
  37    getDynFlags, getOrigNameCache,
  38    
  39    -- ** Writing to the monad
  40    addSimplCount,
  41    
  42    -- ** Lifting into the monad
  43    liftIO, liftIOWithCount,
  44    liftIO1, liftIO2, liftIO3, liftIO4,
  45    
  46    -- ** Global initialization
  47    reinitializeGlobals,
  48    
  49    -- ** Dealing with annotations
  50    getAnnotations, getFirstAnnotations,
  51    
  52    -- ** Debug output
  53    showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet,
  54
  55    -- ** Screen output
  56    putMsg, putMsgS, errorMsg, errorMsgS, 
  57    fatalErrorMsg, fatalErrorMsgS, 
  58    debugTraceMsg, debugTraceMsgS,
  59    dumpIfSet_dyn, 
  60
  61#ifdef GHCI
  62    -- * Getting 'Name's
  63    thNameToGhcName
  64#endif
  65  ) where
  66
  67#ifdef GHCI
  68import Name( Name )
  69#endif
  70import CoreSyn
  71import PprCore
  72import CoreUtils
  73import CoreLint		( lintCoreBindings )
  74import HscTypes
  75import Module
  76import DynFlags
  77import StaticFlags	
  78import Rules            ( RuleBase )
  79import BasicTypes       ( CompilerPhase(..) )
  80import Annotations
  81import Id		( Id )
  82
  83import IOEnv hiding     ( liftIO, failM, failWithM )
  84import qualified IOEnv  ( liftIO )
  85import TcEnv            ( tcLookupGlobal )
  86import TcRnMonad        ( initTcForLookup )
  87
  88import Outputable
  89import FastString
  90import qualified ErrUtils as Err
  91import Bag
  92import Maybes
  93import SrcLoc
  94import UniqSupply
  95import UniqFM       ( UniqFM, mapUFM, filterUFM )
  96import MonadUtils
  97
  98import Util ( split )
  99import ListSetOps	( runs )
 100import Data.List
 101import Data.Ord
 102import Data.Dynamic
 103import Data.IORef
 104import Data.Map (Map)
 105import qualified Data.Map as Map
 106import Data.Word
 107import Control.Monad
 108
 109import Prelude hiding   ( read )
 110
 111#ifdef GHCI
 112import Control.Concurrent.MVar (MVar)
 113import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
 114import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
 115import qualified Language.Haskell.TH as TH
 116#else
 117saveLinkerGlobals :: IO ()
 118saveLinkerGlobals = return ()
 119
 120restoreLinkerGlobals :: () -> IO ()
 121restoreLinkerGlobals () = return ()
 122#endif
 123\end{code}
 124
 125%************************************************************************
 126%*									*
 127                       Debug output
 128%*									*
 129%************************************************************************
 130
 131These functions are not CoreM monad stuff, but they probably ought to
 132be, and it makes a conveneint place.  place for them.  They print out
 133stuff before and after core passes, and do Core Lint when necessary.
 134
 135\begin{code}
 136showPass :: DynFlags -> CoreToDo -> IO ()
 137showPass dflags pass = Err.showPass dflags (showPpr dflags pass)
 138
 139endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
 140endPass dflags pass binds rules
 141  = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
 142       ; lintPassResult dflags pass binds }      
 143  where
 144    mb_flag = case coreDumpFlag pass of
 145                Just flag | dopt flag dflags                    -> Just flag
 146                          | dopt Opt_D_verbose_core2core dflags -> Just flag
 147                _ -> Nothing
 148
 149dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
 150dumpIfSet dflags dump_me pass extra_info doc
 151  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
 152
 153dumpPassResult :: DynFlags 
 154               -> Maybe DumpFlag		-- Just df => show details in a file whose
 155	       	  			--            name is specified by df
 156               -> SDoc 			-- Header
 157               -> SDoc 			-- Extra info to appear after header
 158               -> CoreProgram -> [CoreRule] 
 159               -> IO ()
 160dumpPassResult dflags mb_flag hdr extra_info binds rules
 161  | Just flag <- mb_flag
 162  = Err.dumpSDoc dflags flag (showSDoc dflags hdr) dump_doc
 163
 164  | otherwise
 165  = Err.debugTraceMsg dflags 2 size_doc
 166          -- Report result size 
 167	  -- This has the side effect of forcing the intermediate to be evaluated
 168
 169  where
 170    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
 171
 172    dump_doc  = vcat [ nest 2 extra_info
 173		     , size_doc
 174                     , blankLine
 175                     , pprCoreBindings binds 
 176                     , ppUnless (null rules) pp_rules ]
 177    pp_rules = vcat [ blankLine
 178                    , ptext (sLit "------ Local rules for imported ids --------")
 179                    , pprRules rules ]
 180
 181lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
 182lintPassResult dflags pass binds
 183  = when (gopt Opt_DoCoreLinting dflags) $
 184    do { let (warns, errs) = lintCoreBindings binds
 185       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
 186       ; displayLintResults dflags pass warns errs binds  }
 187
 188displayLintResults :: DynFlags -> CoreToDo
 189                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
 190                   -> IO ()
 191displayLintResults dflags pass warns errs binds
 192  | not (isEmptyBag errs)
 193  = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
 194           (vcat [ banner "errors", Err.pprMessageBag errs
 195                 , ptext (sLit "*** Offending Program ***")
 196                 , pprCoreBindings binds
 197                 , ptext (sLit "*** End of Offense ***") ])
 198       ; Err.ghcExit dflags 1 }
 199
 200  | not (isEmptyBag warns)
 201  , not (case pass of { CoreDesugar -> True; _ -> False })
 202    	-- Suppress warnings after desugaring pass because some
 203	-- are legitimate. Notably, the desugarer generates instance
 204	-- methods with INLINE pragmas that form a mutually recursive
 205	-- group.  Only afer a round of simplification are they unravelled.
 206  , not opt_NoDebugOutput
 207  , showLintWarnings pass
 208  = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
 209        (banner "warnings" $$ Err.pprMessageBag warns)
 210
 211  | otherwise = return ()
 212  where
 213    banner string = ptext (sLit "*** Core Lint")      <+> text string 
 214                    <+> ptext (sLit ": in result of") <+> ppr pass
 215                    <+> ptext (sLit "***")
 216
 217showLintWarnings :: CoreToDo -> Bool
 218-- Disable Lint warnings on the first simplifier pass, because
 219-- there may be some INLINE knots still tied, which is tiresomely noisy
 220showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
 221showLintWarnings _ = True
 222\end{code}
 223
 224
 225%************************************************************************
 226%*									*
 227              The CoreToDo type and related types
 228	  Abstraction of core-to-core passes to run.
 229%*									*
 230%************************************************************************
 231
 232\begin{code}
 233
 234data CoreToDo           -- These are diff core-to-core passes,
 235                        -- which may be invoked in any order,
 236                        -- as many times as you like.
 237
 238  = CoreDoSimplify      -- The core-to-core simplifier.
 239        Int                    -- Max iterations
 240        SimplifierMode
 241  | CoreDoPluginPass String PluginPass
 242  | CoreDoFloatInwards
 243  | CoreDoFloatOutwards FloatOutSwitches
 244  | CoreLiberateCase
 245  | CoreDoPrintCore
 246  | CoreDoStaticArgs
 247  | CoreDoStrictness
 248  | CoreDoWorkerWrapper
 249  | CoreDoSpecialising
 250  | CoreDoSpecConstr
 251  | CoreCSE
 252  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
 253                                           -- matching this string
 254  | CoreDoVectorisation
 255  | CoreDoNothing                -- Useful when building up
 256  | CoreDoPasses [CoreToDo]      -- lists of these things
 257
 258  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
 259  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
 260                       --                 Core output, and hence useful to pass to endPass
 261
 262  | CoreTidy
 263  | CorePrep
 264
 265\end{code}
 266
 267\begin{code}
 268coreDumpFlag :: CoreToDo -> Maybe DumpFlag
 269coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
 270coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
 271coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 272coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 273coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 274coreDumpFlag CoreDoStaticArgs 	      = Just Opt_D_verbose_core2core
 275coreDumpFlag CoreDoStrictness 	      = Just Opt_D_dump_stranal
 276coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 277coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 278coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 279coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
 280coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
 281coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
 282coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds 
 283coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 284coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 285
 286coreDumpFlag CoreDoPrintCore         = Nothing
 287coreDumpFlag (CoreDoRuleCheck {})    = Nothing
 288coreDumpFlag CoreDoNothing           = Nothing
 289coreDumpFlag (CoreDoPasses {})       = Nothing
 290
 291instance Outputable CoreToDo where
 292  ppr (CoreDoSimplify _ _)     = ptext (sLit "Simplifier")
 293  ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
 294  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
 295  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
 296  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
 297  ppr CoreDoStaticArgs 	       = ptext (sLit "Static argument")
 298  ppr CoreDoStrictness 	       = ptext (sLit "Demand analysis")
 299  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
 300  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
 301  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
 302  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
 303  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
 304  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
 305  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
 306  ppr CoreTidy                 = ptext (sLit "Tidy Core")
 307  ppr CorePrep 		       = ptext (sLit "CorePrep")
 308  ppr CoreDoPrintCore          = ptext (sLit "Print core")
 309  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
 310  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
 311  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
 312
 313pprPassDetails :: CoreToDo -> SDoc
 314pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n 
 315                                            , ppr md ]
 316pprPassDetails _ = empty
 317\end{code}
 318
 319\begin{code}
 320data SimplifierMode             -- See comments in SimplMonad
 321  = SimplMode
 322        { sm_names      :: [String] -- Name(s) of the phase
 323        , sm_phase      :: CompilerPhase
 324        , sm_rules      :: Bool     -- Whether RULES are enabled
 325        , sm_inline     :: Bool     -- Whether inlining is enabled
 326        , sm_case_case  :: Bool     -- Whether case-of-case is enabled
 327        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
 328        }
 329
 330instance Outputable SimplifierMode where
 331    ppr (SimplMode { sm_phase = p, sm_names = ss
 332                   , sm_rules = r, sm_inline = i
 333                   , sm_eta_expand = eta, sm_case_case = cc })
 334       = ptext (sLit "SimplMode") <+> braces (
 335         sep [ ptext (sLit "Phase =") <+> ppr p <+>
 336               brackets (text (concat $ intersperse "," ss)) <> comma
 337             , pp_flag i   (sLit "inline") <> comma
 338             , pp_flag r   (sLit "rules") <> comma
 339             , pp_flag eta (sLit "eta-expand") <> comma
 340             , pp_flag cc  (sLit "case-of-case") ])
 341	 where
 342           pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 343\end{code}
 344
 345
 346\begin{code}
 347data FloatOutSwitches = FloatOutSwitches {
 348  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
 349                                   -- doing so will abstract over n or fewer 
 350                                   -- value variables
 351				   -- Nothing <=> float all lambdas to top level,
 352                                   --             regardless of how many free variables
 353                                   -- Just 0 is the vanilla case: float a lambda
 354                                   --    iff it has no free vars
 355
 356  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
 357                                   --            even if they do not escape a lambda
 358  floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
 359                                            --            based on arity information.
 360  }
 361instance Outputable FloatOutSwitches where
 362    ppr = pprFloatOutSwitches
 363
 364pprFloatOutSwitches :: FloatOutSwitches -> SDoc
 365pprFloatOutSwitches sw 
 366  = ptext (sLit "FOS") <+> (braces $
 367     sep $ punctuate comma $ 
 368     [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
 369     , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
 370     , ptext (sLit "PAPs =")   <+> ppr (floatOutPartialApplications sw) ])
 371
 372-- The core-to-core pass ordering is derived from the DynFlags:
 373runWhen :: Bool -> CoreToDo -> CoreToDo
 374runWhen True  do_this = do_this
 375runWhen False _       = CoreDoNothing
 376
 377runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
 378runMaybe (Just x) f = f x
 379runMaybe Nothing  _ = CoreDoNothing
 380
 381
 382dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
 383dumpSimplPhase dflags mode
 384   | Just spec_string <- shouldDumpSimplPhase dflags
 385   = match_spec spec_string
 386   | otherwise
 387   = dopt Opt_D_verbose_core2core dflags
 388
 389  where
 390    match_spec :: String -> Bool
 391    match_spec spec_string 
 392      = or $ map (and . map match . split ':') 
 393           $ split ',' spec_string
 394
 395    match :: String -> Bool
 396    match "" = True
 397    match s  = case reads s of
 398                [(n,"")] -> phase_num  n
 399                _        -> phase_name s
 400
 401    phase_num :: Int -> Bool
 402    phase_num n = case sm_phase mode of
 403                    Phase k -> n == k
 404                    _       -> False
 405
 406    phase_name :: String -> Bool
 407    phase_name s = s `elem` sm_names mode
 408\end{code}
 409
 410
 411Note [RULEs enabled in SimplGently]
 412~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 413RULES are enabled when doing "gentle" simplification.  Two reasons:
 414
 415  * We really want the class-op cancellation to happen:
 416        op (df d1 d2) --> $cop3 d1 d2
 417    because this breaks the mutual recursion between 'op' and 'df'
 418
 419  * I wanted the RULE
 420        lift String ===> ...
 421    to work in Template Haskell when simplifying
 422    splices, so we get simpler code for literal strings
 423
 424But watch out: list fusion can prevent floating.  So use phase control
 425to switch off those rules until after floating.
 426
 427
 428%************************************************************************
 429%*									*
 430             Types for Plugins
 431%*									*
 432%************************************************************************
 433
 434\begin{code}
 435-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
 436type CommandLineOption = String
 437
 438-- | 'Plugin' is the core compiler plugin data type. Try to avoid
 439-- constructing one of these directly, and just modify some fields of
 440-- 'defaultPlugin' instead: this is to try and preserve source-code
 441-- compatability when we add fields to this.
 442--
 443-- Nonetheless, this API is preliminary and highly likely to change in the future.
 444data Plugin = Plugin { 
 445        installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 446                -- ^ Modify the Core pipeline that will be used for compilation. 
 447                -- This is called as the Core pipeline is built for every module
 448                --  being compiled, and plugins get the opportunity to modify 
 449                -- the pipeline in a nondeterministic order.
 450     }
 451
 452-- | Default plugin: does nothing at all! For compatability reasons you should base all your
 453-- plugin definitions on this default value.
 454defaultPlugin :: Plugin
 455defaultPlugin = Plugin {
 456        installCoreToDos = const return
 457    }
 458
 459-- | A description of the plugin pass itself
 460type PluginPass = ModGuts -> CoreM ModGuts
 461
 462bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
 463bindsOnlyPass pass guts
 464  = do { binds' <- pass (mg_binds guts)
 465       ; return (guts { mg_binds = binds' }) }
 466\end{code}
 467
 468
 469%************************************************************************
 470%*									*
 471             Counting and logging
 472%*									*
 473%************************************************************************
 474
 475\begin{code}
 476verboseSimplStats :: Bool
 477verboseSimplStats = opt_PprStyle_Debug		-- For now, anyway
 478
 479zeroSimplCount	   :: DynFlags -> SimplCount
 480isZeroSimplCount   :: SimplCount -> Bool
 481hasDetailedCounts  :: SimplCount -> Bool
 482pprSimplCount	   :: SimplCount -> SDoc
 483doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
 484doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
 485plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 486\end{code}
 487
 488\begin{code}
 489data SimplCount 
 490   = VerySimplCount !Int	-- Used when don't want detailed stats
 491
 492   | SimplCount	{
 493	ticks   :: !Int,	-- Total ticks
 494	details :: !TickCounts,	-- How many of each type
 495
 496	n_log	:: !Int,	-- N
 497	log1	:: [Tick],	-- Last N events; <= opt_HistorySize, 
 498		   		--   most recent first
 499	log2	:: [Tick]	-- Last opt_HistorySize events before that
 500		   		-- Having log1, log2 lets us accumulate the
 501				-- recent history reasonably efficiently
 502     }
 503
 504type TickCounts = Map Tick Int
 505
 506simplCountN :: SimplCount -> Int
 507simplCountN (VerySimplCount n)         = n
 508simplCountN (SimplCount { ticks = n }) = n
 509
 510zeroSimplCount dflags
 511		-- This is where we decide whether to do
 512		-- the VerySimpl version or the full-stats version
 513  | dopt Opt_D_dump_simpl_stats dflags
 514  = SimplCount {ticks = 0, details = Map.empty,
 515                n_log = 0, log1 = [], log2 = []}
 516  | otherwise
 517  = VerySimplCount 0
 518
 519isZeroSimplCount (VerySimplCount n)    	    = n==0
 520isZeroSimplCount (SimplCount { ticks = n }) = n==0
 521
 522hasDetailedCounts (VerySimplCount {}) = False
 523hasDetailedCounts (SimplCount {})     = True
 524
 525doFreeSimplTick tick sc@SimplCount { details = dts } 
 526  = sc { details = dts `addTick` tick }
 527doFreeSimplTick _ sc = sc 
 528
 529doSimplTick dflags tick
 530    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
 531  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 532  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }
 533  where
 534    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 535
 536doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
 537
 538
 539-- Don't use Map.unionWith because that's lazy, and we want to 
 540-- be pretty strict here!
 541addTick :: TickCounts -> Tick -> TickCounts
 542addTick fm tick = case Map.lookup tick fm of
 543			Nothing -> Map.insert tick 1 fm
 544			Just n  -> n1 `seq` Map.insert tick n1 fm
 545				where
 546				   n1 = n+1
 547
 548
 549plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 550	       sc2@(SimplCount { ticks = tks2, details = dts2 })
 551  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
 552  where
 553	-- A hackish way of getting recent log info
 554    log_base | null (log1 sc2) = sc1	-- Nothing at all in sc2
 555	     | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 556	     | otherwise       = sc2
 557
 558plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
 559plusSimplCount _                  _                  = panic "plusSimplCount"
 560       -- We use one or the other consistently
 561
 562pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
 563pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 564  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
 565	  blankLine,
 566	  pprTickCounts dts,
 567	  if verboseSimplStats then
 568		vcat [blankLine,
 569		      ptext (sLit "Log (most recent first)"),
 570		      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 571	  else empty
 572    ]
 573
 574pprTickCounts :: Map Tick Int -> SDoc
 575pprTickCounts counts
 576  = vcat (map pprTickGroup groups)
 577  where
 578    groups :: [[(Tick,Int)]]	-- Each group shares a comon tag
 579    	      			-- toList returns common tags adjacent
 580    groups = runs same_tag (Map.toList counts)
 581    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
 582
 583pprTickGroup :: [(Tick, Int)] -> SDoc
 584pprTickGroup group@((tick1,_):_)
 585  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
 586       2 (vcat [ int n <+> pprTickCts tick  
 587                                    -- flip as we want largest first
 588               | (tick,n) <- sortBy (flip (comparing snd)) group])
 589pprTickGroup [] = panic "pprTickGroup"
 590\end{code}
 591
 592
 593\begin{code}
 594data Tick
 595  = PreInlineUnconditionally	Id
 596  | PostInlineUnconditionally	Id
 597
 598  | UnfoldingDone    		Id
 599  | RuleFired			FastString	-- Rule name
 600
 601  | LetFloatFromLet
 602  | EtaExpansion		Id	-- LHS binder
 603  | EtaReduction		Id	-- Binder on outer lambda
 604  | BetaReduction		Id	-- Lambda binder
 605
 606
 607  | CaseOfCase			Id	-- Bndr on *inner* case
 608  | KnownBranch			Id	-- Case binder
 609  | CaseMerge			Id	-- Binder on outer case
 610  | AltMerge			Id	-- Case binder
 611  | CaseElim			Id	-- Case binder
 612  | CaseIdentity		Id	-- Case binder
 613  | FillInCaseDefault		Id	-- Case binder
 614
 615  | BottomFound		
 616  | SimplifierDone		-- Ticked at each iteration of the simplifier
 617
 618instance Outputable Tick where
 619  ppr tick = text (tickString tick) <+> pprTickCts tick
 620
 621instance Eq Tick where
 622  a == b = case a `cmpTick` b of
 623           EQ -> True
 624           _ -> False
 625
 626instance Ord Tick where
 627  compare = cmpTick
 628
 629tickToTag :: Tick -> Int
 630tickToTag (PreInlineUnconditionally _)	= 0
 631tickToTag (PostInlineUnconditionally _)	= 1
 632tickToTag (UnfoldingDone _)		= 2
 633tickToTag (RuleFired _)			= 3
 634tickToTag LetFloatFromLet		= 4
 635tickToTag (EtaExpansion _)		= 5
 636tickToTag (EtaReduction _)		= 6
 637tickToTag (BetaReduction _)		= 7
 638tickToTag (CaseOfCase _)		= 8
 639tickToTag (KnownBranch _)		= 9
 640tickToTag (CaseMerge _)			= 10
 641tickToTag (CaseElim _)			= 11
 642tickToTag (CaseIdentity _)		= 12
 643tickToTag (FillInCaseDefault _)		= 13
 644tickToTag BottomFound			= 14
 645tickToTag SimplifierDone		= 16
 646tickToTag (AltMerge _)			= 17
 647
 648tickString :: Tick -> String
 649tickString (PreInlineUnconditionally _)	= "PreInlineUnconditionally"
 650tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 651tickString (UnfoldingDone _)		= "UnfoldingDone"
 652tickString (RuleFired _)		= "RuleFired"
 653tickString LetFloatFromLet		= "LetFloatFromLet"
 654tickString (EtaExpansion _)		= "EtaExpansion"
 655tickString (EtaReduction _)		= "EtaReduction"
 656tickString (BetaReduction _)		= "BetaReduction"
 657tickString (CaseOfCase _)		= "CaseOfCase"
 658tickString (KnownBranch _)		= "KnownBranch"
 659tickString (CaseMerge _)		= "CaseMerge"
 660tickString (AltMerge _)			= "AltMerge"
 661tickString (CaseElim _)			= "CaseElim"
 662tickString (CaseIdentity _)		= "CaseIdentity"
 663tickString (FillInCaseDefault _)	= "FillInCaseDefault"
 664tickString BottomFound			= "BottomFound"
 665tickString SimplifierDone		= "SimplifierDone"
 666
 667pprTickCts :: Tick -> SDoc
 668pprTickCts (PreInlineUnconditionally v)	= ppr v
 669pprTickCts (PostInlineUnconditionally v)= ppr v
 670pprTickCts (UnfoldingDone v)		= ppr v
 671pprTickCts (RuleFired v)		= ppr v
 672pprTickCts LetFloatFromLet		= empty
 673pprTickCts (EtaExpansion v)		= ppr v
 674pprTickCts (EtaReduction v)		= ppr v
 675pprTickCts (BetaReduction v)		= ppr v
 676pprTickCts (CaseOfCase v)		= ppr v
 677pprTickCts (KnownBranch v)		= ppr v
 678pprTickCts (CaseMerge v)		= ppr v
 679pprTickCts (AltMerge v)			= ppr v
 680pprTickCts (CaseElim v)			= ppr v
 681pprTickCts (CaseIdentity v)		= ppr v
 682pprTickCts (FillInCaseDefault v)	= ppr v
 683pprTickCts _    			= empty
 684
 685cmpTick :: Tick -> Tick -> Ordering
 686cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 687		GT -> GT
 688		EQ -> cmpEqTick a b
 689		LT -> LT
 690
 691cmpEqTick :: Tick -> Tick -> Ordering
 692cmpEqTick (PreInlineUnconditionally a)	(PreInlineUnconditionally b)	= a `compare` b
 693cmpEqTick (PostInlineUnconditionally a)	(PostInlineUnconditionally b)	= a `compare` b
 694cmpEqTick (UnfoldingDone a)		(UnfoldingDone b)		= a `compare` b
 695cmpEqTick (RuleFired a)			(RuleFired b)			= a `compare` b
 696cmpEqTick (EtaExpansion a)		(EtaExpansion b)		= a `compare` b
 697cmpEqTick (EtaReduction a)		(EtaReduction b)		= a `compare` b
 698cmpEqTick (BetaReduction a)		(BetaReduction b)		= a `compare` b
 699cmpEqTick (CaseOfCase a)		(CaseOfCase b)			= a `compare` b
 700cmpEqTick (KnownBranch a)		(KnownBranch b)			= a `compare` b
 701cmpEqTick (CaseMerge a)			(CaseMerge b)			= a `compare` b
 702cmpEqTick (AltMerge a)			(AltMerge b)			= a `compare` b
 703cmpEqTick (CaseElim a)			(CaseElim b)			= a `compare` b
 704cmpEqTick (CaseIdentity a)		(CaseIdentity b)		= a `compare` b
 705cmpEqTick (FillInCaseDefault a)		(FillInCaseDefault b)		= a `compare` b
 706cmpEqTick _     			_     				= EQ
 707\end{code}
 708
 709
 710%************************************************************************
 711%*									*
 712             Monad and carried data structure definitions
 713%*									*
 714%************************************************************************
 715
 716\begin{code}
 717newtype CoreState = CoreState {
 718        cs_uniq_supply :: UniqSupply
 719}
 720
 721data CoreReader = CoreReader {
 722        cr_hsc_env :: HscEnv,
 723        cr_rule_base :: RuleBase,
 724        cr_module :: Module,
 725        cr_globals :: ((Bool, [String]),
 726#ifdef GHCI
 727                       (MVar PersistentLinkerState, Bool))
 728#else
 729                       ())
 730#endif
 731}
 732
 733data CoreWriter = CoreWriter {
 734        cw_simpl_count :: !SimplCount  
 735        -- Making this strict fixes a nasty space leak
 736        -- See Trac #7702
 737}
 738
 739emptyWriter :: DynFlags -> CoreWriter
 740emptyWriter dflags = CoreWriter {
 741        cw_simpl_count = zeroSimplCount dflags
 742    }
 743
 744plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 745plusWriter w1 w2 = CoreWriter {
 746        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 747    }
 748
 749type CoreIOEnv = IOEnv CoreReader
 750
 751-- | The monad used by Core-to-Core passes to access common state, register simplification
 752-- statistics and so on
 753newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 754
 755instance Functor CoreM where
 756    fmap f ma = do
 757        a <- ma
 758        return (f a)
 759
 760instance Monad CoreM where
 761    return x = CoreM (\s -> nop s x)
 762    mx >>= f = CoreM $ \s -> do
 763            (x, s', w1) <- unCoreM mx s
 764            (y, s'', w2) <- unCoreM (f x) s'
 765            let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702)
 766            return $ seq w (y, s'', w)
 767
 768instance Applicative CoreM where
 769    pure = return
 770    (<*>) = ap
 771
 772-- For use if the user has imported Control.Monad.Error from MTL
 773-- Requires UndecidableInstances
 774instance MonadPlus IO => MonadPlus CoreM where
 775    mzero = CoreM (const mzero)
 776    m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 777
 778instance MonadUnique CoreM where
 779    getUniqueSupplyM = do
 780        us <- getS cs_uniq_supply
 781        let (us1, us2) = splitUniqSupply us
 782        modifyS (\s -> s { cs_uniq_supply = us2 })
 783        return us1
 784
 785    getUniqueM = do
 786        us <- getS cs_uniq_supply
 787        let (u,us') = takeUniqFromSupply us
 788        modifyS (\s -> s { cs_uniq_supply = us' })
 789        return u
 790
 791runCoreM :: HscEnv
 792         -> RuleBase
 793         -> UniqSupply
 794         -> Module
 795         -> CoreM a
 796         -> IO (a, SimplCount)
 797runCoreM hsc_env rule_base us mod m = do
 798        glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals
 799        liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
 800  where
 801    reader glbls = CoreReader {
 802            cr_hsc_env = hsc_env,
 803            cr_rule_base = rule_base,
 804            cr_module = mod,
 805            cr_globals = glbls
 806        }
 807    state = CoreState { 
 808            cs_uniq_supply = us
 809        }
 810
 811    extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
 812    extract (value, _, writer) = (value, cw_simpl_count writer)
 813
 814\end{code}
 815
 816
 817%************************************************************************
 818%*									*
 819             Core combinators, not exported
 820%*									*
 821%************************************************************************
 822
 823\begin{code}
 824
 825nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 826nop s x = do
 827    r <- getEnv
 828    return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
 829
 830read :: (CoreReader -> a) -> CoreM a
 831read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
 832
 833getS :: (CoreState -> a) -> CoreM a
 834getS f = CoreM (\s -> nop s (f s))
 835
 836modifyS :: (CoreState -> CoreState) -> CoreM ()
 837modifyS f = CoreM (\s -> nop (f s) ())
 838
 839write :: CoreWriter -> CoreM ()
 840write w = CoreM (\s -> return ((), s, w))
 841
 842\end{code}
 843
 844\subsection{Lifting IO into the monad}
 845
 846\begin{code}
 847
 848-- | Lift an 'IOEnv' operation into 'CoreM'
 849liftIOEnv :: CoreIOEnv a -> CoreM a
 850liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
 851
 852instance MonadIO CoreM where
 853    liftIO = liftIOEnv . IOEnv.liftIO
 854
 855-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
 856liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 857liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 858
 859\end{code}
 860
 861
 862%************************************************************************
 863%*									*
 864             Reader, writer and state accessors
 865%*									*
 866%************************************************************************
 867
 868\begin{code}
 869getHscEnv :: CoreM HscEnv
 870getHscEnv = read cr_hsc_env
 871
 872getRuleBase :: CoreM RuleBase
 873getRuleBase = read cr_rule_base
 874
 875addSimplCount :: SimplCount -> CoreM ()
 876addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 877
 878-- Convenience accessors for useful fields of HscEnv
 879
 880instance HasDynFlags CoreM where
 881    getDynFlags = fmap hsc_dflags getHscEnv
 882
 883instance HasModule CoreM where
 884    getModule = read cr_module
 885
 886-- | The original name cache is the current mapping from 'Module' and
 887-- 'OccName' to a compiler-wide unique 'Name'
 888getOrigNameCache :: CoreM OrigNameCache
 889getOrigNameCache = do
 890    nameCacheRef <- fmap hsc_NC getHscEnv
 891    liftIO $ fmap nsNames $ readIORef nameCacheRef
 892\end{code}
 893
 894%************************************************************************
 895%*									*
 896             Initializing globals
 897%*									*
 898%************************************************************************
 899
 900This is a rather annoying function. When a plugin is loaded, it currently
 901gets linked against a *newly loaded* copy of the GHC package. This would
 902not be a problem, except that the new copy has its own mutable state
 903that is not shared with that state that has already been initialized by
 904the original GHC package.
 905
 906(NB This mechanism is sufficient for granting plugins read-only access to
 907globals that are guaranteed to be initialized before the plugin is loaded.  If
 908any further synchronization is necessary, I would suggest using the more
 909sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to
 910share a single instance of the global variable among the compiler and the
 911plugins.  Perhaps we should migrate all global variables to use that mechanism,
 912for robustness... -- NSF July 2013)
 913
 914This leads to loaded plugins calling GHC code which pokes the static flags,
 915and then dying with a panic because the static flags *it* sees are uninitialized.
 916
 917There are two possible solutions:
 918  1. Export the symbols from the GHC executable from the GHC library and link
 919     against this existing copy rather than a new copy of the GHC library
 920  2. Carefully ensure that the global state in the two copies of the GHC
 921     library matches
 922
 923I tried 1. and it *almost* works (and speeds up plugin load times!) except
 924on Windows. On Windows the GHC library tends to export more than 65536 symbols
 925(see #5292) which overflows the limit of what we can export from the EXE and
 926causes breakage.
 927
 928(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem,
 929because we could share the GHC library it links to.)
 930
 931We are going to try 2. instead. Unfortunately, this means that every plugin
 932will have to say `reinitializeGlobals` before it does anything, but never mind.
 933
 934I've threaded the cr_globals through CoreM rather than giving them as an
 935argument to the plugin function so that we can turn this function into
 936(return ()) without breaking any plugins when we eventually get 1. working.
 937
 938\begin{code}
 939reinitializeGlobals :: CoreM ()
 940reinitializeGlobals = do
 941    (sf_globals, linker_globals) <- read cr_globals
 942    hsc_env <- getHscEnv
 943    let dflags = hsc_dflags hsc_env
 944    liftIO $ restoreStaticFlagGlobals sf_globals
 945    liftIO $ restoreLinkerGlobals linker_globals
 946    liftIO $ setUnsafeGlobalDynFlags dflags
 947\end{code}
 948
 949%************************************************************************
 950%*									*
 951             Dealing with annotations
 952%*									*
 953%************************************************************************
 954
 955\begin{code}
 956-- | Get all annotations of a given type. This happens lazily, that is
 957-- no deserialization will take place until the [a] is actually demanded and
 958-- the [a] can also be empty (the UniqFM is not filtered).
 959--
 960-- This should be done once at the start of a Core-to-Core pass that uses
 961-- annotations.
 962--
 963-- See Note [Annotations]
 964getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
 965getAnnotations deserialize guts = do
 966     hsc_env <- getHscEnv
 967     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
 968     return (deserializeAnns deserialize ann_env)
 969
 970-- | Get at most one annotation of a given type per Unique.
 971getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
 972getFirstAnnotations deserialize guts
 973  = liftM (mapUFM head . filterUFM (not . null))
 974  $ getAnnotations deserialize guts
 975  
 976\end{code}
 977
 978Note [Annotations]
 979~~~~~~~~~~~~~~~~~~
 980A Core-to-Core pass that wants to make use of annotations calls
 981getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
 982annotations of a specific type. This produces all annotations from interface
 983files read so far. However, annotations from interface files read during the
 984pass will not be visible until getAnnotations is called again. This is similar
 985to how rules work and probably isn't too bad.
 986
 987The current implementation could be optimised a bit: when looking up
 988annotations for a thing from the HomePackageTable, we could search directly in
 989the module where the thing is defined rather than building one UniqFM which
 990contains all annotations we know of. This would work because annotations can
 991only be given to things defined in the same module. However, since we would
 992only want to deserialise every annotation once, we would have to build a cache
 993for every module in the HTP. In the end, it's probably not worth it as long as
 994we aren't using annotations heavily.
 995
 996%************************************************************************
 997%*									*
 998                Direct screen output
 999%*									*
1000%************************************************************************
1001
1002\begin{code}
1003
1004msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1005msg how doc = do
1006        dflags <- getDynFlags
1007        liftIO $ how dflags doc
1008
1009-- | Output a String message to the screen
1010putMsgS :: String -> CoreM ()
1011putMsgS = putMsg . text
1012
1013-- | Output a message to the screen
1014putMsg :: SDoc -> CoreM ()
1015putMsg = msg Err.putMsg
1016
1017-- | Output a string error to the screen
1018errorMsgS :: String -> CoreM ()
1019errorMsgS = errorMsg . text
1020
1021-- | Output an error to the screen
1022errorMsg :: SDoc -> CoreM ()
1023errorMsg = msg Err.errorMsg
1024
1025-- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1026fatalErrorMsgS :: String -> CoreM ()
1027fatalErrorMsgS = fatalErrorMsg . text
1028
1029-- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1030fatalErrorMsg :: SDoc -> CoreM ()
1031fatalErrorMsg = msg Err.fatalErrorMsg
1032
1033-- | Output a string debugging message at verbosity level of @-v@ or higher
1034debugTraceMsgS :: String -> CoreM ()
1035debugTraceMsgS = debugTraceMsg . text
1036
1037-- | Outputs a debugging message at verbosity level of @-v@ or higher
1038debugTraceMsg :: SDoc -> CoreM ()
1039debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1040
1041-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1042dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
1043dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1044\end{code}
1045
1046
1047%************************************************************************
1048%*									*
1049               Finding TyThings
1050%*									*
1051%************************************************************************
1052
1053\begin{code}
1054instance MonadThings CoreM where
1055    lookupThing name = do
1056        hsc_env <- getHscEnv
1057        liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1058\end{code}
1059
1060%************************************************************************
1061%*									*
1062               Template Haskell interoperability
1063%*									*
1064%************************************************************************
1065
1066\begin{code}
1067#ifdef GHCI
1068-- | Attempt to convert a Template Haskell name to one that GHC can
1069-- understand. Original TH names such as those you get when you use
1070-- the @'foo@ syntax will be translated to their equivalent GHC name
1071-- exactly. Qualified or unqualifed TH names will be dynamically bound
1072-- to names in the module being compiled, if possible. Exact TH names
1073-- will be bound to the name they represent, exactly.
1074thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1075thNameToGhcName th_name = do
1076    hsc_env <- getHscEnv
1077    liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1078#endif
1079\end{code}