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