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