ghci: Ensure that system libffi include path is searched
[ghc.git] / compiler / codeGen / StgCmmClosure.hs
index 7a9c841..fff2078 100644 (file)
@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP, RecordWildCards #-}
+
 -----------------------------------------------------------------------------
 --
 -- Stg to C-- code generation:
--- 
+--
 -- The types   LambdaFormInfo
 --             ClosureInfo
 --
 --
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE RecordWildCards #-}
-{-# 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
-
 module StgCmmClosure (
         DynTag,  tagForCon, isSmallFamily,
-       ConTagZ, dataConTagZ,
 
         idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
-       argPrimRep,
+        argPrimRep,
+
+        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
+        assertNonVoidIds, assertNonVoidStgArgs,
 
         -- * LambdaFormInfo
         LambdaFormInfo,         -- Abstract
-       StandardFormInfo,       -- ...ditto...
-       mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
-       mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
-        mkLFBlackHole,
+        StandardFormInfo,        -- ...ditto...
+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+        mkLFStringLit,
         lfDynTag,
-        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
+        isLFThunk, isLFReEntrant, lfUpdatable,
 
-        nodeMustPointToIt,
-        CallMethod(..), getCallMethod,
-
-        isKnownFun, funTag, tagForArity,
+        -- * Used by other modules
+        CgLoc(..), SelfLoopInfo, CallMethod(..),
+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,
 
         -- * ClosureInfo
-       ClosureInfo,
+        ClosureInfo,
         mkClosureInfo,
         mkCmmInfo,
 
@@ -49,7 +44,7 @@ module StgCmmClosure (
         -- ** Labels
         -- These just need the info table label
         closureInfoLabel, staticClosureLabel,
-        closureRednCountsLabel, closureSlowEntryLabel, closureLocalEntryLabel,
+        closureSlowEntryLabel, closureLocalEntryLabel,
 
         -- ** Predicates
         -- These are really just functions on LambdaFormInfo
@@ -63,64 +58,133 @@ module StgCmmClosure (
         -- * InfoTables
         mkDataConInfoTable,
         cafBlackHoleInfoTable,
+        indStaticInfoTable,
         staticClosureNeedsLink,
     ) where
 
 #include "../includes/MachDeps.h"
 
-#define FAST_STRING_NOT_NEEDED
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgSyn
 import SMRep
 import Cmm
+import PprCmmExpr()
 
+import CostCentre
+import BlockId
 import CLabel
-import StaticFlags
 import Id
 import IdInfo
 import DataCon
 import Name
 import Type
-import TypeRep
+import TyCoRep
 import TcType
 import TyCon
+import RepType
 import BasicTypes
 import Outputable
-import Constants
 import DynFlags
 import Util
 
+import Data.Coerce (coerce)
+import qualified Data.ByteString.Char8 as BS8
+
+-----------------------------------------------------------------------------
+--                Data types and synonyms
+-----------------------------------------------------------------------------
+
+-- These data types are mostly used by other modules, especially StgCmmMonad,
+-- but we define them here because some functions in this module need to
+-- have access to them as well
+
+data CgLoc
+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
+                        -- Hp, so that it remains valid across calls
+
+  | LneLoc BlockId [LocalReg]             -- A join point
+        -- A join point (= let-no-escape) should only
+        -- be tail-called, and in a saturated way.
+        -- To tail-call it, assign to these locals,
+        -- and branch to the block id
+
+instance Outputable CgLoc where
+  ppr (CmmLoc e)    = text "cmm" <+> ppr e
+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs
+
+type SelfLoopInfo = (Id, BlockId, [LocalReg])
+
+-- used by ticky profiling
+isKnownFun :: LambdaFormInfo -> Bool
+isKnownFun LFReEntrant{} = True
+isKnownFun LFLetNoEscape = True
+isKnownFun _             = False
+
+
+-------------------------------------
+--        Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+  deriving (Eq, Show)
+
+fromNonVoid :: NonVoid a -> a
+fromNonVoid (NonVoid a) = a
+
+instance (Outputable a) => Outputable (NonVoid a) where
+  ppr (NonVoid a) = ppr a
+
+nonVoidIds :: [Id] -> [NonVoid Id]
+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]
+
+-- | Used in places where some invariant ensures that all these Ids are
+-- non-void; e.g. constructor field binders in case expressions.
+-- See Note [Post-unarisation invariants] in UnariseStg.
+assertNonVoidIds :: [Id] -> [NonVoid Id]
+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))
+                       coerce ids
+
+nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]
+
+-- | Used in places where some invariant ensures that all these arguments are
+-- non-void; e.g. constructor arguments.
+-- See Note [Post-unarisation invariants] in UnariseStg.
+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
+                            coerce args
+
+
 -----------------------------------------------------------------------------
---             Representations
+--                Representations
 -----------------------------------------------------------------------------
 
 -- Why are these here?
 
--- NB: this is reliable because by StgCmm no Ids have unboxed tuple type
 idPrimRep :: Id -> PrimRep
-idPrimRep id = typePrimRep (idType id)
+idPrimRep id = typePrimRep1 (idType id)
+    -- NB: typePrimRep1 fails on unboxed tuples,
+    --     but by StgCmm no Ids have unboxed tuple type
 
-addIdReps :: [Id] -> [(PrimRep, Id)]
-addIdReps ids = [(idPrimRep id, id) | id <- ids]
+addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
+addIdReps = map (\id -> let id' = fromNonVoid id
+                         in NonVoid (idPrimRep id', id'))
 
-addArgReps :: [StgArg] -> [(PrimRep, StgArg)]
-addArgReps args = [(argPrimRep arg, arg) | arg <- args]
+addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
+addArgReps = map (\arg -> let arg' = fromNonVoid arg
+                           in NonVoid (argPrimRep arg', arg'))
 
 argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep (stgArgType arg)
-
-isVoidRep :: PrimRep -> Bool
-isVoidRep VoidRep = True
-isVoidRep _other  = False
-
-isGcPtrRep :: PrimRep -> Bool
-isGcPtrRep PtrRep = True
-isGcPtrRep _      = False
+argPrimRep arg = typePrimRep1 (stgArgType arg)
 
 
 -----------------------------------------------------------------------------
---             LambdaFormInfo
+--                LambdaFormInfo
 -----------------------------------------------------------------------------
 
 -- Information about an identifier, from the code generator's point of
@@ -129,81 +193,75 @@ isGcPtrRep _      = False
 -- tail call or return that identifier.
 
 data LambdaFormInfo
-  = LFReEntrant                -- Reentrant closure (a function)
-       TopLevelFlag    -- True if top level
-       !RepArity               -- Arity. Invariant: always > 0
-       !Bool           -- True <=> no fvs
-       ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
-
-  | LFThunk            -- Thunk (zero arity)
-       TopLevelFlag
-       !Bool           -- True <=> no free vars
-       !Bool           -- True <=> updatable (i.e., *not* single-entry)
-       StandardFormInfo
-       !Bool           -- True <=> *might* be a function type
-
-  | LFCon              -- A saturated constructor application
-       DataCon         -- The constructor
-
-  | LFUnknown          -- Used for function arguments and imported things.
-                       -- We know nothing about this closure.  
-                       -- Treat like updatable "LFThunk"...
-                       -- Imported things which we *do* know something about use
-                       -- one of the other LF constructors (eg LFReEntrant for
-                       -- known functions)
-       !Bool           -- True <=> *might* be a function type
-                       --      The False case is good when we want to enter it,
-                       --      because then we know the entry code will do
-                       --      For a function, the entry code is the fast entry point
-
-  | LFUnLifted         -- A value of unboxed type; 
-                       -- always a value, neeeds evaluation
-
-  | LFLetNoEscape      -- See LetNoEscape module for precise description 
-
-  | LFBlackHole                -- Used for the closures allocated to hold the result
-                       -- of a CAF.  We want the target of the update frame to
-                       -- be in the heap, so we make a black hole to hold it.
-
-                        -- XXX we can very nearly get rid of this, but
-                        -- allocDynClosure needs a LambdaFormInfo
+  = LFReEntrant         -- Reentrant closure (a function)
+        TopLevelFlag    -- True if top level
+        OneShotInfo
+        !RepArity       -- Arity. Invariant: always > 0
+        !Bool           -- True <=> no fvs
+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
+
+  | LFThunk             -- Thunk (zero arity)
+        TopLevelFlag
+        !Bool           -- True <=> no free vars
+        !Bool           -- True <=> updatable (i.e., *not* single-entry)
+        StandardFormInfo
+        !Bool           -- True <=> *might* be a function type
+
+  | LFCon               -- A saturated constructor application
+        DataCon         -- The constructor
+
+  | LFUnknown           -- Used for function arguments and imported things.
+                        -- We know nothing about this closure.
+                        -- Treat like updatable "LFThunk"...
+                        -- Imported things which we *do* know something about use
+                        -- one of the other LF constructors (eg LFReEntrant for
+                        -- known functions)
+        !Bool           -- True <=> *might* be a function type
+                        --      The False case is good when we want to enter it,
+                        --        because then we know the entry code will do
+                        --        For a function, the entry code is the fast entry point
+
+  | LFUnlifted          -- A value of unboxed type;
+                        -- always a value, needs evaluation
+
+  | LFLetNoEscape       -- See LetNoEscape module for precise description
 
 
 -------------------------
--- StandardFormInfo tells whether this thunk has one of 
+-- StandardFormInfo tells whether this thunk has one of
 -- a small number of standard forms
 
 data StandardFormInfo
   = NonStandardThunk
-       -- Not of of the standard forms
+        -- The usual case: not of the standard forms
 
   | SelectorThunk
-       -- A SelectorThunk is of form
-       --      case x of
-       --             con a1,..,an -> ak
-       -- and the constructor is from a single-constr type.
-       WordOff                 -- 0-origin offset of ak within the "goods" of 
-                       -- constructor (Recall that the a1,...,an may be laid
-                       -- out in the heap in a non-obvious order.)
-
-  | ApThunk 
-       -- An ApThunk is of form
-       --      x1 ... xn
-       -- The code for the thunk just pushes x2..xn on the stack and enters x1.
-       -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-       -- in the RTS to save space.
-       RepArity                -- Arity, n
+        -- A SelectorThunk is of form
+        --      case x of
+        --           con a1,..,an -> ak
+        -- and the constructor is from a single-constr type.
+       WordOff          -- 0-origin offset of ak within the "goods" of
+                        -- constructor (Recall that the a1,...,an may be laid
+                        -- out in the heap in a non-obvious order.)
+
+  | ApThunk
+        -- An ApThunk is of form
+        --        x1 ... xn
+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+        -- in the RTS to save space.
+        RepArity                -- Arity, n
 
 
 ------------------------------------------------------
---             Building LambdaFormInfo
+--                Building LambdaFormInfo
 ------------------------------------------------------
 
 mkLFArgument :: Id -> LambdaFormInfo
-mkLFArgument id 
-  | isUnLiftedType ty             = LFUnLifted
+mkLFArgument id
+  | isUnliftedType ty      = LFUnlifted
   | might_be_a_function ty = LFUnknown True
-  | otherwise             = LFUnknown False
+  | otherwise              = LFUnknown False
   where
     ty = idType id
 
@@ -212,31 +270,34 @@ mkLFLetNoEscape :: LambdaFormInfo
 mkLFLetNoEscape = LFLetNoEscape
 
 -------------
-mkLFReEntrant :: TopLevelFlag  -- True of top level
-             -> [Id]           -- Free vars
-             -> [Id]           -- Args
-             -> ArgDescr       -- Argument descriptor
-             -> LambdaFormInfo
-
-mkLFReEntrant top fvs args arg_descr 
-  = LFReEntrant top (length args) (null fvs) arg_descr
+mkLFReEntrant :: TopLevelFlag    -- True of top level
+              -> [Id]            -- Free vars
+              -> [Id]            -- Args
+              -> ArgDescr        -- Argument descriptor
+              -> LambdaFormInfo
+
+mkLFReEntrant _ _ [] _
+  = pprPanic "mkLFReEntrant" empty
+mkLFReEntrant top fvs args arg_descr
+  = LFReEntrant top os_info (length args) (null fvs) arg_descr
+  where os_info = idOneShotInfo (head args)
 
 -------------
 mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
 mkLFThunk thunk_ty top fvs upd_flag
-  = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
-    LFThunk top (null fvs) 
-           (isUpdatable upd_flag)
-           NonStandardThunk 
-           (might_be_a_function thunk_ty)
+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
+    LFThunk top (null fvs)
+            (isUpdatable upd_flag)
+            NonStandardThunk
+            (might_be_a_function thunk_ty)
 
 --------------
 might_be_a_function :: Type -> Bool
 -- Return False only if we are *sure* it's a data type
 -- Look through newtypes etc as much as poss
 might_be_a_function ty
-  | UnaryRep rep <- repType ty
-  , Just tc <- tyConAppTyCon_maybe rep
+  | [LiftedRep] <- typePrimRep ty
+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
   , isDataTyCon tc
   = False
   | otherwise
@@ -249,101 +310,87 @@ mkConLFInfo con = LFCon con
 -------------
 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
 mkSelectorLFInfo id offset updatable
-  = LFThunk NotTopLevel False updatable (SelectorThunk offset) 
-       (might_be_a_function (idType id))
+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+        (might_be_a_function (idType id))
 
 -------------
 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
-       (might_be_a_function (idType id))
+        (might_be_a_function (idType id))
 
 -------------
 mkLFImported :: Id -> LambdaFormInfo
 mkLFImported id
   | Just con <- isDataConWorkId_maybe id
   , isNullaryRepDataCon con
-  = LFCon con  -- An imported nullary constructor
-               -- We assume that the constructor is evaluated so that
-               -- the id really does point directly to the constructor
+  = LFCon con   -- An imported nullary constructor
+                -- We assume that the constructor is evaluated so that
+                -- the id really does point directly to the constructor
 
   | arity > 0
-  = LFReEntrant TopLevel arity True (panic "arg_descr")
+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
 
   | otherwise
   = mkLFArgument id -- Not sure of exact arity
   where
-    arity = idRepArity id
+    arity = idFunRepArity id
 
-------------
-mkLFBlackHole :: LambdaFormInfo
-mkLFBlackHole = LFBlackHole
+-------------
+mkLFStringLit :: LambdaFormInfo
+mkLFStringLit = LFUnlifted
 
 -----------------------------------------------------
---             Dynamic pointer tagging
+--                Dynamic pointer tagging
 -----------------------------------------------------
 
-type ConTagZ = Int     -- A *zero-indexed* contructor tag
-
-type DynTag = Int      -- The tag on a *pointer*
-                       -- (from the dynamic-tagging paper)
+type DynTag = Int       -- The tag on a *pointer*
+                        -- (from the dynamic-tagging paper)
 
-{-     Note [Data constructor dynamic tags]
-       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The family size of a data type (the number of constructors
-or the arity of a function) can be either:
-    * small, if the family size < 2**tag_bits
-    * big, otherwise.
-
-Small families can have the constructor tag in the tag bits.
-Big families only use the tag value 1 to represent evaluatedness.
-We don't have very many tag bits: for example, we have 2 bits on
-x86-32 and 3 bits on x86-64. -}
-
-isSmallFamily :: Int -> Bool
-isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
-
--- We keep the *zero-indexed* tag in the srt_len field of the info
--- table of a data constructor.
-dataConTagZ :: DataCon -> ConTagZ
-dataConTagZ con = dataConTag con - fIRST_TAG
-
-tagForCon :: DataCon -> DynTag
-tagForCon con 
-  | isSmallFamily fam_size = con_tag + 1
-  | otherwise             = 1
+-- Note [Data constructor dynamic tags]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The family size of a data type (the number of constructors
+-- or the arity of a function) can be either:
+--    * small, if the family size < 2**tag_bits
+--    * big, otherwise.
+--
+-- Small families can have the constructor tag in the tag bits.
+-- Big families only use the tag value 1 to represent evaluatedness.
+-- We don't have very many tag bits: for example, we have 2 bits on
+-- x86-32 and 3 bits on x86-64.
+
+isSmallFamily :: DynFlags -> Int -> Bool
+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
+
+tagForCon :: DynFlags -> DataCon -> DynTag
+tagForCon dflags con
+  | isSmallFamily dflags fam_size = con_tag
+  | otherwise                     = 1
   where
-    con_tag  = dataConTagZ con
+    con_tag  = dataConTag con -- NB: 1-indexed
     fam_size = tyConFamilySize (dataConTyCon con)
 
-tagForArity :: RepArity -> DynTag
-tagForArity arity | isSmallFamily arity = arity
-                  | otherwise           = 0
+tagForArity :: DynFlags -> RepArity -> DynTag
+tagForArity dflags arity
+ | isSmallFamily dflags arity = arity
+ | otherwise                  = 0
 
-lfDynTag :: LambdaFormInfo -> DynTag
+lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
 -- Return the tag in the low order bits of a variable bound
 -- to this LambdaForm
-lfDynTag (LFCon con)               = tagForCon con
-lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
-lfDynTag _other                    = 0
+lfDynTag dflags (LFCon con)                 = tagForCon dflags con
+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
+lfDynTag _      _other                      = 0
 
 
 -----------------------------------------------------------------------------
---             Observing LambdaFormInfo
+--                Observing LambdaFormInfo
 -----------------------------------------------------------------------------
 
--------------
-maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
-maybeIsLFCon (LFCon con) = Just con
-maybeIsLFCon _ = Nothing
-
 ------------
 isLFThunk :: LambdaFormInfo -> Bool
 isLFThunk (LFThunk {})  = True
-isLFThunk LFBlackHole   = True
-       -- return True for a blackhole: this function is used to determine
-       -- whether to use the thunk header in SMP mode, and a blackhole
-       -- must have one.
 isLFThunk _ = False
 
 isLFReEntrant :: LambdaFormInfo -> Bool
@@ -351,18 +398,18 @@ isLFReEntrant (LFReEntrant {}) = True
 isLFReEntrant _                = False
 
 -----------------------------------------------------------------------------
---             Choosing SM reps
+--                Choosing SM reps
 -----------------------------------------------------------------------------
 
 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
-lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
-lfClosureType (LFCon con)                  = Constr (fromIntegral (dataConTagZ con))
+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
                                                       (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _)            = thunkClosureType is_sel
-lfClosureType _                           = panic "lfClosureType"
+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
+lfClosureType _                              = panic "lfClosureType"
 
 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
-thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
+thunkClosureType (SelectorThunk off) = ThunkSelector off
 thunkClosureType _                   = Thunk
 
 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
@@ -371,141 +418,186 @@ thunkClosureType _                   = Thunk
 -- to FUN_STATIC in this case.
 
 -----------------------------------------------------------------------------
---             nodeMustPointToIt
+--                nodeMustPointToIt
 -----------------------------------------------------------------------------
 
--- Be sure to see the stg-details notes about these...
-
 nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
-nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
-  = not no_fvs ||   -- Certainly if it has fvs we need to point to it
-    isNotTopLevel top
-                   -- If it is not top level we will point to it
-                   --   We can have a \r closure with no_fvs which
-                   --   is not top level as special case cgRhsClosure
-                   --   has been dissabled in favour of let floating
-
-               -- For lex_profiling we also access the cost centre for a
-               -- non-inherited function i.e. not top level
-               -- the  not top  case above ensures this is ok.
+-- If nodeMustPointToIt is true, then the entry convention for
+-- this closure has R1 (the "Node" register) pointing to the
+-- closure itself --- the "self" argument
+
+nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
+  =  not no_fvs          -- Certainly if it has fvs we need to point to it
+  || isNotTopLevel top   -- See Note [GC recovery]
+        -- For lex_profiling we also access the cost centre for a
+        -- non-inherited (i.e. non-top-level) function.
+        -- The isNotTopLevel test above ensures this is ok.
+
+nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
+  =  not no_fvs            -- Self parameter
+  || isNotTopLevel top     -- Note [GC recovery]
+  || updatable             -- Need to push update frame
+  || gopt Opt_SccProfilingOn dflags
+          -- For the non-updatable (single-entry case):
+          --
+          -- True if has fvs (in which case we need access to them, and we
+          --                    should black-hole it)
+          -- or profiling (in which case we need to recover the cost centre
+          --                 from inside it)  ToDo: do we need this even for
+          --                                    top-level thunks? If not,
+          --                                    isNotTopLevel subsumes this
+
+nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk
+  = True
 
 nodeMustPointToIt _ (LFCon _) = True
 
-       -- Strictly speaking, the above two don't need Node to point
-       -- to it if the arity = 0.  But this is a *really* unlikely
-       -- situation.  If we know it's nil (say) and we are entering
-       -- it. Eg: let x = [] in x then we will certainly have inlined
-       -- x, since nil is a simple atom.  So we gain little by not
-       -- having Node point to known zero-arity things.  On the other
-       -- hand, we do lose something; Patrick's code for figuring out
-       -- when something has been updated but not entered relies on
-       -- having Node point to the result of an update.  SLPJ
-       -- 27/11/92.
-
-nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _)
-  = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
-         -- For the non-updatable (single-entry case):
-         --
-         -- True if has fvs (in which case we need access to them, and we
-         --                should black-hole it)
-         -- or profiling (in which case we need to recover the cost centre
-         --             from inside it)
-
-nodeMustPointToIt _ (LFThunk {})       -- Node must point to a standard-form thunk
-  = True 
+        -- Strictly speaking, the above two don't need Node to point
+        -- to it if the arity = 0.  But this is a *really* unlikely
+        -- situation.  If we know it's nil (say) and we are entering
+        -- it. Eg: let x = [] in x then we will certainly have inlined
+        -- x, since nil is a simple atom.  So we gain little by not
+        -- having Node point to known zero-arity things.  On the other
+        -- hand, we do lose something; Patrick's code for figuring out
+        -- when something has been updated but not entered relies on
+        -- having Node point to the result of an update.  SLPJ
+        -- 27/11/92.
 
 nodeMustPointToIt _ (LFUnknown _)   = True
-nodeMustPointToIt _ LFUnLifted      = False
-nodeMustPointToIt _ LFBlackHole     = True    -- BH entry may require Node to point
-nodeMustPointToIt _ LFLetNoEscape   = False 
+nodeMustPointToIt _ LFUnlifted      = False
+nodeMustPointToIt _ LFLetNoEscape   = False
+
+{- Note [GC recovery]
+~~~~~~~~~~~~~~~~~~~~~
+If we a have a local let-binding (function or thunk)
+   let f = <body> in ...
+AND <body> allocates, then the heap-overflow check needs to know how
+to re-start the evaluation.  It uses the "self" pointer to do this.
+So even if there are no free variables in <body>, we still make
+nodeMustPointToIt be True for non-top-level bindings.
+
+Why do any such bindings exist?  After all, let-floating should have
+floated them out.  Well, a clever optimiser might leave one there to
+avoid a space leak, deliberately recomputing a thunk.  Also (and this
+really does happen occasionally) let-floating may make a function f smaller
+so it can be inlined, so now (f True) may generate a local no-fv closure.
+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
+in TcGenDeriv.) -}
 
 -----------------------------------------------------------------------------
---             getCallMethod
+--                getCallMethod
 -----------------------------------------------------------------------------
 
 {- The entry conventions depend on the type of closure being entered,
 whether or not it has free variables, and whether we're running
 sequentially or in parallel.
 
-Closure                              Node   Argument   Enter
-Characteristics                Par   Req'd  Passing    Via
--------------------------------------------------------------------------------
-Unknown                        & no & yes & stack      & node
-Known fun (>1 arg), no fvs     & no & no  & registers  & fast entry (enough args)
-                                                       & slow entry (otherwise)
-Known fun (>1 arg), fvs                & no & yes & registers  & fast entry (enough args)
-0 arg, no fvs \r,\s            & no & no  & n/a        & direct entry
-0 arg, no fvs \u               & no & yes & n/a        & node
-0 arg, fvs \r,\s               & no & yes & n/a        & direct entry
-0 arg, fvs \u                  & no & yes & n/a        & node
-
-Unknown                        & yes & yes & stack     & node
-Known fun (>1 arg), no fvs     & yes & no  & registers & fast entry (enough args)
-                                                       & slow entry (otherwise)
-Known fun (>1 arg), fvs                & yes & yes & registers & node
-0 arg, no fvs \r,\s            & yes & no  & n/a       & direct entry 
-0 arg, no fvs \u               & yes & yes & n/a       & node
-0 arg, fvs \r,\s               & yes & yes & n/a       & node
-0 arg, fvs \u                  & yes & yes & n/a       & node
-\end{tabular}
+Closure                           Node   Argument   Enter
+Characteristics              Par   Req'd  Passing    Via
+---------------------------------------------------------------------------
+Unknown                     & no  & yes & stack     & node
+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)
+                                                    & slow entry (otherwise)
+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)
+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry
+0 arg, no fvs \u            & no  & yes & n/a       & node
+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node
+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry
+0 arg, fvs \u               & no  & yes & n/a       & node
+Unknown                     & yes & yes & stack     & node
+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)
+                                                    & slow entry (otherwise)
+Known fun (>1 arg), fvs     & yes & yes & registers & node
+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node
+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry
+0 arg, no fvs \u            & yes & yes & n/a       & node
+0 arg, fvs \r,\s            & yes & yes & n/a       & node
+0 arg, fvs \u               & yes & yes & n/a       & node
 
 When black-holing, single-entry closures could also be entered via node
 (rather than directly) to catch double-entry. -}
 
 data CallMethod
-  = EnterIt            -- No args, not a function
+  = EnterIt             -- No args, not a function
 
-  | JumpToIt           -- A join point 
+  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
 
-  | ReturnIt           -- It's a value (function, unboxed value,
-                       -- or constructor), so just return it.
+  | ReturnIt            -- It's a value (function, unboxed value,
+                        -- or constructor), so just return it.
 
-  | SlowCall           -- Unknown fun, or known fun with
-                       -- too few args.
+  | SlowCall                -- Unknown fun, or known fun with
+                        -- too few args.
 
-  | DirectEntry        -- Jump directly, with args in regs
-       CLabel          --   The code label
-       RepArity                --   Its arity
+  | DirectEntry         -- Jump directly, with args in regs
+        CLabel          --   The code label
+        RepArity        --   Its arity
 
 getCallMethod :: DynFlags
               -> Name           -- Function being applied
-              -> CafInfo        -- Can it refer to CAF's?
-             -> LambdaFormInfo -- Its info
-             -> RepArity               -- Number of available arguments
-             -> CallMethod
-
-getCallMethod dflags _name _ lf_info _n_args
-  | nodeMustPointToIt dflags lf_info && dopt Opt_Parallel dflags
-  =    -- If we're parallel, then we must always enter via node.  
-       -- The reason is that the closure may have been         
-       -- fetched since we allocated it.
-    EnterIt
-
-getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
-  | n_args == 0    = ASSERT( arity /= 0 )
-                    ReturnIt   -- No args at all
-  | n_args < arity = SlowCall  -- Not enough args
-  | otherwise      = DirectEntry (enterIdLabel name caf) arity
-
-getCallMethod _ _name _ LFUnLifted n_args
+              -> Id             -- Function Id used to chech if it can refer to
+                                -- CAF's and whether the function is tail-calling
+                                -- itself
+              -> LambdaFormInfo -- Its info
+              -> RepArity       -- Number of available arguments
+              -> RepArity       -- Number of them being void arguments
+              -> CgLoc          -- Passed in from cgIdApp so that we can
+                                -- handle let-no-escape bindings and self-recursive
+                                -- tail calls using the same data constructor,
+                                -- JumpToIt. This saves us one case branch in
+                                -- cgIdApp
+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
+              -> CallMethod
+
+getCallMethod dflags _ id _ n_args v_args _cg_loc
+              (Just (self_loop_id, block_id, args))
+  | gopt Opt_Loopification dflags
+  , id == self_loop_id
+  , args `lengthIs` (n_args - v_args)
+  -- If these patterns match then we know that:
+  --   * loopification optimisation is turned on
+  --   * function is performing a self-recursive call in a tail position
+  --   * number of non-void parameters of the function matches functions arity.
+  -- See Note [Self-recursive tail calls] and Note [Void arguments in
+  -- self-recursive tail calls] in StgCmmExpr for more details
+  = JumpToIt block_id args
+
+getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+              _self_loop_info
+  | n_args == 0 -- No args at all
+  && not (gopt Opt_SccProfilingOn dflags)
+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
+  = ASSERT( arity /= 0 ) ReturnIt
+  | n_args < arity = SlowCall        -- Not enough args
+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
+
+getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
   = ASSERT( n_args == 0 ) ReturnIt
 
-getCallMethod _ _name _ (LFCon _) n_args
+getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
   = ASSERT( n_args == 0 ) ReturnIt
+    -- n_args=0 because it'd be ill-typed to apply a saturated
+    --          constructor application to anything
 
-getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
-  | is_fun     -- it *might* be a function, so we must "call" it (which is always safe)
-  = SlowCall   -- We cannot just enter it [in eval/apply, the entry code
-               -- is the fast-entry code]
+getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+              n_args _v_args _cg_loc _self_loop_info
+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
+                -- is the fast-entry code]
 
   -- Since is_fun is False, we are *definitely* looking at a data value
-  | updatable || doingTickyProfiling dflags -- to catch double entry
+  | updatable || gopt Opt_Ticky dflags -- to catch double entry
       {- OLD: || opt_SMP
-        I decided to remove this, because in SMP mode it doesn't matter
-        if we enter the same thunk multiple times, so the optimisation
-        of jumping directly to the entry code is still valid.  --SDM
-       -}
+         I decided to remove this, because in SMP mode it doesn't matter
+         if we enter the same thunk multiple times, so the optimisation
+         of jumping directly to the entry code is still valid.  --SDM
+        -}
   = EnterIt
+
+  -- even a non-updatable selector thunk can be updated by the garbage
+  -- collector, so we must enter it. (#8817)
+  | SelectorThunk{} <- std_form_info
+  = EnterIt
+
     -- We used to have ASSERT( n_args == 0 ), but actually it is
     -- possible for the optimiser to generate
     --   let bot :: Int = error Int "urk"
@@ -513,115 +605,23 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg
     -- This happens as a result of the case-of-error transformation
     -- So the right thing to do is just to enter the thing
 
-  | otherwise  -- Jump direct to code for single-entry thunks
+  | otherwise        -- Jump direct to code for single-entry thunks
   = ASSERT( n_args == 0 )
-    DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0
+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
+                updatable) 0
 
-getCallMethod _ _name _ (LFUnknown True) _n_args
+getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
   = SlowCall -- might be a function
 
-getCallMethod _ name _ (LFUnknown False) n_args
-  = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) 
+getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
     EnterIt -- Not a function
 
-getCallMethod _ _name _ LFBlackHole _n_args
-  = SlowCall   -- Presumably the black hole has by now
-               -- been updated, but we don't know with
-               -- what, so we slow call it
+getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
+              _self_loop_info
+  = JumpToIt blk_id lne_regs
 
-getCallMethod _ _name _ LFLetNoEscape _n_args
-  = JumpToIt
-
-isKnownFun :: LambdaFormInfo -> Bool
-isKnownFun (LFReEntrant _ _ _ _) = True
-isKnownFun LFLetNoEscape        = True
-isKnownFun _ = False
-
------------------------------------------------------------------------------
---             staticClosureRequired
------------------------------------------------------------------------------
-
-{-  staticClosureRequired is never called (hence commented out)
-
-    SimonMar writes (Sept 07) It's an optimisation we used to apply at
-    one time, I believe, but it got lost probably in the rewrite of
-    the RTS/code generator.  I left that code there to remind me to
-    look into whether it was worth doing sometime
-
-{- Avoiding generating entries and info tables
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At present, for every function we generate all of the following,
-just in case.  But they aren't always all needed, as noted below:
-
-[NB1: all of this applies only to *functions*.  Thunks always
-have closure, info table, and entry code.]
-
-[NB2: All are needed if the function is *exported*, just to play safe.]
-
-* Fast-entry code  ALWAYS NEEDED
-
-* Slow-entry code
-       Needed iff (a) we have any un-saturated calls to the function
-       OR         (b) the function is passed as an arg
-       OR         (c) we're in the parallel world and the function has free vars
-                       [Reason: in parallel world, we always enter functions
-                       with free vars via the closure.]
-
-* The function closure
-       Needed iff (a) we have any un-saturated calls to the function
-       OR         (b) the function is passed as an arg
-       OR         (c) if the function has free vars (ie not top level)
-
-  Why case (a) here?  Because if the arg-satis check fails,
-  UpdatePAP stuffs a pointer to the function closure in the PAP.
-  [Could be changed; UpdatePAP could stuff in a code ptr instead,
-   but doesn't seem worth it.]
-
-  [NB: these conditions imply that we might need the closure
-  without the slow-entry code.  Here's how.
-
-       f x y = let g w = ...x..y..w...
-               in
-               ...(g t)...
-
-  Here we need a closure for g which contains x and y,
-  but since the calls are all saturated we just jump to the
-  fast entry point for g, with R1 pointing to the closure for g.]
-
-
-* Standard info table
-       Needed iff (a) we have any un-saturated calls to the function
-       OR         (b) the function is passed as an arg
-       OR         (c) the function has free vars (ie not top level)
-
-       NB.  In the sequential world, (c) is only required so that the function closure has
-       an info table to point to, to keep the storage manager happy.
-       If (c) alone is true we could fake up an info table by choosing
-       one of a standard family of info tables, whose entry code just
-       bombs out.
-
-       [NB In the parallel world (c) is needed regardless because
-       we enter functions with free vars via the closure.]
-
-       If (c) is retained, then we'll sometimes generate an info table
-       (for storage mgr purposes) without slow-entry code.  Then we need
-       to use an error label in the info table to substitute for the absent
-       slow entry code.
--}
-
-staticClosureRequired
-       :: Name
-       -> StgBinderInfo
-       -> LambdaFormInfo
-       -> Bool
-staticClosureRequired binder bndr_info
-                     (LFReEntrant top_level _ _ _)     -- It's a function
-  = ASSERT( isTopLevel top_level )
-       -- Assumption: it's a top-level, no-free-var binding
-       not (satCallsOnly bndr_info)
-
-staticClosureRequired binder other_binder_info other_lf_info = True
--}
+getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
 
 -----------------------------------------------------------------------------
 --              Data types for closure information
@@ -641,7 +641,7 @@ staticClosureRequired binder other_binder_info other_lf_info = True
      a) to construct the info table itself, and build other things
         related to the binding (e.g. slow entry points for a function)
      b) to allocate a closure containing that info pointer (i.e.
-       it knows the info table label)
+           it knows the info table label)
 -}
 
 data ClosureInfo
@@ -661,31 +661,33 @@ data ClosureInfo
     }
 
 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
-mkCmmInfo :: ClosureInfo -> CmmInfoTable
-mkCmmInfo ClosureInfo {..}
+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
+mkCmmInfo ClosureInfo {..} id ccs
   = CmmInfoTable { cit_lbl  = closureInfoLabel
                  , cit_rep  = closureSMRep
                  , cit_prof = closureProf
-                 , cit_srt  = NoC_SRT }
-
+                 , cit_srt  = Nothing
+                 , cit_clo  = if isStaticRep closureSMRep
+                                then Just (id,ccs)
+                                else Nothing }
 
 --------------------------------------
---     Building ClosureInfos
+--        Building ClosureInfos
 --------------------------------------
 
 mkClosureInfo :: DynFlags
-              -> Bool          -- Is static
-             -> Id
-             -> LambdaFormInfo 
-             -> Int -> Int     -- Total and pointer words
+              -> Bool                -- Is static
+              -> Id
+              -> LambdaFormInfo
+              -> Int -> Int        -- Total and pointer words
               -> String         -- String descriptor
-             -> ClosureInfo
+              -> ClosureInfo
 mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
-  = ClosureInfo { closureName      = name,
-                  closureLFInfo    = lf_info,
-                  closureInfoLabel = info_lbl,  -- These three fields are
-                  closureSMRep     = sm_rep,    -- (almost) an info table
-                  closureProf      = prof }     -- (we don't have an SRT yet)
+  = ClosureInfo { closureName      = name
+                , closureLFInfo    = lf_info
+                , closureInfoLabel = info_lbl   -- These three fields are
+                , closureSMRep     = sm_rep     -- (almost) an info table
+                , closureProf      = prof }     -- (we don't have an SRT yet)
   where
     name       = idName id
     sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
@@ -708,25 +710,91 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
 -- need.  We have a patch for this from Andy Cheadle, but not
 -- incorporated yet. --SDM [6/2004]
 --
---
 -- Previously, eager blackholing was enabled when ticky-ticky
--- was on. But it didn't work, and it wasn't strictly necessary 
--- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING 
+-- was on. But it didn't work, and it wasn't strictly necessary
+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
 -- is unconditionally disabled. -- krc 1/2007
-
+--
 -- Static closures are never themselves black-holed.
 
 blackHoleOnEntry :: ClosureInfo -> Bool
 blackHoleOnEntry cl_info
   | isStaticRep (closureSMRep cl_info)
-  = False      -- Never black-hole a static closure
+  = False        -- Never black-hole a static closure
 
   | otherwise
   = case closureLFInfo cl_info of
-       LFReEntrant _ _ _ _       -> False
-       LFLetNoEscape             -> False
-        LFThunk _ _no_fvs _updatable _ _ -> True
-        _other -> panic "blackHoleOnEntry"      -- Should never happen
+      LFReEntrant {}            -> False
+      LFLetNoEscape             -> False
+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
+      _other -> panic "blackHoleOnEntry"
+
+{- Note [Black-holing non-updatable thunks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not black-hole non-updatable (single-entry) thunks otherwise
+we run into issues like #10414. Specifically:
+
+  * There is no reason to black-hole a non-updatable thunk: it should
+    not be competed for by multiple threads
+
+  * It could, conceivably, cause a space leak if we don't black-hole
+    it, if there was a live but never-followed pointer pointing to it.
+    Let's hope that doesn't happen.
+
+  * It is dangerous to black-hole a non-updatable thunk because
+     - is not updated (of course)
+     - hence, if it is black-holed and another thread tries to evaluate
+       it, that thread will block forever
+    This actually happened in #10414.  So we do not black-hole
+    non-updatable thunks.
+
+  * How could two threads evaluate the same non-updatable (single-entry)
+    thunk?  See Reid Barton's example below.
+
+  * Only eager blackholing could possibly black-hole a non-updatable
+    thunk, because lazy black-holing only affects thunks with an
+    update frame on the stack.
+
+Here is and example due to Reid Barton (#10414):
+    x = \u []  concat [[1], []]
+with the following definitions,
+
+    concat x = case x of
+        []       -> []
+        (:) x xs -> (++) x (concat xs)
+
+    (++) xs ys = case xs of
+        []         -> ys
+        (:) x rest -> (:) x ((++) rest ys)
+
+Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
+to WHNF and calls @(++)@ the heap will contain the following thunks,
+
+    x = 1 : y
+    y = \u []  (++) [] z
+    z = \s []  concat []
+
+Now that the stage is set, consider the follow evaluations by two racing threads
+A and B,
+
+  1. Both threads enter @y@ before either is able to replace it with an
+     indirection
+
+  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
+     replacing it with a black-hole
+
+  3. At some later point thread B does the same case analysis and also attempts
+     to enter @z@. However, it finds that it has been replaced with a black-hole
+     so it blocks.
+
+  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
+     accordingly. It does *not* update @z@, however, as it is single-entry. This
+     leaves Thread B blocked forever on a black-hole which will never be
+     updated.
+
+To avoid this sort of condition we never black-hole non-updatable thunks.
+-}
 
 isStaticClosure :: ClosureInfo -> Bool
 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
@@ -736,35 +804,34 @@ closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
 
 lfUpdatable :: LambdaFormInfo -> Bool
 lfUpdatable (LFThunk _ _ upd _ _)  = upd
-lfUpdatable LFBlackHole           = True
-       -- Black-hole closures are allocated to receive the results of an
-       -- alg case with a named default... so they need to be updated.
 lfUpdatable _ = False
 
 closureSingleEntry :: ClosureInfo -> Bool
 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
 closureSingleEntry _ = False
 
 closureReEntrant :: ClosureInfo -> Bool
-closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
 closureReEntrant _ = False
 
 closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
 closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
 
 lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)
-lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
-lfFunInfo _                                 = Nothing
+lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
+lfFunInfo _                                   = Nothing
 
-funTag :: ClosureInfo -> DynTag
-funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info
+funTag :: DynFlags -> ClosureInfo -> DynTag
+funTag dflags (ClosureInfo { closureLFInfo = lf_info })
+    = lfDynTag dflags lf_info
 
 isToplevClosure :: ClosureInfo -> Bool
 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
   = case lf_info of
-      LFReEntrant TopLevel _ _ _ -> True
-      LFThunk TopLevel _ _ _ _   -> True
-      _other                    -> False
+      LFReEntrant TopLevel _ _ _ -> True
+      LFThunk TopLevel _ _ _ _     -> True
+      _other                       -> False
 
 --------------------------------------
 --   Label generation
@@ -773,33 +840,28 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
 staticClosureLabel :: ClosureInfo -> CLabel
 staticClosureLabel = toClosureLbl .  closureInfoLabel
 
-closureRednCountsLabel :: ClosureInfo -> CLabel
-closureRednCountsLabel = toRednCountsLbl . closureInfoLabel
-
 closureSlowEntryLabel :: ClosureInfo -> CLabel
 closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
 
-closureLocalEntryLabel :: ClosureInfo -> CLabel
-closureLocalEntryLabel
-  | tablesNextToCode = toInfoLbl  . closureInfoLabel
-  | otherwise        = toEntryLbl . closureInfoLabel
+closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
+closureLocalEntryLabel dflags
+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel
+  | otherwise               = toEntryLbl . closureInfoLabel
 
 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
 mkClosureInfoTableLabel id lf_info
   = case lf_info of
-        LFBlackHole -> mkCAFBlackHoleInfoTableLabel
-
-       LFThunk _ _ upd_flag (SelectorThunk offset) _ 
+        LFThunk _ _ upd_flag (SelectorThunk offset) _
                       -> mkSelectorInfoLabel upd_flag offset
 
-       LFThunk _ _ upd_flag (ApThunk arity) _ 
+        LFThunk _ _ upd_flag (ApThunk arity) _
                       -> mkApInfoTableLabel upd_flag arity
 
         LFThunk{}     -> std_mk_lbl name cafs
         LFReEntrant{} -> std_mk_lbl name cafs
         _other        -> panic "closureInfoTableLabel"
 
-  where 
+  where
     name = idName id
 
     std_mk_lbl | is_local  = mkLocalInfoTableLabel
@@ -813,30 +875,30 @@ mkClosureInfoTableLabel id lf_info
        -- invariants in CorePrep anything else gets eta expanded.
 
 
-thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
+thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
 -- thunkEntryLabel is a local help function, not exported.  It's used from
 -- getCallMethod.
-thunkEntryLabel _thunk_id _ (ApThunk arity) upd_flag
-  = enterApLabel upd_flag arity
-thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
-  = enterSelectorLabel upd_flag offset
-thunkEntryLabel thunk_id c _ _
-  = enterIdLabel thunk_id c
+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
+  = enterApLabel dflags upd_flag arity
+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
+  = enterSelectorLabel dflags upd_flag offset
+thunkEntryLabel dflags thunk_id c _ _
+  = enterIdLabel dflags thunk_id c
 
-enterApLabel :: Bool -> Arity -> CLabel
-enterApLabel is_updatable arity
-  | tablesNextToCode = mkApInfoTableLabel is_updatable arity
-  | otherwise        = mkApEntryLabel is_updatable arity
+enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
+enterApLabel dflags is_updatable arity
+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
+  | otherwise               = mkApEntryLabel is_updatable arity
 
-enterSelectorLabel :: Bool -> WordOff -> CLabel
-enterSelectorLabel upd_flag offset
-  | tablesNextToCode = mkSelectorInfoLabel upd_flag offset
-  | otherwise        = mkSelectorEntryLabel upd_flag offset
+enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
+enterSelectorLabel dflags upd_flag offset
+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
+  | otherwise               = mkSelectorEntryLabel upd_flag offset
 
-enterIdLabel :: Name -> CafInfo -> CLabel
-enterIdLabel id c
-  | tablesNextToCode = mkInfoTableLabel id c
-  | otherwise        = mkEntryLabel id c
+enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
+enterIdLabel dflags id c
+  | tablesNextToCode dflags = mkInfoTableLabel id c
+  | otherwise               = mkEntryLabel id c
 
 
 --------------------------------------
@@ -854,26 +916,27 @@ enterIdLabel id c
 
 mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
 mkProfilingInfo dflags id val_descr
-  | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
-  | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
   where
-    ty_descr_w8  = stringToWord8s (getTyDescription (idType id))
-    val_descr_w8 = stringToWord8s val_descr
+    ty_descr_w8  = BS8.pack (getTyDescription (idType id))
 
 getTyDescription :: Type -> String
 getTyDescription ty
   = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
     case tau_ty of
-      TyVarTy _                     -> "*"
-      AppTy fun _                   -> getTyDescription fun
-      FunTy _ res                   -> '-' : '>' : fun_result res
-      TyConApp tycon _              -> getOccString tycon
-      ForAllTy _ ty          -> getTyDescription ty
+      TyVarTy _              -> "*"
+      AppTy fun _            -> getTyDescription fun
+      TyConApp tycon _       -> getOccString tycon
+      FunTy {}              -> '-' : fun_result tau_ty
+      ForAllTy _  ty         -> getTyDescription ty
       LitTy n                -> getTyLitDescription n
+      CastTy ty _            -> getTyDescription ty
+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)
     }
   where
-    fun_result (FunTy _ res) = '>' : fun_result res
-    fun_result other        = getTyDescription other
+    fun_result (FunTy { ft_res = res }) = '>' : fun_result res
+    fun_result other                    = getTyDescription other
 
 getTyLitDescription :: TyLit -> String
 getTyLitDescription l =
@@ -890,23 +953,21 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = sm_rep
                 , cit_prof = prof
-                , cit_srt  = NoC_SRT }
+                , cit_srt  = Nothing
+                , cit_clo  = Nothing }
  where
    name = dataConName data_con
-
-   info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs
-            | otherwise = mkConInfoTableLabel    name NoCafRefs
-
+   info_lbl = mkConInfoTableLabel name NoCafRefs
    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
+                  -- We keep the *zero-indexed* tag in the srt_len field
+                  -- of the info table of a data constructor.
 
-   cl_type = Constr (fromIntegral (dataConTagZ data_con))
-                   (dataConIdentity data_con)
-
-   prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
         | otherwise                            = ProfilingInfo ty_descr val_descr
 
-   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
-   val_descr = stringToWord8s $ occNameString $ getOccName data_con
+   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
+   val_descr = BS8.pack $ occNameString $ getOccName data_con
 
 -- We need a black-hole closure info to pass to @allocDynClosure@ when we
 -- want to allocate the black hole on entry to a CAF.
@@ -916,21 +977,24 @@ cafBlackHoleInfoTable
   = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
                  , cit_rep  = blackHoleRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+indStaticInfoTable :: CmmInfoTable
+indStaticInfoTable
+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
+                 , cit_rep  = indStaticRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
 
 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
---     a) it has an SRT
---     b) it's a constructor with one or more pointer fields
+--        a) it has an SRT
+--        b) it's a constructor with one or more pointer fields
 -- In case (b), the constructor's fields themselves play the role
 -- of the SRT.
---
--- At this point, the cit_srt field has not been calculated (that
--- happens right at the end of the Cmm pipeline), but we do have the
--- VarSet of CAFs that CoreToStg attached, and if that is empty there
--- will definitely not be an SRT.
---
 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
   | isConRep smrep         = not (isStaticNoCafCon smrep)
-  | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
+  | otherwise              = has_srt