{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}

-----------------------------------------------------------------------------
--
-- Monad for Stg to C-- code generation
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module GHC.StgToCmm.Monad (
        FCode,        -- type

        initC, initFCodeState, runC, fixC,
        newUnique,

        emitLabel,

        emit, emitDecl,
        emitProcWithConvention, emitProcWithStackFrame,
        emitOutOfLine, emitAssign, emitStore, emitStore',
        emitComment, emitTick, emitUnwind,

        newTemp,

        getCmm, aGraphToGraph, getPlatform, getProfile,
        getCodeR, getCode, getCodeScoped, getHeapUsage,
        getContext,

        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',

        mkCall, mkCmmCall,

        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,

        ConTagZ,

        Sequel(..), ReturnKind(..),
        withSequel, getSequel,

        SelfLoopInfo(..),

        setTickyCtrLabel, getTickyCtrLabel,
        tickScope, getTickScope,

        withUpdFrameOff, getUpdFrameOff,

        HeapUsage(..), VirtualHpOffset,        initHpUsage,
        getHpUsage,  setHpUsage, heapHWM,
        setVirtHp, getVirtHp, setRealHp,

        getModuleName,

        -- ideally we wouldn't export these, but some other modules access internal state
        getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig,

        -- more localised access to monad state
        CgIdInfo(..),
        getBinds, setBinds,
        -- out of general friendliness, we also export ...
        StgToCmmConfig(..), CgState(..) -- non-abstract
    ) where

import GHC.Prelude hiding( sequence, succ )

import GHC.Platform
import GHC.Platform.Profile
import GHC.Cmm
import GHC.StgToCmm.Config
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Sequel
import GHC.Cmm.Graph as CmmGraph
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import GHC.Unit
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Data.OrdList
import GHC.Types.Basic( ConTagZ )
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import qualified GHC.Types.Unique.DSM as DSM ( MonadGetUnique, getUniqueM )
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Exts (oneShot)

import Control.Monad
import Data.List (mapAccumL)


--------------------------------------------------------
-- The FCode monad and its types
--
-- FCode is the monad plumbed through the Stg->Cmm code generator, and
-- the Cmm parser.  It contains the following things:
--
--  - A writer monad, collecting:
--    - code for the current function, in the form of a CmmAGraph.
--      The function "emit" appends more code to this.
--    - the top-level CmmDecls accumulated so far
--
--  - A state monad with:
--    - the local bindings in scope
--    - the current heap usage
--    - a UniqSupply
--
--  - A reader monad, for StgToCmmConfig, containing
--    - the profile,
--    - the current Module
--    - the debug level
--    - a bunch of flags see StgToCmm.Config for full details

--  - A second reader monad with:
--    - the update-frame offset
--    - the ticky counter label
--    - the Sequel (the continuation to return to)
--    - the self-recursive tail call information
--    - The tick scope for new blocks and ticks
--

--------------------------------------------------------

newtype FCode a = FCode' { forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) }

-- Not derived because of #18202.
-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
instance Functor FCode where
  fmap :: forall a b. (a -> b) -> FCode a -> FCode b
fmap a -> b
f (FCode StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m) =
    (StgToCmmConfig -> FCodeState -> CgState -> (b, CgState))
-> FCode b
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (b, CgState))
 -> FCode b)
-> (StgToCmmConfig -> FCodeState -> CgState -> (b, CgState))
-> FCode b
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
cfg FCodeState
fst CgState
state ->
      case StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m StgToCmmConfig
cfg FCodeState
fst CgState
state of
        (a
x, CgState
state') -> (a -> b
f a
x, CgState
state')

-- This pattern synonym makes the simplifier monad eta-expand,
-- which as a very beneficial effect on compiler performance
-- See #18202.
-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
{-# COMPLETE FCode #-}
pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
              -> FCode a
pattern $mFCode :: forall {r} {a}.
FCode a
-> ((StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)) -> r)
-> ((# #) -> r)
-> r
$bFCode :: forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode m <- FCode' m
  where
    FCode StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m = (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode' ((StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
 -> FCode a)
-> (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a b. (a -> b) -> a -> b
$ (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
forall a b. (a -> b) -> a -> b
oneShot (\StgToCmmConfig
cfg -> (FCodeState -> CgState -> (a, CgState))
-> FCodeState -> CgState -> (a, CgState)
forall a b. (a -> b) -> a -> b
oneShot
                                 (\FCodeState
fstate -> (CgState -> (a, CgState)) -> CgState -> (a, CgState)
forall a b. (a -> b) -> a -> b
oneShot
                                   (\CgState
state -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m StgToCmmConfig
cfg FCodeState
fstate CgState
state)))

instance Applicative FCode where
    pure :: forall a. a -> FCode a
pure a
val = (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode (\StgToCmmConfig
_cfg FCodeState
_fstate CgState
state -> (a
val, CgState
state))
    {-# INLINE pure #-}
    <*> :: forall a b. FCode (a -> b) -> FCode a -> FCode b
(<*>) = FCode (a -> b) -> FCode a -> FCode b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad FCode where
    FCode StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m >>= :: forall a b. FCode a -> (a -> FCode b) -> FCode b
>>= a -> FCode b
k = (StgToCmmConfig -> FCodeState -> CgState -> (b, CgState))
-> FCode b
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (b, CgState))
 -> FCode b)
-> (StgToCmmConfig -> FCodeState -> CgState -> (b, CgState))
-> FCode b
forall a b. (a -> b) -> a -> b
$
        \StgToCmmConfig
cfg FCodeState
fstate CgState
state ->
            case StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m StgToCmmConfig
cfg FCodeState
fstate CgState
state of
              (a
m_result, CgState
new_state) ->
                 case a -> FCode b
k a
m_result of
                   FCode StgToCmmConfig -> FCodeState -> CgState -> (b, CgState)
kcode -> StgToCmmConfig -> FCodeState -> CgState -> (b, CgState)
kcode StgToCmmConfig
cfg FCodeState
fstate CgState
new_state
    {-# INLINE (>>=) #-}

instance MonadUnique FCode where
  getUniqueSupplyM :: FCode UniqSupply
getUniqueSupplyM = CgState -> UniqSupply
cgs_uniqs (CgState -> UniqSupply) -> FCode CgState -> FCode UniqSupply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode CgState
getState
  getUniqueM :: FCode Unique
getUniqueM = (StgToCmmConfig -> FCodeState -> CgState -> (Unique, CgState))
-> FCode Unique
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (Unique, CgState))
 -> FCode Unique)
-> (StgToCmmConfig -> FCodeState -> CgState -> (Unique, CgState))
-> FCode Unique
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
_ FCodeState
_ CgState
st ->
    let (Unique
u, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (CgState -> UniqSupply
cgs_uniqs CgState
st)
    in (Unique
u, CgState
st { cgs_uniqs = us' })

instance DSM.MonadGetUnique FCode where
  getUniqueM :: FCode Unique
getUniqueM = FCode Unique
forall (m :: * -> *). MonadUnique m => m Unique
GHC.Types.Unique.Supply.getUniqueM

initC :: IO CgState
initC :: IO CgState
initC  = do { uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'c'
            ; return (initCgState uniqs) }

runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)
runC :: forall a.
StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)
runC StgToCmmConfig
cfg FCodeState
fst CgState
st FCode a
fcode = FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode a
fcode StgToCmmConfig
cfg FCodeState
fst CgState
st

fixC :: (a -> FCode a) -> FCode a
fixC :: forall a. (a -> FCode a) -> FCode a
fixC a -> FCode a
fcode = (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
 -> FCode a)
-> (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a b. (a -> b) -> a -> b
$
    \StgToCmmConfig
cfg FCodeState
fstate CgState
state ->
      let (a
v, CgState
s) = FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode (a -> FCode a
fcode a
v) StgToCmmConfig
cfg FCodeState
fstate CgState
state
      in (a
v, CgState
s)

--------------------------------------------------------
--        The code generator environment
--------------------------------------------------------
type CgBindings = IdEnv CgIdInfo

data CgIdInfo
  = CgIdInfo
        { CgIdInfo -> Id
cg_id  :: Id
          -- ^ Id that this is the info for
        , CgIdInfo -> LambdaFormInfo
cg_lf  :: LambdaFormInfo
        , CgIdInfo -> CgLoc
cg_loc :: CgLoc
          -- ^ 'CmmExpr' for the *tagged* value
        }

instance OutputableP Platform CgIdInfo where
  pdoc :: Platform -> CgIdInfo -> SDoc
pdoc Platform
env (CgIdInfo { cg_id :: CgIdInfo -> Id
cg_id = Id
id, cg_loc :: CgIdInfo -> CgLoc
cg_loc = CgLoc
loc })
    = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CgLoc -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
env CgLoc
loc

-- See Note [sharing continuations] below
data ReturnKind
  = AssignedDirectly
  | ReturnedTo BlockId ByteOff

-- Note [sharing continuations]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- ReturnKind says how the expression being compiled returned its
-- results: either by assigning directly to the registers specified
-- by the Sequel, or by returning to a continuation that does the
-- assignments.  The point of this is we might be able to re-use the
-- continuation in a subsequent heap-check.  Consider:
--
--    case f x of z
--      True  -> <True code>
--      False -> <False code>
--
-- Naively we would generate
--
--    R2 = x   -- argument to f
--    Sp[young(L1)] = L1
--    call f returns to L1
--  L1:
--    z = R1
--    if (z & 1) then Ltrue else Lfalse
--  Ltrue:
--    Hp = Hp + 24
--    if (Hp > HpLim) then L4 else L7
--  L4:
--    HpAlloc = 24
--    goto L5
--  L5:
--    R1 = z
--    Sp[young(L6)] = L6
--    call stg_gc_unpt_r1 returns to L6
--  L6:
--    z = R1
--    goto L1
--  L7:
--    <True code>
--  Lfalse:
--    <False code>
--
-- We want the gc call in L4 to return to L1, and discard L6.  Note
-- that not only can we share L1 and L6, but the assignment of the
-- return address in L4 is unnecessary because the return address for
-- L1 is already on the stack.  We used to catch the sharing of L1 and
-- L6 in the common-block-eliminator, but not the unnecessary return
-- address assignment.
--
-- Since this case is so common I decided to make it more explicit and
-- robust by programming the sharing directly, rather than relying on
-- the common-block eliminator to catch it.  This makes
-- common-block-elimination an optional optimisation, and furthermore
-- generates less code in the first place that we have to subsequently
-- clean up.
--
-- There are some rarer cases of common blocks that we don't catch
-- this way, but that's ok.  Common-block-elimination is still available
-- to catch them when optimisation is enabled.  Some examples are:
--
--   - when both the True and False branches do a heap check, we
--     can share the heap-check failure code L4a and maybe L4
--
--   - in a case-of-case, there might be multiple continuations that
--     we can common up.
--
-- It is always safe to use AssignedDirectly.  Expressions that jump
-- to the continuation from multiple places (e.g. case expressions)
-- fall back to AssignedDirectly.
--

--------------------------------------------------------
--        The code generator state
--------------------------------------------------------

data CgState
  = MkCgState {
     CgState -> CmmAGraph
cgs_stmts :: CmmAGraph,          -- Current procedure

     CgState -> OrdList DCmmDecl
cgs_tops  :: OrdList DCmmDecl,
        -- Other procedures and data blocks in this compilation unit
        -- Both are ordered only so that we can
        -- reduce forward references, when it's easy to do so

     CgState -> CgBindings
cgs_binds :: CgBindings,

     CgState -> HeapUsage
cgs_hp_usg  :: HeapUsage,

     CgState -> UniqSupply
cgs_uniqs :: UniqSupply }
-- If you are wondering why you have to be careful forcing CgState then
-- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked
-- in #19245

data FCodeState =
  MkFCodeState { FCodeState -> VirtualHpOffset
fcs_upframeoffset :: UpdFrameOffset     -- ^ Size of current update frame UpdFrameOffset must be kept lazy or
                                                         -- else the RTS will deadlock _and_ also experience a severe
                                                         -- performance degradation
              , FCodeState -> Sequel
fcs_sequel        :: !Sequel             -- ^ What to do at end of basic block
              , FCodeState -> Maybe SelfLoopInfo
fcs_selfloop      :: !(Maybe SelfLoopInfo) -- ^ Which tail calls can be compiled as local jumps?
                                                         --   See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr
              , FCodeState -> CLabel
fcs_ticky         :: !CLabel             -- ^ Destination for ticky counts
              , FCodeState -> CmmTickScope
fcs_tickscope     :: !CmmTickScope       -- ^ Tick scope for new blocks & ticks
              }

data HeapUsage   -- See Note [Virtual and real heap pointers]
  = HeapUsage {
        HeapUsage -> VirtualHpOffset
virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word
                                         --   Incremented whenever we allocate
        HeapUsage -> VirtualHpOffset
realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr
                                         --   Used in instruction addressing modes
    }

type VirtualHpOffset = WordOff


{- Note [Virtual and real heap pointers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The code generator can allocate one or more objects contiguously, performing
one heap check to cover allocation of all the objects at once.  Let's call
this little chunk of heap space an "allocation chunk".  The code generator
will emit code to
  * Perform a heap-exhaustion check
  * Move the heap pointer to the end of the allocation chunk
  * Allocate multiple objects within the chunk

The code generator uses VirtualHpOffsets to address words within a
single allocation chunk; these start at one and increase positively.
The first word of the chunk has VirtualHpOffset=1, the second has
VirtualHpOffset=2, and so on.

 * The field realHp tracks (the VirtualHpOffset) where the real Hp
   register is pointing.  Typically it'll be pointing to the end of the
   allocation chunk.

 * The field virtHp gives the VirtualHpOffset of the highest-allocated
   word so far.  It starts at zero (meaning no word has been allocated),
   and increases whenever an object is allocated.

The difference between realHp and virtHp gives the offset from the
real Hp register of a particular word in the allocation chunk. This
is what getHpRelOffset does.  Since the returned offset is relative
to the real Hp register, it is valid only until you change the real
Hp register.  (Changing virtHp doesn't matter.)
-}


initCgState :: UniqSupply -> CgState
initCgState :: UniqSupply -> CgState
initCgState UniqSupply
uniqs
  = MkCgState { cgs_stmts :: CmmAGraph
cgs_stmts  = CmmAGraph
mkNop
              , cgs_tops :: OrdList DCmmDecl
cgs_tops   = OrdList DCmmDecl
forall a. OrdList a
nilOL
              , cgs_binds :: CgBindings
cgs_binds  = CgBindings
forall a. VarEnv a
emptyVarEnv
              , cgs_hp_usg :: HeapUsage
cgs_hp_usg = HeapUsage
initHpUsage
              , cgs_uniqs :: UniqSupply
cgs_uniqs  = UniqSupply
uniqs }

stateIncUsage :: CgState -> CgState -> CgState
-- stateIncUsage@ e1 e2 incorporates in e1
-- the heap high water mark found in e2.
stateIncUsage :: CgState -> CgState -> CgState
stateIncUsage CgState
s1 s2 :: CgState
s2@(MkCgState { cgs_hp_usg :: CgState -> HeapUsage
cgs_hp_usg = HeapUsage
hp_usg })
     = CgState
s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
       CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
s2

addCodeBlocksFrom :: CgState -> CgState -> CgState
-- Add code blocks from the latter to the former
-- (The cgs_stmts will often be empty, but not always; see codeOnly)
CgState
s1 addCodeBlocksFrom :: CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
s2
  = CgState
s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,
         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }

-- The heap high water mark is the larger of virtHp and hwHp.  The latter is
-- only records the high water marks of forked-off branches, so to find the
-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
-- virtHp never retreats!
--
-- Note Jan 04: ok, so why do we only look at the virtual Hp??

heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = HeapUsage -> VirtualHpOffset
virtHp

initHpUsage :: HeapUsage
initHpUsage :: HeapUsage
initHpUsage = HeapUsage { virtHp :: VirtualHpOffset
virtHp = VirtualHpOffset
0, realHp :: VirtualHpOffset
realHp = VirtualHpOffset
0 }

maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
HeapUsage
hp_usg maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
`maxHpHw` VirtualHpOffset
hw = HeapUsage
hp_usg { virtHp = virtHp hp_usg `max` hw }

--------------------------------------------------------
-- Operators for getting and setting the state and "stgToCmmConfig".
--------------------------------------------------------

getState :: FCode CgState
getState :: FCode CgState
getState = (StgToCmmConfig -> FCodeState -> CgState -> (CgState, CgState))
-> FCode CgState
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (CgState, CgState))
 -> FCode CgState)
-> (StgToCmmConfig -> FCodeState -> CgState -> (CgState, CgState))
-> FCode CgState
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
_cfg FCodeState
_fstate CgState
state -> (CgState
state, CgState
state)

setState :: CgState -> FCode ()
setState :: CgState -> FCode ()
setState CgState
state = (StgToCmmConfig -> FCodeState -> CgState -> ((), CgState))
-> FCode ()
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> ((), CgState))
 -> FCode ())
-> (StgToCmmConfig -> FCodeState -> CgState -> ((), CgState))
-> FCode ()
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
_cfg FCodeState
_fstate CgState
_ -> ((), CgState
state)

getHpUsage :: FCode HeapUsage
getHpUsage :: FCode HeapUsage
getHpUsage = do
        state <- FCode CgState
getState
        return $ cgs_hp_usg state

setHpUsage :: HeapUsage -> FCode ()
setHpUsage :: HeapUsage -> FCode ()
setHpUsage HeapUsage
new_hp_usg = do
        state <- FCode CgState
getState
        setState $ state {cgs_hp_usg = new_hp_usg}

setVirtHp :: VirtualHpOffset -> FCode ()
setVirtHp :: VirtualHpOffset -> FCode ()
setVirtHp VirtualHpOffset
new_virtHp
  = do  { hp_usage <- FCode HeapUsage
getHpUsage
        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }

getVirtHp :: FCode VirtualHpOffset
getVirtHp :: FCode VirtualHpOffset
getVirtHp
  = do  { hp_usage <- FCode HeapUsage
getHpUsage
        ; return (virtHp hp_usage) }

setRealHp ::  VirtualHpOffset -> FCode ()
setRealHp :: VirtualHpOffset -> FCode ()
setRealHp VirtualHpOffset
new_realHp
  = do  { hp_usage <- FCode HeapUsage
getHpUsage
        ; setHpUsage (hp_usage {realHp = new_realHp}) }

getBinds :: FCode CgBindings
getBinds :: FCode CgBindings
getBinds = do
        state <- FCode CgState
getState
        return $ cgs_binds state

setBinds :: CgBindings -> FCode ()
setBinds :: CgBindings -> FCode ()
setBinds CgBindings
new_binds = do
        state <- FCode CgState
getState
        setState $ state {cgs_binds = new_binds}

withCgState :: FCode a -> CgState -> FCode (a,CgState)
withCgState :: forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState (FCode StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
fcode) CgState
newstate = (StgToCmmConfig
 -> FCodeState -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState)
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig
  -> FCodeState -> CgState -> ((a, CgState), CgState))
 -> FCode (a, CgState))
-> (StgToCmmConfig
    -> FCodeState -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState)
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
cfg FCodeState
fstate CgState
state ->
  case StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
fcode StgToCmmConfig
cfg FCodeState
fstate CgState
newstate of
    (a
retval, CgState
state2) -> ((a
retval,CgState
state2), CgState
state)

newUniqSupply :: FCode UniqSupply
newUniqSupply :: FCode UniqSupply
newUniqSupply = do
        state <- FCode CgState
getState
        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
        setState $ state { cgs_uniqs = us1 }
        return us2

newUnique :: FCode Unique
newUnique :: FCode Unique
newUnique = do
        state <- FCode CgState
getState
        let (u,us') = takeUniqFromSupply (cgs_uniqs state)
        setState $ state { cgs_uniqs = us' }
        return u

newTemp :: DSM.MonadGetUnique m => CmmType -> m LocalReg
newTemp :: forall (m :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp CmmType
rep = do { uniq <- m Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
DSM.getUniqueM
                 ; return (LocalReg uniq rep) }

------------------
initFCodeState :: Platform -> FCodeState
initFCodeState :: Platform -> FCodeState
initFCodeState Platform
p =
  MkFCodeState { fcs_upframeoffset :: VirtualHpOffset
fcs_upframeoffset = Platform -> VirtualHpOffset
platformWordSizeInBytes Platform
p
               , fcs_sequel :: Sequel
fcs_sequel        = Sequel
Return
               , fcs_selfloop :: Maybe SelfLoopInfo
fcs_selfloop      = Maybe SelfLoopInfo
forall a. Maybe a
Nothing
               , fcs_ticky :: CLabel
fcs_ticky         = CLabel
mkTopTickyCtrLabel
               , fcs_tickscope :: CmmTickScope
fcs_tickscope     = CmmTickScope
GlobalScope
               }

getFCodeState :: FCode FCodeState
getFCodeState :: FCode FCodeState
getFCodeState = (StgToCmmConfig -> FCodeState -> CgState -> (FCodeState, CgState))
-> FCode FCodeState
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (FCodeState, CgState))
 -> FCode FCodeState)
-> (StgToCmmConfig
    -> FCodeState -> CgState -> (FCodeState, CgState))
-> FCode FCodeState
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
_ FCodeState
fstate CgState
state -> (FCodeState
fstate,CgState
state)

-- basically local for the reader monad
withFCodeState :: FCode a -> FCodeState -> FCode a
withFCodeState :: forall a. FCode a -> FCodeState -> FCode a
withFCodeState (FCode StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
fcode) FCodeState
fst = (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
 -> FCode a)
-> (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
cfg FCodeState
_ CgState
state -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
fcode StgToCmmConfig
cfg FCodeState
fst CgState
state

getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop = FCodeState -> Maybe SelfLoopInfo
fcs_selfloop (FCodeState -> Maybe SelfLoopInfo)
-> FCode FCodeState -> FCode (Maybe SelfLoopInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode FCodeState
getFCodeState

withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop :: forall a. SelfLoopInfo -> FCode a -> FCode a
withSelfLoop SelfLoopInfo
self_loop FCode a
code = do
        fstate <- FCode FCodeState
getFCodeState
        withFCodeState code (fstate {fcs_selfloop = Just self_loop})

-- ----------------------------------------------------------------------------
-- Get/set the end-of-block info

withSequel :: Sequel -> FCode a -> FCode a
withSequel :: forall a. Sequel -> FCode a -> FCode a
withSequel Sequel
sequel FCode a
code
  = do  { fstate <- FCode FCodeState
getFCodeState
        ; withFCodeState code (fstate { fcs_sequel = sequel
                                      , fcs_selfloop = Nothing }) }

getSequel :: FCode Sequel
getSequel :: FCode Sequel
getSequel = FCodeState -> Sequel
fcs_sequel (FCodeState -> Sequel) -> FCode FCodeState -> FCode Sequel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode FCodeState
getFCodeState

-- ----------------------------------------------------------------------------
-- Get/set the size of the update frame

-- We keep track of the size of the update frame so that we
-- can set the stack pointer to the proper address on return
-- (or tail call) from the closure.
-- There should be at most one update frame for each closure.
-- Note: I'm including the size of the original return address
-- in the size of the update frame -- hence the default case on `get'.

withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
withUpdFrameOff :: forall a. VirtualHpOffset -> FCode a -> FCode a
withUpdFrameOff VirtualHpOffset
size FCode a
code
  = do  { fstate <- FCode FCodeState
getFCodeState
        ; withFCodeState code (fstate {fcs_upframeoffset = size }) }

getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff :: FCode VirtualHpOffset
getUpdFrameOff = FCodeState -> VirtualHpOffset
fcs_upframeoffset (FCodeState -> VirtualHpOffset)
-> FCode FCodeState -> FCode VirtualHpOffset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode FCodeState
getFCodeState

-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label

getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = FCodeState -> CLabel
fcs_ticky (FCodeState -> CLabel) -> FCode FCodeState -> FCode CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode FCodeState
getFCodeState

setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel :: forall a. CLabel -> FCode a -> FCode a
setTickyCtrLabel CLabel
ticky FCode a
code = do
        fstate <- FCode FCodeState
getFCodeState
        withFCodeState code (fstate {fcs_ticky = ticky})

-- ----------------------------------------------------------------------------
-- Manage tick scopes

-- | The current tick scope. We will assign this to generated blocks.
getTickScope :: FCode CmmTickScope
getTickScope :: FCode CmmTickScope
getTickScope = FCodeState -> CmmTickScope
fcs_tickscope (FCodeState -> CmmTickScope)
-> FCode FCodeState -> FCode CmmTickScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode FCodeState
getFCodeState

-- | Places blocks generated by the given code into a fresh
-- (sub-)scope. This will make sure that Cmm annotations in our scope
-- will apply to the Cmm blocks generated therein - but not the other
-- way around.
tickScope :: FCode a -> FCode a
tickScope :: forall a. FCode a -> FCode a
tickScope FCode a
code = do
        cfg <- FCode StgToCmmConfig
getStgToCmmConfig
        fstate <- getFCodeState
        if not $ stgToCmmEmitDebugInfo cfg then code else do
          u <- newUnique
          let scope' = Unique -> CmmTickScope -> CmmTickScope
SubScope Unique
u (FCodeState -> CmmTickScope
fcs_tickscope FCodeState
fstate)
          withFCodeState code fstate{ fcs_tickscope = scope' }

-- ----------------------------------------------------------------------------
-- Config related helpers

getStgToCmmConfig :: FCode StgToCmmConfig
getStgToCmmConfig :: FCode StgToCmmConfig
getStgToCmmConfig = (StgToCmmConfig
 -> FCodeState -> CgState -> (StgToCmmConfig, CgState))
-> FCode StgToCmmConfig
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode ((StgToCmmConfig
  -> FCodeState -> CgState -> (StgToCmmConfig, CgState))
 -> FCode StgToCmmConfig)
-> (StgToCmmConfig
    -> FCodeState -> CgState -> (StgToCmmConfig, CgState))
-> FCode StgToCmmConfig
forall a b. (a -> b) -> a -> b
$ \StgToCmmConfig
cfg FCodeState
_ CgState
state -> (StgToCmmConfig
cfg,CgState
state)

getProfile :: FCode Profile
getProfile :: FCode Profile
getProfile = StgToCmmConfig -> Profile
stgToCmmProfile (StgToCmmConfig -> Profile)
-> FCode StgToCmmConfig -> FCode Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig

getPlatform :: FCode Platform
getPlatform :: FCode Platform
getPlatform = Profile -> Platform
profilePlatform (Profile -> Platform) -> FCode Profile -> FCode Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
getProfile

getContext :: FCode SDocContext
getContext :: FCode SDocContext
getContext = StgToCmmConfig -> SDocContext
stgToCmmContext (StgToCmmConfig -> SDocContext)
-> FCode StgToCmmConfig -> FCode SDocContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig

-- ----------------------------------------------------------------------------
-- Get the current module name

getModuleName :: FCode Module
getModuleName :: FCode Module
getModuleName = StgToCmmConfig -> Module
stgToCmmThisModule (StgToCmmConfig -> Module) -> FCode StgToCmmConfig -> FCode Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig


--------------------------------------------------------
--                 Forking
--------------------------------------------------------

forkClosureBody :: FCode () -> FCode ()
-- forkClosureBody compiles body_code in environment where:
--   - sequel, update stack frame and self loop info are
--     set to fresh values
--   - state is set to a fresh value, except for local bindings
--     that are passed in unchanged. It's up to the enclosed code to
--     re-bind the free variables to a field of the closure.

forkClosureBody :: FCode () -> FCode ()
forkClosureBody FCode ()
body_code
  = do  { platform <- FCode Platform
getPlatform
        ; cfg      <- getStgToCmmConfig
        ; fstate   <- getFCodeState
        ; us       <- newUniqSupply
        ; state    <- getState
        ; let fcs = FCodeState
fstate { fcs_sequel        = Return
                           , fcs_upframeoffset = platformWordSizeInBytes platform
                           , fcs_selfloop      = Nothing
                           }
              fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds = cgs_binds state }
              ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in
        ; setState $ state `addCodeBlocksFrom` fork_state_out }

forkLneBody :: FCode a -> FCode a
-- 'forkLneBody' takes a body of let-no-escape binding and compiles
-- it in the *current* environment, returning the graph thus constructed.
--
-- The current environment is passed on completely unchanged to
-- the successor.  In particular, any heap usage from the enclosed
-- code is discarded; it should deal with its own heap consumption.
forkLneBody :: forall a. FCode a -> FCode a
forkLneBody FCode a
body_code
  = do  { cfg   <- FCode StgToCmmConfig
getStgToCmmConfig
        ; us    <- newUniqSupply
        ; state <- getState
        ; fstate <- getFCodeState
        ; let fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds = cgs_binds state }
              (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in
        ; setState $ state `addCodeBlocksFrom` fork_state_out
        ; return result }

codeOnly :: FCode () -> FCode ()
-- Emit any code from the inner thing into the outer thing
-- Do not affect anything else in the outer state
-- Used in almost-circular code to prevent false loop dependencies
codeOnly :: FCode () -> FCode ()
codeOnly FCode ()
body_code
  = do  { cfg   <- FCode StgToCmmConfig
getStgToCmmConfig
        ; us    <- newUniqSupply
        ; state <- getState
        ; fstate <- getFCodeState
        ; let   fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds   = cgs_binds state
                                                 , cgs_hp_usg  = cgs_hp_usg state }
                ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in
        ; setState $ state `addCodeBlocksFrom` fork_state_out }

forkAlts :: [FCode a] -> FCode [a]
-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
-- an fcode for the default case 'd', and compiles each in the current
-- environment.  The current environment is passed on unmodified, except
-- that the virtual Hp is moved on to the worst virtual Hp for the branches

forkAlts :: forall a. [FCode a] -> FCode [a]
forkAlts [FCode a]
branch_fcodes
  = do  { cfg   <- FCode StgToCmmConfig
getStgToCmmConfig
        ; us    <- newUniqSupply
        ; state <- getState
        ; fstate <- getFCodeState
        ; let compile UniqSupply
us FCode a
branch
                = (UniqSupply
us2, FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode a
branch StgToCmmConfig
cfg FCodeState
fstate CgState
branch_state)
                where
                  (UniqSupply
us1,UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
                  branch_state :: CgState
branch_state = (UniqSupply -> CgState
initCgState UniqSupply
us1) {
                                        cgs_binds  = cgs_binds state
                                      , cgs_hp_usg = cgs_hp_usg state }
              (_us, results) = mapAccumL compile us branch_fcodes
              (branch_results, branch_out_states) = unzip results
        ; setState $ foldl' stateIncUsage state branch_out_states
                -- NB foldl.  state is the *left* argument to stateIncUsage
        ; return branch_results }

forkAltPair :: FCode a -> FCode a -> FCode (a,a)
-- Most common use of 'forkAlts'; having this helper function avoids
-- accidental use of failible pattern-matches in @do@-notation
forkAltPair :: forall a. FCode a -> FCode a -> FCode (a, a)
forkAltPair FCode a
x FCode a
y = do
  xy' <- [FCode a] -> FCode [a]
forall a. [FCode a] -> FCode [a]
forkAlts [FCode a
x,FCode a
y]
  case xy' of
    [a
x',a
y'] -> (a, a) -> FCode (a, a)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x',a
y')
    [a]
_ -> String -> FCode (a, a)
forall a. HasCallStack => String -> a
panic String
"forkAltPair"

-- collect the code emitted by an FCode computation
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR :: forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR FCode a
fcode
  = do  { state1 <- FCode CgState
getState
        ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop })
        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
        ; return (a, cgs_stmts state2) }

getCode :: FCode a -> FCode CmmAGraph
getCode :: forall a. FCode a -> FCode CmmAGraph
getCode FCode a
fcode = do { (_,stmts) <- FCode a -> FCode (a, CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR FCode a
fcode; return stmts }

-- | Generate code into a fresh tick (sub-)scope and gather generated code
getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped :: forall a. FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped FCode a
fcode
  = do  { state1 <- FCode CgState
getState
        ; ((a, tscope), state2) <-
            tickScope $
            flip withCgState state1 { cgs_stmts = mkNop } $
            do { a   <- fcode
               ; scp <- getTickScope
               ; return (a, scp) }
        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
        ; return (a, (cgs_stmts state2, tscope)) }


-- 'getHeapUsage' applies a function to the amount of heap that it uses.
-- It initialises the heap usage to zeros, and passes on an unchanged
-- heap usage.
--
-- It is usually a prelude to performing a GC check, so everything must
-- be in a tidy and consistent state.
--
-- Note the slightly subtle fixed point behaviour needed here

getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
getHeapUsage :: forall a. (VirtualHpOffset -> FCode a) -> FCode a
getHeapUsage VirtualHpOffset -> FCode a
fcode
  = do  { cfg <- FCode StgToCmmConfig
getStgToCmmConfig
        ; state <- getState
        ; fcstate <- getFCodeState
        ; let   fstate_in = CgState
state { cgs_hp_usg  = initHpUsage }
                (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in
                hp_hw = HeapUsage -> VirtualHpOffset
heapHWM (CgState -> HeapUsage
cgs_hp_usg CgState
fstate_out)        -- Loop here!

        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
        ; return r }

-- ----------------------------------------------------------------------------
-- Combinators for emitting code

emitCgStmt :: CgStmt -> FCode ()
emitCgStmt :: CgStmt -> FCode ()
emitCgStmt CgStmt
stmt
  = do  { state <- FCode CgState
getState
        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
        }

emitLabel :: BlockId -> FCode ()
emitLabel :: BlockId -> FCode ()
emitLabel BlockId
id = do tscope <- FCode CmmTickScope
getTickScope
                  emitCgStmt (CgLabel id tscope)

emitComment :: FastString -> FCode ()
emitComment :: FastString -> FCode ()
emitComment FastString
s
  | Bool
debugIsOn = CgStmt -> FCode ()
emitCgStmt (CmmNode O O -> CgStmt
CgStmt (FastString -> CmmNode O O
CmmComment FastString
s))
  | Bool
otherwise = () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

emitTick :: CmmTickish -> FCode ()
emitTick :: CmmTickish -> FCode ()
emitTick = CgStmt -> FCode ()
emitCgStmt (CgStmt -> FCode ())
-> (CmmTickish -> CgStmt) -> CmmTickish -> FCode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode O O -> CgStmt
CgStmt (CmmNode O O -> CgStmt)
-> (CmmTickish -> CmmNode O O) -> CmmTickish -> CgStmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmTickish -> CmmNode O O
CmmTick

emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
emitUnwind [(GlobalReg, Maybe CmmExpr)]
regs = do
  debug <- StgToCmmConfig -> Bool
stgToCmmEmitDebugInfo (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
  when debug $
     emitCgStmt $ CgStmt $ CmmUnwind regs

emitAssign :: CmmReg  -> CmmExpr -> FCode ()
emitAssign :: CmmReg -> CmmExpr -> FCode ()
emitAssign CmmReg
l CmmExpr
r = CgStmt -> FCode ()
emitCgStmt (CmmNode O O -> CgStmt
CgStmt (CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
l CmmExpr
r))

-- | Assumes natural alignment.
emitStore :: CmmExpr -> CmmExpr -> FCode ()
emitStore :: CmmExpr -> CmmExpr -> FCode ()
emitStore = AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()
emitStore' AlignmentSpec
NaturallyAligned

emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()
emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()
emitStore' AlignmentSpec
alignment CmmExpr
l CmmExpr
r = CgStmt -> FCode ()
emitCgStmt (CmmNode O O -> CgStmt
CgStmt (CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore CmmExpr
l CmmExpr
r AlignmentSpec
alignment))

emit :: CmmAGraph -> FCode ()
emit :: CmmAGraph -> FCode ()
emit CmmAGraph
ag
  = do  { state <- FCode CgState
getState
        ; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } }

emitDecl :: DCmmDecl -> FCode ()
emitDecl :: DCmmDecl -> FCode ()
emitDecl DCmmDecl
decl
  = do  { state <- FCode CgState
getState
        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }

emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
l (CmmAGraph
stmts, CmmTickScope
tscope) = CgStmt -> FCode ()
emitCgStmt (BlockId -> CmmAGraph -> CmmTickScope -> CgStmt
CgFork BlockId
l CmmAGraph
stmts CmmTickScope
tscope)

emitProcWithStackFrame
   :: Convention                        -- entry convention
   -> Maybe CmmInfoTable                -- info table?
   -> CLabel                            -- label for the proc
   -> [CmmFormal]                       -- stack frame
   -> [CmmFormal]                       -- arguments
   -> CmmAGraphScoped                   -- code
   -> Bool                              -- do stack layout?
   -> FCode ()

emitProcWithStackFrame :: Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> [LocalReg]
-> CmmAGraphScoped
-> Bool
-> FCode ()
emitProcWithStackFrame Convention
_conv Maybe CmmInfoTable
mb_info CLabel
lbl [LocalReg]
_stk_args [] CmmAGraphScoped
blocks Bool
False
  = do  { platform <- FCode Platform
getPlatform
        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False
        }
emitProcWithStackFrame Convention
conv Maybe CmmInfoTable
mb_info CLabel
lbl [LocalReg]
stk_args [LocalReg]
args (CmmAGraph
graph, CmmTickScope
tscope) Bool
True
        -- do layout
  = do  { profile <- FCode Profile
getProfile
        ; let (offset, live, entry) = mkCallEntry profile conv args stk_args
              graph' = CmmAGraph
entry CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> CmmAGraph
graph
        ; emitProc mb_info lbl live (graph', tscope) offset True
        }
emitProcWithStackFrame Convention
_ Maybe CmmInfoTable
_ CLabel
_ [LocalReg]
_ [LocalReg]
_ CmmAGraphScoped
_ Bool
_ = String -> FCode ()
forall a. HasCallStack => String -> a
panic String
"emitProcWithStackFrame"

emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
                       -> [CmmFormal]
                       -> CmmAGraphScoped
                       -> FCode ()
emitProcWithConvention :: Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention Convention
conv Maybe CmmInfoTable
mb_info CLabel
lbl [LocalReg]
args CmmAGraphScoped
blocks
  = Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> [LocalReg]
-> CmmAGraphScoped
-> Bool
-> FCode ()
emitProcWithStackFrame Convention
conv Maybe CmmInfoTable
mb_info CLabel
lbl [] [LocalReg]
args CmmAGraphScoped
blocks Bool
True

emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalRegUse] -> CmmAGraphScoped
         -> Int -> Bool -> FCode ()
emitProc :: Maybe CmmInfoTable
-> CLabel
-> [GlobalRegUse]
-> CmmAGraphScoped
-> VirtualHpOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalRegUse]
live CmmAGraphScoped
blocks VirtualHpOffset
offset Bool
do_layout
  = do  { l <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
        ; let
              blks :: DCmmGraph
              blks = BlockId -> CmmAGraphScoped -> DCmmGraph
labelAGraph BlockId
l CmmAGraphScoped
blocks

              infos | Just CmmInfoTable
info <- Maybe CmmInfoTable
mb_info = [((DCmmGraph -> BlockId
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> BlockId
g_entry DCmmGraph
blks), CmmInfoTable
info)]
                    | Bool
otherwise            = []

              sinfo = StackInfo { arg_space :: VirtualHpOffset
arg_space = VirtualHpOffset
offset
                                , do_layout :: Bool
do_layout = Bool
do_layout }

              tinfo = TopInfo { info_tbls :: DWrap CmmInfoTable
info_tbls = [(BlockId, CmmInfoTable)] -> DWrap CmmInfoTable
forall a. [(BlockId, a)] -> DWrap a
DWrap [(BlockId, CmmInfoTable)]
infos
                              , stack_info :: CmmStackInfo
stack_info=CmmStackInfo
sinfo}

              proc_block = GenCmmTopInfo DWrap
-> CLabel -> [GlobalRegUse] -> DCmmGraph -> DCmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc GenCmmTopInfo DWrap
tinfo CLabel
lbl [GlobalRegUse]
live DCmmGraph
blks

        ; state <- getState
        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }

getCmm :: FCode a -> FCode (a, DCmmGroup)
-- Get all the CmmTops (there should be no stmts)
-- Return a single Cmm which may be split from other Cmms by
-- object splitting (at a later stage)
getCmm :: forall a. FCode a -> FCode (a, DCmmGroup)
getCmm FCode a
code
  = do  { state1 <- FCode CgState
getState
        ; (a, state2) <- withCgState code (state1 { cgs_tops  = nilOL })
        ; setState $ state2 { cgs_tops = cgs_tops state1 }
        ; return (a, fromOL (cgs_tops state2)) }


mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse CmmExpr
e CmmAGraph
tbranch CmmAGraph
fbranch = CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' CmmExpr
e CmmAGraph
tbranch CmmAGraph
fbranch Maybe Bool
forall a. Maybe a
Nothing

mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
                 -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' CmmExpr
e CmmAGraph
tbranch CmmAGraph
fbranch Maybe Bool
likely = do
  tscp  <- FCode CmmTickScope
getTickScope
  endif <- newBlockId
  tid   <- newBlockId
  fid   <- newBlockId

  let
    (test, then_, else_, likely') = case likely of
      Just Bool
False | Just CmmExpr
e' <- CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr CmmExpr
e
        -- currently NCG doesn't know about likely
        -- annotations. We manually switch then and
        -- else branch so the likely false branch
        -- becomes a fallthrough.
        -> (CmmExpr
e', CmmAGraph
fbranch, CmmAGraph
tbranch, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
      Maybe Bool
_ -> (CmmExpr
e, CmmAGraph
tbranch, CmmAGraph
fbranch, Maybe Bool
likely)

  return $ catAGraphs [ mkCbranch test tid fid likely'
                      , mkLabel tid tscp, then_, mkBranch endif
                      , mkLabel fid tscp, else_, mkLabel endif tscp ]

mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
mkCmmIfGoto CmmExpr
e BlockId
tid = CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
mkCmmIfGoto' CmmExpr
e BlockId
tid Maybe Bool
forall a. Maybe a
Nothing

mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
mkCmmIfGoto' CmmExpr
e BlockId
tid Maybe Bool
l = do
  endif <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
  tscp  <- getTickScope
  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]

mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen CmmExpr
e CmmAGraph
tbranch = CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThen' CmmExpr
e CmmAGraph
tbranch Maybe Bool
forall a. Maybe a
Nothing

mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThen' CmmExpr
e CmmAGraph
tbranch Maybe Bool
l = do
  endif <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
  tid   <- newBlockId
  tscp  <- getTickScope
  return $ catAGraphs [ mkCbranch e tid endif l
                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]

mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
mkCall :: CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> VirtualHpOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
f (Convention
callConv, Convention
retConv) [LocalReg]
results [CmmExpr]
actuals VirtualHpOffset
updfr_off [CmmExpr]
extra_stack = do
  profile <- FCode Profile
getProfile
  k       <- newBlockId
  tscp    <- getTickScope
  let area = BlockId -> Area
Young BlockId
k
      (off, _, copyin) = copyInOflow profile retConv area results []
      copyout = Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> VirtualHpOffset
-> VirtualHpOffset
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo Profile
profile CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
k VirtualHpOffset
off VirtualHpOffset
updfr_off [CmmExpr]
extra_stack
  return $ catAGraphs [copyout, mkLabel k tscp, copyin]

mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
          -> FCode CmmAGraph
mkCmmCall :: CmmExpr
-> [LocalReg] -> [CmmExpr] -> VirtualHpOffset -> FCode CmmAGraph
mkCmmCall CmmExpr
f [LocalReg]
results [CmmExpr]
actuals VirtualHpOffset
updfr_off
   = CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> VirtualHpOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
f (Convention
NativeDirectCall, Convention
NativeReturn) [LocalReg]
results [CmmExpr]
actuals VirtualHpOffset
updfr_off []


-- ----------------------------------------------------------------------------
-- turn CmmAGraph into CmmGraph, for making a new proc.

aGraphToGraph :: CmmAGraphScoped -> FCode DCmmGraph
aGraphToGraph :: CmmAGraphScoped -> FCode DCmmGraph
aGraphToGraph CmmAGraphScoped
stmts
  = do  { l <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
        ; return (labelAGraph l stmts) }