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

-- | ByteCodeLink: Bytecode assembler and linker
module ByteCodeAsm (
        assembleBCOs, assembleOneBCO,

        bcoFreeNames,
        SizedSeq, sizeSS, ssElts,
        iNTERP_STACK_CHECK_THRESH
  ) where

#include "HsVersions.h"

import GhcPrelude

import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
import GHCi.RemoteTypes
import GHCi

import HscTypes
import Name
import NameSet
import Literal
import TyCon
import FastString
import GHC.StgToCmm.Layout     ( ArgRep(..) )
import SMRep
import DynFlags
import Outputable
import GHC.Platform
import Util
import Unique
import UniqDSet

-- From iserv
import SizedSeq

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
import Data.Char        ( ord )
import Data.List        ( genericLength )
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map

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

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

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

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

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

-- Top level assembler fn.
assembleBCOs
  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
  -> Maybe ModBreaks
  -> IO CompiledByteCode
assembleBCOs :: HscEnv
-> [ProtoBCO Name]
-> [TyCon]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs HscEnv
hsc_env [ProtoBCO Name]
proto_bcos [TyCon]
tycons [RemotePtr ()]
top_strs Maybe ModBreaks
modbreaks = do
  ItblEnv
itblenv <- HscEnv -> [TyCon] -> IO ItblEnv
mkITbls HscEnv
hsc_env [TyCon]
tycons
  [UnlinkedBCO]
bcos    <- (ProtoBCO Name -> IO UnlinkedBCO)
-> [ProtoBCO Name] -> IO [UnlinkedBCO]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) [ProtoBCO Name]
proto_bcos
  ([UnlinkedBCO]
bcos',[RemotePtr ()]
ptrs) <- HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings HscEnv
hsc_env [UnlinkedBCO]
bcos
  CompiledByteCode -> IO CompiledByteCode
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledByteCode :: [UnlinkedBCO]
-> ItblEnv
-> [FFIInfo]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> CompiledByteCode
CompiledByteCode
    { bc_bcos :: [UnlinkedBCO]
bc_bcos = [UnlinkedBCO]
bcos'
    , bc_itbls :: ItblEnv
bc_itbls =  ItblEnv
itblenv
    , bc_ffis :: [FFIInfo]
bc_ffis = [[FFIInfo]] -> [FFIInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ProtoBCO Name -> [FFIInfo]) -> [ProtoBCO Name] -> [[FFIInfo]]
forall a b. (a -> b) -> [a] -> [b]
map ProtoBCO Name -> [FFIInfo]
forall a. ProtoBCO a -> [FFIInfo]
protoBCOFFIs [ProtoBCO Name]
proto_bcos)
    , bc_strs :: [RemotePtr ()]
bc_strs = [RemotePtr ()]
top_strs [RemotePtr ()] -> [RemotePtr ()] -> [RemotePtr ()]
forall a. [a] -> [a] -> [a]
++ [RemotePtr ()]
ptrs
    , bc_breaks :: Maybe ModBreaks
bc_breaks = Maybe ModBreaks
modbreaks
    }

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

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

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

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

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

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


assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO HscEnv
hsc_env ProtoBCO Name
pbco = do
  UnlinkedBCO
ubco <- DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ProtoBCO Name
pbco
  ([UnlinkedBCO
ubco'], [RemotePtr ()]
_ptrs) <- HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings HscEnv
hsc_env [UnlinkedBCO
ubco]
  UnlinkedBCO -> IO UnlinkedBCO
forall (m :: * -> *) a. Monad m => a -> m a
return UnlinkedBCO
ubco'

assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO DynFlags
dflags (ProtoBCO { protoBCOName :: forall a. ProtoBCO a -> a
protoBCOName       = Name
nm
                             , protoBCOInstrs :: forall a. ProtoBCO a -> [BCInstr]
protoBCOInstrs     = [BCInstr]
instrs
                             , protoBCOBitmap :: forall a. ProtoBCO a -> [StgWord]
protoBCOBitmap     = [StgWord]
bitmap
                             , protoBCOBitmapSize :: forall a. ProtoBCO a -> Word16
protoBCOBitmapSize = Word16
bsize
                             , protoBCOArity :: forall a. ProtoBCO a -> Int
protoBCOArity      = Int
arity }) = do
  -- pass 1: collect up the offsets of the local labels.
  let asm :: Assembler ()
asm = (BCInstr -> Assembler ()) -> [BCInstr] -> Assembler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> BCInstr -> Assembler ()
assembleI DynFlags
dflags) [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) = DynFlags -> Bool -> Word -> Assembler () -> (Word, LabelEnvMap)
forall a.
DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm DynFlags
dflags Bool
False Word
initial_offset Assembler ()
asm
      ((Word
n_insns, LabelEnvMap
lbl_map), Bool
long_jumps)
        | Word -> Bool
isLarge Word
n_insns0 = (DynFlags -> Bool -> Word -> Assembler () -> (Word, LabelEnvMap)
forall a.
DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm DynFlags
dflags Bool
True Word
initial_offset Assembler ()
asm, Bool
True)
        | Bool
otherwise = ((Word
n_insns0, LabelEnvMap
lbl_map0), Bool
False)

      env :: Word16 -> Word
      env :: Word16 -> Word
env Word16
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" (Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lbl))
        (Word16 -> LabelEnvMap -> Maybe Word
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word16
lbl LabelEnvMap
lbl_map)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

type LabelEnv = Word16 -> 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 Word16
_ -> Bool
long_jumps
-- LargeOp _ -> True

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

type LabelEnvMap = Map Word16 Word

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

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

-- 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 :: DynFlags -> Word -> [Word16]
largeArg :: DynFlags -> Word -> [Word16]
largeArg DynFlags
dflags Word
w
 | DynFlags -> Int
wORD_SIZE_IN_BITS DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64
           = [Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
48),
              Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
32),
              Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
              Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
 | DynFlags -> Int
wORD_SIZE_IN_BITS DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32
           = [Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
w Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
              Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w]
 | Bool
otherwise = String -> [Word16]
forall a. HasCallStack => String -> a
error String
"wORD_SIZE_IN_BITS not 32 or 64?"

largeArg16s :: DynFlags -> Word
largeArg16s :: DynFlags -> Word
largeArg16s DynFlags
dflags | DynFlags -> Int
wORD_SIZE_IN_BITS DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64 = Word
4
                   | Bool
otherwise                      = Word
2

assembleI :: DynFlags
          -> BCInstr
          -> Assembler ()
assembleI :: DynFlags -> BCInstr -> Assembler ()
assembleI DynFlags
dflags 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 = DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO DynFlags
dflags ProtoBCO Name
proto
                                 Word
p <- IO BCOPtr -> Assembler Word
ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_G [Op p]
  PUSH_ALTS ProtoBCO Name
proto          -> do let ul_bco :: IO UnlinkedBCO
ul_bco = DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO DynFlags
dflags ProtoBCO Name
proto
                                 Word
p <- IO BCOPtr -> Assembler Word
ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_ALTS [Op p]
  PUSH_ALTS_UNLIFTED ProtoBCO Name
proto ArgRep
pk
                           -> do let ul_bco :: IO UnlinkedBCO
ul_bco = DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO DynFlags
dflags ProtoBCO Name
proto
                                 Word
p <- IO BCOPtr -> Assembler Word
ioptr ((UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM UnlinkedBCO -> BCOPtr
BCOPtrBCO IO UnlinkedBCO
ul_bco)
                                 Word16 -> [Operand] -> Assembler ()
emit (ArgRep -> Word16
push_alts ArgRep
pk) [Word -> Operand
Op Word
p]
  BCInstr
PUSH_PAD8                -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_PAD8 []
  BCInstr
PUSH_PAD16               -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_PAD16 []
  BCInstr
PUSH_PAD32               -> Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_PAD32 []
  PUSH_UBX8 Literal
lit            -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX8 [Op np]
  PUSH_UBX16 Literal
lit           -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX16 [Op np]
  PUSH_UBX32 Literal
lit           -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX32 [Op np]
  PUSH_UBX Literal
lit Word16
nws         -> do Word
np <- Literal -> Assembler Word
literal Literal
lit
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PUSH_UBX [Op np, SmallOp nws]

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

  SLIDE     Word16
n Word16
by           -> Word16 -> [Operand] -> Assembler ()
emit bci_SLIDE [SmallOp n, SmallOp by]
  ALLOC_AP  Word16
n              -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP [SmallOp n]
  ALLOC_AP_NOUPD Word16
n         -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_AP_NOUPD [SmallOp n]
  ALLOC_PAP Word16
arity Word16
n        -> Word16 -> [Operand] -> Assembler ()
emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
  MKAP      Word16
off Word16
sz         -> Word16 -> [Operand] -> Assembler ()
emit bci_MKAP [SmallOp off, SmallOp sz]
  MKPAP     Word16
off Word16
sz         -> Word16 -> [Operand] -> Assembler ()
emit bci_MKPAP [SmallOp off, SmallOp sz]
  UNPACK    Word16
n              -> Word16 -> [Operand] -> Assembler ()
emit bci_UNPACK [SmallOp n]
  PACK      DataCon
dcon Word16
sz        -> do Word
itbl_no <- [BCONPtr] -> Assembler Word
lit [Name -> BCONPtr
BCONPtrItbl (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dcon)]
                                 Word16 -> [Operand] -> Assembler ()
emit bci_PACK [Op itbl_no, SmallOp sz]
  LABEL     Word16
lbl            -> Word16 -> Assembler ()
label Word16
lbl
  TESTLT_I  Int
i Word16
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 Word16
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 Word16
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 Word16
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 Word16
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 Word16
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 Word16
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 Word16
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 Word16
l            -> Word16 -> [Operand] -> Assembler ()
emit bci_TESTLT_P [SmallOp i, LabelOp l]
  TESTEQ_P  Word16
i Word16
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       Word16
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_UBX ArgRep
rep           -> Word16 -> [Operand] -> Assembler ()
emit (ArgRep -> Word16
return_ubx ArgRep
rep) []
  CCALL Word16
off RemotePtr C_ffi_cif
m_addr Word16
i       -> do Word
np <- RemotePtr C_ffi_cif -> Assembler Word
forall a. RemotePtr a -> Assembler Word
addr RemotePtr C_ffi_cif
m_addr
                                 Word16 -> [Operand] -> Assembler ()
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
  BRK_FUN Word16
index Unique
uniq RemotePtr CostCentre
cc    -> do Word
p1 <- BCOPtr -> Assembler Word
ptr BCOPtr
BCOPtrBreakArray
                                 Word
q <- Int -> Assembler Word
int (Unique -> Int
getKey Unique
uniq)
                                 Word
np <- RemotePtr CostCentre -> Assembler Word
forall a. RemotePtr a -> Assembler Word
addr RemotePtr CostCentre
cc
                                 Word16 -> [Operand] -> Assembler ()
emit bci_BRK_FUN [Op p1, SmallOp index,
                                                   Op q, Op np]

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

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

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

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

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

-- 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   :: DynFlags -> Double -> [Word]
mkLitI64 :: DynFlags -> Int64  -> [Word]

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

mkLitD :: DynFlags -> Double -> [Word]
mkLitD DynFlags
dflags Double
d
   | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
   = (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Double
arr <- (Int, Int) -> ST s (STUArray s Int Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
        STUArray s Int Double -> Int -> Double -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Double
arr Int
0 Double
d
        STUArray s Int Word
d_arr <- STUArray s Int Double -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Double
arr
        Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
        Word
w1 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
1
        [Word] -> ST s [Word]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word, Word
w1]
     )
   | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8
   = (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Double
arr <- (Int, Int) -> ST s (STUArray s Int Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
        STUArray s Int Double -> Int -> Double -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Double
arr Int
0 Double
d
        STUArray s Int Word
d_arr <- STUArray s Int Double -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Double
arr
        Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
        [Word] -> ST s [Word]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word]
     )
   | Bool
otherwise
   = String -> [Word]
forall a. String -> a
panic String
"mkLitD: Bad wORD_SIZE"

mkLitI64 :: DynFlags -> Int64 -> [Word]
mkLitI64 DynFlags
dflags Int64
ii
   | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
   = (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Int64
arr <- (Int, Int) -> ST s (STUArray s Int Int64)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
        STUArray s Int Int64 -> Int -> Int64 -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int64
arr Int
0 Int64
ii
        STUArray s Int Word
d_arr <- STUArray s Int Int64 -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Int64
arr
        Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
        Word
w1 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
1
        [Word] -> ST s [Word]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word,Word
w1]
     )
   | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8
   = (forall s. ST s [Word]) -> [Word]
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Int64
arr <- (Int, Int) -> ST s (STUArray s Int Int64)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
        STUArray s Int Int64 -> Int -> Int64 -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int64
arr Int
0 Int64
ii
        STUArray s Int Word
d_arr <- STUArray s Int Int64 -> ST s (STUArray s Int Word)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int Int64
arr
        Word
w0 <- STUArray s Int Word -> Int -> ST s Word
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word
d_arr Int
0
        [Word] -> ST s [Word]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word
w0 :: Word]
     )
   | Bool
otherwise
   = String -> [Word]
forall a. String -> a
panic String
"mkLitI64: Bad wORD_SIZE"

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

iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH