{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MagicHash       #-}
{-# LANGUAGE UnboxedTuples   #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
{-# LANGUAGE LambdaCase #-}
--
--
--  (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, words )

import Data.Maybe
import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )

import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Literal
import GHC.Types.Literal.Floating
import GHC.Types.Unique.DSet
import GHC.Types.SptEntry
import GHC.Types.Unique.FM
import GHC.Unit.Types

import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat )
import GHC.Utils.Panic

import GHC.Builtin.Types.Prim ( addrPrimTy )
import GHC.Core.Type          ( isUnliftedType )
import GHC.Core.TyCo.Compare  ( eqType )
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 Language.Haskell.Syntax.Module.Name

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.ByteString (ByteString)
import Data.Char  (ord)
import GHC.Float (castFloatToWord32, castDoubleToWord64)

import qualified Data.List as List ( any )
import GHC.Exts
import GHC.Core.DataCon
import GHC.Data.FlatBag
import GHC.Types.Id
import Data.List (unfoldr)
import GHC.Types.RepType (typePrimRepU)


-- -----------------------------------------------------------------------------
-- 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
  where
    bco_refs :: UnlinkedBCO -> UniqDSet Name
bco_refs UnlinkedBCO{Name
unlinkedBCOName :: Name
unlinkedBCOName :: UnlinkedBCO -> Name
unlinkedBCOName, FlatBag BCONPtr
unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedBCOLits, FlatBag BCOPtr
unlinkedBCOPtrs :: FlatBag BCOPtr
unlinkedBCOPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedBCOPtrs}
        = [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
unlinkedBCOPtrs ] 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
unlinkedBCOLits ] 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
unlinkedBCOPtrs ]
          ) UniqDSet Name -> UniqSet Name -> UniqDSet Name
forall a. UniqDSet a -> UniqSet a -> UniqDSet a
`uniqDSetMinusUniqSet` [Name] -> UniqSet Name
mkNameSet [Name
unlinkedBCOName]
    bco_refs UnlinkedStaticCon{ Name
unlinkedStaticConName :: Name
unlinkedStaticConName :: UnlinkedBCO -> Name
unlinkedStaticConName, Name
unlinkedStaticConDataConName :: Name
unlinkedStaticConDataConName :: UnlinkedBCO -> Name
unlinkedStaticConDataConName
                              , FlatBag BCONPtr
unlinkedStaticConLits :: FlatBag BCONPtr
unlinkedStaticConLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedStaticConLits, FlatBag BCOPtr
unlinkedStaticConPtrs :: FlatBag BCOPtr
unlinkedStaticConPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedStaticConPtrs }
        = [UniqDSet Name] -> UniqDSet Name
forall a. [UniqDSet a] -> UniqDSet a
unionManyUniqDSets (
             [Name] -> UniqDSet Name
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet [ Name
unlinkedStaticConDataConName ] UniqDSet Name -> [UniqDSet Name] -> [UniqDSet Name]
forall a. a -> [a] -> [a]
:
             [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
unlinkedStaticConPtrs ] 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
unlinkedStaticConLits ] 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
unlinkedStaticConPtrs ]
          )
          UniqDSet Name -> UniqSet Name -> UniqDSet Name
forall a. UniqDSet a -> UniqSet a -> UniqDSet a
`uniqDSetMinusUniqSet` [Name] -> UniqSet Name
mkNameSet [ Name
unlinkedStaticConName ]

-- -----------------------------------------------------------------------------
-- 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
  :: Profile
  -> FlatBag ProtoBCO
  -> [TyCon]
  -> [(Name, ByteString)]
  -> Maybe InternalModBreaks
  -> [SptEntry]
  -> IO CompiledByteCode
assembleBCOs :: Profile
-> FlatBag ProtoBCO
-> [TyCon]
-> [(Name, ByteString)]
-> Maybe InternalModBreaks
-> [SptEntry]
-> IO CompiledByteCode
assembleBCOs Profile
profile FlatBag ProtoBCO
proto_bcos [TyCon]
tycons [(Name, ByteString)]
top_strs Maybe InternalModBreaks
modbreaks [SptEntry]
spt_entries = do
  -- TODO: the profile should be bundled with the interpreter: the rts ways are
  -- fixed for an interpreter
  let itbls :: [(Name, ConInfoTable)]
itbls = Profile -> [TyCon] -> [(Name, ConInfoTable)]
mkITbls Profile
profile [TyCon]
tycons
  bcos    <- (ProtoBCO -> IO UnlinkedBCO)
-> FlatBag ProtoBCO -> IO (FlatBag UnlinkedBCO)
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 (Platform -> ProtoBCO -> IO UnlinkedBCO
assembleBCO (Profile -> Platform
profilePlatform Profile
profile)) FlatBag ProtoBCO
proto_bcos
  return CompiledByteCode
    { bc_bcos = bcos
    , bc_itbls = itbls
    , 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.
--
-- We used to allocate remote buffers for BCONPtrStr ByteStrings when
-- assembling, but this gets in the way of bytecode serialization: we
-- want the ability to serialize and reload assembled bytecode, so
-- it's better to preserve BCONPtrStr as-is, and only perform the
-- actual allocation at link-time.
--
-- 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.
--

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 -> IO UnlinkedBCO
assembleBCO :: Platform -> ProtoBCO -> IO UnlinkedBCO
assembleBCO Platform
platform
            (ProtoStaticCon { Name
protoStaticConName :: Name
protoStaticConName :: ProtoBCO -> Name
protoStaticConName
                            , protoStaticCon :: ProtoBCO -> DataCon
protoStaticCon = DataCon
dc
                            , protoStaticConData :: ProtoBCO -> [Either Literal Id]
protoStaticConData = [Either Literal Id]
args
                            }) = do
  let fullword_args :: [Either (OneOrTwo BCONPtr) Id]
fullword_args = Platform -> [Either Literal Id] -> [Either (OneOrTwo BCONPtr) Id]
packSubwordArgs Platform
platform [Either Literal Id]
args
  let ptrs :: FlatBag BCOPtr
ptrs    = (FlatBag BCOPtr -> FlatBag BCOPtr -> FlatBag BCOPtr)
-> FlatBag BCOPtr -> [FlatBag BCOPtr] -> FlatBag BCOPtr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FlatBag BCOPtr -> FlatBag BCOPtr -> FlatBag BCOPtr
forall a. FlatBag a -> FlatBag a -> FlatBag a
mappendFlatBag FlatBag BCOPtr
forall a. FlatBag a
emptyFlatBag ((Either (OneOrTwo BCONPtr) Id -> Maybe (FlatBag BCOPtr))
-> [Either (OneOrTwo BCONPtr) Id] -> [FlatBag BCOPtr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Either (OneOrTwo BCONPtr) Id -> Maybe (FlatBag BCOPtr)
forall {a}. Either a Id -> Maybe (FlatBag BCOPtr)
idBCOArg [Either (OneOrTwo BCONPtr) Id]
fullword_args)
  let nonptrs :: FlatBag BCONPtr
nonptrs = (FlatBag BCONPtr -> FlatBag BCONPtr -> FlatBag BCONPtr)
-> FlatBag BCONPtr -> [FlatBag BCONPtr] -> FlatBag BCONPtr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FlatBag BCONPtr -> FlatBag BCONPtr -> FlatBag BCONPtr
forall a. FlatBag a -> FlatBag a -> FlatBag a
mappendFlatBag FlatBag BCONPtr
forall a. FlatBag a
emptyFlatBag ((Either (OneOrTwo BCONPtr) Id -> Maybe (FlatBag BCONPtr))
-> [Either (OneOrTwo BCONPtr) Id] -> [FlatBag BCONPtr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Either (OneOrTwo BCONPtr) Id -> Maybe (FlatBag BCONPtr)
litBCOArg [Either (OneOrTwo BCONPtr) Id]
fullword_args)
  UnlinkedBCO -> IO UnlinkedBCO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnlinkedStaticCon
    { unlinkedStaticConName :: Name
unlinkedStaticConName = Name
protoStaticConName
    , unlinkedStaticConDataConName :: Name
unlinkedStaticConDataConName = DataCon -> Name
dataConName DataCon
dc
    , unlinkedStaticConLits :: FlatBag BCONPtr
unlinkedStaticConLits = FlatBag BCONPtr
nonptrs
    , unlinkedStaticConPtrs :: FlatBag BCOPtr
unlinkedStaticConPtrs = FlatBag BCOPtr
ptrs
    , unlinkedStaticConIsUnlifted :: Bool
unlinkedStaticConIsUnlifted = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType (DataCon -> Id
dataConWrapId DataCon
dc))
    }
  where
    litBCOArg :: Either (OneOrTwo BCONPtr) Id -> Maybe (FlatBag BCONPtr)
litBCOArg (Left OneOrTwo BCONPtr
l) = FlatBag BCONPtr -> Maybe (FlatBag BCONPtr)
FlatBag BCONPtr -> Maybe (FlatBag BCONPtr)
forall a. a -> Maybe a
Just (FlatBag BCONPtr -> Maybe (FlatBag BCONPtr))
-> FlatBag BCONPtr -> Maybe (FlatBag BCONPtr)
forall a b. (a -> b) -> a -> b
$ case OneOrTwo BCONPtr
l of
      OnlyOne BCONPtr
np -> BCONPtr -> FlatBag BCONPtr
forall a. a -> FlatBag a
unitFlatBag BCONPtr
np
      OnlyTwo BCONPtr
np1 BCONPtr
np2 -> BCONPtr -> BCONPtr -> FlatBag BCONPtr
forall a. a -> a -> FlatBag a
TupleFlatBag BCONPtr
np1 BCONPtr
np2
    litBCOArg (Right Id
var)
      -- Addr# literals are non-pointers
      | Id -> Type
idType Id
var HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy
      = FlatBag BCONPtr -> Maybe (FlatBag BCONPtr)
FlatBag BCONPtr -> Maybe (FlatBag BCONPtr)
forall a. a -> Maybe a
Just (FlatBag BCONPtr -> Maybe (FlatBag BCONPtr))
-> FlatBag BCONPtr -> Maybe (FlatBag BCONPtr)
forall a b. (a -> b) -> a -> b
$ BCONPtr -> FlatBag BCONPtr
forall a. a -> FlatBag a
unitFlatBag (Name -> BCONPtr
BCONPtrAddr (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
var))
      | Bool
otherwise
      = Maybe (FlatBag BCONPtr)
forall a. Maybe a
Nothing

    idBCOArg :: Either a Id -> Maybe (FlatBag BCOPtr)
idBCOArg (Left a
_) = Maybe (FlatBag BCOPtr)
forall a. Maybe a
Nothing
    idBCOArg (Right Id
var)
      | Id -> Type
idType Id
var HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
addrPrimTy
      = Maybe (FlatBag BCOPtr)
forall a. Maybe a
Nothing
      | Just PrimOp
prim <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
var
      = FlatBag BCOPtr -> Maybe (FlatBag BCOPtr)
FlatBag BCOPtr -> Maybe (FlatBag BCOPtr)
forall a. a -> Maybe a
Just (FlatBag BCOPtr -> Maybe (FlatBag BCOPtr))
-> FlatBag BCOPtr -> Maybe (FlatBag BCOPtr)
forall a b. (a -> b) -> a -> b
$ BCOPtr -> FlatBag BCOPtr
forall a. a -> FlatBag a
unitFlatBag (PrimOp -> BCOPtr
BCOPtrPrimOp PrimOp
prim)
      | Bool
otherwise
      = FlatBag BCOPtr -> Maybe (FlatBag BCOPtr)
FlatBag BCOPtr -> Maybe (FlatBag BCOPtr)
forall a. a -> Maybe a
Just (FlatBag BCOPtr -> Maybe (FlatBag BCOPtr))
-> FlatBag BCOPtr -> Maybe (FlatBag BCOPtr)
forall a b. (a -> b) -> a -> b
$ BCOPtr -> FlatBag BCOPtr
forall a. a -> FlatBag a
unitFlatBag (Name -> BCOPtr
BCOPtrName (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
var))

assembleBCO Platform
platform
            (ProtoBCO { protoBCOName :: ProtoBCO -> Name
protoBCOName       = Name
nm
                      , protoBCOInstrs :: ProtoBCO -> [BCInstr]
protoBCOInstrs     = [BCInstr]
instrs
                      , protoBCOBitmap :: ProtoBCO -> [StgWord]
protoBCOBitmap     = [StgWord]
bitmap
                      , protoBCOBitmapSize :: ProtoBCO -> Word
protoBCOBitmapSize = Word
bsize
                      , protoBCOArity :: ProtoBCO -> 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 = UnlinkedBCO { unlinkedBCOName :: Name
unlinkedBCOName = Name
nm
                           , unlinkedBCOArity :: Int
unlinkedBCOArity = Int
arity
                           , unlinkedBCOInstrs :: BCOByteArray Word16
unlinkedBCOInstrs = BCOByteArray Word16
insns_arr
                           , unlinkedBCOBitmap :: BCOByteArray Word
unlinkedBCOBitmap = BCOByteArray Word
bitmap_arr
                           , unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOLits = SmallArray BCONPtr -> FlatBag BCONPtr
forall a. SmallArray a -> FlatBag a
fromSmallArray SmallArray BCONPtr
final_lit_array
                           , unlinkedBCOPtrs :: FlatBag BCOPtr
unlinkedBCOPtrs = 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

-- | Pack sub-word literals (which should appear contiguously in the argument
-- list) into full words, and leave full-word-sized arguments alone.
packSubwordArgs :: Platform -> [Either Literal Id] -> [Either (OneOrTwo BCONPtr) Id]
packSubwordArgs :: Platform -> [Either Literal Id] -> [Either (OneOrTwo BCONPtr) Id]
packSubwordArgs Platform
platform = (Either [Literal] Id -> Either (OneOrTwo BCONPtr) Id)
-> [Either [Literal] Id] -> [Either (OneOrTwo BCONPtr) Id]
forall a b. (a -> b) -> [a] -> [b]
map Either [Literal] Id -> Either (OneOrTwo BCONPtr) Id
packWord ([Either [Literal] Id] -> [Either (OneOrTwo BCONPtr) Id])
-> ([Either Literal Id] -> [Either [Literal] Id])
-> [Either Literal Id]
-> [Either (OneOrTwo BCONPtr) Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Literal Id] -> [Either [Literal] Id]
groupWords
  where
    -- Assumes packed sub-words are always ordered from largest to smallest literal
    packWord :: Either [Literal] Id -> Either (OneOrTwo BCONPtr) Id
    packWord :: Either [Literal] Id -> Either (OneOrTwo BCONPtr) Id
packWord (Right Id
v)    = Id -> Either (OneOrTwo BCONPtr) Id
forall a b. b -> Either a b
Right Id
v -- already word size
    packWord (Left [Literal
lit]) = OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id
OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id
forall a b. a -> Either a b
Left (OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id)
-> OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id
forall a b. (a -> b) -> a -> b
$ Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform Literal
lit -- single >=word_size literal
    packWord (Left [Literal]
lits)  = OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id
OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id
forall a b. a -> Either a b
Left (OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id)
-> OneOrTwo BCONPtr -> Either (OneOrTwo BCONPtr) Id
forall a b. (a -> b) -> a -> b
$ BCONPtr -> OneOrTwo BCONPtr
forall a. a -> OneOrTwo a
OnlyOne (Word -> BCONPtr
BCONPtrWord Word
packedWord)
      where
        packedWord :: Word
packedWord = Int -> [Literal] -> Word
go Int
0 [Literal]
lits

        go :: Int -> [Literal] -> Word
        go :: Int -> [Literal] -> Word
go Int
_      []     = Word
0
        go Int
offset (Literal
l:[Literal]
ls) =
          (Literal -> Word
subwordLiteral Literal
l Word -> Int -> Word
`shiftBy` Int
offset) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Int -> [Literal] -> Word
go (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Literal -> Int
litBits Literal
l) [Literal]
ls

        shiftBy :: Word -> Int -> Word
        shiftBy :: Word -> Int -> Word
shiftBy Word
w Int
offset = case Platform -> ByteOrder
platformByteOrder Platform
platform of
          ByteOrder
LittleEndian -> Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
offset
          ByteOrder
BigEndian    -> Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
offset

        subwordLiteral :: Literal -> Word
        subwordLiteral :: Literal -> Word
subwordLiteral Literal
l = case Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform Literal
l of
          OnlyOne (BCONPtrWord Word
w) -> Word
w
          OneOrTwo BCONPtr
_ -> String -> SDoc -> Word
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"packSubwordArgs: expected a subword literal to lower to one BCONPtrWord" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l)

        litBits :: Literal -> Int
        litBits :: Literal -> Int
litBits Literal
l = Literal -> Int
litBytes Literal
l Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8

    -- Group literals into lists of literals making up a full word, where in
    -- singleton lists the literal may be larger than a word
    -- (e.g. Word64 in 32bit platform)
    groupWords :: [Either Literal Id] -> [Either [Literal] Id]
    groupWords :: [Either Literal Id] -> [Either [Literal] Id]
groupWords = ([Either Literal Id]
 -> Maybe (Either [Literal] Id, [Either Literal Id]))
-> [Either Literal Id] -> [Either [Literal] Id]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [Either Literal Id]
-> Maybe (Either [Literal] Id, [Either Literal Id])
step
      where
        step :: [Either Literal Id]
-> Maybe (Either [Literal] Id, [Either Literal Id])
step [] = Maybe (Either [Literal] Id, [Either Literal Id])
forall a. Maybe a
Nothing
        step (Right Id
v:[Either Literal Id]
xs) = (Either [Literal] Id, [Either Literal Id])
-> Maybe (Either [Literal] Id, [Either Literal Id])
forall a. a -> Maybe a
Just (Id -> Either [Literal] Id
forall a b. b -> Either a b
Right Id
v, [Either Literal Id]
xs)
        step (Left Literal
l:[Either Literal Id]
xs) =
          let ([Literal]
chunk, [Either Literal Id]
rest) = [Literal]
-> [Either Literal Id] -> ([Literal], [Either Literal Id])
takeWord [] (Literal -> Either Literal Id
forall a b. a -> Either a b
Left Literal
lEither Literal Id -> [Either Literal Id] -> [Either Literal Id]
forall a. a -> [a] -> [a]
:[Either Literal Id]
xs)
          in (Either [Literal] Id, [Either Literal Id])
-> Maybe (Either [Literal] Id, [Either Literal Id])
forall a. a -> Maybe a
Just ([Literal] -> Either [Literal] Id
forall a b. a -> Either a b
Left [Literal]
chunk, [Either Literal Id]
rest)

        -- take subwords from list until a full-word is accumulated
        takeWord :: [Literal]
-> [Either Literal Id] -> ([Literal], [Either Literal Id])
takeWord [Literal]
acc [Either Literal Id]
rest
          -- reached a full word in the accumulator; exit!
          | [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Literal -> Int) -> [Literal] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Literal -> Int
litBytes [Literal]
acc) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ws
          = ([Literal] -> [Literal]
forall a. [a] -> [a]
reverse [Literal]
acc, [Either Literal Id]
rest)
        takeWord [Literal
sing] [Either Literal Id]
rest
          -- a larger than word single lit in the accumulator; exit!
          | Literal -> Int
litBytes Literal
sing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ws
          = ([Literal
sing], [Either Literal Id]
rest)
        takeWord [Literal]
acc (Left Literal
l:[Either Literal Id]
ls)
          -- contiguous lits should be sub-words of right size to form full
          -- word; else, the exit condition is never reached.
          = [Literal]
-> [Either Literal Id] -> ([Literal], [Either Literal Id])
takeWord (Literal
lLiteral -> [Literal] -> [Literal]
forall a. a -> [a] -> [a]
:[Literal]
acc) [Either Literal Id]
ls
        takeWord [Literal]
acc [Either Literal Id]
_
          = String -> SDoc -> ([Literal], [Either Literal Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"packSubwordArgs: Reached Ptr or end of list before forming a full word from contiguous literals."
                     (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"acc:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Literal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Literal]
acc)

    litBytes :: Literal -> Int
litBytes = Platform -> PrimRep -> Int
primRepSizeB Platform
platform (PrimRep -> Int) -> (Literal -> PrimRep) -> Literal -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> PrimRep
Type -> PrimRep
typePrimRepU (Type -> PrimRep) -> (Literal -> Type) -> Literal -> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Type
literalType
    ws :: Int
ws = Platform -> Int
platformWordSizeInBytes Platform
platform

-- | Construct a word-array containing an @StgLargeBitmap@.
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
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
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
proto           -> do let ul_bco :: IO UnlinkedBCO
ul_bco = Platform -> ProtoBCO -> IO UnlinkedBCO
assembleBCO Platform
platform ProtoBCO
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
UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
                                 emit_ bci_PUSH_G [Op p]
  PUSH_ALTS ProtoBCO
proto ArgRep
pk
                           -> do let ul_bco :: IO UnlinkedBCO
ul_bco = Platform -> ProtoBCO -> IO UnlinkedBCO
assembleBCO Platform
platform ProtoBCO
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
UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
                                 emit_ (push_alts pk) [Op p]
  PUSH_ALTS_TUPLE ProtoBCO
proto NativeCallInfo
call_info ProtoBCO
tuple_proto
                           -> do let ul_bco :: IO UnlinkedBCO
ul_bco = Platform -> ProtoBCO -> IO UnlinkedBCO
assembleBCO Platform
platform ProtoBCO
proto
                                     ul_tuple_bco :: IO UnlinkedBCO
ul_tuple_bco = Platform -> ProtoBCO -> IO UnlinkedBCO
assembleBCO Platform
platform
                                                                ProtoBCO
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
UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
                                 p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
                                 info <- lit $ 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
litv           -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform Literal
litv
                                 emit_ bci_PUSH_UBX8 [Op np]
  PUSH_UBX16 Literal
litv          -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform Literal
litv
                                 emit_ bci_PUSH_UBX16 [Op np]
  PUSH_UBX32 Literal
litv          -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform Literal
litv
                                 emit_ bci_PUSH_UBX32 [Op np]
  PUSH_UBX Literal
litv WordOff
nws        -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform Literal
litv
                                 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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Int -> OneOrTwo BCONPtr
int Int
i
                                 emit_ bci_TESTLT_I [Op np, LabelOp l]
  TESTEQ_I  Int
i LocalLabel
l            -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Int -> OneOrTwo BCONPtr
int Int
i
                                 emit_ bci_TESTEQ_I [Op np, LabelOp l]
  TESTLT_W  Word
w LocalLabel
l            -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
word Word
w
                                 emit_ bci_TESTLT_W [Op np, LabelOp l]
  TESTEQ_W  Word
w LocalLabel
l            -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
word Word
w
                                 emit_ bci_TESTEQ_W [Op np, LabelOp l]
  TESTLT_I64  Int64
i LocalLabel
l          -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform (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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform (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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform Word64
w
                                 emit_ bci_TESTLT_W64 [Op np, LabelOp l]
  TESTEQ_W64  Word64
w LocalLabel
l          -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform Word64
w
                                 emit_ bci_TESTEQ_W64 [Op np, LabelOp l]
  TESTLT_W32  Word32
w LocalLabel
l          -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Word -> OneOrTwo BCONPtr
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 <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Float -> OneOrTwo BCONPtr
float Platform
platform Float
f
                                 emit_ bci_TESTLT_F [Op np, LabelOp l]
  TESTEQ_F  Float
f LocalLabel
l            -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Float -> OneOrTwo BCONPtr
float Platform
platform Float
f
                                 emit_ bci_TESTEQ_F [Op np, LabelOp l]
  TESTLT_D  Double
d LocalLabel
l            -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Double -> OneOrTwo BCONPtr
double Platform
platform Double
d
                                 emit_ bci_TESTLT_D [Op np, LabelOp l]
  TESTEQ_D  Double
d LocalLabel
l            -> do np <- OneOrTwo BCONPtr -> m Word
forall (m :: * -> *).
MonadAssembler m =>
OneOrTwo BCONPtr -> m Word
lit (OneOrTwo BCONPtr -> m Word) -> OneOrTwo BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Platform -> Double -> OneOrTwo BCONPtr
double Platform
platform 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 FFIInfo
ffi Word16
i          -> do np <- BCONPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCONPtr -> m Word
lit1 (BCONPtr -> m Word) -> BCONPtr -> m Word
forall a b. (a -> b) -> a -> b
$ FFIInfo -> BCONPtr
BCONPtrFFIInfo FFIInfo
ffi
                                 emit_ bci_CCALL [wOp off, Op np, SmallOp i]
  BCInstr
PRIMCALL                 -> Word16 -> [Operand] -> m ()
emit_ bci_PRIMCALL []

  OP_ADD Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ADD_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ADD_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ADD_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ADD_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_SUB Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SUB_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SUB_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SUB_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SUB_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_AND Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_AND_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_AND_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_AND_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_AND_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_XOR Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_XOR_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_XOR_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_XOR_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_XOR_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_OR Width
w -> case Width
w of
    Width
W64                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_OR_64 []
    Width
W32                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_OR_32 []
    Width
W16                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_OR_16 []
    Width
W8                     -> Word16 -> [Operand] -> m ()
emit_ bci_OP_OR_08 []
    Width
_                      -> m ()
forall {a}. a
unsupported_width
  OP_NOT Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NOT_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NOT_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NOT_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NOT_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_NEG Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEG_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEG_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEG_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEG_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_MUL Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_MUL_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_MUL_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_MUL_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_MUL_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_SHL Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SHL_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SHL_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SHL_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_SHL_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_ASR Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ASR_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ASR_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ASR_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_ASR_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_LSR Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_LSR_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_LSR_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_LSR_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_LSR_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width

  OP_NEQ Width
w -> case Width
w of
    Width
W64                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEQ_64 []
    Width
W32                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEQ_32 []
    Width
W16                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEQ_16 []
    Width
W8                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_NEQ_08 []
    Width
_                     -> m ()
forall {a}. a
unsupported_width
  OP_EQ Width
w -> case Width
w of
    Width
W64                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_EQ_64 []
    Width
W32                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_EQ_32 []
    Width
W16                    -> Word16 -> [Operand] -> m ()
emit_ bci_OP_EQ_16 []
    Width
W8                     -> Word16 -> [Operand] -> m ()
emit_ bci_OP_EQ_08 []
    Width
_                      -> m ()
forall {a}. a
unsupported_width

  OP_U_LT Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LT_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LT_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LT_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LT_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_S_LT Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LT_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LT_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LT_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LT_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_U_GE Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GE_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GE_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GE_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GE_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_S_GE Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GE_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GE_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GE_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GE_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_U_GT Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GT_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GT_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GT_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_GT_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_S_GT Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GT_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GT_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GT_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_GT_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_U_LE Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LE_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LE_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LE_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_U_LE_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width
  OP_S_LE Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LE_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LE_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LE_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_S_LE_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width

  OP_INDEX_ADDR Width
w -> case Width
w of
    Width
W64                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_INDEX_ADDR_64 []
    Width
W32                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_INDEX_ADDR_32 []
    Width
W16                  -> Word16 -> [Operand] -> m ()
emit_ bci_OP_INDEX_ADDR_16 []
    Width
W8                   -> Word16 -> [Operand] -> m ()
emit_ bci_OP_INDEX_ADDR_08 []
    Width
_                    -> m ()
forall {a}. a
unsupported_width

  BRK_FUN ibi :: InternalBreakpointId
ibi@(InternalBreakpointId Module
info_mod Int
infox) -> do
    p1 <- BCOPtr -> m Word
forall (m :: * -> *). MonadAssembler m => BCOPtr -> m Word
ptr (BCOPtr -> m Word) -> BCOPtr -> m Word
forall a b. (a -> b) -> a -> b
$ Module -> BCOPtr
BCOPtrBreakArray Module
info_mod
    let -- cast that checks that round-tripping through Word32 doesn't change the value
        infoW32 = let r :: Word32
r = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
infox :: Word32
                   in if Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
infox
                    then Word32
r
                    else String -> SDoc -> Word32
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"schemeER_wrk: breakpoint tick/info index too large!" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
infox)
        ix_hi = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
infoW32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
        ix_lo = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
infoW32 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xffff)
    info_addr        <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod
    info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS     $ moduleUnitId info_mod
    np               <- lit1 $ BCONPtrCostCentre ibi
    emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr
                      , SmallOp ix_hi, SmallOp ix_lo, 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
    unsupported_width :: a
unsupported_width = String -> a
forall a. HasCallStack => String -> a
panic String
"GHC.ByteCode.Asm: Unsupported Width"
    emit_ :: Word16 -> [Operand] -> m ()
emit_ = PlatformWordSize -> Word16 -> [Operand] -> m ()
forall (m :: * -> *).
MonadAssembler m =>
PlatformWordSize -> Word16 -> [Operand] -> m ()
emit (Platform -> PlatformWordSize
platformWordSize Platform
platform)

literal :: Platform -> Literal -> OneOrTwo BCONPtr
literal :: Platform -> Literal -> OneOrTwo BCONPtr
literal Platform
platform = \case
  LitLabel FastString
fs FunctionOrData
_  -> BCONPtr -> OneOrTwo BCONPtr
forall a. a -> OneOrTwo a
OnlyOne (FastString -> BCONPtr
BCONPtrLbl FastString
fs)
  Literal
LitNullAddr    -> Word -> OneOrTwo BCONPtr
word Word
0
  LitFloating LitFloatingType
LitFloat  LitFloating
x -> Platform -> Float -> OneOrTwo BCONPtr
float Platform
platform (LitFloating -> Float
litFloatingToHostFloat LitFloating
x)
  LitFloating LitFloatingType
LitDouble LitFloating
x -> Platform -> Double -> OneOrTwo BCONPtr
double Platform
platform (LitFloating -> Double
litFloatingToHostDouble LitFloating
x)
  LitChar Char
c      -> Int -> OneOrTwo BCONPtr
int (Char -> Int
ord Char
c)
  LitString ByteString
bs   -> BCONPtr -> OneOrTwo BCONPtr
forall a. a -> OneOrTwo a
OnlyOne (ByteString -> BCONPtr
BCONPtrStr ByteString
bs)
   -- LitString requires a zero-terminator when emitted
  LitNumber LitNumType
nt Integer
i -> case LitNumType
nt of
    LitNumType
LitNumInt     -> Word -> OneOrTwo BCONPtr
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumWord    -> Word -> OneOrTwo BCONPtr
word (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumInt8    -> Platform -> Word8 -> OneOrTwo BCONPtr
word8  Platform
platform (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumWord8   -> Platform -> Word8 -> OneOrTwo BCONPtr
word8  Platform
platform (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumInt16   -> Platform -> Word16 -> OneOrTwo BCONPtr
word16 Platform
platform (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumWord16  -> Platform -> Word16 -> OneOrTwo BCONPtr
word16 Platform
platform (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumInt32   -> Platform -> Word32 -> OneOrTwo BCONPtr
word32 Platform
platform (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumWord32  -> Platform -> Word32 -> OneOrTwo BCONPtr
word32 Platform
platform (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumInt64   -> Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumWord64  -> Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
    LitNumType
LitNumBigNat  -> String -> OneOrTwo BCONPtr
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.
  LitRubbish {} -> Word -> OneOrTwo BCONPtr
word Word
0

words :: OneOrTwo Word -> OneOrTwo BCONPtr
words :: OneOrTwo Word -> OneOrTwo BCONPtr
words OneOrTwo Word
ws = (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
Word -> BCONPtr
BCONPtrWord OneOrTwo Word
ws

word :: Word -> OneOrTwo BCONPtr
word :: Word -> OneOrTwo BCONPtr
word Word
w = OneOrTwo Word -> OneOrTwo BCONPtr
words (Word -> OneOrTwo Word
forall a. a -> OneOrTwo a
OnlyOne Word
w)

word2 :: Word -> Word -> OneOrTwo BCONPtr
word2 :: Word -> Word -> OneOrTwo BCONPtr
word2 Word
w1 Word
w2 = OneOrTwo Word -> OneOrTwo BCONPtr
words (Word -> Word -> OneOrTwo Word
forall a. a -> a -> OneOrTwo a
OnlyTwo Word
w1 Word
w2)

-- 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 -> OneOrTwo BCONPtr
int :: Int -> OneOrTwo BCONPtr
int Int
i = Word -> OneOrTwo BCONPtr
word (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

float :: Platform -> Float -> OneOrTwo BCONPtr
float :: Platform -> Float -> OneOrTwo BCONPtr
float Platform
platform Float
f = Platform -> Word32 -> OneOrTwo BCONPtr
word32 Platform
platform (Float -> Word32
castFloatToWord32 Float
f)

double :: Platform -> Double -> OneOrTwo BCONPtr
double :: Platform -> Double -> OneOrTwo BCONPtr
double Platform
p Double
d = Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
p (Double -> Word64
castDoubleToWord64 Double
d)

word64 :: Platform -> Word64 -> OneOrTwo BCONPtr
word64 :: Platform -> Word64 -> OneOrTwo BCONPtr
word64 Platform
platform Word64
ww = case Platform -> PlatformWordSize
platformWordSize Platform
platform 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 -> OneOrTwo BCONPtr
word2 Word
wl Word
wh
        ByteOrder
BigEndian    -> Word -> Word -> OneOrTwo BCONPtr
word2 Word
wh Word
wl
   PlatformWordSize
PW8 -> Word -> OneOrTwo BCONPtr
word (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ww)

word8 :: Platform -> Word8 -> OneOrTwo BCONPtr
word8 :: Platform -> Word8 -> OneOrTwo BCONPtr
word8 Platform
platform Word8
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
  ByteOrder
LittleEndian -> Word -> OneOrTwo BCONPtr
word (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)
  ByteOrder
BigEndian    -> Word -> OneOrTwo BCONPtr
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` (Platform -> Int
platformWordSizeInBits Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8))

word16 :: Platform -> Word16 -> OneOrTwo BCONPtr
word16 :: Platform -> Word16 -> OneOrTwo BCONPtr
word16 Platform
platform Word16
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
  ByteOrder
LittleEndian -> Word -> OneOrTwo BCONPtr
word (Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x)
  ByteOrder
BigEndian    -> Word -> OneOrTwo BCONPtr
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` (Platform -> Int
platformWordSizeInBits Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16))

word32 :: Platform -> Word32 -> OneOrTwo BCONPtr
word32 :: Platform -> Word32 -> OneOrTwo BCONPtr
word32 Platform
platform Word32
x = case Platform -> ByteOrder
platformByteOrder Platform
platform of
  ByteOrder
LittleEndian -> Word -> OneOrTwo BCONPtr
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x)
  ByteOrder
BigEndian    -> case Platform -> PlatformWordSize
platformWordSize Platform
platform of
    PlatformWordSize
PW4 -> Word -> OneOrTwo BCONPtr
word (Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x)
    PlatformWordSize
PW8 -> Word -> OneOrTwo BCONPtr
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"

{-
  The maximum number of words that can be spilled on the stack for
  a tuple return. This is limited by the encoding of the stack
  spill size in the call_info word (used by stg_ret_t):

    - On 32-bit platforms: 8-bit  (bits 24-31), max 255
    - On 64-bit platforms: 40-bit (bits 24-63)

  The stg_ctoi_t frame itself has no size limit since it reads the
  spill count from the TSO's ctoi_tuple_spill_words field. See
  Note [GHCi unboxed tuples stack spills] in StgMiscClosures.cmm.

  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 :: Platform -> WordOff
maxTupleReturnNativeStackSize :: Platform -> WordOff
maxTupleReturnNativeStackSize Platform
platform = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
  PlatformWordSize
PW4 -> WordOff
255
  PlatformWordSize
PW8 -> WordOff
1099511627775

{-
  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 -> Word64
mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word64
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
> Platform -> WordOff
maxTupleReturnNativeStackSize Platform
platform
  = String -> SDoc -> Word64
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 -> Word64 -> Word64)
    -> Bool
    -> SDoc
    -> Word64
    -> Word64)
-> Bool
-> SDoc
-> (Bool -> SDoc -> Word64 -> Word64)
-> Bool
-> SDoc
-> Word64
-> Word64
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))

    -- continuation offset must fit in available bits above the bitmap
    Bool
-> SDoc
-> (Bool -> SDoc -> Word64 -> Word64)
-> Bool
-> SDoc
-> Word64
-> Word64
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Word64
cont_offset Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= WordOff -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Platform -> WordOff
maxTupleReturnNativeStackSize Platform
platform))
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"continuation offset too large:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Word64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word64
cont_offset)

    -- all regs accounted for
    Bool -> SDoc -> Word64 -> Word64
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
        ] ) (Word64 -> Word64) -> Word64 -> Word64
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.

    (Word64 -> (GlobalReg, Int) -> Word64)
-> Word64 -> [(GlobalReg, Int)] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word64 -> (GlobalReg, Int) -> Word64
reg_bit Word64
0 [(GlobalReg, Int)]
argRegs Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
cont_offset Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
  where
    cont_offset :: Word64
    cont_offset :: Word64
cont_offset
      | NativeCallType
nativeCallType NativeCallType -> NativeCallType -> Bool
forall a. Eq a => a -> a -> Bool
== NativeCallType
NativeTupleReturn = WordOff -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
nativeCallStackSpillSize
      | Bool
otherwise                           = Word64
0 -- there is no continuation for primcalls

    reg_bit :: Word64 -> (GlobalReg, Int) -> Word64
    reg_bit :: Word64 -> (GlobalReg, Int) -> Word64
reg_bit Word64
x (GlobalReg
r, Int
n)
      | GlobalReg
r GlobalReg -> GlobalRegSet -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` GlobalRegSet
nativeCallRegs = Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
n
      | Bool
otherwise                     = Word64
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) -> (Word64 -> Integer) -> Word64 -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Literal) -> Word64 -> Literal
forall a b. (a -> b) -> a -> b
$ Platform -> NativeCallInfo -> Word64
mkNativeCallInfoSig Platform
platform NativeCallInfo
call_info

iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH