ghc/compiler/codeGen/CgMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgMonad.lhs,v 1.23 1999/10/13 16:39:16 simonmar Exp $
   5 %
   6 \section[CgMonad]{The code generation monad}
   7
   8 See the beginning of the top-level @CodeGen@ module, to see how this
   9 monadic stuff fits into the Big Picture.
  10
  11 \begin{code}
  12 module CgMonad (
  13         Code,   -- type
  14         FCode,  -- type
  15
  16         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
  17         returnFC, fixC, absC, nopC, getAbsC,
  18
  19         forkClosureBody, forkStatics, forkAlts, forkEval,
  20         forkEvalHelp, forkAbsC,
  21         SemiTaggingStuff,
  22
  23         EndOfBlockInfo(..),
  24         setEndOfBlockInfo, getEndOfBlockInfo,
  25
  26         setSRTLabel, getSRTLabel,
  27         setTickyCtrLabel, getTickyCtrLabel,
  28
  29         StackUsage, Slot(..), HeapUsage,
  30
  31         profCtrC, profCtrAbsC,
  32
  33         costCentresC, moduleName,
  34
  35         Sequel(..), -- ToDo: unabstract?
  36         sequelToAmode,
  37
  38         -- out of general friendliness, we also export ...
  39         CgInfoDownwards(..), CgState(..),       -- non-abstract
  40         CompilationInfo(..)
  41     ) where
  42
  43 #include "HsVersions.h"
  44
  45 import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds )
  46 import {-# SOURCE #-} CgUsages  ( getSpRelOffset )
  47
  48 import AbsCSyn
  49 import AbsCUtils        ( mkAbsCStmts )
  50 import CmdLineOpts      ( opt_SccProfilingOn, opt_DoTickyProfiling )
  51 import CLabel           ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
  52 import Module           ( Module )
  53 import DataCon          ( ConTag )
  54 import Id               ( Id )
  55 import VarEnv
  56 import PrimRep          ( PrimRep(..) )
  57 import StgSyn           ( StgLiveVars )
  58 import Outputable
  59
  60 infixr 9 `thenC`        -- Right-associative!
  61 infixr 9 `thenFC`
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection[CgMonad-environment]{Stuff for manipulating environments}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 This monadery has some information that it only passes {\em
  71 downwards}, as well as some ``state'' which is modified as we go
  72 along.
  73
  74 \begin{code}
  75 data CgInfoDownwards    -- information only passed *downwards* by the monad
  76   = MkCgInfoDown
  77      CompilationInfo    -- COMPLETELY STATIC info about this compilation
  78                         --  (e.g., what flags were passed to the compiler)
  79
  80      CgBindings         -- [Id -> info] : static environment
  81
  82      CLabel             -- label of the current SRT
  83
  84      CLabel             -- current destination for ticky counts
  85
  86      EndOfBlockInfo     -- Info for stuff to do at end of basic block:
  87
  88
  89 data CompilationInfo
  90   = MkCompInfo
  91         Module          -- the module name
  92
  93 data CgState
  94   = MkCgState
  95         AbstractC       -- code accumulated so far
  96         CgBindings      -- [Id -> info] : *local* bindings environment
  97                         -- Bindings for top-level things are given in the info-down part
  98         CgStksAndHeapUsage
  99 \end{code}
 100
 101 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
 102 if the expression is a @case@, what to do at the end of each
 103 alternative.
 104
 105 \begin{code}
 106 data EndOfBlockInfo
 107   = EndOfBlockInfo
 108         VirtualSpOffset   -- Args Sp: trim the stack to this point at a
 109                           -- return; push arguments starting just
 110                           -- above this point on a tail call.
 111
 112                           -- This is therefore the stk ptr as seen
 113                           -- by a case alternative.
 114         Sequel
 115
 116 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
 117 \end{code}
 118
 119 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
 120 that it must survive stack pointer adjustments at the end of the
 121 block.
 122
 123 \begin{code}
 124 data Sequel
 125   = OnStack
 126         VirtualSpOffset   -- Continuation is on the stack, at the
 127                           -- specified location
 128
 129   | UpdateCode
 130
 131   | CaseAlts
 132           CAddrMode   -- Jump to this; if the continuation is for a vectored
 133                       -- case this might be the label of a return
 134                       -- vector Guaranteed to be a non-volatile
 135                       -- addressing mode (I think)
 136           SemiTaggingStuff
 137
 138   | SeqFrame                    -- like CaseAlts but push a seq frame too.
 139           CAddrMode
 140           SemiTaggingStuff
 141
 142 type SemiTaggingStuff
 143   = Maybe                           -- Maybe[1] we don't have any semi-tagging stuff...
 144      ([(ConTag, JoinDetails)],      -- Alternatives
 145       Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
 146                                     -- Maybe[3] the default is a
 147                                     -- bind-default (Just b); that is,
 148                                     -- it expects a ptr to the thing
 149                                     -- in Node, bound to b
 150      )
 151
 152 type JoinDetails
 153   = (AbstractC, CLabel)         -- Code to load regs from heap object + profiling macros,
 154                                 -- and join point label
 155
 156 -- The abstract C is executed only from a successful semitagging
 157 -- venture, when a case has looked at a variable, found that it's
 158 -- evaluated, and wants to load up the contents and go to the join
 159 -- point.
 160
 161 -- DIRE WARNING.
 162 -- The OnStack case of sequelToAmode delivers an Amode which is only
 163 -- valid just before the final control transfer, because it assumes
 164 -- that Sp is pointing to the top word of the return address.  This
 165 -- seems unclean but there you go.
 166
 167 -- sequelToAmode returns an amode which refers to an info table.  The info
 168 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind.  We're careful
 169 -- not to handle real code pointers, just in case we're compiling for
 170 -- an unregisterised/untailcallish architecture, where info pointers and
 171 -- code pointers aren't the same.
 172
 173 sequelToAmode :: Sequel -> FCode CAddrMode
 174
 175 sequelToAmode (OnStack virt_sp_offset)
 176   = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
 177     returnFC (CVal sp_rel RetRep)
 178
 179 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
 180 sequelToAmode (CaseAlts amode _) = returnFC amode
 181 sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
 182
 183 type CgStksAndHeapUsage         -- stacks and heap usage information
 184   = (StackUsage, HeapUsage)
 185
 186 data Slot = Free | NonPointer
 187   deriving
 188 #ifdef DEBUG
 189         (Eq,Show)
 190 #else
 191         Eq
 192 #endif
 193
 194 type StackUsage =
 195         (Int,              -- virtSp: Virtual offset of topmost allocated slot
 196          [(Int,Slot)],     -- free:   List of free slots, in increasing order
 197          Int,              -- realSp: Virtual offset of real stack pointer
 198          Int)              -- hwSp:   Highest value ever taken by virtSp
 199
 200 type HeapUsage =
 201         (HeapOffset,    -- virtHp: Virtual offset of highest-allocated word
 202          HeapOffset)    -- realHp: Virtual offset of real heap ptr
 203 \end{code}
 204
 205 NB: absolutely every one of the above Ints is really
 206 a VirtualOffset of some description (the code generator
 207 works entirely in terms of VirtualOffsets).
 208
 209 Initialisation.
 210
 211 \begin{code}
 212 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
 213
 214 initUsage :: CgStksAndHeapUsage
 215 initUsage  = ((0,[],0,0), (0,0))
 216 \end{code}
 217
 218 "envInitForAlternatives" initialises the environment for a case alternative,
 219 assuming that the alternative is entered after an evaluation.
 220 This involves:
 221
 222    - zapping any volatile bindings, which aren't valid.
 223
 224    - zapping the heap usage. It should be restored by a heap check.
 225
 226    - setting the virtual AND real stack pointer fields to the given
 227    virtual stack offsets.  this doesn't represent any {\em code}; it is a
 228    prediction of where the real stack pointer will be when we come back
 229    from the case analysis.
 230
 231    - BUT LEAVING the rest of the stack-usage info because it is all
 232    valid.  In particular, we leave the tail stack pointers unchanged,
 233    becuase the alternative has to de-allocate the original @case@
 234    expression's stack.  \end{itemize}
 235
 236 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 237 marks found in $e_2$.
 238
 239 \begin{code}
 240 stateIncUsage :: CgState -> CgState -> CgState
 241
 242 stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
 243               (MkCgState _     _  ((_,_,_,h2),(vH2, _)))
 244      = MkCgState abs_c
 245                  bs
 246                  ((v,f,r,h1 `max` h2),
 247                   (vH1 `max` vH2, rH1))
 248 \end{code}
 249
 250 %************************************************************************
 251 %*                                                                      *
 252 \subsection[CgMonad-basics]{Basic code-generation monad magic}
 253 %*                                                                      *
 254 %************************************************************************
 255
 256 \begin{code}
 257 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
 258 type Code    = CgInfoDownwards -> CgState -> CgState
 259
 260 {-# INLINE thenC #-}
 261 {-# INLINE thenFC #-}
 262 {-# INLINE returnFC #-}
 263 \end{code}
 264 The Abstract~C is not in the environment so as to improve strictness.
 265
 266 \begin{code}
 267 initC :: CompilationInfo -> Code -> AbstractC
 268
 269 initC cg_info code
 270   = case (code (MkCgInfoDown
 271                         cg_info
 272                         (error "initC: statics")
 273                         (error "initC: srt")
 274                         (mkTopTickyCtrLabel)
 275                         initEobInfo)
 276                initialStateC) of
 277       MkCgState abc _ _ -> abc
 278
 279 returnFC :: a -> FCode a
 280
 281 returnFC val info_down state = (val, state)
 282 \end{code}
 283
 284 \begin{code}
 285 thenC :: Code
 286       -> (CgInfoDownwards -> CgState -> a)
 287       -> CgInfoDownwards -> CgState -> a
 288
 289 -- thenC has both of the following types:
 290 -- thenC :: Code -> Code    -> Code
 291 -- thenC :: Code -> FCode a -> FCode a
 292
 293 thenC m k info_down state
 294   = k info_down new_state
 295   where
 296     new_state  = m info_down state
 297
 298 listCs :: [Code] -> Code
 299
 300 listCs []     info_down state = state
 301 listCs (c:cs) info_down state = stateN
 302   where
 303     state1 = c         info_down state
 304     stateN = listCs cs info_down state1
 305
 306 mapCs :: (a -> Code) -> [a] -> Code
 307
 308 mapCs f []     info_down state = state
 309 mapCs f (c:cs) info_down state = stateN
 310   where
 311     state1 = (f c)      info_down state
 312     stateN = mapCs f cs info_down state1
 313 \end{code}
 314
 315 \begin{code}
 316 thenFC  :: FCode a
 317         -> (a -> CgInfoDownwards -> CgState -> c)
 318         -> CgInfoDownwards -> CgState -> c
 319
 320 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
 321 -- thenFC :: FCode a -> (a -> Code)    -> Code
 322
 323 thenFC m k info_down state
 324   = k m_result info_down new_state
 325   where
 326     (m_result, new_state) = m info_down state
 327
 328 listFCs :: [FCode a] -> FCode [a]
 329
 330 listFCs []       info_down state = ([],             state)
 331 listFCs (fc:fcs) info_down state = (thing : things, stateN)
 332   where
 333     (thing,  state1) = fc          info_down state
 334     (things, stateN) = listFCs fcs info_down state1
 335
 336 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 337
 338 mapFCs f []       info_down state = ([],             state)
 339 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
 340   where
 341     (thing,  state1) = (f fc)       info_down state
 342     (things, stateN) = mapFCs f fcs info_down state1
 343 \end{code}
 344
 345 And the knot-tying combinator:
 346 \begin{code}
 347 fixC :: (a -> FCode a) -> FCode a
 348 fixC fcode info_down state = result
 349   where
 350     result@(v, _) = fcode v info_down state
 351     --      ^-------------^
 352 \end{code}
 353
 354 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 355 fresh environment, except that:
 356         - compilation info and statics are passed in unchanged.
 357 The current environment is passed on completely unaltered, except that
 358 abstract C from the fork is incorporated.
 359
 360 @forkAbsC@ takes a code and compiles it in the current environment,
 361 returning the abstract C thus constructed.  The current environment
 362 is passed on completely unchanged.  It is pretty similar to @getAbsC@,
 363 except that the latter does affect the environment. ToDo: combine?
 364
 365 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
 366 from the current bindings, but which is otherwise freshly initialised.
 367 The Abstract~C returned is attached to the current state, but the
 368 bindings and usage information is otherwise unchanged.
 369
 370 \begin{code}
 371 forkClosureBody :: Code -> Code
 372
 373 forkClosureBody code
 374         (MkCgInfoDown cg_info statics srt ticky _)
 375         (MkCgState absC_in binds un_usage)
 376   = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
 377   where
 378     fork_state              = code body_info_down initialStateC
 379     MkCgState absC_fork _ _ = fork_state
 380     body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
 381
 382 forkStatics :: FCode a -> FCode a
 383
 384 forkStatics fcode (MkCgInfoDown cg_info _ srt ticky _)
 385                   (MkCgState absC_in statics un_usage)
 386   = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
 387   where
 388   (result, state) = fcode rhs_info_down initialStateC
 389   MkCgState absC_fork _ _ = state       -- Don't merge these this line with the one
 390                                         -- above or it becomes too strict!
 391   rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
 392
 393 forkAbsC :: Code -> FCode AbstractC
 394 forkAbsC code info_down (MkCgState absC1 bs usage)
 395   = (absC2, new_state)
 396   where
 397     MkCgState absC2 _ ((_, _, _,h2), _) =
 398         code info_down (MkCgState AbsCNop bs usage)
 399     ((v, f, r, h1), heap_usage) = usage
 400
 401     new_usage = ((v, f, r, h1 `max` h2), heap_usage)
 402     new_state = MkCgState absC1 bs new_usage
 403 \end{code}
 404
 405 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
 406 an fcode for the default case $d$, and compiles each in the current
 407 environment.  The current environment is passed on unmodified, except
 408 that
 409         - the worst stack high-water mark is incorporated
 410         - the virtual Hp is moved on to the worst virtual Hp for the branches
 411
 412 \begin{code}
 413 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
 414
 415 forkAlts branch_fcodes deflt_fcode info_down in_state
 416  = ((branch_results , deflt_result), out_state)
 417   where
 418     compile fc = fc info_down in_state
 419
 420     (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
 421
 422     (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
 423
 424     out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
 425                 -- NB foldl.  in_state is the *left* argument to stateIncUsage
 426 \end{code}
 427
 428 @forkEval@ takes two blocks of code.
 429
 430    -  The first meddles with the environment to set it up as expected by
 431       the alternatives of a @case@ which does an eval (or gc-possible primop).
 432    -  The second block is the code for the alternatives.
 433       (plus info for semi-tagging purposes)
 434
 435 @forkEval@ picks up the virtual stack pointer and returns a suitable
 436 @EndOfBlockInfo@ for the caller to use, together with whatever value
 437 is returned by the second block.
 438
 439 It uses @initEnvForAlternatives@ to initialise the environment, and
 440 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
 441 usage.
 442
 443 \begin{code}
 444 forkEval :: EndOfBlockInfo              -- For the body
 445          -> Code                        -- Code to set environment
 446          -> FCode Sequel                -- Semi-tagging info to store
 447          -> FCode EndOfBlockInfo        -- The new end of block info
 448
 449 forkEval body_eob_info env_code body_code
 450   = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
 451     returnFC (EndOfBlockInfo v sequel)
 452
 453 forkEvalHelp :: EndOfBlockInfo  -- For the body
 454              -> Code            -- Code to set environment
 455              -> FCode a         -- The code to do after the eval
 456              -> FCode (Int,     -- Sp
 457                        a)       -- Result of the FCode
 458
 459 forkEvalHelp body_eob_info env_code body_code
 460          info_down@(MkCgInfoDown cg_info statics srt ticky _) state
 461   = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
 462   where
 463     info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
 464
 465     (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
 466         -- These v and f things are now set up as the body code expects them
 467
 468     (value_returned, state_at_end_return)
 469         = body_code info_down_for_body state_for_body
 470
 471     state_for_body = MkCgState AbsCNop
 472                              (nukeVolatileBinds binds)
 473                              ((v,f,v,v), (0,0))
 474
 475
 476 stateIncUsageEval :: CgState -> CgState -> CgState
 477 stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
 478                   (MkCgState absC2 _  ((_,_,_,h2),         _))
 479      = MkCgState (absC1 `AbsCStmts` absC2)
 480                  -- The AbsC coming back should consist only of nested declarations,
 481                  -- notably of the return vector!
 482                  bs
 483                  ((v,f,r,h1 `max` h2), heap_usage)
 484         -- We don't max the heap high-watermark because stateIncUsageEval is
 485         -- used only in forkEval, which in turn is only used for blocks of code
 486         -- which do their own heap-check.
 487 \end{code}
 488
 489 %************************************************************************
 490 %*                                                                      *
 491 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
 492 %*                                                                      *
 493 %************************************************************************
 494
 495 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
 496 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
 497 \begin{code}
 498 nopC :: Code
 499 nopC info_down state = state
 500
 501 absC :: AbstractC -> Code
 502 absC more_absC info_down state@(MkCgState absC binds usage)
 503   = MkCgState (mkAbsCStmts absC more_absC) binds usage
 504 \end{code}
 505
 506 These two are just like @absC@, except they examine the compilation
 507 info (whether SCC profiling or profiling-ctrs going) and possibly emit
 508 nothing.
 509
 510 \begin{code}
 511 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
 512
 513 costCentresC macro args _ state@(MkCgState absC binds usage)
 514   = if opt_SccProfilingOn
 515     then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
 516     else state
 517
 518 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
 519
 520 profCtrC macro args _ state@(MkCgState absC binds usage)
 521   = if not opt_DoTickyProfiling
 522     then state
 523     else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
 524
 525 profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
 526
 527 profCtrAbsC macro args
 528   = if not opt_DoTickyProfiling
 529     then AbsCNop
 530     else CCallProfCtrMacro macro args
 531
 532 {- Try to avoid adding too many special compilation strategies here.
 533    It's better to modify the header files as necessary for particular
 534    targets, so that we can get away with as few variants of .hc files
 535    as possible.
 536 -}
 537 \end{code}
 538
 539 @getAbsC@ compiles the code in the current environment, and returns
 540 the abstract C thus constructed (leaving the abstract C being carried
 541 around in the state untouched).  @getAbsC@ does not generate any
 542 in-line Abstract~C itself, but the environment it returns is that
 543 obtained from the compilation.
 544
 545 \begin{code}
 546 getAbsC :: Code -> FCode AbstractC
 547
 548 getAbsC code info_down (MkCgState absC binds usage)
 549   = (absC2, MkCgState absC binds2 usage2)
 550   where
 551     (MkCgState absC2 binds2 usage2)
 552         = code info_down (MkCgState AbsCNop binds usage)
 553 \end{code}
 554
 555 \begin{code}
 556
 557 moduleName :: FCode Module
 558 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
 559   = (mod_name, state)
 560
 561 \end{code}
 562
 563 \begin{code}
 564 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 565 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt ticky _) state
 566   = code (MkCgInfoDown c_info statics srt ticky eob_info) state
 567
 568 getEndOfBlockInfo :: FCode EndOfBlockInfo
 569 getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
 570   = (eob_info, state)
 571 \end{code}
 572
 573 \begin{code}
 574 getSRTLabel :: FCode CLabel
 575 getSRTLabel (MkCgInfoDown _ _ srt _ _) state
 576   = (srt, state)
 577
 578 setSRTLabel :: CLabel -> Code -> Code
 579 setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
 580   = code (MkCgInfoDown c_info statics srt ticky eob_info) state
 581 \end{code}
 582
 583 \begin{code}
 584 getTickyCtrLabel :: FCode CLabel
 585 getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
 586   = (ticky, state)
 587
 588 setTickyCtrLabel :: CLabel -> Code -> Code
 589 setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
 590   = code (MkCgInfoDown c_info statics srt ticky eob_info) state
 591 \end{code}