[project @ 2001-10-08 13:24:53 by simonmar]

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

diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index 8aecbe2..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, 
@@ -39,8 +42,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 +166,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 +191,19 @@ 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
+
+         let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls
 
-         return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
+         -- 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, 
@@ -216,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
@@ -322,32 +337,36 @@ mkBits findLabel st proto_insns
        literal st (MachFloat r)  = float st (fromRational r)
        literal st (MachDouble r) = double st (fromRational r)
        literal st (MachChar c)   = int st c
-       literal st other          = pprPanic "ByteCodeLink.mkBits" (ppr other)
+       literal st other          = pprPanic "ByteCodeLink.literal" (ppr other)
 
        ctoi_itbl st pk
           = addr st ret_itbl_addr
             where
-               ret_itbl_addr = case pk of
-                                  PtrRep    -> stg_ctoi_ret_R1p_info
-                                  WordRep   -> stg_ctoi_ret_R1n_info
-                                  IntRep    -> stg_ctoi_ret_R1n_info
-                                  AddrRep   -> stg_ctoi_ret_R1n_info
-                                  CharRep   -> stg_ctoi_ret_R1n_info
-                                  FloatRep  -> stg_ctoi_ret_F1_info
-                                  DoubleRep -> stg_ctoi_ret_D1_info
-                                  VoidRep   -> stg_ctoi_ret_V_info
-                                  _ -> pprPanic "mkBits.ctoi_itbl" (ppr pk)
+               ret_itbl_addr 
+                  = case pk of
+                       PtrRep    -> stg_ctoi_ret_R1p_info
+                       WordRep   -> stg_ctoi_ret_R1n_info
+                       IntRep    -> stg_ctoi_ret_R1n_info
+                       AddrRep   -> stg_ctoi_ret_R1n_info
+                       CharRep   -> stg_ctoi_ret_R1n_info
+                       FloatRep  -> stg_ctoi_ret_F1_info
+                       DoubleRep -> stg_ctoi_ret_D1_info
+                       VoidRep   -> stg_ctoi_ret_V_info
+                       other     -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk)
 
        itoc_itbl st pk
           = addr st ret_itbl_addr
             where
-               ret_itbl_addr = case pk of
-                                  CharRep   -> stg_gc_unbx_r1_ret_info
-                                  IntRep    -> stg_gc_unbx_r1_ret_info
-                                  FloatRep  -> stg_gc_f1_ret_info
-                                  DoubleRep -> stg_gc_d1_ret_info
-                                  VoidRep   -> nullAddr  
-                                  -- Interpreter.c spots this special case
+               ret_itbl_addr 
+                  = case pk of
+                       CharRep   -> stg_gc_unbx_r1_ret_info
+                       IntRep    -> stg_gc_unbx_r1_ret_info
+                       AddrRep   -> stg_gc_unbx_r1_ret_info
+                       FloatRep  -> stg_gc_f1_ret_info
+                       DoubleRep -> stg_gc_d1_ret_info
+                       VoidRep   -> nullAddr  
+                       -- Interpreter.c spots this special case
+                       other     -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk)
                      
 foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr
 foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr
@@ -602,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)