    {-# LANGUAGE FlexibleInstances     #-}
    {-# LANGUAGE MagicHash             #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
    --
    --  (c) The University of Glasgow 2002-2006
    --

    -- | Bytecode assembler and linker
    module GHC.ByteCode.Linker
      ( linkBCO
      , lookupStaticPtr
      , lookupIE
      , nameToCLabel
      , linkFail
      )
    where

    import GHC.Prelude

    import GHC.Runtime.Interpreter
    import GHC.ByteCode.Types
    import GHCi.RemoteTypes
    import GHCi.ResolvedBCO

    import GHC.Builtin.PrimOps
    import GHC.Builtin.Names

    import GHC.Unit.Types

    import GHC.Data.FastString
    import GHC.Data.SizedSeq

    import GHC.Linker.Types

    import GHC.Utils.Panic
    import GHC.Utils.Outputable

    import GHC.Types.Name
    import GHC.Types.Name.Env

    import Language.Haskell.Syntax.Module.Name

    -- Standard libraries
    import Data.Array.Unboxed
    import Foreign.Ptr
    import GHC.Exts

    {-
      Linking interpretables into something we can run
    -}

    linkBCO
      :: Interp
      -> LinkerEnv
      -> NameEnv Int
      -> UnlinkedBCO
      -> IO ResolvedBCO
    linkBCO :: Interp -> LinkerEnv -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO
    linkBCO Interp
    interp LinkerEnv
    le NameEnv Int
    bco_ix
               (UnlinkedBCO Name
    _ Int
    arity UArray Int Word16
    insns UArray Int Word64
    bitmap SizedSeq BCONPtr
    lits0 SizedSeq BCOPtr
    ptrs0) = do
      -- fromIntegral Word -> Word64 should be a no op if Word is Word64
      -- otherwise it will result in a cast to longlong on 32bit systems.
      lits <- (BCONPtr -> IO Word64) -> [BCONPtr] -> IO [Word64]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM ((Word -> Word64) -> IO Word -> IO Word64
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Word -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (IO Word -> IO Word64)
    -> (BCONPtr -> IO Word) -> BCONPtr -> IO Word64
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Interp -> LinkerEnv -> BCONPtr -> IO Word
    lookupLiteral Interp
    interp LinkerEnv
    le) (SizedSeq BCONPtr -> [BCONPtr]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq BCONPtr
    lits0)
      ptrs <- mapM (resolvePtr interp le bco_ix) (ssElts ptrs0)
      return (ResolvedBCO isLittleEndian arity insns bitmap
                  (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
                  (addListToSS emptySS ptrs))

    lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
    lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
    lookupLiteral Interp
    interp LinkerEnv
    le BCONPtr
    ptr = case BCONPtr
    ptr of
      BCONPtrWord Word
    lit -> Word -> IO Word
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Word
    lit
      BCONPtrLbl  FastString
    sym -> do
        Ptr a# <- Interp -> FastString -> IO (Ptr ())
    lookupStaticPtr Interp
    interp FastString
    sym
        return (W# (int2Word# (addr2Int# a#)))
      BCONPtrItbl Name
    nm -> do
        Ptr a# <- Interp -> ItblEnv -> Name -> IO (Ptr ())
    lookupIE Interp
    interp (LinkerEnv -> ItblEnv
    itbl_env LinkerEnv
    le) Name
    nm
        return (W# (int2Word# (addr2Int# a#)))
      BCONPtrAddr Name
    nm -> do
        Ptr a# <- Interp -> AddrEnv -> Name -> IO (Ptr ())
    lookupAddr Interp
    interp (LinkerEnv -> AddrEnv
    addr_env LinkerEnv
    le) Name
    nm
        return (W# (int2Word# (addr2Int# a#)))
      BCONPtrStr ByteString
    _ ->
        -- should be eliminated during assembleBCOs
        String -> IO Word
    forall a. HasCallStack => String -> a
    panic String
    "lookupLiteral: BCONPtrStr"

    lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
    lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
    lookupStaticPtr Interp
    interp FastString
    addr_of_label_string = do
      m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    addr_of_label_string
      case m of
        Just Ptr ()
    ptr -> Ptr () -> IO (Ptr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr ()
    ptr
        Maybe (Ptr ())
    Nothing  -> String -> String -> IO (Ptr ())
    forall a. String -> String -> IO a
    linkFail String
    "GHC.ByteCode.Linker: can't find label"
                      (FastString -> String
    unpackFS FastString
    addr_of_label_string)

    lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
    lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
    lookupIE Interp
    interp ItblEnv
    ie Name
    con_nm =
      case ItblEnv -> Name -> Maybe (Name, ItblPtr)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv ItblEnv
    ie Name
    con_nm of
        Just (Name
    _, ItblPtr RemotePtr StgInfoTable
    a) -> Ptr () -> IO (Ptr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RemotePtr () -> Ptr ()
    forall a. RemotePtr a -> Ptr a
    fromRemotePtr (RemotePtr StgInfoTable -> RemotePtr ()
    forall a b. RemotePtr a -> RemotePtr b
    castRemotePtr RemotePtr StgInfoTable
    a))
        Maybe (Name, ItblPtr)
    Nothing -> do -- try looking up in the object files.
           let sym_to_find1 :: FastString
    sym_to_find1 = Name -> String -> FastString
    nameToCLabel Name
    con_nm String
    "con_info"
           m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find1
           case m of
              Just Ptr ()
    addr -> Ptr () -> IO (Ptr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr ()
    addr
              Maybe (Ptr ())
    Nothing
                 -> do -- perhaps a nullary constructor?
                       let sym_to_find2 :: FastString
    sym_to_find2 = Name -> String -> FastString
    nameToCLabel Name
    con_nm String
    "static_info"
                       n <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find2
                       case n of
                          Just Ptr ()
    addr -> Ptr () -> IO (Ptr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr ()
    addr
                          Maybe (Ptr ())
    Nothing   -> String -> String -> IO (Ptr ())
    forall a. String -> String -> IO a
    linkFail String
    "GHC.ByteCode.Linker.lookupIE"
                                          (FastString -> String
    unpackFS FastString
    sym_to_find1 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " or " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                           FastString -> String
    unpackFS FastString
    sym_to_find2)

    -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
    lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
    lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
    lookupAddr Interp
    interp AddrEnv
    ae Name
    addr_nm = do
      case AddrEnv -> Name -> Maybe (Name, AddrPtr)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv AddrEnv
    ae Name
    addr_nm of
        Just (Name
    _, AddrPtr RemotePtr ()
    ptr) -> Ptr () -> IO (Ptr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RemotePtr () -> Ptr ()
    forall a. RemotePtr a -> Ptr a
    fromRemotePtr RemotePtr ()
    ptr)
        Maybe (Name, AddrPtr)
    Nothing -> do -- try looking up in the object files.
          let sym_to_find :: FastString
    sym_to_find = Name -> String -> FastString
    nameToCLabel Name
    addr_nm String
    "bytes"
                              -- see Note [Bytes label] in GHC.Cmm.CLabel
          m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find
          case m of
            Just Ptr ()
    ptr -> Ptr () -> IO (Ptr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ptr ()
    ptr
            Maybe (Ptr ())
    Nothing -> String -> String -> IO (Ptr ())
    forall a. String -> String -> IO a
    linkFail String
    "GHC.ByteCode.Linker.lookupAddr"
                         (FastString -> String
    unpackFS FastString
    sym_to_find)

    lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
    lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
    lookupPrimOp Interp
    interp PrimOp
    primop = do
      let sym_to_find :: String
    sym_to_find = PrimOp -> String -> String
    primopToCLabel PrimOp
    primop String
    "closure"
      m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp (String -> FastString
    mkFastString String
    sym_to_find)
      case m of
        Just Ptr ()
    p -> RemotePtr () -> IO (RemotePtr ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Ptr () -> RemotePtr ()
    forall a. Ptr a -> RemotePtr a
    toRemotePtr Ptr ()
    p)
        Maybe (Ptr ())
    Nothing -> String -> String -> IO (RemotePtr ())
    forall a. String -> String -> IO a
    linkFail String
    "GHC.ByteCode.Linker.lookupCE(primop)" String
    sym_to_find

    resolvePtr
      :: Interp
      -> LinkerEnv
      -> NameEnv Int
      -> BCOPtr
      -> IO ResolvedBCOPtr
    resolvePtr :: Interp -> LinkerEnv -> NameEnv Int -> BCOPtr -> IO ResolvedBCOPtr
    resolvePtr Interp
    interp LinkerEnv
    le NameEnv Int
    bco_ix BCOPtr
    ptr = case BCOPtr
    ptr of
      BCOPtrName Name
    nm
        | Just Int
    ix <- NameEnv Int -> Name -> Maybe Int
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv NameEnv Int
    bco_ix Name
    nm
        -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> ResolvedBCOPtr
    ResolvedBCORef Int
    ix) -- ref to another BCO in this group

        | Just (Name
    _, ForeignHValue
    rhv) <- NameEnv (Name, ForeignHValue)
    -> Name -> Maybe (Name, ForeignHValue)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv (LinkerEnv -> NameEnv (Name, ForeignHValue)
    closure_env LinkerEnv
    le) Name
    nm
        -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RemoteRef HValue -> ResolvedBCOPtr
    ResolvedBCOPtr (ForeignHValue -> RemoteRef HValue
    forall a. ForeignRef a -> RemoteRef a
    unsafeForeignRefToRemoteRef ForeignHValue
    rhv))

        | Bool
    otherwise
        -> Bool -> SDoc -> IO ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Name -> Bool
    isExternalName Name
    nm) (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    nm) (IO ResolvedBCOPtr -> IO ResolvedBCOPtr)
    -> IO ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall a b. (a -> b) -> a -> b
    $
           do
              let sym_to_find :: FastString
    sym_to_find = Name -> String -> FastString
    nameToCLabel Name
    nm String
    "closure"
              m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find
              case m of
                Just Ptr ()
    p -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RemotePtr () -> ResolvedBCOPtr
    ResolvedBCOStaticPtr (Ptr () -> RemotePtr ()
    forall a. Ptr a -> RemotePtr a
    toRemotePtr Ptr ()
    p))
                Maybe (Ptr ())
    Nothing -> String -> String -> IO ResolvedBCOPtr
    forall a. String -> String -> IO a
    linkFail String
    "GHC.ByteCode.Linker.lookupCE" (FastString -> String
    unpackFS FastString
    sym_to_find)

      BCOPtrPrimOp PrimOp
    op
        -> RemotePtr () -> ResolvedBCOPtr
    ResolvedBCOStaticPtr (RemotePtr () -> ResolvedBCOPtr)
    -> IO (RemotePtr ()) -> IO ResolvedBCOPtr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Interp -> PrimOp -> IO (RemotePtr ())
    lookupPrimOp Interp
    interp PrimOp
    op

      BCOPtrBCO UnlinkedBCO
    bco
        -> ResolvedBCO -> ResolvedBCOPtr
    ResolvedBCOPtrBCO (ResolvedBCO -> ResolvedBCOPtr)
    -> IO ResolvedBCO -> IO ResolvedBCOPtr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Interp -> LinkerEnv -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO
    linkBCO Interp
    interp LinkerEnv
    le NameEnv Int
    bco_ix UnlinkedBCO
    bco

      BCOPtrBreakArray ForeignRef BreakArray
    breakarray
        -> ForeignRef BreakArray
    -> (RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr
    forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
    withForeignRef ForeignRef BreakArray
    breakarray ((RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr)
    -> (RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr
    forall a b. (a -> b) -> a -> b
    $ \RemoteRef BreakArray
    ba -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RemoteRef BreakArray -> ResolvedBCOPtr
    ResolvedBCOPtrBreakArray RemoteRef BreakArray
    ba)

    linkFail :: String -> String -> IO a
    linkFail :: forall a. String -> String -> IO a
    linkFail String
    who String
    what
       = GhcException -> IO a
    forall a. GhcException -> IO a
    throwGhcExceptionIO (String -> GhcException
    ProgramError (String -> GhcException) -> String -> GhcException
    forall a b. (a -> b) -> a -> b
    $
            [String] -> String
    unlines [ String
    "",String
    who
                    , String
    "During interactive linking, GHCi couldn't find the following symbol:"
                    , Char
    ' ' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    ' ' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    what
                    , String
    "This may be due to you not asking GHCi to load extra object files,"
                    , String
    "archives or DLLs needed by your current session.  Restart GHCi, specifying"
                    , String
    "the missing library using the -L/path/to/object/dir and -lmissinglibname"
                    , String
    "flags, or simply by naming the relevant files on the GHCi command line."
                    , String
    "Alternatively, this link failure might indicate a bug in GHCi."
                    , String
    "If you suspect the latter, please report this as a GHC bug:"
                    , String
    "  https://www.haskell.org/ghc/reportabug"
                    ])

    nameToCLabel :: Name -> String -> FastString
    nameToCLabel :: Name -> String -> FastString
    nameToCLabel Name
    n String
    suffix = String -> FastString
    mkFastString String
    label
      where
        encodeZ :: FastString -> String
    encodeZ = FastZString -> String
    zString (FastZString -> String)
    -> (FastString -> FastZString) -> FastString -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FastString -> FastZString
    zEncodeFS
        (Module Unit
    pkgKey ModuleName
    modName) = Bool -> Module -> Module
    forall a. HasCallStack => Bool -> a -> a
    assert (Name -> Bool
    isExternalName Name
    n) (Module -> Module) -> Module -> Module
    forall a b. (a -> b) -> a -> b
    $ case HasDebugCallStack => Name -> Module
    Name -> Module
    nameModule Name
    n of
            -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
            -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
            Module
    mod | Module
    mod Module -> Module -> Bool
    forall a. Eq a => a -> a -> Bool
    == Module
    gHC_PRIM -> Module
    gHC_PRIMOPWRAPPERS
            Module
    mod -> Module
    mod
        packagePart :: String
    packagePart = FastString -> String
    encodeZ (Unit -> FastString
    forall u. IsUnitId u => u -> FastString
    unitFS Unit
    pkgKey)
        modulePart :: String
    modulePart  = FastString -> String
    encodeZ (ModuleName -> FastString
    moduleNameFS ModuleName
    modName)
        occPart :: String
    occPart     = FastString -> String
    encodeZ (FastString -> String) -> FastString -> String
    forall a b. (a -> b) -> a -> b
    $ OccName -> FastString
    occNameMangledFS (Name -> OccName
    nameOccName Name
    n)

        label :: String
    label = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
            [ if Unit
    pkgKey Unit -> Unit -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unit
    mainUnit then String
    "" else String
    packagePart String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_"
            , String
    modulePart
            , Char
    '_'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    occPart
            , Char
    '_'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    suffix
            ]

    -- See Note [Primop wrappers] in GHC.Builtin.PrimOps
    primopToCLabel :: PrimOp -> String -> String
    primopToCLabel :: PrimOp -> String -> String
    primopToCLabel PrimOp
    primop String
    suffix = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
        [ String
    "ghczmprim_GHCziPrimopWrappers_"
        , FastZString -> String
    zString (FastString -> FastZString
    zEncodeFS (OccName -> FastString
    occNameFS (PrimOp -> OccName
    primOpOcc PrimOp
    primop)))
        , Char
    '_'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    suffix
        ]