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