Commit 7cb1fae2 authored by Simon Marlow's avatar Simon Marlow
Browse files

Remote GHCi: batch the creation of strings

Summary:
This makes a big performance difference especially when loading a
large number of modules and using parallel compilation (ghci -jN).

Test Plan:
* validate
* `ghci -fexternal-interpreter` in `nofib/real/anna`

Reviewers: niteria, bgamari, ezyang, austin, hvr, erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1876

GHC Trac Issues: #11100
parent 2fb6a8c3
{-# LANGUAGE BangPatterns, CPP, MagicHash #-}
{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
......@@ -6,7 +6,7 @@
-- | ByteCodeLink: Bytecode assembler and linker
module ByteCodeAsm (
assembleBCOs, assembleBCO,
assembleBCOs, assembleOneBCO,
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
......@@ -19,6 +19,7 @@ import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
import GHCi.RemoteTypes
import GHCi
import HscTypes
import Name
......@@ -49,7 +50,6 @@ import Data.Array.Base ( UArray(..) )
import Data.Array.Unsafe( castSTUArray )
import qualified Data.ByteString as B
import Foreign
import Data.Char ( ord )
import Data.List
......@@ -93,13 +93,61 @@ assembleBCOs
assembleBCOs hsc_env proto_bcos tycons modbreaks = do
itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
(bcos',ptrs) <- mallocStrings hsc_env bcos
return CompiledByteCode
{ bc_bcos = bcos
{ bc_bcos = bcos'
, bc_itbls = itblenv
, bc_ffis = concat (map protoBCOFFIs proto_bcos)
, bc_strs = ptrs
, bc_breaks = modbreaks
}
-- Find all the literal strings and malloc them together. We want to
-- do this because:
--
-- a) It should be done when we compile the module, not each time we relink it
-- b) For -fexternal-interpreter It's more efficient to malloc the strings
-- as a single batch message, especially when compiling in parallel.
--
mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings hsc_env ulbcos = do
let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
ptrs <- iservCmd hsc_env (MallocStrings bytestrings)
return (evalState (mapM splice ulbcos) ptrs, ptrs)
where
splice bco@UnlinkedBCO{..} = do
lits <- mapM spliceLit unlinkedBCOLits
ptrs <- mapM splicePtr unlinkedBCOPtrs
return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
spliceLit (BCONPtrStr _) = do
(RemotePtr p : rest) <- get
put rest
return (BCONPtrWord (fromIntegral p))
spliceLit other = return other
splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
splicePtr other = return other
collect UnlinkedBCO{..} = do
mapM_ collectLit unlinkedBCOLits
mapM_ collectPtr unlinkedBCOPtrs
collectLit (BCONPtrStr bs) = do
strs <- get
put (bs:strs)
collectLit _ = return ()
collectPtr (BCOPtrBCO bco) = collect bco
collectPtr _ = return ()
assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO hsc_env pbco = do
ubco <- assembleBCO (hsc_dflags hsc_env) pbco
([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
return ubco'
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
-- pass 1: collect up the offsets of the local labels.
......@@ -385,7 +433,7 @@ assembleI dflags i = case i of
literal (MachChar c) = int (ord c)
literal (MachInt64 ii) = int64 (fromIntegral ii)
literal (MachWord64 ii) = int64 (fromIntegral ii)
literal (MachStr bs) = lit [BCONPtrStr (bs `B.snoc` 0)]
literal (MachStr bs) = lit [BCONPtrStr bs]
-- MachStr requires a zero-terminator when emitted
literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
......
......@@ -125,7 +125,7 @@ coreExprToBCOs hsc_env this_mod expr
dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
assembleBCO dflags proto_bco
assembleOneBCO hsc_env proto_bco
-- The regular freeVars function gives more information than is useful to
......
......@@ -92,8 +92,9 @@ lookupLiteral hsc_env _ (BCONPtrLbl sym) = do
lookupLiteral hsc_env ie (BCONPtrItbl nm) = do
Ptr a# <- lookupIE hsc_env ie nm
return (W# (int2Word# (addr2Int# a#)))
lookupLiteral hsc_env _ (BCONPtrStr bs) = do
fromIntegral . ptrToWordPtr . fromRemotePtr <$> mallocData hsc_env bs
lookupLiteral _ _ (BCONPtrStr _) =
-- should be eliminated during assembleBCOs
panic "lookupLiteral: BCONPtrStr"
lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
lookupStaticPtr hsc_env addr_of_label_string = do
......
......@@ -42,6 +42,7 @@ data CompiledByteCode = CompiledByteCode
{ bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings
, bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls
, bc_ffis :: [FFIInfo] -- ffi blocks we allocated
, bc_strs :: [RemotePtr ()] -- malloc'd strings
, bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
-- creating breakpoints, for some reason)
}
......
......@@ -73,6 +73,7 @@ data Message a where
-- | Malloc some data and return a 'RemotePtr' to it
MallocData :: ByteString -> Message (RemotePtr ())
MallocStrings :: [ByteString] -> Message [RemotePtr ()]
-- | Calls 'GHCi.FFI.prepareForeignCall'
PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
......@@ -323,42 +324,43 @@ getMessage = do
12 -> Msg <$> CreateBCOs <$> get
13 -> Msg <$> FreeHValueRefs <$> get
14 -> Msg <$> MallocData <$> get
15 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
16 -> Msg <$> FreeFFI <$> get
17 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get)
18 -> Msg <$> (EvalStmt <$> get <*> get)
19 -> Msg <$> (ResumeStmt <$> get <*> get)
20 -> Msg <$> (AbandonStmt <$> get)
21 -> Msg <$> (EvalString <$> get)
22 -> Msg <$> (EvalStringToString <$> get <*> get)
23 -> Msg <$> (EvalIO <$> get)
24 -> Msg <$> (MkCostCentres <$> get <*> get)
25 -> Msg <$> (CostCentreStackInfo <$> get)
26 -> Msg <$> (NewBreakArray <$> get)
27 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
28 -> Msg <$> (BreakpointStatus <$> get <*> get)
29 -> Msg <$> (GetBreakpointVar <$> get <*> get)
30 -> Msg <$> return StartTH
31 -> Msg <$> FinishTH <$> get
32 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
33 -> Msg <$> NewName <$> get
34 -> Msg <$> (Report <$> get <*> get)
35 -> Msg <$> (LookupName <$> get <*> get)
36 -> Msg <$> Reify <$> get
37 -> Msg <$> ReifyFixity <$> get
38 -> Msg <$> (ReifyInstances <$> get <*> get)
39 -> Msg <$> ReifyRoles <$> get
40 -> Msg <$> (ReifyAnnotations <$> get <*> get)
41 -> Msg <$> ReifyModule <$> get
42 -> Msg <$> ReifyConStrictness <$> get
43 -> Msg <$> AddDependentFile <$> get
44 -> Msg <$> AddTopDecls <$> get
45 -> Msg <$> (IsExtEnabled <$> get)
46 -> Msg <$> return ExtsEnabled
47 -> Msg <$> return StartRecover
48 -> Msg <$> EndRecover <$> get
49 -> Msg <$> return QDone
50 -> Msg <$> QException <$> get
15 -> Msg <$> MallocStrings <$> get
16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
17 -> Msg <$> FreeFFI <$> get
18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get)
19 -> Msg <$> (EvalStmt <$> get <*> get)
20 -> Msg <$> (ResumeStmt <$> get <*> get)
21 -> Msg <$> (AbandonStmt <$> get)
22 -> Msg <$> (EvalString <$> get)
23 -> Msg <$> (EvalStringToString <$> get <*> get)
24 -> Msg <$> (EvalIO <$> get)
25 -> Msg <$> (MkCostCentres <$> get <*> get)
26 -> Msg <$> (CostCentreStackInfo <$> get)
27 -> Msg <$> (NewBreakArray <$> get)
28 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
29 -> Msg <$> (BreakpointStatus <$> get <*> get)
30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
31 -> Msg <$> return StartTH
32 -> Msg <$> FinishTH <$> get
33 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
34 -> Msg <$> NewName <$> get
35 -> Msg <$> (Report <$> get <*> get)
36 -> Msg <$> (LookupName <$> get <*> get)
37 -> Msg <$> Reify <$> get
38 -> Msg <$> ReifyFixity <$> get
39 -> Msg <$> (ReifyInstances <$> get <*> get)
40 -> Msg <$> ReifyRoles <$> get
41 -> Msg <$> (ReifyAnnotations <$> get <*> get)
42 -> Msg <$> ReifyModule <$> get
43 -> Msg <$> ReifyConStrictness <$> get
44 -> Msg <$> AddDependentFile <$> get
45 -> Msg <$> AddTopDecls <$> get
46 -> Msg <$> (IsExtEnabled <$> get)
47 -> Msg <$> return ExtsEnabled
48 -> Msg <$> return StartRecover
49 -> Msg <$> EndRecover <$> get
50 -> Msg <$> return QDone
51 -> Msg <$> QException <$> get
_ -> Msg <$> QFail <$> get
putMessage :: Message a -> Put
......@@ -378,43 +380,44 @@ putMessage m = case m of
CreateBCOs bco -> putWord8 12 >> put bco
FreeHValueRefs val -> putWord8 13 >> put val
MallocData bs -> putWord8 14 >> put bs
PrepFFI conv args res -> putWord8 15 >> put conv >> put args >> put res
FreeFFI p -> putWord8 16 >> put p
MkConInfoTable p n t d -> putWord8 17 >> put p >> put n >> put t >> put d
EvalStmt opts val -> putWord8 18 >> put opts >> put val
ResumeStmt opts val -> putWord8 19 >> put opts >> put val
AbandonStmt val -> putWord8 20 >> put val
EvalString val -> putWord8 21 >> put val
EvalStringToString str val -> putWord8 22 >> put str >> put val
EvalIO val -> putWord8 23 >> put val
MkCostCentres mod ccs -> putWord8 24 >> put mod >> put ccs
CostCentreStackInfo ptr -> putWord8 25 >> put ptr
NewBreakArray sz -> putWord8 26 >> put sz
EnableBreakpoint arr ix b -> putWord8 27 >> put arr >> put ix >> put b
BreakpointStatus arr ix -> putWord8 28 >> put arr >> put ix
GetBreakpointVar a b -> putWord8 29 >> put a >> put b
StartTH -> putWord8 30
FinishTH val -> putWord8 31 >> put val
RunTH st q loc ty -> putWord8 32 >> put st >> put q >> put loc >> put ty
NewName a -> putWord8 33 >> put a
Report a b -> putWord8 34 >> put a >> put b
LookupName a b -> putWord8 35 >> put a >> put b
Reify a -> putWord8 36 >> put a
ReifyFixity a -> putWord8 37 >> put a
ReifyInstances a b -> putWord8 38 >> put a >> put b
ReifyRoles a -> putWord8 39 >> put a
ReifyAnnotations a b -> putWord8 40 >> put a >> put b
ReifyModule a -> putWord8 41 >> put a
ReifyConStrictness a -> putWord8 42 >> put a
AddDependentFile a -> putWord8 43 >> put a
AddTopDecls a -> putWord8 44 >> put a
IsExtEnabled a -> putWord8 45 >> put a
ExtsEnabled -> putWord8 46
StartRecover -> putWord8 47
EndRecover a -> putWord8 48 >> put a
QDone -> putWord8 49
QException a -> putWord8 50 >> put a
QFail a -> putWord8 51 >> put a
MallocStrings bss -> putWord8 15 >> put bss
PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res
FreeFFI p -> putWord8 17 >> put p
MkConInfoTable p n t d -> putWord8 18 >> put p >> put n >> put t >> put d
EvalStmt opts val -> putWord8 19 >> put opts >> put val
ResumeStmt opts val -> putWord8 20 >> put opts >> put val
AbandonStmt val -> putWord8 21 >> put val
EvalString val -> putWord8 22 >> put val
EvalStringToString str val -> putWord8 23 >> put str >> put val
EvalIO val -> putWord8 24 >> put val
MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs
CostCentreStackInfo ptr -> putWord8 26 >> put ptr
NewBreakArray sz -> putWord8 27 >> put sz
EnableBreakpoint arr ix b -> putWord8 28 >> put arr >> put ix >> put b
BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix
GetBreakpointVar a b -> putWord8 30 >> put a >> put b
StartTH -> putWord8 31
FinishTH val -> putWord8 32 >> put val
RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty
NewName a -> putWord8 34 >> put a
Report a b -> putWord8 35 >> put a >> put b
LookupName a b -> putWord8 36 >> put a >> put b
Reify a -> putWord8 37 >> put a
ReifyFixity a -> putWord8 38 >> put a
ReifyInstances a b -> putWord8 39 >> put a >> put b
ReifyRoles a -> putWord8 40 >> put a
ReifyAnnotations a b -> putWord8 41 >> put a >> put b
ReifyModule a -> putWord8 42 >> put a
ReifyConStrictness a -> putWord8 43 >> put a
AddDependentFile a -> putWord8 44 >> put a
AddTopDecls a -> putWord8 45 >> put a
IsExtEnabled a -> putWord8 46 >> put a
ExtsEnabled -> putWord8 47
StartRecover -> putWord8 48
EndRecover a -> putWord8 49 >> put a
QDone -> putWord8 50
QException a -> putWord8 51 >> put a
QFail a -> putWord8 52 >> put a
-- -----------------------------------------------------------------------------
-- Reading/writing messages
......
......@@ -75,6 +75,7 @@ run m = case m of
aps <- localRef ref
mapM mkRemoteRef =<< getIdValFromApStack aps ix
MallocData bs -> mkString bs
MallocStrings bss -> mapM mkString0 bss
PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
MkConInfoTable ptrs nptrs tag desc ->
......@@ -323,6 +324,13 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
copyBytes ptr cstr len
return (castRemotePtr (toRemotePtr ptr))
mkString0 :: ByteString -> IO (RemotePtr ())
mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
ptr <- mallocBytes (len+1)
copyBytes ptr cstr len
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr ptr))
mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
......
......@@ -18,6 +18,12 @@ data SizedSeq a = SizedSeq !Word [a]
instance Functor SizedSeq where
fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l)
instance Foldable SizedSeq where
foldr f c ss = foldr f c (ssElts ss)
instance Traversable SizedSeq where
traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l)
instance Binary a => Binary (SizedSeq a)
emptySS :: SizedSeq a
......
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