ghc/compiler/codeGen/CgMonad.lhs

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