Improving the performance of breakpoints up to 50% (by playing with laziness)

This patch performs several optimizations with the goal of minimizing the cost of building the arguments to breakpointJump:
  - Group them all in a single tuple, to minimize closure creation in heap
  - Wrap this with the GHC.Base.lazy combinator, to induce max laziness
  - Remove as many literal strings as possible 
    * injecting a module-local CAF to store the module name and use that 
    * eliminating the package string (not needed).

5 files changed, 72 insertions, 46 deletions

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 27d41476e1..2a1f74f339 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -23,6 +23,7 @@ import {-# SOURCE #-}	Match( matchWrapper )
 import DsMonad
 import DsGRHSs
 import DsUtils
+import DsBreakpoint
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
@@ -46,6 +47,10 @@ import BasicTypes hiding ( TopLevel )
 import FastString
 import Util		( mapSnd )
 
+import Name
+import OccName
+import Literal
+
 import Control.Monad
 import Data.List
 \end{code}
@@ -58,7 +63,21 @@ import Data.List
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do
+  mb_mod_name_ref <- getModNameRefDs
+  case mb_mod_name_ref of 
+    Just _  -> ds_lhs_binds auto_scc binds
+    Nothing -> do  -- Inject a CAF with the module name as literal
+      mod <- getModuleDs
+      mod_name_ref <- do
+                 u <- newUnique 
+                 let n = mkSystemName u (mkVarOcc "_module")
+                 return (mkLocalId n stringTy)
+      let mod_name = moduleNameFS$ moduleName mod
+      mod_lit <- dsExpr (HsLit (HsString mod_name))
+      withModNameRefDs mod_name_ref $ do
+                 res <- ds_lhs_binds auto_scc binds
+                 return$ (mod_name_ref, mod_lit) : res
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
 dsLHsBinds binds = ds_lhs_binds NoSccs binds
diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 07b3ec91c7..0282d6dbdb 100644
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -7,8 +7,8 @@
 -----------------------------------------------------------------------------
 
 \begin{code}
-module DsBreakpoint( 
-                     dsAndThenMaybeInsertBreakpoint
+module DsBreakpoint( debug_enabled
+                   , dsAndThenMaybeInsertBreakpoint
                    , maybeInsertBreakpoint
                    , breakpoints_enabled
                    , mkBreakpointExpr
@@ -18,7 +18,6 @@ import TysPrim
 import TysWiredIn
 import PrelNames        
 import Module
-import PackageConfig
 import SrcLoc
 import TyCon
 import TypeRep
@@ -47,14 +46,14 @@ import Control.Monad
 import Data.IORef
 import Foreign.StablePtr
 import GHC.Exts
+
 #ifdef GHCI
 mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id)
 mkBreakpointExpr loc bkptFuncId ty = do
         scope <- getScope
         mod   <- getModuleDs
         u     <- newUnique
-        let mod_name = moduleNameFS$ moduleName mod
-            valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc 
+        let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc 
         when (not instrumenting) $
               warnDs (text "Extracted ids:" <+> (ppr scope $$ 
                                                    ppr (map idType scope)))
@@ -64,6 +63,7 @@ mkBreakpointExpr loc bkptFuncId ty = do
                         else return 0
         ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
         jumpFuncId         <- mkJumpFunc bkptFuncId
+        Just mod_name_ref  <- getModNameRefDs 
         let [opaqueDataCon] = tyConDataCons opaqueTyCon
             opaqueId = dataConWrapId opaqueDataCon
             opaqueTy = mkTyConApp opaqueTyCon []
@@ -73,22 +73,24 @@ mkBreakpointExpr loc bkptFuncId ty = do
            -- Yes, I know... I'm gonna burn in hell.
             Ptr addr# = castStablePtrToPtr stablePtr
             locals    = ExplicitList opaqueTy (map wrapInOpaque scope)
-            locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod))
-                              , HsLit (HsString mod_name)
+            locInfo = nlTuple [ HsVar mod_name_ref
                               , HsLit (HsInt (fromIntegral site))]
             funE  = l$ HsVar jumpFuncId
-            ptrE  = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
-            locsE = l (HsApp (l(HsWrap (WpTyApp (mkListTy opaqueTy)) (HsVar lazyId))) 
-                             (l locals))
-            locE  = l locInfo
-            msgE  = l (srcSpanLit loc)
-        return $  
-            l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `HsApp` locE) `HsApp` msgE)        
+            ptrE  = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#)))))
+            locE  = locInfo
+            msgE  = srcSpanLit loc
+            argsE = nlTuple [ptrE, locals, msgE]
+            lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE)
+            argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy]
+        return $ 
+            l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE)
+
     where l = L loc
           nlTuple exps = ExplicitTuple (map noLoc exps) Boxed
           srcSpanLit :: SrcSpan -> HsExpr Id
           srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
           instrumenting = idName bkptFuncId == breakpointAutoName
+          mkTupleType tys = mkTupleTy Boxed (length tys) tys
 #else
 mkBreakpointExpr = undefined    -- A stage1 ghc doesn't care about breakpoints
 #endif
@@ -139,14 +141,12 @@ mkJumpFunc bkptFuncId
   where 
         tyvar = alphaTyVar
         basicType extra opaqueTy = 
-                           (FunTy intTy
-                            (FunTy (mkListTy opaqueTy)
-                             (FunTy (mkTupleType [stringTy, stringTy, intTy])
-                              (FunTy stringTy
+               (FunTy (mkTupleType [stringTy, intTy])
+                 (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy])
                           (ForAllTy tyvar
                                (extra
                                 (FunTy (TyVarTy tyvar)
-                                 (TyVarTy tyvar))))))))
+                                 (TyVarTy tyvar))))))
         build name extra  = do 
             ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
             return$ Id.mkGlobalId VanillaGlobal name
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index d3dd0e110f..9251a818ee 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -23,7 +23,7 @@ module DsMonad (
 
 	DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
-        bindLocalsDs, getLocalBindsDs, getBkptSitesDs,
+        bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs,
 	-- Warnings
 	DsWarning, warnDs, failWithDs,
 
@@ -144,7 +144,9 @@ data DsGblEnv = DsGblEnv {
 data DsLclEnv = DsLclEnv {
 	ds_meta	   :: DsMetaEnv,	-- Template Haskell bindings
 	ds_loc	   :: SrcSpan,		-- to put in pattern-matching error msgs
-        ds_locals  :: OccEnv Id         -- For locals in breakpoints
+        ds_locals  :: OccEnv Id,        -- For locals in breakpoints
+        ds_mod_name_ref :: Maybe Id     -- The Id used to store the Module name 
+                                        --  used by the breakpoint desugaring 
      }
 
 -- Inside [| |] brackets, the desugarer looks 
@@ -211,7 +213,8 @@ mkDsEnvs mod rdr_env type_env msg_var
                                     ds_bkptSites = sites_var}
                lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
 			            ds_loc = noSrcSpan,
-                                    ds_locals = emptyOccEnv }
+                                    ds_locals = emptyOccEnv,
+                                    ds_mod_name_ref = Nothing }
 
        return (gbl_env, lcl_env)
 
@@ -337,6 +340,13 @@ dsExtendMetaEnv menv thing_inside
 getLocalBindsDs :: DsM [Id]
 getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
 
+getModNameRefDs :: DsM (Maybe Id)
+getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) }
+
+withModNameRefDs :: Id -> DsM a -> DsM a
+withModNameRefDs id thing_inside =
+    updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside
+
 bindLocalsDs :: [Id] -> DsM a -> DsM a
 bindLocalsDs new_ids enclosed_scope = 
     updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs
index fccf1a83c7..c4318ca448 100644
--- a/compiler/main/Breakpoints.hs
+++ b/compiler/main/Breakpoints.hs
@@ -46,9 +46,9 @@ noDbgSites = []
 #ifdef GHCI

 lookupBogusBreakpointVal :: Name -> Maybe HValue

 lookupBogusBreakpointVal name 

-  | name == breakpointJumpName     = Just$ unsafeCoerce# (\_ _ _ _ a->a)

-  | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ _ _ a->a)

-  | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ _ _ a->a)

+  | name == breakpointJumpName     = Just$ unsafeCoerce# (\_ _ a->a)

+  | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ a->a)

+  | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ a->a)

   | otherwise = Nothing

 #else 

 lookupBogusBreakpointVal _ = Nothing

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 52212d6b6a..2167035c9d 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -255,7 +255,7 @@ import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module
 import UniqFM
-import PackageConfig    ( PackageId, stringToPackageId )
+import PackageConfig    ( PackageId, stringToPackageId, mainPackageId )
 import FiniteMap
 import Panic
 import Digraph
@@ -2258,44 +2258,41 @@ reinstallBreakpointHandlers session = do
 -----------------------------------------------------------------------
 -- Jump functions
 
-type SiteInfo = (String, String, SiteNumber)
-jumpFunction, jumpAutoFunction  :: Session -> BkptHandler Module -> Int -> [Opaque] 
-                                -> SiteInfo -> String -> b -> b
-jumpCondFunction  :: Session -> BkptHandler Module -> Int -> [Opaque] 
-                  -> SiteInfo -> String -> Bool -> b -> b
-jumpFunctionM :: Session -> BkptHandler a -> Int -> [Opaque] -> BkptLocation a 
-              -> String -> b -> IO b
+type SiteInfo = (String, SiteNumber)
+jumpFunction, jumpAutoFunction  :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b
+jumpCondFunction  :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b
+jumpFunctionM :: Session -> BkptHandler a ->  BkptLocation a -> (Int, [Opaque], String) -> b -> IO b
 
-jumpCondFunction _ _ _ _ _ _ False b = b
-jumpCondFunction session handler ptr hValues siteInfo locmsg True b
-    = jumpFunction session handler ptr hValues siteInfo locmsg b
+jumpCondFunction _ _ _ _ False b = b
+jumpCondFunction session handler site args True b
+    = jumpFunction session handler site args b
 
-jumpFunction session handler ptr hValues siteInfo locmsg b 
+jumpFunction session handler siteInfo args b 
     | site <- mkSite siteInfo
-    = unsafePerformIO $ jumpFunctionM session handler ptr hValues site locmsg b
+    = unsafePerformIO $ jumpFunctionM session handler site args b
 
-jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b = 
+jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b = 
       do 
          ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
          let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
          handleBreakpoint handler session (zip ids hValues) site locmsg b
 
-jumpAutoFunction session handler ptr hValues siteInfo locmsg b 
+jumpAutoFunction session handler siteInfo args b 
     | site <- mkSite siteInfo
     = unsafePerformIO $ do
          break <- isAutoBkptEnabled handler session site 
          if break 
-            then jumpFunctionM session handler ptr hValues site locmsg b
+            then jumpFunctionM session handler site args b
             else return b
 
-jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b 
+jumpStepByStepFunction session handler siteInfo args b 
     | site <- mkSite siteInfo
     = unsafePerformIO $ do
-          jumpFunctionM session handler ptr hValues site locmsg b
+          jumpFunctionM session handler site args b
 
 mkSite :: SiteInfo -> BkptLocation Module
-mkSite (pkgName, modName, sitenum) =
-  (mkModule (stringToPackageId pkgName) (mkModuleName modName), sitenum)
+mkSite ( modName, sitenum) =
+  (mkModule mainPackageId (mkModuleName modName), sitenum)
 
 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)