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

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

        -- * For testing
        assembleBCO
  ) where

import GHC.Prelude hiding ( any )


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.Types.SptEntry
import GHC.Types.Unique.FM

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

import GHC.Core.TyCon
import GHC.Data.SizedSeq
import GHC.Data.SmallArray

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

import Control.Monad
import qualified Control.Monad.Trans.State.Strict as MTL

import qualified Data.Array.Unboxed as Array
import qualified Data.Array.IO as Array
import Data.Array.Base  ( UArray(..), numElements, unsafeFreeze )

#if ! defined(DEBUG)
import Data.Array.Base  ( unsafeWrite )
#endif

import Foreign hiding (shiftL, shiftR)
import Data.Char  (ord)
import Data.Maybe (fromMaybe)
import GHC.Float (castFloatToWord32, castDoubleToWord64)

import qualified Data.List as List ( any )
import GHC.Exts


-- -----------------------------------------------------------------------------
-- 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
_ BCOByteArray Word16
_ BCOByteArray Word
_ FlatBag BCONPtr
nonptrs FlatBag 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 <- FlatBag BCOPtr -> [BCOPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag 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 <- FlatBag BCONPtr -> [BCONPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag 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 <- FlatBag BCOPtr -> [BCOPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag 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
  -> FlatBag (ProtoBCO Name)
  -> [TyCon]
  -> AddrEnv
  -> Maybe ModBreaks
  -> [SptEntry]
  -> IO CompiledByteCode
assembleBCOs :: Interp
-> Profile
-> FlatBag (ProtoBCO Name)
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile FlatBag (ProtoBCO Name)
proto_bcos [TyCon]
tycons AddrEnv
top_strs Maybe ModBreaks
modbreaks [SptEntry]
spt_entries = 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
    , bc_spt_entries = spt_entries
    }

-- 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 -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
mallocStrings :: Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
mallocStrings Interp
interp FlatBag 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
MTL.execState ((UnlinkedBCO -> State [ByteString] ())
-> FlatBag 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 FlatBag 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 (MTL.evalState (mapM splice ulbcos) ptrs)
 where
  splice :: UnlinkedBCO -> StateT [RemotePtr a] m UnlinkedBCO
splice bco :: UnlinkedBCO
bco@UnlinkedBCO{Int
BCOByteArray Word
BCOByteArray Word16
Name
FlatBag BCONPtr
FlatBag BCOPtr
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: BCOByteArray Word16
unlinkedBCOBitmap :: BCOByteArray Word
unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOPtrs :: FlatBag BCOPtr
unlinkedBCOPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedBCOBitmap :: UnlinkedBCO -> BCOByteArray Word
unlinkedBCOInstrs :: UnlinkedBCO -> BCOByteArray Word16
unlinkedBCOArity :: UnlinkedBCO -> Int
..} = do
    lits <- (BCONPtr -> StateT [RemotePtr a] m BCONPtr)
-> FlatBag BCONPtr -> StateT [RemotePtr a] m (FlatBag 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) -> FlatBag a -> m (FlatBag b)
mapM BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall {m :: * -> *} {a}.
Monad m =>
BCONPtr -> StateT [RemotePtr a] m BCONPtr
spliceLit FlatBag 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
MTL.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 ()
MTL.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
BCOByteArray Word
BCOByteArray Word16
Name
FlatBag BCONPtr
FlatBag BCOPtr
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedBCOBitmap :: UnlinkedBCO -> BCOByteArray Word
unlinkedBCOInstrs :: UnlinkedBCO -> BCOByteArray Word16
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: BCOByteArray Word16
unlinkedBCOBitmap :: BCOByteArray Word
unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOPtrs :: FlatBag BCOPtr
..} = do
    (BCONPtr -> StateT [ByteString] m ())
-> FlatBag 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 FlatBag BCONPtr
unlinkedBCOLits
    (BCOPtr -> StateT [ByteString] m ())
-> FlatBag 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 FlatBag 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
MTL.get
    MTL.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 ()

data RunAsmReader = RunAsmReader { RunAsmReader -> IOUArray Int Word16
isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)
                                  , RunAsmReader -> SmallMutableArrayIO BCOPtr
ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
                                  , RunAsmReader -> SmallMutableArrayIO BCONPtr
lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )
                                  }

data RunAsmResult = RunAsmResult { RunAsmResult -> UArray Int Word16
final_isn_array :: !(Array.UArray Int Word16)
                                 , RunAsmResult -> SmallArray BCOPtr
final_ptr_array :: !(SmallArray BCOPtr)
                                 , RunAsmResult -> SmallArray BCONPtr
final_lit_array :: !(SmallArray BCONPtr) }

-- How many words we have written so far.
data AsmState = AsmState { AsmState -> Int
nisn :: !Int, AsmState -> Int
nptr :: !Int, AsmState -> Int
nlit :: !Int }


{-# NOINLINE inspectInstrs #-}
-- | Perform analysis of the bytecode to determine
--  1. How many instructions we will produce
--  2. If we are going to need long jumps.
--  3. The offsets that labels refer to
inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState
inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState
inspectInstrs Platform
platform Bool
long_jump Word
e [BCInstr]
instrs =
  Bool -> Word -> InspectAsm () -> InspectState
inspectAsm Bool
long_jump Word
e ((BCInstr -> InspectAsm ()) -> [BCInstr] -> InspectAsm ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Platform -> BCInstr -> InspectAsm ()
assembleInspectAsm Platform
platform) [BCInstr]
instrs)

{-# NOINLINE runInstrs #-}
-- | Assemble the bytecode from the instructions.
runInstrs ::  Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult
runInstrs :: Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult
runInstrs Platform
platform Bool
long_jumps InspectState
is_state [BCInstr]
instrs = do
  -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs.
  isn_array <- (Int, Int) -> IO (IOUArray Int Word16)
forall i. Ix i => (i, i) -> IO (IOUArray i Word16)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
Array.newArray_ (Int
0, (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ InspectState -> Word
instrCount InspectState
is_state) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined
  lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined
  let 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))
        (UniqFM LocalLabel Word -> LocalLabel -> Maybe Word
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (InspectState -> UniqFM LocalLabel Word
lblEnv InspectState
is_state) LocalLabel
lbl)
  let initial_state  = Int -> Int -> Int -> AsmState
AsmState Int
0 Int
0 Int
0
  let initial_reader = RunAsmReader{IOUArray Int Word16
SmallMutableArrayIO BCONPtr
SmallMutableArrayIO BCOPtr
isn_array :: IOUArray Int Word16
ptr_array :: SmallMutableArrayIO BCOPtr
lit_array :: SmallMutableArrayIO BCONPtr
isn_array :: IOUArray Int Word16
ptr_array :: SmallMutableArrayIO BCOPtr
lit_array :: SmallMutableArrayIO BCONPtr
..}
  runAsm long_jumps env initial_reader initial_state (mapM_ (\BCInstr
i -> Platform -> BCInstr -> RunAsm ()
assembleRunAsm Platform
platform BCInstr
i) instrs)
  final_isn_array <- unsafeFreeze isn_array
  final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array
  final_lit_array <- unsafeFreezeSmallArrayIO lit_array
  return $ RunAsmResult {..}

assembleRunAsm :: Platform -> BCInstr -> RunAsm ()
assembleRunAsm :: Platform -> BCInstr -> RunAsm ()
assembleRunAsm Platform
p BCInstr
i = forall (m :: * -> *).
MonadAssembler m =>
Platform -> BCInstr -> m ()
assembleI @RunAsm Platform
p BCInstr
i

assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()
assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()
assembleInspectAsm Platform
p BCInstr
i = forall (m :: * -> *).
MonadAssembler m =>
Platform -> BCInstr -> m ()
assembleI @InspectAsm Platform
p BCInstr
i

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 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.
      is0 :: InspectState
is0 = Platform -> Bool -> Word -> [BCInstr] -> InspectState
inspectInstrs Platform
platform Bool
False Word
initial_offset [BCInstr]
instrs
      (InspectState
is1, Bool
long_jumps)
        | InspectState -> Bool
isLargeInspectState InspectState
is0
                    = (Platform -> Bool -> Word -> [BCInstr] -> InspectState
inspectInstrs Platform
platform Bool
True Word
initial_offset [BCInstr]
instrs, Bool
True)
        | Bool
otherwise = (InspectState
is0, Bool
False)


  -- pass 2: run assembler and generate instructions, literals and pointers
  RunAsmResult{..} <- Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult
runInstrs Platform
platform Bool
long_jumps InspectState
is1 [BCInstr]
instrs

  -- precomputed size should be equal to final size
  massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array
              && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array
              && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array)
             (text "bytecode instruction count mismatch")

  let !insns_arr =  UArray Int Word16 -> BCOByteArray Word16
forall a. UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray Int Word16 -> BCOByteArray Word16)
-> UArray Int Word16 -> BCOByteArray Word16
forall a b. (a -> b) -> a -> b
$ UArray Int Word16
final_isn_array
      !bitmap_arr = UArray Int Word -> BCOByteArray Word
forall a. UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray Int Word -> BCOByteArray Word)
-> UArray Int Word -> BCOByteArray Word
forall a b. (a -> b) -> a -> b
$ Word -> [StgWord] -> UArray Int Word
mkBitmapArray Word
bsize [StgWord]
bitmap
      ul_bco = Name
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> FlatBag BCONPtr
-> FlatBag BCOPtr
-> UnlinkedBCO
UnlinkedBCO Name
nm Int
arity BCOByteArray Word16
insns_arr BCOByteArray Word
bitmap_arr (SmallArray BCONPtr -> FlatBag BCONPtr
forall a. SmallArray a -> FlatBag a
fromSmallArray SmallArray BCONPtr
final_lit_array) (SmallArray BCOPtr -> FlatBag BCOPtr
forall a. SmallArray a -> FlatBag a
fromSmallArray SmallArray BCOPtr
final_ptr_array)

  -- 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 Word
-- 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 Word
mkBitmapArray Word
bsize [StgWord]
bitmap
  = (Int, Int) -> [Word] -> UArray Int Word
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) ([Word] -> UArray Int Word) -> [Word] -> UArray Int Word
forall a b. (a -> b) -> a -> b
$
      Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
bsize Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: (StgWord -> Word) -> [StgWord] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Integer -> Word) -> (StgWord -> Integer) -> StgWord -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgWord -> Integer
fromStgWord) [StgWord]
bitmap


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)


ptr :: MonadAssembler m => BCOPtr -> m Word
ptr :: forall (m :: * -> *). MonadAssembler m => BCOPtr -> m Word
ptr = IO BCOPtr -> m Word
forall (m :: * -> *). MonadAssembler m => IO BCOPtr -> m Word
ioptr (IO BCOPtr -> m Word) -> (BCOPtr -> IO BCOPtr) -> BCOPtr -> m 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

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

newtype RunAsm a = RunAsm' { forall a.
RunAsm a
-> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
runRunAsm :: Bool
                                       -> LabelEnv
                                       -> RunAsmReader
                                       -> AsmState
                                       -> IO (AsmState, a) }

pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a))
                  -> RunAsm a
pattern $mRunAsm :: forall {r} {a}.
RunAsm a
-> ((Bool
     -> (LocalLabel -> Word)
     -> RunAsmReader
     -> AsmState
     -> IO (AsmState, a))
    -> r)
-> ((# #) -> r)
-> r
$bRunAsm :: forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm m <- RunAsm' m
  where
    RunAsm Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
m = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm' ((Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
oneShot ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, a))
 -> Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, a))
-> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
$ \Bool
a -> ((LocalLabel -> Word)
 -> RunAsmReader -> AsmState -> IO (AsmState, a))
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
oneShot (((LocalLabel -> Word)
  -> RunAsmReader -> AsmState -> IO (AsmState, a))
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> ((LocalLabel -> Word)
    -> RunAsmReader -> AsmState -> IO (AsmState, a))
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
$ \LocalLabel -> Word
b -> (RunAsmReader -> AsmState -> IO (AsmState, a))
-> RunAsmReader -> AsmState -> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
oneShot ((RunAsmReader -> AsmState -> IO (AsmState, a))
 -> RunAsmReader -> AsmState -> IO (AsmState, a))
-> (RunAsmReader -> AsmState -> IO (AsmState, a))
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
$ \RunAsmReader
c -> (AsmState -> IO (AsmState, a)) -> AsmState -> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
oneShot ((AsmState -> IO (AsmState, a)) -> AsmState -> IO (AsmState, a))
-> (AsmState -> IO (AsmState, a)) -> AsmState -> IO (AsmState, a)
forall a b. (a -> b) -> a -> b
$ \AsmState
d -> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
m Bool
a LocalLabel -> Word
b RunAsmReader
c AsmState
d)
{-# COMPLETE RunAsm #-}

instance Functor RunAsm where
  fmap :: forall a b. (a -> b) -> RunAsm a -> RunAsm b
fmap a -> b
f (RunAsm Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
x) = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, b))
-> RunAsm b
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm (\Bool
a LocalLabel -> Word
b RunAsmReader
c !AsmState
s -> ((AsmState, a) -> (AsmState, b))
-> IO (AsmState, a) -> IO (AsmState, b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (AsmState, a) -> (AsmState, b)
forall a b. (a -> b) -> (AsmState, a) -> (AsmState, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
x Bool
a LocalLabel -> Word
b RunAsmReader
c AsmState
s))

instance Applicative RunAsm where
  pure :: forall a. a -> RunAsm a
pure a
x = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, a))
 -> RunAsm a)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, a))
-> RunAsm a
forall a b. (a -> b) -> a -> b
$ \Bool
_ LocalLabel -> Word
_ RunAsmReader
_ !AsmState
s -> (AsmState, a) -> IO (AsmState, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsmState
s, a
x)
  (RunAsm Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a -> b)
f) <*> :: forall a b. RunAsm (a -> b) -> RunAsm a -> RunAsm b
<*> (RunAsm Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
x) = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, b))
-> RunAsm b
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, b))
 -> RunAsm b)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, b))
-> RunAsm b
forall a b. (a -> b) -> a -> b
$ \Bool
a LocalLabel -> Word
b RunAsmReader
c !AsmState
s -> do
                                  (!s', f') <- Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a -> b)
f Bool
a LocalLabel -> Word
b RunAsmReader
c AsmState
s
                                  (!s'', x') <- x a b c s'
                                  return (s'', f' x')
  {-# INLINE (<*>) #-}


instance Monad RunAsm where
  return :: forall a. a -> RunAsm a
return  = a -> RunAsm a
forall a. a -> RunAsm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (RunAsm Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
m) >>= :: forall a b. RunAsm a -> (a -> RunAsm b) -> RunAsm b
>>= a -> RunAsm b
f = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, b))
-> RunAsm b
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, b))
 -> RunAsm b)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, b))
-> RunAsm b
forall a b. (a -> b) -> a -> b
$ \Bool
a LocalLabel -> Word
b RunAsmReader
c !AsmState
s -> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
m Bool
a LocalLabel -> Word
b RunAsmReader
c AsmState
s IO (AsmState, a)
-> ((AsmState, a) -> IO (AsmState, b)) -> IO (AsmState, b)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(AsmState
s', a
r) -> RunAsm b
-> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, b)
forall a.
RunAsm a
-> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
runRunAsm (a -> RunAsm b
f a
r) Bool
a LocalLabel -> Word
b RunAsmReader
c AsmState
s'
  {-# INLINE (>>=) #-}

runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a
runAsm :: forall a.
Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> RunAsm a
-> IO a
runAsm Bool
long_jumps LocalLabel -> Word
e RunAsmReader
r AsmState
s (RunAsm'{Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
runRunAsm :: forall a.
RunAsm a
-> Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
runRunAsm :: Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
runRunAsm}) = ((AsmState, a) -> a) -> IO (AsmState, a) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AsmState, a) -> a
forall a b. (a, b) -> b
snd (IO (AsmState, a) -> IO a) -> IO (AsmState, a) -> IO a
forall a b. (a -> b) -> a -> b
$ Bool
-> (LocalLabel -> Word)
-> RunAsmReader
-> AsmState
-> IO (AsmState, a)
runRunAsm Bool
long_jumps LocalLabel -> Word
e RunAsmReader
r AsmState
s

expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()
expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()
expand PlatformWordSize
word_size Bool
largeArgs Operand
o = do
  e <- RunAsm (LocalLabel -> Word)
askEnv
  case o of
    (SmallOp Word16
w) -> Word16 -> RunAsm ()
writeIsn Word16
w
    (LabelOp LocalLabel
w) -> let !r :: Word
r = LocalLabel -> Word
e LocalLabel
w in Word -> RunAsm ()
forall a. Integral a => a -> RunAsm ()
handleLargeArg Word
r
    (Op Word
w) -> Word -> RunAsm ()
forall a. Integral a => a -> RunAsm ()
handleLargeArg Word
w
    (IOp Int
i) -> Int -> RunAsm ()
forall a. Integral a => a -> RunAsm ()
handleLargeArg Int
i

  where
    handleLargeArg :: Integral a => a -> RunAsm ()
    handleLargeArg :: forall a. Integral a => a -> RunAsm ()
handleLargeArg a
w  =
      if Bool
largeArgs
        then PlatformWordSize -> Word64 -> RunAsm ()
largeArg PlatformWordSize
word_size (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)
        else Word16 -> RunAsm ()
writeIsn (a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w)

lift :: IO a -> RunAsm a
lift :: forall a. IO a -> RunAsm a
lift IO a
io = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, a))
 -> RunAsm a)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, a))
-> RunAsm a
forall a b. (a -> b) -> a -> b
$ \Bool
_ LocalLabel -> Word
_ RunAsmReader
_ AsmState
s -> IO a
io IO a -> (a -> IO (AsmState, a)) -> IO (AsmState, a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> (AsmState, a) -> IO (AsmState, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsmState
s, a
a)

askLongJumps :: RunAsm Bool
askLongJumps :: RunAsm Bool
askLongJumps = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, Bool))
-> RunAsm Bool
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, Bool))
 -> RunAsm Bool)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, Bool))
-> RunAsm Bool
forall a b. (a -> b) -> a -> b
$ \Bool
a LocalLabel -> Word
_ RunAsmReader
_ AsmState
s -> (AsmState, Bool) -> IO (AsmState, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsmState
s, Bool
a)

askEnv :: RunAsm LabelEnv
askEnv :: RunAsm (LocalLabel -> Word)
askEnv = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, LocalLabel -> Word))
-> RunAsm (LocalLabel -> Word)
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, LocalLabel -> Word))
 -> RunAsm (LocalLabel -> Word))
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, LocalLabel -> Word))
-> RunAsm (LocalLabel -> Word)
forall a b. (a -> b) -> a -> b
$ \Bool
_ LocalLabel -> Word
b RunAsmReader
_ AsmState
s -> (AsmState, LocalLabel -> Word) -> IO (AsmState, LocalLabel -> Word)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsmState
s, LocalLabel -> Word
b)

writePtr :: BCOPtr -> RunAsm Word
writePtr :: BCOPtr -> RunAsm Word
writePtr BCOPtr
w
            = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, Word))
-> RunAsm Word
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, Word))
 -> RunAsm Word)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, Word))
-> RunAsm Word
forall a b. (a -> b) -> a -> b
$ \Bool
_ LocalLabel -> Word
_ (RunAsmReader{IOUArray Int Word16
SmallMutableArrayIO BCONPtr
SmallMutableArrayIO BCOPtr
isn_array :: RunAsmReader -> IOUArray Int Word16
ptr_array :: RunAsmReader -> SmallMutableArrayIO BCOPtr
lit_array :: RunAsmReader -> SmallMutableArrayIO BCONPtr
isn_array :: IOUArray Int Word16
ptr_array :: SmallMutableArrayIO BCOPtr
lit_array :: SmallMutableArrayIO BCONPtr
..}) AsmState
asm -> do
              SmallMutableArrayIO BCOPtr -> Int -> BCOPtr -> IO ()
forall a. SmallMutableArrayIO a -> Int -> a -> IO ()
writeSmallArrayIO SmallMutableArrayIO BCOPtr
ptr_array (AsmState -> Int
nptr AsmState
asm) BCOPtr
w
              let !n' :: Int
n' = AsmState -> Int
nptr AsmState
asm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              let !asm' :: AsmState
asm' = AsmState
asm { nptr = n' }
              (AsmState, Word) -> IO (AsmState, Word)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AsmState
asm', Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AsmState -> Int
nptr AsmState
asm))

writeLit :: BCONPtr -> RunAsm Word
writeLit :: BCONPtr -> RunAsm Word
writeLit BCONPtr
w = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, Word))
-> RunAsm Word
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, Word))
 -> RunAsm Word)
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, Word))
-> RunAsm Word
forall a b. (a -> b) -> a -> b
$ \Bool
_ LocalLabel -> Word
_ (RunAsmReader{IOUArray Int Word16
SmallMutableArrayIO BCONPtr
SmallMutableArrayIO BCOPtr
isn_array :: RunAsmReader -> IOUArray Int Word16
ptr_array :: RunAsmReader -> SmallMutableArrayIO BCOPtr
lit_array :: RunAsmReader -> SmallMutableArrayIO BCONPtr
isn_array :: IOUArray Int Word16
ptr_array :: SmallMutableArrayIO BCOPtr
lit_array :: SmallMutableArrayIO BCONPtr
..}) AsmState
asm -> do
              SmallMutableArrayIO BCONPtr -> Int -> BCONPtr -> IO ()
forall a. SmallMutableArrayIO a -> Int -> a -> IO ()
writeSmallArrayIO SmallMutableArrayIO BCONPtr
lit_array (AsmState -> Int
nlit AsmState
asm) BCONPtr
w
              let !n' :: Int
n' = AsmState -> Int
nlit AsmState
asm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              let !asm' :: AsmState
asm' = AsmState
asm { nlit = n' }
              (AsmState, Word) -> IO (AsmState, Word)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AsmState
asm', Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AsmState -> Int
nlit AsmState
asm))

writeLits :: OneOrTwo BCONPtr -> RunAsm Word
writeLits :: OneOrTwo BCONPtr -> RunAsm Word
writeLits (OnlyOne BCONPtr
l) = BCONPtr -> RunAsm Word
writeLit BCONPtr
l
writeLits (OnlyTwo BCONPtr
l1 BCONPtr
l2) = BCONPtr -> RunAsm Word
writeLit BCONPtr
l1 RunAsm Word -> RunAsm Word -> RunAsm Word
forall a b. RunAsm a -> RunAsm b -> RunAsm a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* BCONPtr -> RunAsm Word
writeLit BCONPtr
l2

writeIsn :: Word16 -> RunAsm ()
writeIsn :: Word16 -> RunAsm ()
writeIsn Word16
w = (Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, ()))
-> RunAsm ()
forall a.
(Bool
 -> (LocalLabel -> Word)
 -> RunAsmReader
 -> AsmState
 -> IO (AsmState, a))
-> RunAsm a
RunAsm ((Bool
  -> (LocalLabel -> Word)
  -> RunAsmReader
  -> AsmState
  -> IO (AsmState, ()))
 -> RunAsm ())
-> (Bool
    -> (LocalLabel -> Word)
    -> RunAsmReader
    -> AsmState
    -> IO (AsmState, ()))
-> RunAsm ()
forall a b. (a -> b) -> a -> b
$ \Bool
_ LocalLabel -> Word
_ (RunAsmReader{IOUArray Int Word16
SmallMutableArrayIO BCONPtr
SmallMutableArrayIO BCOPtr
isn_array :: RunAsmReader -> IOUArray Int Word16
ptr_array :: RunAsmReader -> SmallMutableArrayIO BCOPtr
lit_array :: RunAsmReader -> SmallMutableArrayIO BCONPtr
isn_array :: IOUArray Int Word16
ptr_array :: SmallMutableArrayIO BCOPtr
lit_array :: SmallMutableArrayIO BCONPtr
..}) AsmState
asm -> do
#if defined(DEBUG)
              Array.writeArray isn_array (nisn asm) w
#else
              IOUArray Int Word16 -> Int -> Word16 -> IO ()
forall i. Ix i => IOUArray i Word16 -> Int -> Word16 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite IOUArray Int Word16
isn_array (AsmState -> Int
nisn AsmState
asm) Word16
w
#endif
              let !n' :: Int
n' = AsmState -> Int
nisn AsmState
asm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              let !asm' :: AsmState
asm' = AsmState
asm { nisn = n' }
              (AsmState, ()) -> IO (AsmState, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AsmState
asm', ())

{-# INLINE any #-}
-- Any is unrolled manually so that the call in `emit` can be eliminated without
-- relying on SpecConstr (which does not work across modules).
any :: (a -> Bool) -> [a] -> Bool
any :: forall a. (a -> Bool) -> [a] -> Bool
any a -> Bool
_ [] = Bool
False
any a -> Bool
f [a
x] = a -> Bool
f a
x
any a -> Bool
f [a
x,a
y] = a -> Bool
f a
x Bool -> Bool -> Bool
|| a -> Bool
f a
y
any a -> Bool
f [a
x,a
y,a
z] = a -> Bool
f a
x Bool -> Bool -> Bool
|| a -> Bool
f a
y Bool -> Bool -> Bool
|| a -> Bool
f a
z
any a -> Bool
f [a
x1,a
x2,a
x3,a
x4] = a -> Bool
f a
x1 Bool -> Bool -> Bool
|| a -> Bool
f a
x2 Bool -> Bool -> Bool
|| a -> Bool
f a
x3 Bool -> Bool -> Bool
|| a -> Bool
f a
x4
any a -> Bool
f [a
x1,a
x2,a
x3,a
x4, a
x5] = a -> Bool
f a
x1 Bool -> Bool -> Bool
|| a -> Bool
f a
x2 Bool -> Bool -> Bool
|| a -> Bool
f a
x3 Bool -> Bool -> Bool
|| a -> Bool
f a
x4 Bool -> Bool -> Bool
|| a -> Bool
f a
x5
any a -> Bool
f [a
x1,a
x2,a
x3,a
x4,a
x5,a
x6] = a -> Bool
f a
x1 Bool -> Bool -> Bool
|| a -> Bool
f a
x2 Bool -> Bool -> Bool
|| a -> Bool
f a
x3 Bool -> Bool -> Bool
|| a -> Bool
f a
x4 Bool -> Bool -> Bool
|| a -> Bool
f a
x5 Bool -> Bool -> Bool
|| a -> Bool
f a
x6
any a -> Bool
f [a]
xs = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any a -> Bool
f [a]
xs

{-# INLINE mapM6_ #-}
mapM6_ :: Monad m => (a -> m b) -> [a] -> m ()
mapM6_ :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m ()
mapM6_ a -> m b
_ [] = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapM6_ a -> m b
f [a
x] = () () -> m b -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> m b
f a
x
mapM6_ a -> m b
f [a
x,a
y] = () () -> m b -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> m b
f a
x m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
y
mapM6_ a -> m b
f [a
x,a
y,a
z] = () () -> m b -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> m b
f a
x m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
y m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
z
mapM6_ a -> m b
f [a
a1,a
a2,a
a3,a
a4] = () () -> m b -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> m b
f a
a1 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a2 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a3 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a4
mapM6_ a -> m b
f [a
a1,a
a2,a
a3,a
a4,a
a5] = () () -> m b -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> m b
f a
a1 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a2 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a3 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a4 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a5
mapM6_ a -> m b
f [a
a1,a
a2,a
a3,a
a4,a
a5,a
a6] = () () -> m b -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> m b
f a
a1 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a2 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a3 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a4 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a5 m () -> m b -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a -> m b
f a
a6
mapM6_ a -> m b
f [a]
xs = (a -> m b) -> [a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> m b
f [a]
xs

instance MonadAssembler RunAsm where
  ioptr :: IO BCOPtr -> RunAsm Word
ioptr IO BCOPtr
p_io = do
    p <- IO BCOPtr -> RunAsm BCOPtr
forall a. IO a -> RunAsm a
lift IO BCOPtr
p_io
    writePtr p
  lit :: OneOrTwo BCONPtr -> RunAsm Word
lit OneOrTwo BCONPtr
lits = OneOrTwo BCONPtr -> RunAsm Word
writeLits OneOrTwo BCONPtr
lits

  label :: LocalLabel -> RunAsm ()
label LocalLabel
_ = () -> RunAsm ()
forall a. a -> RunAsm a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  emit :: PlatformWordSize -> Word16 -> [Operand] -> RunAsm ()
emit PlatformWordSize
pwordsize Word16
w [Operand]
ops = do
    long_jumps <- RunAsm Bool
askLongJumps
    -- See the definition of `any` above
    let largeArgs = (Operand -> Bool) -> [Operand] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
any (Bool -> Operand -> Bool
largeOp Bool
long_jumps) [Operand]
ops
    let opcode
          | Bool
largeArgs = Word16 -> Word16
largeArgInstr Word16
w
          | Bool
otherwise = Word16
w
    writeIsn opcode
    mapM6_ (expand pwordsize largeArgs) ops

  {-# INLINE emit #-}
  {-# INLINE label #-}
  {-# INLINE lit #-}
  {-# INLINE ioptr #-}

type LabelEnvMap = UniqFM LocalLabel Word

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

instance Outputable InspectState where
  ppr :: InspectState -> SDoc
ppr (InspectState Word
i Word
p Word
l UniqFM LocalLabel Word
m) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"InspectState" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
i, Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
p, Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
l, Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UniqFM LocalLabel Word -> Int
forall {k} (key :: k) elt. UniqFM key elt -> Int
sizeUFM UniqFM LocalLabel Word
m)]

isLargeInspectState :: InspectState -> Bool
isLargeInspectState :: InspectState -> Bool
isLargeInspectState InspectState{Word
UniqFM LocalLabel Word
instrCount :: InspectState -> Word
ptrCount :: InspectState -> Word
litCount :: InspectState -> Word
lblEnv :: InspectState -> UniqFM LocalLabel Word
instrCount :: Word
ptrCount :: Word
litCount :: Word
lblEnv :: UniqFM LocalLabel Word
..} =
  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
$ UniqFM LocalLabel Word -> Int
forall {k} (key :: k) elt. UniqFM key elt -> Int
sizeUFM UniqFM LocalLabel Word
lblEnv)
    Bool -> Bool -> Bool
|| Word -> Bool
isLargeW Word
instrCount

newtype InspectEnv = InspectEnv { InspectEnv -> Bool
_inspectLongJumps :: Bool
                                }

newtype InspectAsm a = InspectAsm' { forall a.
InspectAsm a -> InspectEnv -> InspectState -> (# InspectState, a #)
runInspectAsm :: InspectEnv -> InspectState -> (# InspectState,  a #) }

pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #))
                   -> InspectAsm a
pattern $mInspectAsm :: forall {r} {a}.
InspectAsm a
-> ((InspectEnv -> InspectState -> (# InspectState, a #)) -> r)
-> ((# #) -> r)
-> r
$bInspectAsm :: forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm m <- InspectAsm' m
  where
    InspectAsm InspectEnv -> InspectState -> (# InspectState, a #)
m = (InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm' ((InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectEnv -> InspectState -> (# InspectState, a #)
forall a b. (a -> b) -> a -> b
oneShot ((InspectEnv -> InspectState -> (# InspectState, a #))
 -> InspectEnv -> InspectState -> (# InspectState, a #))
-> (InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectEnv
-> InspectState
-> (# InspectState, a #)
forall a b. (a -> b) -> a -> b
$ \InspectEnv
a -> (InspectState -> (# InspectState, a #))
-> InspectState -> (# InspectState, a #)
forall a b. (a -> b) -> a -> b
oneShot ((InspectState -> (# InspectState, a #))
 -> InspectState -> (# InspectState, a #))
-> (InspectState -> (# InspectState, a #))
-> InspectState
-> (# InspectState, a #)
forall a b. (a -> b) -> a -> b
$ \InspectState
b -> InspectEnv -> InspectState -> (# InspectState, a #)
m InspectEnv
a InspectState
b)
{-# COMPLETE InspectAsm #-}

instance Functor InspectAsm where
  fmap :: forall a b. (a -> b) -> InspectAsm a -> InspectAsm b
fmap a -> b
f (InspectAsm InspectEnv -> InspectState -> (# InspectState, a #)
k) = (InspectEnv -> InspectState -> (# InspectState, b #))
-> InspectAsm b
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, b #))
 -> InspectAsm b)
-> (InspectEnv -> InspectState -> (# InspectState, b #))
-> InspectAsm b
forall a b. (a -> b) -> a -> b
$ \InspectEnv
a InspectState
b -> case InspectEnv -> InspectState -> (# InspectState, a #)
k InspectEnv
a InspectState
b of
                                                  (# InspectState
b', a
c #) -> (# InspectState
b', a -> b
f a
c #)

instance Applicative InspectAsm where
  pure :: forall a. a -> InspectAsm a
pure a
x = (InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, a #))
 -> InspectAsm a)
-> (InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
forall a b. (a -> b) -> a -> b
$ \InspectEnv
_ InspectState
s -> (# InspectState
s, a
x #)
  (InspectAsm InspectEnv -> InspectState -> (# InspectState, a -> b #)
f) <*> :: forall a b. InspectAsm (a -> b) -> InspectAsm a -> InspectAsm b
<*> (InspectAsm InspectEnv -> InspectState -> (# InspectState, a #)
x) = (InspectEnv -> InspectState -> (# InspectState, b #))
-> InspectAsm b
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, b #))
 -> InspectAsm b)
-> (InspectEnv -> InspectState -> (# InspectState, b #))
-> InspectAsm b
forall a b. (a -> b) -> a -> b
$ \InspectEnv
a InspectState
b -> case InspectEnv -> InspectState -> (# InspectState, a -> b #)
f InspectEnv
a InspectState
b of
                                                              (# InspectState
s', a -> b
f' #) ->
                                                                case InspectEnv -> InspectState -> (# InspectState, a #)
x InspectEnv
a InspectState
s' of
                                                                  (# InspectState
s'', a
x' #) -> (# InspectState
s'', a -> b
f' a
x' #)

instance Monad InspectAsm where
  return :: forall a. a -> InspectAsm a
return = a -> InspectAsm a
forall a. a -> InspectAsm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (InspectAsm InspectEnv -> InspectState -> (# InspectState, a #)
m) >>= :: forall a b. InspectAsm a -> (a -> InspectAsm b) -> InspectAsm b
>>= a -> InspectAsm b
f = (InspectEnv -> InspectState -> (# InspectState, b #))
-> InspectAsm b
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, b #))
 -> InspectAsm b)
-> (InspectEnv -> InspectState -> (# InspectState, b #))
-> InspectAsm b
forall a b. (a -> b) -> a -> b
$ \ InspectEnv
a InspectState
b -> case InspectEnv -> InspectState -> (# InspectState, a #)
m InspectEnv
a InspectState
b of
                                                (# InspectState
s', a
a' #) -> InspectAsm b -> InspectEnv -> InspectState -> (# InspectState, b #)
forall a.
InspectAsm a -> InspectEnv -> InspectState -> (# InspectState, a #)
runInspectAsm (a -> InspectAsm b
f a
a') InspectEnv
a InspectState
s'

get_ :: InspectAsm InspectState
get_ :: InspectAsm InspectState
get_ = (InspectEnv -> InspectState -> (# InspectState, InspectState #))
-> InspectAsm InspectState
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, InspectState #))
 -> InspectAsm InspectState)
-> (InspectEnv -> InspectState -> (# InspectState, InspectState #))
-> InspectAsm InspectState
forall a b. (a -> b) -> a -> b
$ \InspectEnv
_ InspectState
b -> (# InspectState
b, InspectState
b #)

put_ :: InspectState -> InspectAsm ()
put_ :: InspectState -> InspectAsm ()
put_ !InspectState
s = (InspectEnv -> InspectState -> (# InspectState, () #))
-> InspectAsm ()
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, () #))
 -> InspectAsm ())
-> (InspectEnv -> InspectState -> (# InspectState, () #))
-> InspectAsm ()
forall a b. (a -> b) -> a -> b
$ \InspectEnv
_ InspectState
_ -> (# InspectState
s, () #)

modify_ :: (InspectState -> InspectState) -> InspectAsm ()
modify_ :: (InspectState -> InspectState) -> InspectAsm ()
modify_ InspectState -> InspectState
f = (InspectEnv -> InspectState -> (# InspectState, () #))
-> InspectAsm ()
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, () #))
 -> InspectAsm ())
-> (InspectEnv -> InspectState -> (# InspectState, () #))
-> InspectAsm ()
forall a b. (a -> b) -> a -> b
$ \InspectEnv
_ InspectState
s -> let !s' :: InspectState
s' = InspectState -> InspectState
f InspectState
s in (# InspectState
s', () #)

ask_ :: InspectAsm InspectEnv
ask_ :: InspectAsm InspectEnv
ask_ = (InspectEnv -> InspectState -> (# InspectState, InspectEnv #))
-> InspectAsm InspectEnv
forall a.
(InspectEnv -> InspectState -> (# InspectState, a #))
-> InspectAsm a
InspectAsm ((InspectEnv -> InspectState -> (# InspectState, InspectEnv #))
 -> InspectAsm InspectEnv)
-> (InspectEnv -> InspectState -> (# InspectState, InspectEnv #))
-> InspectAsm InspectEnv
forall a b. (a -> b) -> a -> b
$ \InspectEnv
a InspectState
b -> (# InspectState
b, InspectEnv
a #)

inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState
inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState
inspectAsm Bool
long_jumps Word
initial_offset (InspectAsm InspectEnv -> InspectState -> (# InspectState, () #)
s) =
  case InspectEnv -> InspectState -> (# InspectState, () #)
s (Bool -> InspectEnv
InspectEnv Bool
long_jumps) (Word -> Word -> Word -> UniqFM LocalLabel Word -> InspectState
InspectState Word
initial_offset Word
0 Word
0 UniqFM LocalLabel Word
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM) of
    (# InspectState
res, () #) -> InspectState
res
{-# INLINE inspectAsm #-}



instance MonadAssembler InspectAsm where
  ioptr :: IO BCOPtr -> InspectAsm Word
ioptr IO BCOPtr
_ = do
    s <- InspectAsm InspectState
get_
    let n = InspectState -> Word
ptrCount InspectState
s
    put_ (s { ptrCount = n + 1 })
    return n

  lit :: OneOrTwo BCONPtr -> InspectAsm Word
lit OneOrTwo BCONPtr
ls = do
    s <- InspectAsm InspectState
get_
    let n = InspectState -> Word
litCount InspectState
s
    put_ (s { litCount = n + oneTwoLength ls })
    return n

  label :: LocalLabel -> InspectAsm ()
label LocalLabel
lbl = (InspectState -> InspectState) -> InspectAsm ()
modify_ (\InspectState
s -> let !count :: Word
count = InspectState -> Word
instrCount InspectState
s in let !env' :: UniqFM LocalLabel Word
env' = UniqFM LocalLabel Word
-> LocalLabel -> Word -> UniqFM LocalLabel Word
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (InspectState -> UniqFM LocalLabel Word
lblEnv InspectState
s) LocalLabel
lbl Word
count in InspectState
s { lblEnv = env' })

  emit :: PlatformWordSize -> Word16 -> [Operand] -> InspectAsm ()
emit PlatformWordSize
pwordsize Word16
_ [Operand]
ops = do
    InspectEnv long_jumps <- InspectAsm InspectEnv
ask_
    -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed
    -- to unroll for arguments up to size 6.
    let size = (State Word () -> Word -> Word
forall s a. State s a -> s -> s
MTL.execState ((Operand -> State Word ()) -> [Operand] -> State Word ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m ()
mapM6_ (\Operand
x -> (Word -> Word) -> State Word ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MTL.modify (Operand -> Word
count' Operand
x Word -> Word -> Word
forall a. Num a => a -> a -> a
+)) [Operand]
ops) Word
0) Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1
        largeOps = (Operand -> Bool) -> [Operand] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
any (Bool -> Operand -> Bool
largeOp Bool
long_jumps) [Operand]
ops
        bigSize = PlatformWordSize -> Word
largeArg16s PlatformWordSize
pwordsize
        count' = if Bool
largeOps then Word -> Operand -> Word
countLarge Word
bigSize else Word -> Operand -> Word
countSmall Word
bigSize

    s <- get_
    put_ (s { instrCount = instrCount s + size })

  {-# INLINE emit #-}
  {-# INLINE label #-}
  {-# INLINE lit #-}
  {-# INLINE ioptr #-}

count :: Word -> Bool -> Operand -> Word
count :: Word -> Bool -> Operand -> Word
count Word
_ Bool
_ (SmallOp Word16
_)          = Word
1
count Word
big Bool
largeOps (LabelOp LocalLabel
_) = if Bool
largeOps then Word
big else Word
1
count Word
big Bool
largeOps (Op Word
_)      = if Bool
largeOps then Word
big else Word
1
count Word
big Bool
largeOps (IOp Int
_)     = if Bool
largeOps then Word
big else Word
1
{-# INLINE count #-}

countSmall, countLarge :: Word -> Operand -> Word
countLarge :: Word -> Operand -> Word
countLarge Word
big Operand
x = Word -> Bool -> Operand -> Word
count Word
big Bool
True Operand
x
countSmall :: Word -> Operand -> Word
countSmall Word
big Operand
x = Word -> Bool -> Operand -> Word
count Word
big Bool
False Operand
x


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

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

{-# INLINE largeArg #-}
largeArg :: PlatformWordSize -> Word64 -> RunAsm ()
largeArg :: PlatformWordSize -> Word64 -> RunAsm ()
largeArg PlatformWordSize
wsize Word64
w = case PlatformWordSize
wsize of
   PlatformWordSize
PW8 ->  do Word16 -> RunAsm ()
writeIsn (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))
              Word16 -> RunAsm ()
writeIsn (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))
              Word16 -> RunAsm ()
writeIsn (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))
              Word16 -> RunAsm ()
writeIsn (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)
   PlatformWordSize
PW4 -> Bool -> SDoc -> RunAsm () -> RunAsm ()
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) (RunAsm () -> RunAsm ()) -> RunAsm () -> RunAsm ()
forall a b. (a -> b) -> a -> b
$ do
          Word16 -> RunAsm ()
writeIsn (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))
          Word16 -> RunAsm ()
writeIsn (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)

largeArg16s :: PlatformWordSize -> Word
largeArg16s :: PlatformWordSize -> Word
largeArg16s PlatformWordSize
pwordsize = case PlatformWordSize
pwordsize of
   PlatformWordSize
PW8 -> Word
4
   PlatformWordSize
PW4 -> Word
2

data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving ((forall a b. (a -> b) -> OneOrTwo a -> OneOrTwo b)
-> (forall a b. a -> OneOrTwo b -> OneOrTwo a) -> Functor OneOrTwo
forall a b. a -> OneOrTwo b -> OneOrTwo a
forall a b. (a -> b) -> OneOrTwo a -> OneOrTwo 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) -> OneOrTwo a -> OneOrTwo b
fmap :: forall a b. (a -> b) -> OneOrTwo a -> OneOrTwo b
$c<$ :: forall a b. a -> OneOrTwo b -> OneOrTwo a
<$ :: forall a b. a -> OneOrTwo b -> OneOrTwo a
Functor)

oneTwoLength :: OneOrTwo a -> Word
oneTwoLength :: forall a. OneOrTwo a -> Word
oneTwoLength (OnlyOne {}) = Word
1
oneTwoLength (OnlyTwo {}) = Word
2

class Monad m => MonadAssembler m where
  ioptr :: IO BCOPtr -> m Word
  lit :: OneOrTwo BCONPtr -> m Word
  label :: LocalLabel -> m ()
  emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()

lit1 :: MonadAssembler m => BCONPtr -> m Word
lit1 :: forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 BCONPtr
p = OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (BCONPtr -> OneOrTwo BCONPtr
forall a. a -> OneOrTwo a
OnlyOne BCONPtr
p)

{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-}
{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-}

assembleI :: forall m . MonadAssembler m
          => Platform
          -> BCInstr
          -> m ()
assembleI :: forall (m :: * -> *).
MonadAssembler m =>
Platform -> BCInstr -> m ()
assembleI Platform
platform BCInstr
i = case BCInstr
i of
  STKCHECK Word
n               -> Word16 -> [Operand] -> m ()
emit_ bci_STKCHECK [Op n]
  PUSH_L WordOff
o1                -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH_L [wOp o1]
  PUSH_LL WordOff
o1 WordOff
o2            -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH_LL [wOp o1, wOp o2]
  PUSH_LLL WordOff
o1 WordOff
o2 WordOff
o3        -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]
  PUSH8 ByteOff
o1                 -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH8 [bOp o1]
  PUSH16 ByteOff
o1                -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH16 [bOp o1]
  PUSH32 ByteOff
o1                -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH32 [bOp o1]
  PUSH8_W ByteOff
o1               -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH8_W [bOp o1]
  PUSH16_W ByteOff
o1              -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH16_W [bOp o1]
  PUSH32_W ByteOff
o1              -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH32_W [bOp o1]
  PUSH_G Name
nm                -> do p <- BCOPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCOPtr -> m Word
ptr (Name -> BCOPtr
BCOPtrName Name
nm)
                                 emit_ bci_PUSH_G [Op p]
  PUSH_PRIMOP PrimOp
op           -> do p <- BCOPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCOPtr -> m 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 -> m Word
forall (m :: * -> *). MonadAssembler m => IO BCOPtr -> m 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 -> m Word
forall (m :: * -> *). MonadAssembler m => IO BCOPtr -> m 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 -> m Word
forall (m :: * -> *). MonadAssembler m => IO BCOPtr -> m 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] -> m ()
emit_ bci_PUSH_PAD8 []
  BCInstr
PUSH_PAD16               -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH_PAD16 []
  BCInstr
PUSH_PAD32               -> Word16 -> [Operand] -> m ()
emit_ bci_PUSH_PAD32 []
  PUSH_UBX8 Literal
lit            -> do np <- Literal -> m Word
literal Literal
lit
                                 emit_ bci_PUSH_UBX8 [Op np]
  PUSH_UBX16 Literal
lit           -> do np <- Literal -> m Word
literal Literal
lit
                                 emit_ bci_PUSH_UBX16 [Op np]
  PUSH_UBX32 Literal
lit           -> do np <- Literal -> m Word
literal Literal
lit
                                 emit_ bci_PUSH_UBX32 [Op np]
  PUSH_UBX Literal
lit WordOff
nws         -> do np <- Literal -> m 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 -> m Word
forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 (Name -> BCONPtr
BCONPtrAddr Name
nm)
                                 emit_ bci_PUSH_UBX [Op np, SmallOp 1]

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

  SLIDE     WordOff
n WordOff
by           -> Word16 -> [Operand] -> m ()
emit_ bci_SLIDE [wOp n, wOp by]
  ALLOC_AP  HalfWord
n              -> Word16 -> [Operand] -> m ()
emit_ bci_ALLOC_AP [truncHalfWord platform n]
  ALLOC_AP_NOUPD HalfWord
n         -> Word16 -> [Operand] -> m ()
emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n]
  ALLOC_PAP HalfWord
arity HalfWord
n        -> Word16 -> [Operand] -> m ()
emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]
  MKAP      WordOff
off HalfWord
sz         -> Word16 -> [Operand] -> m ()
emit_ bci_MKAP [wOp off, truncHalfWord platform sz]
  MKPAP     WordOff
off HalfWord
sz         -> Word16 -> [Operand] -> m ()
emit_ bci_MKPAP [wOp off, truncHalfWord platform sz]
  UNPACK    WordOff
n              -> Word16 -> [Operand] -> m ()
emit_ bci_UNPACK [wOp n]
  PACK      DataCon
dcon WordOff
sz        -> do itbl_no <- BCONPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 (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 -> m ()
forall (m :: * -> *). MonadAssembler m => LocalLabel -> m ()
label LocalLabel
lbl
  TESTLT_I  Int
i LocalLabel
l            -> do np <- Int -> m Word
int Int
i
                                 emit_ bci_TESTLT_I [Op np, LabelOp l]
  TESTEQ_I  Int
i LocalLabel
l            -> do np <- Int -> m Word
int Int
i
                                 emit_ bci_TESTEQ_I [Op np, LabelOp l]
  TESTLT_W  Word
w LocalLabel
l            -> do np <- Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word Word
w
                                 emit_ bci_TESTLT_W [Op np, LabelOp l]
  TESTEQ_W  Word
w LocalLabel
l            -> do np <- Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word Word
w
                                 emit_ bci_TESTEQ_W [Op np, LabelOp l]
  TESTLT_I64  Int64
i LocalLabel
l          -> do np <- Word64 -> m 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 -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
word64 Word64
w
                                 emit_ bci_TESTLT_W64 [Op np, LabelOp l]
  TESTEQ_W64  Word64
w LocalLabel
l          -> do np <- Word64 -> m Word
word64 Word64
w
                                 emit_ bci_TESTEQ_W64 [Op np, LabelOp l]
  TESTLT_W32  Word32
w LocalLabel
l          -> do np <- Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
float Float
f
                                 emit_ bci_TESTLT_F [Op np, LabelOp l]
  TESTEQ_F  Float
f LocalLabel
l            -> do np <- Float -> m Word
float Float
f
                                 emit_ bci_TESTEQ_F [Op np, LabelOp l]
  TESTLT_D  Double
d LocalLabel
l            -> do np <- Double -> m Word
double Double
d
                                 emit_ bci_TESTLT_D [Op np, LabelOp l]
  TESTEQ_D  Double
d LocalLabel
l            -> do np <- Double -> m Word
double Double
d
                                 emit_ bci_TESTEQ_D [Op np, LabelOp l]
  TESTLT_P  Word16
i LocalLabel
l            -> Word16 -> [Operand] -> m ()
emit_ bci_TESTLT_P [SmallOp i, LabelOp l]
  TESTEQ_P  Word16
i LocalLabel
l            -> Word16 -> [Operand] -> m ()
emit_ bci_TESTEQ_P [SmallOp i, LabelOp l]
  BCInstr
CASEFAIL                 -> Word16 -> [Operand] -> m ()
emit_ bci_CASEFAIL []
  SWIZZLE   WordOff
stkoff Int
n       -> Word16 -> [Operand] -> m ()
emit_ bci_SWIZZLE [wOp stkoff, IOp n]
  JMP       LocalLabel
l              -> Word16 -> [Operand] -> m ()
emit_ bci_JMP [LabelOp l]
  BCInstr
ENTER                    -> Word16 -> [Operand] -> m ()
emit_ bci_ENTER []
  RETURN ArgRep
rep               -> Word16 -> [Operand] -> m ()
emit_ (ArgRep -> Word16
return_non_tuple ArgRep
rep) []
  BCInstr
RETURN_TUPLE             -> Word16 -> [Operand] -> m ()
emit_ bci_RETURN_T []
  CCALL WordOff
off RemotePtr C_ffi_cif
m_addr Word16
i       -> do np <- RemotePtr C_ffi_cif -> m Word
forall {m :: * -> *} {a}. MonadAssembler m => RemotePtr a -> m Word
addr RemotePtr C_ffi_cif
m_addr
                                 emit_ bci_CCALL [wOp off, Op np, SmallOp i]
  BCInstr
PRIMCALL                 -> Word16 -> [Operand] -> m ()
emit_ bci_PRIMCALL []
  BRK_FUN ForeignRef BreakArray
arr RemotePtr ModuleName
tick_mod Word16
tickx RemotePtr ModuleName
info_mod Word16
infox RemotePtr CostCentre
cc ->
                              do p1 <- BCOPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCOPtr -> m Word
ptr (ForeignRef BreakArray -> BCOPtr
BCOPtrBreakArray ForeignRef BreakArray
arr)
                                 tick_addr <- addr tick_mod
                                 info_addr <- addr info_mod
                                 np <- addr cc
                                 emit_ bci_BRK_FUN [ Op p1
                                                  , Op tick_addr, Op info_addr
                                                  , SmallOp tickx, SmallOp infox
                                                  , Op np
                                                  ]
#if MIN_VERSION_rts(1,0,3)
  BCO_NAME ByteString
name            -> do np <- BCONPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 (ByteString -> BCONPtr
BCONPtrStr ByteString
name)
                                 emit_ bci_BCO_NAME [Op np]
#endif



  where
    emit_ :: Word16 -> [Operand] -> m ()
emit_ = PlatformWordSize -> Word16 -> [Operand] -> m ()
forall (m :: * -> *).
MonadAssembler m =>
PlatformWordSize -> Word16 -> [Operand] -> m ()
emit PlatformWordSize
word_size

    literal :: Literal -> m Word
    literal :: Literal -> m Word
literal (LitLabel FastString
fs FunctionOrData
_)   = FastString -> m Word
forall {m :: * -> *}. MonadAssembler m => FastString -> m Word
litlabel FastString
fs
    literal Literal
LitNullAddr       = Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word Word
0
    literal (LitFloat Rational
r)      = Float -> m Word
float (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
    literal (LitDouble Rational
r)     = Double -> m Word
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
    literal (LitChar Char
c)       = Int -> m Word
int (Char -> Int
ord Char
c)
    literal (LitString ByteString
bs)    = BCONPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 (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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord    -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt8    -> Word8 -> m Word
word8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord8   -> Word8 -> m Word
word8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt16   -> Word16 -> m Word
word16 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord16  -> Word16 -> m Word
word16 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt32   -> Word32 -> m Word
word32 (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord32  -> Word32 -> m Word
word32 (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt64   -> Word64 -> m Word
word64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord64  -> Word64 -> m Word
word64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumBigNat  -> String -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word Word
0

    litlabel :: FastString -> m Word
litlabel FastString
fs = BCONPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 (FastString -> BCONPtr
BCONPtrLbl FastString
fs)
    addr :: RemotePtr a -> m Word
addr (RemotePtr Word64
a) = Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
    words :: OneOrTwo Word -> m Word
words OneOrTwo Word
ws = OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit ((Word -> BCONPtr) -> OneOrTwo Word -> OneOrTwo BCONPtr
forall a b. (a -> b) -> OneOrTwo a -> OneOrTwo b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> BCONPtr
BCONPtrWord OneOrTwo Word
ws)
    word :: Word -> m Word
word Word
w = OneOrTwo Word -> m Word
forall {m :: * -> *}. MonadAssembler m => OneOrTwo Word -> m Word
words (Word -> OneOrTwo Word
forall a. a -> OneOrTwo a
OnlyOne Word
w)
    word2 :: Word -> Word -> m Word
word2 Word
w1 Word
w2 = OneOrTwo Word -> m Word
forall {m :: * -> *}. MonadAssembler m => OneOrTwo Word -> m Word
words (Word -> Word -> OneOrTwo Word
forall a. a -> a -> OneOrTwo a
OnlyTwo Word
w1 Word
w2)
    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 -> m Word
    int :: Int -> m Word
int  Int
i = Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

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

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

    word64 :: Word64 -> m Word
    word64 :: Word64 -> m 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 -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> Word -> m Word
word2 Word
wl Word
wh
            ByteOrder
BigEndian    -> Word -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> Word -> m Word
word2 Word
wh Word
wl
       PlatformWordSize
PW8 -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ww)

    word8 :: Word8 -> m Word
    word8 :: Word8 -> m Word
word8  Word8
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
      ByteOrder
LittleEndian -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)
      ByteOrder
BigEndian    -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
    word16 :: Word16 -> m Word
word16 Word16
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
      ByteOrder
LittleEndian -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x)
      ByteOrder
BigEndian    -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
    word32 :: Word32 -> m Word
word32 Word32
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
      ByteOrder
LittleEndian -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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 -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m Word
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x)
        PlatformWordSize
PW8 -> Word -> m Word
forall {m :: * -> *}. MonadAssembler m => Word -> m 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
  Jumps.cmm, 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
  = -- 24 bits for register bitmap
    Bool
-> SDoc
-> (Bool
    -> SDoc
    -> (Bool -> SDoc -> Word32 -> Word32)
    -> Bool
    -> SDoc
    -> Word32
    -> Word32)
-> Bool
-> SDoc
-> (Bool -> SDoc -> Word32 -> Word32)
-> Bool
-> SDoc
-> Word32
-> Word32
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([(GlobalReg, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GlobalReg, Int)]
argRegs 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)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GlobalReg, Int)]
argRegs))

    -- 8 bits for continuation offset (only for NativeTupleReturn)
    Bool
-> SDoc
-> (Bool -> SDoc -> Word32 -> Word32)
-> Bool
-> SDoc
-> Word32
-> 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)

    -- all regs accounted for
    Bool -> SDoc -> Word32 -> 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, Int) -> GlobalReg)
-> [(GlobalReg, Int)] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Int) -> GlobalReg
forall a b. (a, b) -> a
fst [(GlobalReg, Int)]
argRegs)) (GlobalRegSet -> [GlobalReg]
forall r. RegSet r -> [r]
regSetToList GlobalRegSet
nativeCallRegs))
      ( [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not all registers accounted for"
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"argRegs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(GlobalReg, Int)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(GlobalReg, Int)]
argRegs
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"nativeCallRegs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GlobalRegSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalRegSet
nativeCallRegs
        ] ) (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
      -- SIMD GHCi TODO: the above assertion doesn't account for register overlap;
      -- it will need to be adjusted for SIMD vector support in the bytecode interpreter.

    (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)]
argRegs 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
    argRegs :: [(GlobalReg, Int)]
argRegs = [GlobalReg] -> [Int] -> [(GlobalReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> GlobalArgRegs -> [GlobalReg]
allArgRegsCover Platform
platform GlobalArgRegs
SCALAR_ARG_REGS) [Int
0..]
      -- The bytecode interpreter does not (currently) handle vector registers,
      -- so we only use the scalar argument-passing registers here.

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