compiler/ghci/ByteCodeLink.lhs

   1 %
   2 % (c) The University of Glasgow 2000-2006
   3 %
   4 ByteCodeLink: Bytecode assembler and linker
   5
   6 \begin{code}
   7 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
   8
   9 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module ByteCodeLink (
  17         HValue,
  18         ClosureEnv, emptyClosureEnv, extendClosureEnv,
  19         linkBCO, lookupStaticPtr, lookupName
  20        ,lookupIE
  21   ) where
  22
  23 #include "HsVersions.h"
  24
  25 import ByteCodeItbls
  26 import ByteCodeAsm
  27 import ObjLink
  28
  29 import Name
  30 import NameEnv
  31 import OccName
  32 import PrimOp
  33 import Module
  34 import PackageConfig
  35 import FastString
  36 import Panic
  37 import Outputable
  38
  39 -- Standard libraries
  40 import GHC.Word         ( Word(..) )
  41
  42 import Data.Array.Base
  43 import GHC.Arr          ( STArray(..) )
  44
  45 import Control.Monad    ( zipWithM )
  46 import Control.Monad.ST ( stToIO )
  47
  48 import GHC.Exts
  49 import GHC.Arr          ( Array(..) )
  50 import GHC.IOBase       ( IO(..) )
  51 import GHC.Ptr          ( Ptr(..), castPtr )
  52 import GHC.Base         ( writeArray#, RealWorld, Int(..), Word# )
  53 \end{code}
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{Linking interpretables into something we can run}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 type ClosureEnv = NameEnv (Name, HValue)
  64 newtype HValue = HValue Any
  65
  66 emptyClosureEnv = emptyNameEnv
  67
  68 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
  69 extendClosureEnv cl_env pairs
  70   = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
  71 \end{code}
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{Linking interpretables into something we can run}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 {-
  82 data BCO# = BCO# ByteArray#             -- instrs   :: Array Word16#
  83                  ByteArray#             -- literals :: Array Word32#
  84                  PtrArray#              -- ptrs     :: Array HValue
  85                  ByteArray#             -- itbls    :: Array Addr#
  86 -}
  87
  88 linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
  89 linkBCO ie ce ul_bco
  90    = do BCO bco# <- linkBCO' ie ce ul_bco
  91         -- SDM: Why do we need mkApUpd0 here?  I *think* it's because
  92         -- otherwise top-level interpreted CAFs don't get updated
  93         -- after evaluation.   A top-level BCO will evaluate itself and
  94         -- return its value when entered, but it won't update itself.
  95         -- Wrapping the BCO in an AP_UPD thunk will take care of the
  96         -- update for us.
  97         --
  98         -- Update: the above is true, but now we also have extra invariants:
  99         --   (a) An AP thunk *must* point directly to a BCO
 100         --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
 101         --   (c) An AP is always fully saturated, so we *can't* wrap
 102         --       non-zero arity BCOs in an AP thunk.
 103         --
 104         if (unlinkedBCOArity ul_bco > 0)
 105            then return (unsafeCoerce# bco#)
 106            else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
 107
 108
 109 linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
 110 linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
 111    -- Raises an IO exception on failure
 112    = do let literals = ssElts literalsSS
 113             ptrs     = ssElts ptrsSS
 114
 115         linked_literals <- mapM (lookupLiteral ie) literals
 116
 117         let n_literals = sizeSS literalsSS
 118             n_ptrs     = sizeSS ptrsSS
 119
 120         ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
 121
 122         let
 123             ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
 124
 125             literals_arr = listArray (0, n_literals-1) linked_literals
 126                            :: UArray Int Word
 127             literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
 128
 129             (I# arity#)  = arity
 130
 131         newBCO insns_barr literals_barr ptrs_parr arity# bitmap
 132
 133
 134 -- we recursively link any sub-BCOs while making the ptrs array
 135 mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
 136 mkPtrsArray ie ce n_ptrs ptrs = do
 137   marr <- newArray_ (0, n_ptrs-1)
 138   let
 139     fill (BCOPtrName n)     i = do
 140         ptr <- lookupName ce n
 141         unsafeWrite marr i ptr
 142     fill (BCOPtrPrimOp op)  i = do
 143         ptr <- lookupPrimOp op
 144         unsafeWrite marr i ptr
 145     fill (BCOPtrBCO ul_bco) i = do
 146         BCO bco# <- linkBCO' ie ce ul_bco
 147         writeArrayBCO marr i bco#
 148     fill (BCOPtrBreakInfo brkInfo) i =
 149         unsafeWrite marr i (unsafeCoerce# brkInfo)
 150     fill (BCOPtrArray brkArray) i =
 151         unsafeWrite marr i (unsafeCoerce# brkArray)
 152   zipWithM fill ptrs [0..]
 153   unsafeFreeze marr
 154
 155 newtype IOArray i e = IOArray (STArray RealWorld i e)
 156
 157 instance MArray IOArray e IO where
 158     getBounds (IOArray marr) = stToIO $ getBounds marr
 159     getNumElements (IOArray marr) = stToIO $ getNumElements marr
 160     newArray lu init = stToIO $ do
 161         marr <- newArray lu init; return (IOArray marr)
 162     newArray_ lu = stToIO $ do
 163         marr <- newArray_ lu; return (IOArray marr)
 164     unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
 165     unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
 166
 167 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
 168 writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
 169 writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
 170   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
 171   (# s#, () #) }
 172
 173 {-
 174 writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
 175 writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
 176   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
 177   (# s#, () #) }
 178 -}
 179
 180 data BCO = BCO BCO#
 181
 182 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
 183 newBCO instrs lits ptrs arity bitmap
 184    = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
 185                   (# s1, bco #) -> (# s1, BCO bco #)
 186
 187
 188 lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
 189 lookupLiteral ie (BCONPtrWord lit) = return lit
 190 lookupLiteral ie (BCONPtrLbl  sym) = do Ptr a# <- lookupStaticPtr sym
 191                                         return (W# (int2Word# (addr2Int# a#)))
 192 lookupLiteral ie (BCONPtrItbl nm)  = do Ptr a# <- lookupIE ie nm
 193                                         return (W# (int2Word# (addr2Int# a#)))
 194
 195 lookupStaticPtr :: FastString -> IO (Ptr ())
 196 lookupStaticPtr addr_of_label_string
 197    = do let label_to_find = unpackFS addr_of_label_string
 198         m <- lookupSymbol label_to_find
 199         case m of
 200            Just ptr -> return ptr
 201            Nothing  -> linkFail "ByteCodeLink: can't find label"
 202                                 label_to_find
 203
 204 lookupPrimOp :: PrimOp -> IO HValue
 205 lookupPrimOp primop
 206    = do let sym_to_find = primopToCLabel primop "closure"
 207         m <- lookupSymbol sym_to_find
 208         case m of
 209            Just (Ptr addr) -> case addrToHValue# addr of
 210                                  (# hval #) -> return hval
 211            Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 212
 213 lookupName :: ClosureEnv -> Name -> IO HValue
 214 lookupName ce nm
 215    = case lookupNameEnv ce nm of
 216         Just (_,aa) -> return aa
 217         Nothing
 218            -> ASSERT2(isExternalName nm, ppr nm)
 219               do let sym_to_find = nameToCLabel nm "closure"
 220                  m <- lookupSymbol sym_to_find
 221                  case m of
 222                     Just (Ptr addr) -> case addrToHValue# addr of
 223                                           (# hval #) -> return hval
 224                     Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
 225
 226 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
 227 lookupIE ie con_nm
 228    = case lookupNameEnv ie con_nm of
 229         Just (_, a) -> return (castPtr (itblCode a))
 230         Nothing
 231            -> do -- try looking up in the object files.
 232                  let sym_to_find1 = nameToCLabel con_nm "con_info"
 233                  m <- lookupSymbol sym_to_find1
 234                  case m of
 235                     Just addr -> return addr
 236                     Nothing
 237                        -> do -- perhaps a nullary constructor?
 238                              let sym_to_find2 = nameToCLabel con_nm "static_info"
 239                              n <- lookupSymbol sym_to_find2
 240                              case n of
 241                                 Just addr -> return addr
 242                                 Nothing   -> linkFail "ByteCodeLink.lookupIE"
 243                                                 (sym_to_find1 ++ " or " ++ sym_to_find2)
 244
 245 linkFail :: String -> String -> IO a
 246 linkFail who what
 247    = ghcError (ProgramError $
 248         unlines [ ""
 249                 , "During interactive linking, GHCi couldn't find the following symbol:"
 250                 , ' ' : ' ' : what
 251                 , "This may be due to you not asking GHCi to load extra object files,"
 252                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
 253                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
 254                 , "flags, or simply by naming the relevant files on the GHCi command line."
 255                 , "Alternatively, this link failure might indicate a bug in GHCi."
 256                 , "If you suspect the latter, please send a bug report to:"
 257                 , "  glasgow-haskell-bugs@haskell.org"
 258                 ])
 259
 260 -- HACKS!!!  ToDo: cleaner
 261 nameToCLabel :: Name -> String{-suffix-} -> String
 262 nameToCLabel n suffix
 263    = if pkgid /= mainPackageId
 264         then package_part ++ '_': qual_name
 265         else qual_name
 266   where
 267         pkgid = modulePackageId mod
 268         mod = ASSERT( isExternalName n ) nameModule n
 269         package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
 270         module_part  = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
 271         occ_part     = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
 272         qual_name = module_part ++ '_':occ_part ++ '_':suffix
 273
 274
 275 primopToCLabel :: PrimOp -> String{-suffix-} -> String
 276 primopToCLabel primop suffix
 277    = let str = "ghczmprim_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
 278      in --trace ("primopToCLabel: " ++ str)
 279         str
 280 \end{code}
 281