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