{-# 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,

        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.Dataflow.Collections
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 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' })

initC :: IO CgState
initC :: IO CgState
initC  = do { UniqSupply
uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'c'
            ; CgState -> IO CgState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> CgState
initCgState UniqSupply
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 CmmDecl
cgs_tops  :: OrdList CmmDecl,
        -- 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 CmmDecl
cgs_tops   = OrdList CmmDecl
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
        CgState
state <- FCode CgState
getState
        HeapUsage -> FCode HeapUsage
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapUsage -> FCode HeapUsage) -> HeapUsage -> FCode HeapUsage
forall a b. (a -> b) -> a -> b
$ CgState -> HeapUsage
cgs_hp_usg CgState
state

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

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

getVirtHp :: FCode VirtualHpOffset
getVirtHp :: FCode VirtualHpOffset
getVirtHp
  = do  { HeapUsage
hp_usage <- FCode HeapUsage
getHpUsage
        ; VirtualHpOffset -> FCode VirtualHpOffset
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapUsage -> VirtualHpOffset
virtHp HeapUsage
hp_usage) }

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

getBinds :: FCode CgBindings
getBinds :: FCode CgBindings
getBinds = do
        CgState
state <- FCode CgState
getState
        CgBindings -> FCode CgBindings
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgBindings -> FCode CgBindings) -> CgBindings -> FCode CgBindings
forall a b. (a -> b) -> a -> b
$ CgState -> CgBindings
cgs_binds CgState
state

setBinds :: CgBindings -> FCode ()
setBinds :: CgBindings -> FCode ()
setBinds CgBindings
new_binds = do
        CgState
state <- FCode CgState
getState
        CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
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
        CgState
state <- FCode CgState
getState
        let (UniqSupply
us1, UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (CgState -> UniqSupply
cgs_uniqs CgState
state)
        CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs = us1 }
        UniqSupply -> FCode UniqSupply
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us2

newUnique :: FCode Unique
newUnique :: FCode Unique
newUnique = do
        CgState
state <- FCode CgState
getState
        let (Unique
u,UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (CgState -> UniqSupply
cgs_uniqs CgState
state)
        CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs = us' }
        Unique -> FCode Unique
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
u

newTemp :: MonadUnique m => CmmType -> m LocalReg
newTemp :: forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp CmmType
rep = do { Unique
uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                 ; LocalReg -> m LocalReg
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> CmmType -> LocalReg
LocalReg Unique
uniq CmmType
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
        FCodeState
fstate <- FCode FCodeState
getFCodeState
        FCode a -> FCodeState -> FCode a
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
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  { FCodeState
fstate <- FCode FCodeState
getFCodeState
        ; FCode a -> FCodeState -> FCode a
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
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  { FCodeState
fstate <- FCode FCodeState
getFCodeState
        ; FCode a -> FCodeState -> FCode a
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
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
        FCodeState
fstate <- FCode FCodeState
getFCodeState
        FCode a -> FCodeState -> FCode a
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
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
        StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
        FCodeState
fstate <- FCode FCodeState
getFCodeState
        if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ StgToCmmConfig -> Bool
stgToCmmEmitDebugInfo StgToCmmConfig
cfg then FCode a
code else do
          Unique
u <- FCode Unique
newUnique
          let scope' :: CmmTickScope
scope' = Unique -> CmmTickScope -> CmmTickScope
SubScope Unique
u (FCodeState -> CmmTickScope
fcs_tickscope FCodeState
fstate)
          FCode a -> FCodeState -> FCode a
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code FCodeState
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
platform <- FCode Platform
getPlatform
        ; StgToCmmConfig
cfg      <- FCode StgToCmmConfig
getStgToCmmConfig
        ; FCodeState
fstate   <- FCode FCodeState
getFCodeState
        ; UniqSupply
us       <- FCode UniqSupply
newUniqSupply
        ; CgState
state    <- FCode CgState
getState
        ; let fcs :: FCodeState
fcs = FCodeState
fstate { fcs_sequel        = Return
                           , fcs_upframeoffset = platformWordSizeInBytes platform
                           , fcs_selfloop      = Nothing
                           }
              fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds = cgs_binds state }
              ((),CgState
fork_state_out) = FCode ()
-> StgToCmmConfig -> FCodeState -> CgState -> ((), CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode ()
body_code StgToCmmConfig
cfg FCodeState
fcs CgState
fork_state_in
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
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  { StgToCmmConfig
cfg   <- FCode StgToCmmConfig
getStgToCmmConfig
        ; UniqSupply
us    <- FCode UniqSupply
newUniqSupply
        ; CgState
state <- FCode CgState
getState
        ; FCodeState
fstate <- FCode FCodeState
getFCodeState
        ; let fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds = cgs_binds state }
              (a
result, CgState
fork_state_out) = FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode a
body_code StgToCmmConfig
cfg FCodeState
fstate CgState
fork_state_in
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
fork_state_out
        ; a -> FCode a
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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  { StgToCmmConfig
cfg   <- FCode StgToCmmConfig
getStgToCmmConfig
        ; UniqSupply
us    <- FCode UniqSupply
newUniqSupply
        ; CgState
state <- FCode CgState
getState
        ; FCodeState
fstate <- FCode FCodeState
getFCodeState
        ; let   fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds   = cgs_binds state
                                                 , cgs_hp_usg  = cgs_hp_usg state }
                ((), CgState
fork_state_out) = FCode ()
-> StgToCmmConfig -> FCodeState -> CgState -> ((), CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode ()
body_code StgToCmmConfig
cfg FCodeState
fstate CgState
fork_state_in
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
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  { StgToCmmConfig
cfg   <- FCode StgToCmmConfig
getStgToCmmConfig
        ; UniqSupply
us    <- FCode UniqSupply
newUniqSupply
        ; CgState
state <- FCode CgState
getState
        ; FCodeState
fstate <- FCode FCodeState
getFCodeState
        ; let compile :: UniqSupply -> FCode a -> (UniqSupply, (a, CgState))
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 }
              (UniqSupply
_us, [(a, CgState)]
results) = (UniqSupply -> FCode a -> (UniqSupply, (a, CgState)))
-> UniqSupply -> [FCode a] -> (UniqSupply, [(a, CgState)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL UniqSupply -> FCode a -> (UniqSupply, (a, CgState))
compile UniqSupply
us [FCode a]
branch_fcodes
              ([a]
branch_results, [CgState]
branch_out_states) = [(a, CgState)] -> ([a], [CgState])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, CgState)]
results
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ (CgState -> CgState -> CgState) -> CgState -> [CgState] -> CgState
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CgState -> CgState -> CgState
stateIncUsage CgState
state [CgState]
branch_out_states
                -- NB foldl.  state is the *left* argument to stateIncUsage
        ; [a] -> FCode [a]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
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
  [a]
xy' <- [FCode a] -> FCode [a]
forall a. [FCode a] -> FCode [a]
forkAlts [FCode a
x,FCode a
y]
  case [a]
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  { CgState
state1 <- FCode CgState
getState
        ; (a
a, CgState
state2) <- FCode a -> CgState -> FCode (a, CgState)
forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState FCode a
fcode (CgState
state1 { cgs_stmts = mkNop })
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts = cgs_stmts state1  }
        ; (a, CmmAGraph) -> FCode (a, CmmAGraph)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, CgState -> CmmAGraph
cgs_stmts CgState
state2) }

getCode :: FCode a -> FCode CmmAGraph
getCode :: forall a. FCode a -> FCode CmmAGraph
getCode FCode a
fcode = do { (a
_,CmmAGraph
stmts) <- FCode a -> FCode (a, CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR FCode a
fcode; CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
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  { CgState
state1 <- FCode CgState
getState
        ; ((a
a, CmmTickScope
tscope), CgState
state2) <-
            FCode ((a, CmmTickScope), CgState)
-> FCode ((a, CmmTickScope), CgState)
forall a. FCode a -> FCode a
tickScope (FCode ((a, CmmTickScope), CgState)
 -> FCode ((a, CmmTickScope), CgState))
-> FCode ((a, CmmTickScope), CgState)
-> FCode ((a, CmmTickScope), CgState)
forall a b. (a -> b) -> a -> b
$
            (FCode (a, CmmTickScope)
 -> CgState -> FCode ((a, CmmTickScope), CgState))
-> CgState
-> FCode (a, CmmTickScope)
-> FCode ((a, CmmTickScope), CgState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip FCode (a, CmmTickScope)
-> CgState -> FCode ((a, CmmTickScope), CgState)
forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState CgState
state1 { cgs_stmts = mkNop } (FCode (a, CmmTickScope) -> FCode ((a, CmmTickScope), CgState))
-> FCode (a, CmmTickScope) -> FCode ((a, CmmTickScope), CgState)
forall a b. (a -> b) -> a -> b
$
            do { a
a   <- FCode a
fcode
               ; CmmTickScope
scp <- FCode CmmTickScope
getTickScope
               ; (a, CmmTickScope) -> FCode (a, CmmTickScope)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, CmmTickScope
scp) }
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts = cgs_stmts state1  }
        ; (a, CmmAGraphScoped) -> FCode (a, CmmAGraphScoped)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, (CgState -> CmmAGraph
cgs_stmts CgState
state2, CmmTickScope
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  { StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
        ; CgState
state <- FCode CgState
getState
        ; FCodeState
fcstate <- FCode FCodeState
getFCodeState
        ; let   fstate_in :: CgState
fstate_in = CgState
state { cgs_hp_usg  = initHpUsage }
                (a
r, CgState
fstate_out) = FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode (VirtualHpOffset -> FCode a
fcode VirtualHpOffset
hp_hw) StgToCmmConfig
cfg FCodeState
fcstate CgState
fstate_in
                hp_hw :: VirtualHpOffset
hp_hw = HeapUsage -> VirtualHpOffset
heapHWM (CgState -> HeapUsage
cgs_hp_usg CgState
fstate_out)        -- Loop here!

        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
fstate_out { cgs_hp_usg = cgs_hp_usg state }
        ; a -> FCode a
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r }

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

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

emitLabel :: BlockId -> FCode ()
emitLabel :: BlockId -> FCode ()
emitLabel BlockId
id = do CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
                  CgStmt -> FCode ()
emitCgStmt (BlockId -> CmmTickScope -> CgStmt
CgLabel BlockId
id CmmTickScope
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
  Bool
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
  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
     CgStmt -> FCode ()
emitCgStmt (CgStmt -> FCode ()) -> CgStmt -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmNode O O -> CgStmt
CgStmt (CmmNode O O -> CgStmt) -> CmmNode O O -> CgStmt
forall a b. (a -> b) -> a -> b
$ [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg, Maybe CmmExpr)]
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  { CgState
state <- FCode CgState
getState
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } }

emitDecl :: CmmDecl -> FCode ()
emitDecl :: CmmDecl -> FCode ()
emitDecl CmmDecl
decl
  = do  { CgState
state <- FCode CgState
getState
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
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
platform <- FCode Platform
getPlatform
        ; Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> VirtualHpOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [] CmmAGraphScoped
blocks (Width -> VirtualHpOffset
widthInBytes (Platform -> Width
wordWidth Platform
platform)) Bool
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
profile <- FCode Profile
getProfile
        ; let (VirtualHpOffset
offset, [GlobalReg]
live, CmmAGraph
entry) = Profile
-> Convention
-> [LocalReg]
-> [LocalReg]
-> (VirtualHpOffset, [GlobalReg], CmmAGraph)
mkCallEntry Profile
profile Convention
conv [LocalReg]
args [LocalReg]
stk_args
              graph' :: CmmAGraph
graph' = CmmAGraph
entry CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> CmmAGraph
graph
        ; Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> VirtualHpOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalReg]
live (CmmAGraph
graph', CmmTickScope
tscope) VirtualHpOffset
offset Bool
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 -> [GlobalReg] -> CmmAGraphScoped
         -> Int -> Bool -> FCode ()
emitProc :: Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> VirtualHpOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalReg]
live CmmAGraphScoped
blocks VirtualHpOffset
offset Bool
do_layout
  = do  { BlockId
l <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
        ; let
              blks :: CmmGraph
              blks :: CmmGraph
blks = BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
l CmmAGraphScoped
blocks

              infos :: LabelMap CmmInfoTable
infos | Just CmmInfoTable
info <- Maybe CmmInfoTable
mb_info = KeyOf LabelMap -> CmmInfoTable -> LabelMap CmmInfoTable
forall a. KeyOf LabelMap -> a -> LabelMap a
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
blks) CmmInfoTable
info
                    | Bool
otherwise            = LabelMap CmmInfoTable
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty

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

              tinfo :: CmmTopInfo
tinfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
infos
                              , stack_info :: CmmStackInfo
stack_info=CmmStackInfo
sinfo}

              proc_block :: CmmDecl
proc_block = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
tinfo CLabel
lbl [GlobalReg]
live CmmGraph
blks

        ; CgState
state <- FCode CgState
getState
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_tops = cgs_tops state `snocOL` proc_block } }

getCmm :: FCode a -> FCode (a, CmmGroup)
-- 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, CmmGroup)
getCmm FCode a
code
  = do  { CgState
state1 <- FCode CgState
getState
        ; (a
a, CgState
state2) <- FCode a -> CgState -> FCode (a, CgState)
forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState FCode a
code (CgState
state1 { cgs_tops  = nilOL })
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_tops = cgs_tops state1 }
        ; (a, CmmGroup) -> FCode (a, CmmGroup)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, OrdList CmmDecl -> CmmGroup
forall a. OrdList a -> [a]
fromOL (CgState -> OrdList CmmDecl
cgs_tops CgState
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
  CmmTickScope
tscp  <- FCode CmmTickScope
getTickScope
  BlockId
endif <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  BlockId
tid   <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  BlockId
fid   <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId

  let
    (CmmExpr
test, CmmAGraph
then_, CmmAGraph
else_, Maybe Bool
likely') = case Maybe Bool
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)

  CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [ CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
test BlockId
tid BlockId
fid Maybe Bool
likely'
                      , BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
tid CmmTickScope
tscp, CmmAGraph
then_, BlockId -> CmmAGraph
mkBranch BlockId
endif
                      , BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
fid CmmTickScope
tscp, CmmAGraph
else_, BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
endif CmmTickScope
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
  BlockId
endif <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  CmmTickScope
tscp  <- FCode CmmTickScope
getTickScope
  CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [ CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
e BlockId
tid BlockId
endif Maybe Bool
l, BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
endif CmmTickScope
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
  BlockId
endif <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  BlockId
tid   <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  CmmTickScope
tscp  <- FCode CmmTickScope
getTickScope
  CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [ CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
e BlockId
tid BlockId
endif Maybe Bool
l
                      , BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
tid CmmTickScope
tscp, CmmAGraph
tbranch, BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
endif CmmTickScope
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
profile <- FCode Profile
getProfile
  BlockId
k       <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  CmmTickScope
tscp    <- FCode CmmTickScope
getTickScope
  let area :: Area
area = BlockId -> Area
Young BlockId
k
      (VirtualHpOffset
off, [GlobalReg]
_, CmmAGraph
copyin) = Profile
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (VirtualHpOffset, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
retConv Area
area [LocalReg]
results []
      copyout :: CmmAGraph
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
  CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [CmmAGraph
copyout, BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
k CmmTickScope
tscp, CmmAGraph
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 CmmGraph
aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
aGraphToGraph CmmAGraphScoped
stmts
  = do  { BlockId
l <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
        ; CmmGraph -> FCode CmmGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
l CmmAGraphScoped
stmts) }