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