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 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 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     newArray lu init = stToIO $ do
 157         marr <- newArray lu init; return (IOArray marr)
 158     newArray_ lu = stToIO $ do
 159         marr <- newArray_ lu; return (IOArray marr)
 160     unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
 161     unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
 162
 163 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
 164 writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
 165 writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
 166   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
 167   (# s#, () #) }
 168
 169 {-
 170 writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
 171 writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
 172   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
 173   (# s#, () #) }
 174 -}
 175
 176 data BCO = BCO BCO#
 177
 178 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
 179 newBCO instrs lits ptrs arity bitmap
 180    = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
 181                   (# s1, bco #) -> (# s1, BCO bco #)
 182
 183
 184 lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
 185 lookupLiteral ie (BCONPtrWord lit) = return lit
 186 lookupLiteral ie (BCONPtrLbl  sym) = do Ptr a# <- lookupStaticPtr sym
 187                                         return (W# (int2Word# (addr2Int# a#)))
 188 lookupLiteral ie (BCONPtrItbl nm)  = do Ptr a# <- lookupIE ie nm
 189                                         return (W# (int2Word# (addr2Int# a#)))
 190
 191 lookupStaticPtr :: FastString -> IO (Ptr ())
 192 lookupStaticPtr addr_of_label_string
 193    = do let label_to_find = unpackFS addr_of_label_string
 194         m <- lookupSymbol label_to_find
 195         case m of
 196            Just ptr -> return ptr
 197            Nothing  -> linkFail "ByteCodeLink: can't find label"
 198                                 label_to_find
 199
 200 lookupPrimOp :: PrimOp -> IO HValue
 201 lookupPrimOp primop
 202    = do let sym_to_find = primopToCLabel primop "closure"
 203         m <- lookupSymbol sym_to_find
 204         case m of
 205            Just (Ptr addr) -> case addrToHValue# addr of
 206                                  (# hval #) -> return hval
 207            Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 208
 209 lookupName :: ClosureEnv -> Name -> IO HValue
 210 lookupName ce nm
 211    = case lookupNameEnv ce nm of
 212         Just (_,aa) -> return aa
 213         Nothing
 214            -> ASSERT2(isExternalName nm, ppr nm)
 215               do let sym_to_find = nameToCLabel nm "closure"
 216                  m <- lookupSymbol sym_to_find
 217                  case m of
 218                     Just (Ptr addr) -> case addrToHValue# addr of
 219                                           (# hval #) -> return hval
 220                     Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
 221
 222 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
 223 lookupIE ie con_nm
 224    = case lookupNameEnv ie con_nm of
 225         Just (_, a) -> return (castPtr (itblCode a))
 226         Nothing
 227            -> do -- try looking up in the object files.
 228                  let sym_to_find1 = nameToCLabel con_nm "con_info"
 229                  m <- lookupSymbol sym_to_find1
 230                  case m of
 231                     Just addr -> return addr
 232                     Nothing
 233                        -> do -- perhaps a nullary constructor?
 234                              let sym_to_find2 = nameToCLabel con_nm "static_info"
 235                              n <- lookupSymbol sym_to_find2
 236                              case n of
 237                                 Just addr -> return addr
 238                                 Nothing   -> linkFail "ByteCodeLink.lookupIE"
 239                                                 (sym_to_find1 ++ " or " ++ sym_to_find2)
 240
 241 linkFail :: String -> String -> IO a
 242 linkFail who what
 243    = throwDyn (ProgramError $
 244         unlines [ ""
 245                 , "During interactive linking, GHCi couldn't find the following symbol:"
 246                 , ' ' : ' ' : what
 247                 , "This may be due to you not asking GHCi to load extra object files,"
 248                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
 249                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
 250                 , "flags, or simply by naming the relevant files on the GHCi command line."
 251                 , "Alternatively, this link failure might indicate a bug in GHCi."
 252                 , "If you suspect the latter, please send a bug report to:"
 253                 , "  glasgow-haskell-bugs@haskell.org"
 254                 ])
 255
 256 -- HACKS!!!  ToDo: cleaner
 257 nameToCLabel :: Name -> String{-suffix-} -> String
 258 nameToCLabel n suffix
 259    = if pkgid /= mainPackageId
 260         then package_part ++ '_': qual_name
 261         else qual_name
 262   where
 263         pkgid = modulePackageId mod
 264         mod = nameModule n
 265         package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
 266         module_part  = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
 267         occ_part     = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
 268         qual_name = module_part ++ '_':occ_part ++ '_':suffix
 269
 270
 271 primopToCLabel :: PrimOp -> String{-suffix-} -> String
 272 primopToCLabel primop suffix
 273    = let str = "base_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
 274      in --trace ("primopToCLabel: " ++ str)
 275         str
 276 \end{code}
 277