Code-size optimisation for top-level indirections (#7308)

Top-level indirections are often generated when there is a cast, e.g.

foo :: T
foo = bar `cast` (some coercion)

For these we were generating a full-blown CAF, which is a fair chunk
of code.

This patch makes these indirections generate a single IND_STATIC
closure (4 words) instead.  This is exactly what the CAF would
evaluate to eventually anyway, we're just shortcutting the whole
process.

6 files changed, 60 insertions, 21 deletions

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index b4e2cd66dd..89b9c4c0df 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -29,6 +29,7 @@ import Panic
 import UniqSupply
 import MonadUtils
 import Util
+import Outputable
 
 import Data.Bits
 import Data.Word
@@ -221,7 +222,7 @@ mkInfoTableContents dflags
                     []          -> mkIntCLit dflags 0
                     (lit:_rest) -> ASSERT( null _rest ) lit
 
-    mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
+    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
 
 mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
 
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index 5f6f33ee8a..6f569ef6fa 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -23,7 +23,7 @@ module SMRep (
         ConstrDescription,
 
         -- ** Construction
-        mkHeapRep, blackHoleRep, mkStackRep, mkRTSRep,
+        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep,
 
         -- ** Predicates
         isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
@@ -163,6 +163,7 @@ data ClosureTypeInfo
   | Thunk
   | ThunkSelector SelectorOffset
   | BlackHole
+  | IndStatic
 
 type ConstrTag         = Int
 type ConstrDescription = [Word8] -- result of dataConIdentity
@@ -219,6 +220,9 @@ mkStackRep liveness = StackRep liveness
 blackHoleRep :: SMRep
 blackHoleRep = HeapRep False 0 0 BlackHole
 
+indStaticRep :: SMRep
+indStaticRep = HeapRep True 1 0 IndStatic
+
 -----------------------------------------------------------------------------
 -- Predicates
 
@@ -240,6 +244,7 @@ isThunkRep :: SMRep -> Bool
 isThunkRep (HeapRep _ _ _ Thunk{})         = True
 isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
 isThunkRep (HeapRep _ _ _ BlackHole{})     = True
+isThunkRep (HeapRep _ _ _ IndStatic{})     = True
 isThunkRep _                               = False
 
 isFunRep :: SMRep -> Bool
@@ -302,6 +307,7 @@ closureTypeHdrSize dflags ty = case ty of
                   Thunk{}         -> thunkHdrSize dflags
                   ThunkSelector{} -> thunkHdrSize dflags
                   BlackHole{}     -> thunkHdrSize dflags
+                  IndStatic{}     -> thunkHdrSize dflags
                   _               -> fixedHdrSize dflags
         -- All thunks use thunkHdrSize, even if they are non-updatable.
         -- this is because we don't have separate closure types for
@@ -354,6 +360,8 @@ rtsClosureType rep
 
       HeapRep False _ _ BlackHole{} -> BLACKHOLE
 
+      HeapRep False _ _ IndStatic{} -> IND_STATIC
+
       _ -> panic "rtsClosureType"
 
 -- We export these ones
@@ -421,6 +429,7 @@ pprTypeInfo (ThunkSelector offset)
 
 pprTypeInfo Thunk     = ptext (sLit "Thunk")
 pprTypeInfo BlackHole = ptext (sLit "BlackHole")
+pprTypeInfo IndStatic = ptext (sLit "IndStatic")
 
 -- XXX Does not belong here!!
 stringToWord8s :: String -> [Word8]
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 944f5aab76..6098e615ae 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -40,6 +40,7 @@ import Module
 import ErrUtils
 import Outputable
 import Stream
+import BasicTypes
 
 import OrdList
 import MkGraph
@@ -117,7 +118,7 @@ variable. -}
 cgTopBinding :: DynFlags -> StgBinding -> FCode ()
 cgTopBinding dflags (StgNonRec id rhs)
   = do  { id' <- maybeExternaliseId dflags id
-        ; (info, fcode) <- cgTopRhs id' rhs
+        ; (info, fcode) <- cgTopRhs NonRecursive id' rhs
         ; fcode
         ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
                                      -- so we find it when we look up occurrences
@@ -127,23 +128,23 @@ cgTopBinding dflags (StgRec pairs)
   = do  { let (bndrs, rhss) = unzip pairs
         ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
         ; let pairs' = zip bndrs' rhss
-        ; r <- sequence $ unzipWith cgTopRhs pairs'
+        ; r <- sequence $ unzipWith (cgTopRhs Recursive) pairs'
         ; let (infos, fcodes) = unzip r
         ; addBindsC infos
         ; sequence_ fcodes
         }
 
 
-cgTopRhs :: Id -> StgRhs -> FCode (CgIdInfo, FCode ())
+cgTopRhs :: RecFlag -> Id -> StgRhs -> FCode (CgIdInfo, FCode ())
         -- The Id is passed along for setting up a binding...
         -- It's already been externalised if necessary
 
-cgTopRhs bndr (StgRhsCon _cc con args)
+cgTopRhs _rec bndr (StgRhsCon _cc con args)
   = forkStatics (cgTopRhsCon bndr con args)
 
-cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
+cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
   = ASSERT(null fvs)    -- There should be no free variables
-    forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
+    forkStatics (cgTopRhsClosure rec bndr cc bi upd_flag args body)
 
 
 ---------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 60eeaa12db..4870455fe2 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -37,6 +37,7 @@ import CLabel
 import StgSyn
 import CostCentre
 import Id
+import IdInfo
 import Name
 import Module
 import ListSetOps
@@ -56,7 +57,8 @@ import Control.Monad
 -- For closures bound at top level, allocate in static space.
 -- They should have no free variables.
 
-cgTopRhsClosure :: Id
+cgTopRhsClosure :: RecFlag              -- member of a recursive group?
+                -> Id
                 -> CostCentreStack      -- Optional cost centre annotation
                 -> StgBinderInfo
                 -> UpdateFlag
@@ -64,19 +66,39 @@ cgTopRhsClosure :: Id
                 -> StgExpr
                 -> FCode (CgIdInfo, FCode ())
 
-cgTopRhsClosure id ccs _ upd_flag args body
+cgTopRhsClosure rec id ccs _ upd_flag args body
  = do { dflags <- getDynFlags
       ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
       ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
             cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)
-      ; return (cg_id_info, gen_code lf_info closure_label)
+      ; return (cg_id_info, gen_code dflags lf_info closure_label)
       }
   where
-  gen_code lf_info closure_label
+  -- special case for a indirection (f = g).  We create an IND_STATIC
+  -- closure pointing directly to the indirectee.  This is exactly
+  -- what the CAF will eventually evaluate to anyway, we're just
+  -- shortcutting the whole process, and generating a lot less code
+  -- (#7308)
+  --
+  -- Note: we omit the optimisation when this binding is part of a
+  -- recursive group, because the optimisation would inhibit the black
+  -- hole detection from working in that case.  Test
+  -- concurrent/should_run/4030 fails, for instance.
+  --
+  gen_code dflags _ closure_label
+    | StgApp f [] <- body, null args, isNonRec rec
+    = do
+         cg_info <- getCgIdInfo f
+         let closure_rep   = mkStaticClosureFields dflags
+                                    indStaticInfoTable ccs MayHaveCafRefs
+                                    [unLit (idInfoToAmode cg_info)]
+         emitDataLits closure_label closure_rep
+         return ()
+
+  gen_code dflags lf_info closure_label
    = do {     -- LAY OUT THE OBJECT
           let name = idName id
         ; mod_name <- getModuleName
-        ; dflags   <- getDynFlags
         ; let descr         = closureDescription dflags mod_name name
               closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
 
@@ -95,6 +117,9 @@ cgTopRhsClosure id ccs _ upd_flag args body
       
         ; return () }
 
+  unLit (CmmLit l) = l
+  unLit _ = panic "unLit"
+
 ------------------------------------------------------------------------
 --              Non-top-level bindings
 ------------------------------------------------------------------------
@@ -719,15 +744,12 @@ link_caf node _is_upd = do
         (CmmReg (CmmLocal node), AddrHint),
         (hp_rel, AddrHint) ]
       False
-        -- node is live, so save it.
 
   -- see Note [atomic CAF entry] in rts/sm/Storage.c
   ; updfr  <- getUpdFrameOff
   ; emit =<< mkCmmIfThen
       (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), CmmLit (zeroCLit dflags)])
-        -- re-enter R1.  Doing this directly is slightly dodgy; we're
-        -- assuming lots of things, like the stack pointer hasn't
-        -- moved since we entered the CAF.
+        -- re-enter the CAF
        (let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) in
         mkJump dflags NativeNodeCall target [] updfr)
 
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index e4c42d203d..7f44f67ff7 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -63,6 +63,7 @@ module StgCmmClosure (
         -- * InfoTables
         mkDataConInfoTable,
         cafBlackHoleInfoTable,
+        indStaticInfoTable,
         staticClosureNeedsLink,
     ) where
 
@@ -915,6 +916,13 @@ cafBlackHoleInfoTable
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
+indStaticInfoTable :: CmmInfoTable
+indStaticInfoTable
+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
+                 , cit_rep  = indStaticRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = NoC_SRT }
+
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
 -- the static closure graph.  But it only needs such a field if either
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 22007bf9fe..5fe3db12c9 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -41,12 +41,10 @@ import SMRep
 import Cmm
 import CmmUtils
 import CostCentre
-import Outputable
 import IdInfo( CafInfo(..), mayHaveCafRefs )
 import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
-import Util
 
 import Control.Monad (when)
 import Data.Maybe (isJust)
@@ -182,8 +180,8 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
     is_caf = isThunkRep (cit_rep info_tbl)
 
     padding
-        | not is_caf = []
-        | otherwise  = ASSERT(null payload) [mkIntCLit dflags 0]
+        | is_caf && null payload = [mkIntCLit dflags 0]
+        | otherwise = []
 
     static_link_field
         | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl