[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

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 154738d..5ef060e 100644 (file)
--- 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 PrelBase                ( Int(..) )
 import PrelGHC         ( ByteArray# )
 import PrelIOBase      ( IO(..) )

+import Monad           ( when )

 
 \end{code}
 
 
 \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]
 
             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 ())
 
                     (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)))
 
         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
 
                                     (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))
 
                   (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)))
 
       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.
 
 -- 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
      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 ->
          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)
      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+
                             -- 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#)
                                    )
                                       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
 \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
 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)
 
     mapBc f xs   `thenBc` \ rs ->
     returnBc (r:rs)
 

-emitBc :: ProtoBCO Name -> BcM ()
+emitBc :: ([Addr] -> ProtoBCO Name) -> BcM ()

 emitBc bco st
 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
 
 getLabelBc :: BcM Int
 getLabelBc st

diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs
index 64e27fd..dcc96d9 100644 (file)
--- 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))
                                        -- 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
 
 
 type LocalLabel = Int
 

@@ -109,8 +110,8 @@ data BCInstr
 
 
 instance Outputable a => Outputable (ProtoBCO a) where
 
 
 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)
         $$ 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 (file)
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -39,8 +39,9 @@ import MArray         ( castSTUArray,
                          newIntArray, writeIntArray,
                          newAddrArray, writeAddrArray,
                          readWordArray )
                          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(..) )
 import FiniteMap
 
 import PrelBase                ( Int(..) )

@@ -116,20 +117,22 @@ data UnlinkedBCO
                  (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)
+   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",
       = 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
 
 
 -- these need a proper home

@@ -162,7 +165,7 @@ this BCO.
 -- Top level assembler fn.
 assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
 
 -- 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
    = 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         
 
          (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, 
 
 -- 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#
 -}
 
                  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
    = 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
 
         -- 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#
 
 
 data BCO = BCO BCO#