From 5df78042458dc002b72b9b20f1e43ab28bff9ada Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 8 Aug 2001 14:11:58 +0000 Subject: [PATCH] [project @ 2001-08-08 14:11:58 by sewardj] Use the bytecode generator's monad to keep track of the malloc'd blocks created for each BCO. Eventually use this info to generate a finaliser which is tied to the real, linked BCO --- ghc/compiler/ghci/ByteCodeGen.lhs | 47 +++++++++++++++++++++++++---------- ghc/compiler/ghci/ByteCodeInstr.lhs | 7 +++--- ghc/compiler/ghci/ByteCodeLink.lhs | 33 ++++++++++++++++-------- 3 files changed, 61 insertions(+), 26 deletions(-) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 154738d..5ef060e 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -60,6 +60,7 @@ import Exception ( throwDyn ) import PrelBase ( Int(..) ) import PrelGHC ( ByteArray# ) import PrelIOBase ( IO(..) ) +import Monad ( when ) \end{code} @@ -84,10 +85,13 @@ byteCodeGen dflags binds local_tycons local_classes getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds] - (BcM_State proto_bcos final_ctr, ()) - <- runBc (BcM_State [] 0) + (BcM_State proto_bcos final_ctr mallocd, ()) + <- runBc (BcM_State [] 0 []) (mapBc (schemeR True) flatBinds `thenBc_` returnBc ()) + when (not (null mallocd)) + (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -110,10 +114,13 @@ coreExprToBCOs dflags expr (panic "invented_id's type") let invented_name = idName invented_id - (BcM_State all_proto_bcos final_ctr, ()) - <- runBc (BcM_State [] 0) + (BcM_State all_proto_bcos final_ctr mallocd, ()) + <- runBc (BcM_State [] 0 []) (schemeR True (invented_id, freeVars expr)) + when (not (null mallocd)) + (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos))) @@ -156,8 +163,8 @@ ppBCEnv p -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. -mkProtoBCO nm instrs_ordlist origin - = ProtoBCO nm maybe_with_stack_check origin +mkProtoBCO nm instrs_ordlist origin mallocd_blocks + = ProtoBCO nm maybe_with_stack_check origin mallocd_blocks where -- Overestimate the stack usage (in words) of this BCO, -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit @@ -774,6 +781,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l ioToBc (mkMarshalCode cconv (r_offW, r_rep) addr_offW (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller -> + recordMallocBc addr_of_marshaller `thenBc_` let -- do the call do_call = unitOL (CCALL addr_of_marshaller) @@ -1038,9 +1046,10 @@ pushAtom False d p (AnnLit lit) -- at the same time. let n = I# l -- CAREFUL! Chars are 32 bits in ghc 4.09+ - in ioToBc ( - do (Ptr a#) <- mallocBytes (n+1) - strncpy (Ptr a#) ba (fromIntegral n) + in ioToBc (mallocBytes (n+1)) `thenBc` \ (Ptr a#) -> + recordMallocBc (A# a#) `thenBc_` + ioToBc ( + do strncpy (Ptr a#) ba (fromIntegral n) writeCharOffAddr (A# a#) n '\0' return (A# a#) ) @@ -1243,8 +1252,9 @@ bind x f = f x \begin{code} data BcM_State = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs - nextlabel :: Int } -- for generating local labels - + nextlabel :: Int, -- for generating local labels + malloced :: [Addr] } -- ptrs malloced for current BCO + -- Should be free()d when it is GCd type BcM r = BcM_State -> IO (BcM_State, r) ioToBc :: IO a -> BcM a @@ -1278,9 +1288,20 @@ mapBc f (x:xs) mapBc f xs `thenBc` \ rs -> returnBc (r:rs) -emitBc :: ProtoBCO Name -> BcM () +emitBc :: ([Addr] -> ProtoBCO Name) -> BcM () emitBc bco st - = return (st{bcos = bco : bcos st}, ()) + = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ()) + +newbcoBc :: BcM () +newbcoBc st + | not (null (malloced st)) + = panic "ByteCodeGen.newbcoBc: missed prior emitBc?" + | otherwise + = return (st, ()) + +recordMallocBc :: Addr -> BcM () +recordMallocBc a st + = return (st{malloced = a : malloced st}, ()) getLabelBc :: BcM Int getLabelBc st diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 64e27fd..dcc96d9 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -37,8 +37,9 @@ data ProtoBCO a -- what the BCO came from (Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)) + [Addr] -- malloc'd; free when BCO is GCd -nameOfProtoBCO (ProtoBCO nm insns origin) = nm +nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm type LocalLabel = Int @@ -109,8 +110,8 @@ data BCInstr instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs origin) - = (text "ProtoBCO" <+> ppr name <> colon) + ppr (ProtoBCO name instrs origin malloced) + = (text "ProtoBCO" <+> ppr name <+> text (show malloced) <> colon) $$ nest 6 (vcat (map ppr instrs)) $$ case origin of Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 50d0125..29902c1 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -39,8 +39,9 @@ import MArray ( castSTUArray, newIntArray, writeIntArray, newAddrArray, writeAddrArray, readWordArray ) -import Foreign ( Word16, Ptr(..) ) -import Addr ( Word, Addr, nullAddr ) +import Foreign ( Word16, Ptr(..), free ) +import Addr ( Word, Addr(..), nullAddr ) +import Weak ( addFinalizer ) import FiniteMap import PrelBase ( Int(..) ) @@ -116,20 +117,22 @@ data UnlinkedBCO (SizedSeq Word) -- literals (SizedSeq (Either Name PrimOp)) -- ptrs (SizedSeq Name) -- itbl refs + [Addr] -- malloc'd, free when BCO GC'd -nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm +nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _ _) = nm -- When translating expressions, we need to distinguish the root -- BCO for the expression type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO]) instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm insns lits ptrs itbls) + ppr (UnlinkedBCO nm insns lits ptrs itbls malloced) = sep [text "BCO", ppr nm, text "with", int (sizeSS insns), text "insns", int (sizeSS lits), text "lits", int (sizeSS ptrs), text "ptrs", - int (sizeSS itbls), text "itbls"] + int (sizeSS itbls), text "itbls", + int (length malloced), text "malloced"] -- these need a proper home @@ -162,7 +165,7 @@ this BCO. -- Top level assembler fn. assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO -assembleBCO (ProtoBCO nm instrs origin) +assembleBCO (ProtoBCO nm instrs origin malloced) = let -- pass 1: collect up the offsets of the local labels. -- Remember that the first insn starts at offset 1 since offset 0 @@ -189,7 +192,7 @@ assembleBCO (ProtoBCO nm instrs origin) (final_insns, final_lits, final_ptrs, final_itbls) <- mkBits findLabel init_asm_state instrs - return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls) + return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls malloced) -- instrs nonptrs ptrs itbls type AsmState = (SizedSeq Word16, SizedSeq Word, @@ -468,7 +471,7 @@ data BCO# = BCO# ByteArray# -- instrs :: Array Word16# ByteArray# -- itbls :: Array Addr# -} -linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) +linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS malloced) = do insns <- listFromSS insnsSS literals <- listFromSS literalsSS ptrs <- listFromSS ptrsSS @@ -509,8 +512,18 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) -- WAS: return (unsafeCoerce# bco#) case mkApUpd0# (unsafeCoerce# bco#) of - (# final_bco #) -> return final_bco - + (# final_bco #) + | not (null malloced) + -> do addFinalizer final_bco (freeup malloced) + return final_bco + | otherwise + -> return final_bco + where + freeup :: [Addr] -> IO () + freeup = mapM_ zonk + zonk a@(A# a#) + = do -- putStrLn ("freeing malloced block at " ++ show a) + free (Ptr a#) data BCO = BCO BCO# -- 1.7.10.4