ghc/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(..), sizeSS, ssElts )
  20 import ObjLink          ( lookupSymbol )
  21
  22 import Name             ( Name,  nameModule, nameOccName, isExternalName )
  23 import NameEnv
  24 import OccName          ( occNameString )
  25 import PrimOp           ( PrimOp, primOpOcc )
  26 import Module           ( moduleString  )
  27 import FastString       ( FastString(..), unpackFS )
  28 import Outputable
  29 import Panic            ( GhcException(..) )
  30
  31 -- Standard libraries
  32 import GHC.Word         ( Word(..) )
  33
  34 import Data.Array.IArray ( array )
  35 import Data.Array.Base  ( UArray(..) )
  36 import Foreign          ( Word16 )
  37
  38 import Control.Exception ( throwDyn )
  39
  40 import GHC.Exts         ( BCO#, newBCO#, unsafeCoerce#,
  41                           ByteArray#, Array#, addrToHValue#, mkApUpd0# )
  42
  43 import GHC.Arr          ( Array(..) )
  44 import GHC.IOBase       ( IO(..) )
  45 import GHC.Ptr          ( Ptr(..) )
  46 \end{code}
  47
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{Linking interpretables into something we can run}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 \begin{code}
  56 type ClosureEnv = NameEnv (Name, HValue)
  57 data HValue     = HValue  -- dummy type, actually a pointer to some Real Code.
  58
  59 emptyClosureEnv = emptyNameEnv
  60
  61 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
  62 extendClosureEnv cl_env pairs
  63   = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
  64 \end{code}
  65
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Linking interpretables into something we can run}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 {-
  75 data BCO# = BCO# ByteArray#             -- instrs   :: Array Word16#
  76                  ByteArray#             -- literals :: Array Word32#
  77                  PtrArray#              -- ptrs     :: Array HValue
  78                  ByteArray#             -- itbls    :: Array Addr#
  79 -}
  80
  81 linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
  82 linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
  83 -- Raises an IO exception on failure
  84    = do let insns    = ssElts insnsSS
  85             literals = ssElts literalsSS
  86             ptrs     = ssElts ptrsSS
  87             itbls    = ssElts itblsSS
  88
  89         linked_ptrs     <- mapM (lookupCE ce) ptrs
  90         linked_itbls    <- mapM (lookupIE ie) itbls
  91         linked_literals <- mapM lookupLiteral literals
  92
  93         let n_insns    = sizeSS insnsSS
  94             n_literals = sizeSS literalsSS
  95             n_ptrs     = sizeSS ptrsSS
  96             n_itbls    = sizeSS itblsSS
  97
  98         let ptrs_arr = array (0, n_ptrs-1) (indexify linked_ptrs)
  99                        :: Array Int HValue
 100             ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
 101
 102             itbls_arr = array (0, n_itbls-1) (indexify linked_itbls)
 103                         :: UArray Int ItblPtr
 104             itbls_barr = case itbls_arr of UArray lo hi barr -> barr
 105
 106             insns_arr | n_insns > 65535
 107                       = panic "linkBCO: >= 64k insns in BCO"
 108                       | otherwise
 109                       = array (0, n_insns)
 110                               (indexify (fromIntegral n_insns:insns))
 111                         :: UArray Int Word16
 112             insns_barr = case insns_arr of UArray lo hi barr -> barr
 113
 114             literals_arr = array (0, n_literals-1) (indexify linked_literals)
 115                            :: UArray Int Word
 116             literals_barr = case literals_arr of UArray lo hi barr -> barr
 117
 118             indexify :: [a] -> [(Int, a)]
 119             indexify xs = zip [0..] xs
 120
 121         BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
 122
 123         -- WAS: return (unsafeCoerce# bco#)
 124         case mkApUpd0# (unsafeCoerce# bco#) of
 125            (# final_bco #) -> return final_bco
 126
 127
 128 data BCO = BCO BCO#
 129
 130 newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
 131 newBCO a b c d
 132    = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
 133
 134
 135 lookupLiteral :: Either Word FastString -> IO Word
 136 lookupLiteral (Left lit)  = return lit
 137 lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
 138                                return (W# (unsafeCoerce# addr))
 139      -- Can't be bothered to find the official way to convert Addr# to Word#;
 140      -- the FFI/Foreign designers make it too damn difficult
 141      -- Hence we apply the Blunt Instrument, which works correctly
 142      -- on all reasonable architectures anyway
 143
 144 lookupStaticPtr :: FastString -> IO (Ptr ())
 145 lookupStaticPtr addr_of_label_string
 146    = do let label_to_find = unpackFS addr_of_label_string
 147         m <- lookupSymbol label_to_find
 148         case m of
 149            Just ptr -> return ptr
 150            Nothing  -> linkFail "ByteCodeLink: can't find label"
 151                                 label_to_find
 152
 153 lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue
 154 lookupCE ce (Right primop)
 155    = do let sym_to_find = primopToCLabel primop "closure"
 156         m <- lookupSymbol sym_to_find
 157         case m of
 158            Just (Ptr addr) -> case addrToHValue# addr of
 159                                  (# hval #) -> return hval
 160            Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 161
 162 lookupCE ce (Left nm)
 163    = case lookupNameEnv ce nm of
 164         Just (_,aa) -> return aa
 165         Nothing
 166            -> ASSERT2(isExternalName nm, ppr nm)
 167               do let sym_to_find = nameToCLabel nm "closure"
 168                  m <- lookupSymbol sym_to_find
 169                  case m of
 170                     Just (Ptr addr) -> case addrToHValue# addr of
 171                                           (# hval #) -> return hval
 172                     Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
 173
 174 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
 175 lookupIE ie con_nm
 176    = case lookupNameEnv ie con_nm of
 177         Just (_, Ptr a) -> return (Ptr a)
 178         Nothing
 179            -> do -- try looking up in the object files.
 180                  let sym_to_find1 = nameToCLabel con_nm "con_info"
 181                  m <- lookupSymbol sym_to_find1
 182                  case m of
 183                     Just addr -> return addr
 184                     Nothing
 185                        -> do -- perhaps a nullary constructor?
 186                              let sym_to_find2 = nameToCLabel con_nm "static_info"
 187                              n <- lookupSymbol sym_to_find2
 188                              case n of
 189                                 Just addr -> return addr
 190                                 Nothing   -> linkFail "ByteCodeLink.lookupIE"
 191                                                 (sym_to_find1 ++ " or " ++ sym_to_find2)
 192
 193 linkFail :: String -> String -> IO a
 194 linkFail who what
 195    = throwDyn (ProgramError $
 196         unlines [ ""
 197                 , "During interactive linking, GHCi couldn't find the following symbol:"
 198                 , ' ' : ' ' : what
 199                 , "This may be due to you not asking GHCi to load extra object files,"
 200                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
 201                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
 202                 , "flags, or simply by naming the relevant files on the GHCi command line."
 203                 , "Alternatively, this link failure might indicate a bug in GHCi."
 204                 , "If you suspect the latter, please send a bug report to:"
 205                 , "  glasgow-haskell-bugs@haskell.org"
 206                 ])
 207
 208 -- HACKS!!!  ToDo: cleaner
 209 nameToCLabel :: Name -> String{-suffix-} -> String
 210 nameToCLabel n suffix
 211    = moduleString (nameModule n)
 212      ++ '_':occNameString (nameOccName n) ++ '_':suffix
 213
 214 primopToCLabel :: PrimOp -> String{-suffix-} -> String
 215 primopToCLabel primop suffix
 216    = let str = "GHCziPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix
 217      in --trace ("primopToCLabel: " ++ str)
 218         str
 219 \end{code}
 220