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