compiler/codeGen/CgBindery.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[CgBindery]{Utility functions related to doing @CgBindings@}
   6
   7 \begin{code}
   8 module CgBindery (
   9         CgBindings, CgIdInfo,
  10         StableLoc, VolatileLoc,
  11
  12         cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
  13
  14         stableIdInfo, heapIdInfo,
  15         letNoEscapeIdInfo, idInfoToAmode,
  16
  17         addBindC, addBindsC,
  18
  19         nukeVolatileBinds,
  20         nukeDeadBindings,
  21         getLiveStackSlots,
  22
  23         bindArgsToStack,  rebindToStack,
  24         bindNewToNode, bindNewToReg, bindArgsToRegs,
  25         bindNewToTemp,
  26         getArgAmode, getArgAmodes,
  27         getCgIdInfo,
  28         getCAddrModeIfVolatile, getVolatileRegs,
  29         maybeLetNoEscape,
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import CgMonad
  35 import CgHeapery
  36 import CgStackery
  37 import CgUtils
  38 import CLabel
  39 import ClosureInfo
  40
  41 import Cmm
  42 import PprCmm           ( {- instance Outputable -} )
  43 import SMRep
  44 import Id
  45 import VarEnv
  46 import VarSet
  47 import Literal
  48 import Maybes
  49 import Name
  50 import StgSyn
  51 import Unique
  52 import UniqSet
  53 import Outputable
  54 \end{code}
  55
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection[Bindery-datatypes]{Data types}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 @(CgBinding a b)@ is a type of finite maps from a to b.
  64
  65 The assumption used to be that @lookupCgBind@ must get exactly one
  66 match.  This is {\em completely wrong} in the case of compiling
  67 letrecs (where knot-tying is used).  An initial binding is fed in (and
  68 never evaluated); eventually, a correct binding is put into the
  69 environment.  So there can be two bindings for a given name.
  70
  71 \begin{code}
  72 type CgBindings = IdEnv CgIdInfo
  73
  74 data CgIdInfo
  75   = CgIdInfo
  76         { cg_id :: Id   -- Id that this is the info for
  77                         -- Can differ from the Id at occurrence sites by
  78                         -- virtue of being externalised, for splittable C
  79         , cg_rep :: CgRep
  80         , cg_vol :: VolatileLoc
  81         , cg_stb :: StableLoc
  82         , cg_lf  :: LambdaFormInfo }
  83
  84 mkCgIdInfo id vol stb lf
  85   = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
  86                cg_lf = lf, cg_rep = idCgRep id }
  87
  88 voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
  89                          , cg_stb = VoidLoc, cg_lf = mkLFArgument id
  90                          , cg_rep = VoidArg }
  91         -- Used just for VoidRep things
  92
  93 data VolatileLoc        -- These locations die across a call
  94   = NoVolatileLoc
  95   | RegLoc      CmmReg             -- In one of the registers (global or local)
  96   | VirHpLoc    VirtualHpOffset  -- Hp+offset (address of closure)
  97   | VirNodeLoc  VirtualHpOffset  -- Cts of offset indirect from Node
  98                                    -- ie *(Node+offset)
  99 \end{code}
 100
 101 @StableLoc@ encodes where an Id can be found, used by
 102 the @CgBindings@ environment in @CgBindery@.
 103
 104 \begin{code}
 105 data StableLoc
 106   = NoStableLoc
 107
 108   | VirStkLoc   VirtualSpOffset         -- The thing is held in this
 109                                         -- stack slot
 110
 111   | VirStkLNE   VirtualSpOffset         -- A let-no-escape thing; the
 112                                         -- value is this stack pointer
 113                                         -- (as opposed to the contents of the slot)
 114
 115   | StableLoc   CmmExpr
 116   | VoidLoc     -- Used only for VoidRep variables.  They never need to
 117                 -- be saved, so it makes sense to treat treat them as
 118                 -- having a stable location
 119 \end{code}
 120
 121 \begin{code}
 122 instance Outputable CgIdInfo where
 123   ppr (CgIdInfo id rep vol stb lf)
 124     = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
 125
 126 instance Outputable VolatileLoc where
 127   ppr NoVolatileLoc = empty
 128   ppr (RegLoc r)     = ptext SLIT("reg") <+> ppr r
 129   ppr (VirHpLoc v)   = ptext SLIT("vh")  <+> ppr v
 130   ppr (VirNodeLoc v) = ptext SLIT("vn")  <+> ppr v
 131
 132 instance Outputable StableLoc where
 133   ppr NoStableLoc   = empty
 134   ppr VoidLoc       = ptext SLIT("void")
 135   ppr (VirStkLoc v) = ptext SLIT("vs")    <+> ppr v
 136   ppr (VirStkLNE v) = ptext SLIT("lne")    <+> ppr v
 137   ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
 138 \end{code}
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection[Bindery-idInfo]{Manipulating IdInfo}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 \begin{code}
 147 stableIdInfo id amode   lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
 148 heapIdInfo id offset    lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
 149 letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
 150 stackIdInfo id sp       lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
 151 nodeIdInfo id offset    lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
 152 regIdInfo id reg        lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
 153
 154 idInfoToAmode :: CgIdInfo -> FCode CmmExpr
 155 idInfoToAmode info
 156   = case cg_vol info of {
 157       RegLoc reg        -> returnFC (CmmReg reg) ;
 158       VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
 159       VirHpLoc hp_off   -> getHpRelOffset hp_off ;
 160       NoVolatileLoc ->
 161
 162     case cg_stb info of
 163       StableLoc amode  -> returnFC amode
 164       VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
 165                              ; return (CmmLoad sp_rel mach_rep) }
 166
 167       VirStkLNE sp_off -> getSpRelOffset sp_off
 168
 169       VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
 170                 -- We return a 'bottom' amode, rather than panicing now
 171                 -- In this way getArgAmode returns a pair of (VoidArg, bottom)
 172                 -- and that's exactly what we want
 173
 174       NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
 175     }
 176   where
 177     mach_rep = argMachRep (cg_rep info)
 178
 179 cgIdInfoId :: CgIdInfo -> Id
 180 cgIdInfoId = cg_id
 181
 182 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
 183 cgIdInfoLF = cg_lf
 184
 185 cgIdInfoArgRep :: CgIdInfo -> CgRep
 186 cgIdInfoArgRep = cg_rep
 187
 188 maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
 189 maybeLetNoEscape other                                    = Nothing
 190 \end{code}
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 .There are three basic routines, for adding (@addBindC@), modifying
 199 (@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
 200
 201 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
 202 The name should not already be bound. (nice ASSERT, eh?)
 203
 204 \begin{code}
 205 addBindC :: Id -> CgIdInfo -> Code
 206 addBindC name stuff_to_bind = do
 207         binds <- getBinds
 208         setBinds $ extendVarEnv binds name stuff_to_bind
 209
 210 addBindsC :: [(Id, CgIdInfo)] -> Code
 211 addBindsC new_bindings = do
 212         binds <- getBinds
 213         let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
 214                               binds
 215                               new_bindings
 216         setBinds new_binds
 217
 218 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
 219 modifyBindC name mangle_fn = do
 220         binds <- getBinds
 221         setBinds $ modifyVarEnv mangle_fn binds name
 222
 223 getCgIdInfo :: Id -> FCode CgIdInfo
 224 getCgIdInfo id
 225   = do  {       -- Try local bindings first
 226         ; local_binds  <- getBinds
 227         ; case lookupVarEnv local_binds id of {
 228             Just info -> return info ;
 229             Nothing   -> do
 230
 231         {       -- Try top-level bindings
 232           static_binds <- getStaticBinds
 233         ; case lookupVarEnv static_binds id of {
 234             Just info -> return info ;
 235             Nothing   ->
 236
 237                 -- Should be imported; make up a CgIdInfo for it
 238         let
 239             name = idName id
 240         in
 241         if isExternalName name then do
 242             this_pkg <- getThisPackage
 243             let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name))
 244             return (stableIdInfo id ext_lbl (mkLFImported id))
 245         else
 246         if isVoidArg (idCgRep id) then
 247                 -- Void things are never in the environment
 248             return (voidIdInfo id)
 249         else
 250         -- Bug
 251         cgLookupPanic id
 252         }}}}
 253
 254
 255 cgLookupPanic :: Id -> FCode a
 256 cgLookupPanic id
 257   = do  static_binds <- getStaticBinds
 258         local_binds <- getBinds
 259         srt <- getSRTLabel
 260         pprPanic "cgPanic"
 261                 (vcat [ppr id,
 262                 ptext SLIT("static binds for:"),
 263                 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
 264                 ptext SLIT("local binds for:"),
 265                 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
 266                 ptext SLIT("SRT label") <+> pprCLabel srt
 267               ])
 268 \end{code}
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 We sometimes want to nuke all the volatile bindings; we must be sure
 277 we don't leave any (NoVolatile, NoStable) binds around...
 278
 279 \begin{code}
 280 nukeVolatileBinds :: CgBindings -> CgBindings
 281 nukeVolatileBinds binds
 282   = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
 283   where
 284     keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
 285     keep_if_stable info acc
 286       = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection[lookup-interface]{Interface functions to looking up bindings}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 \begin{code}
 297 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
 298 getCAddrModeIfVolatile id
 299   = do  { info <- getCgIdInfo id
 300         ; case cg_stb info of
 301                 NoStableLoc -> do -- Aha!  So it is volatile!
 302                         amode <- idInfoToAmode info
 303                         return $ Just amode
 304                 a_stable_loc -> return Nothing }
 305 \end{code}
 306
 307 @getVolatileRegs@ gets a set of live variables, and returns a list of
 308 all registers on which these variables depend.  These are the regs
 309 which must be saved and restored across any C calls.  If a variable is
 310 both in a volatile location (depending on a register) {\em and} a
 311 stable one (notably, on the stack), we modify the current bindings to
 312 forget the volatile one.
 313
 314 \begin{code}
 315 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
 316
 317 getVolatileRegs vars = do
 318   do    { stuff <- mapFCs snaffle_it (varSetElems vars)
 319         ; returnFC $ catMaybes stuff }
 320   where
 321     snaffle_it var = do
 322         { info <- getCgIdInfo var
 323         ; let
 324                 -- commoned-up code...
 325              consider_reg reg
 326                 =       -- We assume that all regs can die across C calls
 327                         -- We leave it to the save-macros to decide which
 328                         -- regs *really* need to be saved.
 329                   case cg_stb info 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
 337         ; case cg_vol info of
 338             RegLoc (CmmGlobal reg) -> consider_reg reg
 339             VirNodeLoc _           -> consider_reg node
 340             other_loc              -> returnFC Nothing  -- Local registers
 341         }
 342
 343     nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
 344 \end{code}
 345
 346 \begin{code}
 347 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
 348 getArgAmode (StgVarArg var)
 349   = do  { info <- getCgIdInfo var
 350         ; amode <- idInfoToAmode info
 351         ; return (cgIdInfoArgRep info, amode ) }
 352
 353 getArgAmode (StgLitArg lit)
 354   = do  { cmm_lit <- cgLit lit
 355         ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
 356
 357 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
 358
 359 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
 360 getArgAmodes [] = returnFC []
 361 getArgAmodes (atom:atoms)
 362   | isStgTypeArg atom = getArgAmodes atoms
 363   | otherwise         = do { amode  <- getArgAmode  atom
 364                            ; amodes <- getArgAmodes atoms
 365                            ; return ( amode : amodes ) }
 366 \end{code}
 367
 368 %************************************************************************
 369 %*                                                                      *
 370 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 \begin{code}
 375 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
 376 bindArgsToStack args
 377   = mapCs bind args
 378   where
 379     bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
 380
 381 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
 382 bindArgsToRegs args
 383   = mapCs bind args
 384   where
 385     bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
 386
 387 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
 388 bindNewToNode id offset lf_info
 389   = addBindC id (nodeIdInfo id offset lf_info)
 390
 391 -- Create a new temporary whose unique is that in the id,
 392 -- bind the id to it, and return the addressing mode for the
 393 -- temporary.
 394 bindNewToTemp :: Id -> FCode LocalReg
 395 bindNewToTemp id
 396   = do  addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
 397         return temp_reg
 398   where
 399     uniq     = getUnique id
 400     temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
 401     kind     = if isFollowableArg (idCgRep id)
 402                then KindPtr
 403                else KindNonPtr
 404     lf_info  = mkLFArgument id  -- Always used of things we
 405                                 -- know nothing about
 406
 407 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
 408 bindNewToReg name reg lf_info
 409   = addBindC name info
 410   where
 411     info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
 412 \end{code}
 413
 414 \begin{code}
 415 rebindToStack :: Id -> VirtualSpOffset -> Code
 416 rebindToStack name offset
 417   = modifyBindC name replace_stable_fn
 418   where
 419     replace_stable_fn info = info { cg_stb = VirStkLoc offset }
 420 \end{code}
 421
 422 %************************************************************************
 423 %*                                                                      *
 424 \subsection[CgMonad-deadslots]{Finding dead stack slots}
 425 %*                                                                      *
 426 %************************************************************************
 427
 428 nukeDeadBindings does the following:
 429
 430       - Removes all bindings from the environment other than those
 431         for variables in the argument to nukeDeadBindings.
 432       - Collects any stack slots so freed, and returns them to the  stack free
 433         list.
 434       - Moves the virtual stack pointer to point to the topmost used
 435         stack locations.
 436
 437 You can have multi-word slots on the stack (where a Double# used to
 438 be, for instance); if dead, such a slot will be reported as *several*
 439 offsets (one per word).
 440
 441 Probably *naughty* to look inside monad...
 442
 443 \begin{code}
 444 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
 445                  -> Code
 446 nukeDeadBindings live_vars = do
 447         binds <- getBinds
 448         let (dead_stk_slots, bs') =
 449                 dead_slots live_vars
 450                         [] []
 451                         [ (cg_id b, b) | b <- varEnvElts binds ]
 452         setBinds $ mkVarEnv bs'
 453         freeStackSlots dead_stk_slots
 454 \end{code}
 455
 456 Several boring auxiliary functions to do the dirty work.
 457
 458 \begin{code}
 459 dead_slots :: StgLiveVars
 460            -> [(Id,CgIdInfo)]
 461            -> [VirtualSpOffset]
 462            -> [(Id,CgIdInfo)]
 463            -> ([VirtualSpOffset], [(Id,CgIdInfo)])
 464
 465 -- dead_slots carries accumulating parameters for
 466 --      filtered bindings, dead slots
 467 dead_slots live_vars fbs ds []
 468   = (ds, reverse fbs) -- Finished; rm the dups, if any
 469
 470 dead_slots live_vars fbs ds ((v,i):bs)
 471   | v `elementOfUniqSet` live_vars
 472     = dead_slots live_vars ((v,i):fbs) ds bs
 473           -- Live, so don't record it in dead slots
 474           -- Instead keep it in the filtered bindings
 475
 476   | otherwise
 477     = case cg_stb i of
 478         VirStkLoc offset
 479          | size > 0
 480          -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
 481
 482         _ -> dead_slots live_vars fbs ds bs
 483   where
 484     size :: WordOff
 485     size = cgRepSizeW (cg_rep i)
 486 \end{code}
 487
 488 \begin{code}
 489 getLiveStackSlots :: FCode [VirtualSpOffset]
 490 -- Return the offsets of slots in stack containig live pointers
 491 getLiveStackSlots
 492   = do  { binds <- getBinds
 493         ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
 494                                    cg_rep = rep } <- varEnvElts binds,
 495                         isFollowableArg rep] }
 496 \end{code}