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