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