never executed always true always false
    1 {-# LANGUAGE FlexibleInstances     #-}
    2 {-# LANGUAGE MagicHash             #-}
    3 {-# LANGUAGE MultiParamTypeClasses #-}
    4 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
    5 --
    6 --  (c) The University of Glasgow 2002-2006
    7 --
    8 
    9 -- | Bytecode assembler and linker
   10 module GHC.ByteCode.Linker
   11   ( ClosureEnv
   12   , emptyClosureEnv
   13   , extendClosureEnv
   14   , linkBCO
   15   , lookupStaticPtr
   16   , lookupIE
   17   , nameToCLabel
   18   , linkFail
   19   )
   20 where
   21 
   22 import GHC.Prelude
   23 
   24 import GHC.Runtime.Interpreter
   25 import GHC.ByteCode.Types
   26 import GHCi.RemoteTypes
   27 import GHCi.ResolvedBCO
   28 import GHCi.BreakArray
   29 
   30 import GHC.Builtin.PrimOps
   31 import GHC.Builtin.Names
   32 
   33 import GHC.Unit.Types
   34 import GHC.Unit.Module.Name
   35 
   36 import GHC.Data.FastString
   37 import GHC.Data.SizedSeq
   38 
   39 import GHC.Utils.Panic
   40 import GHC.Utils.Panic.Plain
   41 import GHC.Utils.Outputable
   42 
   43 import GHC.Types.Name
   44 import GHC.Types.Name.Env
   45 
   46 -- Standard libraries
   47 import Data.Array.Unboxed
   48 import Foreign.Ptr
   49 import GHC.Exts
   50 
   51 {-
   52   Linking interpretables into something we can run
   53 -}
   54 
   55 type ClosureEnv = NameEnv (Name, ForeignHValue)
   56 
   57 emptyClosureEnv :: ClosureEnv
   58 emptyClosureEnv = emptyNameEnv
   59 
   60 extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
   61 extendClosureEnv cl_env pairs
   62   = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
   63 
   64 {-
   65   Linking interpretables into something we can run
   66 -}
   67 
   68 linkBCO
   69   :: Interp
   70   -> ItblEnv
   71   -> ClosureEnv
   72   -> NameEnv Int
   73   -> RemoteRef BreakArray
   74   -> UnlinkedBCO
   75   -> IO ResolvedBCO
   76 linkBCO interp ie ce bco_ix breakarray
   77            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   78   -- fromIntegral Word -> Word64 should be a no op if Word is Word64
   79   -- otherwise it will result in a cast to longlong on 32bit systems.
   80   lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)
   81   ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)
   82   return (ResolvedBCO isLittleEndian arity insns bitmap
   83               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
   84               (addListToSS emptySS ptrs))
   85 
   86 lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
   87 lookupLiteral interp ie ptr = case ptr of
   88   BCONPtrWord lit -> return lit
   89   BCONPtrLbl  sym -> do
   90     Ptr a# <- lookupStaticPtr interp sym
   91     return (W# (int2Word# (addr2Int# a#)))
   92   BCONPtrItbl nm -> do
   93     Ptr a# <- lookupIE interp ie nm
   94     return (W# (int2Word# (addr2Int# a#)))
   95   BCONPtrStr _ ->
   96     -- should be eliminated during assembleBCOs
   97     panic "lookupLiteral: BCONPtrStr"
   98 
   99 lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
  100 lookupStaticPtr interp addr_of_label_string = do
  101   m <- lookupSymbol interp addr_of_label_string
  102   case m of
  103     Just ptr -> return ptr
  104     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"
  105                   (unpackFS addr_of_label_string)
  106 
  107 lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
  108 lookupIE interp ie con_nm =
  109   case lookupNameEnv ie con_nm of
  110     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
  111     Nothing -> do -- try looking up in the object files.
  112        let sym_to_find1 = nameToCLabel con_nm "con_info"
  113        m <- lookupSymbol interp sym_to_find1
  114        case m of
  115           Just addr -> return addr
  116           Nothing
  117              -> do -- perhaps a nullary constructor?
  118                    let sym_to_find2 = nameToCLabel con_nm "static_info"
  119                    n <- lookupSymbol interp sym_to_find2
  120                    case n of
  121                       Just addr -> return addr
  122                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"
  123                                       (unpackFS sym_to_find1 ++ " or " ++
  124                                        unpackFS sym_to_find2)
  125 
  126 lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
  127 lookupPrimOp interp primop = do
  128   let sym_to_find = primopToCLabel primop "closure"
  129   m <- lookupSymbol interp (mkFastString sym_to_find)
  130   case m of
  131     Just p -> return (toRemotePtr p)
  132     Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
  133 
  134 resolvePtr
  135   :: Interp
  136   -> ItblEnv
  137   -> ClosureEnv
  138   -> NameEnv Int
  139   -> RemoteRef BreakArray
  140   -> BCOPtr
  141   -> IO ResolvedBCOPtr
  142 resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
  143   BCOPtrName nm
  144     | Just ix <- lookupNameEnv bco_ix nm
  145     -> return (ResolvedBCORef ix) -- ref to another BCO in this group
  146 
  147     | Just (_, rhv) <- lookupNameEnv ce nm
  148     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
  149 
  150     | otherwise
  151     -> assertPpr (isExternalName nm) (ppr nm) $
  152        do
  153           let sym_to_find = nameToCLabel nm "closure"
  154           m <- lookupSymbol interp sym_to_find
  155           case m of
  156             Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
  157             Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
  158 
  159   BCOPtrPrimOp op
  160     -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
  161 
  162   BCOPtrBCO bco
  163     -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco
  164 
  165   BCOPtrBreakArray
  166     -> return (ResolvedBCOPtrBreakArray breakarray)
  167 
  168 linkFail :: String -> String -> IO a
  169 linkFail who what
  170    = throwGhcExceptionIO (ProgramError $
  171         unlines [ "",who
  172                 , "During interactive linking, GHCi couldn't find the following symbol:"
  173                 , ' ' : ' ' : what
  174                 , "This may be due to you not asking GHCi to load extra object files,"
  175                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
  176                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
  177                 , "flags, or simply by naming the relevant files on the GHCi command line."
  178                 , "Alternatively, this link failure might indicate a bug in GHCi."
  179                 , "If you suspect the latter, please report this as a GHC bug:"
  180                 , "  https://www.haskell.org/ghc/reportabug"
  181                 ])
  182 
  183 
  184 nameToCLabel :: Name -> String -> FastString
  185 nameToCLabel n suffix = mkFastString label
  186   where
  187     encodeZ = zString . zEncodeFS
  188     (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
  189         -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
  190         -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
  191         mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
  192         mod -> mod
  193     packagePart = encodeZ (unitFS pkgKey)
  194     modulePart  = encodeZ (moduleNameFS modName)
  195     occPart     = encodeZ (occNameFS (nameOccName n))
  196 
  197     label = concat
  198         [ if pkgKey == mainUnit then "" else packagePart ++ "_"
  199         , modulePart
  200         , '_':occPart
  201         , '_':suffix
  202         ]
  203 
  204 
  205 -- See Note [Primop wrappers] in GHC.Builtin.PrimOps
  206 primopToCLabel :: PrimOp -> String -> String
  207 primopToCLabel primop suffix = concat
  208     [ "ghczmprim_GHCziPrimopWrappers_"
  209     , zString (zEncodeFS (occNameFS (primOpOcc primop)))
  210     , '_':suffix
  211     ]