compiler/codeGen/StgCmmMonad.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Monad for Stg to C-- code generation
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmMonad (
  10         FCode,  -- type
  11
  12         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
  13         returnFC, fixC, nopC, whenC,
  14         newUnique, newUniqSupply,
  15
  16         emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
  17
  18         getCmm, cgStmtsToBlocks,
  19         getCodeR, getCode, getHeapUsage,
  20
  21         forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
  22
  23         ConTagZ,
  24
  25         Sequel(..),
  26         withSequel, getSequel,
  27
  28         setSRTLabel, getSRTLabel,
  29         setTickyCtrLabel, getTickyCtrLabel,
  30
  31         withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
  32
  33         HeapUsage(..), VirtualHpOffset, initHpUsage,
  34         getHpUsage,  setHpUsage, heapHWM,
  35         setVirtHp, getVirtHp, setRealHp,
  36
  37         getModuleName,
  38
  39         -- ideally we wouldn't export these, but some other modules access internal state
  40         getState, setState, getInfoDown, getDynFlags, getThisPackage,
  41
  42         -- more localised access to monad state
  43         CgIdInfo(..), CgLoc(..),
  44         getBinds, setBinds, getStaticBinds,
  45
  46         -- out of general friendliness, we also export ...
  47         CgInfoDownwards(..), CgState(..)        -- non-abstract
  48     ) where
  49
  50 #include "HsVersions.h"
  51
  52 import StgCmmClosure
  53 import DynFlags
  54 import MkZipCfgCmm
  55 import ZipCfgCmmRep (UpdFrameOffset)
  56 import BlockId
  57 import Cmm
  58 import CLabel
  59 import TyCon    ( PrimRep )
  60 import SMRep
  61 import Module
  62 import Id
  63 import VarEnv
  64 import OrdList
  65 import Unique
  66 import Util()
  67 import UniqSupply
  68 import FastString(sLit)
  69 import Outputable
  70
  71 import Control.Monad
  72 import Data.List
  73 import Prelude hiding( sequence )
  74 import qualified Prelude( sequence )
  75
  76 infixr 9 `thenC`        -- Right-associative!
  77 infixr 9 `thenFC`
  78
  79
  80 --------------------------------------------------------
  81 --      The FCode monad and its types
  82 --------------------------------------------------------
  83
  84 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
  85
  86 instance Monad FCode where
  87         (>>=) = thenFC
  88         return = returnFC
  89
  90 {-# INLINE thenC #-}
  91 {-# INLINE thenFC #-}
  92 {-# INLINE returnFC #-}
  93
  94 initC :: DynFlags -> Module -> FCode a -> IO a
  95 initC dflags mod (FCode code)
  96   = do  { uniqs <- mkSplitUniqSupply 'c'
  97         ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
  98               (res, _) -> return res
  99         }
 100
 101 returnFC :: a -> FCode a
 102 returnFC val = FCode (\_info_down state -> (val, state))
 103
 104 thenC :: FCode () -> FCode a -> FCode a
 105 thenC (FCode m) (FCode k) =
 106         FCode (\info_down state -> let (_,new_state) = m info_down state in
 107                 k info_down new_state)
 108
 109 nopC :: FCode ()
 110 nopC = return ()
 111
 112 whenC :: Bool -> FCode () -> FCode ()
 113 whenC True  code  = code
 114 whenC False _code = nopC
 115
 116 listCs :: [FCode ()] -> FCode ()
 117 listCs [] = return ()
 118 listCs (fc:fcs) = do
 119         fc
 120         listCs fcs
 121
 122 mapCs :: (a -> FCode ()) -> [a] -> FCode ()
 123 mapCs = mapM_
 124
 125 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
 126 thenFC (FCode m) k = FCode (
 127         \info_down state ->
 128                 let
 129                         (m_result, new_state) = m info_down state
 130                         (FCode kcode) = k m_result
 131                 in
 132                         kcode info_down new_state
 133         )
 134
 135 listFCs :: [FCode a] -> FCode [a]
 136 listFCs = Prelude.sequence
 137
 138 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 139 mapFCs = mapM
 140
 141 fixC :: (a -> FCode a) -> FCode a
 142 fixC fcode = FCode (
 143         \info_down state ->
 144                 let
 145                         FCode fc = fcode v
 146                         result@(v,_) = fc info_down state
 147                         --          ^--------^
 148                 in
 149                         result
 150         )
 151
 152
 153 --------------------------------------------------------
 154 --      The code generator environment
 155 --------------------------------------------------------
 156
 157 -- This monadery has some information that it only passes
 158 -- *downwards*, as well as some ``state'' which is modified
 159 -- as we go along.
 160
 161 data CgInfoDownwards    -- information only passed *downwards* by the monad
 162   = MkCgInfoDown {
 163         cgd_dflags     :: DynFlags,
 164         cgd_mod        :: Module,         -- Module being compiled
 165         cgd_statics    :: CgBindings,     -- [Id -> info] : static environment
 166         cgd_srt_lbl    :: CLabel,         -- Label of the current top-level SRT
 167         cgd_updfr_off  :: UpdFrameOffset, -- Size of current update frame
 168         cgd_ticky      :: CLabel,         -- Current destination for ticky counts
 169         cgd_sequel     :: Sequel          -- What to do at end of basic block
 170   }
 171
 172 type CgBindings = IdEnv CgIdInfo
 173
 174 data CgIdInfo
 175   = CgIdInfo
 176         { cg_id :: Id   -- Id that this is the info for
 177                         -- Can differ from the Id at occurrence sites by
 178                         -- virtue of being externalised, for splittable C
 179         , cg_lf  :: LambdaFormInfo
 180         , cg_loc :: CgLoc                    -- CmmExpr for the *tagged* value
 181         , cg_rep :: PrimRep                  -- Cache for (idPrimRep id)
 182         , cg_tag :: {-# UNPACK #-} !DynTag   -- Cache for (lfDynTag cg_lf)
 183         }
 184
 185 data CgLoc
 186   = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
 187                         -- Hp, so that it remains valid across calls
 188
 189   | LneLoc BlockId [LocalReg]      -- A join point
 190         -- A join point (= let-no-escape) should only
 191         -- be tail-called, and in a saturated way.
 192         -- To tail-call it, assign to these locals,
 193         -- and branch to the block id
 194
 195 instance Outputable CgIdInfo where
 196   ppr (CgIdInfo { cg_id = id, cg_loc = loc })
 197     = ppr id <+> ptext (sLit "-->") <+> ppr loc
 198
 199 instance Outputable CgLoc where
 200   ppr (CmmLoc e)    = ptext (sLit "cmm") <+> ppr e
 201   ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
 202
 203
 204 -- Sequel tells what to do with the result of this expression
 205 data Sequel
 206   = Return Bool           -- Return result(s) to continuation found on the stack
 207                           --    True <=> the continuation is update code (???)
 208
 209   | AssignTo
 210         [LocalReg]      -- Put result(s) in these regs and fall through
 211                         --      NB: no void arguments here
 212         Bool            -- Should we adjust the heap pointer back to recover
 213                         -- space that's unused on this path?
 214                         -- We need to do this only if the expression may
 215                         -- allocate (e.g. it's a foreign call or allocating primOp)
 216 instance Show Sequel where
 217   show (Return _) = "Sequel: Return"
 218   show (AssignTo _ _) = "Sequel: Assign"
 219
 220 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 221 initCgInfoDown dflags mod
 222   = MkCgInfoDown {      cgd_dflags    = dflags,
 223                         cgd_mod       = mod,
 224                         cgd_statics   = emptyVarEnv,
 225                         cgd_srt_lbl   = error "initC: srt_lbl",
 226                         cgd_updfr_off = initUpdFrameOff,
 227                         cgd_ticky     = mkTopTickyCtrLabel,
 228                         cgd_sequel    = initSequel }
 229
 230 initSequel :: Sequel
 231 initSequel = Return False
 232
 233 initUpdFrameOff :: UpdFrameOffset
 234 initUpdFrameOff = widthInBytes wordWidth -- space for the RA
 235
 236
 237 --------------------------------------------------------
 238 --      The code generator state
 239 --------------------------------------------------------
 240
 241 data CgState
 242   = MkCgState {
 243      cgs_stmts :: CmmAGraph,      -- Current procedure
 244
 245      cgs_tops  :: OrdList CmmTopZ,
 246         -- Other procedures and data blocks in this compilation unit
 247         -- Both are ordered only so that we can
 248         -- reduce forward references, when it's easy to do so
 249
 250      cgs_binds :: CgBindings,   -- [Id -> info] : *local* bindings environment
 251                                 -- Bindings for top-level things are given in
 252                                 -- the info-down part
 253
 254      cgs_hp_usg  :: HeapUsage,
 255
 256      cgs_uniqs :: UniqSupply }
 257
 258 data HeapUsage =
 259   HeapUsage {
 260         virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
 261         realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
 262   }
 263
 264 type VirtualHpOffset = WordOff
 265
 266 initCgState :: UniqSupply -> CgState
 267 initCgState uniqs
 268   = MkCgState { cgs_stmts      = mkNop, cgs_tops = nilOL,
 269                 cgs_binds      = emptyVarEnv,
 270                 cgs_hp_usg     = initHpUsage,
 271                 cgs_uniqs      = uniqs }
 272
 273 stateIncUsage :: CgState -> CgState -> CgState
 274 -- stateIncUsage@ e1 e2 incorporates in e1
 275 -- the heap high water mark found in e2.
 276 stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
 277      = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
 278        `addCodeBlocksFrom` s2
 279
 280 addCodeBlocksFrom :: CgState -> CgState -> CgState
 281 -- Add code blocks from the latter to the former
 282 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
 283 s1 `addCodeBlocksFrom` s2
 284   = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
 285          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 286
 287
 288 -- The heap high water mark is the larger of virtHp and hwHp.  The latter is
 289 -- only records the high water marks of forked-off branches, so to find the
 290 -- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
 291 -- virtHp never retreats!
 292 --
 293 -- Note Jan 04: ok, so why do we only look at the virtual Hp??
 294
 295 heapHWM :: HeapUsage -> VirtualHpOffset
 296 heapHWM = virtHp
 297
 298 initHpUsage :: HeapUsage
 299 initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
 300
 301 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
 302 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 303
 304
 305 --------------------------------------------------------
 306 -- Operators for getting and setting the state and "info_down".
 307 --------------------------------------------------------
 308
 309 getState :: FCode CgState
 310 getState = FCode $ \_info_down state -> (state,state)
 311
 312 setState :: CgState -> FCode ()
 313 setState state = FCode $ \_info_down _ -> ((),state)
 314
 315 getHpUsage :: FCode HeapUsage
 316 getHpUsage = do
 317         state <- getState
 318         return $ cgs_hp_usg state
 319
 320 setHpUsage :: HeapUsage -> FCode ()
 321 setHpUsage new_hp_usg = do
 322         state <- getState
 323         setState $ state {cgs_hp_usg = new_hp_usg}
 324
 325 setVirtHp :: VirtualHpOffset -> FCode ()
 326 setVirtHp new_virtHp
 327   = do  { hp_usage <- getHpUsage
 328         ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
 329
 330 getVirtHp :: FCode VirtualHpOffset
 331 getVirtHp
 332   = do  { hp_usage <- getHpUsage
 333         ; return (virtHp hp_usage) }
 334
 335 setRealHp ::  VirtualHpOffset -> FCode ()
 336 setRealHp new_realHp
 337   = do  { hp_usage <- getHpUsage
 338         ; setHpUsage (hp_usage {realHp = new_realHp}) }
 339
 340 getBinds :: FCode CgBindings
 341 getBinds = do
 342         state <- getState
 343         return $ cgs_binds state
 344
 345 setBinds :: CgBindings -> FCode ()
 346 setBinds new_binds = do
 347         state <- getState
 348         setState $ state {cgs_binds = new_binds}
 349
 350 getStaticBinds :: FCode CgBindings
 351 getStaticBinds = do
 352         info  <- getInfoDown
 353         return (cgd_statics info)
 354
 355 withState :: FCode a -> CgState -> FCode (a,CgState)
 356 withState (FCode fcode) newstate = FCode $ \info_down state ->
 357         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
 358
 359 newUniqSupply :: FCode UniqSupply
 360 newUniqSupply = do
 361         state <- getState
 362         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
 363         setState $ state { cgs_uniqs = us1 }
 364         return us2
 365
 366 newUnique :: FCode Unique
 367 newUnique = do
 368         us <- newUniqSupply
 369         return (uniqFromSupply us)
 370
 371 ------------------
 372 getInfoDown :: FCode CgInfoDownwards
 373 getInfoDown = FCode $ \info_down state -> (info_down,state)
 374
 375 getDynFlags :: FCode DynFlags
 376 getDynFlags = liftM cgd_dflags getInfoDown
 377
 378 getThisPackage :: FCode PackageId
 379 getThisPackage = liftM thisPackage getDynFlags
 380
 381 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 382 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 383
 384 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
 385 doFCode (FCode fcode) info_down state = fcode info_down state
 386
 387
 388 -- ----------------------------------------------------------------------------
 389 -- Get the current module name
 390
 391 getModuleName :: FCode Module
 392 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
 393
 394 -- ----------------------------------------------------------------------------
 395 -- Get/set the end-of-block info
 396
 397 withSequel :: Sequel -> FCode () -> FCode ()
 398 withSequel sequel code
 399   = do  { info  <- getInfoDown
 400         ; withInfoDown code (info {cgd_sequel = sequel }) }
 401
 402 getSequel :: FCode Sequel
 403 getSequel = do  { info <- getInfoDown
 404                 ; return (cgd_sequel info) }
 405
 406 -- ----------------------------------------------------------------------------
 407 -- Get/set the current SRT label
 408
 409 -- There is just one SRT for each top level binding; all the nested
 410 -- bindings use sub-sections of this SRT.  The label is passed down to
 411 -- the nested bindings via the monad.
 412
 413 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
 414 getSRTLabel = do info  <- getInfoDown
 415                  return (cgd_srt_lbl info)
 416
 417 setSRTLabel :: CLabel -> FCode a -> FCode a
 418 setSRTLabel srt_lbl code
 419   = do  info <- getInfoDown
 420         withInfoDown code (info { cgd_srt_lbl = srt_lbl})
 421
 422 -- ----------------------------------------------------------------------------
 423 -- Get/set the size of the update frame
 424
 425 -- We keep track of the size of the update frame so that we
 426 -- can set the stack pointer to the proper address on return
 427 -- (or tail call) from the closure.
 428 -- There should be at most one update frame for each closure.
 429 -- Note: I'm including the size of the original return address
 430 -- in the size of the update frame -- hence the default case on `get'.
 431
 432 withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
 433 withUpdFrameOff size code
 434   = do  { info  <- getInfoDown
 435         ; withInfoDown code (info {cgd_updfr_off = size }) }
 436
 437 getUpdFrameOff :: FCode UpdFrameOffset
 438 getUpdFrameOff
 439   = do  { info  <- getInfoDown
 440         ; return $ cgd_updfr_off info }
 441
 442 -- ----------------------------------------------------------------------------
 443 -- Get/set the current ticky counter label
 444
 445 getTickyCtrLabel :: FCode CLabel
 446 getTickyCtrLabel = do
 447         info <- getInfoDown
 448         return (cgd_ticky info)
 449
 450 setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
 451 setTickyCtrLabel ticky code = do
 452         info <- getInfoDown
 453         withInfoDown code (info {cgd_ticky = ticky})
 454
 455
 456 --------------------------------------------------------
 457 --              Forking
 458 --------------------------------------------------------
 459
 460 forkClosureBody :: FCode () -> FCode ()
 461 -- forkClosureBody takes a code, $c$, and compiles it in a
 462 -- fresh environment, except that:
 463 --      - compilation info and statics are passed in unchanged.
 464 --      - local bindings are passed in unchanged
 465 --        (it's up to the enclosed code to re-bind the
 466 --         free variables to a field of the closure)
 467 --
 468 -- The current state is passed on completely unaltered, except that
 469 -- C-- from the fork is incorporated.
 470
 471 forkClosureBody body_code
 472   = do  { info <- getInfoDown
 473         ; us   <- newUniqSupply
 474         ; state <- getState
 475         ; let   body_info_down = info { cgd_sequel    = initSequel
 476                                       , cgd_updfr_off = initUpdFrameOff }
 477                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
 478                 ((),fork_state_out)
 479                     = doFCode body_code body_info_down fork_state_in
 480         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 481
 482 forkStatics :: FCode a -> FCode a
 483 -- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
 484 -- from the current *local bindings*, but which is otherwise freshly initialised.
 485 -- The Abstract~C returned is attached to the current state, but the
 486 -- bindings and usage information is otherwise unchanged.
 487 forkStatics body_code
 488   = do  { info  <- getInfoDown
 489         ; us    <- newUniqSupply
 490         ; state <- getState
 491         ; let   rhs_info_down = info { cgd_statics = cgs_binds state
 492                                      , cgd_sequel  = initSequel
 493                                      , cgd_updfr_off = initUpdFrameOff }
 494                 (result, fork_state_out) = doFCode body_code rhs_info_down
 495                                                    (initCgState us)
 496         ; setState (state `addCodeBlocksFrom` fork_state_out)
 497         ; return result }
 498
 499 forkProc :: FCode a -> FCode a
 500 -- 'forkProc' takes a code and compiles it in the *current* environment,
 501 -- returning the graph thus constructed.
 502 --
 503 -- The current environment is passed on completely unchanged to
 504 -- the successor.  In particular, any heap usage from the enclosed
 505 -- code is discarded; it should deal with its own heap consumption
 506 forkProc body_code
 507   = do  { info_down <- getInfoDown
 508         ; us    <- newUniqSupply
 509         ; state <- getState
 510         ; let   info_down' = info_down -- { cgd_sequel = initSequel }
 511                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
 512                 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
 513         ; setState $ state `addCodeBlocksFrom` fork_state_out
 514         ; return result }
 515
 516 codeOnly :: FCode () -> FCode ()
 517 -- Emit any code from the inner thing into the outer thing
 518 -- Do not affect anything else in the outer state
 519 -- Used in almost-circular code to prevent false loop dependencies
 520 codeOnly body_code
 521   = do  { info_down <- getInfoDown
 522         ; us   <- newUniqSupply
 523         ; state <- getState
 524         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
 525                                                    cgs_hp_usg  = cgs_hp_usg state }
 526                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
 527         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 528
 529 forkAlts :: [FCode a] -> FCode [a]
 530 -- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
 531 -- an fcode for the default case 'd', and compiles each in the current
 532 -- environment.  The current environment is passed on unmodified, except
 533 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
 534
 535 forkAlts branch_fcodes
 536   = do  { info_down <- getInfoDown
 537         ; us <- newUniqSupply
 538         ; state <- getState
 539         ; let compile us branch
 540                 = (us2, doFCode branch info_down branch_state)
 541                 where
 542                   (us1,us2) = splitUniqSupply us
 543                   branch_state = (initCgState us1) {
 544                                         cgs_binds   = cgs_binds state,
 545                                         cgs_hp_usg  = cgs_hp_usg state }
 546
 547               (_us, results) = mapAccumL compile us branch_fcodes
 548               (branch_results, branch_out_states) = unzip results
 549         ; setState $ foldl stateIncUsage state branch_out_states
 550                 -- NB foldl.  state is the *left* argument to stateIncUsage
 551         ; return branch_results }
 552
 553 -- collect the code emitted by an FCode computation
 554 getCodeR :: FCode a -> FCode (a, CmmAGraph)
 555 getCodeR fcode
 556   = do  { state1 <- getState
 557         ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
 558         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
 559         ; return (a, cgs_stmts state2) }
 560
 561 getCode :: FCode a -> FCode CmmAGraph
 562 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
 563
 564 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
 565 -- It initialises the heap usage to zeros, and passes on an unchanged
 566 -- heap usage.
 567 --
 568 -- It is usually a prelude to performing a GC check, so everything must
 569 -- be in a tidy and consistent state.
 570 --
 571 -- Note the slightly subtle fixed point behaviour needed here
 572
 573 getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
 574 getHeapUsage fcode
 575   = do  { info_down <- getInfoDown
 576         ; state <- getState
 577         ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
 578                 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
 579                 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
 580
 581         ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
 582         ; return r }
 583
 584 -- ----------------------------------------------------------------------------
 585 -- Combinators for emitting code
 586
 587 emit :: CmmAGraph -> FCode ()
 588 emit ag
 589   = do  { state <- getState
 590         ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
 591
 592 emitData :: Section -> [CmmStatic] -> FCode ()
 593 emitData sect lits
 594   = do  { state <- getState
 595         ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
 596   where
 597     data_block = CmmData sect lits
 598
 599 emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
 600                           CmmAGraph -> FCode ()
 601 emitProcWithConvention conv info lbl args blocks
 602   = do  { us <- newUniqSupply
 603         ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
 604               blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
 605         ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
 606         ; state <- getState
 607         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 608
 609 emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
 610 emitProc = emitProcWithConvention NativeCall
 611
 612 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 613 emitSimpleProc lbl code =
 614   emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
 615
 616 getCmm :: FCode () -> FCode CmmZ
 617 -- Get all the CmmTops (there should be no stmts)
 618 -- Return a single Cmm which may be split from other Cmms by
 619 -- object splitting (at a later stage)
 620 getCmm code
 621   = do  { state1 <- getState
 622         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
 623         ; setState $ state2 { cgs_tops = cgs_tops state1 }
 624         ; return (Cmm (fromOL (cgs_tops state2))) }
 625
 626 -- ----------------------------------------------------------------------------
 627 -- CgStmts
 628
 629 -- These functions deal in terms of CgStmts, which is an abstract type
 630 -- representing the code in the current proc.
 631
 632 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
 633 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
 634 cgStmtsToBlocks stmts
 635   = do  { us <- newUniqSupply
 636         ; return (initUs_ us (lgraphOfAGraph stmts)) }
 637