Attach finaliser for malloc'd blocks to the UnlinkedBCOs, not to
linked really-really-really BCOs. This is because an unlinked BCO
may be copied many times to generated LinkedBCOs before it dies.
Attaching finalisers to linked BCOs could mean multiple free()s on
the same address.
import ByteCodeItbls ( ItblEnv, ItblPtr )
import ByteCodeItbls ( ItblEnv, ItblPtr )
+import Monad ( when, foldM )
import ST ( runST )
import IArray ( array )
import MArray ( castSTUArray,
import ST ( runST )
import IArray ( array )
import MArray ( castSTUArray,
(SizedSeq Word) -- literals
(SizedSeq (Either Name PrimOp)) -- ptrs
(SizedSeq Name) -- itbl refs
(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
-- 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 malloced)
+ ppr (UnlinkedBCO nm insns lits ptrs itbls)
= sep [text "BCO", ppr nm, text "with",
int (sizeSS insns), text "insns",
int (sizeSS lits), text "lits",
int (sizeSS ptrs), text "ptrs",
= 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 (length malloced), text "malloced"]
+ int (sizeSS itbls), text "itbls"]
-- these need a proper home
-- these need a proper home
itbls <- return emptySS :: IO (SizedSeq Name)
let init_asm_state = (insns,lits,ptrs,itbls)
(final_insns, final_lits, final_ptrs, final_itbls)
itbls <- return emptySS :: IO (SizedSeq Name)
let init_asm_state = (insns,lits,ptrs,itbls)
(final_insns, final_lits, final_ptrs, final_itbls)
- <- mkBits findLabel init_asm_state instrs
+ <- mkBits findLabel init_asm_state instrs
- return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls malloced)
+ let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls
+ when (not (null malloced)) (addFinalizer ul_bco (mapM_ zonk malloced))
+ return ul_bco
+ where
+ zonk (A# a#) = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
+ free (Ptr a#)
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16, SizedSeq Word,
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16, SizedSeq Word,
ByteArray# -- itbls :: Array Addr#
-}
ByteArray# -- itbls :: Array Addr#
-}
-linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS malloced)
+linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
= do insns <- listFromSS insnsSS
literals <- listFromSS literalsSS
ptrs <- listFromSS ptrsSS
= do insns <- listFromSS insnsSS
literals <- listFromSS literalsSS
ptrs <- listFromSS ptrsSS
-- WAS: return (unsafeCoerce# bco#)
case mkApUpd0# (unsafeCoerce# bco#) of
-- WAS: return (unsafeCoerce# bco#)
case mkApUpd0# (unsafeCoerce# bco#) of
- (# 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#)
+ (# final_bco #) -> return final_bco
+