CoreMonad.lhs 36.4 KB
Newer Older
1 2 3 4 5 6
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[CoreMonad]{The core pipeline monad}

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
7 8 9 10 11 12 13
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

14 15 16
{-# LANGUAGE UndecidableInstances #-}

module CoreMonad (
17
    -- * Configuration of the core-to-core passes
18
    CoreToDo(..), runWhen, runMaybe,
19 20
    SimplifierMode(..),
    FloatOutSwitches(..),
21
    dumpSimplPhase, pprPassDetails, 
22 23 24 25

    -- * Plugins
    PluginPass, Plugin(..), CommandLineOption, 
    defaultPlugin, bindsOnlyPass,
26 27

    -- * Counting
28
    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
29 30
    pprSimplCount, plusSimplCount, zeroSimplCount, 
    isZeroSimplCount, hasDetailedCounts, Tick(..),
31

32 33 34 35
    -- * The monad
    CoreM, runCoreM,
    
    -- ** Reading from the monad
36
    getHscEnv, getRuleBase, getModule,
37 38 39 40 41 42 43 44 45
    getDynFlags, getOrigNameCache,
    
    -- ** Writing to the monad
    addSimplCount,
    
    -- ** Lifting into the monad
    liftIO, liftIOWithCount,
    liftIO1, liftIO2, liftIO3, liftIO4,
    
46 47 48
    -- ** Global initialization
    reinitializeGlobals,
    
49
    -- ** Dealing with annotations
50
    getAnnotations, getFirstAnnotations,
51
    
52
    -- ** Debug output
53
    showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet,
54

55 56 57 58
    -- ** Screen output
    putMsg, putMsgS, errorMsg, errorMsgS, 
    fatalErrorMsg, fatalErrorMsgS, 
    debugTraceMsg, debugTraceMsgS,
59
    dumpIfSet_dyn, 
60 61 62 63 64 65 66

#ifdef GHCI
    -- * Getting 'Name's
    thNameToGhcName
#endif
  ) where

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
67 68 69
#ifdef GHCI
import Name( Name )
#endif
70 71 72 73
import CoreSyn
import PprCore
import CoreUtils
import CoreLint		( lintCoreBindings )
74 75
import PrelNames        ( iNTERACTIVE )
import HscTypes
76
import Module           ( Module )
77 78
import DynFlags
import StaticFlags	
79
import Rules            ( RuleBase )
80
import BasicTypes       ( CompilerPhase(..) )
81
import Annotations
82
import Id		( Id )
83 84 85 86 87 88 89

import IOEnv hiding     ( liftIO, failM, failWithM )
import qualified IOEnv  ( liftIO )
import TcEnv            ( tcLookupGlobal )
import TcRnMonad        ( TcM, initTc )

import Outputable
90
import FastString
91
import qualified ErrUtils as Err
92
import Bag
93 94
import Maybes
import UniqSupply
95
import UniqFM       ( UniqFM, mapUFM, filterUFM )
96
import MonadUtils
97

98 99
import Util		( split, sortLe )
import ListSetOps	( runs )
100
import Data.List	( intersperse )
101 102
import Data.Dynamic
import Data.IORef
103 104
import Data.Map (Map)
import qualified Data.Map as Map
105 106 107 108 109 110
import Data.Word
import Control.Monad

import Prelude hiding   ( read )

#ifdef GHCI
111 112
import Control.Concurrent.MVar (MVar)
import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
113 114
import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
import qualified Language.Haskell.TH as TH
115 116 117 118 119 120
#else
saveLinkerGlobals :: IO ()
saveLinkerGlobals = return ()

restoreLinkerGlobals :: () -> IO ()
restoreLinkerGlobals () = return ()
121 122 123
#endif
\end{code}

124 125 126 127 128 129 130 131 132 133 134
%************************************************************************
%*									*
                       Debug output
%*									*
%************************************************************************

These functions are not CoreM monad stuff, but they probably ought to
be, and it makes a conveneint place.  place for them.  They print out
stuff before and after core passes, and do Core Lint when necessary.

\begin{code}
135 136
showPass :: DynFlags -> CoreToDo -> IO ()
showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
137

138
endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
139 140 141 142 143 144 145 146
endPass dflags pass binds rules
  = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules
       ; lintPassResult dflags pass binds }      
  where
    mb_flag = case coreDumpFlag pass of
                Just dflag | dopt dflag dflags                   -> Just dflag
                           | dopt Opt_D_verbose_core2core dflags -> Just dflag
                _ -> Nothing
147

148 149 150 151
dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dump_me pass extra_info doc
  = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc

152 153 154 155 156
dumpPassResult :: DynFlags 
               -> Maybe DynFlag		-- Just df => show details in a file whose
	       	  			--            name is specified by df
               -> SDoc 			-- Header
               -> SDoc 			-- Extra info to appear after header
157
               -> CoreProgram -> [CoreRule] 
158 159 160 161 162 163 164 165 166
               -> IO ()
dumpPassResult dflags mb_flag hdr extra_info binds rules
  | Just dflag <- mb_flag
  = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc

  | otherwise
  = Err.debugTraceMsg dflags 2 $
    (text "Result size of" <+> hdr <+> equals <+> int (coreBindsSize binds))
          -- Report result size 
167
	  -- This has the side effect of forcing the intermediate to be evaluated
168

169
  where
170 171 172 173 174
    dump_doc  = vcat [ text "Result size =" <+> int (coreBindsSize binds)
                     , extra_info
		     , blankLine
                     , pprCoreBindings binds 
                     , ppUnless (null rules) pp_rules ]
175 176 177
    pp_rules = vcat [ blankLine
                    , ptext (sLit "------ Local rules for imported ids --------")
                    , pprRules rules ]
178

179
lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
180 181 182 183 184 185
lintPassResult dflags pass binds
  = when (dopt Opt_DoCoreLinting dflags) $
    do { let (warns, errs) = lintCoreBindings binds
       ; Err.showPass dflags ("Core Linted result of " ++ showSDoc (ppr pass))
       ; displayLintResults dflags pass warns errs binds  }

186
displayLintResults :: DynFlags -> CoreToDo
187
                   -> Bag Err.Message -> Bag Err.Message -> CoreProgram
188 189 190 191 192 193 194 195 196 197
                   -> IO ()
displayLintResults dflags pass warns errs binds
  | not (isEmptyBag errs)
  = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
			 , ptext (sLit "*** Offending Program ***")
			 , pprCoreBindings binds
			 , ptext (sLit "*** End of Offense ***") ])
       ; Err.ghcExit dflags 1 }

  | not (isEmptyBag warns)
198 199 200 201 202
  , not (case pass of { CoreDesugar -> True; _ -> False })
    	-- Suppress warnings after desugaring pass because some
	-- are legitimate. Notably, the desugarer generates instance
	-- methods with INLINE pragmas that form a mutually recursive
	-- group.  Only afer a round of simplification are they unravelled.
203 204 205 206 207 208 209 210 211 212 213 214 215
  , not opt_NoDebugOutput
  , showLintWarnings pass
  = printDump (banner "warnings" $$ Err.pprMessageBag warns)

  | otherwise = return ()
  where
    banner string = ptext (sLit "*** Core Lint")      <+> text string 
                    <+> ptext (sLit ": in result of") <+> ppr pass
                    <+> ptext (sLit "***")

showLintWarnings :: CoreToDo -> Bool
-- Disable Lint warnings on the first simplifier pass, because
-- there may be some INLINE knots still tied, which is tiresomely noisy
216 217
showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
showLintWarnings _ = True
218 219 220
\end{code}


221 222 223 224 225 226 227 228
%************************************************************************
%*									*
              The CoreToDo type and related types
	  Abstraction of core-to-core passes to run.
%*									*
%************************************************************************

\begin{code}
229

230 231 232 233 234
data CoreToDo           -- These are diff core-to-core passes,
                        -- which may be invoked in any order,
                        -- as many times as you like.

  = CoreDoSimplify      -- The core-to-core simplifier.
235
        Int                    -- Max iterations
236
        SimplifierMode
237
  | CoreDoPluginPass String PluginPass
238 239 240 241 242 243 244 245 246 247 248 249
  | CoreDoFloatInwards
  | CoreDoFloatOutwards FloatOutSwitches
  | CoreLiberateCase
  | CoreDoPrintCore
  | CoreDoStaticArgs
  | CoreDoStrictness
  | CoreDoWorkerWrapper
  | CoreDoSpecialising
  | CoreDoSpecConstr
  | CoreCSE
  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                           -- matching this string
250
  | CoreDoVectorisation
251 252 253
  | CoreDoNothing                -- Useful when building up
  | CoreDoPasses [CoreToDo]      -- lists of these things

254 255 256
  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
                       --                 Core output, and hence useful to pass to endPass
257 258 259 260

  | CoreTidy
  | CorePrep

261 262 263
\end{code}

\begin{code}
264 265
coreDumpFlag :: CoreToDo -> Maybe DynFlag
coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
266
coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
267 268 269 270 271 272 273 274 275
coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs 	      = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStrictness 	      = Just Opt_D_dump_stranal
coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
276 277
coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
278
coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds 
279 280
coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
281 282 283 284 285 286 287

coreDumpFlag CoreDoPrintCore         = Nothing
coreDumpFlag (CoreDoRuleCheck {})    = Nothing
coreDumpFlag CoreDoNothing           = Nothing
coreDumpFlag (CoreDoPasses {})       = Nothing

instance Outputable CoreToDo where
288
  ppr (CoreDoSimplify _ _)     = ptext (sLit "Simplifier")
289
  ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
290 291 292 293 294 295 296 297 298
  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
  ppr CoreDoStaticArgs 	       = ptext (sLit "Static argument")
  ppr CoreDoStrictness 	       = ptext (sLit "Demand analysis")
  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
299
  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
300 301
  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
302
  ppr CoreTidy                 = ptext (sLit "Tidy Core")
303 304 305 306 307
  ppr CorePrep 		       = ptext (sLit "CorePrep")
  ppr CoreDoPrintCore          = ptext (sLit "Print core")
  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
308 309 310 311

pprPassDetails :: CoreToDo -> SDoc
pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n
pprPassDetails _ = empty
312
\end{code}
313

314
\begin{code}
315
data SimplifierMode             -- See comments in SimplMonad
316 317 318 319 320 321 322 323
  = SimplMode
        { sm_names      :: [String] -- Name(s) of the phase
        , sm_phase      :: CompilerPhase
        , sm_rules      :: Bool     -- Whether RULES are enabled
        , sm_inline     :: Bool     -- Whether inlining is enabled
        , sm_case_case  :: Bool     -- Whether case-of-case is enabled
        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
        }
324 325

instance Outputable SimplifierMode where
326 327 328 329 330 331 332 333 334 335
    ppr (SimplMode { sm_phase = p, sm_names = ss
                   , sm_rules = r, sm_inline = i
                   , sm_eta_expand = eta, sm_case_case = cc })
       = ptext (sLit "SimplMode") <+> braces (
         sep [ ptext (sLit "Phase =") <+> ppr p <+>
               brackets (text (concat $ intersperse "," ss)) <> comma
             , pp_flag i   (sLit "inline") <> comma
             , pp_flag r   (sLit "rules") <> comma
             , pp_flag eta (sLit "eta-expand") <> comma
             , pp_flag cc  (sLit "case-of-case") ])
336 337
	 where
           pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
338 339
\end{code}

340

341
\begin{code}
342
data FloatOutSwitches = FloatOutSwitches {
343 344 345 346 347 348 349 350 351 352 353
  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
                                   -- doing so will abstract over n or fewer 
                                   -- value variables
				   -- Nothing <=> float all lambdas to top level,
                                   --             regardless of how many free variables
                                   -- Just 0 is the vanilla case: float a lambda
                                   --    iff it has no free vars

  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                   --            even if they do not escape a lambda
  floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
Simon Marlow's avatar
Simon Marlow committed
354
                                            --            based on arity information.
355
  }
356 357 358 359
instance Outputable FloatOutSwitches where
    ppr = pprFloatOutSwitches

pprFloatOutSwitches :: FloatOutSwitches -> SDoc
360 361 362 363 364 365
pprFloatOutSwitches sw 
  = ptext (sLit "FOS") <+> (braces $
     sep $ punctuate comma $ 
     [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
     , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
     , ptext (sLit "PAPs =")   <+> ppr (floatOutPartialApplications sw) ])
366 367 368 369 370 371 372 373 374 375

-- The core-to-core pass ordering is derived from the DynFlags:
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen True  do_this = do_this
runWhen False _       = CoreDoNothing

runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just x) f = f x
runMaybe Nothing  _ = CoreDoNothing

376

377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396
dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
dumpSimplPhase dflags mode
   | Just spec_string <- shouldDumpSimplPhase dflags
   = match_spec spec_string
   | otherwise
   = dopt Opt_D_verbose_core2core dflags

  where
    match_spec :: String -> Bool
    match_spec spec_string 
      = or $ map (and . map match . split ':') 
           $ split ',' spec_string

    match :: String -> Bool
    match "" = True
    match s  = case reads s of
                [(n,"")] -> phase_num  n
                _        -> phase_name s

    phase_num :: Int -> Bool
397 398 399
    phase_num n = case sm_phase mode of
                    Phase k -> n == k
                    _       -> False
400 401

    phase_name :: String -> Bool
402
    phase_name s = s `elem` sm_names mode
403 404 405
\end{code}


406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422
Note [RULEs enabled in SimplGently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RULES are enabled when doing "gentle" simplification.  Two reasons:

  * We really want the class-op cancellation to happen:
        op (df d1 d2) --> $cop3 d1 d2
    because this breaks the mutual recursion between 'op' and 'df'

  * I wanted the RULE
        lift String ===> ...
    to work in Template Haskell when simplifying
    splices, so we get simpler code for literal strings

But watch out: list fusion can prevent floating.  So use phase control
to switch off those rules until after floating.


423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
%************************************************************************
%*									*
             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

457
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
458 459 460 461 462 463
bindsOnlyPass pass guts
  = do { binds' <- pass (mg_binds guts)
       ; return (guts { mg_binds = binds' }) }
\end{code}


464 465 466 467 468 469 470 471 472 473 474 475
%************************************************************************
%*									*
             Counting and logging
%*									*
%************************************************************************

\begin{code}
verboseSimplStats :: Bool
verboseSimplStats = opt_PprStyle_Debug		-- For now, anyway

zeroSimplCount	   :: DynFlags -> SimplCount
isZeroSimplCount   :: SimplCount -> Bool
476
hasDetailedCounts  :: SimplCount -> Bool
477 478 479 480 481 482 483
pprSimplCount	   :: SimplCount -> SDoc
doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
\end{code}

\begin{code}
data SimplCount 
484
   = VerySimplCount !Int	-- Used when don't want detailed stats
485 486 487 488 489 490 491 492 493 494 495 496 497

   | SimplCount	{
	ticks   :: !Int,	-- Total ticks
	details :: !TickCounts,	-- How many of each type

	n_log	:: !Int,	-- N
	log1	:: [Tick],	-- Last N events; <= opt_HistorySize, 
		   		--   most recent first
	log2	:: [Tick]	-- Last opt_HistorySize events before that
		   		-- Having log1, log2 lets us accumulate the
				-- recent history reasonably efficiently
     }

498
type TickCounts = Map Tick Int
499

500 501 502 503
simplCountN :: SimplCount -> Int
simplCountN (VerySimplCount n)         = n
simplCountN (SimplCount { ticks = n }) = n

504 505 506 507
zeroSimplCount dflags
		-- This is where we decide whether to do
		-- the VerySimpl version or the full-stats version
  | dopt Opt_D_dump_simpl_stats dflags
508
  = SimplCount {ticks = 0, details = Map.empty,
509 510
                n_log = 0, log1 = [], log2 = []}
  | otherwise
511
  = VerySimplCount 0
512

513 514
isZeroSimplCount (VerySimplCount n)    	    = n==0
isZeroSimplCount (SimplCount { ticks = n }) = n==0
515

516 517 518
hasDetailedCounts (VerySimplCount {}) = False
hasDetailedCounts (SimplCount {})     = True

519 520 521 522 523 524 525 526 527 528
doFreeSimplTick tick sc@SimplCount { details = dts } 
  = sc { details = dts `addTick` tick }
doFreeSimplTick _ sc = sc 

doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
  | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
  | otherwise		  = sc1 { n_log = nl+1, log1 = tick : l1 }
  where
    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }

529
doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
530 531


532
-- Don't use Map.unionWith because that's lazy, and we want to 
533 534
-- be pretty strict here!
addTick :: TickCounts -> Tick -> TickCounts
535 536 537
addTick fm tick = case Map.lookup tick fm of
			Nothing -> Map.insert tick 1 fm
			Just n  -> n1 `seq` Map.insert tick n1 fm
538 539 540 541 542 543
				where
				   n1 = n+1


plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
	       sc2@(SimplCount { ticks = tks2, details = dts2 })
544
  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
545 546 547 548 549 550
  where
	-- A hackish way of getting recent log info
    log_base | null (log1 sc2) = sc1	-- Nothing at all in sc2
	     | null (log2 sc2) = sc2 { log2 = log1 sc1 }
	     | otherwise       = sc2

551 552 553
plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
plusSimplCount _                  _                  = panic "plusSimplCount"
       -- We use one or the other consistently
554

555
pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
556 557 558
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
	  blankLine,
559
	  pprTickCounts dts,
560 561 562 563 564 565 566
	  if verboseSimplStats then
		vcat [blankLine,
		      ptext (sLit "Log (most recent first)"),
		      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
	  else empty
    ]

567 568 569 570 571 572 573 574 575 576 577 578 579 580
pprTickCounts :: Map Tick Int -> SDoc
pprTickCounts counts
  = vcat (map pprTickGroup groups)
  where
    groups :: [[(Tick,Int)]]	-- Each group shares a comon tag
    	      			-- toList returns common tags adjacent
    groups = runs same_tag (Map.toList counts)
    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2

pprTickGroup :: [(Tick, Int)] -> SDoc
pprTickGroup group@((tick1,_):_)
  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
       2 (vcat [ int n <+> pprTickCts tick  
               | (tick,n) <- sortLe le group])
581
  where
582 583
    le (_,n1) (_,n2) = n2 <= n1   -- We want largest first
pprTickGroup [] = panic "pprTickGroup"
584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703
\end{code}


\begin{code}
data Tick
  = PreInlineUnconditionally	Id
  | PostInlineUnconditionally	Id

  | UnfoldingDone    		Id
  | RuleFired			FastString	-- Rule name

  | LetFloatFromLet
  | EtaExpansion		Id	-- LHS binder
  | EtaReduction		Id	-- Binder on outer lambda
  | BetaReduction		Id	-- Lambda binder


  | CaseOfCase			Id	-- Bndr on *inner* case
  | KnownBranch			Id	-- Case binder
  | CaseMerge			Id	-- Binder on outer case
  | AltMerge			Id	-- Case binder
  | CaseElim			Id	-- Case binder
  | CaseIdentity		Id	-- Case binder
  | FillInCaseDefault		Id	-- Case binder

  | BottomFound		
  | SimplifierDone		-- Ticked at each iteration of the simplifier

instance Outputable Tick where
  ppr tick = text (tickString tick) <+> pprTickCts tick

instance Eq Tick where
  a == b = case a `cmpTick` b of
           EQ -> True
           _ -> False

instance Ord Tick where
  compare = cmpTick

tickToTag :: Tick -> Int
tickToTag (PreInlineUnconditionally _)	= 0
tickToTag (PostInlineUnconditionally _)	= 1
tickToTag (UnfoldingDone _)		= 2
tickToTag (RuleFired _)			= 3
tickToTag LetFloatFromLet		= 4
tickToTag (EtaExpansion _)		= 5
tickToTag (EtaReduction _)		= 6
tickToTag (BetaReduction _)		= 7
tickToTag (CaseOfCase _)		= 8
tickToTag (KnownBranch _)		= 9
tickToTag (CaseMerge _)			= 10
tickToTag (CaseElim _)			= 11
tickToTag (CaseIdentity _)		= 12
tickToTag (FillInCaseDefault _)		= 13
tickToTag BottomFound			= 14
tickToTag SimplifierDone		= 16
tickToTag (AltMerge _)			= 17

tickString :: Tick -> String
tickString (PreInlineUnconditionally _)	= "PreInlineUnconditionally"
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
tickString (UnfoldingDone _)		= "UnfoldingDone"
tickString (RuleFired _)		= "RuleFired"
tickString LetFloatFromLet		= "LetFloatFromLet"
tickString (EtaExpansion _)		= "EtaExpansion"
tickString (EtaReduction _)		= "EtaReduction"
tickString (BetaReduction _)		= "BetaReduction"
tickString (CaseOfCase _)		= "CaseOfCase"
tickString (KnownBranch _)		= "KnownBranch"
tickString (CaseMerge _)		= "CaseMerge"
tickString (AltMerge _)			= "AltMerge"
tickString (CaseElim _)			= "CaseElim"
tickString (CaseIdentity _)		= "CaseIdentity"
tickString (FillInCaseDefault _)	= "FillInCaseDefault"
tickString BottomFound			= "BottomFound"
tickString SimplifierDone		= "SimplifierDone"

pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally v)	= ppr v
pprTickCts (PostInlineUnconditionally v)= ppr v
pprTickCts (UnfoldingDone v)		= ppr v
pprTickCts (RuleFired v)		= ppr v
pprTickCts LetFloatFromLet		= empty
pprTickCts (EtaExpansion v)		= ppr v
pprTickCts (EtaReduction v)		= ppr v
pprTickCts (BetaReduction v)		= ppr v
pprTickCts (CaseOfCase v)		= ppr v
pprTickCts (KnownBranch v)		= ppr v
pprTickCts (CaseMerge v)		= ppr v
pprTickCts (AltMerge v)			= ppr v
pprTickCts (CaseElim v)			= ppr v
pprTickCts (CaseIdentity v)		= ppr v
pprTickCts (FillInCaseDefault v)	= ppr v
pprTickCts _    			= empty

cmpTick :: Tick -> Tick -> Ordering
cmpTick a b = case (tickToTag a `compare` tickToTag b) of
		GT -> GT
		EQ -> cmpEqTick a b
		LT -> LT

cmpEqTick :: Tick -> Tick -> Ordering
cmpEqTick (PreInlineUnconditionally a)	(PreInlineUnconditionally b)	= a `compare` b
cmpEqTick (PostInlineUnconditionally a)	(PostInlineUnconditionally b)	= a `compare` b
cmpEqTick (UnfoldingDone a)		(UnfoldingDone b)		= a `compare` b
cmpEqTick (RuleFired a)			(RuleFired b)			= a `compare` b
cmpEqTick (EtaExpansion a)		(EtaExpansion b)		= a `compare` b
cmpEqTick (EtaReduction a)		(EtaReduction b)		= a `compare` b
cmpEqTick (BetaReduction a)		(BetaReduction b)		= a `compare` b
cmpEqTick (CaseOfCase a)		(CaseOfCase b)			= a `compare` b
cmpEqTick (KnownBranch a)		(KnownBranch b)			= a `compare` b
cmpEqTick (CaseMerge a)			(CaseMerge b)			= a `compare` b
cmpEqTick (AltMerge a)			(AltMerge b)			= a `compare` b
cmpEqTick (CaseElim a)			(CaseElim b)			= a `compare` b
cmpEqTick (CaseIdentity a)		(CaseIdentity b)		= a `compare` b
cmpEqTick (FillInCaseDefault a)		(FillInCaseDefault b)		= a `compare` b
cmpEqTick _     			_     				= EQ
\end{code}


704 705 706 707 708
%************************************************************************
%*									*
             Monad and carried data structure definitions
%*									*
%************************************************************************
709 710

\begin{code}
711 712
newtype CoreState = CoreState {
        cs_uniq_supply :: UniqSupply
713 714 715 716 717
}

data CoreReader = CoreReader {
        cr_hsc_env :: HscEnv,
        cr_rule_base :: RuleBase,
718 719 720 721 722 723 724
        cr_module :: Module,
        cr_globals :: ((Bool, [String], [Way]),
#ifdef GHCI
                       (MVar PersistentLinkerState, Bool))
#else
                       ())
#endif
725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
}

data CoreWriter = CoreWriter {
        cw_simpl_count :: SimplCount
}

emptyWriter :: DynFlags -> CoreWriter
emptyWriter dflags = CoreWriter {
        cw_simpl_count = zeroSimplCount dflags
    }

plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
plusWriter w1 w2 = CoreWriter {
        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
    }

type CoreIOEnv = IOEnv CoreReader

-- | The monad used by Core-to-Core passes to access common state, register simplification
-- statistics and so on
newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }

instance Functor CoreM where
    fmap f ma = do
        a <- ma
        return (f a)

instance Monad CoreM where
    return x = CoreM (\s -> nop s x)
    mx >>= f = CoreM $ \s -> do
            (x, s', w1) <- unCoreM mx s
            (y, s'', w2) <- unCoreM (f x) s'
            return (y, s'', w1 `plusWriter` w2)

instance Applicative CoreM where
    pure = return
    (<*>) = ap

-- For use if the user has imported Control.Monad.Error from MTL
-- Requires UndecidableInstances
instance MonadPlus IO => MonadPlus CoreM where
    mzero = CoreM (const mzero)
    m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)

instance MonadUnique CoreM where
    getUniqueSupplyM = do
        us <- getS cs_uniq_supply
        let (us1, us2) = splitUniqSupply us
        modifyS (\s -> s { cs_uniq_supply = us2 })
        return us1

runCoreM :: HscEnv
         -> RuleBase
         -> UniqSupply
         -> Module
         -> CoreM a
         -> IO (a, SimplCount)
782 783 784
runCoreM hsc_env rule_base us mod m = do
        glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals
        liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
785
  where
786
    reader glbls = CoreReader {
787 788
            cr_hsc_env = hsc_env,
            cr_rule_base = rule_base,
789 790
            cr_module = mod,
            cr_globals = glbls
791 792
        }
    state = CoreState { 
793
            cs_uniq_supply = us
794 795 796 797 798 799 800
        }

    extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
    extract (value, _, writer) = (value, cw_simpl_count writer)

\end{code}

801 802 803 804 805 806

%************************************************************************
%*									*
             Core combinators, not exported
%*									*
%************************************************************************
807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845

\begin{code}

nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
nop s x = do
    r <- getEnv
    return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)

read :: (CoreReader -> a) -> CoreM a
read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))

getS :: (CoreState -> a) -> CoreM a
getS f = CoreM (\s -> nop s (f s))

modifyS :: (CoreState -> CoreState) -> CoreM ()
modifyS f = CoreM (\s -> nop (f s) ())

write :: CoreWriter -> CoreM ()
write w = CoreM (\s -> return ((), s, w))

\end{code}

\subsection{Lifting IO into the monad}

\begin{code}

-- | Lift an 'IOEnv' operation into 'CoreM'
liftIOEnv :: CoreIOEnv a -> CoreM a
liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))

instance MonadIO CoreM where
    liftIO = liftIOEnv . IOEnv.liftIO

-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
liftIOWithCount :: IO (SimplCount, a) -> CoreM a
liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)

\end{code}

846 847 848 849 850 851

%************************************************************************
%*									*
             Reader, writer and state accessors
%*									*
%************************************************************************
852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867

\begin{code}
getHscEnv :: CoreM HscEnv
getHscEnv = read cr_hsc_env

getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base

getModule :: CoreM Module
getModule = read cr_module

addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count })

-- Convenience accessors for useful fields of HscEnv

868 869
instance HasDynFlags CoreM where
    getDynFlags = fmap hsc_dflags getHscEnv
870 871 872 873 874 875 876 877 878

-- | The original name cache is the current mapping from 'Module' and
-- 'OccName' to a compiler-wide unique 'Name'
getOrigNameCache :: CoreM OrigNameCache
getOrigNameCache = do
    nameCacheRef <- fmap hsc_NC getHscEnv
    liftIO $ fmap nsNames $ readIORef nameCacheRef
\end{code}

879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921
%************************************************************************
%*									*
             Initializing globals
%*									*
%************************************************************************

This is a rather annoying function. When a plugin is loaded, it currently
gets linked against a *newly loaded* copy of the GHC package. This would
not be a problem, except that the new copy has its own mutable state
that is not shared with that state that has already been initialized by
the original GHC package.

This leads to loaded plugins calling GHC code which pokes the static flags,
and then dying with a panic because the static flags *it* sees are uninitialized.

There are two possible solutions:
  1. Export the symbols from the GHC executable from the GHC library and link
     against this existing copy rather than a new copy of the GHC library
  2. Carefully ensure that the global state in the two copies of the GHC
     library matches

I tried 1. and it *almost* works (and speeds up plugin load times!) except
on Windows. On Windows the GHC library tends to export more than 65536 symbols
(see #5292) which overflows the limit of what we can export from the EXE and
causes breakage.

(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem,
because we could share the GHC library it links to.)

We are going to try 2. instead. Unfortunately, this means that every plugin
will have to say `reinitializeGlobals` before it does anything, but never mind.

I've threaded the cr_globals through CoreM rather than giving them as an
argument to the plugin function so that we can turn this function into
(return ()) without breaking any plugins when we eventually get 1. working.

\begin{code}
reinitializeGlobals :: CoreM ()
reinitializeGlobals = do
    (sf_globals, linker_globals) <- read cr_globals
    liftIO $ restoreStaticFlagGlobals sf_globals
    liftIO $ restoreLinkerGlobals linker_globals
\end{code}
922 923 924 925 926 927

%************************************************************************
%*									*
             Dealing with annotations
%*									*
%************************************************************************
928 929

\begin{code}
930 931 932
-- | Get all annotations of a given type. This happens lazily, that is
-- no deserialization will take place until the [a] is actually demanded and
-- the [a] can also be empty (the UniqFM is not filtered).
933
--
934 935
-- This should be done once at the start of a Core-to-Core pass that uses
-- annotations.
936
--
937 938 939 940 941
-- See Note [Annotations]
getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations deserialize guts = do
     hsc_env <- getHscEnv
     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
942 943
     return (deserializeAnns deserialize ann_env)

944 945 946 947 948 949
-- | Get at most one annotation of a given type per Unique.
getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
getFirstAnnotations deserialize guts
  = liftM (mapUFM head . filterUFM (not . null))
  $ getAnnotations deserialize guts
  
950 951
\end{code}

952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968
Note [Annotations]
~~~~~~~~~~~~~~~~~~
A Core-to-Core pass that wants to make use of annotations calls
getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
annotations of a specific type. This produces all annotations from interface
files read so far. However, annotations from interface files read during the
pass will not be visible until getAnnotations is called again. This is similar
to how rules work and probably isn't too bad.

The current implementation could be optimised a bit: when looking up
annotations for a thing from the HomePackageTable, we could search directly in
the module where the thing is defined rather than building one UniqFM which
contains all annotations we know of. This would work because annotations can
only be given to things defined in the same module. However, since we would
only want to deserialise every annotation once, we would have to build a cache
for every module in the HTP. In the end, it's probably not worth it as long as
we aren't using annotations heavily.
969 970 971 972 973 974

%************************************************************************
%*									*
                Direct screen output
%*									*
%************************************************************************
975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027

\begin{code}

msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
msg how doc = do
        dflags <- getDynFlags
        liftIO $ how dflags doc

-- | Output a String message to the screen
putMsgS :: String -> CoreM ()
putMsgS = putMsg . text

-- | Output a message to the screen
putMsg :: SDoc -> CoreM ()
putMsg = msg Err.putMsg

-- | Output a string error to the screen
errorMsgS :: String -> CoreM ()
errorMsgS = errorMsg . text

-- | Output an error to the screen
errorMsg :: SDoc -> CoreM ()
errorMsg = msg Err.errorMsg

-- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
fatalErrorMsgS :: String -> CoreM ()
fatalErrorMsgS = fatalErrorMsg . text

-- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg = msg Err.fatalErrorMsg

-- | Output a string debugging message at verbosity level of @-v@ or higher
debugTraceMsgS :: String -> CoreM ()
debugTraceMsgS = debugTraceMsg . text

-- | Outputs a debugging message at verbosity level of @-v@ or higher
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg = msg (flip Err.debugTraceMsg 3)

-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
\end{code}

\begin{code}

initTcForLookup :: HscEnv -> TcM a -> IO a
initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE

\end{code}


1028 1029 1030 1031 1032
%************************************************************************
%*									*
               Finding TyThings
%*									*
%************************************************************************
1033

1034
\begin{code}
1035 1036 1037 1038 1039 1040
instance MonadThings CoreM where
    lookupThing name = do
        hsc_env <- getHscEnv
        liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
\end{code}

1041 1042 1043 1044 1045
%************************************************************************
%*									*
               Template Haskell interoperability
%*									*
%************************************************************************
1046 1047 1048

\begin{code}
#ifdef GHCI
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1049 1050 1051 1052 1053 1054
-- | Attempt to convert a Template Haskell name to one that GHC can
-- understand. Original TH names such as those you get when you use
-- the @'foo@ syntax will be translated to their equivalent GHC name
-- exactly. Qualified or unqualifed TH names will be dynamically bound
-- to names in the module being compiled, if possible. Exact TH names
-- will be bound to the name they represent, exactly.
1055 1056 1057 1058 1059 1060
thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
thNameToGhcName th_name = do
    hsc_env <- getHscEnv
    liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
#endif
\end{code}