import PrelBase ( Int(..) )
import PrelGHC ( ByteArray# )
import PrelIOBase ( IO(..) )
+import Monad ( when )
\end{code}
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)))
(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)))
-- 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
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)
-- 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#)
)
\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
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
-- 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
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)
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(..) )
(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
-- 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
(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,
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
-- 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#