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