Commit 648fd73a authored by Simon Marlow's avatar Simon Marlow Committed by Simon Marlow

Squash space leaks in the result of byteCodeGen

When loading a large number of modules into GHCi, we collect
CompiledByteCode for every module and then link it all at the end.
Space leaks in the CompiledByteCode linger until we traverse it all for
linking, and possibly longer, if there are bits we don't look at.

This is the nuke-it-from-orbit approach: we deepseq the whole thing
after code generation. It's the only way to be sure.

Test Plan:
Heap profile of GHCi while loading nofib/real/anna into GHCi, this patch
reduces the peak heap usage from ~100M to ~50M.

Reviewers: hvr, austin, bgamari, erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2419
parent c4f3d91b
{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- (c) The University of Glasgow 2002-2006
--
......@@ -57,6 +58,7 @@ import UniqSupply
import Module
import Control.Arrow ( second )
import Control.Exception
import Data.Array
import Data.Map (Map)
import Data.IntMap (IntMap)
......@@ -93,10 +95,21 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
assembleBCOs hsc_env proto_bcos tycs
cbc <- assembleBCOs hsc_env proto_bcos tycs
(case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
-- Squash space leaks in the CompiledByteCode. This is really
-- important, because when loading a set of modules into GHCi
-- we don't touch the CompiledByteCode until the end when we
-- do linking. Forcing out the thunks here reduces space
-- usage by more than 50% when loading a large number of
-- modules.
evaluate (seqCompiledByteCode cbc)
return cbc
where dflags = hsc_dflags hsc_env
-- -----------------------------------------------------------------------------
......
{-# LANGUAGE MagicHash, RecordWildCards #-}
{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
--
-- (c) The University of Glasgow 2002-2006
--
-- | Bytecode assembler types
module ByteCodeTypes
( CompiledByteCode(..), FFIInfo(..)
( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
, CgBreakInfo(..)
......@@ -26,6 +26,7 @@ import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
import GHCi.InfoTable
import Control.DeepSeq
import Foreign
import Data.Array
......@@ -48,38 +49,61 @@ data CompiledByteCode = CompiledByteCode
}
-- ToDo: we're not tracking strings that we malloc'd
newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
deriving Show
deriving (Show, NFData)
instance Outputable CompiledByteCode where
ppr CompiledByteCode{..} = ppr bc_bcos
-- Not a real NFData instance, because ModBreaks contains some things
-- we can't rnf
seqCompiledByteCode :: CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode{..} =
rnf bc_bcos `seq`
rnf (nameEnvElts bc_itbls) `seq`
rnf bc_ffis `seq`
rnf bc_strs `seq`
rnf (fmap seqModBreaks bc_breaks)
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) deriving Show
newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)
deriving (Show, NFData)
data UnlinkedBCO
= UnlinkedBCO {
unlinkedBCOName :: Name,
unlinkedBCOArity :: Int,
unlinkedBCOInstrs :: UArray Int Word16, -- insns
unlinkedBCOBitmap :: UArray Int Word, -- bitmap
unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
unlinkedBCOName :: !Name,
unlinkedBCOArity :: {-# UNPACK #-} !Int,
unlinkedBCOInstrs :: !(UArray Int Word16), -- insns
unlinkedBCOBitmap :: !(UArray Int Word), -- bitmap
unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs
}
instance NFData UnlinkedBCO where
rnf UnlinkedBCO{..} =
rnf unlinkedBCOLits `seq`
rnf unlinkedBCOPtrs
data BCOPtr
= BCOPtrName Name
| BCOPtrPrimOp PrimOp
| BCOPtrBCO UnlinkedBCO
= BCOPtrName !Name
| BCOPtrPrimOp !PrimOp
| BCOPtrBCO !UnlinkedBCO
| BCOPtrBreakArray -- a pointer to this module's BreakArray
instance NFData BCOPtr where
rnf (BCOPtrBCO bco) = rnf bco
rnf x = x `seq` ()
data BCONPtr
= BCONPtrWord Word
| BCONPtrLbl FastString
| BCONPtrItbl Name
| BCONPtrStr ByteString
= BCONPtrWord {-# UNPACK #-} !Word
| BCONPtrLbl !FastString
| BCONPtrItbl !Name
| BCONPtrStr !ByteString
instance NFData BCONPtr where
rnf x = x `seq` ()
-- | Information about a breakpoint that we know at code-generation time
data CgBreakInfo
......@@ -88,6 +112,12 @@ data CgBreakInfo
, cgb_resty :: Type
}
-- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
seqCgBreakInfo CgBreakInfo{..} =
rnf (map snd cgb_vars) `seq`
seqType cgb_resty
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
......@@ -126,6 +156,15 @@ data ModBreaks
-- ^ info about each breakpoint from the bytecode generator
}
seqModBreaks :: ModBreaks -> ()
seqModBreaks ModBreaks{..} =
rnf modBreaks_flags `seq`
rnf modBreaks_locs `seq`
rnf modBreaks_vars `seq`
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo)
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
emptyModBreaks = ModBreaks
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment