Commit 5df78042 authored by sewardj's avatar sewardj

[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
parent dfebb20f
......@@ -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
......
......@@ -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)
......
......@@ -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#
......
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