X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeAsm.lhs;h=c6c7a0d0f9e3e0ca7ffac11ae1c53993685a3885;hb=ee26207114635c480dbc7518c0510545a6f62611;hp=31cbd251cb5bb36c9de7cc8319b5e3b2cf41a68f;hpb=cdce647711c0f46f5799b24de087622cb77e647f;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 31cbd25..c6c7a0d 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -36,12 +36,11 @@ import Outputable import Control.Monad ( foldM ) import Control.Monad.ST ( runST ) -import GHC.Word ( Word(..) ) import Data.Array.MArray import Data.Array.Unboxed ( listArray ) import Data.Array.Base ( UArray(..) ) import Data.Array.ST ( castSTUArray ) -import Foreign ( Word16, free ) +import Foreign import Data.Bits import Data.Int ( Int64 ) import Data.Char ( ord ) @@ -100,7 +99,7 @@ bcoFreeNames bco ) instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm arity insns bitmap lits ptrs) + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) = sep [text "BCO", ppr nm, text "with", int (sizeSS lits), text "lits", int (sizeSS ptrs), text "ptrs" ] @@ -123,14 +122,14 @@ assembleBCOs proto_bcos tycons return (ByteCode bcos itblenv) assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO -assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) +assembleBCO (ProtoBCO nm instrs bitmap bsize arity _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 -- (eventually) will hold the total # of insns. label_env = mkLabelEnv emptyFM 1 instrs - mkLabelEnv env i_offset [] = env + mkLabelEnv env _ [] = env mkLabelEnv env i_offset (i:is) = let new_env = case i of LABEL n -> addToFM env n i_offset ; _ -> env @@ -155,10 +154,10 @@ 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 @@ -168,9 +167,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 @@ -186,18 +185,21 @@ type AsmState = (SizedSeq Word16, SizedSeq BCOPtr) data SizedSeq a = SizedSeq !Int [a] +emptySS :: SizedSeq a emptySS = SizedSeq 0 [] -- Why are these two monadic??? +addToSS :: SizedSeq a -> a -> IO (SizedSeq a) addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs)) +addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a) addListToSS (SizedSeq n r_xs) xs = return (SizedSeq (n + length xs) (reverse xs ++ r_xs)) ssElts :: SizedSeq a -> [a] -ssElts (SizedSeq n r_xs) = reverse r_xs +ssElts (SizedSeq _ r_xs) = reverse r_xs sizeSS :: SizedSeq a -> Int -sizeSS (SizedSeq n r_xs) = n +sizeSS (SizedSeq n _) = n -- Bring in all the bci_ bytecode constants. #include "Bytecodes.h" @@ -271,13 +273,14 @@ 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 UNPACK n -> instr2 st bci_UNPACK n PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon instr3 st2 bci_PACK itbl_no sz - LABEL lab -> return st + LABEL _ -> return st TESTLT_I i l -> do (np, st2) <- int st i instr3 st2 bci_TESTLT_I np (findLabel l) TESTEQ_I i l -> do (np, st2) <- int st i @@ -304,7 +307,6 @@ mkBits findLabel st proto_insns (p1, st2) <- ptr st (BCOPtrArray array) (p2, st3) <- ptr st2 (BCOPtrBreakInfo info) instr4 st3 bci_BRK_FUN p1 index p2 - PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3 i2s :: Int -> Word16 i2s = fromIntegral @@ -383,14 +385,16 @@ 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 _ other = pprPanic "ByteCodeAsm.literal" (ppr other) +push_alts :: CgRep -> Int push_alts NonPtrArg = bci_PUSH_ALTS_N push_alts FloatArg = bci_PUSH_ALTS_F push_alts DoubleArg = bci_PUSH_ALTS_D @@ -398,6 +402,7 @@ push_alts VoidArg = bci_PUSH_ALTS_V push_alts LongArg = bci_PUSH_ALTS_L push_alts PtrArg = bci_PUSH_ALTS_P +return_ubx :: CgRep -> Word16 return_ubx NonPtrArg = bci_RETURN_N return_ubx FloatArg = bci_RETURN_F return_ubx DoubleArg = bci_RETURN_D @@ -433,6 +438,7 @@ instrSize16s instr PUSH_APPLY_PPPPPP{} -> 1 SLIDE{} -> 3 ALLOC_AP{} -> 2 + ALLOC_AP_NOUPD{} -> 2 ALLOC_PAP{} -> 3 MKAP{} -> 3 MKPAP{} -> 3 @@ -492,6 +498,8 @@ mkLitD d w0 <- readArray d_arr 0 return [w0 :: Word] ) + | otherwise + = panic "mkLitD: Bad wORD_SIZE" mkLitI64 ii | wORD_SIZE == 4 @@ -511,6 +519,8 @@ mkLitI64 ii w0 <- readArray d_arr 0 return [w0 :: Word] ) + | otherwise + = panic "mkLitI64: Bad wORD_SIZE" mkLitI i = runST (do @@ -530,5 +540,6 @@ mkLitPtr a return [w0 :: Word] ) -iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int) +iNTERP_STACK_CHECK_THRESH :: Int +iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH \end{code}