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