X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeAsm.lhs;h=f0678402ec8e019b5cae64228002e2954f512080;hb=a6e9efb2821f4f921d0e68f61d4241b089357e15;hp=5772b400afa1de387795f307f444904b58f85212;hpb=0bffc410964e1688ad80d277d53400659e697ab5;p=ghc-hetmet.git

diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs
index 5772b40..f067840 100644
--- a/ghc/compiler/ghci/ByteCodeAsm.lhs
+++ b/ghc/compiler/ghci/ByteCodeAsm.lhs
@@ -29,6 +29,7 @@ import PrimOp		( PrimOp )
 import PrimRep		( PrimRep(..), isFollowableRep, is64BitRep )
 import Constants	( wORD_SIZE )
 import FastString	( FastString(..), unpackFS )
+import SMRep		( StgWord )
 import FiniteMap
 import Outputable
 
@@ -37,6 +38,7 @@ import Control.Monad.ST	( ST, runST )
 
 import GHC.Word		( Word(..) )
 import Data.Array.MArray
+import Data.Array.Unboxed ( listArray )
 import Data.Array.Base	( STUArray, UArray(..), unsafeWrite )
 import Data.Array.ST	( castSTUArray )
 import Foreign		( Word16, free )
@@ -65,6 +67,7 @@ data UnlinkedBCO
 	unlinkedBCOName   :: Name,
 	unlinkedBCOArity  :: Int,
 	unlinkedBCOInstrs :: ByteArray#,			 -- insns
+	unlinkedBCOBitmap :: ByteArray#,			 -- bitmap
         unlinkedBCOLits   :: (SizedSeq (Either Word FastString)), -- literals
 			-- Either literal words or a pointer to a asciiz
 			-- string, denoting a label whose *address* should
@@ -84,7 +87,7 @@ bcoFreeNames :: UnlinkedBCO -> NameSet
 bcoFreeNames bco
   = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
   where
-    bco_refs (UnlinkedBCO _ _ _ _ ptrs itbls)
+    bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
 	= unionManyNameSets (
 	     mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
 	     mkNameSet (ssElts itbls) :
@@ -92,7 +95,7 @@ bcoFreeNames bco
 	  )
 
 instance Outputable UnlinkedBCO where
-   ppr (UnlinkedBCO nm arity insns lits ptrs itbls)
+   ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
       = sep [text "BCO", ppr nm, text "with", 
              int (sizeSS lits), text "lits",
              int (sizeSS ptrs), text "ptrs",
@@ -148,11 +151,13 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
 
              insns_arr
 		 | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
-                 | otherwise = runST (mkInstrArray arity bitmap 
-					bsize n_insns asm_insns)
+                 | otherwise = mkInstrArray n_insns asm_insns
              insns_barr = case insns_arr of UArray _lo _hi barr -> barr
 
-         let ul_bco = UnlinkedBCO nm arity insns_barr final_lits 
+	     bitmap_arr = mkBitmapArray bsize bitmap
+             bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
+
+         let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits 
 					final_ptrs final_itbls
 
          -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
@@ -165,25 +170,13 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
          zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
                            free ptr
 
+mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
+mkBitmapArray bsize bitmap
+  = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
 
-mkInstrArray :: Int -> [StgWord] -> Int -> Int -> [Word16]
-	-> ST s (UArray Int Word16)
-mkInstrArray arity bitmap bsize n_insns asm_insns = do
-  (arr :: STUArray s Int Word16) <- newArray_ (0, n_insns + bco_info_w16s)
-  zipWithM (unsafeWrite arr) [bco_info_w16s ..] 
-	(fromIntegral n_insns : asm_insns)
-  (arr' :: STUArray s Int StgWord) <- castSTUArray arr
-  writeArray arr' 0 (fromIntegral arity)
-  writeArray arr' 1 (fromIntegral bsize)
-  zipWithM (writeArray arr') [2..] bitmap
-  arr <- castSTUArray arr'
-  unsafeFreeze arr
- where
-     -- The BCO info (arity, bitmap) goes at the beginning of
-     -- the instruction stream.  See Closures.h for details.	   
-     bco_info_w16s = (1 {- for the arity -} +
-		      1 {- for the bitmap size -} +
-		      length bitmap) * (wORD_SIZE `quot` 2)
+mkInstrArray :: Int -> [Word16]	-> UArray Int Word16
+mkInstrArray n_insns asm_insns
+  = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
 
 -- instrs nonptrs ptrs itbls
 type AsmState = (SizedSeq Word16, 
@@ -351,15 +344,15 @@ mkBits findLabel st proto_insns
           = do st_I1 <- addToSS st_I0 (getName dcon)
                return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
 
-       literal st (MachLabel fs)  = litlabel st fs
-       literal st (MachWord w)    = int st (fromIntegral w)
-       literal st (MachInt j)     = int st (fromIntegral j)
-       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 (MachInt64 ii)  = int64 st (fromIntegral ii)
-       literal st (MachWord64 ii) = int64 st (fromIntegral ii)
-       literal st other           = pprPanic "ByteCodeLink.literal" (ppr other)
+       literal st (MachLabel fs _) = litlabel st fs
+       literal st (MachWord w)     = int st (fromIntegral w)
+       literal st (MachInt j)      = int st (fromIntegral j)
+       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 (MachInt64 ii)   = int64 st (fromIntegral ii)
+       literal st (MachWord64 ii)  = int64 st (fromIntegral ii)
+       literal st other            = pprPanic "ByteCodeLink.literal" (ppr other)
 
 
 push_alts WordRep   = bci_PUSH_ALTS_N