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