    {-# 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,
            mkTupleInfoLit
      ) where

    #include "HsVersions.h"

    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 hiding ( WordOff )

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

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

    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        ( tupleRegsCover )
    import GHC.Platform
    import GHC.Platform.Profile

    import Control.Monad
    import Control.Monad.ST ( runST )
    import Control.Monad.Trans.Class
    import Control.Monad.Trans.State.Strict

    import Data.Array.MArray

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

    import Data.Array.Unsafe( castSTUArray )

    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

    -- -----------------------------------------------------------------------------
    -- 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]
      -> [RemotePtr ()]
      -> Maybe ModBreaks
      -> IO CompiledByteCode
    assembleBCOs :: Interp
    -> Profile
    -> [ProtoBCO Name]
    -> [TyCon]
    -> [RemotePtr ()]
    -> Maybe ModBreaks
    -> IO CompiledByteCode
    assembleBCOs Interp
    interp Profile
    profile [ProtoBCO Name]
    proto_bcos [TyCon]
    tycons [RemotePtr ()]
    top_strs Maybe ModBreaks
    modbreaks = do
      -- TODO: the profile should be bundled with the interpreter: the rts ways are
      -- fixed for an interpreter
      ItblEnv
    itblenv <- Interp -> Profile -> [TyCon] -> IO ItblEnv
    mkITbls Interp
    interp Profile
    profile [TyCon]
    tycons
      [UnlinkedBCO]
    bcos    <- (ProtoBCO Name -> IO UnlinkedBCO)
    -> [ProtoBCO Name] -> IO [UnlinkedBCO]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO (Profile -> Platform
    profilePlatform Profile
    profile)) [ProtoBCO Name]
    proto_bcos
      ([UnlinkedBCO]
    bcos',[RemotePtr ()]
    ptrs) <- Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
    mallocStrings Interp
    interp [UnlinkedBCO]
    bcos
      CompiledByteCode -> IO CompiledByteCode
    forall (m :: * -> *) a. Monad m => a -> m a
    return CompiledByteCode
        { bc_bcos :: [UnlinkedBCO]
    bc_bcos = [UnlinkedBCO]
    bcos'
        , bc_itbls :: ItblEnv
    bc_itbls =  ItblEnv
    itblenv
        , bc_ffis :: [FFIInfo]
    bc_ffis = (ProtoBCO Name -> [FFIInfo]) -> [ProtoBCO Name] -> [FFIInfo]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ProtoBCO Name -> [FFIInfo]
    forall a. ProtoBCO a -> [FFIInfo]
    protoBCOFFIs [ProtoBCO Name]
    proto_bcos
        , bc_strs :: [RemotePtr ()]
    bc_strs = [RemotePtr ()]
    top_strs [RemotePtr ()] -> [RemotePtr ()] -> [RemotePtr ()]
    forall a. [a] -> [a] -> [a]
    ++ [RemotePtr ()]
    ptrs
        , bc_breaks :: Maybe ModBreaks
    bc_breaks = Maybe ModBreaks
    modbreaks
        }

    -- Find all the literal strings and malloc them together.  We want to
    -- do this because:
    --
    --  a) It should be done when we compile the module, not each time we relink it
    --  b) For -fexternal-interpreter It's more efficient to malloc the strings
    --     as a single batch message, especially when compiling in parallel.
    --
    mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
    mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
    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) [])
      [RemotePtr ()]
    ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
    forall a. Binary a => Interp -> Message a -> IO a
    interpCmd Interp
    interp ([ByteString] -> Message [RemotePtr ()]
    MallocStrings [ByteString]
    bytestrings)
      ([UnlinkedBCO], [RemotePtr ()])
    -> IO ([UnlinkedBCO], [RemotePtr ()])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (State [RemotePtr ()] [UnlinkedBCO]
    -> [RemotePtr ()] -> [UnlinkedBCO]
    forall s a. State s a -> s -> a
    evalState ((UnlinkedBCO -> StateT [RemotePtr ()] Identity UnlinkedBCO)
    -> [UnlinkedBCO] -> State [RemotePtr ()] [UnlinkedBCO]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM UnlinkedBCO -> StateT [RemotePtr ()] Identity UnlinkedBCO
    forall {m :: * -> *} {a}.
    Monad m =>
    UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
    splice [UnlinkedBCO]
    ulbcos) [RemotePtr ()]
    ptrs, [RemotePtr ()]
    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
    unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
    unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
    unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
    unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
    unlinkedBCOArity :: UnlinkedBCO -> Int
    unlinkedBCOPtrs :: SizedSeq BCOPtr
    unlinkedBCOLits :: SizedSeq BCONPtr
    unlinkedBCOBitmap :: UArray Int Word64
    unlinkedBCOInstrs :: UArray Int Word16
    unlinkedBCOArity :: Int
    unlinkedBCOName :: Name
    unlinkedBCOName :: UnlinkedBCO -> Name
    ..} = do
        SizedSeq BCONPtr
    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)
    mapM BCONPtr -> StateT [RemotePtr a] m BCONPtr
    forall {m :: * -> *} {a}.
    Monad m =>
    BCONPtr -> StateT [RemotePtr a] m BCONPtr
    spliceLit SizedSeq BCONPtr
    unlinkedBCOLits
        SizedSeq BCOPtr
    ptrs <- (BCOPtr -> StateT [RemotePtr a] m BCOPtr)
    -> SizedSeq BCOPtr -> StateT [RemotePtr a] m (SizedSeq BCOPtr)
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM BCOPtr -> StateT [RemotePtr a] m BCOPtr
    splicePtr SizedSeq BCOPtr
    unlinkedBCOPtrs
        UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
    forall (m :: * -> *) a. Monad m => a -> m a
    return UnlinkedBCO
    bco { unlinkedBCOLits :: SizedSeq BCONPtr
    unlinkedBCOLits = SizedSeq BCONPtr
    lits, unlinkedBCOPtrs :: SizedSeq BCOPtr
    unlinkedBCOPtrs = SizedSeq BCOPtr
    ptrs }

      spliceLit :: BCONPtr -> StateT [RemotePtr a] m BCONPtr
    spliceLit (BCONPtrStr ByteString
    _) = do
        [RemotePtr a]
    rptrs <- StateT [RemotePtr a] m [RemotePtr a]
    forall (m :: * -> *) s. Monad m => StateT s m s
    get
        case [RemotePtr a]
    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 (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. String -> a
    panic String
    "mallocStrings:spliceLit"
      spliceLit BCONPtr
    other = BCONPtr -> StateT [RemotePtr a] m BCONPtr
    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 (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
    unlinkedBCOPtrs :: SizedSeq BCOPtr
    unlinkedBCOLits :: SizedSeq BCONPtr
    unlinkedBCOBitmap :: UArray Int Word64
    unlinkedBCOInstrs :: UArray Int Word16
    unlinkedBCOArity :: Int
    unlinkedBCOName :: Name
    unlinkedBCOPtrs :: UnlinkedBCO -> SizedSeq BCOPtr
    unlinkedBCOLits :: UnlinkedBCO -> SizedSeq BCONPtr
    unlinkedBCOInstrs :: UnlinkedBCO -> UArray Int Word16
    unlinkedBCOBitmap :: UnlinkedBCO -> UArray Int Word64
    unlinkedBCOArity :: UnlinkedBCO -> Int
    unlinkedBCOName :: UnlinkedBCO -> Name
    ..} = 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
        [ByteString]
    strs <- StateT [ByteString] m [ByteString]
    forall (m :: * -> *) s. Monad m => StateT s m s
    get
        [ByteString] -> StateT [ByteString] m ()
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
    put (ByteString
    bsByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    :[ByteString]
    strs)
      collectLit BCONPtr
    _ = () -> StateT [ByteString] m ()
    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 (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
      UnlinkedBCO
    ubco <- Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO (Profile -> Platform
    profilePlatform Profile
    profile) ProtoBCO Name
    pbco
      ([UnlinkedBCO
    ubco'], [RemotePtr ()]
    _ptrs) <- Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
    mallocStrings Interp
    interp [UnlinkedBCO
    ubco]
      UnlinkedBCO -> IO UnlinkedBCO
    forall (m :: * -> *) a. Monad m => a -> m a
    return UnlinkedBCO
    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 -> Word16
    protoBCOBitmapSize = Word16
    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
    isLarge (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
    isLarge 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)
      (SizedSeq Word16
    final_insns, SizedSeq BCONPtr
    final_lits, SizedSeq BCOPtr
    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
      ASSERT(n_insns == sizeSS final_insns) return ()

      let asm_insns :: [Word16]
    asm_insns = SizedSeq Word16 -> [Word16]
    forall a. SizedSeq a -> [a]
    ssElts SizedSeq Word16
    final_insns
          insns_arr :: UArray Int Word16
    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 :: UArray Int Word64
    bitmap_arr = Word16 -> [StgWord] -> UArray Int Word64
    mkBitmapArray Word16
    bsize [StgWord]
    bitmap
          ul_bco :: UnlinkedBCO
    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))

      UnlinkedBCO -> IO UnlinkedBCO
    forall (m :: * -> *) a. Monad m => a -> m a
    return UnlinkedBCO
    ul_bco

    mkBitmapArray :: Word16 -> [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 :: Word16 -> [StgWord] -> UArray Int Word64
    mkBitmapArray Word16
    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 (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
    $
          Word16 -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    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
      | SmallOp Word16
      | LabelOp LocalLabel
    -- (unused)  | LargeOp Word

    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
    <$ :: forall a b. a -> Assembler b -> Assembler a
    $c<$ :: forall a b. a -> Assembler b -> Assembler a
    fmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
    $cfmap :: forall a b. (a -> b) -> Assembler a -> Assembler b
    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 (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 (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 (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 (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 (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 (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 (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
    isLarge Word
    w
       LabelOp LocalLabel
    _ -> Bool
    long_jumps
    -- LargeOp _ -> True

    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 (m :: * -> *) a. Monad m => a -> m a
    return a
    x
        go (AllocPtr IO BCOPtr
    p_io Word -> Assembler a
    k) = do
          BCOPtr
    p <- IO BCOPtr
    -> StateT
         (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO BCOPtr
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift IO BCOPtr
    p_io
          Word
    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_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))
          Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    go (Assembler a
     -> StateT
          (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a)
    -> Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    forall a b. (a -> b) -> a -> b
    $ Word -> Assembler a
    k Word
    w
        go (AllocLit [BCONPtr]
    lits Word -> Assembler a
    k) = do
          Word
    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))
          Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    go (Assembler a
     -> StateT
          (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a)
    -> Assembler a
    -> StateT (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) IO a
    forall a b. (a -> b) -> a -> b
    $ Word -> Assembler a
    k Word
    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 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
              opcode :: Word16
    opcode
                | Bool
    largeOps = 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
    largeOps then Platform -> Word -> [Word16]
    largeArg Platform
    platform Word
    w else [Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w]
    --        expand (LargeOp w) = largeArg platform w
          ((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 :: Word
    ptrCount = Word
    n Word -> Word -> Word
    forall a. Num a => a -> a -> a
    + Word
    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 :: Word
    litCount = Word
    n Word -> Word -> Word
    forall a. Num a => a -> a -> a
    + [BCONPtr] -> Word
    forall i a. Num i => [a] -> i
    genericLength [BCONPtr]
    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 :: LabelEnvMap
    lblEnv = LocalLabel -> Word -> LabelEnvMap -> LabelEnvMap
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert LocalLabel
    lbl (InspectState -> Word
    instrCount InspectState
    s) (InspectState -> LabelEnvMap
    lblEnv InspectState
    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 :: Word
    instrCount = InspectState -> Word
    instrCount InspectState
    s Word -> Word -> Word
    forall a. Num a => a -> a -> a
    + Word
    size }
            size :: Word
    size = [Word] -> Word
    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 (LargeOp _) = largeArg16s platform

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

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

    largeArg :: Platform -> Word -> [Word16]
    largeArg :: Platform -> Word -> [Word16]
    largeArg Platform
    platform Word
    w = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
       PlatformWordSize
    PW8 -> [Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word
    w Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    48),
               Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word
    w Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    32),
               Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word
    w Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    16),
               Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    w]
       PlatformWordSize
    PW4 -> [Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word
    w Word -> Int -> Word
    forall a. Bits a => a -> Int -> a
    `shiftR` Int
    16),
               Word -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word
    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 Word16
    o1                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_L [SmallOp o1]
      PUSH_LL Word16
    o1 Word16
    o2            -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
      PUSH_LLL Word16
    o1 Word16
    o2 Word16
    o3        -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
      PUSH8 Word16
    o1                 -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH8 [SmallOp o1]
      PUSH16 Word16
    o1                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH16 [SmallOp o1]
      PUSH32 Word16
    o1                -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH32 [SmallOp o1]
      PUSH8_W Word16
    o1               -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH8_W [SmallOp o1]
      PUSH16_W Word16
    o1              -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH16_W [SmallOp o1]
      PUSH32_W Word16
    o1              -> Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH32_W [SmallOp o1]
      PUSH_G Name
    nm                -> do Word
    p <- BCOPtr -> Assembler Word
    ptr (Name -> BCOPtr
    BCOPtrName Name
    nm)
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_G [Op p]
      PUSH_PRIMOP PrimOp
    op           -> do Word
    p <- BCOPtr -> Assembler Word
    ptr (PrimOp -> BCOPtr
    BCOPtrPrimOp PrimOp
    op)
                                     Word16 -> [Operand] -> Assembler ()
    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
                                     Word
    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)
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_G [Op p]
      PUSH_ALTS ProtoBCO Name
    proto          -> do let ul_bco :: IO UnlinkedBCO
    ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform ProtoBCO Name
    proto
                                     Word
    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)
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_ALTS [Op p]
      PUSH_ALTS_UNLIFTED ProtoBCO Name
    proto ArgRep
    pk
                               -> do let ul_bco :: IO UnlinkedBCO
    ul_bco = Platform -> ProtoBCO Name -> IO UnlinkedBCO
    assembleBCO Platform
    platform ProtoBCO Name
    proto
                                     Word
    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)
                                     Word16 -> [Operand] -> Assembler ()
    emit (ArgRep -> Word16
    push_alts ArgRep
    pk) [Word -> Operand
    Op Word
    p]
      PUSH_ALTS_TUPLE ProtoBCO Name
    proto TupleInfo
    tuple_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
                                     Word
    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)
                                     Word
    p_tup <- 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_tuple_bco)
                                     Word
    info <- Int -> Assembler Word
    int (Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> Int) -> Word32 -> Int
    forall a b. (a -> b) -> a -> b
    $
                                                  Platform -> TupleInfo -> Word32
    mkTupleInfoSig Platform
    platform TupleInfo
    tuple_info)
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_ALTS_T
                                          [Word -> Operand
    Op Word
    p, Word -> Operand
    Op Word
    info, Word -> Operand
    Op Word
    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 Word
    np <- Literal -> Assembler Word
    literal Literal
    lit
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_UBX8 [Op np]
      PUSH_UBX16 Literal
    lit           -> do Word
    np <- Literal -> Assembler Word
    literal Literal
    lit
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_UBX16 [Op np]
      PUSH_UBX32 Literal
    lit           -> do Word
    np <- Literal -> Assembler Word
    literal Literal
    lit
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_UBX32 [Op np]
      PUSH_UBX Literal
    lit Word16
    nws         -> do Word
    np <- Literal -> Assembler Word
    literal Literal
    lit
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PUSH_UBX [Op np, SmallOp nws]

      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     Word16
    n Word16
    by           -> Word16 -> [Operand] -> Assembler ()
    emit bci_SLIDE [SmallOp n, SmallOp by]
      ALLOC_AP  Word16
    n              -> Word16 -> [Operand] -> Assembler ()
    emit bci_ALLOC_AP [SmallOp n]
      ALLOC_AP_NOUPD Word16
    n         -> Word16 -> [Operand] -> Assembler ()
    emit bci_ALLOC_AP_NOUPD [SmallOp n]
      ALLOC_PAP Word16
    arity Word16
    n        -> Word16 -> [Operand] -> Assembler ()
    emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
      MKAP      Word16
    off Word16
    sz         -> Word16 -> [Operand] -> Assembler ()
    emit bci_MKAP [SmallOp off, SmallOp sz]
      MKPAP     Word16
    off Word16
    sz         -> Word16 -> [Operand] -> Assembler ()
    emit bci_MKPAP [SmallOp off, SmallOp sz]
      UNPACK    Word16
    n              -> Word16 -> [Operand] -> Assembler ()
    emit bci_UNPACK [SmallOp n]
      PACK      DataCon
    dcon Word16
    sz        -> do Word
    itbl_no <- [BCONPtr] -> Assembler Word
    lit [Name -> BCONPtr
    BCONPtrItbl (DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    dcon)]
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_PACK [Op itbl_no, SmallOp sz]
      LABEL     LocalLabel
    lbl            -> LocalLabel -> Assembler ()
    label LocalLabel
    lbl
      TESTLT_I  Int
    i LocalLabel
    l            -> do Word
    np <- Int -> Assembler Word
    int Int
    i
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTLT_I [Op np, LabelOp l]
      TESTEQ_I  Int
    i LocalLabel
    l            -> do Word
    np <- Int -> Assembler Word
    int Int
    i
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTEQ_I [Op np, LabelOp l]
      TESTLT_W  Word
    w LocalLabel
    l            -> do Word
    np <- Word -> Assembler Word
    word Word
    w
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTLT_W [Op np, LabelOp l]
      TESTEQ_W  Word
    w LocalLabel
    l            -> do Word
    np <- Word -> Assembler Word
    word Word
    w
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTEQ_W [Op np, LabelOp l]
      TESTLT_F  Float
    f LocalLabel
    l            -> do Word
    np <- Float -> Assembler Word
    float Float
    f
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTLT_F [Op np, LabelOp l]
      TESTEQ_F  Float
    f LocalLabel
    l            -> do Word
    np <- Float -> Assembler Word
    float Float
    f
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTEQ_F [Op np, LabelOp l]
      TESTLT_D  Double
    d LocalLabel
    l            -> do Word
    np <- Double -> Assembler Word
    double Double
    d
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_TESTLT_D [Op np, LabelOp l]
      TESTEQ_D  Double
    d LocalLabel
    l            -> do Word
    np <- Double -> Assembler Word
    double Double
    d
                                     Word16 -> [Operand] -> Assembler ()
    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   Word16
    stkoff Word16
    n       -> Word16 -> [Operand] -> Assembler ()
    emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
      JMP       LocalLabel
    l              -> Word16 -> [Operand] -> Assembler ()
    emit bci_JMP [LabelOp l]
      BCInstr
    ENTER                    -> Word16 -> [Operand] -> Assembler ()
    emit bci_ENTER []
      BCInstr
    RETURN                   -> Word16 -> [Operand] -> Assembler ()
    emit bci_RETURN []
      RETURN_UNLIFTED ArgRep
    rep      -> Word16 -> [Operand] -> Assembler ()
    emit (ArgRep -> Word16
    return_unlifted ArgRep
    rep) []
      BCInstr
    RETURN_TUPLE             -> Word16 -> [Operand] -> Assembler ()
    emit bci_RETURN_T []
      CCALL Word16
    off RemotePtr C_ffi_cif
    m_addr Word16
    i       -> do Word
    np <- RemotePtr C_ffi_cif -> Assembler Word
    forall {a}. RemotePtr a -> Assembler Word
    addr RemotePtr C_ffi_cif
    m_addr
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_CCALL [SmallOp off, Op np, SmallOp i]
      BRK_FUN Word16
    index Unique
    uniq RemotePtr CostCentre
    cc    -> do Word
    p1 <- BCOPtr -> Assembler Word
    ptr BCOPtr
    BCOPtrBreakArray
                                     Word
    q <- Int -> Assembler Word
    int (Unique -> Int
    getKey Unique
    uniq)
                                     Word
    np <- RemotePtr CostCentre -> Assembler Word
    forall {a}. RemotePtr a -> Assembler Word
    addr RemotePtr CostCentre
    cc
                                     Word16 -> [Operand] -> Assembler ()
    emit bci_BRK_FUN [Op p1, SmallOp index,
                                                       Op q, 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       = Int -> Assembler Word
    int Int
    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     -> Int -> Assembler Word
    int (Integer -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord    -> Int -> Assembler Word
    int (Integer -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt8    -> Int64 -> Assembler Word
    int8 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord8   -> Int64 -> Assembler Word
    int8 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt16   -> Int64 -> Assembler Word
    int16 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord16  -> Int64 -> Assembler Word
    int16 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt32   -> Int64 -> Assembler Word
    int32 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord32  -> Int64 -> Assembler Word
    int32 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInt64   -> Int64 -> Assembler Word
    int64 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumWord64  -> Int64 -> Assembler Word
    int64 (Integer -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Integer
    i)
          LitNumType
    LitNumInteger -> String -> Assembler Word
    forall a. String -> a
    panic String
    "GHC.ByteCode.Asm.literal: LitNumInteger"
          LitNumType
    LitNumNatural -> String -> Assembler Word
    forall a. String -> a
    panic String
    "GHC.ByteCode.Asm.literal: LitNumNatural"

        -- 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 {}) = Int -> Assembler Word
    int Int
    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]
        float :: Float -> Assembler Word
    float = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Float -> [Word]) -> Float -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Float -> [Word]
    mkLitF
        double :: Double -> Assembler Word
    double = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Double -> [Word]) -> Double -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Double -> [Word]
    mkLitD Platform
    platform
        int :: Int -> Assembler Word
    int = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Int -> [Word]) -> Int -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> [Word]
    mkLitI
        int8 :: Int64 -> Assembler Word
    int8 = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Int64 -> [Word]) -> Int64 -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Int64 -> [Word]
    mkLitI64 Platform
    platform
        int16 :: Int64 -> Assembler Word
    int16 = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Int64 -> [Word]) -> Int64 -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Int64 -> [Word]
    mkLitI64 Platform
    platform
        int32 :: Int64 -> Assembler Word
    int32 = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Int64 -> [Word]) -> Int64 -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Int64 -> [Word]
    mkLitI64 Platform
    platform
        int64 :: Int64 -> Assembler Word
    int64 = [Word] -> Assembler Word
    words ([Word] -> Assembler Word)
    -> (Int64 -> [Word]) -> Int64 -> Assembler Word
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Int64 -> [Word]
    mkLitI64 Platform
    platform
        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]

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

    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_unlifted :: ArgRep -> Word16
    return_unlifted :: ArgRep -> Word16
    return_unlifted ArgRep
    V   = bci_RETURN_V
    return_unlifted ArgRep
    P   = bci_RETURN_P
    return_unlifted ArgRep
    N   = bci_RETURN_N
    return_unlifted ArgRep
    L   = bci_RETURN_L
    return_unlifted ArgRep
    F   = bci_RETURN_F
    return_unlifted ArgRep
    D   = bci_RETURN_D
    return_unlifted ArgRep
    V16 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "return_unlifted: vector"
    return_unlifted ArgRep
    V32 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "return_unlifted: vector"
    return_unlifted ArgRep
    V64 = String -> Word16
    forall a. HasCallStack => String -> a
    error String
    "return_unlifted: 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).

     -}
    maxTupleNativeStackSize :: WordOff
    maxTupleNativeStackSize :: WordOff
    maxTupleNativeStackSize = WordOff
    62

    {-
      Construct the tuple_info word that stg_ctoi_t and stg_ret_t use
      to convert a tuple between the native calling convention and the
      interpreter.

      See Note [GHCi tuple layout] for more information.
     -}
    mkTupleInfoSig :: Platform -> TupleInfo -> Word32
    mkTupleInfoSig :: Platform -> TupleInfo -> Word32
    mkTupleInfoSig Platform
    platform TupleInfo{GlobalRegSet
    WordOff
    tupleSize :: TupleInfo -> WordOff
    tupleRegs :: TupleInfo -> GlobalRegSet
    tupleNativeStackSize :: TupleInfo -> WordOff
    tupleNativeStackSize :: WordOff
    tupleRegs :: GlobalRegSet
    tupleSize :: WordOff
    ..}
      | WordOff
    tupleNativeStackSize WordOff -> WordOff -> Bool
    forall a. Ord a => a -> a -> Bool
    > WordOff
    maxTupleNativeStackSize
      = String -> SDoc -> Word32
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkTupleInfoSig: tuple too big for the bytecode compiler"
                 (WordOff -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr WordOff
    tupleNativeStackSize SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "stack words." SDoc -> SDoc -> SDoc
    <+>
                  String -> SDoc
    text String
    "Use -fobject-code to get around this limit"
                 )
      | Bool
    otherwise
      = ASSERT(length regs <= 24) {- 24 bits for bitmap -}
        ASSERT(tupleNativeStackSize < 255) {- 8 bits for stack size -}
        ASSERT(all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}
        (Word32 -> (GlobalReg, Int) -> Word32)
    -> Word32 -> [(GlobalReg, Int)] -> Word32
    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
    .|.
          (WordOff -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    tupleNativeStackSize Word32 -> Int -> Word32
    forall a. Bits a => a -> Int -> a
    `shiftL` Int
    24)
      where
        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
    tupleRegs = 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]
    tupleRegsCover Platform
    platform

    mkTupleInfoLit :: Platform -> TupleInfo -> Literal
    mkTupleInfoLit :: Platform -> TupleInfo -> Literal
    mkTupleInfoLit Platform
    platform TupleInfo
    tuple_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 -> TupleInfo -> Word32
    mkTupleInfoSig Platform
    platform TupleInfo
    tuple_info

    -- 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.
    mkLitI   ::             Int    -> [Word]
    mkLitF   ::             Float  -> [Word]
    mkLitD   :: Platform -> Double -> [Word]
    mkLitI64 :: Platform -> Int64  -> [Word]

    mkLitF :: Float -> [Word]
    mkLitF Float
    f
       = (forall s. ST s [Word]) -> [Word]
    forall a. (forall s. ST s a) -> a
    runST (do
            STUArray s Int Float
    arr <- (Int, Int) -> ST s (STUArray s Int Float)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    newArray_ ((Int
    0::Int),Int
    0)
            STUArray s Int Float -> Int -> Float -> ST s ()
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> e -> m ()
    writeArray STUArray s Int Float
    arr Int
    0 Float
    f
            STUArray s Int Word
    f_arr <- STUArray s Int Float -> ST s (STUArray s Int Word)
    forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
    castSTUArray STUArray s Int Float
    arr
            Word
    w0 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    f_arr Int
    0
            [Word] -> ST s [Word]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Word
    w0 :: Word]
         )

    mkLitD :: Platform -> Double -> [Word]
    mkLitD Platform
    platform Double
    d = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
       PlatformWordSize
    PW4 -> (forall s. ST s [Word]) -> [Word]
    forall a. (forall s. ST s a) -> a
    runST (do
            STUArray s Int Double
    arr <- (Int, Int) -> ST s (STUArray s Int Double)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    newArray_ ((Int
    0::Int),Int
    1)
            STUArray s Int Double -> Int -> Double -> ST s ()
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> e -> m ()
    writeArray STUArray s Int Double
    arr Int
    0 Double
    d
            STUArray s Int Word
    d_arr <- STUArray s Int Double -> ST s (STUArray s Int Word)
    forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
    castSTUArray STUArray s Int Double
    arr
            Word
    w0 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    d_arr Int
    0
            Word
    w1 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    d_arr Int
    1
            [Word] -> ST s [Word]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Word
    w0 :: Word, Word
    w1]
         )
       PlatformWordSize
    PW8 -> (forall s. ST s [Word]) -> [Word]
    forall a. (forall s. ST s a) -> a
    runST (do
            STUArray s Int Double
    arr <- (Int, Int) -> ST s (STUArray s Int Double)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    newArray_ ((Int
    0::Int),Int
    0)
            STUArray s Int Double -> Int -> Double -> ST s ()
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> e -> m ()
    writeArray STUArray s Int Double
    arr Int
    0 Double
    d
            STUArray s Int Word
    d_arr <- STUArray s Int Double -> ST s (STUArray s Int Word)
    forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
    castSTUArray STUArray s Int Double
    arr
            Word
    w0 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    d_arr Int
    0
            [Word] -> ST s [Word]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Word
    w0 :: Word]
         )

    mkLitI64 :: Platform -> Int64 -> [Word]
    mkLitI64 Platform
    platform Int64
    ii = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
       PlatformWordSize
    PW4 -> (forall s. ST s [Word]) -> [Word]
    forall a. (forall s. ST s a) -> a
    runST (do
            STUArray s Int Int64
    arr <- (Int, Int) -> ST s (STUArray s Int Int64)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    newArray_ ((Int
    0::Int),Int
    1)
            STUArray s Int Int64 -> Int -> Int64 -> ST s ()
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> e -> m ()
    writeArray STUArray s Int Int64
    arr Int
    0 Int64
    ii
            STUArray s Int Word
    d_arr <- STUArray s Int Int64 -> ST s (STUArray s Int Word)
    forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
    castSTUArray STUArray s Int Int64
    arr
            Word
    w0 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    d_arr Int
    0
            Word
    w1 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    d_arr Int
    1
            [Word] -> ST s [Word]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Word
    w0 :: Word,Word
    w1]
         )
       PlatformWordSize
    PW8 -> (forall s. ST s [Word]) -> [Word]
    forall a. (forall s. ST s a) -> a
    runST (do
            STUArray s Int Int64
    arr <- (Int, Int) -> ST s (STUArray s Int Int64)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    newArray_ ((Int
    0::Int),Int
    0)
            STUArray s Int Int64 -> Int -> Int64 -> ST s ()
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> e -> m ()
    writeArray STUArray s Int Int64
    arr Int
    0 Int64
    ii
            STUArray s Int Word
    d_arr <- STUArray s Int Int64 -> ST s (STUArray s Int Word)
    forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
    castSTUArray STUArray s Int Int64
    arr
            Word
    w0 <- STUArray s Int Word -> Int -> ST s Word
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> i -> m e
    readArray STUArray s Int Word
    d_arr Int
    0
            [Word] -> ST s [Word]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Word
    w0 :: Word]
         )

    mkLitI :: Int -> [Word]
    mkLitI Int
    i = [Int -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i :: Word]

    iNTERP_STACK_CHECK_THRESH :: Int
    iNTERP_STACK_CHECK_THRESH :: Int
    iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH