[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

@@ -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

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)

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#