{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
--
-- Building info tables.
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module GHC.StgToCmm.Layout (
        mkArgDescr,
        emitCall, emitReturn, adjustHpBackwards,

        emitClosureProcAndInfoTable,
        emitClosureAndInfoTable,

        slowCall, directCall,

        FieldOffOrPadding(..),
        ClosureHeader(..),
        mkVirtHeapOffsets,
        mkVirtHeapOffsetsWithPadding,
        mkVirtConstrOffsets,
        mkVirtConstrSizes,
        getHpRelOffset,

        ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
        getArgAmode, getNonVoidArgAmodes
  ) where


import GHC.Prelude hiding ((<*>))

import GHC.StgToCmm.Closure
import GHC.StgToCmm.Env
import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Lit
import GHC.StgToCmm.Utils

import GHC.Cmm.Graph
import GHC.Runtime.Heap.Layout
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Info
import GHC.Cmm.CLabel
import GHC.Stg.Syntax
import GHC.Types.Id
import GHC.Core.TyCon    ( PrimRep(..), primRepSizeB )
import GHC.Types.Basic   ( RepArity )
import GHC.Platform
import GHC.Platform.Profile
import GHC.Unit

import GHC.Utils.Misc
import Data.List (mapAccumL, partition)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import Control.Monad
import GHC.StgToCmm.Config (stgToCmmPlatform)
import GHC.StgToCmm.Types

------------------------------------------------------------------------
--                Call and return sequences
------------------------------------------------------------------------

-- | Return multiple values to the sequel
--
-- If the sequel is @Return@
--
-- >     return (x,y)
--
-- If the sequel is @AssignTo [p,q]@
--
-- >    p=x; q=y;
--
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr]
results
  = do { Profile
profile   <- FCode Profile
getProfile
       ; Platform
platform  <- FCode Platform
getPlatform
       ; Sequel
sequel    <- FCode Sequel
getSequel
       ; Int
updfr_off <- FCode Int
getUpdFrameOff
       ; case Sequel
sequel of
           Sequel
Return ->
             do { FCode ()
adjustHpBackwards
                ; let e :: CmmExpr
e = Platform -> CmmExpr -> CmmExpr
cmmLoadGCWord Platform
platform (Area -> Int -> CmmExpr
CmmStackSlot Area
Old Int
updfr_off)
                ; CmmAGraph -> FCode ()
emit (Profile -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkReturn Profile
profile (Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform CmmExpr
e) [CmmExpr]
results Int
updfr_off)
                }
           AssignTo [LocalReg]
regs Bool
adjust ->
             do { Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
adjust FCode ()
adjustHpBackwards
                ; [LocalReg] -> [CmmExpr] -> FCode ()
emitMultiAssign  [LocalReg]
regs [CmmExpr]
results }
       ; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
       }


-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
-- using the call/return convention @conv@, passing @args@, and
-- returning the results to the current sequel.
--
emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall :: (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall (Convention, Convention)
convs CmmExpr
fun [CmmExpr]
args
  = (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind
emitCallWithExtraStack (Convention, Convention)
convs CmmExpr
fun [CmmExpr]
args [CmmExpr]
noExtraStack


-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
-- entry-code of @fun@, using the call/return convention @conv@,
-- passing @args@, pushing some extra stack frames described by
-- @stack@, and returning the results to the current sequel.
--
emitCallWithExtraStack
   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
   -> [CmmExpr] -> FCode ReturnKind
emitCallWithExtraStack :: (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind
emitCallWithExtraStack (Convention
callConv, Convention
retConv) CmmExpr
fun [CmmExpr]
args [CmmExpr]
extra_stack
  = do  { Profile
profile <- FCode Profile
getProfile
        ; FCode ()
adjustHpBackwards
        ; Sequel
sequel <- FCode Sequel
getSequel
        ; Int
updfr_off <- FCode Int
getUpdFrameOff
        ; case Sequel
sequel of
            Sequel
Return -> do
              CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ Profile
-> Convention
-> CmmExpr
-> [CmmExpr]
-> Int
-> [CmmExpr]
-> CmmAGraph
mkJumpExtra Profile
profile Convention
callConv CmmExpr
fun [CmmExpr]
args Int
updfr_off [CmmExpr]
extra_stack
              ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
            AssignTo [LocalReg]
res_regs Bool
_ -> do
              BlockId
k <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
              let area :: Area
area = BlockId -> Area
Young BlockId
k
                  (Int
off, [GlobalReg]
_, CmmAGraph
copyin) = Profile
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
retConv Area
area [LocalReg]
res_regs []
                  copyout :: CmmAGraph
copyout = Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> Int
-> Int
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo Profile
profile CmmExpr
fun Convention
callConv [CmmExpr]
args BlockId
k Int
off Int
updfr_off
                                   [CmmExpr]
extra_stack
              CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
              CmmAGraph -> FCode ()
emit (CmmAGraph
copyout CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
k CmmTickScope
tscope CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
copyin)
              ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> Int -> ReturnKind
ReturnedTo BlockId
k Int
off)
      }


adjustHpBackwards :: FCode ()
-- This function adjusts the heap pointer just before a tail call or
-- return.  At a call or return, the virtual heap pointer may be less
-- than the real Hp, because the latter was advanced to deal with
-- the worst-case branch of the code, and we may be in a better-case
-- branch.  In that case, move the real Hp *back* and retract some
-- ticky allocation count.
--
-- It *does not* deal with high-water-mark adjustment.  That's done by
-- functions which allocate heap.
adjustHpBackwards :: FCode ()
adjustHpBackwards
  = do  { HeapUsage
hp_usg <- FCode HeapUsage
getHpUsage
        ; let rHp :: Int
rHp = HeapUsage -> Int
realHp HeapUsage
hp_usg
              vHp :: Int
vHp = HeapUsage -> Int
virtHp HeapUsage
hp_usg
              adjust_words :: Int
adjust_words = Int
vHp Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
rHp
        ; CmmExpr
new_hp <- Int -> FCode CmmExpr
getHpRelOffset Int
vHp

        ; CmmAGraph -> FCode ()
emit (if Int
adjust_words Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                then CmmAGraph
mkNop
                else CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpReg CmmExpr
new_hp) -- Generates nothing when vHp==rHp

        ; Bool -> Int -> FCode ()
tickyAllocHeap Bool
False Int
adjust_words -- ...ditto

        ; Int -> FCode ()
setRealHp Int
vHp
        }


-------------------------------------------------------------------------
--        Making calls: directCall and slowCall
-------------------------------------------------------------------------

-- General plan is:
--   - we'll make *one* fast call, either to the function itself
--     (directCall) or to stg_ap_<pat>_fast (slowCall)
--     Any left-over arguments will be pushed on the stack,
--
--     e.g. Sp[old+8]  = arg1
--          Sp[old+16] = arg2
--          Sp[old+32] = stg_ap_pp_info
--          R2 = arg3
--          R3 = arg4
--          call f() return to Nothing updfr_off: 32


directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
-- (directCall f n args)
-- calls f(arg1, ..., argn), and applies the result to the remaining args
-- The function f has arity n, and there are guaranteed at least n args
-- Both arity and args include void args
directCall :: Convention -> CLabel -> Int -> [StgArg] -> FCode ReturnKind
directCall Convention
conv CLabel
lbl Int
arity [StgArg]
stg_args
  = do  { [(ArgRep, Maybe CmmExpr)]
argreps <- [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
stg_args
        ; String
-> Convention
-> CLabel
-> Int
-> [(ArgRep, Maybe CmmExpr)]
-> FCode ReturnKind
direct_call String
"directCall" Convention
conv CLabel
lbl Int
arity [(ArgRep, Maybe CmmExpr)]
argreps }


slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
-- (slowCall fun args) applies fun to args, returning the results to Sequel
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
slowCall CmmExpr
fun [StgArg]
stg_args
  = do  StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
        let profile :: Profile
profile   = StgToCmmConfig -> Profile
stgToCmmProfile      StgToCmmConfig
cfg
            platform :: Platform
platform  = StgToCmmConfig -> Platform
stgToCmmPlatform     StgToCmmConfig
cfg
            ctx :: SDocContext
ctx       = StgToCmmConfig -> SDocContext
stgToCmmContext      StgToCmmConfig
cfg
            fast_pap :: Bool
fast_pap  = StgToCmmConfig -> Bool
stgToCmmFastPAPCalls StgToCmmConfig
cfg
            align_sat :: Bool
align_sat = StgToCmmConfig -> Bool
stgToCmmAlignCheck   StgToCmmConfig
cfg
        [(ArgRep, Maybe CmmExpr)]
argsreps <- [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
stg_args
        let (FastString
rts_fun, Int
arity) = [ArgRep] -> (FastString, Int)
slowCallPattern (((ArgRep, Maybe CmmExpr) -> ArgRep)
-> [(ArgRep, Maybe CmmExpr)] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (ArgRep, Maybe CmmExpr) -> ArgRep
forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
argsreps)

        (ReturnKind
r, CmmAGraph
slow_code) <- FCode ReturnKind -> FCode (ReturnKind, CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR (FCode ReturnKind -> FCode (ReturnKind, CmmAGraph))
-> FCode ReturnKind -> FCode (ReturnKind, CmmAGraph)
forall a b. (a -> b) -> a -> b
$ do
           ReturnKind
r <- String
-> Convention
-> CLabel
-> Int
-> [(ArgRep, Maybe CmmExpr)]
-> FCode ReturnKind
direct_call String
"slow_call" Convention
NativeNodeCall
                 (FastString -> CLabel
mkRtsApFastLabel FastString
rts_fun) Int
arity ((ArgRep
P,CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
fun)(ArgRep, Maybe CmmExpr)
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. a -> [a] -> [a]
:[(ArgRep, Maybe CmmExpr)]
argsreps)
           FastString -> FCode ()
emitComment (FastString -> FCode ()) -> FastString -> FCode ()
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"slow_call for " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                      SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
fun) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                      String
" with pat " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
rts_fun)
           ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r

        -- See Note [avoid intermediate PAPs]
        let n_args :: Int
n_args = [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
stg_args
        if Int
n_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
arity Bool -> Bool -> Bool
&& Bool
fast_pap
           then do
             CmmExpr
funv <- (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) (LocalReg -> CmmExpr) -> FCode LocalReg -> FCode CmmExpr
forall a b. (a -> b) -> FCode a -> FCode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> FCode LocalReg
assignTemp CmmExpr
fun
             CmmExpr
fun_iptr <- (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) (LocalReg -> CmmExpr) -> FCode LocalReg -> FCode CmmExpr
forall a b. (a -> b) -> FCode a -> FCode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
               CmmExpr -> FCode LocalReg
assignTemp (Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_sat (Platform -> CmmExpr -> CmmExpr
cmmUntag Platform
platform CmmExpr
funv))

             -- ToDo: we could do slightly better here by reusing the
             -- continuation from the slow call, which we have in r.
             -- Also we'd like to push the continuation on the stack
             -- before the branch, so that we only get one copy of the
             -- code that saves all the live variables across the
             -- call, but that might need some improvements to the
             -- special case in the stack layout code to handle this
             -- (see Note [diamond proc point]).

             CmmAGraph
fast_code <- FCode ReturnKind -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode ReturnKind -> FCode CmmAGraph)
-> FCode ReturnKind -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$
                (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall (Convention
NativeNodeCall, Convention
NativeReturn)
                  (Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform CmmExpr
fun_iptr)
                  ([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs ((ArgRep
P,CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
funv)(ArgRep, Maybe CmmExpr)
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. a -> [a] -> [a]
:[(ArgRep, Maybe CmmExpr)]
argsreps))

             BlockId
slow_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
             BlockId
fast_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
             BlockId
is_tagged_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
             BlockId
end_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId

             let correct_arity :: CmmExpr
correct_arity = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (Profile -> CmmExpr -> CmmExpr
funInfoArity Profile
profile CmmExpr
fun_iptr)
                                                    (Platform -> Int -> CmmExpr
mkIntExpr Platform
platform Int
n_args)

             CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
             CmmAGraph -> FCode ()
emit (CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch (Platform -> CmmExpr -> CmmExpr
cmmIsTagged Platform
platform CmmExpr
funv)
                             BlockId
is_tagged_lbl BlockId
slow_lbl (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
is_tagged_lbl CmmTickScope
tscope
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
correct_arity BlockId
fast_lbl BlockId
slow_lbl (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
fast_lbl CmmTickScope
tscope
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
fast_code
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
end_lbl
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
slow_lbl CmmTickScope
tscope
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
slow_code
                   CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
end_lbl CmmTickScope
tscope)
             ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r

           else do
             CmmAGraph -> FCode ()
emit CmmAGraph
slow_code
             ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r


-- Note [avoid intermediate PAPs]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- A slow call which needs multiple generic apply patterns will be
-- almost guaranteed to create one or more intermediate PAPs when
-- applied to a function that takes the correct number of arguments.
-- We try to avoid this situation by generating code to test whether
-- we are calling a function with the correct number of arguments
-- first, i.e.:
--
--   if (TAG(f) != 0} {  // f is not a thunk
--      if (f->info.arity == n) {
--         ... make a fast call to f ...
--      }
--   }
--   ... otherwise make the slow call ...
--
-- We *only* do this when the call requires multiple generic apply
-- functions, which requires pushing extra stack frames and probably
-- results in intermediate PAPs.  (I say probably, because it might be
-- that we're over-applying a function, but that seems even less
-- likely).
--
-- This very rarely applies, but if it does happen in an inner loop it
-- can have a severe impact on performance (#6084).


--------------
direct_call :: String
            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall
            -> CLabel -> RepArity
            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
direct_call :: String
-> Convention
-> CLabel
-> Int
-> [(ArgRep, Maybe CmmExpr)]
-> FCode ReturnKind
direct_call String
caller Convention
call_conv CLabel
lbl Int
arity [(ArgRep, Maybe CmmExpr)]
args
  | Bool
debugIsOn Bool -> Bool -> Bool
&& [(ArgRep, Maybe CmmExpr)]
args [(ArgRep, Maybe CmmExpr)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` Int
real_arity  -- Too few args
  = do -- Caller should ensure that there enough args!
       Platform
platform <- FCode Platform
getPlatform
       String -> SDoc -> FCode ReturnKind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"direct_call" (SDoc -> FCode ReturnKind) -> SDoc -> FCode ReturnKind
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
caller SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
arity SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
            Platform -> CLabel -> SDoc
pprDebugCLabel Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([(ArgRep, Maybe CmmExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ArgRep, Maybe CmmExpr)]
args) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
            Platform -> [Maybe CmmExpr] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (((ArgRep, Maybe CmmExpr) -> Maybe CmmExpr)
-> [(ArgRep, Maybe CmmExpr)] -> [Maybe CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (ArgRep, Maybe CmmExpr) -> Maybe CmmExpr
forall a b. (a, b) -> b
snd [(ArgRep, Maybe CmmExpr)]
args) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ArgRep] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (((ArgRep, Maybe CmmExpr) -> ArgRep)
-> [(ArgRep, Maybe CmmExpr)] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (ArgRep, Maybe CmmExpr) -> ArgRep
forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
args)

  | [(ArgRep, Maybe CmmExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ArgRep, Maybe CmmExpr)]
rest_args  -- Precisely the right number of arguments
  = (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall (Convention
call_conv, Convention
NativeReturn) CmmExpr
target ([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args)

  | Bool
otherwise       -- Note [over-saturated calls]
  = do Bool
do_scc_prof <- StgToCmmConfig -> Bool
stgToCmmSCCProfiling (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
       (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind
emitCallWithExtraStack (Convention
call_conv, Convention
NativeReturn)
                              CmmExpr
target
                              ([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
fast_args)
                              ([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs ([(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs [(ArgRep, Maybe CmmExpr)]
rest_args Bool
do_scc_prof))
  where
    target :: CmmExpr
target = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)
    ([(ArgRep, Maybe CmmExpr)]
fast_args, [(ArgRep, Maybe CmmExpr)]
rest_args) = Int
-> [(ArgRep, Maybe CmmExpr)]
-> ([(ArgRep, Maybe CmmExpr)], [(ArgRep, Maybe CmmExpr)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
real_arity [(ArgRep, Maybe CmmExpr)]
args
    real_arity :: Int
real_arity = case Convention
call_conv of
                   Convention
NativeNodeCall -> Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
                   Convention
_              -> Int
arity


-- When constructing calls, it is easier to keep the ArgReps and the
-- CmmExprs zipped together.  However, a void argument has no
-- representation, so we need to use Maybe CmmExpr (the alternative of
-- using zeroCLit or even undefined would work, but would be ugly).
--
getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
args = do
   Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> FCode Profile -> FCode Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
getProfile
   (StgArg -> FCode (ArgRep, Maybe CmmExpr))
-> [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Platform -> StgArg -> FCode (ArgRep, Maybe CmmExpr)
getArgRepAmode Platform
platform) [StgArg]
args
  where getArgRepAmode :: Platform -> StgArg -> FCode (ArgRep, Maybe CmmExpr)
getArgRepAmode Platform
platform StgArg
arg
           | ArgRep
V <- ArgRep
rep  = (ArgRep, Maybe CmmExpr) -> FCode (ArgRep, Maybe CmmExpr)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgRep
V, Maybe CmmExpr
forall a. Maybe a
Nothing)
           | Bool
otherwise = do CmmExpr
expr <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
                            (ArgRep, Maybe CmmExpr) -> FCode (ArgRep, Maybe CmmExpr)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgRep
rep, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
expr)
           where rep :: ArgRep
rep = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (StgArg -> PrimRep
argPrimRep StgArg
arg)

nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [] = []
nonVArgs ((ArgRep
_,Maybe CmmExpr
Nothing)  : [(ArgRep, Maybe CmmExpr)]
args) = [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args
nonVArgs ((ArgRep
_,Just CmmExpr
arg) : [(ArgRep, Maybe CmmExpr)]
args) = CmmExpr
arg CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args

{-
Note [over-saturated calls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The natural thing to do for an over-saturated call would be to call
the function with the correct number of arguments, and then apply the
remaining arguments to the value returned, e.g.

  f a b c d   (where f has arity 2)
  -->
  r = call f(a,b)
  call r(c,d)

but this entails
  - saving c and d on the stack
  - making a continuation info table
  - at the continuation, loading c and d off the stack into regs
  - finally, call r

Note that since there are a fixed number of different r's
(e.g.  stg_ap_pp_fast), we can also pre-compile continuations
that correspond to each of them, rather than generating a fresh
one for each over-saturated call.

Not only does this generate much less code, it is faster too.  We will
generate something like:

Sp[old+16] = c
Sp[old+24] = d
Sp[old+32] = stg_ap_pp_info
call f(a,b) -- usual calling convention

For the purposes of the CmmCall node, we count this extra stack as
just more arguments that we are passing on the stack (cml_args).
-}

-- | 'slowArgs' takes a list of function arguments and prepares them for
-- pushing on the stack for "extra" arguments to a function which requires
-- fewer arguments than we currently have.
slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)]
slowArgs :: [(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs []   Bool
_                    = [(ArgRep, Maybe CmmExpr)]
forall a. Monoid a => a
mempty
slowArgs [(ArgRep, Maybe CmmExpr)]
args Bool
sccProfilingEnabled  -- careful: reps contains voids (V), but args does not
  | Bool
sccProfilingEnabled = [(ArgRep, Maybe CmmExpr)]
save_cccs [(ArgRep, Maybe CmmExpr)]
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. [a] -> [a] -> [a]
++ [(ArgRep, Maybe CmmExpr)]
this_pat [(ArgRep, Maybe CmmExpr)]
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. [a] -> [a] -> [a]
++ [(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs [(ArgRep, Maybe CmmExpr)]
rest_args Bool
sccProfilingEnabled
  | Bool
otherwise           =              [(ArgRep, Maybe CmmExpr)]
this_pat [(ArgRep, Maybe CmmExpr)]
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. [a] -> [a] -> [a]
++ [(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs [(ArgRep, Maybe CmmExpr)]
rest_args Bool
sccProfilingEnabled
  where
    (FastString
arg_pat, Int
n)            = [ArgRep] -> (FastString, Int)
slowCallPattern (((ArgRep, Maybe CmmExpr) -> ArgRep)
-> [(ArgRep, Maybe CmmExpr)] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (ArgRep, Maybe CmmExpr) -> ArgRep
forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
args)
    ([(ArgRep, Maybe CmmExpr)]
call_args, [(ArgRep, Maybe CmmExpr)]
rest_args)  = Int
-> [(ArgRep, Maybe CmmExpr)]
-> ([(ArgRep, Maybe CmmExpr)], [(ArgRep, Maybe CmmExpr)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [(ArgRep, Maybe CmmExpr)]
args

    stg_ap_pat :: CLabel
stg_ap_pat = UnitId -> FastString -> CLabel
mkCmmRetInfoLabel UnitId
rtsUnitId FastString
arg_pat
    this_pat :: [(ArgRep, Maybe CmmExpr)]
this_pat   = (ArgRep
N, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (CLabel -> CmmExpr
mkLblExpr CLabel
stg_ap_pat)) (ArgRep, Maybe CmmExpr)
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. a -> [a] -> [a]
: [(ArgRep, Maybe CmmExpr)]
call_args
    save_cccs :: [(ArgRep, Maybe CmmExpr)]
save_cccs  = [(ArgRep
N, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (CLabel -> CmmExpr
mkLblExpr CLabel
save_cccs_lbl)), (ArgRep
N, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
cccsExpr)]
    save_cccs_lbl :: CLabel
save_cccs_lbl = UnitId -> FastString -> CLabel
mkCmmRetInfoLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"stg_restore_cccs")

-------------------------------------------------------------------------
----        Laying out objects on the heap and stack
-------------------------------------------------------------------------

-- The heap always grows upwards, so hpRel is easy to compute
hpRel :: VirtualHpOffset         -- virtual offset of Hp
      -> VirtualHpOffset         -- virtual offset of The Thing
      -> WordOff                -- integer word offset
hpRel :: Int -> Int -> Int
hpRel Int
hp Int
off = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hp

getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
-- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad
getHpRelOffset :: Int -> FCode CmmExpr
getHpRelOffset Int
virtual_offset
  = do Platform
platform <- FCode Platform
getPlatform
       HeapUsage
hp_usg <- FCode HeapUsage
getHpUsage
       CmmExpr -> FCode CmmExpr
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> CmmReg -> Int -> CmmExpr
cmmRegOffW Platform
platform CmmReg
hpReg (Int -> Int -> Int
hpRel (HeapUsage -> Int
realHp HeapUsage
hp_usg) Int
virtual_offset))

data FieldOffOrPadding a
    = FieldOff (NonVoid a) -- Something that needs an offset.
               ByteOff     -- Offset in bytes.
    | Padding ByteOff  -- Length of padding in bytes.
              ByteOff  -- Offset in bytes.

-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
-- of header the object has.  This will be accounted for in the
-- offsets of the fields returned.
data ClosureHeader
  = NoHeader
  | StdHeader
  | ThunkHeader

mkVirtHeapOffsetsWithPadding
  :: Profile
  -> ClosureHeader            -- What kind of header to account for
  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
  -> ( WordOff                -- Total number of words allocated
     , WordOff                -- Number of words allocated for *pointers*
     , [FieldOffOrPadding a]  -- Either an offset or padding.
     )

-- Things with their offsets from start of object in order of
-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
-- First in list gets lowest offset, which is initial offset + 1.
--
-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
-- than the unboxed things

mkVirtHeapOffsetsWithPadding :: forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
header [NonVoid (PrimRep, a)]
things =
    Bool
-> (Int, Int, [FieldOffOrPadding a])
-> (Int, Int, [FieldOffOrPadding a])
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((NonVoid (PrimRep, a) -> Bool) -> [NonVoid (PrimRep, a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PrimRep -> Bool
isVoidRep (PrimRep -> Bool)
-> (NonVoid (PrimRep, a) -> PrimRep)
-> NonVoid (PrimRep, a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimRep, a) -> PrimRep
forall a b. (a, b) -> a
fst ((PrimRep, a) -> PrimRep)
-> (NonVoid (PrimRep, a) -> (PrimRep, a))
-> NonVoid (PrimRep, a)
-> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid (PrimRep, a) -> (PrimRep, a)
forall a. NonVoid a -> a
fromNonVoid) [NonVoid (PrimRep, a)]
things))
    ( Int
tot_wds
    , Platform -> Int -> Int
bytesToWordsRoundUp Platform
platform Int
bytes_of_ptrs
    , [[FieldOffOrPadding a]] -> [FieldOffOrPadding a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FieldOffOrPadding a]]
ptrs_w_offsets [[FieldOffOrPadding a]]
-> [[FieldOffOrPadding a]] -> [[FieldOffOrPadding a]]
forall a. [a] -> [a] -> [a]
++ [[FieldOffOrPadding a]]
non_ptrs_w_offsets) [FieldOffOrPadding a]
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. [a] -> [a] -> [a]
++ [FieldOffOrPadding a]
final_pad
    )
  where
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    hdr_words :: Int
hdr_words = case ClosureHeader
header of
      ClosureHeader
NoHeader -> Int
0
      ClosureHeader
StdHeader -> Profile -> Int
fixedHdrSizeW Profile
profile
      ClosureHeader
ThunkHeader -> Profile -> Int
thunkHdrSize Profile
profile
    hdr_bytes :: Int
hdr_bytes = Platform -> Int -> Int
forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
hdr_words

    ([NonVoid (PrimRep, a)]
ptrs, [NonVoid (PrimRep, a)]
non_ptrs) = (NonVoid (PrimRep, a) -> Bool)
-> [NonVoid (PrimRep, a)]
-> ([NonVoid (PrimRep, a)], [NonVoid (PrimRep, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (PrimRep -> Bool
isGcPtrRep (PrimRep -> Bool)
-> (NonVoid (PrimRep, a) -> PrimRep)
-> NonVoid (PrimRep, a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimRep, a) -> PrimRep
forall a b. (a, b) -> a
fst ((PrimRep, a) -> PrimRep)
-> (NonVoid (PrimRep, a) -> (PrimRep, a))
-> NonVoid (PrimRep, a)
-> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid (PrimRep, a) -> (PrimRep, a)
forall a. NonVoid a -> a
fromNonVoid) [NonVoid (PrimRep, a)]
things

    (Int
bytes_of_ptrs, [[FieldOffOrPadding a]]
ptrs_w_offsets) =
       (Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a]))
-> Int -> [NonVoid (PrimRep, a)] -> (Int, [[FieldOffOrPadding a]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a])
computeOffset Int
0 [NonVoid (PrimRep, a)]
ptrs
    (Int
tot_bytes, [[FieldOffOrPadding a]]
non_ptrs_w_offsets) =
       (Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a]))
-> Int -> [NonVoid (PrimRep, a)] -> (Int, [[FieldOffOrPadding a]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a])
computeOffset Int
bytes_of_ptrs [NonVoid (PrimRep, a)]
non_ptrs

    tot_wds :: Int
tot_wds = Platform -> Int -> Int
bytesToWordsRoundUp Platform
platform Int
tot_bytes

    final_pad_size :: Int
final_pad_size = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
word_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tot_bytes
    final_pad :: [FieldOffOrPadding a]
final_pad
        | Int
final_pad_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = [(Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
final_pad_size
                                         (Int
hdr_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tot_bytes))]
        | Bool
otherwise          = []

    word_size :: Int
word_size = Platform -> Int
platformWordSizeInBytes Platform
platform

    computeOffset :: Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a])
computeOffset Int
bytes_so_far NonVoid (PrimRep, a)
nv_thing =
        (Int
new_bytes_so_far, FieldOffOrPadding a -> [FieldOffOrPadding a]
with_padding FieldOffOrPadding a
field_off)
      where
        (PrimRep
rep, a
thing) = NonVoid (PrimRep, a) -> (PrimRep, a)
forall a. NonVoid a -> a
fromNonVoid NonVoid (PrimRep, a)
nv_thing

        -- Size of the field in bytes.
        !sizeB :: Int
sizeB = Platform -> PrimRep -> Int
primRepSizeB Platform
platform PrimRep
rep

        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
        -- But not more than to a word.
        !align :: Int
align = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
word_size Int
sizeB
        !start :: Int
start = Int -> Int -> Int
roundUpTo Int
bytes_so_far Int
align
        !padding :: Int
padding = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bytes_so_far

        -- Final offset is:
        --   size of header + bytes_so_far + padding
        !final_offset :: Int
final_offset = Int
hdr_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytes_so_far Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
padding
        !new_bytes_so_far :: Int
new_bytes_so_far = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeB
        field_off :: FieldOffOrPadding a
field_off = NonVoid a -> Int -> FieldOffOrPadding a
forall a. NonVoid a -> Int -> FieldOffOrPadding a
FieldOff (a -> NonVoid a
forall a. a -> NonVoid a
NonVoid a
thing) Int
final_offset

        with_padding :: FieldOffOrPadding a -> [FieldOffOrPadding a]
with_padding FieldOffOrPadding a
field_off
            | Int
padding Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [FieldOffOrPadding a
field_off]
            | Bool
otherwise    = [ Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
padding (Int
hdr_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytes_so_far)
                             , FieldOffOrPadding a
field_off
                             ]


mkVirtHeapOffsets
  :: Profile
  -> ClosureHeader            -- What kind of header to account for
  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
  -> (WordOff,                -- _Total_ number of words allocated
      WordOff,                -- Number of words allocated for *pointers*
      [(NonVoid a, ByteOff)])
mkVirtHeapOffsets :: forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
header [NonVoid (PrimRep, a)]
things =
    ( Int
tot_wds
    , Int
ptr_wds
    , [ (NonVoid a
field, Int
offset) | (FieldOff NonVoid a
field Int
offset) <- [FieldOffOrPadding a]
things_offsets ]
    )
  where
   (Int
tot_wds, Int
ptr_wds, [FieldOffOrPadding a]
things_offsets) =
       Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
header [NonVoid (PrimRep, a)]
things

-- | Just like mkVirtHeapOffsets, but for constructors
mkVirtConstrOffsets
  :: Profile -> [NonVoid (PrimRep, a)]
  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
mkVirtConstrOffsets :: forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile = Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
StdHeader

-- | Just like mkVirtConstrOffsets, but used when we don't have the actual
-- arguments. Useful when e.g. generating info tables; we just need to know
-- sizes of pointer and non-pointer fields.
mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (Int, Int)
mkVirtConstrSizes Profile
profile [NonVoid PrimRep]
field_reps
  = (Int
tot_wds, Int
ptr_wds)
  where
    (Int
tot_wds, Int
ptr_wds, [(NonVoid (), Int)]
_) =
       Profile
-> [NonVoid (PrimRep, ())] -> (Int, Int, [(NonVoid (), Int)])
forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile
         ((NonVoid PrimRep -> NonVoid (PrimRep, ()))
-> [NonVoid PrimRep] -> [NonVoid (PrimRep, ())]
forall a b. (a -> b) -> [a] -> [b]
map (\NonVoid PrimRep
nv_rep -> (PrimRep, ()) -> NonVoid (PrimRep, ())
forall a. a -> NonVoid a
NonVoid (NonVoid PrimRep -> PrimRep
forall a. NonVoid a -> a
fromNonVoid NonVoid PrimRep
nv_rep, ())) [NonVoid PrimRep]
field_reps)

-------------------------------------------------------------------------
--
--        Making argument descriptors
--
--  An argument descriptor describes the layout of args on the stack,
--  both for         * GC (stack-layout) purposes, and
--                * saving/restoring registers when a heap-check fails
--
-- Void arguments aren't important, therefore (contrast constructSlowCall)
--
-------------------------------------------------------------------------

-- bring in ARG_P, ARG_N, etc.
#include "FunTypes.h"

mkArgDescr :: Platform -> [Id] -> ArgDescr
mkArgDescr :: Platform -> [Id] -> ArgDescr
mkArgDescr Platform
platform [Id]
args
  = let arg_bits :: [Bool]
arg_bits = Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
arg_reps
        arg_reps :: [ArgRep]
arg_reps = (ArgRep -> Bool) -> [ArgRep] -> [ArgRep]
forall a. (a -> Bool) -> [a] -> [a]
filter ArgRep -> Bool
isNonV ((Id -> ArgRep) -> [Id] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Id -> ArgRep
idArgRep Platform
platform) [Id]
args)
           -- Getting rid of voids eases matching of standard patterns
    in case [ArgRep] -> Maybe Int
stdPattern [ArgRep]
arg_reps of
         Just Int
spec_id -> Int -> ArgDescr
ArgSpec Int
spec_id
         Maybe Int
Nothing      -> [Bool] -> ArgDescr
ArgGen  [Bool]
arg_bits

argBits :: Platform -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
argBits :: Platform -> [ArgRep] -> [Bool]
argBits Platform
_         []           = []
argBits Platform
platform (ArgRep
P   : [ArgRep]
args) = Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
argBits Platform
platform (ArgRep
arg : [ArgRep]
args) = Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
arg) (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True)
                                 [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args

----------------------
stdPattern :: [ArgRep] -> Maybe Int
stdPattern :: [ArgRep] -> Maybe Int
stdPattern [ArgRep]
reps
  = case [ArgRep]
reps of
        []    -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NONE        -- just void args, probably
        [ArgRep
N]   -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_N
        [ArgRep
P]   -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_P
        [ArgRep
F]   -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_F
        [ArgRep
D]   -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_D
        [ArgRep
L]   -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_L
        [ArgRep
V16] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_V16
        [ArgRep
V32] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_V32
        [ArgRep
V64] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_V64

        [ArgRep
N,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NN
        [ArgRep
N,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NP
        [ArgRep
P,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PN
        [ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PP

        [ArgRep
N,ArgRep
N,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NNN
        [ArgRep
N,ArgRep
N,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NNP
        [ArgRep
N,ArgRep
P,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NPN
        [ArgRep
N,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NPP
        [ArgRep
P,ArgRep
N,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PNN
        [ArgRep
P,ArgRep
N,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PNP
        [ArgRep
P,ArgRep
P,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPN
        [ArgRep
P,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPP

        [ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P]     -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPPP
        [ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P]   -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPPPP
        [ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPPPPP

        [ArgRep]
_ -> Maybe Int
forall a. Maybe a
Nothing

-------------------------------------------------------------------------
--        Amodes for arguments
-------------------------------------------------------------------------

getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode (NonVoid (StgVarArg Id
var)) = CgIdInfo -> CmmExpr
idInfoToAmode (CgIdInfo -> CmmExpr) -> FCode CgIdInfo -> FCode CmmExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> FCode CgIdInfo
getCgIdInfo Id
var
getArgAmode (NonVoid (StgLitArg Literal
lit)) = Literal -> FCode CmmExpr
cgLit Literal
lit

getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
--     so the result list may be shorter than the argument list
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [] = [CmmExpr] -> FCode [CmmExpr]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return []
getNonVoidArgAmodes (StgArg
arg:[StgArg]
args)
  | PrimRep -> Bool
isVoidRep (StgArg -> PrimRep
argPrimRep StgArg
arg) = [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
  | Bool
otherwise = do { CmmExpr
amode  <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
                   ; [CmmExpr]
amodes <- [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
                   ; [CmmExpr] -> FCode [CmmExpr]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ( CmmExpr
amode CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [CmmExpr]
amodes ) }

-------------------------------------------------------------------------
--
--        Generating the info table and code for a closure
--
-------------------------------------------------------------------------

-- Here we make an info table of type 'CmmInfo'.  The concrete
-- representation as a list of 'CmmAddr' is handled later
-- in the pipeline by 'cmmToRawCmm'.
-- When loading the free variables, a function closure pointer may be tagged,
-- so we must take it into account.

emitClosureProcAndInfoTable :: Bool                    -- top-level?
                            -> Id                      -- name of the closure
                            -> LambdaFormInfo
                            -> CmmInfoTable
                            -> [NonVoid Id]            -- incoming arguments
                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
                            -> FCode ()
emitClosureProcAndInfoTable :: Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((Int, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [NonVoid Id]
args (Int, LocalReg, [LocalReg]) -> FCode ()
body
 = do   { Profile
profile <- FCode Profile
getProfile
        ; Platform
platform <- FCode Platform
getPlatform
        -- Bind the binder itself, but only if it's not a top-level
        -- binding. We need non-top let-bindings to refer to the
        -- top-level binding, which this binding would incorrectly shadow.
        ; LocalReg
node <- if Bool
top_lvl then LocalReg -> FCode LocalReg
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalReg -> FCode LocalReg) -> LocalReg -> FCode LocalReg
forall a b. (a -> b) -> a -> b
$ Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)
                  else NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr) LambdaFormInfo
lf_info
        ; let node_points :: Bool
node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
        ; [LocalReg]
arg_regs <- [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs [NonVoid Id]
args
        ; let args' :: [LocalReg]
args' = if Bool
node_points then (LocalReg
node LocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs) else [LocalReg]
arg_regs
              conv :: Convention
conv  = if Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info then Convention
NativeNodeCall
                                                          else Convention
NativeDirectCall
              (Int
offset, [GlobalReg]
_, CmmAGraph
_) = Profile
-> Convention
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
mkCallEntry Profile
profile Convention
conv [LocalReg]
args' []
        ; Platform
-> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable (Profile -> Platform
profilePlatform Profile
profile) CmmInfoTable
info_tbl Convention
conv [LocalReg]
args' (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ (Int, LocalReg, [LocalReg]) -> FCode ()
body (Int
offset, LocalReg
node, [LocalReg]
arg_regs)
        }

-- Data constructors need closures, but not with all the argument handling
-- needed for functions. The shared part goes here.
emitClosureAndInfoTable
   :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable :: Platform
-> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable Platform
platform CmmInfoTable
info_tbl Convention
conv [LocalReg]
args FCode ()
body
  = do { (()
_, CmmAGraphScoped
blks) <- FCode () -> FCode ((), CmmAGraphScoped)
forall a. FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped FCode ()
body
       ; let entry_lbl :: CLabel
entry_lbl = Platform -> CLabel -> CLabel
toEntryLbl Platform
platform (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info_tbl)
       ; Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention Convention
conv (CmmInfoTable -> Maybe CmmInfoTable
forall a. a -> Maybe a
Just CmmInfoTable
info_tbl) CLabel
entry_lbl [LocalReg]
args CmmAGraphScoped
blks
       }