    {-# LANGUAGE CPP             #-}
    {-# LANGUAGE DeriveFunctor   #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
    --
    --  (c) The University of Glasgow 2002-2006
    --

    -- | Bytecode assembler and linker
    module GHC.ByteCode.Asm (
            assembleBCOs, assembleOneBCO,
            bcoFreeNames,
            SizedSeq, sizeSS, ssElts,
            iNTERP_STACK_CHECK_THRESH,
            mkNativeCallInfoLit
      ) where

    import GHC.Prelude

    import GHC.ByteCode.Instr
    import GHC.ByteCode.InfoTable
    import GHC.ByteCode.Types
    import GHCi.RemoteTypes
    import GHC.Runtime.Interpreter
    import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )

    import GHC.Types.Name
    import GHC.Types.Name.Set
    import GHC.Types.Literal
    import GHC.Types.Unique.DSet

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

    import GHC.Core.TyCon
    import GHC.Data.FastString
    import GHC.Data.SizedSeq

    import GHC.StgToCmm.Layout     ( ArgRep(..) )
    import GHC.Cmm.Expr
    import GHC.Cmm.CallConv        ( allArgRegsCover )
    import GHC.Platform
    import GHC.Platform.Profile

    import Control.Monad
    import Control.Monad.Trans.Class
    import Control.Monad.Trans.State.Strict

    import qualified Data.Array.Unboxed as Array
    import Data.Array.Base  ( UArray(..) )

    import Foreign hiding (shiftL, shiftR)
    import Data.Char        ( ord )
    import Data.List        ( genericLength )
    import Data.Map.Strict (Map)
    import Data.Maybe (fromMaybe)
    import qualified Data.Map.Strict as Map
    import GHC.Float (castFloatToWord32, castDoubleToWord64)

    -- -----------------------------------------------------------------------------
    -- Unlinked BCOs

    -- CompiledByteCode represents the result of byte-code
    -- compiling a bunch of functions and data types

    -- | Finds external references.  Remember to remove the names
    -- defined by this group of BCOs themselves
    bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
    bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
    bcoFreeNames UnlinkedBCO
    bco
      = UnlinkedBCO -> UniqDSet Name
    bco_refs UnlinkedBCO
    bco UniqDSet Name -> UniqSet Name -> UniqDSet Name
    forall a. UniqDSet a -> UniqSet a -> UniqDSet a
    `uniqDSetMinusUniqSet` [Name] -> UniqSet Name
    mkNameSet [UnlinkedBCO -> Name
    unlinkedBCOName UnlinkedBCO
    bco]
      where
        bco_refs :: UnlinkedBCO -> UniqDSet Name
    bco_refs (UnlinkedBCO Name
    _ Int
    _ UArray Int Word16
    _ UArray Int Word64
    _ SizedSeq BCONPtr
    nonptrs SizedSeq BCOPtr
    ptrs)
            = [UniqDSet Name] -> UniqDSet Name
    forall a. [UniqDSet a] -> UniqDSet a
    unionManyUniqDSets (
                 [Name] -> UniqDSet Name
    forall a. Uniquable a => [a] -> UniqDSet a
    mkUniqDSet [ Name
    n | BCOPtrName Name
    n <- SizedSeq BCOPtr -> [BCOPtr]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq BCOPtr
    ptrs ] UniqDSet Name -> [UniqDSet Name] -> [UniqDSet Name]
    forall a. a -> [a] -> [a]
    :
                 [Name] -> UniqDSet Name
    forall a. Uniquable a => [a] -> UniqDSet a
    mkUniqDSet [ Name
    n | BCONPtrItbl Name
    n <- SizedSeq BCONPtr -> [BCONPtr]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq BCONPtr
    nonptrs ] UniqDSet Name -> [UniqDSet Name] -> [UniqDSet Name]
    forall a. a -> [a] -> [a]
    :
                 (UnlinkedBCO -> UniqDSet Name) -> [UnlinkedBCO] -> [UniqDSet Name]
    forall a b. (a -> b) -> [a] -> [b]
    map UnlinkedBCO -> UniqDSet Name
    bco_refs [ UnlinkedBCO
    bco | BCOPtrBCO UnlinkedBCO
    bco <- SizedSeq BCOPtr -> [BCOPtr]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq BCOPtr
    ptrs ]
              )

    -- -----------------------------------------------------------------------------
    -- The bytecode assembler

    -- The object format for bytecodes is: 16 bits for the opcode, and 16
    -- for each field -- so the code can be considered a sequence of
    -- 16-bit ints.  Each field denotes either a stack offset or number of
    -- items on the stack (eg SLIDE), and index into the pointer table (eg
    -- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
    -- bytecode address in this BCO.

    -- Top level assembler fn.
    assembleBCOs
      :: Interp
      -> Profile
      -> [ProtoBCO Name]
      -> [TyCon]
      -> AddrEnv
      -> Maybe ModBreaks
      -> IO CompiledByteCode
    assembleBCOs :: Interp
    -> Profile
    -> [ProtoBCO Name]
    -> [TyCon]
    -> AddrEnv
    -> Maybe ModBreaks
    -> IO CompiledByteCode
    assembleBCOs Interp
    interp Profile
    profile [ProtoBCO Name]
    proto_bcos [TyCon]
    tycons AddrEnv
    top_strs Maybe ModBreaks
    modbreaks = do
      -- TODO: the profile should be bundled with the interpreter: the rts ways are
      -- fixed for an interpreter
      itblenv <- Interp -> Profile -> [TyCon] -> IO ItblEnv
    mkITbls Interp
    interp Profile
    profile [TyCon]
    tycons
      bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
      bcos'   <- mallocStrings interp bcos
      return CompiledByteCode
        { bc_bcos = bcos'
        , bc_itbls =  itblenv
        , bc_ffis = concatMap protoBCOFFIs proto_bcos
        , bc_strs = top_strs
        , bc_breaks = modbreaks
        }

    -- Note [Allocating string literals]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- Our strategy for handling top-level string literal bindings is described in
    -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode,
    -- but not all Addr# literals in a program are guaranteed to be lifted to the
    -- top level. Our strategy for handling local Addr# literals is somewhat simpler:
    -- after assembling, we find all the BCONPtrStr arguments in the program, malloc
    -- memory for them, and bake the resulting addresses into the instruction stream
    -- in the form of BCONPtrWord arguments.
    --
    -- Since we do this when assembling, we only allocate the memory when we compile
    -- the module, not each time we relink it. However, we do want to take care to
    -- malloc the memory all in one go, since that is more efficient with
    -- -fexternal-interpreter, especially when compiling in parallel.
    --
    -- Note that, as with top-level string literal bindings, this memory is never
    -- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for
    -- top-level string literal bindings] in GHC.StgToByteCode for some discussion
    -- about why.
    --
    mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
    mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
    mallocStrings Interp
    interp [UnlinkedBCO]
    ulbcos = do
      let bytestrings :: [ByteString]
    bytestrings = [ByteString] -> [ByteString]
    forall a. [a] -> [a]
    reverse (State [ByteString] () -> [ByteString] -> [ByteString]
    forall s a. State s a -> s -> s
    execState ((UnlinkedBCO -> State [ByteString] ())
    -> [UnlinkedBCO] -> State [ByteString] ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ UnlinkedBCO -> State [ByteString] ()
    forall {m :: * -> *}.
    Monad m =>
    UnlinkedBCO -> StateT [ByteString] m ()
    collect [UnlinkedBCO]
    ulbcos) [])
      ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
    forall a. Binary a => Interp -> Message a -> IO a
    interpCmd Interp
    interp ([ByteString] -> Message [RemotePtr ()]
    MallocStrings [ByteString]
    bytestrings)
      return (evalState (mapM splice ulbcos) ptrs)
     where
      splice :: UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
    splice bco :: UnlinkedBCO
    bco@UnlinkedBCO{Int
    UArray Int Word16
    UArray Int Word64
    SizedSeq BCONPtr
    SizedSeq BCOPtr
    Name
    unlinkedBCOName :: UnlinkedBCO -> Name
    unlinkedBCOName :: Name
    unlinkedBCOArity :: Int
    unlinkedBCOInstrs :: UArray Int Word16
    unlinkedBCOBitmap :: UArray Int Word64
    unlinkedBCOLits :: SizedSeq BCONPtr
    unlinkedBCOPtrs :: SizedSeq BCOPtr
    unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
    unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
    unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
    unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
    unlinkedBCOArity :: UnlinkedBCO -> Int
    ..} = do
        lits <- (BCONPtr -> StateT [RemotePtr a] m BCONPtr)
    -> SizedSeq BCONPtr -> StateT [RemotePtr a] m (SizedSeq BCONPtr)
    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) -> SizedSeq a -> m (SizedSeq b)
    mapM BCONPtr -> StateT [RemotePtr a] m BCONPtr
    forall {m :: * -> *} {a}.
    Monad m =>
    BCONPtr -> StateT [RemotePtr a] m BCONPtr
    spliceLit SizedSeq BCONPtr
    unlinkedBCOLits
        ptrs <- mapM splicePtr unlinkedBCOPtrs
        return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }

      spliceLit :: BCONPtr -> StateT [RemotePtr a] m BCONPtr
    spliceLit (BCONPtrStr ByteString
    _) = do
        rptrs <- StateT [RemotePtr a] m [RemotePtr a]
    forall (m :: * -> *) s. Monad m => StateT s m s
    get
        case rptrs of
          (RemotePtr Word64
    p : [RemotePtr a]
    rest) -> do
            [RemotePtr a] -> StateT [RemotePtr a] m ()
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
    put [RemotePtr a]
    rest
            BCONPtr -> StateT [RemotePtr a] m BCONPtr
    forall a. a -> StateT [RemotePtr a] m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word -> BCONPtr
    BCONPtrWord (Word64 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    p))
          [RemotePtr a]
    _ -> String -> StateT [RemotePtr a] m BCONPtr
    forall a. HasCallStack => String -> a
    panic String
    "mallocStrings:spliceLit"
      spliceLit BCONPtr
    other = BCONPtr -> StateT [RemotePtr a] m BCONPtr
    forall a. a -> StateT [RemotePtr a] m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return BCONPtr
    other

      splicePtr :: BCOPtr -> StateT [RemotePtr a] m BCOPtr
    splicePtr (BCOPtrBCO UnlinkedBCO
    bco) = UnlinkedBCO -> BCOPtr
    BCOPtrBCO (UnlinkedBCO -> BCOPtr)
    -> StateT [RemotePtr a] m UnlinkedBCO
    -> StateT [RemotePtr a] m BCOPtr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
    splice UnlinkedBCO
    bco
      splicePtr BCOPtr
    other = BCOPtr -> StateT [RemotePtr a] m BCOPtr
    forall a. a -> StateT [RemotePtr a] m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return BCOPtr
    other

      collect :: UnlinkedBCO -> StateT [ByteString] m ()
    collect UnlinkedBCO{Int
    UArray Int Word16
    UArray Int Word64
    SizedSeq BCONPtr
    SizedSeq BCOPtr
    Name
    unlinkedBCOName :: UnlinkedBCO -> Name
    unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
    unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
    unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
    unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
    unlinkedBCOArity :: UnlinkedBCO -> Int
    unlinkedBCOName :: Name
    unlinkedBCOArity :: Int
    unlinkedBCOInstrs :: UArray Int Word16
    unlinkedBCOBitmap :: UArray Int Word64
    unlinkedBCOLits :: SizedSeq BCONPtr
    unlinkedBCOPtrs :: SizedSeq BCOPtr
    ..} = do
        (BCONPtr -> StateT [ByteString] m ())
    -> SizedSeq BCONPtr -> StateT [ByteString] m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ BCONPtr -> StateT [ByteString] m ()
    forall {m :: * -> *}.
    Monad m =>
    BCONPtr -> StateT [ByteString] m ()
    collectLit SizedSeq BCONPtr
    unlinkedBCOLits
        (BCOPtr -> StateT [ByteString] m ())
    -> SizedSeq BCOPtr -> StateT [ByteString] m ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ BCOPtr -> StateT [ByteString] m ()
    collectPtr SizedSeq BCOPtr
    unlinkedBCOPtrs

      collectLit :: BCONPtr -> StateT [ByteString] m ()
    collectLit (BCONPtrStr ByteString
    bs) = do
        strs <- StateT [ByteString] m [ByteString]
    forall (m :: * -> *) s. Monad m => StateT s m s
    get
        put (bs:strs)
      collectLit BCONPtr
    _ = () -> StateT [ByteString] m ()
    forall a. a -> StateT [ByteString] m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

      collectPtr :: BCOPtr -> StateT [ByteString] m ()
    collectPtr (BCOPtrBCO UnlinkedBCO
    bco) = UnlinkedBCO -> StateT [ByteString] m ()
    collect UnlinkedBCO
    bco
      collectPtr BCOPtr
    _ = () -> StateT [ByteString] m ()
    forall a. a -> StateT [ByteString] m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
    assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
    assembleOneBCO Interp
    interp Profile
    profile ProtoBCO Name
    pbco = do
      -- TODO: the profile should be bundled with the interpreter: the rts ways are
      -- fixed for an interpreter
      ubco <- Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO (Profile -> Platform
    profilePlatform Profile
    profile) ProtoBCO Name
    pbco
      [ubco'] <- mallocStrings interp [ubco]
      return ubco'

    assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform (ProtoBCO { protoBCOName :: forall a. ProtoBCO a -> a
    protoBCOName       = Name
    nm
                                 , protoBCOInstrs :: forall a. ProtoBCO a -> [BCInstr]
    protoBCOInstrs     = [BCInstr]
    instrs
                                 , protoBCOBitmap :: forall a. ProtoBCO a -> [StgWord]
    protoBCOBitmap     = [StgWord]
    bitmap
                                 , protoBCOBitmapSize :: forall a. ProtoBCO a -> Word
    protoBCOBitmapSize = Word
    bsize
                                 , protoBCOArity :: forall a. ProtoBCO a -> Int
    protoBCOArity      = Int
    arity }) = do
      -- pass 1: collect up the offsets of the local labels.
      let asm :: Assembler ()
    asm = (BCInstr -> Assembler ()) -> [BCInstr] -> Assembler ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Platform -> BCInstr -> Assembler ()
    assembleI Platform
    platform) [BCInstr]
    instrs

          initial_offset :: Word
    initial_offset = Word
    0

          -- Jump instructions are variable-sized, there are long and short variants
          -- depending on the magnitude of the offset.  However, we can't tell what
          -- size instructions we will need until we have calculated the offsets of
          -- the labels, which depends on the size of the instructions...  So we
          -- first create the label environment assuming that all jumps are short,
          -- and if the final size is indeed small enough for short jumps, we are
          -- done.  Otherwise, we repeat the calculation, and we force all jumps in
          -- this BCO to be long.
          (Word
    n_insns0, LabelEnvMap
    lbl_map0) = Platform -> Bool -> Word -> Assembler () -> (Word, LabelEnvMap)
    forall a.
    Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
    inspectAsm Platform
    platform Bool
    False Word
    initial_offset Assembler ()
    asm
          ((Word
    n_insns, LabelEnvMap
    lbl_map), Bool
    long_jumps)
            | Word -> Bool
    isLargeW (Int -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Word) -> Int -> Word
    forall a b. (a -> b) -> a -> b
    $ LabelEnvMap -> Int
    forall k a. Map k a -> Int
    Map.size LabelEnvMap
    lbl_map0)
              Bool -> Bool -> Bool
    || Word -> Bool
    isLargeW Word
    n_insns0
                        = (Platform -> Bool -> Word -> Assembler () -> (Word, LabelEnvMap)
    forall a.
    Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
    inspectAsm Platform
    platform Bool
    True Word
    initial_offset Assembler ()
    asm, Bool
    True)
            | Bool
    otherwise = ((Word
    n_insns0, LabelEnvMap
    lbl_map0), Bool
    False)

          env :: LocalLabel -> Word
          env :: LocalLabel -> Word
    env LocalLabel
    lbl = Word -> Maybe Word -> Word
    forall a. a -> Maybe a -> a
    fromMaybe
            (String -> SDoc -> Word
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "assembleBCO.findLabel" (LocalLabel -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LocalLabel
    lbl))
            (LocalLabel -> LabelEnvMap -> Maybe Word
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup LocalLabel
    lbl LabelEnvMap
    lbl_map)

      -- pass 2: run assembler and generate instructions, literals and pointers
      let initial_state :: (SizedSeq a, SizedSeq a, SizedSeq a)
    initial_state = (SizedSeq a
    forall a. SizedSeq a
    emptySS, SizedSeq a
    forall a. SizedSeq a
    emptySS, SizedSeq a
    forall a. SizedSeq a
    emptySS)
      (final_insns, final_lits, final_ptrs) <- (StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
     -> (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
     -> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr))
    -> (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
    -> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
    -> (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
    -> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
    execStateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
    forall {a} {a} {a}. (SizedSeq a, SizedSeq a, SizedSeq a)
    initial_state (StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
     -> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr))
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
    -> IO (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
    forall a b. (a -> b) -> a -> b
    $ Platform
    -> Bool
    -> (LocalLabel -> Word)
    -> Assembler ()
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
    forall a.
    Platform
    -> Bool
    -> (LocalLabel -> Word)
    -> Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    runAsm Platform
    platform Bool
    long_jumps LocalLabel -> Word
    env Assembler ()
    asm

      -- precomputed size should be equal to final size
      massertPpr (n_insns == sizeSS final_insns)
                 (text "bytecode instruction count mismatch")

      let asm_insns = SizedSeq Word16 -> [Word16]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq Word16
    final_insns
          insns_arr = (Int, Int) -> [Word16] -> UArray Int Word16
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    (i, i) -> [e] -> a i e
    Array.listArray (Int
    0, Word -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    n_insns Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) [Word16]
    asm_insns
          bitmap_arr = Word -> [StgWord] -> UArray Int Word64
    mkBitmapArray Word
    bsize [StgWord]
    bitmap
          ul_bco = Name
    -> Int
    -> UArray Int Word16
    -> UArray Int Word64
    -> SizedSeq BCONPtr
    -> SizedSeq BCOPtr
    -> UnlinkedBCO
    UnlinkedBCO Name
    nm Int
    arity UArray Int Word16
    insns_arr UArray Int Word64
    bitmap_arr SizedSeq BCONPtr
    final_lits SizedSeq BCOPtr
    final_ptrs

      -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
      -- objects, since they might get run too early.  Disable this until
      -- we figure out what to do.
      -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))

      return ul_bco

    mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
    -- Here the return type must be an array of Words, not StgWords,
    -- because the underlying ByteArray# will end up as a component
    -- of a BCO object.
    mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
    mkBitmapArray Word
    bsize [StgWord]
    bitmap
      = (Int, Int) -> [Word64] -> UArray Int Word64
    forall (a :: * -> * -> *) e i.
    (IArray a e, Ix i) =>
    (i, i) -> [e] -> a i e
    Array.listArray (Int
    0, [StgWord] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [StgWord]
    bitmap) ([Word64] -> UArray Int Word64) -> [Word64] -> UArray Int Word64
    forall a b. (a -> b) -> a -> b
    $
          Word -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    bsize Word64 -> [Word64] -> [Word64]
    forall a. a -> [a] -> [a]
    : (StgWord -> Word64) -> [StgWord] -> [Word64]
    forall a b. (a -> b) -> [a] -> [b]
    map (Integer -> Word64
    forall a. Num a => Integer -> a
    fromInteger (Integer -> Word64) -> (StgWord -> Integer) -> StgWord -> Word64
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StgWord -> Integer
    fromStgWord) [StgWord]
    bitmap

    -- instrs nonptrs ptrs
    type AsmState = (SizedSeq Word16,
                     SizedSeq BCONPtr,
                     SizedSeq BCOPtr)

    data Operand
      = Op Word
      | IOp Int
      | SmallOp Word16
      | LabelOp LocalLabel

    wOp :: WordOff -> Operand
    wOp :: WordOff -> Operand
    wOp = Word -> Operand
    Op (Word -> Operand) -> (WordOff -> Word) -> WordOff -> Operand
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . WordOff -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral

    bOp :: ByteOff -> Operand
    bOp :: ByteOff -> Operand
    bOp = Word -> Operand
    Op (Word -> Operand) -> (ByteOff -> Word) -> ByteOff -> Operand
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteOff -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral

    truncHalfWord :: Platform -> HalfWord -> Operand
    truncHalfWord :: Platform -> HalfWord -> Operand
    truncHalfWord Platform
    platform HalfWord
    w = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
      PlatformWordSize
    PW4 | HalfWord
    w HalfWord -> HalfWord -> Bool
    forall a. Ord a => a -> a -> Bool
    <= HalfWord
    65535      -> Word -> Operand
    Op (HalfWord -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral HalfWord
    w)
      PlatformWordSize
    PW8 | HalfWord
    w HalfWord -> HalfWord -> Bool
    forall a. Ord a => a -> a -> Bool
    <= HalfWord
    4294967295 -> Word -> Operand
    Op (HalfWord -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral HalfWord
    w)
      PlatformWordSize
    _ -> String -> SDoc -> Operand
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.ByteCode.Asm.truncHalfWord" (HalfWord -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr HalfWord
    w)

    data Assembler a
      = AllocPtr (IO BCOPtr) (Word -> Assembler a)
      | AllocLit [BCONPtr] (Word -> Assembler a)
      | AllocLabel LocalLabel (Assembler a)
      | Emit Word16 [Operand] (Assembler a)
      | NullAsm a
      deriving ((forall a b. (a -> b) -> Assembler a -> Assembler b)
    -> (forall a b. a -> Assembler b -> Assembler a)
    -> Functor Assembler
    forall a b. a -> Assembler b -> Assembler a
    forall a b. (a -> b) -> Assembler a -> Assembler b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
    fmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
    $c<$ :: forall a b. a -> Assembler b -> Assembler a
    <$ :: forall a b. a -> Assembler b -> Assembler a
    Functor)

    instance Applicative Assembler where
        pure :: forall a. a -> Assembler a
    pure = a -> Assembler a
    forall a. a -> Assembler a
    NullAsm
        <*> :: forall a b. Assembler (a -> b) -> Assembler a -> Assembler b
    (<*>) = Assembler (a -> b) -> Assembler a -> Assembler b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad Assembler where
      NullAsm a
    x >>= :: forall a b. Assembler a -> (a -> Assembler b) -> Assembler b
    >>= a -> Assembler b
    f = a -> Assembler b
    f a
    x
      AllocPtr IO BCOPtr
    p Word -> Assembler a
    k >>= a -> Assembler b
    f = IO BCOPtr -> (Word -> Assembler b) -> Assembler b
    forall a. IO BCOPtr -> (Word -> Assembler a) -> Assembler a
    AllocPtr IO BCOPtr
    p (Word -> Assembler a
    k (Word -> Assembler a) -> (a -> Assembler b) -> Word -> Assembler b
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> a -> Assembler b
    f)
      AllocLit [BCONPtr]
    l Word -> Assembler a
    k >>= a -> Assembler b
    f = [BCONPtr] -> (Word -> Assembler b) -> Assembler b
    forall a. [BCONPtr] -> (Word -> Assembler a) -> Assembler a
    AllocLit [BCONPtr]
    l (Word -> Assembler a
    k (Word -> Assembler a) -> (a -> Assembler b) -> Word -> Assembler b
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> a -> Assembler b
    f)
      AllocLabel LocalLabel
    lbl Assembler a
    k >>= a -> Assembler b
    f = LocalLabel -> Assembler b -> Assembler b
    forall a. LocalLabel -> Assembler a -> Assembler a
    AllocLabel LocalLabel
    lbl (Assembler a
    k Assembler a -> (a -> Assembler b) -> Assembler b
    forall a b. Assembler a -> (a -> Assembler b) -> Assembler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= a -> Assembler b
    f)
      Emit Word16
    w [Operand]
    ops Assembler a
    k >>= a -> Assembler b
    f = Word16 -> [Operand] -> Assembler b -> Assembler b
    forall a. Word16 -> [Operand] -> Assembler a -> Assembler a
    Emit Word16
    w [Operand]
    ops (Assembler a
    k Assembler a -> (a -> Assembler b) -> Assembler b
    forall a b. Assembler a -> (a -> Assembler b) -> Assembler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= a -> Assembler b
    f)

    ioptr :: IO BCOPtr -> Assembler Word
    ioptr :: IO BCOPtr -> Assembler Word
    ioptr IO BCOPtr
    p = IO BCOPtr -> (Word -> Assembler Word) -> Assembler Word
    forall a. IO BCOPtr -> (Word -> Assembler a) -> Assembler a
    AllocPtr IO BCOPtr
    p Word -> Assembler Word
    forall a. a -> Assembler a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    ptr :: BCOPtr -> Assembler Word
    ptr :: BCOPtr -> Assembler Word
    ptr = IO BCOPtr -> Assembler Word
    ioptr (IO BCOPtr -> Assembler Word)
    -> (BCOPtr -> IO BCOPtr) -> BCOPtr -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BCOPtr -> IO BCOPtr
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    lit :: [BCONPtr] -> Assembler Word
    lit :: [BCONPtr] -> Assembler Word
    lit [BCONPtr]
    l = [BCONPtr] -> (Word -> Assembler Word) -> Assembler Word
    forall a. [BCONPtr] -> (Word -> Assembler a) -> Assembler a
    AllocLit [BCONPtr]
    l Word -> Assembler Word
    forall a. a -> Assembler a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    label :: LocalLabel -> Assembler ()
    label :: LocalLabel -> Assembler ()
    label LocalLabel
    w = LocalLabel -> Assembler () -> Assembler ()
    forall a. LocalLabel -> Assembler a -> Assembler a
    AllocLabel LocalLabel
    w (() -> Assembler ()
    forall a. a -> Assembler a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    emit :: Word16 -> [Operand] -> Assembler ()
    emit :: Word16 -> [Operand] -> Assembler ()
    emit Word16
    w [Operand]
    ops = Word16 -> [Operand] -> Assembler () -> Assembler ()
    forall a. Word16 -> [Operand] -> Assembler a -> Assembler a
    Emit Word16
    w [Operand]
    ops (() -> Assembler ()
    forall a. a -> Assembler a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())

    type LabelEnv = LocalLabel -> Word

    largeOp :: Bool -> Operand -> Bool
    largeOp :: Bool -> Operand -> Bool
    largeOp Bool
    long_jumps Operand
    op = case Operand
    op of
       SmallOp Word16
    _ -> Bool
    False
       Op Word
    w      -> Word -> Bool
    isLargeW Word
    w
       IOp Int
    i     -> Int -> Bool
    isLargeI Int
    i
       LabelOp LocalLabel
    _ -> Bool
    long_jumps

    runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
    runAsm :: forall a.
    Platform
    -> Bool
    -> (LocalLabel -> Word)
    -> Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    runAsm Platform
    platform Bool
    long_jumps LocalLabel -> Word
    e = Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    go
      where
        go :: Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    go (NullAsm a
    x) = a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    forall a.
    a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    x
        go (AllocPtr IO BCOPtr
    p_io Word -> Assembler a
    k) = do
          p <- IO BCOPtr
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO BCOPtr
    forall (m :: * -> *) a.
    Monad m =>
    m a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift IO BCOPtr
    p_io
          w <- state $ \(SizedSeq Word16
    st_i0,SizedSeq BCONPtr
    st_l0,SizedSeq BCOPtr
    st_p0) ->
            let st_p1 :: SizedSeq BCOPtr
    st_p1 = SizedSeq BCOPtr -> BCOPtr -> SizedSeq BCOPtr
    forall a. SizedSeq a -> a -> SizedSeq a
    addToSS SizedSeq BCOPtr
    st_p0 BCOPtr
    p
            in (SizedSeq BCOPtr -> Word
    forall a. SizedSeq a -> Word
    sizeSS SizedSeq BCOPtr
    st_p0, (SizedSeq Word16
    st_i0,SizedSeq BCONPtr
    st_l0,SizedSeq BCOPtr
    st_p1))
          go $ k w
        go (AllocLit [BCONPtr]
    lits Word -> Assembler a
    k) = do
          w <- ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
     -> (Word, (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO Word
    forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
    state (((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
      -> (Word, (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
     -> StateT
          (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO Word)
    -> ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
        -> (Word, (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO Word
    forall a b. (a -> b) -> a -> b
    $ \(SizedSeq Word16
    st_i0,SizedSeq BCONPtr
    st_l0,SizedSeq BCOPtr
    st_p0) ->
            let st_l1 :: SizedSeq BCONPtr
    st_l1 = SizedSeq BCONPtr -> [BCONPtr] -> SizedSeq BCONPtr
    forall a. SizedSeq a -> [a] -> SizedSeq a
    addListToSS SizedSeq BCONPtr
    st_l0 [BCONPtr]
    lits
            in (SizedSeq BCONPtr -> Word
    forall a. SizedSeq a -> Word
    sizeSS SizedSeq BCONPtr
    st_l0, (SizedSeq Word16
    st_i0,SizedSeq BCONPtr
    st_l1,SizedSeq BCOPtr
    st_p0))
          go $ k w
        go (AllocLabel LocalLabel
    _ Assembler a
    k) = Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    go Assembler a
    k
        go (Emit Word16
    w [Operand]
    ops Assembler a
    k) = do
          let largeArgs :: Bool
    largeArgs = (Operand -> Bool) -> [Operand] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Bool -> Operand -> Bool
    largeOp Bool
    long_jumps) [Operand]
    ops
              opcode :: Word16
    opcode
                | Bool
    largeArgs = Word16 -> Word16
    largeArgInstr Word16
    w
                | Bool
    otherwise = Word16
    w
              words :: [Word16]
    words = (Operand -> [Word16]) -> [Operand] -> [Word16]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Operand -> [Word16]
    expand [Operand]
    ops
              expand :: Operand -> [Word16]
    expand (SmallOp Word16
    w) = [Word16
    w]
              expand (LabelOp LocalLabel
    w) = Operand -> [Word16]
    expand (Word -> Operand
    Op (LocalLabel -> Word
    e LocalLabel
    w))
              expand (Op Word
    w) = if Bool
    largeArgs then Platform -> Word64 -> [Word16]
    largeArg Platform
    platform (Word -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w) else [Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w]
              expand (IOp Int
    i) = if Bool
    largeArgs then Platform -> Word64 -> [Word16]
    largeArg Platform
    platform (Int -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i) else [Int -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i]
          ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
     -> ((), (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
    forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
    state (((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
      -> ((), (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
     -> StateT
          (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ())
    -> ((SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)
        -> ((), (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr)))
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO ()
    forall a b. (a -> b) -> a -> b
    $ \(SizedSeq Word16
    st_i0,SizedSeq BCONPtr
    st_l0,SizedSeq BCOPtr
    st_p0) ->
            let st_i1 :: SizedSeq Word16
    st_i1 = SizedSeq Word16 -> [Word16] -> SizedSeq Word16
    forall a. SizedSeq a -> [a] -> SizedSeq a
    addListToSS SizedSeq Word16
    st_i0 (Word16
    opcode Word16 -> [Word16] -> [Word16]
    forall a. a -> [a] -> [a]
    : [Word16]
    words)
            in ((), (SizedSeq Word16
    st_i1,SizedSeq BCONPtr
    st_l0,SizedSeq BCOPtr
    st_p0))
          Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    go Assembler a
    k

    type LabelEnvMap = Map LocalLabel Word

    data InspectState = InspectState
      { InspectState -> Word
    instrCount :: !Word
      , InspectState -> Word
    ptrCount :: !Word
      , InspectState -> Word
    litCount :: !Word
      , InspectState -> LabelEnvMap
    lblEnv :: LabelEnvMap
      }

    inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
    inspectAsm :: forall a.
    Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
    inspectAsm Platform
    platform Bool
    long_jumps Word
    initial_offset
      = InspectState -> Assembler a -> (Word, LabelEnvMap)
    go (Word -> Word -> Word -> LabelEnvMap -> InspectState
    InspectState Word
    initial_offset Word
    0 Word
    0 LabelEnvMap
    forall k a. Map k a
    Map.empty)
      where
        go :: InspectState -> Assembler a -> (Word, LabelEnvMap)
    go InspectState
    s (NullAsm a
    _) = (InspectState -> Word
    instrCount InspectState
    s, InspectState -> LabelEnvMap
    lblEnv InspectState
    s)
        go InspectState
    s (AllocPtr IO BCOPtr
    _ Word -> Assembler a
    k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
    go (InspectState
    s { ptrCount = n + 1 }) (Word -> Assembler a
    k Word
    n)
          where n :: Word
    n = InspectState -> Word
    ptrCount InspectState
    s
        go InspectState
    s (AllocLit [BCONPtr]
    ls Word -> Assembler a
    k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
    go (InspectState
    s { litCount = n + genericLength ls }) (Word -> Assembler a
    k Word
    n)
          where n :: Word
    n = InspectState -> Word
    litCount InspectState
    s
        go InspectState
    s (AllocLabel LocalLabel
    lbl Assembler a
    k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
    go InspectState
    s' Assembler a
    k
          where s' :: InspectState
    s' = InspectState
    s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
        go InspectState
    s (Emit Word16
    _ [Operand]
    ops Assembler a
    k) = InspectState -> Assembler a -> (Word, LabelEnvMap)
    go InspectState
    s' Assembler a
    k
          where
            s' :: InspectState
    s' = InspectState
    s { instrCount = instrCount s + size }
            size :: Word
    size = [Word] -> Word
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((Operand -> Word) -> [Operand] -> [Word]
    forall a b. (a -> b) -> [a] -> [b]
    map Operand -> Word
    count [Operand]
    ops) Word -> Word -> Word
    forall a. Num a => a -> a -> a
    + Word
    1
            largeOps :: Bool
    largeOps = (Operand -> Bool) -> [Operand] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Bool -> Operand -> Bool
    largeOp Bool
    long_jumps) [Operand]
    ops
            count :: Operand -> Word
    count (SmallOp Word16
    _) = Word
    1
            count (LabelOp LocalLabel
    _) = Operand -> Word
    count (Word -> Operand
    Op Word
    0)
            count (Op Word
    _) = if Bool
    largeOps then Platform -> Word
    largeArg16s Platform
    platform else Word
    1
            count (IOp Int
    _) = if Bool
    largeOps then Platform -> Word
    largeArg16s Platform
    platform else Word
    1

    -- Bring in all the bci_ bytecode constants.
    #include "Bytecodes.h"

    largeArgInstr :: Word16 -> Word16
    largeArgInstr :: Word16 -> Word16
    largeArgInstr Word16
    bci = bci_FLAG_LARGE_ARGS .|. bci

    largeArg :: Platform -> Word64 -> [Word16]
    largeArg :: Platform -> Word64 -> [Word16]
    largeArg Platform
    platform Word64
    w = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
       PlatformWordSize
    PW8 -> [Word64 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word64
    w Word64 -> Int -> Word64
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    48),
               Word64 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word64
    w Word64 -> Int -> Word64
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    32),
               Word64 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word64
    w Word64 -> Int -> Word64
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    16),
               Word64 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    w]
       PlatformWordSize
    PW4 -> Bool -> SDoc -> [Word16] -> [Word16]
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Word64
    w Word64 -> Word64 -> Bool
    forall a. Ord a => a -> a -> Bool
    < Word32 -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32
    forall a. Bounded a => a
    maxBound :: Word32))
                        (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "largeArg too big:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Word64 -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Word64
    w) ([Word16] -> [Word16]) -> [Word16] -> [Word16]
    forall a b. (a -> b) -> a -> b
    $
              [Word64 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word64
    w Word64 -> Int -> Word64
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    16),
               Word64 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    w]

    largeArg16s :: Platform -> Word
    largeArg16s :: Platform -> Word
    largeArg16s Platform
    platform = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
       PlatformWordSize
    PW8 -> Word
    4
       PlatformWordSize
    PW4 -> Word
    2

    assembleI :: Platform
              -> BCInstr
              -> Assembler ()
    assembleI :: Platform -> BCInstr -> Assembler ()
    assembleI Platform
    platform BCInstr
    i = case BCInstr
    i of
      STKCHECK Word
    n               -> Word16 -> [Operand] -> Assembler ()
    emit bci_STKCHECK [Op n]
      PUSH_L WordOff
    o1                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_L [wOp o1]
      PUSH_LL WordOff
    o1 WordOff
    o2            -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_LL [wOp o1, wOp o2]
      PUSH_LLL WordOff
    o1 WordOff
    o2 WordOff
    o3        -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]
      PUSH8 ByteOff
    o1                 -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH8 [bOp o1]
      PUSH16 ByteOff
    o1                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH16 [bOp o1]
      PUSH32 ByteOff
    o1                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH32 [bOp o1]
      PUSH8_W ByteOff
    o1               -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH8_W [bOp o1]
      PUSH16_W ByteOff
    o1              -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH16_W [bOp o1]
      PUSH32_W ByteOff
    o1              -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH32_W [bOp o1]
      PUSH_G Name
    nm                -> do p <- BCOPtr -> Assembler Word
    ptr (Name -> BCOPtr
    BCOPtrName Name
    nm)
                                     emit bci_PUSH_G [Op p]
      PUSH_PRIMOP PrimOp
    op           -> do p <- BCOPtr -> Assembler Word
    ptr (PrimOp -> BCOPtr
    BCOPtrPrimOp PrimOp
    op)
                                     emit bci_PUSH_G [Op p]
      PUSH_BCO ProtoBCO Name
    proto           -> do let ul_bco :: IO UnlinkedBCO
    ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform ProtoBCO Name
    proto
                                     p <- IO BCOPtr -> Assembler Word
    ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM UnlinkedBCO -> BCOPtr
    BCOPtrBCO IO UnlinkedBCO
    ul_bco)
                                     emit bci_PUSH_G [Op p]
      PUSH_ALTS ProtoBCO Name
    proto ArgRep
    pk
                               -> do let ul_bco :: IO UnlinkedBCO
    ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform ProtoBCO Name
    proto
                                     p <- IO BCOPtr -> Assembler Word
    ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM UnlinkedBCO -> BCOPtr
    BCOPtrBCO IO UnlinkedBCO
    ul_bco)
                                     emit (push_alts pk) [Op p]
      PUSH_ALTS_TUPLE ProtoBCO Name
    proto NativeCallInfo
    call_info ProtoBCO Name
    tuple_proto
                               -> do let ul_bco :: IO UnlinkedBCO
    ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform ProtoBCO Name
    proto
                                         ul_tuple_bco :: IO UnlinkedBCO
    ul_tuple_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform
                                                                    ProtoBCO Name
    tuple_proto
                                     p <- IO BCOPtr -> Assembler Word
    ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM UnlinkedBCO -> BCOPtr
    BCOPtrBCO IO UnlinkedBCO
    ul_bco)
                                     p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
                                     info <- word (fromIntegral $
                                                  mkNativeCallInfoSig platform call_info)
                                     emit bci_PUSH_ALTS_T
                                          [Op p, Op info, Op p_tup]
      BCInstr
    PUSH_PAD8                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_PAD8 []
      BCInstr
    PUSH_PAD16               -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_PAD16 []
      BCInstr
    PUSH_PAD32               -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_PAD32 []
      PUSH_UBX8 Literal
    lit            -> do np <- Literal -> Assembler Word
    literal Literal
    lit
                                     emit bci_PUSH_UBX8 [Op np]
      PUSH_UBX16 Literal
    lit           -> do np <- Literal -> Assembler Word
    literal Literal
    lit
                                     emit bci_PUSH_UBX16 [Op np]
      PUSH_UBX32 Literal
    lit           -> do np <- Literal -> Assembler Word
    literal Literal
    lit
                                     emit bci_PUSH_UBX32 [Op np]
      PUSH_UBX Literal
    lit WordOff
    nws         -> do np <- Literal -> Assembler Word
    literal Literal
    lit
                                     emit bci_PUSH_UBX [Op np, wOp nws]

      -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
      PUSH_ADDR Name
    nm             -> do np <- [BCONPtr] -> Assembler Word
    lit [Name -> BCONPtr
    BCONPtrAddr Name
    nm]
                                     emit bci_PUSH_UBX [Op np, SmallOp 1]

      BCInstr
    PUSH_APPLY_N             -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_N []
      BCInstr
    PUSH_APPLY_V             -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_V []
      BCInstr
    PUSH_APPLY_F             -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_F []
      BCInstr
    PUSH_APPLY_D             -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_D []
      BCInstr
    PUSH_APPLY_L             -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_L []
      BCInstr
    PUSH_APPLY_P             -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_P []
      BCInstr
    PUSH_APPLY_PP            -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_PP []
      BCInstr
    PUSH_APPLY_PPP           -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_PPP []
      BCInstr
    PUSH_APPLY_PPPP          -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_PPPP []
      BCInstr
    PUSH_APPLY_PPPPP         -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_PPPPP []
      BCInstr
    PUSH_APPLY_PPPPPP        -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_APPLY_PPPPPP []

      SLIDE     WordOff
    n WordOff
    by           -> Word16 -> [Operand] -> Assembler ()
    emit bci_SLIDE [wOp n, wOp by]
      ALLOC_AP  HalfWord
    n              -> Word16 -> [Operand] -> Assembler ()
    emit bci_ALLOC_AP [truncHalfWord platform n]
      ALLOC_AP_NOUPD HalfWord
    n         -> Word16 -> [Operand] -> Assembler ()
    emit bci_ALLOC_AP_NOUPD [truncHalfWord platform n]
      ALLOC_PAP HalfWord
    arity HalfWord
    n        -> Word16 -> [Operand] -> Assembler ()
    emit bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]
      MKAP      WordOff
    off HalfWord
    sz         -> Word16 -> [Operand] -> Assembler ()
    emit bci_MKAP [wOp off, truncHalfWord platform sz]
      MKPAP     WordOff
    off HalfWord
    sz         -> Word16 -> [Operand] -> Assembler ()
    emit bci_MKPAP [wOp off, truncHalfWord platform sz]
      UNPACK    WordOff
    n              -> Word16 -> [Operand] -> Assembler ()
    emit bci_UNPACK [wOp n]
      PACK      DataCon
    dcon WordOff
    sz        -> do itbl_no <- [BCONPtr] -> Assembler Word
    lit [Name -> BCONPtr
    BCONPtrItbl (DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    dcon)]
                                     emit bci_PACK [Op itbl_no, wOp sz]
      LABEL     LocalLabel
    lbl            -> LocalLabel -> Assembler ()
    label LocalLabel
    lbl
      TESTLT_I  Int
    i LocalLabel
    l            -> do np <- Int -> Assembler Word
    int Int
    i
                                     emit bci_TESTLT_I [Op np, LabelOp l]
      TESTEQ_I  Int
    i LocalLabel
    l            -> do np <- Int -> Assembler Word
    int Int
    i
                                     emit bci_TESTEQ_I [Op np, LabelOp l]
      TESTLT_W  Word
    w LocalLabel
    l            -> do np <- Word -> Assembler Word
    word Word
    w
                                     emit bci_TESTLT_W [Op np, LabelOp l]
      TESTEQ_W  Word
    w LocalLabel
    l            -> do np <- Word -> Assembler Word
    word Word
    w
                                     emit bci_TESTEQ_W [Op np, LabelOp l]
      TESTLT_I64  Int64
    i LocalLabel
    l          -> do np <- Word64 -> Assembler Word
    word64 (Int64 -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int64
    i)
                                     emit bci_TESTLT_I64 [Op np, LabelOp l]
      TESTEQ_I64  Int64
    i LocalLabel
    l          -> do np <- Word64 -> Assembler Word
    word64 (Int64 -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int64
    i)
                                     emit bci_TESTEQ_I64 [Op np, LabelOp l]
      TESTLT_I32  Int32
    i LocalLabel
    l          -> do np <- Word -> Assembler Word
    word (Int32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int32
    i)
                                     emit bci_TESTLT_I32 [Op np, LabelOp l]
      TESTEQ_I32 Int32
    i LocalLabel
    l           -> do np <- Word -> Assembler Word
    word (Int32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int32
    i)
                                     emit bci_TESTEQ_I32 [Op np, LabelOp l]
      TESTLT_I16  Int16
    i LocalLabel
    l          -> do np <- Word -> Assembler Word
    word (Int16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int16
    i)
                                     emit bci_TESTLT_I16 [Op np, LabelOp l]
      TESTEQ_I16 Int16
    i LocalLabel
    l           -> do np <- Word -> Assembler Word
    word (Int16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int16
    i)
                                     emit bci_TESTEQ_I16 [Op np, LabelOp l]
      TESTLT_I8  Int8
    i LocalLabel
    l           -> do np <- Word -> Assembler Word
    word (Int8 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int8
    i)
                                     emit bci_TESTLT_I8 [Op np, LabelOp l]
      TESTEQ_I8 Int16
    i LocalLabel
    l            -> do np <- Word -> Assembler Word
    word (Int16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int16
    i)
                                     emit bci_TESTEQ_I8 [Op np, LabelOp l]
      TESTLT_W64  Word64
    w LocalLabel
    l          -> do np <- Word64 -> Assembler Word
    word64 Word64
    w
                                     emit bci_TESTLT_W64 [Op np, LabelOp l]
      TESTEQ_W64  Word64
    w LocalLabel
    l          -> do np <- Word64 -> Assembler Word
    word64 Word64
    w
                                     emit bci_TESTEQ_W64 [Op np, LabelOp l]
      TESTLT_W32  Word32
    w LocalLabel
    l          -> do np <- Word -> Assembler Word
    word (Word32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    w)
                                     emit bci_TESTLT_W32 [Op np, LabelOp l]
      TESTEQ_W32  Word32
    w LocalLabel
    l          -> do np <- Word -> Assembler Word
    word (Word32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    w)
                                     emit bci_TESTEQ_W32 [Op np, LabelOp l]
      TESTLT_W16  Word16
    w LocalLabel
    l          -> do np <- Word -> Assembler Word
    word (Word16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    w)
                                     emit bci_TESTLT_W16 [Op np, LabelOp l]
      TESTEQ_W16  Word16
    w LocalLabel
    l          -> do np <- Word -> Assembler Word
    word (Word16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    w)
                                     emit bci_TESTEQ_W16 [Op np, LabelOp l]
      TESTLT_W8  Word8
    w LocalLabel
    l           -> do np <- Word -> Assembler Word
    word (Word8 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    w)
                                     emit bci_TESTLT_W8 [Op np, LabelOp l]
      TESTEQ_W8  Word8
    w LocalLabel
    l           -> do np <- Word -> Assembler Word
    word (Word8 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    w)
                                     emit bci_TESTEQ_W8 [Op np, LabelOp l]
      TESTLT_F  Float
    f LocalLabel
    l            -> do np <- Float -> Assembler Word
    float Float
    f
                                     emit bci_TESTLT_F [Op np, LabelOp l]
      TESTEQ_F  Float
    f LocalLabel
    l            -> do np <- Float -> Assembler Word
    float Float
    f
                                     emit bci_TESTEQ_F [Op np, LabelOp l]
      TESTLT_D  Double
    d LocalLabel
    l            -> do np <- Double -> Assembler Word
    double Double
    d
                                     emit bci_TESTLT_D [Op np, LabelOp l]
      TESTEQ_D  Double
    d LocalLabel
    l            -> do np <- Double -> Assembler Word
    double Double
    d
                                     emit bci_TESTEQ_D [Op np, LabelOp l]
      TESTLT_P  Word16
    i LocalLabel
    l            -> Word16 -> [Operand] -> Assembler ()
    emit bci_TESTLT_P [SmallOp i, LabelOp l]
      TESTEQ_P  Word16
    i LocalLabel
    l            -> Word16 -> [Operand] -> Assembler ()
    emit bci_TESTEQ_P [SmallOp i, LabelOp l]
      BCInstr
    CASEFAIL                 -> Word16 -> [Operand] -> Assembler ()
    emit bci_CASEFAIL []
      SWIZZLE   WordOff
    stkoff Int
    n       -> Word16 -> [Operand] -> Assembler ()
    emit bci_SWIZZLE [wOp stkoff, IOp n]
      JMP       LocalLabel
    l              -> Word16 -> [Operand] -> Assembler ()
    emit bci_JMP [LabelOp l]
      BCInstr
    ENTER                    -> Word16 -> [Operand] -> Assembler ()
    emit bci_ENTER []
      RETURN ArgRep
    rep               -> Word16 -> [Operand] -> Assembler ()
    emit (ArgRep -> Word16
    return_non_tuple ArgRep
    rep) []
      BCInstr
    RETURN_TUPLE             -> Word16 -> [Operand] -> Assembler ()
    emit bci_RETURN_T []
      CCALL WordOff
    off RemotePtr C_ffi_cif
    m_addr Word16
    i       -> do np <- RemotePtr C_ffi_cif -> Assembler Word
    forall {a}. RemotePtr a -> Assembler Word
    addr RemotePtr C_ffi_cif
    m_addr
                                     emit bci_CCALL [wOp off, Op np, SmallOp i]
      BCInstr
    PRIMCALL                 -> Word16 -> [Operand] -> Assembler ()
    emit bci_PRIMCALL []
      BRK_FUN ForeignRef BreakArray
    arr Word16
    index RemotePtr ModuleName
    mod RemotePtr CostCentre
    cc -> do p1 <- BCOPtr -> Assembler Word
    ptr (ForeignRef BreakArray -> BCOPtr
    BCOPtrBreakArray ForeignRef BreakArray
    arr)
                                     m <- addr mod
                                     np <- addr cc
                                     emit bci_BRK_FUN [Op p1, SmallOp index,
                                                       Op m, Op np]

      where
        literal :: Literal -> Assembler Word
    literal (LitLabel FastString
    fs (Just Int
    sz) FunctionOrData
    _)
         | Platform -> OS
    platformOS Platform
    platform OS -> OS -> Bool
    forall a. Eq a => a -> a -> Bool
    == OS
    OSMinGW32
             = FastString -> Assembler Word
    litlabel (FastString -> FastString -> FastString
    appendFS FastString
    fs (String -> FastString
    mkFastString (Char
    '@'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Int -> String
    forall a. Show a => a -> String
    show Int
    sz)))
         -- On Windows, stdcall labels have a suffix indicating the no. of
         -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
        literal (LitLabel FastString
    fs Maybe Int
    _ FunctionOrData
    _) = FastString -> Assembler Word
    litlabel FastString
    fs
        literal Literal
    LitNullAddr       = Word -> Assembler Word
    word Word
    0
        literal (LitFloat Rational
    r)      = Float -> Assembler Word
    float (Rational -> Float
    forall a. Fractional a => Rational -> a
    fromRational Rational
    r)
        literal (LitDouble Rational
    r)     = Double -> Assembler Word
    double (Rational -> Double
    forall a. Fractional a => Rational -> a
    fromRational Rational
    r)
        literal (LitChar Char
    c)       = Int -> Assembler Word
    int (Char -> Int
    ord Char
    c)
        literal (LitString ByteString
    bs)    = [BCONPtr] -> Assembler Word
    lit [ByteString -> BCONPtr
    BCONPtrStr ByteString
    bs]
           -- LitString requires a zero-terminator when emitted
        literal (LitNumber LitNumType
    nt Integer
    i) = case LitNumType
    nt of
          LitNumType
    LitNumInt     -> Word -> Assembler Word
    word (Integer -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord    -> Word -> Assembler Word
    word (Integer -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt8    -> Word8 -> Assembler Word
    word8 (Integer -> Word8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord8   -> Word8 -> Assembler Word
    word8 (Integer -> Word8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt16   -> Word16 -> Assembler Word
    word16 (Integer -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord16  -> Word16 -> Assembler Word
    word16 (Integer -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt32   -> Word32 -> Assembler Word
    word32 (Integer -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord32  -> Word32 -> Assembler Word
    word32 (Integer -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt64   -> Word64 -> Assembler Word
    word64 (Integer -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord64  -> Word64 -> Assembler Word
    word64 (Integer -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumBigNat  -> String -> Assembler Word
    forall a. HasCallStack => String -> a
    panic String
    "GHC.ByteCode.Asm.literal: LitNumBigNat"

        -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
        -- likely to elicit a crash (rather than corrupt memory) in case absence
        -- analysis messed up.
        literal (LitRubbish {}) = Word -> Assembler Word
    word Word
    0

        litlabel :: FastString -> Assembler Word
    litlabel FastString
    fs = [BCONPtr] -> Assembler Word
    lit [FastString -> BCONPtr
    BCONPtrLbl FastString
    fs]
        addr :: RemotePtr a -> Assembler Word
    addr (RemotePtr Word64
    a) = [Word] -> Assembler Word
    words [Word64 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    a]
        words :: [Word] -> Assembler Word
    words [Word]
    ws = [BCONPtr] -> Assembler Word
    lit ((Word -> BCONPtr) -> [Word] -> [BCONPtr]
    forall a b. (a -> b) -> [a] -> [b]
    map Word -> BCONPtr
    BCONPtrWord [Word]
    ws)
        word :: Word -> Assembler Word
    word Word
    w = [Word] -> Assembler Word
    words [Word
    w]
        word_size :: PlatformWordSize
    word_size  = Platform -> PlatformWordSize
    platformWordSize Platform
    platform
        word_size_bits :: Int
    word_size_bits = Platform -> Int
    platformWordSizeInBits Platform
    platform

        -- Make lists of host-sized words for literals, so that when the
        -- words are placed in memory at increasing addresses, the
        -- bit pattern is correct for the host's word size and endianness.
        --
        -- Note that we only support host endianness == target endianness for now,
        -- even with the external interpreter. This would need to be fixed to
        -- support host endianness /= target endianness
        int :: Int -> Assembler Word
        int :: Int -> Assembler Word
    int  Int
    i = Word -> Assembler Word
    word (Int -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i)

        float :: Float -> Assembler Word
        float :: Float -> Assembler Word
    float Float
    f = Word32 -> Assembler Word
    word32 (Float -> Word32
    castFloatToWord32 Float
    f)

        double :: Double -> Assembler Word
        double :: Double -> Assembler Word
    double Double
    d = Word64 -> Assembler Word
    word64 (Double -> Word64
    castDoubleToWord64 Double
    d)

        word64 :: Word64 -> Assembler Word
        word64 :: Word64 -> Assembler Word
    word64 Word64
    ww = case PlatformWordSize
    word_size of
           PlatformWordSize
    PW4 ->
            let !wl :: Word
    wl = Word64 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    ww
                !wh :: Word
    wh = Word64 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word64
    ww Word64 -> Int -> Word64
    forall a. Bits a => a -> Int -> a
    `unsafeShiftR` Int
    32)
            in case Platform -> ByteOrder
    platformByteOrder Platform
    platform of
                ByteOrder
    LittleEndian -> [Word] -> Assembler Word
    words [Word
    wl,Word
    wh]
                ByteOrder
    BigEndian    -> [Word] -> Assembler Word
    words [Word
    wh,Word
    wl]
           PlatformWordSize
    PW8 -> Word -> Assembler Word
    word (Word64 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    ww)

        word8 :: Word8 -> Assembler Word
        word8 :: Word8 -> Assembler Word
    word8  Word8
    x = case Platform -> ByteOrder
    platformByteOrder Platform
    platform of
          ByteOrder
    LittleEndian -> Word -> Assembler Word
    word (Word8 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    x)
          ByteOrder
    BigEndian    -> Word -> Assembler Word
    word (Word8 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    x Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `unsafeShiftL` (Int
    word_size_bits Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    8))

        word16 :: Word16 -> Assembler Word
        word16 :: Word16 -> Assembler Word
    word16 Word16
    x = case Platform -> ByteOrder
    platformByteOrder Platform
    platform of
          ByteOrder
    LittleEndian -> Word -> Assembler Word
    word (Word16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    x)
          ByteOrder
    BigEndian    -> Word -> Assembler Word
    word (Word16 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    x Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `unsafeShiftL` (Int
    word_size_bits Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    16))

        word32 :: Word32 -> Assembler Word
        word32 :: Word32 -> Assembler Word
    word32 Word32
    x = case Platform -> ByteOrder
    platformByteOrder Platform
    platform of
          ByteOrder
    LittleEndian -> Word -> Assembler Word
    word (Word32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    x)
          ByteOrder
    BigEndian    -> case PlatformWordSize
    word_size of
            PlatformWordSize
    PW4 -> Word -> Assembler Word
    word (Word32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    x)
            PlatformWordSize
    PW8 -> Word -> Assembler Word
    word (Word32 -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    x Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `unsafeShiftL` Int
    32)

    isLargeW :: Word -> Bool
    isLargeW :: Word -> Bool
    isLargeW Word
    n = Word
    n Word -> Word -> Bool
    forall a. Ord a => a -> a -> Bool
    > Word
    65535

    isLargeI :: Int -> Bool
    isLargeI :: Int -> Bool
    isLargeI Int
    n = Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    32767 Bool -> Bool -> Bool
    || Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < -Int
    32768

    push_alts :: ArgRep -> Word16
    push_alts :: ArgRep -> Word16
    push_alts ArgRep
    V   = bci_PUSH_ALTS_V
    push_alts ArgRep
    P   = bci_PUSH_ALTS_P
    push_alts ArgRep
    N   = bci_PUSH_ALTS_N
    push_alts ArgRep
    L   = bci_PUSH_ALTS_L
    push_alts ArgRep
    F   = bci_PUSH_ALTS_F
    push_alts ArgRep
    D   = bci_PUSH_ALTS_D
    push_alts ArgRep
    V16 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "push_alts: vector"
    push_alts ArgRep
    V32 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "push_alts: vector"
    push_alts ArgRep
    V64 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "push_alts: vector"

    return_non_tuple :: ArgRep -> Word16
    return_non_tuple :: ArgRep -> Word16
    return_non_tuple ArgRep
    V   = bci_RETURN_V
    return_non_tuple ArgRep
    P   = bci_RETURN_P
    return_non_tuple ArgRep
    N   = bci_RETURN_N
    return_non_tuple ArgRep
    L   = bci_RETURN_L
    return_non_tuple ArgRep
    F   = bci_RETURN_F
    return_non_tuple ArgRep
    D   = bci_RETURN_D
    return_non_tuple ArgRep
    V16 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "return_non_tuple: vector"
    return_non_tuple ArgRep
    V32 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "return_non_tuple: vector"
    return_non_tuple ArgRep
    V64 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "return_non_tuple: vector"

    {-
      we can only handle up to a fixed number of words on the stack,
      because we need a stg_ctoi_tN stack frame for each size N. See
      Note [unboxed tuple bytecodes and tuple_BCO].

      If needed, you can support larger tuples by adding more in
      StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
      raising this limit.

      Note that the limit is the number of words passed on the stack.
      If the calling convention passes part of the tuple in registers, the
      maximum number of tuple elements may be larger. Elements can also
      take multiple words on the stack (for example Double# on a 32 bit
      platform).
     -}
    maxTupleReturnNativeStackSize :: WordOff
    maxTupleReturnNativeStackSize :: WordOff
    maxTupleReturnNativeStackSize = WordOff
    62

    {-
      Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall
      use to convert arguments between the native calling convention and the
      interpreter.

      See Note [GHCi and native call registers] for more information.
     -}
    mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32
    mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32
    mkNativeCallInfoSig Platform
    platform NativeCallInfo{GlobalRegSet
    NativeCallType
    WordOff
    nativeCallType :: NativeCallType
    nativeCallSize :: WordOff
    nativeCallRegs :: GlobalRegSet
    nativeCallStackSpillSize :: WordOff
    nativeCallStackSpillSize :: NativeCallInfo -> WordOff
    nativeCallRegs :: NativeCallInfo -> GlobalRegSet
    nativeCallSize :: NativeCallInfo -> WordOff
    nativeCallType :: NativeCallInfo -> NativeCallType
    ..}
      | NativeCallType
    nativeCallType NativeCallType -> NativeCallType -> Bool
    forall a. Eq a => a -> a -> Bool
    == NativeCallType
    NativeTupleReturn Bool -> Bool -> Bool
    && WordOff
    nativeCallStackSpillSize WordOff -> WordOff -> Bool
    forall a. Ord a => a -> a -> Bool
    > WordOff
    maxTupleReturnNativeStackSize
      = String -> SDoc -> Word32
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkNativeCallInfoSig: tuple too big for the bytecode compiler"
                 (WordOff -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr WordOff
    nativeCallStackSpillSize SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "stack words." SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
                  String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Use -fobject-code to get around this limit"
                 )
      | Bool
    otherwise
      = Bool
    -> SDoc
    -> (Bool
        -> SDoc
        -> (Bool
            -> SDoc
            -> ((Word32 -> (GlobalReg, Int) -> Word32)
                -> Word32 -> [(GlobalReg, Int)] -> Word32)
            -> (Word32 -> (GlobalReg, Int) -> Word32)
            -> Word32
            -> [(GlobalReg, Int)]
            -> Word32)
        -> Bool
        -> SDoc
        -> ((Word32 -> (GlobalReg, Int) -> Word32)
            -> Word32 -> [(GlobalReg, Int)] -> Word32)
        -> (Word32 -> (GlobalReg, Int) -> Word32)
        -> Word32
        -> [(GlobalReg, Int)]
        -> Word32)
    -> Bool
    -> SDoc
    -> (Bool
        -> SDoc
        -> ((Word32 -> (GlobalReg, Int) -> Word32)
            -> Word32 -> [(GlobalReg, Int)] -> Word32)
        -> (Word32 -> (GlobalReg, Int) -> Word32)
        -> Word32
        -> [(GlobalReg, Int)]
        -> Word32)
    -> Bool
    -> SDoc
    -> ((Word32 -> (GlobalReg, Int) -> Word32)
        -> Word32 -> [(GlobalReg, Int)] -> Word32)
    -> (Word32 -> (GlobalReg, Int) -> Word32)
    -> Word32
    -> [(GlobalReg, Int)]
    -> Word32
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ([GlobalReg] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [GlobalReg]
    regs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    24) (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "too many registers for bitmap:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ([GlobalReg] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [GlobalReg]
    regs)) {- 24 bits for register bitmap -}
        Bool
    -> SDoc
    -> (Bool
        -> SDoc
        -> ((Word32 -> (GlobalReg, Int) -> Word32)
            -> Word32 -> [(GlobalReg, Int)] -> Word32)
        -> (Word32 -> (GlobalReg, Int) -> Word32)
        -> Word32
        -> [(GlobalReg, Int)]
        -> Word32)
    -> Bool
    -> SDoc
    -> ((Word32 -> (GlobalReg, Int) -> Word32)
        -> Word32 -> [(GlobalReg, Int)] -> Word32)
    -> (Word32 -> (GlobalReg, Int) -> Word32)
    -> Word32
    -> [(GlobalReg, Int)]
    -> Word32
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (Word32
    cont_offset Word32 -> Word32 -> Bool
    forall a. Ord a => a -> a -> Bool
    < Word32
    255) (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "continuation offset too large:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Word32 -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Word32
    cont_offset) {- 8 bits for continuation offset (only for NativeTupleReturn) -}
        Bool
    -> SDoc
    -> ((Word32 -> (GlobalReg, Int) -> Word32)
        -> Word32 -> [(GlobalReg, Int)] -> Word32)
    -> (Word32 -> (GlobalReg, Int) -> Word32)
    -> Word32
    -> [(GlobalReg, Int)]
    -> Word32
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ((GlobalReg -> Bool) -> [GlobalReg] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (GlobalReg -> [GlobalReg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [GlobalReg]
    regs) (GlobalRegSet -> [GlobalReg]
    forall r. RegSet r -> [r]
    regSetToList GlobalRegSet
    nativeCallRegs)) (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "not all registers accounted for") {- all regs accounted for -}
        (Word32 -> (GlobalReg, Int) -> Word32)
    -> Word32 -> [(GlobalReg, Int)] -> Word32
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Word32 -> (GlobalReg, Int) -> Word32
    reg_bit Word32
    0 ([GlobalReg] -> [Int] -> [(GlobalReg, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [GlobalReg]
    regs [Int
    0..]) Word32 -> Word32 -> Word32
    forall a. Bits a => a -> a -> a
    .|. (Word32
    cont_offset Word32 -> Int -> Word32
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    24)
      where
        cont_offset :: Word32
        cont_offset :: Word32
    cont_offset
          | NativeCallType
    nativeCallType NativeCallType -> NativeCallType -> Bool
    forall a. Eq a => a -> a -> Bool
    == NativeCallType
    NativeTupleReturn = WordOff -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    nativeCallStackSpillSize
          | Bool
    otherwise                           = Word32
    0 -- there is no continuation for primcalls

        reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
        reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
    reg_bit Word32
    x (GlobalReg
    r, Int
    n)
          | GlobalReg
    r GlobalReg -> GlobalRegSet -> Bool
    forall r. Ord r => r -> RegSet r -> Bool
    `elemRegSet` GlobalRegSet
    nativeCallRegs = Word32
    x Word32 -> Word32 -> Word32
    forall a. Bits a => a -> a -> a
    .|. Word32
    1 Word32 -> Int -> Word32
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    n
          | Bool
    otherwise                     = Word32
    x
        regs :: [GlobalReg]
    regs = Platform -> [GlobalReg]
    allArgRegsCover Platform
    platform

    mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
    mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
    mkNativeCallInfoLit Platform
    platform NativeCallInfo
    call_info =
      Platform -> Integer -> Literal
    mkLitWord Platform
    platform (Integer -> Literal) -> (Word32 -> Integer) -> Word32 -> Literal
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Word32 -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> Literal) -> Word32 -> Literal
    forall a b. (a -> b) -> a -> b
    $ Platform -> NativeCallInfo -> Word32
    mkNativeCallInfoSig Platform
    platform NativeCallInfo
    call_info

    iNTERP_STACK_CHECK_THRESH :: Int
    iNTERP_STACK_CHECK_THRESH :: Int
    iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH