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         C_SRT           -- Here are the statics live in the continuation
 213                         -- E.g.  case (case x# of 0# -> a; DEFAULT -> b) of {
 214                         --          r -> <blah>
 215                         -- When compiling the nested case, remember to put the
 216                         -- result in r, and fall through
 217
 218
 219 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 220 initCgInfoDown dflags mod
 221   = MkCgInfoDown {      cgd_dflags    = dflags,
 222                         cgd_mod       = mod,
 223                         cgd_statics   = emptyVarEnv,
 224                         cgd_srt_lbl   = error "initC: srt_lbl",
 225                         cgd_updfr_off = initUpdFrameOff,
 226                         cgd_ticky     = mkTopTickyCtrLabel,
 227                         cgd_sequel    = initSequel }
 228
 229 initSequel :: Sequel
 230 initSequel = Return False
 231
 232 initUpdFrameOff :: UpdFrameOffset
 233 initUpdFrameOff = widthInBytes wordWidth -- space for the RA
 234
 235
 236 --------------------------------------------------------
 237 --      The code generator state
 238 --------------------------------------------------------
 239
 240 data CgState
 241   = MkCgState {
 242      cgs_stmts :: CmmAGraph,      -- Current procedure
 243
 244      cgs_tops  :: OrdList CmmTopZ,
 245         -- Other procedures and data blocks in this compilation unit
 246         -- Both are ordered only so that we can
 247         -- reduce forward references, when it's easy to do so
 248
 249      cgs_binds :: CgBindings,   -- [Id -> info] : *local* bindings environment
 250                                 -- Bindings for top-level things are given in
 251                                 -- the info-down part
 252
 253      cgs_hp_usg  :: HeapUsage,
 254
 255      cgs_uniqs :: UniqSupply }
 256
 257 data HeapUsage =
 258   HeapUsage {
 259         virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
 260         realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
 261   }
 262
 263 type VirtualHpOffset = WordOff
 264
 265 initCgState :: UniqSupply -> CgState
 266 initCgState uniqs
 267   = MkCgState { cgs_stmts      = mkNop, cgs_tops = nilOL,
 268                 cgs_binds      = emptyVarEnv,
 269                 cgs_hp_usg     = initHpUsage,
 270                 cgs_uniqs      = uniqs }
 271
 272 stateIncUsage :: CgState -> CgState -> CgState
 273 -- stateIncUsage@ e1 e2 incorporates in e1
 274 -- the heap high water mark found in e2.
 275 stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
 276      = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
 277        `addCodeBlocksFrom` s2
 278
 279 addCodeBlocksFrom :: CgState -> CgState -> CgState
 280 -- Add code blocks from the latter to the former
 281 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
 282 s1 `addCodeBlocksFrom` s2
 283   = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
 284          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 285
 286
 287 -- The heap high water mark is the larger of virtHp and hwHp.  The latter is
 288 -- only records the high water marks of forked-off branches, so to find the
 289 -- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
 290 -- virtHp never retreats!
 291 --
 292 -- Note Jan 04: ok, so why do we only look at the virtual Hp??
 293
 294 heapHWM :: HeapUsage -> VirtualHpOffset
 295 heapHWM = virtHp
 296
 297 initHpUsage :: HeapUsage
 298 initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
 299
 300 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
 301 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 302
 303
 304 --------------------------------------------------------
 305 -- Operators for getting and setting the state and "info_down".
 306 --------------------------------------------------------
 307
 308 getState :: FCode CgState
 309 getState = FCode $ \_info_down state -> (state,state)
 310
 311 setState :: CgState -> FCode ()
 312 setState state = FCode $ \_info_down _ -> ((),state)
 313
 314 getHpUsage :: FCode HeapUsage
 315 getHpUsage = do
 316         state <- getState
 317         return $ cgs_hp_usg state
 318
 319 setHpUsage :: HeapUsage -> FCode ()
 320 setHpUsage new_hp_usg = do
 321         state <- getState
 322         setState $ state {cgs_hp_usg = new_hp_usg}
 323
 324 setVirtHp :: VirtualHpOffset -> FCode ()
 325 setVirtHp new_virtHp
 326   = do  { hp_usage <- getHpUsage
 327         ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
 328
 329 getVirtHp :: FCode VirtualHpOffset
 330 getVirtHp
 331   = do  { hp_usage <- getHpUsage
 332         ; return (virtHp hp_usage) }
 333
 334 setRealHp ::  VirtualHpOffset -> FCode ()
 335 setRealHp new_realHp
 336   = do  { hp_usage <- getHpUsage
 337         ; setHpUsage (hp_usage {realHp = new_realHp}) }
 338
 339 getBinds :: FCode CgBindings
 340 getBinds = do
 341         state <- getState
 342         return $ cgs_binds state
 343
 344 setBinds :: CgBindings -> FCode ()
 345 setBinds new_binds = do
 346         state <- getState
 347         setState $ state {cgs_binds = new_binds}
 348
 349 getStaticBinds :: FCode CgBindings
 350 getStaticBinds = do
 351         info  <- getInfoDown
 352         return (cgd_statics info)
 353
 354 withState :: FCode a -> CgState -> FCode (a,CgState)
 355 withState (FCode fcode) newstate = FCode $ \info_down state ->
 356         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
 357
 358 newUniqSupply :: FCode UniqSupply
 359 newUniqSupply = do
 360         state <- getState
 361         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
 362         setState $ state { cgs_uniqs = us1 }
 363         return us2
 364
 365 newUnique :: FCode Unique
 366 newUnique = do
 367         us <- newUniqSupply
 368         return (uniqFromSupply us)
 369
 370 ------------------
 371 getInfoDown :: FCode CgInfoDownwards
 372 getInfoDown = FCode $ \info_down state -> (info_down,state)
 373
 374 getDynFlags :: FCode DynFlags
 375 getDynFlags = liftM cgd_dflags getInfoDown
 376
 377 getThisPackage :: FCode PackageId
 378 getThisPackage = liftM thisPackage getDynFlags
 379
 380 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 381 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 382
 383 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
 384 doFCode (FCode fcode) info_down state = fcode info_down state
 385
 386
 387 -- ----------------------------------------------------------------------------
 388 -- Get the current module name
 389
 390 getModuleName :: FCode Module
 391 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
 392
 393 -- ----------------------------------------------------------------------------
 394 -- Get/set the end-of-block info
 395
 396 withSequel :: Sequel -> FCode () -> FCode ()
 397 withSequel sequel code
 398   = do  { info  <- getInfoDown
 399         ; withInfoDown code (info {cgd_sequel = sequel }) }
 400
 401 getSequel :: FCode Sequel
 402 getSequel = do  { info <- getInfoDown
 403                 ; return (cgd_sequel info) }
 404
 405 -- ----------------------------------------------------------------------------
 406 -- Get/set the current SRT label
 407
 408 -- There is just one SRT for each top level binding; all the nested
 409 -- bindings use sub-sections of this SRT.  The label is passed down to
 410 -- the nested bindings via the monad.
 411
 412 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
 413 getSRTLabel = do info  <- getInfoDown
 414                  return (cgd_srt_lbl info)
 415
 416 setSRTLabel :: CLabel -> FCode a -> FCode a
 417 setSRTLabel srt_lbl code
 418   = do  info <- getInfoDown
 419         withInfoDown code (info { cgd_srt_lbl = srt_lbl})
 420
 421 -- ----------------------------------------------------------------------------
 422 -- Get/set the size of the update frame
 423
 424 -- We keep track of the size of the update frame so that we
 425 -- can set the stack pointer to the proper address on return
 426 -- (or tail call) from the closure.
 427 -- There should be at most one update frame for each closure.
 428 -- Note: I'm including the size of the original return address
 429 -- in the size of the update frame -- hence the default case on `get'.
 430
 431 withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
 432 withUpdFrameOff size code
 433   = do  { info  <- getInfoDown
 434         ; withInfoDown code (info {cgd_updfr_off = size }) }
 435
 436 getUpdFrameOff :: FCode UpdFrameOffset
 437 getUpdFrameOff
 438   = do  { info  <- getInfoDown
 439         ; return $ cgd_updfr_off info }
 440
 441 -- ----------------------------------------------------------------------------
 442 -- Get/set the current ticky counter label
 443
 444 getTickyCtrLabel :: FCode CLabel
 445 getTickyCtrLabel = do
 446         info <- getInfoDown
 447         return (cgd_ticky info)
 448
 449 setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
 450 setTickyCtrLabel ticky code = do
 451         info <- getInfoDown
 452         withInfoDown code (info {cgd_ticky = ticky})
 453
 454
 455 --------------------------------------------------------
 456 --              Forking
 457 --------------------------------------------------------
 458
 459 forkClosureBody :: FCode () -> FCode ()
 460 -- forkClosureBody takes a code, $c$, and compiles it in a
 461 -- fresh environment, except that:
 462 --      - compilation info and statics are passed in unchanged.
 463 --      - local bindings are passed in unchanged
 464 --        (it's up to the enclosed code to re-bind the
 465 --         free variables to a field of the closure)
 466 --
 467 -- The current state is passed on completely unaltered, except that
 468 -- C-- from the fork is incorporated.
 469
 470 forkClosureBody body_code
 471   = do  { info <- getInfoDown
 472         ; us   <- newUniqSupply
 473         ; state <- getState
 474         ; let   body_info_down = info { cgd_sequel    = initSequel
 475                                       , cgd_updfr_off = initUpdFrameOff }
 476                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
 477                 ((),fork_state_out)
 478                     = doFCode body_code body_info_down fork_state_in
 479         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 480
 481 forkStatics :: FCode a -> FCode a
 482 -- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
 483 -- from the current *local bindings*, but which is otherwise freshly initialised.
 484 -- The Abstract~C returned is attached to the current state, but the
 485 -- bindings and usage information is otherwise unchanged.
 486 forkStatics body_code
 487   = do  { info  <- getInfoDown
 488         ; us    <- newUniqSupply
 489         ; state <- getState
 490         ; let   rhs_info_down = info { cgd_statics = cgs_binds state
 491                                      , cgd_sequel  = initSequel
 492                                      , cgd_updfr_off = initUpdFrameOff }
 493                 (result, fork_state_out) = doFCode body_code rhs_info_down
 494                                                    (initCgState us)
 495         ; setState (state `addCodeBlocksFrom` fork_state_out)
 496         ; return result }
 497
 498 forkProc :: FCode a -> FCode a
 499 -- 'forkProc' takes a code and compiles it in the *current* environment,
 500 -- returning the graph thus constructed.
 501 --
 502 -- The current environment is passed on completely unchanged to
 503 -- the successor.  In particular, any heap usage from the enclosed
 504 -- code is discarded; it should deal with its own heap consumption
 505 forkProc body_code
 506   = do  { info_down <- getInfoDown
 507         ; us    <- newUniqSupply
 508         ; state <- getState
 509         ; let   info_down' = info_down { cgd_sequel = initSequel }
 510                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
 511                 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
 512         ; setState $ state `addCodeBlocksFrom` fork_state_out
 513         ; return result }
 514
 515 codeOnly :: FCode () -> FCode ()
 516 -- Emit any code from the inner thing into the outer thing
 517 -- Do not affect anything else in the outer state
 518 -- Used in almost-circular code to prevent false loop dependencies
 519 codeOnly body_code
 520   = do  { info_down <- getInfoDown
 521         ; us   <- newUniqSupply
 522         ; state <- getState
 523         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
 524                                                    cgs_hp_usg  = cgs_hp_usg state }
 525                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
 526         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 527
 528 forkAlts :: [FCode a] -> FCode [a]
 529 -- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
 530 -- an fcode for the default case 'd', and compiles each in the current
 531 -- environment.  The current environment is passed on unmodified, except
 532 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
 533
 534 forkAlts branch_fcodes
 535   = do  { info_down <- getInfoDown
 536         ; us <- newUniqSupply
 537         ; state <- getState
 538         ; let compile us branch
 539                 = (us2, doFCode branch info_down branch_state)
 540                 where
 541                   (us1,us2) = splitUniqSupply us
 542                   branch_state = (initCgState us1) {
 543                                         cgs_binds   = cgs_binds state,
 544                                         cgs_hp_usg  = cgs_hp_usg state }
 545
 546               (_us, results) = mapAccumL compile us branch_fcodes
 547               (branch_results, branch_out_states) = unzip results
 548         ; setState $ foldl stateIncUsage state branch_out_states
 549                 -- NB foldl.  state is the *left* argument to stateIncUsage
 550         ; return branch_results }
 551
 552 -- collect the code emitted by an FCode computation
 553 getCodeR :: FCode a -> FCode (a, CmmAGraph)
 554 getCodeR fcode
 555   = do  { state1 <- getState
 556         ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
 557         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
 558         ; return (a, cgs_stmts state2) }
 559
 560 getCode :: FCode a -> FCode CmmAGraph
 561 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
 562
 563 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
 564 -- It initialises the heap usage to zeros, and passes on an unchanged
 565 -- heap usage.
 566 --
 567 -- It is usually a prelude to performing a GC check, so everything must
 568 -- be in a tidy and consistent state.
 569 --
 570 -- Note the slightly subtle fixed point behaviour needed here
 571
 572 getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
 573 getHeapUsage fcode
 574   = do  { info_down <- getInfoDown
 575         ; state <- getState
 576         ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
 577                 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
 578                 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
 579
 580         ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
 581         ; return r }
 582
 583 -- ----------------------------------------------------------------------------
 584 -- Combinators for emitting code
 585
 586 emit :: CmmAGraph -> FCode ()
 587 emit ag
 588   = do  { state <- getState
 589         ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
 590
 591 emitData :: Section -> [CmmStatic] -> FCode ()
 592 emitData sect lits
 593   = do  { state <- getState
 594         ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
 595   where
 596     data_block = CmmData sect lits
 597
 598 emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
 599                           CmmAGraph -> FCode ()
 600 emitProcWithConvention conv info lbl args blocks
 601   = do  { us <- newUniqSupply
 602         ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
 603               blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
 604         ; let proc_block = CmmProc info lbl args blks
 605         ; state <- getState
 606         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 607
 608 emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
 609 emitProc = emitProcWithConvention Native
 610
 611 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 612 emitSimpleProc lbl code =
 613   emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
 614
 615 getCmm :: FCode () -> FCode CmmZ
 616 -- Get all the CmmTops (there should be no stmts)
 617 -- Return a single Cmm which may be split from other Cmms by
 618 -- object splitting (at a later stage)
 619 getCmm code
 620   = do  { state1 <- getState
 621         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
 622         ; setState $ state2 { cgs_tops = cgs_tops state1 }
 623         ; return (Cmm (fromOL (cgs_tops state2))) }
 624
 625 -- ----------------------------------------------------------------------------
 626 -- CgStmts
 627
 628 -- These functions deal in terms of CgStmts, which is an abstract type
 629 -- representing the code in the current proc.
 630
 631 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
 632 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
 633 cgStmtsToBlocks stmts
 634   = do  { us <- newUniqSupply
 635         ; return (initUs_ us (lgraphOfAGraph 0 stmts)) }
 636