Pass DynFlags down to showSDocDump
authorIan Lynagh <igloo@earth.li>
Mon, 11 Jun 2012 23:46:49 +0000 (00:46 +0100)
committerIan Lynagh <igloo@earth.li>
Mon, 11 Jun 2012 23:46:49 +0000 (00:46 +0100)
To help with this, we now also pass DynFlags around inside the SpecM
monad.

compiler/codeGen/StgCmmBind.hs
compiler/coreSyn/CoreUnfold.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Specialise.lhs
compiler/utils/Outputable.lhs

index 3ae25b4..4f9d1b5 100644 (file)
@@ -79,7 +79,8 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
   ; srt_info <- getSRTInfo srt
   ; mod_name <- getModuleName
-  ; let descr         = closureDescription mod_name name
+  ; dflags   <- getDynFlags
+  ; let descr         = closureDescription dflags mod_name name
        closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
        closure_label = mkLocalClosureLabel name (idCafInfo id)
        cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
@@ -288,8 +289,9 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
        ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
        ; mod_name <- getModuleName
        ; c_srt <- getSRTInfo srt
+       ; dflags <- getDynFlags
        ; let   name  = idName bndr
-               descr = closureDescription mod_name name
+               descr = closureDescription dflags mod_name name
                fv_details :: [(NonVoid Id, VirtualHpOffset)]
                (tot_wds, ptr_wds, fv_details)
                   = mkVirtHeapOffsets (isLFThunk lf_info)
@@ -336,10 +338,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
   = do -- AHA!  A STANDARD-FORM THUNK
   {    -- LAY OUT THE OBJECT
     mod_name <- getModuleName
+  ; dflags <- getDynFlags
   ; let (tot_wds, ptr_wds, payload_w_offsets)
            = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
 
-       descr = closureDescription mod_name (idName bndr)
+       descr = closureDescription dflags mod_name (idName bndr)
        closure_info = mkClosureInfo False      -- Not static
                                     bndr lf_info tot_wds ptr_wds
                                     NoC_SRT    -- No SRT for a std-form closure
@@ -685,13 +688,14 @@ link_caf _is_upd = do
 -- name of the data constructor itself.  Otherwise it is determined by
 -- @closureDescription@ from the let binding information.
 
-closureDescription :: Module           -- Module
+closureDescription :: DynFlags
+           -> Module           -- Module
                   -> Name              -- Id of closure binding
                   -> String
        -- Not called for StgRhsCon which have global info tables built in
        -- CgConTbls.lhs with a description generated from the data constructor
-closureDescription mod_name name
-  = showSDocDump (char '<' <>
+closureDescription dflags mod_name name
+  = showSDocDump dflags (char '<' <>
                    (if isExternalName name
                      then ppr name -- ppr will include the module name prefix
                      else pprModule mod_name <> char '.' <> ppr name) <>
index c717e4b..8f62ed4 100644 (file)
@@ -896,7 +896,7 @@ tryUnfolding dflags id lone_variable
                        -- uf_arity will typically be equal to (idArity id), 
                        -- but may be less for InlineRules
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
- = pprTrace ("Considering inlining: " ++ showSDocDump (ppr id))
+ = pprTrace ("Considering inlining: " ++ showSDocDump dflags (ppr id))
                 (vcat [text "arg infos" <+> ppr arg_infos,
                        text "uf arity" <+> ppr uf_arity,
                        text "interesting continuation" <+> ppr cont_info,
index 41ff505..a176e6c 100644 (file)
@@ -363,54 +363,54 @@ runCorePasses passes guts
     do_pass guts pass
        = do { dflags <- getDynFlags
             ; liftIO $ showPass dflags pass
-            ; guts' <- doCorePass pass guts
+            ; guts' <- doCorePass dflags pass guts
             ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
             ; return guts' }
 
-doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
-doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
-                                       simplifyPgm pass
+doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts
+doCorePass _      pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                              simplifyPgm pass
 
-doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
-                                       doPass cseProgram
+doCorePass _      CoreCSE                   = {-# SCC "CommonSubExpr" #-}
+                                              doPass cseProgram
 
-doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
-                                       doPassD liberateCase
+doCorePass _      CoreLiberateCase          = {-# SCC "LiberateCase" #-}
+                                              doPassD liberateCase
 
-doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
-                                       doPass floatInwards
+doCorePass _      CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                              doPass floatInwards
 
-doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
-                                       doPassDUM (floatOutwards f)
+doCorePass _      (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
+                                              doPassDUM (floatOutwards f)
 
-doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
-                                       doPassU doStaticArgs
+doCorePass _      CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
+                                              doPassU doStaticArgs
 
-doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
-                                       doPassDM dmdAnalPgm
+doCorePass _      CoreDoStrictness          = {-# SCC "Stranal" #-}
+                                              doPassDM dmdAnalPgm
 
-doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
-                                       doPassU wwTopBinds
+doCorePass _      CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                              doPassU wwTopBinds
 
-doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
-                                       specProgram
+doCorePass dflags CoreDoSpecialising        = {-# SCC "Specialise" #-}
+                                              specProgram dflags
 
-doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
-                                       specConstrProgram
+doCorePass _      CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
+                                              specConstrProgram
 
-doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
-                                       vectorise
+doCorePass _      CoreDoVectorisation       = {-# SCC "Vectorise" #-}
+                                              vectorise
 
-doCorePass CoreDoPrintCore              = observe   printCore
-doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
-doCorePass CoreDoNothing                = return
-doCorePass (CoreDoPasses passes)        = runCorePasses passes
+doCorePass _      CoreDoPrintCore              = observe   printCore
+doCorePass _      (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
+doCorePass _      CoreDoNothing                = return
+doCorePass _      (CoreDoPasses passes)        = runCorePasses passes
 
 #ifdef GHCI
-doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
+doCorePass _      (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
 #endif
 
-doCorePass pass = pprPanic "doCorePass" (ppr pass)
+doCorePass _      pass = pprPanic "doCorePass" (ppr pass)
 \end{code}
 
 %************************************************************************
index 726d0d5..44286b4 100644 (file)
@@ -1425,7 +1425,7 @@ completeCall env var cont
          pprDefiniteTrace "Inlining done:" (ppr var) stuff
         else stuff
       | otherwise
-      = pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var))
+      = pprDefiniteTrace ("Inlining done: " ++ showSDocDump dflags (ppr var))
            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                   text "Cont:  " <+> ppr cont])
            stuff
index 94c7170..6892c9c 100644 (file)
@@ -20,17 +20,20 @@ import CoreSyn
 import Rules
 import CoreUtils        ( exprIsTrivial, applyTypeToArgs )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
-import UniqSupply       ( UniqSM, initUs_, MonadUnique(..) )
+import UniqSupply
 import Name
 import MkId             ( voidArgId, realWorldPrimId )
 import Maybes           ( catMaybes, isJust )
 import BasicTypes
 import HscTypes
 import Bag
+import DynFlags
 import Util
 import Outputable
 import FastString
+import State
 
+import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
@@ -561,17 +564,17 @@ Hence, the invariant is this:
 %************************************************************************
 
 \begin{code}
-specProgram :: ModGuts -> CoreM ModGuts
-specProgram guts
+specProgram :: DynFlags -> ModGuts -> CoreM ModGuts
+specProgram dflags guts
   = do { hpt_rules <- getRuleBase
        ; let local_rules = mg_rules guts
              rule_base = extendRuleBaseList hpt_rules (mg_rules guts)
 
              -- Specialise the bindings of this module
-       ; (binds', uds) <- runSpecM (go (mg_binds guts))
+       ; (binds', uds) <- runSpecM dflags (go (mg_binds guts))
 
              -- Specialise imported functions
-       ; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds
+       ; (new_rules, spec_binds) <- specImports dflags emptyVarSet rule_base uds
 
        ; let final_binds | null spec_binds = binds'
                          | otherwise       = Rec (flattenBinds spec_binds) : binds'
@@ -593,7 +596,8 @@ specProgram guts
                          (bind', uds') <- specBind top_subst bind uds
                          return (bind' ++ binds', uds')
 
-specImports :: VarSet           -- Don't specialise these ones
+specImports :: DynFlags
+            -> VarSet           -- Don't specialise these ones
                                 -- See Note [Avoiding recursive specialisation]
             -> RuleBase         -- Rules from this module and the home package
                                 -- (but not external packages, which can change)
@@ -601,24 +605,25 @@ specImports :: VarSet           -- Don't specialise these ones
             -> CoreM ( [CoreRule]   -- New rules
                      , [CoreBind] ) -- Specialised bindings and floating bindings
 -- See Note [Specialise imported INLINABLE things]
-specImports done rb uds
+specImports dflags done rb uds
   = do { let import_calls = varEnvElts (ud_calls uds)
        ; (rules, spec_binds) <- go rb import_calls
        ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) }
   where
     go _ [] = return ([], [])
     go rb (CIS fn calls_for_fn : other_calls)
-      = do { (rules1, spec_binds1) <- specImport done rb fn (Map.toList calls_for_fn)
+      = do { (rules1, spec_binds1) <- specImport dflags done rb fn (Map.toList calls_for_fn)
            ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
 
-specImport :: VarSet                -- Don't specialise these
+specImport :: DynFlags
+           -> VarSet                -- Don't specialise these
                                     -- See Note [Avoiding recursive specialisation]
            -> RuleBase              -- Rules from this module
            -> Id -> [CallInfo]      -- Imported function and calls for it
            -> CoreM ( [CoreRule]    -- New rules
                     , [CoreBind] )  -- Specialised bindings
-specImport done rb fn calls_for_fn
+specImport dflags done rb fn calls_for_fn
   | fn `elemVarSet` done
   = return ([], [])     -- No warning.  This actually happens all the time
                         -- when specialising a recursive function, becuase
@@ -635,7 +640,7 @@ specImport done rb fn calls_for_fn
        ; let full_rb = unionRuleBase rb (eps_rule_base eps)
              rules_for_fn = getRules full_rb fn
 
-       ; (rules1, spec_pairs, uds) <- runSpecM $
+       ; (rules1, spec_pairs, uds) <- runSpecM dflags $
               specCalls emptySubst rules_for_fn calls_for_fn fn rhs
        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
              -- After the rules kick in we may get recursion, but
@@ -643,9 +648,9 @@ specImport done rb fn calls_for_fn
              -- See Note [Glom the bindings if imported functions are specialised]
 
               -- Now specialise any cascaded calls
-       ; (rules2, spec_binds2) <- specImports (extendVarSet done fn)
-                                              (extendRuleBaseList rb rules1)
-                                              uds
+       ; (rules2, spec_binds2) <- specImports dflags (extendVarSet done fn)
+                                                     (extendRuleBaseList rb rules1)
+                                                     uds
 
        ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
 
@@ -1127,10 +1132,11 @@ specCalls subst rules_for_me calls_for_me fn rhs
 
            ; spec_f <- newSpecIdSM fn spec_id_ty
            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
+           ; dflags <- getDynFlags
            ; let
                 -- The rule to put in the function's specialisation is:
                 --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
-                rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args))
+                rule_name = mkFastString ("SPEC " ++ showSDocDump dflags (ppr fn <+> ppr spec_ty_args))
                 spec_env_rule = mkRule True {- Auto generated -} is_local
                                   rule_name
                                   inl_act       -- Note [Auto-specialisation and RULES]
@@ -1782,11 +1788,39 @@ deleteCallsFor bs calls = delVarEnvList calls bs
 %************************************************************************
 
 \begin{code}
-type SpecM a = UniqSM a
-
-runSpecM:: SpecM a -> CoreM a
-runSpecM spec = do { us <- getUniqueSupplyM
-                   ; return (initUs_ us spec) }
+newtype SpecM a = SpecM (State SpecState a)
+
+data SpecState = SpecState {
+                     spec_uniq_supply :: UniqSupply,
+                     spec_dflags :: DynFlags
+                 }
+
+instance Monad SpecM where
+    SpecM x >>= f = SpecM $ do y <- x
+                               case f y of
+                                   SpecM z ->
+                                       z
+    return x = SpecM $ return x
+    fail str = SpecM $ fail str
+
+instance MonadUnique SpecM where
+    getUniqueSupplyM
+        = SpecM $ do st <- get
+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st
+                     put $ st { spec_uniq_supply = us2 }
+                     return us1
+
+instance HasDynFlags SpecM where
+    getDynFlags = SpecM $ liftM spec_dflags get
+
+runSpecM :: DynFlags -> SpecM a -> CoreM a
+runSpecM dflags (SpecM spec)
+    = do us <- getUniqueSupplyM
+         let initialState = SpecState {
+                                spec_uniq_supply = us,
+                                spec_dflags = dflags
+                            }
+         return $ evalState spec initialState
 
 mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
 mapAndCombineSM _ []     = return ([], emptyUDs)
index 364786e..c0b77bb 100644 (file)
@@ -388,8 +388,8 @@ showSDocUnqual _ d
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
 
-showSDocDump :: SDoc -> String
-showSDocDump 
+showSDocDump :: DynFlags -> SDoc -> String
+showSDocDump _ d
  = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle))
 
 showSDocDumpOneLine :: SDoc -> String