ghc/compiler/codeGen/CgBindery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CgBindery]{Utility functions related to doing @CgBindings@}
   5
   6 \begin{code}
   7 module CgBindery (
   8         CgBindings, CgIdInfo,
   9         StableLoc, VolatileLoc,
  10
  11         stableAmodeIdInfo, heapIdInfo,
  12         letNoEscapeIdInfo, idInfoToAmode,
  13
  14         addBindC, addBindsC,
  15
  16         nukeVolatileBinds,
  17         nukeDeadBindings,
  18
  19         bindNewToStack,  rebindToStack,
  20         bindNewToNode, bindNewToReg, bindArgsToRegs,
  21         bindNewToTemp,
  22         getArgAmode, getArgAmodes,
  23         getCAddrModeAndInfo, getCAddrMode,
  24         getCAddrModeIfVolatile, getVolatileRegs,
  25
  26         buildContLivenessMask
  27     ) where
  28
  29 #include "HsVersions.h"
  30
  31 import AbsCSyn
  32 import CgMonad
  33
  34 import CgUsages         ( getHpRelOffset, getSpRelOffset, getRealSp )
  35 import CgStackery       ( freeStackSlots, getStackFrame )
  36 import CLabel           ( mkClosureLabel,
  37                           mkBitmapLabel, pprCLabel )
  38 import ClosureInfo      ( mkLFImported, mkLFArgument, LambdaFormInfo )
  39 import Bitmap
  40 import PrimRep          ( isFollowableRep, getPrimRepSize )
  41 import Id               ( Id, idPrimRep, idType )
  42 import Type             ( typePrimRep )
  43 import VarEnv
  44 import VarSet           ( varSetElems )
  45 import Literal          ( Literal )
  46 import Maybes           ( catMaybes, maybeToBool, seqMaybe )
  47 import Name             ( isInternalName, NamedThing(..) )
  48 #ifdef DEBUG
  49 import PprAbsC          ( pprAmode, pprMagicId )
  50 #endif
  51 import PrimRep          ( PrimRep(..) )
  52 import StgSyn           ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
  53 import Unique           ( Unique, Uniquable(..) )
  54 import UniqSet          ( elementOfUniqSet )
  55 import Util             ( zipWithEqual, sortLt )
  56 import Outputable
  57 \end{code}
  58
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection[Bindery-datatypes]{Data types}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 @(CgBinding a b)@ is a type of finite maps from a to b.
  67
  68 The assumption used to be that @lookupCgBind@ must get exactly one
  69 match.  This is {\em completely wrong} in the case of compiling
  70 letrecs (where knot-tying is used).  An initial binding is fed in (and
  71 never evaluated); eventually, a correct binding is put into the
  72 environment.  So there can be two bindings for a given name.
  73
  74 \begin{code}
  75 type CgBindings = IdEnv CgIdInfo
  76
  77 data CgIdInfo
  78   = MkCgIdInfo  Id      -- Id that this is the info for
  79                 VolatileLoc
  80                 StableLoc
  81                 LambdaFormInfo
  82
  83 data VolatileLoc
  84   = NoVolatileLoc
  85   | TempVarLoc  Unique
  86
  87   | RegLoc      MagicId                 -- in one of the magic registers
  88                                         -- (probably {Int,Float,Char,etc}Reg)
  89
  90   | VirHpLoc    VirtualHeapOffset       -- Hp+offset (address of closure)
  91
  92   | VirNodeLoc  VirtualHeapOffset       -- Cts of offset indirect from Node
  93                                         -- ie *(Node+offset)
  94 \end{code}
  95
  96 @StableLoc@ encodes where an Id can be found, used by
  97 the @CgBindings@ environment in @CgBindery@.
  98
  99 \begin{code}
 100 data StableLoc
 101   = NoStableLoc
 102   | VirStkLoc           VirtualSpOffset
 103   | LitLoc              Literal
 104   | StableAmodeLoc      CAddrMode
 105
 106 -- these are so StableLoc can be abstract:
 107
 108 maybeStkLoc (VirStkLoc offset) = Just offset
 109 maybeStkLoc _                  = Nothing
 110 \end{code}
 111
 112 \begin{code}
 113 instance Outputable CgIdInfo where
 114   ppr (MkCgIdInfo id vol stb lf)
 115     = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
 116
 117 instance Outputable VolatileLoc where
 118   ppr NoVolatileLoc = empty
 119   ppr (TempVarLoc u) = ptext SLIT("tmp") <+> ppr u
 120   ppr (RegLoc r)     = ptext SLIT("reg") <+> pprMagicId r
 121   ppr (VirHpLoc v)   = ptext SLIT("vh") <+> ppr v
 122   ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
 123
 124 instance Outputable StableLoc where
 125   ppr NoStableLoc        = empty
 126   ppr (VirStkLoc v)      = ptext SLIT("vs") <+> ppr v
 127   ppr (LitLoc l)         = ptext SLIT("lit") <+> ppr l
 128   ppr (StableAmodeLoc a) = ptext SLIT("amode") <+> pprAmode a
 129 \end{code}
 130
 131 %************************************************************************
 132 %*                                                                      *
 133 \subsection[Bindery-idInfo]{Manipulating IdInfo}
 134 %*                                                                      *
 135 %************************************************************************
 136
 137 \begin{code}
 138 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
 139 heapIdInfo i offset       lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
 140 tempIdInfo i uniq         lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
 141
 142 letNoEscapeIdInfo i sp lf_info
 143   = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
 144
 145 idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
 146 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
 147
 148 idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
 149
 150 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc   = returnFC (CTemp uniq kind)
 151 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc   = returnFC (CReg magic_id)
 152
 153 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit)           = returnFC (CLit lit)
 154 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
 155
 156 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
 157   = returnFC (CVal (nodeRel nd_off) kind)
 158     -- Virtual offsets from Node increase into the closures,
 159     -- and so do Node-relative offsets (which we want in the CVal),
 160     -- so there is no mucking about to do to the offset.
 161
 162 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
 163   = getHpRelOffset hp_off `thenFC` \ rel_hp ->
 164     returnFC (CAddr rel_hp)
 165
 166 idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
 167   = getSpRelOffset i `thenFC` \ rel_sp ->
 168     returnFC (CVal rel_sp kind)
 169
 170 #ifdef DEBUG
 171 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
 172 #endif
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 There are three basic routines, for adding (@addBindC@), modifying
 182 (@modifyBindC@) and looking up (@lookupBindC@) bindings.
 183
 184 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
 185 The name should not already be bound. (nice ASSERT, eh?)
 186
 187 \begin{code}
 188 addBindC :: Id -> CgIdInfo -> Code
 189 addBindC name stuff_to_bind = do
 190         binds <- getBinds
 191         setBinds $ extendVarEnv binds name stuff_to_bind
 192
 193 addBindsC :: [(Id, CgIdInfo)] -> Code
 194 addBindsC new_bindings = do
 195         binds <- getBinds
 196         let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
 197                 binds
 198                 new_bindings
 199         setBinds new_binds
 200
 201 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
 202 modifyBindC name mangle_fn = do
 203         binds <- getBinds
 204         setBinds $ modifyVarEnv mangle_fn binds name
 205
 206 lookupBindC :: Id -> FCode CgIdInfo
 207 lookupBindC id = do maybe_info <- lookupBindC_maybe id
 208                     case maybe_info of
 209                       Just info -> return info
 210                       Nothing   -> cgLookupPanic id
 211
 212 lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo)
 213 lookupBindC_maybe id
 214   = do  static_binds <- getStaticBinds
 215         local_binds  <- getBinds
 216         return (lookupVarEnv local_binds id
 217                         `seqMaybe`
 218                 lookupVarEnv static_binds id)
 219
 220 cgLookupPanic :: Id -> FCode a
 221 cgLookupPanic id
 222   = do  static_binds <- getStaticBinds
 223         local_binds <- getBinds
 224         srt <- getSRTLabel
 225         pprPanic "cgPanic"
 226                 (vcat [ppr id,
 227                 ptext SLIT("static binds for:"),
 228                 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
 229                 ptext SLIT("local binds for:"),
 230                 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
 231                 ptext SLIT("SRT label") <+> pprCLabel srt
 232               ])
 233 \end{code}
 234
 235 %************************************************************************
 236 %*                                                                      *
 237 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
 238 %*                                                                      *
 239 %************************************************************************
 240
 241 We sometimes want to nuke all the volatile bindings; we must be sure
 242 we don't leave any (NoVolatile, NoStable) binds around...
 243
 244 \begin{code}
 245 nukeVolatileBinds :: CgBindings -> CgBindings
 246 nukeVolatileBinds binds
 247   = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
 248   where
 249     keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
 250     keep_if_stable (MkCgIdInfo i _ stable_loc  entry_info) acc
 251       = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
 252 \end{code}
 253
 254
 255 %************************************************************************
 256 %*                                                                      *
 257 \subsection[lookup-interface]{Interface functions to looking up bindings}
 258 %*                                                                      *
 259 %************************************************************************
 260
 261 I {\em think} all looking-up is done through @getCAddrMode(s)@.
 262
 263 \begin{code}
 264 getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
 265
 266 getCAddrModeAndInfo id
 267   = do
 268         maybe_cg_id_info <- lookupBindC_maybe id
 269         case maybe_cg_id_info of
 270
 271                 -- Nothing => not in the environment, so should be imported
 272           Nothing | isInternalName name -> cgLookupPanic id
 273                   | otherwise        -> returnFC (id, global_amode, mkLFImported id)
 274
 275           Just (MkCgIdInfo id' volatile_loc stable_loc lf_info)
 276                   -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
 277                         return (id', amode, lf_info)
 278   where
 279     name = getName id
 280     global_amode = CLbl (mkClosureLabel name) kind
 281     kind = idPrimRep id
 282
 283 getCAddrMode :: Id -> FCode CAddrMode
 284 getCAddrMode name = do
 285         (_, amode, _) <- getCAddrModeAndInfo name
 286         return amode
 287 \end{code}
 288
 289 \begin{code}
 290 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
 291 getCAddrModeIfVolatile name
 292 --  | toplevelishId name = returnFC Nothing
 293 --  | otherwise
 294         = do
 295         (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
 296         case stable_loc of
 297                 NoStableLoc -> do -- Aha!  So it is volatile!
 298                         amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
 299                         return $ Just amode
 300                 a_stable_loc -> return Nothing
 301 \end{code}
 302
 303 @getVolatileRegs@ gets a set of live variables, and returns a list of
 304 all registers on which these variables depend.  These are the regs
 305 which must be saved and restored across any C calls.  If a variable is
 306 both in a volatile location (depending on a register) {\em and} a
 307 stable one (notably, on the stack), we modify the current bindings to
 308 forget the volatile one.
 309
 310 \begin{code}
 311 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
 312
 313 getVolatileRegs vars = do
 314         stuff <- mapFCs snaffle_it (varSetElems vars)
 315         returnFC $ catMaybes stuff
 316         where
 317         snaffle_it var = do
 318                 (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
 319                 let
 320                 -- commoned-up code...
 321                         consider_reg reg =
 322                                 if not (isVolatileReg reg) then
 323                                 -- Potentially dies across C calls
 324                                 -- For now, that's everything; we leave
 325                                 -- it to the save-macros to decide which
 326                                 -- regs *really* need to be saved.
 327                                         returnFC Nothing
 328                                 else
 329                                         case stable_loc of
 330                                                 NoStableLoc -> returnFC (Just reg) -- got one!
 331                                                 is_a_stable_loc -> do
 332                                                         -- has both volatile & stable locations;
 333                                                         -- force it to rely on the stable location
 334                                                         modifyBindC var nuke_vol_bind
 335                                                         return Nothing
 336                         in
 337                         case volatile_loc of
 338                                 RegLoc reg   -> consider_reg reg
 339                                 VirNodeLoc _ -> consider_reg node
 340                                 non_reg_loc  -> returnFC Nothing
 341
 342         nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
 343                 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
 344 \end{code}
 345
 346 \begin{code}
 347 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
 348 getArgAmodes [] = returnFC []
 349 getArgAmodes (atom:atoms)
 350         | isStgTypeArg atom
 351         = getArgAmodes atoms
 352         | otherwise = do
 353                 amode <- getArgAmode  atom
 354                 amodes <- getArgAmodes atoms
 355                 return ( amode : amodes )
 356
 357 getArgAmode :: StgArg -> FCode CAddrMode
 358
 359 getArgAmode (StgVarArg var) = getCAddrMode var          -- The common case
 360 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
 361 \end{code}
 362
 363 %************************************************************************
 364 %*                                                                      *
 365 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
 366 %*                                                                      *
 367 %************************************************************************
 368
 369 \begin{code}
 370 bindNewToStack :: (Id, VirtualSpOffset) -> Code
 371 bindNewToStack (name, offset)
 372   = addBindC name info
 373   where
 374     info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name)
 375
 376 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
 377 bindNewToNode name offset lf_info
 378   = addBindC name info
 379   where
 380     info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
 381
 382 -- Create a new temporary whose unique is that in the id,
 383 -- bind the id to it, and return the addressing mode for the
 384 -- temporary.
 385 bindNewToTemp :: Id -> FCode CAddrMode
 386 bindNewToTemp id
 387   = do  addBindC id id_info
 388         return temp_amode
 389   where
 390     uniq       = getUnique id
 391     temp_amode = CTemp uniq (idPrimRep id)
 392     id_info    = tempIdInfo id uniq lf_info
 393     lf_info    = mkLFArgument id        -- Always used of things we
 394                                         -- know nothing about
 395
 396 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
 397 bindNewToReg name magic_id lf_info
 398   = addBindC name info
 399   where
 400     info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
 401
 402 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 403 bindArgsToRegs args regs
 404   = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
 405   where
 406     arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
 407 \end{code}
 408
 409 \begin{code}
 410 rebindToStack :: Id -> VirtualSpOffset -> Code
 411 rebindToStack name offset
 412   = modifyBindC name replace_stable_fn
 413   where
 414     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 415       = MkCgIdInfo i vol (VirStkLoc offset) einfo
 416 \end{code}
 417
 418 %************************************************************************
 419 %*                                                                      *
 420 \subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
 421 %*                                                                      *
 422 %************************************************************************
 423
 424 There are four kinds of things on the stack:
 425
 426         - pointer variables (bound in the environment)
 427         - non-pointer variables (boudn in the environment)
 428         - free slots (recorded in the stack free list)
 429         - non-pointer data slots (recorded in the stack free list)
 430
 431 We build up a bitmap of non-pointer slots by searching the environment
 432 for all the pointer variables, and subtracting these from a bitmap
 433 with initially all bits set (up to the size of the stack frame).
 434
 435 \begin{code}
 436 buildLivenessMask
 437         :: VirtualSpOffset      -- size of the stack frame
 438         -> VirtualSpOffset      -- offset from which the bitmap should start
 439         -> FCode Bitmap         -- mask for free/unlifted slots
 440
 441 buildLivenessMask size sp = do {
 442     -- find all live stack-resident pointers
 443     binds <- getBinds;
 444     ((vsp, _, free, _, _), heap_usage) <- getUsage;
 445
 446     let {
 447         rel_slots = sortLt (<)
 448             [ sp - ofs  -- get slots relative to top of frame
 449             | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
 450               isFollowableRep (idPrimRep id)
 451             ];
 452     };
 453
 454     WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds )
 455     return (intsToReverseBitmap size rel_slots)
 456   }
 457
 458 -- In a continuation, we want a liveness mask that starts from just after
 459 -- the return address, which is on the stack at realSp.
 460
 461 buildContLivenessMask :: Id -> FCode Liveness
 462         -- The Id is used just for its unique to make a label
 463 buildContLivenessMask id = do
 464         realSp <- getRealSp
 465
 466         frame_sp <- getStackFrame
 467         -- realSp points to the frame-header for the current stack frame,
 468         -- and the end of this frame is frame_sp.  The size is therefore
 469         -- realSp - frame_sp - 1 (subtract one for the frame-header).
 470         let frame_size = realSp - frame_sp - 1
 471
 472         mask <- buildLivenessMask frame_size (realSp-1)
 473
 474         let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask
 475         absC (maybeLargeBitmap liveness)
 476         return liveness
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481 \subsection[CgMonad-deadslots]{Finding dead stack slots}
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 nukeDeadBindings does the following:
 486
 487       - Removes all bindings from the environment other than those
 488         for variables in the argument to nukeDeadBindings.
 489       - Collects any stack slots so freed, and returns them to the  stack free
 490         list.
 491       - Moves the virtual stack pointer to point to the topmost used
 492         stack locations.
 493
 494 You can have multi-word slots on the stack (where a Double# used to
 495 be, for instance); if dead, such a slot will be reported as *several*
 496 offsets (one per word).
 497
 498 Probably *naughty* to look inside monad...
 499
 500 \begin{code}
 501 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
 502                  -> Code
 503 nukeDeadBindings live_vars = do
 504         binds <- getBinds
 505         let (dead_stk_slots, bs') =
 506                 dead_slots live_vars
 507                         [] []
 508                         [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
 509         setBinds $ mkVarEnv bs'
 510         freeStackSlots dead_stk_slots
 511 \end{code}
 512
 513 Several boring auxiliary functions to do the dirty work.
 514
 515 \begin{code}
 516 dead_slots :: StgLiveVars
 517            -> [(Id,CgIdInfo)]
 518            -> [VirtualSpOffset]
 519            -> [(Id,CgIdInfo)]
 520            -> ([VirtualSpOffset], [(Id,CgIdInfo)])
 521
 522 -- dead_slots carries accumulating parameters for
 523 --      filtered bindings, dead slots
 524 dead_slots live_vars fbs ds []
 525   = (ds, reverse fbs) -- Finished; rm the dups, if any
 526
 527 dead_slots live_vars fbs ds ((v,i):bs)
 528   | v `elementOfUniqSet` live_vars
 529     = dead_slots live_vars ((v,i):fbs) ds bs
 530           -- Live, so don't record it in dead slots
 531           -- Instead keep it in the filtered bindings
 532
 533   | otherwise
 534     = case i of
 535         MkCgIdInfo _ _ stable_loc _
 536          | is_stk_loc && size > 0 ->
 537            dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
 538          where
 539           maybe_stk_loc = maybeStkLoc stable_loc
 540           is_stk_loc    = maybeToBool maybe_stk_loc
 541           (Just offset) = maybe_stk_loc
 542
 543         _ -> dead_slots live_vars fbs ds bs
 544   where
 545
 546     size :: Int
 547     size = (getPrimRepSize . typePrimRep . idType) v
 548
 549 \end{code}