[project @ 2001-08-14 13:40:07 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 29902c1..73ccb95 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -4,6 +4,9 @@
 \section[ByteCodeLink]{Bytecode assembler and linker}
 
 \begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
 module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
                      ClosureEnv, HValue, filterNameMap,
                      linkIModules, linkIExpr,
@@ -30,7 +33,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, 
@@ -117,22 +120,20 @@ 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 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",
-             int (sizeSS itbls), text "itbls",
-             int (length malloced), text "malloced"]
+             int (sizeSS itbls), text "itbls"]
 
 
 -- these need a proper home
@@ -190,9 +191,19 @@ assembleBCO (ProtoBCO nm instrs origin malloced)
          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
+
+         let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls
 
-         return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls malloced)
+         -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
+         -- objects, since they might get run too early.  Disable this until
+         -- we figure out what to do.
+         -- 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, 
@@ -219,6 +230,7 @@ mkBits findLabel st proto_insns
        doInstr :: AsmState -> BCInstr -> IO AsmState
        doInstr st i
           = case i of
+               SWIZZLE   stkoff n -> instr3 st i_SWIZZLE stkoff n
                ARGCHECK  n        -> instr2 st i_ARGCHECK n
                STKCHECK  n        -> instr2 st i_STKCHECK n
                PUSH_L    o1       -> instr2 st i_PUSH_L o1
@@ -471,7 +483,7 @@ data BCO# = BCO# ByteArray#                 -- instrs   :: Array Word16#
                  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
@@ -512,18 +524,8 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS malloced)
 
         -- 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
+
 
 data BCO = BCO BCO#
 
@@ -619,8 +621,10 @@ i_STKCHECK = (bci_STKCHECK :: Int)
 i_JMP      = (bci_JMP :: Int)
 #ifdef bci_CCALL
 i_CCALL    = (bci_CCALL :: Int)
+i_SWIZZLE  = (bci_SWIZZLE :: Int)
 #else
 i_CCALL    = error "Sorry pal, you need to bootstrap to use i_CCALL."
+i_SWIZZLE  = error "Sorry pal, you need to bootstrap to use i_SWIZZLE."
 #endif
 
 iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)