{-# 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, runC, fixC,
        newUnique,

        emitLabel,

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

        newTemp,

        getCmm, aGraphToGraph, getPlatform, getProfile,
        getCodeR, getCode, getCodeScoped, getHeapUsage,
        getCallOpts, getPtrOpts,

        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,

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

import GHC.Prelude hiding( sequence, succ )

import GHC.Platform
import GHC.Platform.Profile
import GHC.Cmm
import GHC.StgToCmm.Closure
import GHC.Driver.Session
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Graph as CmmGraph
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Info
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.Misc
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 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' { forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode :: CgInfoDownwards -> 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 CgInfoDownwards -> CgState -> (a, CgState)
m) =
    forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
info_down CgState
state ->
      case CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
info_down 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 :: (CgInfoDownwards -> CgState -> (a, CgState))
              -> FCode a
pattern $mFCode :: forall {r} {a}.
FCode a
-> ((CgInfoDownwards -> CgState -> (a, CgState)) -> r)
-> ((# #) -> r)
-> r
$bFCode :: forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode m <- FCode' m
  where
    FCode CgInfoDownwards -> CgState -> (a, CgState)
m = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode' forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot (\CgInfoDownwards
cgInfoDown -> oneShot :: forall a b. (a -> b) -> a -> b
oneShot (\CgState
state ->CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
cgInfoDown CgState
state))

instance Applicative FCode where
    pure :: forall a. a -> FCode a
pure a
val = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode (\CgInfoDownwards
_info_down CgState
state -> (a
val, CgState
state))
    {-# INLINE pure #-}
    <*> :: forall a 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 CgInfoDownwards -> CgState -> (a, CgState)
m >>= :: forall a b. FCode a -> (a -> FCode b) -> FCode b
>>= a -> FCode b
k = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$
        \CgInfoDownwards
info_down CgState
state ->
            case CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
info_down CgState
state of
              (a
m_result, CgState
new_state) ->
                 case a -> FCode b
k a
m_result of
                   FCode 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode CgState
getState
  getUniqueM :: FCode Unique
getUniqueM = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
_ CgState
st ->
    let (Unique
u, 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 Char
'c'
            ; forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> CgState
initCgState UniqSupply
uniqs) }

runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC :: forall a. DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC DynFlags
dflags Module
mod CgState
st FCode a
fcode = 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 :: forall a. (a -> FCode a) -> FCode a
fixC a -> FCode a
fcode = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$
    \CgInfoDownwards
info_down CgState
state -> let (a
v, CgState
s) = 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 -> VirtualHpOffset
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
                                            -- GHC.StgToCmm.Expr
        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
        , 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 })
    = forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
<+> forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
env 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 Sequel
Return = String -> SDoc
text String
"Return"
    ppr (AssignTo [LocalReg]
regs Bool
b) = String -> SDoc
text String
"AssignTo" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LocalReg]
regs SDoc -> SDoc -> 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 DynFlags
dflags Module
mod
  = MkCgInfoDown { cgd_dflags :: DynFlags
cgd_dflags    = DynFlags
dflags
                 , cgd_mod :: Module
cgd_mod       = Module
mod
                 , cgd_updfr_off :: VirtualHpOffset
cgd_updfr_off = Platform -> VirtualHpOffset
initUpdFrameOff (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                 , cgd_ticky :: CLabel
cgd_ticky     = CLabel
mkTopTickyCtrLabel
                 , cgd_sequel :: Sequel
cgd_sequel    = Sequel
initSequel
                 , cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = forall a. Maybe a
Nothing
                 , cgd_tick_scope :: CmmTickScope
cgd_tick_scope= CmmTickScope
GlobalScope }

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

initUpdFrameOff :: Platform -> UpdFrameOffset
initUpdFrameOff :: Platform -> VirtualHpOffset
initUpdFrameOff Platform
platform = Platform -> VirtualHpOffset
platformWordSizeInBytes Platform
platform -- 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 }
-- 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 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   = forall a. OrdList a
nilOL
              , cgs_binds :: CgBindings
cgs_binds  = 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 :: HeapUsage
cgs_hp_usg  = CgState -> HeapUsage
cgs_hp_usg  CgState
s1 HeapUsage -> VirtualHpOffset -> HeapUsage
`maxHpHw`  HeapUsage -> VirtualHpOffset
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)
CgState
s1 addCodeBlocksFrom :: CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
s2
  = CgState
s1 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
s1 CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> CgState -> CmmAGraph
cgs_stmts CgState
s2,
         cgs_tops :: OrdList CmmDecl
cgs_tops  = CgState -> OrdList CmmDecl
cgs_tops  CgState
s1 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 -> 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 :: VirtualHpOffset
virtHp = HeapUsage -> VirtualHpOffset
virtHp HeapUsage
hp_usg forall a. Ord a => a -> a -> a
`max` VirtualHpOffset
hw }

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

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

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

getHpUsage :: FCode HeapUsage
getHpUsage :: FCode HeapUsage
getHpUsage = do
        CgState
state <- FCode CgState
getState
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ CgState
state {cgs_hp_usg :: HeapUsage
cgs_hp_usg = HeapUsage
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 :: VirtualHpOffset
virtHp = VirtualHpOffset
new_virtHp}) }

getVirtHp :: FCode VirtualHpOffset
getVirtHp :: FCode VirtualHpOffset
getVirtHp
  = do  { HeapUsage
hp_usage <- FCode HeapUsage
getHpUsage
        ; 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 :: VirtualHpOffset
realHp = VirtualHpOffset
new_realHp}) }

getBinds :: FCode CgBindings
getBinds :: FCode CgBindings
getBinds = do
        CgState
state <- FCode CgState
getState
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 :: forall a. FCode a -> CgState -> FCode (a, CgState)
withState (FCode CgInfoDownwards -> CgState -> (a, CgState)
fcode) CgState
newstate = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
info_down CgState
state ->
  case CgInfoDownwards -> CgState -> (a, CgState)
fcode CgInfoDownwards
info_down 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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs :: UniqSupply
cgs_uniqs = UniqSupply
us1 }
        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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs :: UniqSupply
cgs_uniqs = UniqSupply
us' }
        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 <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                 ; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> CmmType -> LocalReg
LocalReg Unique
uniq CmmType
rep) }

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

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

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

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

getProfile :: FCode Profile
getProfile :: FCode Profile
getProfile = DynFlags -> Profile
targetProfile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

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

getCallOpts :: FCode CallOpts
getCallOpts :: FCode CallOpts
getCallOpts = do
   DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
   Profile
profile <- FCode Profile
getProfile
   forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CallOpts
    { co_profile :: Profile
co_profile       = Profile
profile
    , co_loopification :: Bool
co_loopification = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Loopification DynFlags
dflags
    , co_ticky :: Bool
co_ticky         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky DynFlags
dflags
    }

getPtrOpts :: FCode PtrOpts
getPtrOpts :: FCode PtrOpts
getPtrOpts = do
   DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
   Profile
profile <- FCode Profile
getProfile
   forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PtrOpts
      { po_profile :: Profile
po_profile     = Profile
profile
      , po_align_check :: Bool
po_align_check = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AlignmentSanitisation DynFlags
dflags
      }


withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown :: forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode CgInfoDownwards -> CgState -> (a, CgState)
fcode) CgInfoDownwards
info_down = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
_ 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; 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 :: forall a. Sequel -> FCode a -> FCode a
withSequel Sequel
sequel FCode a
code
  = do  { CgInfoDownwards
info  <- FCode CgInfoDownwards
getInfoDown
        ; 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 = forall a. Maybe a
Nothing }) }

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

getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff :: FCode VirtualHpOffset
getUpdFrameOff
  = do  { CgInfoDownwards
info  <- FCode CgInfoDownwards
getInfoDown
        ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> VirtualHpOffset
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
        forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CLabel
cgd_ticky CgInfoDownwards
info)

setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel :: forall a. CLabel -> FCode a -> FCode a
setTickyCtrLabel CLabel
ticky FCode a
code = do
        CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
        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
        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 :: forall a. FCode a -> FCode a
tickScope FCode a
code = do
        CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
        if DynFlags -> VirtualHpOffset
debugLevel (CgInfoDownwards -> DynFlags
cgd_dflags CgInfoDownwards
info) forall a. Eq a => a -> a -> Bool
== VirtualHpOffset
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)
          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 FCode ()
body_code
  = do  { Platform
platform <- FCode Platform
getPlatform
        ; 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 :: VirtualHpOffset
cgd_updfr_off = Platform -> VirtualHpOffset
initUpdFrameOff Platform
platform
                                    , cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = 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 }
              ((),CgState
fork_state_out) = forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
body_info_down CgState
fork_state_in
        ; CgState -> FCode ()
setState 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  { 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 }
              (a
result, CgState
fork_state_out) = forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
body_code CgInfoDownwards
info_down CgState
fork_state_in
        ; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
fork_state_out
        ; 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  { 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 }
                ((), CgState
fork_state_out) = forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
info_down CgState
fork_state_in
        ; CgState -> FCode ()
setState 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  { 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 UniqSupply
us FCode a
branch
                = (UniqSupply
us2, forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
branch CgInfoDownwards
info_down 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 :: CgBindings
cgs_binds  = CgState -> CgBindings
cgs_binds CgState
state
                                      , cgs_hp_usg :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
              (UniqSupply
_us, [(a, CgState)]
results) = 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(a, CgState)]
results
        ; CgState -> FCode ()
setState forall a b. (a -> 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
        ; 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' <- forall a. [FCode a] -> FCode [a]
forkAlts [FCode a
x,FCode a
y]
  case [a]
xy' of
    [a
x',a
y'] -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
x',a
y')
    [a]
_ -> forall a. 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) <- forall a. FCode a -> CgState -> FCode (a, CgState)
withState FCode a
fcode (CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop })
        ; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1  }
        ; 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) <- forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR FCode a
fcode; 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) <-
            forall a. FCode a -> FCode a
tickScope forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. FCode a -> CgState -> FCode (a, CgState)
withState CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop } forall a b. (a -> b) -> a -> b
$
            do { a
a   <- FCode a
fcode
               ; CmmTickScope
scp <- FCode CmmTickScope
getTickScope
               ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, CmmTickScope
scp) }
        ; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1  }
        ; 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  { 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 }
                (a
r, CgState
fstate_out) = forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode (VirtualHpOffset -> FCode a
fcode VirtualHpOffset
hp_hw) CgInfoDownwards
info_down CgState
fstate_in
                hp_hw :: VirtualHpOffset
hp_hw = HeapUsage -> VirtualHpOffset
heapHWM (CgState -> HeapUsage
cgs_hp_usg CgState
fstate_out)        -- Loop here!

        ; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
fstate_out { cgs_hp_usg :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
        ; 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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state forall a. OrdList a -> a -> OrdList a
`snocOL` CgStmt
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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()

emitTick :: CmmTickish -> FCode ()
emitTick :: CmmTickish -> FCode ()
emitTick = CgStmt -> FCode ()
emitCgStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode O O -> CgStmt
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
  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> VirtualHpOffset
debugLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
> VirtualHpOffset
0) forall a b. (a -> b) -> a -> b
$
     CgStmt -> FCode ()
emitCgStmt forall a b. (a -> b) -> a -> b
$ CmmNode O O -> CgStmt
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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> CmmAGraph
ag } }

emitDecl :: CmmDecl -> FCode ()
emitDecl :: CmmDecl -> FCode ()
emitDecl CmmDecl
decl
  = do  { CgState
state <- FCode CgState
getState
        ; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
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
_ = forall a. 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 <- 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 = forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
blks) CmmInfoTable
info
                    | Bool
otherwise            = 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 = 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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
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) <- forall a. FCode a -> CgState -> FCode (a, CgState)
withState FCode a
code (CgState
state1 { cgs_tops :: OrdList CmmDecl
cgs_tops  = forall a. OrdList a
nilOL })
        ; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state1 }
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, 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 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  BlockId
tid   <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  BlockId
fid   <- 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, forall a. a -> Maybe a
Just Bool
True)
      Maybe Bool
_ -> (CmmExpr
e, CmmAGraph
tbranch, CmmAGraph
fbranch, Maybe Bool
likely)

  forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  CmmTickScope
tscp  <- FCode CmmTickScope
getTickScope
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  BlockId
tid   <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
  CmmTickScope
tscp  <- FCode CmmTickScope
getTickScope
  forall (m :: * -> *) a. Monad m => a -> m a
return 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       <- 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
l CmmAGraphScoped
stmts) }