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