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