    {-# LANGUAGE CPP                   #-}
    {-# 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
      ( ClosureEnv
      , emptyClosureEnv
      , extendClosureEnv
      , linkBCO
      , lookupStaticPtr
      , lookupIE
      , nameToCLabel
      , linkFail
      )
    where

    #include "HsVersions.h"

    import GHC.Prelude

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

    import GHC.Builtin.PrimOps

    import GHC.Unit.Types
    import GHC.Unit.Module.Name

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

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

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

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

    {-
      Linking interpretables into something we can run
    -}

    type ClosureEnv = NameEnv (Name, ForeignHValue)

    emptyClosureEnv :: ClosureEnv
    emptyClosureEnv :: ClosureEnv
    emptyClosureEnv = ClosureEnv
    forall a. NameEnv a
    emptyNameEnv

    extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
    extendClosureEnv :: ClosureEnv -> [(Name, ForeignHValue)] -> ClosureEnv
    extendClosureEnv ClosureEnv
    cl_env [(Name, ForeignHValue)]
    pairs
      = ClosureEnv -> [(Name, (Name, ForeignHValue))] -> ClosureEnv
    forall a. NameEnv a -> [(Name, a)] -> NameEnv a
    extendNameEnvList ClosureEnv
    cl_env [ (Name
    n, (Name
    n,ForeignHValue
    v)) | (Name
    n,ForeignHValue
    v) <- [(Name, ForeignHValue)]
    pairs]

    {-
      Linking interpretables into something we can run
    -}

    linkBCO
      :: Interp
      -> ItblEnv
      -> ClosureEnv
      -> NameEnv Int
      -> RemoteRef BreakArray
      -> UnlinkedBCO
      -> IO ResolvedBCO
    linkBCO :: Interp
    -> ItblEnv
    -> ClosureEnv
    -> NameEnv Int
    -> RemoteRef BreakArray
    -> UnlinkedBCO
    -> IO ResolvedBCO
    linkBCO Interp
    interp ItblEnv
    ie ClosureEnv
    ce NameEnv Int
    bco_ix RemoteRef BreakArray
    breakarray
               (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.
      [Word64]
    lits <- (BCONPtr -> IO Word64) -> [BCONPtr] -> IO [Word64]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ((Word -> Word64) -> IO Word -> IO Word64
    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 -> ItblEnv -> BCONPtr -> IO Word
    lookupLiteral Interp
    interp ItblEnv
    ie) (SizedSeq BCONPtr -> [BCONPtr]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq BCONPtr
    lits0)
      [ResolvedBCOPtr]
    ptrs <- (BCOPtr -> IO ResolvedBCOPtr) -> [BCOPtr] -> IO [ResolvedBCOPtr]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (Interp
    -> ItblEnv
    -> ClosureEnv
    -> NameEnv Int
    -> RemoteRef BreakArray
    -> BCOPtr
    -> IO ResolvedBCOPtr
    resolvePtr Interp
    interp ItblEnv
    ie ClosureEnv
    ce NameEnv Int
    bco_ix RemoteRef BreakArray
    breakarray) (SizedSeq BCOPtr -> [BCOPtr]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq BCOPtr
    ptrs0)
      ResolvedBCO -> IO ResolvedBCO
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    -> Int
    -> UArray Int Word16
    -> UArray Int Word64
    -> UArray Int Word64
    -> SizedSeq ResolvedBCOPtr
    -> ResolvedBCO
    ResolvedBCO Bool
    isLittleEndian Int
    arity UArray Int Word16
    insns UArray Int Word64
    bitmap
                  ((Int, Int) -> [Word64] -> UArray Int Word64
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    (i, i) -> [e] -> a i e
    listArray (Int
    0, Word -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (SizedSeq BCONPtr -> Word
    forall a. SizedSeq a -> Word
    sizeSS SizedSeq BCONPtr
    lits0)Int -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) [Word64]
    lits)
                  (SizedSeq ResolvedBCOPtr
    -> [ResolvedBCOPtr] -> SizedSeq ResolvedBCOPtr
    forall a. SizedSeq a -> [a] -> SizedSeq a
    addListToSS SizedSeq ResolvedBCOPtr
    forall a. SizedSeq a
    emptySS [ResolvedBCOPtr]
    ptrs))

    lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
    lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
    lookupLiteral Interp
    interp ItblEnv
    ie BCONPtr
    ptr = case BCONPtr
    ptr of
      BCONPtrWord Word
    lit -> Word -> IO Word
    forall (m :: * -> *) a. Monad m => a -> m a
    return Word
    lit
      BCONPtrLbl  FastString
    sym -> do
        Ptr Addr#
    a# <- Interp -> FastString -> IO (Ptr ())
    lookupStaticPtr Interp
    interp FastString
    sym
        Word -> IO Word
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word# -> Word
    W# (Int# -> Word#
    int2Word# (Addr# -> Int#
    addr2Int# Addr#
    a#)))
      BCONPtrItbl Name
    nm -> do
        Ptr Addr#
    a# <- Interp -> ItblEnv -> Name -> IO (Ptr ())
    lookupIE Interp
    interp ItblEnv
    ie Name
    nm
        Word -> IO Word
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word# -> Word
    W# (Int# -> Word#
    int2Word# (Addr# -> Int#
    addr2Int# Addr#
    a#)))
      BCONPtrStr ByteString
    _ ->
        -- should be eliminated during assembleBCOs
        String -> IO Word
    forall a. 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
      Maybe (Ptr ())
    m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    addr_of_label_string
      case Maybe (Ptr ())
    m of
        Just Ptr ()
    ptr -> Ptr () -> IO (Ptr ())
    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 (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"
           Maybe (Ptr ())
    m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find1
           case Maybe (Ptr ())
    m of
              Just Ptr ()
    addr -> Ptr () -> IO (Ptr ())
    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"
                       Maybe (Ptr ())
    n <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find2
                       case Maybe (Ptr ())
    n of
                          Just Ptr ()
    addr -> Ptr () -> IO (Ptr ())
    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)

    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"
      Maybe (Ptr ())
    m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp (String -> FastString
    mkFastString String
    sym_to_find)
      case Maybe (Ptr ())
    m of
        Just Ptr ()
    p -> RemotePtr () -> IO (RemotePtr ())
    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
      -> ItblEnv
      -> ClosureEnv
      -> NameEnv Int
      -> RemoteRef BreakArray
      -> BCOPtr
      -> IO ResolvedBCOPtr
    resolvePtr :: Interp
    -> ItblEnv
    -> ClosureEnv
    -> NameEnv Int
    -> RemoteRef BreakArray
    -> BCOPtr
    -> IO ResolvedBCOPtr
    resolvePtr Interp
    interp ItblEnv
    ie ClosureEnv
    ce NameEnv Int
    bco_ix RemoteRef BreakArray
    breakarray 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 (m :: * -> *) a. Monad m => a -> m a
    return (Int -> ResolvedBCOPtr
    ResolvedBCORef Int
    ix) -- ref to another BCO in this group

        | Just (Name
    _, ForeignHValue
    rhv) <- ClosureEnv -> Name -> Maybe (Name, ForeignHValue)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv ClosureEnv
    ce Name
    nm
        -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    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
        -> ASSERT2(isExternalName nm, ppr nm)
           do
              let sym_to_find :: FastString
    sym_to_find = Name -> String -> FastString
    nameToCLabel Name
    nm String
    "closure"
              Maybe (Ptr ())
    m <- Interp -> FastString -> IO (Maybe (Ptr ()))
    lookupSymbol Interp
    interp FastString
    sym_to_find
              case Maybe (Ptr ())
    m of
                Just Ptr ()
    p -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    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
    -> ItblEnv
    -> ClosureEnv
    -> NameEnv Int
    -> RemoteRef BreakArray
    -> UnlinkedBCO
    -> IO ResolvedBCO
    linkBCO Interp
    interp ItblEnv
    ie ClosureEnv
    ce NameEnv Int
    bco_ix RemoteRef BreakArray
    breakarray UnlinkedBCO
    bco

      BCOPtr
    BCOPtrBreakArray
        -> ResolvedBCOPtr -> IO ResolvedBCOPtr
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RemoteRef BreakArray -> ResolvedBCOPtr
    ResolvedBCOPtrBreakArray RemoteRef BreakArray
    breakarray)

    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) = ASSERT( isExternalName n ) nameModule n
        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 (OccName -> FastString
    occNameFS (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
        ]