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