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