X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeAsm.lhs;h=36bb477d9252f1aa24b45aac0ee355676b638a66;hb=d7b36bbbcd56ee14656223d02e32f5a1f52ea17b;hp=28263f9f74598c9e9da3b0c7839ddf8a4d456434;hpb=b067bdc33ce1a0bb01957b0bcfbb1c516dba53a4;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 28263f9..36bb477 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -7,6 +7,13 @@ ByteCodeLink: Bytecode assembler and linker
 \begin{code}
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module ByteCodeAsm (  
 	assembleBCOs, assembleBCO,
 
@@ -46,7 +53,7 @@ import Data.Bits
 import Data.Int		( Int64 )
 import Data.Char	( ord )
 
-import GHC.Base		( ByteArray# )
+import GHC.Base		( ByteArray#, MutableByteArray#, RealWorld )
 import GHC.IOBase	( IO(..) )
 import GHC.Ptr		( Ptr(..) )
 
@@ -71,13 +78,15 @@ data UnlinkedBCO
 	unlinkedBCOInstrs :: ByteArray#,		 -- insns
 	unlinkedBCOBitmap :: ByteArray#,		 -- bitmap
         unlinkedBCOLits   :: (SizedSeq BCONPtr),        -- non-ptrs
-        unlinkedBCOPtrs   :: (SizedSeq BCOPtr) 	        -- ptrs
+        unlinkedBCOPtrs   :: (SizedSeq BCOPtr)   	-- ptrs
    }
 
 data BCOPtr
   = BCOPtrName   Name
   | BCOPtrPrimOp PrimOp
   | BCOPtrBCO    UnlinkedBCO
+  | BCOPtrBreakInfo  BreakInfo
+  | BCOPtrArray (MutableByteArray# RealWorld)
 
 data BCONPtr
   = BCONPtrWord  Word
@@ -153,13 +162,12 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
              insns_arr
 		 | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
                  | otherwise = mkInstrArray n_insns asm_insns
-             insns_barr = case insns_arr of UArray _lo _hi barr -> barr
+             insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
 
 	     bitmap_arr = mkBitmapArray bsize bitmap
-             bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
+             bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr
 
-         let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits 
-					final_ptrs
+         let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs 
 
          -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
          -- objects, since they might get run too early.  Disable this until
@@ -167,9 +175,9 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
          -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
 
          return ul_bco
-     where
-         zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
-                           free ptr
+     -- where
+     --     zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
+     --                      free ptr
 
 mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
 mkBitmapArray bsize bitmap
@@ -270,6 +278,7 @@ mkBits findLabel st proto_insns
 
                SLIDE     n by     -> instr3 st bci_SLIDE n by
                ALLOC_AP  n        -> instr2 st bci_ALLOC_AP n
+               ALLOC_AP_NOUPD n   -> instr2 st bci_ALLOC_AP_NOUPD n
                ALLOC_PAP arity n  -> instr3 st bci_ALLOC_PAP arity n
                MKAP      off sz   -> instr3 st bci_MKAP off sz
                MKPAP     off sz   -> instr3 st bci_MKPAP off sz
@@ -299,6 +308,10 @@ mkBits findLabel st proto_insns
                RETURN_UBX rep     -> instr1 st (return_ubx rep)
                CCALL off m_addr   -> do (np, st2) <- addr st m_addr
                                         instr3 st2 bci_CCALL off np
+               BRK_FUN array index info -> do 
+                  (p1, st2) <- ptr st  (BCOPtrArray array) 
+                  (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
+                  instr4 st3 bci_BRK_FUN p1 index p2
 
        i2s :: Int -> Word16
        i2s = fromIntegral
@@ -377,12 +390,13 @@ mkBits findLabel st proto_insns
        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 MachNullAddr     = int st (fromIntegral 0)
        literal st (MachFloat r)    = float st (fromRational r)
        literal st (MachDouble r)   = double st (fromRational r)
        literal st (MachChar c)     = int st (ord 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 other            = pprPanic "ByteCodeAsm.literal" (ppr other)
 
 
 push_alts NonPtrArg = bci_PUSH_ALTS_N
@@ -427,6 +441,7 @@ instrSize16s instr
 	PUSH_APPLY_PPPPPP{}	-> 1
         SLIDE{}			-> 3
         ALLOC_AP{}		-> 2
+        ALLOC_AP_NOUPD{}	-> 2
         ALLOC_PAP{}		-> 3
         MKAP{}			-> 3
         MKPAP{}			-> 3
@@ -448,6 +463,7 @@ instrSize16s instr
         RETURN_UBX{}		-> 1
 	CCALL{}			-> 3
         SWIZZLE{}		-> 3
+        BRK_FUN{}               -> 4 
 
 -- Make lists of host-sized words for literals, so that when the
 -- words are placed in memory at increasing addresses, the