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

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

#include "HsVersions.h"

import GHC.Prelude

import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter
import GHC.Runtime.Heap.Layout hiding ( WordOff )

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

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

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

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

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

import Data.Array.MArray

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

import Data.Array.Unsafe( castSTUArray )

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

      initial_offset :: Word
initial_offset = Word
0

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

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

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

  -- precomputed size should be equal to final size
  ASSERT(n_insns == sizeSS final_insns) return ()

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

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

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

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

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

data Operand
  = Op Word
  | SmallOp Word16
  | LabelOp LocalLabel
-- (unused)  | LargeOp Word

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

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

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

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

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

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

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

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

type LabelEnv = LocalLabel -> Word

largeOp :: Bool -> Operand -> Bool
largeOp :: Bool -> Operand -> Bool
largeOp Bool
long_jumps Operand
op = case Operand
op of
   SmallOp Word16
_ -> Bool
False
   Op Word
w      -> Word -> Bool
isLarge Word
w
   LabelOp LocalLabel
_ -> Bool
long_jumps
-- LargeOp _ -> True

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

type LabelEnvMap = Map LocalLabel Word

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

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

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

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

largeArg :: Platform -> Word -> [Word16]
largeArg :: Platform -> Word -> [Word16]
largeArg Platform
platform Word
w = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
   PlatformWordSize
PW8 -> [forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
48),
           forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
32),
           forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
           forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
   PlatformWordSize
PW4 -> [forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
           forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]

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

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

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

  SLIDE     Word16
n Word16
by           -> Word16 -> [Operand] -> Assembler ()
emit bci_SLIDE [SmallOp n, SmallOp by]
  ALLOC_AP  Word16
n              -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP [SmallOp n]
  ALLOC_AP_NOUPD Word16
n         -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP_NOUPD [SmallOp n]
  ALLOC_PAP Word16
arity Word16
n        -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
  MKAP      Word16
off Word16
sz         -> Word16 -> [Operand] -> Assembler ()
emit bci_MKAP [SmallOp off, SmallOp sz]
  MKPAP     Word16
off Word16
sz         -> Word16 -> [Operand] -> Assembler ()
emit bci_MKPAP [SmallOp off, SmallOp sz]
  UNPACK    Word16
n              -> Word16 -> [Operand] -> Assembler ()
emit bci_UNPACK [SmallOp n]
  PACK      DataCon
dcon Word16
sz        -> do Word
itbl_no <- [BCONPtr] -> Assembler Word
lit [Name -> BCONPtr
BCONPtrItbl (forall a. NamedThing a => a -> Name
getName DataCon
dcon)]
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PACK [Op itbl_no, SmallOp sz]
  LABEL     LocalLabel
lbl            -> LocalLabel -> Assembler ()
label LocalLabel
lbl
  TESTLT_I  Int
i LocalLabel
l            -> do Word
np <- Int -> Assembler Word
int Int
i
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_I [Op np, LabelOp l]
  TESTEQ_I  Int
i LocalLabel
l            -> do Word
np <- Int -> Assembler Word
int Int
i
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_I [Op np, LabelOp l]
  TESTLT_W  Word
w LocalLabel
l            -> do Word
np <- Word -> Assembler Word
word Word
w
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_W [Op np, LabelOp l]
  TESTEQ_W  Word
w LocalLabel
l            -> do Word
np <- Word -> Assembler Word
word Word
w
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_W [Op np, LabelOp l]
  TESTLT_F  Float
f LocalLabel
l            -> do Word
np <- Float -> Assembler Word
float Float
f
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_F [Op np, LabelOp l]
  TESTEQ_F  Float
f LocalLabel
l            -> do Word
np <- Float -> Assembler Word
float Float
f
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_F [Op np, LabelOp l]
  TESTLT_D  Double
d LocalLabel
l            -> do Word
np <- Double -> Assembler Word
double Double
d
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_D [Op np, LabelOp l]
  TESTEQ_D  Double
d LocalLabel
l            -> do Word
np <- Double -> Assembler Word
double Double
d
                                 Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_D [Op np, LabelOp l]
  TESTLT_P  Word16
i LocalLabel
l            -> Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_P [SmallOp i, LabelOp l]
  TESTEQ_P  Word16
i LocalLabel
l            -> Word16 -> [Operand] -> Assembler ()
emit bci_TESTEQ_P [SmallOp i, LabelOp l]
  BCInstr
CASEFAIL                 -> Word16 -> [Operand] -> Assembler ()
emit bci_CASEFAIL []
  SWIZZLE   Word16
stkoff Word16
n       -> Word16 -> [Operand] -> Assembler ()
emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
  JMP       LocalLabel
l              -> Word16 -> [Operand] -> Assembler ()
emit bci_JMP [LabelOp l]
  BCInstr
ENTER                    -> Word16 -> [Operand] -> Assembler ()
emit bci_ENTER []
  BCInstr
RETURN                   -> Word16 -> [Operand] -> Assembler ()
emit bci_RETURN []
  RETURN_UNLIFTED ArgRep
rep      -> Word16 -> [Operand] -> Assembler ()
emit (ArgRep -> Word16
return_unlifted ArgRep
rep) []
  BCInstr
RETURN_TUPLE             -> Word16 -> [Operand] -> Assembler ()
emit bci_RETURN_T []
  CCALL Word16
off RemotePtr C_ffi_cif
m_addr Word16
i       -> do Word
np <- forall {a}. RemotePtr a -> Assembler Word
addr RemotePtr C_ffi_cif
m_addr
                                 Word16 -> [Operand] -> Assembler ()
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
  BRK_FUN Word16
index Unique
uniq RemotePtr CostCentre
cc    -> do Word
p1 <- BCOPtr -> Assembler Word
ptr BCOPtr
BCOPtrBreakArray
                                 Word
q <- Int -> Assembler Word
int (Unique -> Int
getKey Unique
uniq)
                                 Word
np <- forall {a}. RemotePtr a -> Assembler Word
addr RemotePtr CostCentre
cc
                                 Word16 -> [Operand] -> Assembler ()
emit bci_BRK_FUN [Op p1, SmallOp index,
                                                   Op q, Op np]

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

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

    litlabel :: FastString -> Assembler Word
litlabel FastString
fs = [BCONPtr] -> Assembler Word
lit [FastString -> BCONPtr
BCONPtrLbl FastString
fs]
    addr :: RemotePtr a -> Assembler Word
addr (RemotePtr Word64
a) = [Word] -> Assembler Word
words [forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a]
    float :: Float -> Assembler Word
float = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> [Word]
mkLitF
    double :: Double -> Assembler Word
double = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Double -> [Word]
mkLitD Platform
platform
    int :: Int -> Assembler Word
int = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word]
mkLitI
    int8 :: Int64 -> Assembler Word
int8 = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
    int16 :: Int64 -> Assembler Word
int16 = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
    int32 :: Int64 -> Assembler Word
int32 = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
    int64 :: Int64 -> Assembler Word
int64 = [Word] -> Assembler Word
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Int64 -> [Word]
mkLitI64 Platform
platform
    words :: [Word] -> Assembler Word
words [Word]
ws = [BCONPtr] -> Assembler Word
lit (forall a b. (a -> b) -> [a] -> [b]
map Word -> BCONPtr
BCONPtrWord [Word]
ws)
    word :: Word -> Assembler Word
word Word
w = [Word] -> Assembler Word
words [Word
w]

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

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

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

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

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

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

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

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

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

mkTupleInfoLit :: Platform -> TupleInfo -> Literal
mkTupleInfoLit :: Platform -> TupleInfo -> Literal
mkTupleInfoLit Platform
platform TupleInfo
tuple_info =
  Platform -> Integer -> Literal
mkLitWord Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Platform -> TupleInfo -> Word32
mkTupleInfoSig Platform
platform TupleInfo
tuple_info

-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
mkLitI   ::             Int    -> [Word]
mkLitF   ::             Float  -> [Word]
mkLitD   :: Platform -> Double -> [Word]
mkLitI64 :: Platform -> Int64  -> [Word]

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

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

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

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

iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH