-----------------------------------------------------------------------------
--
-- Code generation for foreign calls.
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module StgCmmForeign (
  cgForeignCall,
  emitPrimCall, emitCCall,
  emitForeignCall,     -- For CmmParse
  emitSaveThreadState,
  saveThreadState,
  emitLoadThreadState,
  loadThreadState,
  emitOpenNursery,
  emitCloseNursery,
 ) where

import GhcPrelude hiding( succ, (<*>) )

import StgSyn
import StgCmmProf (storeCurCCS, ccsType)
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
import StgCmmLayout

import BlockId (newBlockId)
import Cmm
import CmmUtils
import MkGraph
import Type
import RepType
import TysPrim
import CLabel
import SMRep
import ForeignCall
import DynFlags
import Maybes
import Outputable
import UniqSupply
import BasicTypes

import Control.Monad

-----------------------------------------------------------------------------
-- Code generation for Foreign Calls
-----------------------------------------------------------------------------

-- | emit code for a foreign call, and return the results to the sequel.
--
cgForeignCall :: ForeignCall            -- the op
              -> [StgArg]               -- x,y    arguments
              -> Type                   -- result type
              -> FCode ReturnKind

cgForeignCall :: ForeignCall -> [StgArg] -> Type -> FCode ReturnKind
cgForeignCall (CCall (CCallSpec target :: CCallTarget
target cconv :: CCallConv
cconv safety :: Safety
safety)) stg_args :: [StgArg]
stg_args res_ty :: Type
res_ty
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let -- in the stdcall calling convention, the symbol needs @size appended
              -- to it, where size is the total number of bytes of arguments.  We
              -- attach this info to the CLabel here, and the CLabel pretty printer
              -- will generate the suffix when the label is printed.
            call_size :: [(CmmExpr, b)] -> Maybe Int
call_size args :: [(CmmExpr, b)]
args
              | CCallConv
StdCallConv <- CCallConv
cconv = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((CmmExpr, b) -> Int) -> [(CmmExpr, b)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (CmmExpr, b) -> Int
forall b. (CmmExpr, b) -> Int
arg_size [(CmmExpr, b)]
args))
              | Bool
otherwise            = Maybe Int
forall a. Maybe a
Nothing

              -- ToDo: this might not be correct for 64-bit API
            arg_size :: (CmmExpr, b) -> Int
arg_size (arg :: CmmExpr
arg, _) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Width -> Int
widthInBytes (Width -> Int) -> Width -> Int
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
arg)
                                     (DynFlags -> Int
wORD_SIZE DynFlags
dflags)
        ; [(CmmExpr, ForeignHint)]
cmm_args <- [StgArg] -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs [StgArg]
stg_args
        ; (res_regs :: [LocalReg]
res_regs, res_hints :: [ForeignHint]
res_hints) <- Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs Type
res_ty
        ; let ((call_args :: [CmmExpr]
call_args, arg_hints :: [ForeignHint]
arg_hints), cmm_target :: CmmExpr
cmm_target)
                = case CCallTarget
target of
                   StaticTarget _ _   _      False ->
                       String -> (([CmmExpr], [ForeignHint]), CmmExpr)
forall a. String -> a
panic "cgForeignCall: unexpected FFI value import"
                   StaticTarget _ lbl :: CLabelString
lbl mPkgId :: Maybe UnitId
mPkgId True
                     -> let labelSource :: ForeignLabelSource
labelSource
                                = case Maybe UnitId
mPkgId of
                                        Nothing         -> ForeignLabelSource
ForeignLabelInThisPackage
                                        Just pkgId :: UnitId
pkgId      -> UnitId -> ForeignLabelSource
ForeignLabelInPackage UnitId
pkgId
                            size :: Maybe Int
size = [(CmmExpr, ForeignHint)] -> Maybe Int
forall b. [(CmmExpr, b)] -> Maybe Int
call_size [(CmmExpr, ForeignHint)]
cmm_args
                        in  ( [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
cmm_args
                            , CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel
                                        (CLabelString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel CLabelString
lbl Maybe Int
size ForeignLabelSource
labelSource FunctionOrData
IsFunction)))

                   DynamicTarget    ->  case [(CmmExpr, ForeignHint)]
cmm_args of
                                           (fn :: CmmExpr
fn,_):rest :: [(CmmExpr, ForeignHint)]
rest -> ([(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
rest, CmmExpr
fn)
                                           [] -> String -> (([CmmExpr], [ForeignHint]), CmmExpr)
forall a. String -> a
panic "cgForeignCall []"
              fc :: ForeignConvention
fc = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
cconv [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
CmmMayReturn
              call_target :: ForeignTarget
call_target = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
cmm_target ForeignConvention
fc

        -- we want to emit code for the call, and then emitReturn.
        -- However, if the sequel is AssignTo, we shortcut a little
        -- and generate a foreign call that assigns the results
        -- directly.  Otherwise we end up generating a bunch of
        -- useless "r = r" assignments, which are not merely annoying:
        -- they prevent the common block elimination from working correctly
        -- in the case of a safe foreign call.
        -- See Note [safe foreign call convention]
        --
        ; Sequel
sequel <- FCode Sequel
getSequel
        ; case Sequel
sequel of
            AssignTo assign_to_these :: [LocalReg]
assign_to_these _ ->
                Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
safety [LocalReg]
assign_to_these ForeignTarget
call_target [CmmExpr]
call_args

            _something_else :: Sequel
_something_else ->
                do { ReturnKind
_ <- Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
safety [LocalReg]
res_regs ForeignTarget
call_target [CmmExpr]
call_args
                   ; [CmmExpr] -> FCode ReturnKind
emitReturn ((LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
res_regs)
                   }
         }

{- Note [safe foreign call convention]

The simple thing to do for a safe foreign call would be the same as an
unsafe one: just

    emitForeignCall ...
    emitReturn ...

but consider what happens in this case

   case foo x y z of
     (# s, r #) -> ...

The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]
as the result reg, and we generate

  r = foo(x,y,z) returns to L1  -- emitForeignCall
 L1:
  r = r  -- emitReturn
  goto L2
L2:
  ...

Now L1 is a proc point (by definition, it is the continuation of the
safe foreign call).  If L2 does a heap check, then L2 will also be a
proc point.

Furthermore, the stack layout algorithm has to arrange to save r
somewhere between the call and the jump to L1, which is annoying: we
would have to treat r differently from the other live variables, which
have to be saved *before* the call.

So we adopt a special convention for safe foreign calls: the results
are copied out according to the NativeReturn convention by the call,
and the continuation of the call should copyIn the results.  (The
copyOut code is actually inserted when the safe foreign call is
lowered later).  The result regs attached to the safe foreign call are
only used temporarily to hold the results before they are copied out.

We will now generate this:

  r = foo(x,y,z) returns to L1
 L1:
  r = R1  -- copyIn, inserted by mkSafeCall
  goto L2
 L2:
  ... r ...

And when the safe foreign call is lowered later (see Note [lower safe
foreign calls]) we get this:

  suspendThread()
  r = foo(x,y,z)
  resumeThread()
  R1 = r  -- copyOut, inserted by lowerSafeForeignCall
  jump L1
 L1:
  r = R1  -- copyIn, inserted by mkSafeCall
  goto L2
 L2:
  ... r ...

Now consider what happens if L2 does a heap check: the Adams
optimisation kicks in and commons up L1 with the heap-check
continuation, resulting in just one proc point instead of two. Yay!
-}


emitCCall :: [(CmmFormal,ForeignHint)]
          -> CmmExpr
          -> [(CmmActual,ForeignHint)]
          -> FCode ()
emitCCall :: [(LocalReg, ForeignHint)]
-> CmmExpr -> [(CmmExpr, ForeignHint)] -> FCode ()
emitCCall hinted_results :: [(LocalReg, ForeignHint)]
hinted_results fn :: CmmExpr
fn hinted_args :: [(CmmExpr, ForeignHint)]
hinted_args
  = FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
PlayRisky [LocalReg]
results ForeignTarget
target [CmmExpr]
args
  where
    (args :: [CmmExpr]
args, arg_hints :: [ForeignHint]
arg_hints) = [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
hinted_args
    (results :: [LocalReg]
results, result_hints :: [ForeignHint]
result_hints) = [(LocalReg, ForeignHint)] -> ([LocalReg], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LocalReg, ForeignHint)]
hinted_results
    target :: ForeignTarget
target = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
fn ForeignConvention
fc
    fc :: ForeignConvention
fc = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint]
arg_hints [ForeignHint]
result_hints CmmReturnInfo
CmmMayReturn


emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
emitPrimCall :: [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall res :: [LocalReg]
res op :: CallishMachOp
op args :: [CmmExpr]
args
  = FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
PlayRisky [LocalReg]
res (CallishMachOp -> ForeignTarget
PrimTarget CallishMachOp
op) [CmmExpr]
args

-- alternative entry point, used by CmmParse
emitForeignCall
        :: Safety
        -> [CmmFormal]          -- where to put the results
        -> ForeignTarget        -- the op
        -> [CmmActual]          -- arguments
        -> FCode ReturnKind
emitForeignCall :: Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall safety :: Safety
safety results :: [LocalReg]
results target :: ForeignTarget
target args :: [CmmExpr]
args
  | Bool -> Bool
not (Safety -> Bool
playSafe Safety
safety) = do
    DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let (caller_save :: CmmAGraph
caller_save, caller_load :: CmmAGraph
caller_load) = DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags
    CmmAGraph -> FCode ()
emit CmmAGraph
caller_save
    ForeignTarget
target' <- ForeignTarget -> FCode ForeignTarget
load_target_into_temp ForeignTarget
target
    [CmmExpr]
args' <- (CmmExpr -> FCode CmmExpr) -> [CmmExpr] -> FCode [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> FCode CmmExpr
maybe_assign_temp [CmmExpr]
args
    CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
target' [LocalReg]
results [CmmExpr]
args'
    CmmAGraph -> FCode ()
emit CmmAGraph
caller_load
    ReturnKind -> FCode ReturnKind
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly

  | Bool
otherwise = do
    DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Int
updfr_off <- FCode Int
getUpdFrameOff
    ForeignTarget
target' <- ForeignTarget -> FCode ForeignTarget
load_target_into_temp ForeignTarget
target
    [CmmExpr]
args' <- (CmmExpr -> FCode CmmExpr) -> [CmmExpr] -> FCode [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> FCode CmmExpr
maybe_assign_temp [CmmExpr]
args
    BlockId
k <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
    let (off :: Int
off, _, copyout :: CmmAGraph
copyout) = DynFlags
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
NativeReturn (BlockId -> Area
Young BlockId
k) [LocalReg]
results []
       -- see Note [safe foreign call convention]
    CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
    CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$
           (    CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Area -> Int -> CmmExpr
CmmStackSlot (BlockId -> Area
Young BlockId
k) (Width -> Int
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)))
                        (CmmLit -> CmmExpr
CmmLit (BlockId -> CmmLit
CmmBlock BlockId
k))
            CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmNode O C -> CmmAGraph
mkLast ($WCmmForeignCall :: ForeignTarget
-> [LocalReg]
-> [CmmExpr]
-> BlockId
-> Int
-> Int
-> Bool
-> CmmNode O C
CmmForeignCall { tgt :: ForeignTarget
tgt  = ForeignTarget
target'
                                       , res :: [LocalReg]
res  = [LocalReg]
results
                                       , args :: [CmmExpr]
args = [CmmExpr]
args'
                                       , succ :: BlockId
succ = BlockId
k
                                       , ret_args :: Int
ret_args = Int
off
                                       , ret_off :: Int
ret_off = Int
updfr_off
                                       , intrbl :: Bool
intrbl = Safety -> Bool
playInterruptible Safety
safety })
            CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
k CmmTickScope
tscope
            CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
copyout
           )
    ReturnKind -> FCode ReturnKind
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> Int -> ReturnKind
ReturnedTo BlockId
k Int
off)

load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
load_target_into_temp (ForeignTarget expr :: CmmExpr
expr conv :: ForeignConvention
conv) = do
  CmmExpr
tmp <- CmmExpr -> FCode CmmExpr
maybe_assign_temp CmmExpr
expr
  ForeignTarget -> FCode ForeignTarget
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
tmp ForeignConvention
conv)
load_target_into_temp other_target :: ForeignTarget
other_target@(PrimTarget _) =
  ForeignTarget -> FCode ForeignTarget
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignTarget
other_target

-- What we want to do here is create a new temporary for the foreign
-- call argument if it is not safe to use the expression directly,
-- because the expression mentions caller-saves GlobalRegs (see
-- Note [Register Parameter Passing]).
--
-- However, we can't pattern-match on the expression here, because
-- this is used in a loop by CmmParse, and testing the expression
-- results in a black hole.  So we always create a temporary, and rely
-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code
-- ends up being the same, at least for the RTS .cmm code.
--
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp e :: CmmExpr
e = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  LocalReg
reg <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
e)
  CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
e
  CmmExpr -> FCode CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
reg))

-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO

-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.

emitSaveThreadState :: FCode ()
emitSaveThreadState :: FCode ()
emitSaveThreadState = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmAGraph
code <- DynFlags -> FCode CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState DynFlags
dflags
  CmmAGraph -> FCode ()
emit CmmAGraph
code

-- | Produce code to save the current thread state to @CurrentTSO@
saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState :: DynFlags -> m CmmAGraph
saveThreadState dflags :: DynFlags
dflags = do
  LocalReg
tso <- CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
  CmmAGraph
close_nursery <- DynFlags -> LocalReg -> m CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
closeNursery DynFlags
dflags LocalReg
tso
  CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
    -- tso = CurrentTSO;
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr,
    -- tso->stackobj->sp = Sp;
    CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags
                       (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags
                                           (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso))
                                           (DynFlags -> Int
tso_stackobj DynFlags
dflags))
                                (DynFlags -> CmmType
bWord DynFlags
dflags))
                       (DynFlags -> Int
stack_SP DynFlags
dflags))
            CmmExpr
spExpr,
    CmmAGraph
close_nursery,
    -- and save the current cost centre stack in the TSO when profiling:
    if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags then
        CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso)) (DynFlags -> Int
tso_CCCS DynFlags
dflags)) CmmExpr
cccsExpr
      else CmmAGraph
mkNop
    ]

emitCloseNursery :: FCode ()
emitCloseNursery :: FCode ()
emitCloseNursery = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  LocalReg
tso <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
  CmmAGraph
code <- DynFlags -> LocalReg -> FCode CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
closeNursery DynFlags
dflags LocalReg
tso
  CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
code

{- |
@closeNursery dflags tso@ produces code to close the nursery.
A local register holding the value of @CurrentTSO@ is expected for
efficiency.

Closing the nursery corresponds to the following code:

@
  tso = CurrentTSO;
  cn = CurrentNuresry;

  // Update the allocation limit for the current thread.  We don't
  // check to see whether it has overflowed at this point, that check is
  // made when we run out of space in the current heap block (stg_gc_noregs)
  // and in the scheduler when context switching (schedulePostRunThread).
  tso->alloc_limit -= Hp + WDS(1) - cn->start;

  // Set cn->free to the next unoccupied word in the block
  cn->free = Hp + WDS(1);
@
-}
closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
closeNursery :: DynFlags -> LocalReg -> m CmmAGraph
closeNursery df :: DynFlags
df tso :: LocalReg
tso = do
  let tsoreg :: CmmReg
tsoreg  = LocalReg -> CmmReg
CmmLocal LocalReg
tso
  CmmReg
cnreg      <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
  CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
cnreg CmmExpr
currentNurseryExpr,

    -- CurrentNursery->free = Hp+1;
    CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free DynFlags
df CmmReg
cnreg) (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
df CmmExpr
hpExpr 1),

    let alloc :: CmmExpr
alloc =
           MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
df)
              [ DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
df CmmExpr
hpExpr 1
              , CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start DynFlags
df CmmReg
cnreg) (DynFlags -> CmmType
bWord DynFlags
df)
              ]

        alloc_limit :: CmmExpr
alloc_limit = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
df (CmmReg -> CmmExpr
CmmReg CmmReg
tsoreg) (DynFlags -> Int
tso_alloc_limit DynFlags
df)
    in

    -- tso->alloc_limit += alloc
    CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
alloc_limit (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub Width
W64)
                               [ CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
alloc_limit CmmType
b64
                               , MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_WordTo64 DynFlags
df) [CmmExpr
alloc] ])
   ]

emitLoadThreadState :: FCode ()
emitLoadThreadState :: FCode ()
emitLoadThreadState = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmAGraph
code <- DynFlags -> FCode CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState DynFlags
dflags
  CmmAGraph -> FCode ()
emit CmmAGraph
code

-- | Produce code to load the current thread state from @CurrentTSO@
loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState :: DynFlags -> m CmmAGraph
loadThreadState dflags :: DynFlags
dflags = do
  LocalReg
tso <- CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
  LocalReg
stack <- CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
  CmmAGraph
open_nursery <- DynFlags -> LocalReg -> m CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
openNursery DynFlags
dflags LocalReg
tso
  CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
    -- tso = CurrentTSO;
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr,
    -- stack = tso->stackobj;
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
stack) (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso)) (DynFlags -> Int
tso_stackobj DynFlags
dflags)) (DynFlags -> CmmType
bWord DynFlags
dflags)),
    -- Sp = stack->sp;
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
spReg (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
stack)) (DynFlags -> Int
stack_SP DynFlags
dflags)) (DynFlags -> CmmType
bWord DynFlags
dflags)),
    -- SpLim = stack->stack + RESERVED_STACK_WORDS;
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
spLimReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
stack)) (DynFlags -> Int
stack_STACK DynFlags
dflags))
                                (DynFlags -> Int
rESERVED_STACK_WORDS DynFlags
dflags)),
    -- HpAlloc = 0;
    --   HpAlloc is assumed to be set to non-zero only by a failed
    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
    CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpAllocReg (DynFlags -> CmmExpr
zeroExpr DynFlags
dflags),
    CmmAGraph
open_nursery,
    -- and load the current cost centre stack from the TSO when profiling:
    if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
       then CmmExpr -> CmmAGraph
storeCurCCS
              (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso))
                 (DynFlags -> Int
tso_CCCS DynFlags
dflags)) (DynFlags -> CmmType
ccsType DynFlags
dflags))
       else CmmAGraph
mkNop
   ]


emitOpenNursery :: FCode ()
emitOpenNursery :: FCode ()
emitOpenNursery = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  LocalReg
tso <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
  CmmAGraph
code <- DynFlags -> LocalReg -> FCode CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
openNursery DynFlags
dflags LocalReg
tso
  CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
code

{- |
@openNursery dflags tso@ produces code to open the nursery. A local register
holding the value of @CurrentTSO@ is expected for efficiency.

Opening the nursery corresponds to the following code:

@
   tso = CurrentTSO;
   cn = CurrentNursery;
   bdfree = CurrentNursery->free;
   bdstart = CurrentNursery->start;

   // We *add* the currently occupied portion of the nursery block to
   // the allocation limit, because we will subtract it again in
   // closeNursery.
   tso->alloc_limit += bdfree - bdstart;

   // Set Hp to the last occupied word of the heap block.  Why not the
   // next unocupied word?  Doing it this way means that we get to use
   // an offset of zero more often, which might lead to slightly smaller
   // code on some architectures.
   Hp = bdfree - WDS(1);

   // Set HpLim to the end of the current nursery block (note that this block
   // might be a block group, consisting of several adjacent blocks.
   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
@
-}
openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
openNursery :: DynFlags -> LocalReg -> m CmmAGraph
openNursery df :: DynFlags
df tso :: LocalReg
tso = do
  let tsoreg :: CmmReg
tsoreg =  LocalReg -> CmmReg
CmmLocal LocalReg
tso
  CmmReg
cnreg      <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
  CmmReg
bdfreereg  <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
  CmmReg
bdstartreg <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)

  -- These assignments are carefully ordered to reduce register
  -- pressure and generate not completely awful code on x86.  To see
  -- what code we generate, look at the assembly for
  -- stg_returnToStackTop in rts/StgStartup.cmm.
  CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
     CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
cnreg CmmExpr
currentNurseryExpr,
     CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
bdfreereg  (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free DynFlags
df CmmReg
cnreg)  (DynFlags -> CmmType
bWord DynFlags
df)),

     -- Hp = CurrentNursery->free - 1;
     CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
df (CmmReg -> CmmExpr
CmmReg CmmReg
bdfreereg) (-1)),

     CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
bdstartreg (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start DynFlags
df CmmReg
cnreg) (DynFlags -> CmmType
bWord DynFlags
df)),

     -- HpLim = CurrentNursery->start +
     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
     CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpLimReg
         (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExpr DynFlags
df
             (CmmReg -> CmmExpr
CmmReg CmmReg
bdstartreg)
             (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
df
               (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordMul DynFlags
df) [
                 MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_SS_Conv Width
W32 (DynFlags -> Width
wordWidth DynFlags
df))
                   [CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_blocks DynFlags
df CmmReg
cnreg) CmmType
b32],
                 DynFlags -> Int -> CmmExpr
mkIntExpr DynFlags
df (DynFlags -> Int
bLOCK_SIZE DynFlags
df)
                ])
               (-1)
             )
         ),

     -- alloc = bd->free - bd->start
     let alloc :: CmmExpr
alloc =
           MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
df) [CmmReg -> CmmExpr
CmmReg CmmReg
bdfreereg, CmmReg -> CmmExpr
CmmReg CmmReg
bdstartreg]

         alloc_limit :: CmmExpr
alloc_limit = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
df (CmmReg -> CmmExpr
CmmReg CmmReg
tsoreg) (DynFlags -> Int
tso_alloc_limit DynFlags
df)
     in

     -- tso->alloc_limit += alloc
     CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
alloc_limit (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
W64)
                               [ CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
alloc_limit CmmType
b64
                               , MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_WordTo64 DynFlags
df) [CmmExpr
alloc] ])

   ]

nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
  :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free   dflags :: DynFlags
dflags cn :: CmmReg
cn =
  DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (DynFlags -> Int
oFFSET_bdescr_free DynFlags
dflags)
nursery_bdescr_start :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start  dflags :: DynFlags
dflags cn :: CmmReg
cn =
  DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (DynFlags -> Int
oFFSET_bdescr_start DynFlags
dflags)
nursery_bdescr_blocks :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_blocks dflags :: DynFlags
dflags cn :: CmmReg
cn =
  DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (DynFlags -> Int
oFFSET_bdescr_blocks DynFlags
dflags)

tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
tso_stackobj :: DynFlags -> Int
tso_stackobj dflags :: DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgTSO_stackobj DynFlags
dflags)
tso_alloc_limit :: DynFlags -> Int
tso_alloc_limit dflags :: DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgTSO_alloc_limit DynFlags
dflags)
tso_CCCS :: DynFlags -> Int
tso_CCCS     dflags :: DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgTSO_cccs DynFlags
dflags)
stack_STACK :: DynFlags -> Int
stack_STACK  dflags :: DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgStack_stack DynFlags
dflags)
stack_SP :: DynFlags -> Int
stack_SP     dflags :: DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgStack_sp DynFlags
dflags)


closureField :: DynFlags -> ByteOff -> ByteOff
closureField :: DynFlags -> Int -> Int
closureField dflags :: DynFlags
dflags off :: Int
off = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
fixedHdrSize DynFlags
dflags

-- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual
-- value passed to the call.  For ByteArray#/Array# we pass the
-- address of the actual array, not the address of the heap object.

getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
-- (a) Drop void args
-- (b) Add foreign-call shim code
-- It's (b) that makes this differ from getNonVoidArgAmodes

getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs args :: [StgArg]
args
  = do  { [Maybe (CmmExpr, ForeignHint)]
mb_cmms <- (StgArg -> FCode (Maybe (CmmExpr, ForeignHint)))
-> [StgArg] -> FCode [Maybe (CmmExpr, ForeignHint)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StgArg -> FCode (Maybe (CmmExpr, ForeignHint))
get [StgArg]
args
        ; [(CmmExpr, ForeignHint)] -> FCode [(CmmExpr, ForeignHint)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (CmmExpr, ForeignHint)] -> [(CmmExpr, ForeignHint)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (CmmExpr, ForeignHint)]
mb_cmms) }
  where
    get :: StgArg -> FCode (Maybe (CmmExpr, ForeignHint))
get arg :: StgArg
arg | [PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
arg_reps
            = Maybe (CmmExpr, ForeignHint)
-> FCode (Maybe (CmmExpr, ForeignHint))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (CmmExpr, ForeignHint)
forall a. Maybe a
Nothing
            | Bool
otherwise
            = do { CmmExpr
cmm <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
                 ; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                 ; Maybe (CmmExpr, ForeignHint)
-> FCode (Maybe (CmmExpr, ForeignHint))
forall (m :: * -> *) a. Monad m => a -> m a
return ((CmmExpr, ForeignHint) -> Maybe (CmmExpr, ForeignHint)
forall a. a -> Maybe a
Just (DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim DynFlags
dflags Type
arg_ty CmmExpr
cmm, ForeignHint
hint)) }
            where
              arg_ty :: Type
arg_ty   = StgArg -> Type
stgArgType StgArg
arg
              arg_reps :: [PrimRep]
arg_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg_ty
              hint :: ForeignHint
hint     = Type -> ForeignHint
typeForeignHint Type
arg_ty

add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim dflags :: DynFlags
dflags arg_ty :: Type
arg_ty expr :: CmmExpr
expr
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon
  = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr (DynFlags -> Int
arrPtrsHdrSize DynFlags
dflags)

  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon
  = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr (DynFlags -> Int
smallArrPtrsHdrSize DynFlags
dflags)

  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon
  = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr (DynFlags -> Int
arrWordsHdrSize DynFlags
dflags)

  | Bool
otherwise = CmmExpr
expr
  where
    tycon :: TyCon
tycon           = Type -> TyCon
tyConAppTyCon (Type -> Type
unwrapType Type
arg_ty)
        -- should be a tycon app, since this is a foreign call