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