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