compiler/ghci/ByteCodeLink.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   3 %
   4 \section[ByteCodeLink]{Bytecode assembler and linker}
   5
   6 \begin{code}
   7
   8 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
   9
  10 module ByteCodeLink (
  11         HValue,
  12         ClosureEnv, emptyClosureEnv, extendClosureEnv,
  13         linkBCO, lookupStaticPtr
  14   ) where
  15
  16 #include "HsVersions.h"
  17
  18 import ByteCodeItbls    ( ItblEnv, ItblPtr )
  19 import ByteCodeAsm      ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
  20 import ObjLink          ( lookupSymbol )
  21
  22 import Name             ( Name,  nameModule, nameOccName )
  23 import NameEnv
  24 import OccName          ( occNameFS )
  25 import PrimOp           ( PrimOp, primOpOcc )
  26 import Module
  27 import PackageConfig    ( mainPackageId, packageIdFS )
  28 import FastString       ( FastString(..), unpackFS, zEncodeFS )
  29 import Panic            ( GhcException(..) )
  30
  31 #ifdef DEBUG
  32 import Name             ( isExternalName )
  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(..) )
  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                         :: UArray Int ItblPtr
 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 HasBounds IOArray where
 161     bounds (IOArray marr) = bounds marr
 162
 163 instance MArray IOArray e IO where
 164     newArray lu init = stToIO $ do
 165         marr <- newArray lu init; return (IOArray marr)
 166     newArray_ lu = stToIO $ do
 167         marr <- newArray_ lu; return (IOArray marr)
 168     unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
 169     unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
 170
 171 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
 172 writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
 173 writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
 174   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
 175   (# s#, () #) }
 176
 177 data BCO = BCO BCO#
 178
 179 newBCO :: ByteArray# -> ByteArray# -> Array# a
 180          -> ByteArray# -> Int# -> ByteArray# -> IO BCO
 181 newBCO instrs lits ptrs itbls arity bitmap
 182    = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
 183                   (# s1, bco #) -> (# s1, BCO bco #)
 184
 185
 186 lookupLiteral :: Either Word FastString -> IO Word
 187 lookupLiteral (Left lit)  = return lit
 188 lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
 189                                return (W# (unsafeCoerce# addr))
 190      -- Can't be bothered to find the official way to convert Addr# to Word#;
 191      -- the FFI/Foreign designers make it too damn difficult
 192      -- Hence we apply the Blunt Instrument, which works correctly
 193      -- on all reasonable architectures anyway
 194
 195 lookupStaticPtr :: FastString -> IO (Ptr ())
 196 lookupStaticPtr addr_of_label_string
 197    = do let label_to_find = unpackFS addr_of_label_string
 198         m <- lookupSymbol label_to_find
 199         case m of
 200            Just ptr -> return ptr
 201            Nothing  -> linkFail "ByteCodeLink: can't find label"
 202                                 label_to_find
 203
 204 lookupPrimOp :: PrimOp -> IO HValue
 205 lookupPrimOp primop
 206    = do let sym_to_find = primopToCLabel primop "closure"
 207         m <- lookupSymbol sym_to_find
 208         case m of
 209            Just (Ptr addr) -> case addrToHValue# addr of
 210                                  (# hval #) -> return hval
 211            Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 212
 213 lookupName :: ClosureEnv -> Name -> IO HValue
 214 lookupName ce nm
 215    = case lookupNameEnv ce nm of
 216         Just (_,aa) -> return aa
 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 (_, Ptr a) -> return (Ptr 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