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