[project @ 2001-08-08 14:40:01 by sewardj]

[ghc-hetmet.git] / ghc / compiler / ghci / ByteCodeLink.lhs

diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index 50d0125..310f6c4 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -30,7 +30,7 @@ import ByteCodeInstr  ( BCInstr(..), ProtoBCO(..) )
 import ByteCodeItbls   ( ItblEnv, ItblPtr )
 
 
-import Monad           ( foldM )
+import Monad           ( when, foldM )
 import ST              ( runST )
 import IArray          ( array )
 import MArray          ( castSTUArray, 
@@ -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(..) )
@@ -162,7 +163,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
@@ -187,9 +188,14 @@ assembleBCO (ProtoBCO nm instrs origin)
          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)
+         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,