diff options
Diffstat (limited to 'compiler/ghci/ByteCodeLink.lhs')
| -rw-r--r-- | compiler/ghci/ByteCodeLink.lhs | 136 |
1 files changed, 68 insertions, 68 deletions
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 4cd7729608..6caf5861ad 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -14,10 +14,10 @@ ByteCodeLink: Bytecode assembler and linker -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module ByteCodeLink ( - HValue, - ClosureEnv, emptyClosureEnv, extendClosureEnv, - linkBCO, lookupStaticPtr, lookupName +module ByteCodeLink ( + HValue, + ClosureEnv, emptyClosureEnv, extendClosureEnv, + linkBCO, lookupStaticPtr, lookupName ,lookupIE ) where @@ -41,24 +41,24 @@ import Outputable import Data.Array.Base -import Control.Monad ( zipWithM ) +import Control.Monad ( zipWithM ) import Control.Monad.ST ( stToIO ) import GHC.Arr ( Array(..), STArray(..) ) -import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) -import GHC.IOBase ( IO(..) ) +import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) +import GHC.IOBase ( IO(..) ) import GHC.Exts -import GHC.Ptr ( Ptr(..), castPtr ) -import GHC.Word ( Word(..) ) +import GHC.Ptr ( Ptr(..), castPtr ) +import GHC.Word ( Word(..) ) import Data.Word \end{code} %************************************************************************ -%* * +%* * \subsection{Linking interpretables into something we can run} -%* * +%* * %************************************************************************ \begin{code} @@ -74,45 +74,45 @@ extendClosureEnv cl_env pairs %************************************************************************ -%* * +%* * \subsection{Linking interpretables into something we can run} -%* * +%* * %************************************************************************ \begin{code} -{- -data BCO# = BCO# ByteArray# -- instrs :: Array Word16# - ByteArray# -- literals :: Array Word32# - PtrArray# -- ptrs :: Array HValue - ByteArray# -- itbls :: Array Addr# +{- +data BCO# = BCO# ByteArray# -- instrs :: Array Word16# + ByteArray# -- literals :: Array Word32# + PtrArray# -- ptrs :: Array HValue + ByteArray# -- itbls :: Array Addr# -} linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue linkBCO ie ce ul_bco = do BCO bco# <- linkBCO' ie ce ul_bco - -- SDM: Why do we need mkApUpd0 here? I *think* it's because - -- otherwise top-level interpreted CAFs don't get updated - -- after evaluation. A top-level BCO will evaluate itself and - -- return its value when entered, but it won't update itself. - -- Wrapping the BCO in an AP_UPD thunk will take care of the - -- update for us. - -- - -- Update: the above is true, but now we also have extra invariants: - -- (a) An AP thunk *must* point directly to a BCO - -- (b) A zero-arity BCO *must* be wrapped in an AP thunk - -- (c) An AP is always fully saturated, so we *can't* wrap - -- non-zero arity BCOs in an AP thunk. - -- - if (unlinkedBCOArity ul_bco > 0) - then return (unsafeCoerce# bco#) - else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco } + -- SDM: Why do we need mkApUpd0 here? I *think* it's because + -- otherwise top-level interpreted CAFs don't get updated + -- after evaluation. A top-level BCO will evaluate itself and + -- return its value when entered, but it won't update itself. + -- Wrapping the BCO in an AP_UPD thunk will take care of the + -- update for us. + -- + -- Update: the above is true, but now we also have extra invariants: + -- (a) An AP thunk *must* point directly to a BCO + -- (b) A zero-arity BCO *must* be wrapped in an AP thunk + -- (c) An AP is always fully saturated, so we *can't* wrap + -- non-zero arity BCOs in an AP thunk. + -- + if (unlinkedBCOArity ul_bco > 0) + then return (unsafeCoerce# bco#) + else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco } linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) -- Raises an IO exception on failure = do let literals = ssElts literalsSS - ptrs = ssElts ptrsSS + ptrs = ssElts ptrsSS linked_literals <- mapM (lookupLiteral ie) literals @@ -123,7 +123,7 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) then panic "linkBCO: >= 64k ptrs" else mkPtrsArray ie ce (fromIntegral n_ptrs) ptrs - let + let !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr litRange @@ -134,7 +134,7 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) literals_arr = listArray litRange linked_literals !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr - !(I# arity#) = arity + !(I# arity#) = arity newBCO insns_barr literals_barr ptrs_parr arity# bitmap @@ -144,19 +144,19 @@ mkPtrsArray :: ItblEnv -> ClosureEnv -> Word16 -> [BCOPtr] -> IO (Array Word16 H mkPtrsArray ie ce n_ptrs ptrs = do let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0) marr <- newArray_ ptrRange - let + let fill (BCOPtrName n) i = do - ptr <- lookupName ce n - unsafeWrite marr i ptr + ptr <- lookupName ce n + unsafeWrite marr i ptr fill (BCOPtrPrimOp op) i = do - ptr <- lookupPrimOp op - unsafeWrite marr i ptr + ptr <- lookupPrimOp op + unsafeWrite marr i ptr fill (BCOPtrBCO ul_bco) i = do - BCO bco# <- linkBCO' ie ce ul_bco - writeArrayBCO marr i bco# - fill (BCOPtrBreakInfo brkInfo) i = + BCO bco# <- linkBCO' ie ce ul_bco + writeArrayBCO marr i bco# + fill (BCOPtrBreakInfo brkInfo) i = unsafeWrite marr i (unsafeCoerce# brkInfo) - fill (BCOPtrArray brkArray) i = + fill (BCOPtrArray brkArray) i = unsafeWrite marr i (unsafeCoerce# brkArray) zipWithM fill ptrs [0..] unsafeFreeze marr @@ -190,24 +190,24 @@ data BCO = BCO BCO# newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO newBCO instrs lits ptrs arity bitmap - = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of - (# s1, bco #) -> (# s1, BCO bco #) + = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of + (# s1, bco #) -> (# s1, BCO bco #) lookupLiteral :: ItblEnv -> BCONPtr -> IO Word lookupLiteral ie (BCONPtrWord lit) = return lit lookupLiteral ie (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym - return (W# (int2Word# (addr2Int# a#))) + return (W# (int2Word# (addr2Int# a#))) lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm - return (W# (int2Word# (addr2Int# a#))) + return (W# (int2Word# (addr2Int# a#))) lookupStaticPtr :: FastString -> IO (Ptr ()) -lookupStaticPtr addr_of_label_string +lookupStaticPtr addr_of_label_string = do let label_to_find = unpackFS addr_of_label_string - m <- lookupSymbol label_to_find + m <- lookupSymbol label_to_find case m of Just ptr -> return ptr - Nothing -> linkFail "ByteCodeLink: can't find label" + Nothing -> linkFail "ByteCodeLink: can't find label" label_to_find lookupPrimOp :: PrimOp -> IO HValue @@ -223,9 +223,9 @@ lookupName :: ClosureEnv -> Name -> IO HValue lookupName ce nm = case lookupNameEnv ce nm of Just (_,aa) -> return aa - Nothing + Nothing -> ASSERT2(isExternalName nm, ppr nm) - do let sym_to_find = nameToCLabel nm "closure" + do let sym_to_find = nameToCLabel nm "closure" m <- lookupSymbol sym_to_find case m of Just (Ptr addr) -> case addrToHValue# addr of @@ -233,7 +233,7 @@ lookupName ce nm Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find lookupIE :: ItblEnv -> Name -> IO (Ptr a) -lookupIE ie con_nm +lookupIE ie con_nm = case lookupNameEnv ie con_nm of Just (_, a) -> return (castPtr (itblCode a)) Nothing @@ -242,29 +242,29 @@ lookupIE ie con_nm m <- lookupSymbol sym_to_find1 case m of Just addr -> return addr - Nothing + Nothing -> do -- perhaps a nullary constructor? let sym_to_find2 = nameToCLabel con_nm "static_info" n <- lookupSymbol sym_to_find2 case n of Just addr -> return addr - Nothing -> linkFail "ByteCodeLink.lookupIE" + Nothing -> linkFail "ByteCodeLink.lookupIE" (sym_to_find1 ++ " or " ++ sym_to_find2) linkFail :: String -> String -> IO a linkFail who what = ghcError (ProgramError $ unlines [ "",who - , "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" - ]) + , "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 |