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