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