{-# LANGUAGE GADTs #-}

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

module StgCmmMonad (
        FCode,        -- type

        initC, runC, fixC,
        newUnique,

        emitLabel,

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

        getCmm, aGraphToGraph,
        getCodeR, getCode, getCodeScoped, getHeapUsage,

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

        mkCall, mkCmmCall,

        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,

        ConTagZ,

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

        setTickyCtrLabel, getTickyCtrLabel,
        tickScope, getTickScope,

        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,

        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, getInfoDown, getDynFlags, getThisPackage,

        -- more localised access to monad state
        CgIdInfo(..),
        getBinds, setBinds,

        -- out of general friendliness, we also export ...
        CgInfoDownwards(..), CgState(..)        -- non-abstract
    ) where

import GhcPrelude hiding( sequence, succ )

import Cmm
import StgCmmClosure
import DynFlags
import Hoopl.Collections
import MkGraph
import BlockId
import CLabel
import SMRep
import Module
import Id
import VarEnv
import OrdList
import BasicTypes( ConTagZ )
import Unique
import UniqSupply
import FastString
import Outputable
import Util

import Control.Monad
import Data.List



--------------------------------------------------------
-- 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 CgInfoDownwards, containing
--    - DynFlags,
--    - the current Module
--    - the update-frame offset
--    - the ticky counter label
--    - the Sequel (the continuation to return to)
--    - the self-recursive tail call information

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

newtype FCode a = FCode { FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }

instance Functor FCode where
    fmap :: (a -> b) -> FCode a -> FCode b
fmap f :: a -> b
f (FCode g :: CgInfoDownwards -> CgState -> (a, CgState)
g) = (CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b)
-> (CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b
forall a b. (a -> b) -> a -> b
$ \i :: CgInfoDownwards
i s :: CgState
s -> case CgInfoDownwards -> CgState -> (a, CgState)
g CgInfoDownwards
i CgState
s of (a :: a
a, s' :: CgState
s') -> (a -> b
f a
a, CgState
s')

instance Applicative FCode where
    pure :: a -> FCode a
pure val :: a
val = (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode (\_info_down :: CgInfoDownwards
_info_down state :: CgState
state -> (a
val, CgState
state))
    {-# INLINE pure #-}
    <*> :: 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 m :: CgInfoDownwards -> CgState -> (a, CgState)
m >>= :: FCode a -> (a -> FCode b) -> FCode b
>>= k :: a -> FCode b
k = (CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b)
-> (CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b
forall a b. (a -> b) -> a -> b
$
        \info_down :: CgInfoDownwards
info_down state :: CgState
state ->
            case CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
info_down CgState
state of
              (m_result :: a
m_result, new_state :: CgState
new_state) ->
                 case a -> FCode b
k a
m_result of
                   FCode kcode :: CgInfoDownwards -> CgState -> (b, CgState)
kcode -> CgInfoDownwards -> CgState -> (b, CgState)
kcode CgInfoDownwards
info_down 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 = (CgInfoDownwards -> CgState -> (Unique, CgState)) -> FCode Unique
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (Unique, CgState)) -> FCode Unique)
-> (CgInfoDownwards -> CgState -> (Unique, CgState))
-> FCode Unique
forall a b. (a -> b) -> a -> b
$ \_ st :: CgState
st ->
    let (u :: Unique
u, us' :: UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (CgState -> UniqSupply
cgs_uniqs CgState
st)
    in (Unique
u, CgState
st { cgs_uniqs :: UniqSupply
cgs_uniqs = UniqSupply
us' })

initC :: IO CgState
initC :: IO CgState
initC  = do { UniqSupply
uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply 'c'
            ; CgState -> IO CgState
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> CgState
initCgState UniqSupply
uniqs) }

runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC :: DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC dflags :: DynFlags
dflags mod :: Module
mod st :: CgState
st fcode :: FCode a
fcode = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
fcode (DynFlags -> Module -> CgInfoDownwards
initCgInfoDown DynFlags
dflags Module
mod) CgState
st

fixC :: (a -> FCode a) -> FCode a
fixC :: (a -> FCode a) -> FCode a
fixC fcode :: a -> FCode a
fcode = (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a)
-> (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a b. (a -> b) -> a -> b
$
    \info_down :: CgInfoDownwards
info_down state :: CgState
state -> let (v :: a
v, s :: CgState
s) = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode (a -> FCode a
fcode a
v) CgInfoDownwards
info_down CgState
state
                        in (a
v, CgState
s)

--------------------------------------------------------
--        The code generator environment
--------------------------------------------------------

-- This monadery has some information that it only passes
-- *downwards*, as well as some ``state'' which is modified
-- as we go along.

data CgInfoDownwards        -- information only passed *downwards* by the monad
  = MkCgInfoDown {
        CgInfoDownwards -> DynFlags
cgd_dflags    :: DynFlags,
        CgInfoDownwards -> Module
cgd_mod       :: Module,            -- Module being compiled
        CgInfoDownwards -> UpdFrameOffset
cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame
        CgInfoDownwards -> CLabel
cgd_ticky     :: CLabel,            -- Current destination for ticky counts
        CgInfoDownwards -> Sequel
cgd_sequel    :: Sequel,            -- What to do at end of basic block
        CgInfoDownwards -> Maybe SelfLoopInfo
cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled
                                            -- as local jumps? See Note
                                            -- [Self-recursive tail calls] in
                                            -- StgCmmExpr
        CgInfoDownwards -> CmmTickScope
cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks
  }

type CgBindings = IdEnv CgIdInfo

data CgIdInfo
  = CgIdInfo
        { CgIdInfo -> Id
cg_id :: Id   -- Id that this is the info for
                        -- Can differ from the Id at occurrence sites by
                        -- virtue of being externalised, for splittable C
                        -- See Note [Externalise when splitting]
        , CgIdInfo -> LambdaFormInfo
cg_lf  :: LambdaFormInfo
        , CgIdInfo -> CgLoc
cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value
        }

-- Note [Externalise when splitting]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- If we're splitting the object with -fsplit-objs, we need to
-- externalise *all* the top-level names, and then make sure we only
-- use the externalised one in any C label we use which refers to this
-- name.

instance Outputable CgIdInfo where
  ppr :: CgIdInfo -> SDoc
ppr (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
<+> String -> SDoc
text "-->" SDoc -> SDoc -> SDoc
<+> CgLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr CgLoc
loc

-- Sequel tells what to do with the result of this expression
data Sequel
  = Return              -- Return result(s) to continuation found on the stack.

  | AssignTo
        [LocalReg]      -- Put result(s) in these regs and fall through
                        -- NB: no void arguments here
                        --
        Bool            -- Should we adjust the heap pointer back to
                        -- recover space that's unused on this path?
                        -- We need to do this only if the expression
                        -- may allocate (e.g. it's a foreign call or
                        -- allocating primOp)

instance Outputable Sequel where
    ppr :: Sequel -> SDoc
ppr Return = String -> SDoc
text "Return"
    ppr (AssignTo regs :: [LocalReg]
regs b :: Bool
b) = String -> SDoc
text "AssignTo" SDoc -> SDoc -> SDoc
<+> [LocalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocalReg]
regs SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b

-- 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.
--


initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags :: DynFlags
dflags mod :: Module
mod
  = MkCgInfoDown :: DynFlags
-> Module
-> UpdFrameOffset
-> CLabel
-> Sequel
-> Maybe SelfLoopInfo
-> CmmTickScope
-> CgInfoDownwards
MkCgInfoDown { cgd_dflags :: DynFlags
cgd_dflags    = DynFlags
dflags
                 , cgd_mod :: Module
cgd_mod       = Module
mod
                 , cgd_updfr_off :: UpdFrameOffset
cgd_updfr_off = DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags
                 , cgd_ticky :: CLabel
cgd_ticky     = CLabel
mkTopTickyCtrLabel
                 , cgd_sequel :: Sequel
cgd_sequel    = Sequel
initSequel
                 , cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = Maybe SelfLoopInfo
forall a. Maybe a
Nothing
                 , cgd_tick_scope :: CmmTickScope
cgd_tick_scope= CmmTickScope
GlobalScope }

initSequel :: Sequel
initSequel :: Sequel
initSequel = Sequel
Return

initUpdFrameOff :: DynFlags -> UpdFrameOffset
initUpdFrameOff :: DynFlags -> UpdFrameOffset
initUpdFrameOff dflags :: DynFlags
dflags = Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags) -- space for the RA


--------------------------------------------------------
--        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 }

data HeapUsage   -- See Note [Virtual and real heap pointers]
  = HeapUsage {
        HeapUsage -> UpdFrameOffset
virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word
                                         --   Incremented whenever we allocate
        HeapUsage -> UpdFrameOffset
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 uniqs :: UniqSupply
uniqs
  = MkCgState :: CmmAGraph
-> OrdList CmmDecl
-> CgBindings
-> HeapUsage
-> UniqSupply
-> CgState
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 s1 :: CgState
s1 s2 :: CgState
s2@(MkCgState { cgs_hp_usg :: CgState -> HeapUsage
cgs_hp_usg = HeapUsage
hp_usg })
     = CgState
s1 { cgs_hp_usg :: HeapUsage
cgs_hp_usg  = CgState -> HeapUsage
cgs_hp_usg  CgState
s1 HeapUsage -> UpdFrameOffset -> HeapUsage
`maxHpHw`  HeapUsage -> UpdFrameOffset
virtHp HeapUsage
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)
s1 :: CgState
s1 addCodeBlocksFrom :: CgState -> CgState -> CgState
`addCodeBlocksFrom` s2 :: CgState
s2
  = CgState
s1 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
s1 CmmAGraph -> CmmAGraph -> CmmAGraph
MkGraph.<*> CgState -> CmmAGraph
cgs_stmts CgState
s2,
         cgs_tops :: OrdList CmmDecl
cgs_tops  = CgState -> OrdList CmmDecl
cgs_tops  CgState
s1 OrdList CmmDecl -> OrdList CmmDecl -> OrdList CmmDecl
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` CgState -> OrdList CmmDecl
cgs_tops  CgState
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 -> UpdFrameOffset
heapHWM = HeapUsage -> UpdFrameOffset
virtHp

initHpUsage :: HeapUsage
initHpUsage :: HeapUsage
initHpUsage = HeapUsage :: UpdFrameOffset -> UpdFrameOffset -> HeapUsage
HeapUsage { virtHp :: UpdFrameOffset
virtHp = 0, realHp :: UpdFrameOffset
realHp = 0 }

maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
hp_usg :: HeapUsage
hp_usg maxHpHw :: HeapUsage -> UpdFrameOffset -> HeapUsage
`maxHpHw` hw :: UpdFrameOffset
hw = HeapUsage
hp_usg { virtHp :: UpdFrameOffset
virtHp = HeapUsage -> UpdFrameOffset
virtHp HeapUsage
hp_usg UpdFrameOffset -> UpdFrameOffset -> UpdFrameOffset
forall a. Ord a => a -> a -> a
`max` UpdFrameOffset
hw }

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

getState :: FCode CgState
getState :: FCode CgState
getState = (CgInfoDownwards -> CgState -> (CgState, CgState)) -> FCode CgState
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (CgState, CgState))
 -> FCode CgState)
-> (CgInfoDownwards -> CgState -> (CgState, CgState))
-> FCode CgState
forall a b. (a -> b) -> a -> b
$ \_info_down :: CgInfoDownwards
_info_down state :: CgState
state -> (CgState
state, CgState
state)

setState :: CgState -> FCode ()
setState :: CgState -> FCode ()
setState state :: CgState
state = (CgInfoDownwards -> CgState -> ((), CgState)) -> FCode ()
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> ((), CgState)) -> FCode ())
-> (CgInfoDownwards -> CgState -> ((), CgState)) -> FCode ()
forall a b. (a -> b) -> a -> b
$ \_info_down :: CgInfoDownwards
_info_down _ -> ((), CgState
state)

getHpUsage :: FCode HeapUsage
getHpUsage :: FCode HeapUsage
getHpUsage = do
        CgState
state <- FCode CgState
getState
        HeapUsage -> FCode HeapUsage
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 new_hp_usg :: 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 :: HeapUsage
cgs_hp_usg = HeapUsage
new_hp_usg}

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

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

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

getBinds :: FCode CgBindings
getBinds :: FCode CgBindings
getBinds = do
        CgState
state <- FCode CgState
getState
        CgBindings -> FCode CgBindings
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 new_binds :: 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 :: CgBindings
cgs_binds = CgBindings
new_binds}

withState :: FCode a -> CgState -> FCode (a,CgState)
withState :: FCode a -> CgState -> FCode (a, CgState)
withState (FCode fcode :: CgInfoDownwards -> CgState -> (a, CgState)
fcode) newstate :: CgState
newstate = (CgInfoDownwards -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState)
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> ((a, CgState), CgState))
 -> FCode (a, CgState))
-> (CgInfoDownwards -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState)
forall a b. (a -> b) -> a -> b
$ \info_down :: CgInfoDownwards
info_down state :: CgState
state ->
  case CgInfoDownwards -> CgState -> (a, CgState)
fcode CgInfoDownwards
info_down CgState
newstate of
    (retval :: a
retval, state2 :: CgState
state2) -> ((a
retval,CgState
state2), CgState
state)

newUniqSupply :: FCode UniqSupply
newUniqSupply :: FCode UniqSupply
newUniqSupply = do
        CgState
state <- FCode CgState
getState
        let (us1 :: UniqSupply
us1, us2 :: 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 :: UniqSupply
cgs_uniqs = UniqSupply
us1 }
        UniqSupply -> FCode UniqSupply
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 (u :: Unique
u,us' :: 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 :: UniqSupply
cgs_uniqs = UniqSupply
us' }
        Unique -> FCode Unique
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
u

------------------
getInfoDown :: FCode CgInfoDownwards
getInfoDown :: FCode CgInfoDownwards
getInfoDown = (CgInfoDownwards -> CgState -> (CgInfoDownwards, CgState))
-> FCode CgInfoDownwards
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (CgInfoDownwards, CgState))
 -> FCode CgInfoDownwards)
-> (CgInfoDownwards -> CgState -> (CgInfoDownwards, CgState))
-> FCode CgInfoDownwards
forall a b. (a -> b) -> a -> b
$ \info_down :: CgInfoDownwards
info_down state :: CgState
state -> (CgInfoDownwards
info_down,CgState
state)

getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop = do
        CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
        Maybe SelfLoopInfo -> FCode (Maybe SelfLoopInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SelfLoopInfo -> FCode (Maybe SelfLoopInfo))
-> Maybe SelfLoopInfo -> FCode (Maybe SelfLoopInfo)
forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> Maybe SelfLoopInfo
cgd_self_loop CgInfoDownwards
info_down

withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop self_loop :: SelfLoopInfo
self_loop code :: FCode a
code = do
        CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
        FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info_down {cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = SelfLoopInfo -> Maybe SelfLoopInfo
forall a. a -> Maybe a
Just SelfLoopInfo
self_loop})

instance HasDynFlags FCode where
    getDynFlags :: FCode DynFlags
getDynFlags = (CgInfoDownwards -> DynFlags)
-> FCode CgInfoDownwards -> FCode DynFlags
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CgInfoDownwards -> DynFlags
cgd_dflags FCode CgInfoDownwards
getInfoDown

getThisPackage :: FCode UnitId
getThisPackage :: FCode UnitId
getThisPackage = (DynFlags -> UnitId) -> FCode DynFlags -> FCode UnitId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DynFlags -> UnitId
thisPackage FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode :: CgInfoDownwards -> CgState -> (a, CgState)
fcode) info_down :: CgInfoDownwards
info_down = (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a)
-> (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a b. (a -> b) -> a -> b
$ \_ state :: CgState
state -> CgInfoDownwards -> CgState -> (a, CgState)
fcode CgInfoDownwards
info_down CgState
state

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

getModuleName :: FCode Module
getModuleName :: FCode Module
getModuleName = do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown; Module -> FCode Module
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> Module
cgd_mod CgInfoDownwards
info) }

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

withSequel :: Sequel -> FCode a -> FCode a
withSequel :: Sequel -> FCode a -> FCode a
withSequel sequel :: Sequel
sequel code :: FCode a
code
  = do  { CgInfoDownwards
info  <- FCode CgInfoDownwards
getInfoDown
        ; FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_sequel :: Sequel
cgd_sequel = Sequel
sequel, cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = Maybe SelfLoopInfo
forall a. Maybe a
Nothing }) }

getSequel :: FCode Sequel
getSequel :: FCode Sequel
getSequel = do  { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
                ; Sequel -> FCode Sequel
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> Sequel
cgd_sequel CgInfoDownwards
info) }

-- ----------------------------------------------------------------------------
-- 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 :: UpdFrameOffset -> FCode a -> FCode a
withUpdFrameOff size :: UpdFrameOffset
size code :: FCode a
code
  = do  { CgInfoDownwards
info  <- FCode CgInfoDownwards
getInfoDown
        ; FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_updfr_off :: UpdFrameOffset
cgd_updfr_off = UpdFrameOffset
size }) }

getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff
  = do  { CgInfoDownwards
info  <- FCode CgInfoDownwards
getInfoDown
        ; UpdFrameOffset -> FCode UpdFrameOffset
forall (m :: * -> *) a. Monad m => a -> m a
return (UpdFrameOffset -> FCode UpdFrameOffset)
-> UpdFrameOffset -> FCode UpdFrameOffset
forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> UpdFrameOffset
cgd_updfr_off CgInfoDownwards
info }

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

getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
        CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
        CLabel -> FCode CLabel
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CLabel
cgd_ticky CgInfoDownwards
info)

setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel ticky :: CLabel
ticky code :: FCode a
code = do
        CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
        FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_ticky :: CLabel
cgd_ticky = CLabel
ticky})

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

-- | The current tick scope. We will assign this to generated blocks.
getTickScope :: FCode CmmTickScope
getTickScope :: FCode CmmTickScope
getTickScope = do
        CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
        CmmTickScope -> FCode CmmTickScope
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CmmTickScope
cgd_tick_scope CgInfoDownwards
info)

-- | 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 :: FCode a -> FCode a
tickScope code :: FCode a
code = do
        CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
        if DynFlags -> UpdFrameOffset
debugLevel (CgInfoDownwards -> DynFlags
cgd_dflags CgInfoDownwards
info) UpdFrameOffset -> UpdFrameOffset -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then FCode a
code else do
          Unique
u <- FCode Unique
newUnique
          let scope' :: CmmTickScope
scope' = Unique -> CmmTickScope -> CmmTickScope
SubScope Unique
u (CgInfoDownwards -> CmmTickScope
cgd_tick_scope CgInfoDownwards
info)
          FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code CgInfoDownwards
info{ cgd_tick_scope :: CmmTickScope
cgd_tick_scope = CmmTickScope
scope' }


--------------------------------------------------------
--                 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 body_code :: FCode ()
body_code
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; CgInfoDownwards
info   <- FCode CgInfoDownwards
getInfoDown
        ; UniqSupply
us     <- FCode UniqSupply
newUniqSupply
        ; CgState
state  <- FCode CgState
getState
        ; let body_info_down :: CgInfoDownwards
body_info_down = CgInfoDownwards
info { cgd_sequel :: Sequel
cgd_sequel    = Sequel
initSequel
                                    , cgd_updfr_off :: UpdFrameOffset
cgd_updfr_off = DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags
                                    , cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = Maybe SelfLoopInfo
forall a. Maybe a
Nothing }
              fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds :: CgBindings
cgs_binds = CgState -> CgBindings
cgs_binds CgState
state }
              ((),fork_state_out :: CgState
fork_state_out) = FCode () -> CgInfoDownwards -> CgState -> ((), CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
body_info_down 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 :: FCode a -> FCode a
forkLneBody body_code :: FCode a
body_code
  = do  { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
        ; UniqSupply
us        <- FCode UniqSupply
newUniqSupply
        ; CgState
state     <- FCode CgState
getState
        ; let fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds :: CgBindings
cgs_binds = CgState -> CgBindings
cgs_binds CgState
state }
              (result :: a
result, fork_state_out :: CgState
fork_state_out) = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
body_code CgInfoDownwards
info_down 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 (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 body_code :: FCode ()
body_code
  = do  { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
        ; UniqSupply
us        <- FCode UniqSupply
newUniqSupply
        ; CgState
state     <- FCode CgState
getState
        ; let   fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds :: CgBindings
cgs_binds   = CgState -> CgBindings
cgs_binds CgState
state
                                                 , cgs_hp_usg :: HeapUsage
cgs_hp_usg  = CgState -> HeapUsage
cgs_hp_usg CgState
state }
                ((), fork_state_out :: CgState
fork_state_out) = FCode () -> CgInfoDownwards -> CgState -> ((), CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
info_down 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 :: [FCode a] -> FCode [a]
forkAlts branch_fcodes :: [FCode a]
branch_fcodes
  = do  { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
        ; UniqSupply
us <- FCode UniqSupply
newUniqSupply
        ; CgState
state <- FCode CgState
getState
        ; let compile :: UniqSupply -> FCode a -> (UniqSupply, (a, CgState))
compile us :: UniqSupply
us branch :: FCode a
branch
                = (UniqSupply
us2, FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
branch CgInfoDownwards
info_down CgState
branch_state)
                where
                  (us1 :: UniqSupply
us1,us2 :: UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
                  branch_state :: CgState
branch_state = (UniqSupply -> CgState
initCgState UniqSupply
us1) {
                                        cgs_binds :: CgBindings
cgs_binds  = CgState -> CgBindings
cgs_binds CgState
state
                                      , cgs_hp_usg :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
              (_us :: UniqSupply
_us, results :: [(a, CgState)]
results) = (UniqSupply -> FCode a -> (UniqSupply, (a, CgState)))
-> UniqSupply -> [FCode a] -> (UniqSupply, [(a, CgState)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL UniqSupply -> FCode a -> (UniqSupply, (a, CgState))
compile UniqSupply
us [FCode a]
branch_fcodes
              (branch_results :: [a]
branch_results, branch_out_states :: [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 (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 (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 :: FCode a -> FCode a -> FCode (a, a)
forkAltPair x :: FCode a
x y :: 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
    [x' :: a
x',y' :: a
y'] -> (a, a) -> FCode (a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x',a
y')
    _ -> String -> FCode (a, a)
forall a. String -> a
panic "forkAltPair"

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

getCode :: FCode a -> FCode CmmAGraph
getCode :: FCode a -> FCode CmmAGraph
getCode fcode :: FCode a
fcode = do { (_,stmts :: CmmAGraph
stmts) <- FCode a -> FCode (a, CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR FCode a
fcode; CmmAGraph -> FCode CmmAGraph
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 :: FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped fcode :: FCode a
fcode
  = do  { CgState
state1 <- FCode CgState
getState
        ; ((a :: a
a, tscope :: CmmTickScope
tscope), state2 :: 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)
withState CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
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 (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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1  }
        ; (a, CmmAGraphScoped) -> FCode (a, CmmAGraphScoped)
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 :: (UpdFrameOffset -> FCode a) -> FCode a
getHeapUsage fcode :: UpdFrameOffset -> FCode a
fcode
  = do  { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
        ; CgState
state <- FCode CgState
getState
        ; let   fstate_in :: CgState
fstate_in = CgState
state { cgs_hp_usg :: HeapUsage
cgs_hp_usg  = HeapUsage
initHpUsage }
                (r :: a
r, fstate_out :: CgState
fstate_out) = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode (UpdFrameOffset -> FCode a
fcode UpdFrameOffset
hp_hw) CgInfoDownwards
info_down CgState
fstate_in
                hp_hw :: UpdFrameOffset
hp_hw = HeapUsage -> UpdFrameOffset
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 :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
        ; 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 stmt :: 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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state CmmAGraph -> CgStmt -> CmmAGraph
forall a. OrdList a -> a -> OrdList a
`snocOL` CgStmt
stmt }
        }

emitLabel :: BlockId -> FCode ()
emitLabel :: BlockId -> FCode ()
emitLabel id :: 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 s :: FastString
s
  | Bool
debugIsOn = CgStmt -> FCode ()
emitCgStmt (CmmNode O O -> CgStmt
CgStmt (FastString -> CmmNode O O
CmmComment FastString
s))
  | Bool
otherwise = () -> FCode ()
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 regs :: [(GlobalReg, Maybe CmmExpr)]
regs = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> UpdFrameOffset
debugLevel DynFlags
dflags UpdFrameOffset -> UpdFrameOffset -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
     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 l :: CmmReg
l r :: CmmExpr
r = CgStmt -> FCode ()
emitCgStmt (CmmNode O O -> CgStmt
CgStmt (CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
l CmmExpr
r))

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

emit :: CmmAGraph -> FCode ()
emit :: CmmAGraph -> FCode ()
emit ag :: 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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state CmmAGraph -> CmmAGraph -> CmmAGraph
MkGraph.<*> CmmAGraph
ag } }

emitDecl :: CmmDecl -> FCode ()
emitDecl :: CmmDecl -> FCode ()
emitDecl decl :: 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 :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state OrdList CmmDecl -> CmmDecl -> OrdList CmmDecl
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
decl } }

emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine l :: BlockId
l (stmts :: CmmAGraph
stmts, tscope :: 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 _conv :: Convention
_conv mb_info :: Maybe CmmInfoTable
mb_info lbl :: CLabel
lbl _stk_args :: [LocalReg]
_stk_args [] blocks :: CmmAGraphScoped
blocks False
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc_ Maybe CmmInfoTable
mb_info CLabel
lbl [] CmmAGraphScoped
blocks (Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)) Bool
False
        }
emitProcWithStackFrame conv :: Convention
conv mb_info :: Maybe CmmInfoTable
mb_info lbl :: CLabel
lbl stk_args :: [LocalReg]
stk_args args :: [LocalReg]
args (graph :: CmmAGraph
graph, tscope :: CmmTickScope
tscope) True
        -- do layout
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let (offset :: UpdFrameOffset
offset, live :: [GlobalReg]
live, entry :: CmmAGraph
entry) = DynFlags
-> Convention
-> [LocalReg]
-> [LocalReg]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
mkCallEntry DynFlags
dflags Convention
conv [LocalReg]
args [LocalReg]
stk_args
              graph' :: CmmAGraph
graph' = CmmAGraph
entry CmmAGraph -> CmmAGraph -> CmmAGraph
MkGraph.<*> CmmAGraph
graph
        ; Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc_ Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalReg]
live (CmmAGraph
graph', CmmTickScope
tscope) UpdFrameOffset
offset Bool
True
        }
emitProcWithStackFrame _ _ _ _ _ _ _ = String -> FCode ()
forall a. String -> a
panic "emitProcWithStackFrame"

emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
                       -> [CmmFormal]
                       -> CmmAGraphScoped
                       -> FCode ()
emitProcWithConvention :: Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention conv :: Convention
conv mb_info :: Maybe CmmInfoTable
mb_info lbl :: CLabel
lbl args :: [LocalReg]
args blocks :: 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 -> FCode ()
emitProc :: Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> FCode ()
emitProc  mb_info :: Maybe CmmInfoTable
mb_info lbl :: CLabel
lbl live :: [GlobalReg]
live blocks :: CmmAGraphScoped
blocks offset :: UpdFrameOffset
offset
 = Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc_ Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalReg]
live CmmAGraphScoped
blocks UpdFrameOffset
offset Bool
True

emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
          -> Int -> Bool -> FCode ()
emitProc_ :: Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc_ mb_info :: Maybe CmmInfoTable
mb_info lbl :: CLabel
lbl live :: [GlobalReg]
live blocks :: CmmAGraphScoped
blocks offset :: UpdFrameOffset
offset do_layout :: Bool
do_layout
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; BlockId
l <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
        ; let
              blks :: CmmGraph
blks = BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
l CmmAGraphScoped
blocks

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

              sinfo :: CmmStackInfo
sinfo = StackInfo :: UpdFrameOffset -> Maybe UpdFrameOffset -> Bool -> CmmStackInfo
StackInfo { arg_space :: UpdFrameOffset
arg_space = UpdFrameOffset
offset
                                , updfr_space :: Maybe UpdFrameOffset
updfr_space = UpdFrameOffset -> Maybe UpdFrameOffset
forall a. a -> Maybe a
Just (DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags)
                                , do_layout :: Bool
do_layout = Bool
do_layout }

              tinfo :: CmmTopInfo
tinfo = TopInfo :: LabelMap CmmInfoTable -> CmmStackInfo -> CmmTopInfo
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 :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state OrdList CmmDecl -> CmmDecl -> OrdList CmmDecl
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
proc_block } }

getCmm :: FCode () -> FCode 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 :: FCode () -> FCode CmmGroup
getCmm code :: FCode ()
code
  = do  { CgState
state1 <- FCode CgState
getState
        ; ((), state2 :: CgState
state2) <- FCode () -> CgState -> FCode ((), CgState)
forall a. FCode a -> CgState -> FCode (a, CgState)
withState FCode ()
code (CgState
state1 { cgs_tops :: OrdList CmmDecl
cgs_tops  = OrdList CmmDecl
forall a. OrdList a
nilOL })
        ; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state1 }
        ; CmmGroup -> FCode CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return (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 e :: CmmExpr
e tbranch :: CmmAGraph
tbranch fbranch :: 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' e :: CmmExpr
e tbranch :: CmmAGraph
tbranch fbranch :: CmmAGraph
fbranch likely :: 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
    (test :: CmmExpr
test, then_ :: CmmAGraph
then_, else_ :: CmmAGraph
else_, likely' :: Maybe Bool
likely') = case Maybe Bool
likely of
      Just False | Just e' :: 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)
      _ -> (CmmExpr
e, CmmAGraph
tbranch, CmmAGraph
fbranch, Maybe Bool
likely)

  CmmAGraph -> FCode CmmAGraph
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 e :: CmmExpr
e tid :: 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' e :: CmmExpr
e tid :: BlockId
tid l :: Maybe Bool
l = do
  BlockId
endif <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  CmmTickScope
tscp  <- FCode CmmTickScope
getTickScope
  CmmAGraph -> FCode CmmAGraph
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 e :: CmmExpr
e tbranch :: 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' e :: CmmExpr
e tbranch :: CmmAGraph
tbranch l :: 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 (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]
-> UpdFrameOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall f :: CmmExpr
f (callConv :: Convention
callConv, retConv :: Convention
retConv) results :: [LocalReg]
results actuals :: [CmmExpr]
actuals updfr_off :: UpdFrameOffset
updfr_off extra_stack :: [CmmExpr]
extra_stack = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  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
      (off :: UpdFrameOffset
off, _, copyin :: CmmAGraph
copyin) = DynFlags
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
retConv Area
area [LocalReg]
results []
      copyout :: CmmAGraph
copyout = DynFlags
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo DynFlags
dflags CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
k UpdFrameOffset
off UpdFrameOffset
updfr_off [CmmExpr]
extra_stack
  CmmAGraph -> FCode CmmAGraph
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] -> UpdFrameOffset -> FCode CmmAGraph
mkCmmCall f :: CmmExpr
f results :: [LocalReg]
results actuals :: [CmmExpr]
actuals updfr_off :: UpdFrameOffset
updfr_off
   = CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
f (Convention
NativeDirectCall, Convention
NativeReturn) [LocalReg]
results [CmmExpr]
actuals UpdFrameOffset
updfr_off []


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

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