ghc/compiler/codeGen/CgMonad.lhs

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