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

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

import GHC.Prelude

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

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

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

import GHC.Core.TyCon
import GHC.Data.FlatBag
import GHC.Data.SizedSeq

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 Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict

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

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

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

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

-- | Finds external references.  Remember to remove the names
-- defined by this group of BCOs themselves
bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
bcoFreeNames UnlinkedBCO
bco
  = UnlinkedBCO -> UniqDSet Name
bco_refs UnlinkedBCO
bco UniqDSet Name -> UniqSet Name -> UniqDSet Name
forall a. UniqDSet a -> UniqSet a -> UniqDSet a
`uniqDSetMinusUniqSet` [Name] -> UniqSet Name
mkNameSet [UnlinkedBCO -> Name
unlinkedBCOName UnlinkedBCO
bco]
  where
    bco_refs :: UnlinkedBCO -> UniqDSet Name
bco_refs (UnlinkedBCO Name
_ Int
_ 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
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 (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
get
    case rptrs of
      (RemotePtr Word64
p : [RemotePtr a]
rest) -> do
        [RemotePtr a] -> StateT [RemotePtr a] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [RemotePtr a]
rest
        BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall a. a -> StateT [RemotePtr a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word -> BCONPtr
BCONPtrWord (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p))
      [RemotePtr a]
_ -> String -> StateT [RemotePtr a] m BCONPtr
forall a. HasCallStack => String -> a
panic String
"mallocStrings:spliceLit"
  spliceLit BCONPtr
other = BCONPtr -> StateT [RemotePtr a] m BCONPtr
forall a. a -> StateT [RemotePtr a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return BCONPtr
other

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

  collect :: UnlinkedBCO -> StateT [ByteString] m ()
collect UnlinkedBCO{Int
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
get
    put (bs:strs)
  collectLit BCONPtr
_ = () -> StateT [ByteString] m ()
forall a. a -> StateT [ByteString] m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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


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

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

      initial_offset :: Word
initial_offset = Word
0

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

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

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

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

  let asm_insns = SizedSeq Word16 -> [Word16]
forall a. SizedSeq a -> [a]
ssElts SizedSeq Word16
final_insns
      !insns_arr =  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
$ (Int, Int) -> [Word16] -> UArray Int Word16
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0 :: Int, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n_insns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word16]
asm_insns
      !bitmap_arr = UArray Int 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 (SizedSeq BCONPtr -> FlatBag BCONPtr
forall a. SizedSeq a -> FlatBag a
fromSizedSeq SizedSeq BCONPtr
final_lits) (SizedSeq BCOPtr -> FlatBag BCOPtr
forall a. SizedSeq a -> FlatBag a
fromSizedSeq SizedSeq BCOPtr
final_ptrs)

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

  return ul_bco

mkBitmapArray :: Word -> [StgWord] -> UArray Int 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

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

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

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

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

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

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

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

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

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

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

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

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

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

type LabelEnv = LocalLabel -> Word

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

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

type LabelEnvMap = Map LocalLabel Word

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

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

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

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

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

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

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

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

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

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

  where
    literal :: Literal -> Assembler Word
literal (LitLabel FastString
fs FunctionOrData
_)   = FastString -> Assembler Word
litlabel FastString
fs
    literal Literal
LitNullAddr       = Word -> Assembler Word
word Word
0
    literal (LitFloat Rational
r)      = Float -> Assembler Word
float (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
    literal (LitDouble Rational
r)     = Double -> Assembler Word
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
    literal (LitChar Char
c)       = Int -> Assembler Word
int (Char -> Int
ord Char
c)
    literal (LitString ByteString
bs)    = [BCONPtr] -> Assembler Word
lit [ByteString -> BCONPtr
BCONPtrStr ByteString
bs]
       -- LitString requires a zero-terminator when emitted
    literal (LitNumber LitNumType
nt Integer
i) = case LitNumType
nt of
      LitNumType
LitNumInt     -> Word -> Assembler Word
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord    -> Word -> Assembler Word
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt8    -> Word8 -> Assembler Word
word8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord8   -> Word8 -> Assembler Word
word8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt16   -> Word16 -> Assembler Word
word16 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord16  -> Word16 -> Assembler Word
word16 (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt32   -> Word32 -> Assembler Word
word32 (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord32  -> Word32 -> Assembler Word
word32 (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumInt64   -> Word64 -> Assembler Word
word64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumWord64  -> Word64 -> Assembler Word
word64 (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
      LitNumType
LitNumBigNat  -> String -> Assembler Word
forall a. HasCallStack => String -> a
panic String
"GHC.ByteCode.Asm.literal: LitNumBigNat"

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

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

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

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

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

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

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

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

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


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

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

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

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

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

  If needed, you can support larger tuples by adding more in
  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