X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fghci%2FByteCodeLink.lhs;h=fd99f8ed31769e4611a340f94c10fd34f5f41752;hb=3178cb8bf5907b4c42fd3b643fc2dd073c2cd2e4;hp=50d01254dd4e40a382410b9388bfb3d840740d09;hpb=daf8e15b8dcad8808ad068c3b93ee5fe99ece5bf;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 50d0125..fd99f8e 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -4,9 +4,12 @@ \section[ByteCodeLink]{Bytecode assembler and linker} \begin{code} + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, ClosureEnv, HValue, filterNameMap, - linkIModules, linkIExpr, + linkIModules, linkIExpr, linkFail, iNTERP_STACK_CHECK_THRESH ) where @@ -30,26 +33,31 @@ import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) ) import ByteCodeItbls ( ItblEnv, ItblPtr ) -import Monad ( foldM ) +import Monad ( when, foldM ) import ST ( runST ) import IArray ( array ) import MArray ( castSTUArray, + newInt64Array, writeInt64Array, newFloatArray, writeFloatArray, newDoubleArray, writeDoubleArray, 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(..) ) import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array#, addrToHValue#, mkApUpd0# ) import IOExts ( fixIO ) +import Exception ( throwDyn ) +import Panic ( GhcException(..) ) import PrelArr ( Array(..) ) import ArrayBase ( UArray(..) ) import PrelIOBase ( IO(..) ) +import Int ( Int64 ) \end{code} @@ -162,7 +170,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 +195,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 +234,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 @@ -304,6 +323,11 @@ mkBits findLabel st proto_insns st_l1 <- addListToSS st_l0 ws return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + int64 (st_i0,st_l0,st_p0,st_I0) i + = do let ws = mkLitI64 i + st_l1 <- addListToSS st_l0 ws + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + addr (st_i0,st_l0,st_p0,st_I0) a = do let ws = mkLitA a st_l1 <- addListToSS st_l0 ws @@ -317,12 +341,14 @@ 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 (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 other = pprPanic "ByteCodeLink.literal" (ppr other) + 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) ctoi_itbl st pk = addr st ret_itbl_addr @@ -346,6 +372,7 @@ mkBits findLabel st proto_insns = case pk of CharRep -> stg_gc_unbx_r1_ret_info IntRep -> stg_gc_unbx_r1_ret_info + WordRep -> 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 @@ -400,10 +427,11 @@ instrSize16s instr -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: Double -> [Word] -mkLitA :: Addr -> [Word] +mkLitI :: Int -> [Word] +mkLitF :: Float -> [Word] +mkLitD :: Double -> [Word] +mkLitA :: Addr -> [Word] +mkLitI64 :: Int64 -> [Word] mkLitF f = runST (do @@ -433,6 +461,25 @@ mkLitD d return [w0] ) +mkLitI64 ii + | wORD_SIZE == 4 + = runST (do + arr <- newInt64Array ((0::Int),1) + writeInt64Array arr 0 ii + d_arr <- castSTUArray arr + w0 <- readWordArray d_arr 0 + w1 <- readWordArray d_arr 1 + return [w0,w1] + ) + | wORD_SIZE == 8 + = runST (do + arr <- newInt64Array ((0::Int),0) + writeInt64Array arr 0 ii + d_arr <- castSTUArray arr + w0 <- readWordArray d_arr 0 + return [w0] + ) + mkLitI i = runST (do arr <- newIntArray ((0::Int),0) @@ -521,20 +568,23 @@ newBCO a b c d lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue lookupCE ce (Right primop) - = do m <- lookupSymbol (primopToCLabel primop "closure") + = do let sym_to_find = primopToCLabel primop "closure" + m <- lookupSymbol sym_to_find case m of Just (Ptr addr) -> case addrToHValue# addr of (# hval #) -> return hval - Nothing -> pprPanic "ByteCodeLink.lookupCE(primop)" (ppr primop) + Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find lookupCE ce (Left nm) = case lookupFM ce nm of Just aa -> return aa Nothing - -> do m <- lookupSymbol (nameToCLabel nm "closure") + -> ASSERT2(isGlobalName nm, ppr nm) + do let sym_to_find = nameToCLabel nm "closure" + m <- lookupSymbol sym_to_find case m of Just (Ptr addr) -> case addrToHValue# addr of (# hval #) -> return hval - Nothing -> pprPanic "ByteCodeLink.lookupCE" (ppr nm) + Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find lookupIE :: ItblEnv -> Name -> IO (Ptr a) lookupIE ie con_nm @@ -542,15 +592,33 @@ lookupIE ie con_nm Just (Ptr a) -> return (Ptr a) Nothing -> do -- try looking up in the object files. - m <- lookupSymbol (nameToCLabel con_nm "con_info") + let sym_to_find1 = nameToCLabel con_nm "con_info" + m <- lookupSymbol sym_to_find1 case m of Just addr -> return addr Nothing -> do -- perhaps a nullary constructor? - n <- lookupSymbol (nameToCLabel con_nm "static_info") + let sym_to_find2 = nameToCLabel con_nm "static_info" + n <- lookupSymbol sym_to_find2 case n of Just addr -> return addr - Nothing -> pprPanic "ByteCodeLink.lookupIE" (ppr con_nm) + Nothing -> linkFail "ByteCodeLink.lookupIE" + (sym_to_find1 ++ " or " ++ sym_to_find2) + +linkFail :: String -> String -> IO a +linkFail who what + = throwDyn (ProgramError $ + unlines [ "" + , "During interactive linking, GHCi couldn't find the following symbol:" + , ' ' : ' ' : what + , "This may be due to you not asking GHCi to load extra object files," + , "archives or DLLs needed by your current session. Restart GHCi, specifying" + , "the missing library using the -L/path/to/object/dir and -lmissinglibname" + , "flags, or simply by naming the relevant files on the GHCi command line." + , "Alternatively, this link failure might indicate a bug in GHCi." + , "If you suspect the latter, please send a bug report to:" + , " glasgow-haskell-bugs@haskell.org" + ]) -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String @@ -606,8 +674,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)