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