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             this_pkg <- getThisPackage
 284             let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name))
 285             return (stableIdInfo id ext_lbl (mkLFImported id))
 286         else
 287         if isVoidArg (idCgRep id) then
 288                 -- Void things are never in the environment
 289             return (voidIdInfo id)
 290         else
 291         -- Bug
 292         cgLookupPanic id
 293         }}}}
 294
 295
 296 cgLookupPanic :: Id -> FCode a
 297 cgLookupPanic id
 298   = do  static_binds <- getStaticBinds
 299         local_binds <- getBinds
 300         srt <- getSRTLabel
 301         pprPanic "cgPanic"
 302                 (vcat [ppr id,
 303                 ptext SLIT("static binds for:"),
 304                 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
 305                 ptext SLIT("local binds for:"),
 306                 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
 307                 ptext SLIT("SRT label") <+> pprCLabel srt
 308               ])
 309 \end{code}
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 We sometimes want to nuke all the volatile bindings; we must be sure
 318 we don't leave any (NoVolatile, NoStable) binds around...
 319
 320 \begin{code}
 321 nukeVolatileBinds :: CgBindings -> CgBindings
 322 nukeVolatileBinds binds
 323   = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
 324   where
 325     keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
 326     keep_if_stable info acc
 327       = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
 328 \end{code}
 329
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsection[lookup-interface]{Interface functions to looking up bindings}
 334 %*                                                                      *
 335 %************************************************************************
 336
 337 \begin{code}
 338 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
 339 getCAddrModeIfVolatile id
 340   = do  { info <- getCgIdInfo id
 341         ; case cg_stb info of
 342                 NoStableLoc -> do -- Aha!  So it is volatile!
 343                         amode <- idInfoToAmode info
 344                         return $ Just amode
 345                 a_stable_loc -> return Nothing }
 346 \end{code}
 347
 348 @getVolatileRegs@ gets a set of live variables, and returns a list of
 349 all registers on which these variables depend.  These are the regs
 350 which must be saved and restored across any C calls.  If a variable is
 351 both in a volatile location (depending on a register) {\em and} a
 352 stable one (notably, on the stack), we modify the current bindings to
 353 forget the volatile one.
 354
 355 \begin{code}
 356 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
 357
 358 getVolatileRegs vars = do
 359   do    { stuff <- mapFCs snaffle_it (varSetElems vars)
 360         ; returnFC $ catMaybes stuff }
 361   where
 362     snaffle_it var = do
 363         { info <- getCgIdInfo var
 364         ; let
 365                 -- commoned-up code...
 366              consider_reg reg
 367                 =       -- We assume that all regs can die across C calls
 368                         -- We leave it to the save-macros to decide which
 369                         -- regs *really* need to be saved.
 370                   case cg_stb info of
 371                         NoStableLoc     -> returnFC (Just reg) -- got one!
 372                         is_a_stable_loc -> do
 373                                 { -- has both volatile & stable locations;
 374                                   -- force it to rely on the stable location
 375                                   modifyBindC var nuke_vol_bind
 376                                 ; return Nothing }
 377
 378         ; case cg_vol info of
 379             RegLoc (CmmGlobal reg) -> consider_reg reg
 380             VirNodeLoc _           -> consider_reg node
 381             other_loc              -> returnFC Nothing  -- Local registers
 382         }
 383
 384     nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
 385 \end{code}
 386
 387 \begin{code}
 388 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
 389 getArgAmode (StgVarArg var)
 390   = do  { info <- getCgIdInfo var
 391         ; amode <- idInfoToAmode info
 392         ; return (cgIdInfoArgRep info, amode ) }
 393
 394 getArgAmode (StgLitArg lit)
 395   = do  { cmm_lit <- cgLit lit
 396         ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
 397
 398 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
 399
 400 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
 401 getArgAmodes [] = returnFC []
 402 getArgAmodes (atom:atoms)
 403   | isStgTypeArg atom = getArgAmodes atoms
 404   | otherwise         = do { amode  <- getArgAmode  atom
 405                            ; amodes <- getArgAmodes atoms
 406                            ; return ( amode : amodes ) }
 407 \end{code}
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 \begin{code}
 416 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
 417 bindArgsToStack args
 418   = mapCs bind args
 419   where
 420     bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
 421
 422 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
 423 bindArgsToRegs args
 424   = mapCs bind args
 425   where
 426     bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
 427
 428 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
 429 bindNewToNode id offset lf_info
 430   = addBindC id (nodeIdInfo id offset lf_info)
 431
 432 bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
 433 bindNewToUntagNode id offset lf_info tag
 434   = addBindC id (untagNodeIdInfo id offset lf_info tag)
 435
 436 -- Create a new temporary whose unique is that in the id,
 437 -- bind the id to it, and return the addressing mode for the
 438 -- temporary.
 439 bindNewToTemp :: Id -> FCode LocalReg
 440 bindNewToTemp id
 441   = do  addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
 442         return temp_reg
 443   where
 444     uniq     = getUnique id
 445     temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
 446     kind     = if isFollowableArg (idCgRep id)
 447                then KindPtr
 448                else KindNonPtr
 449     lf_info  = mkLFArgument id  -- Always used of things we
 450                                 -- know nothing about
 451
 452 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
 453 bindNewToReg name reg lf_info
 454   = addBindC name info
 455   where
 456     info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
 457 \end{code}
 458
 459 \begin{code}
 460 rebindToStack :: Id -> VirtualSpOffset -> Code
 461 rebindToStack name offset
 462   = modifyBindC name replace_stable_fn
 463   where
 464     replace_stable_fn info = info { cg_stb = VirStkLoc offset }
 465 \end{code}
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection[CgMonad-deadslots]{Finding dead stack slots}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 nukeDeadBindings does the following:
 474
 475       - Removes all bindings from the environment other than those
 476         for variables in the argument to nukeDeadBindings.
 477       - Collects any stack slots so freed, and returns them to the  stack free
 478         list.
 479       - Moves the virtual stack pointer to point to the topmost used
 480         stack locations.
 481
 482 You can have multi-word slots on the stack (where a Double# used to
 483 be, for instance); if dead, such a slot will be reported as *several*
 484 offsets (one per word).
 485
 486 Probably *naughty* to look inside monad...
 487
 488 \begin{code}
 489 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
 490                  -> Code
 491 nukeDeadBindings live_vars = do
 492         binds <- getBinds
 493         let (dead_stk_slots, bs') =
 494                 dead_slots live_vars
 495                         [] []
 496                         [ (cg_id b, b) | b <- varEnvElts binds ]
 497         setBinds $ mkVarEnv bs'
 498         freeStackSlots dead_stk_slots
 499 \end{code}
 500
 501 Several boring auxiliary functions to do the dirty work.
 502
 503 \begin{code}
 504 dead_slots :: StgLiveVars
 505            -> [(Id,CgIdInfo)]
 506            -> [VirtualSpOffset]
 507            -> [(Id,CgIdInfo)]
 508            -> ([VirtualSpOffset], [(Id,CgIdInfo)])
 509
 510 -- dead_slots carries accumulating parameters for
 511 --      filtered bindings, dead slots
 512 dead_slots live_vars fbs ds []
 513   = (ds, reverse fbs) -- Finished; rm the dups, if any
 514
 515 dead_slots live_vars fbs ds ((v,i):bs)
 516   | v `elementOfUniqSet` live_vars
 517     = dead_slots live_vars ((v,i):fbs) ds bs
 518           -- Live, so don't record it in dead slots
 519           -- Instead keep it in the filtered bindings
 520
 521   | otherwise
 522     = case cg_stb i of
 523         VirStkLoc offset
 524          | size > 0
 525          -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
 526
 527         _ -> dead_slots live_vars fbs ds bs
 528   where
 529     size :: WordOff
 530     size = cgRepSizeW (cg_rep i)
 531 \end{code}
 532
 533 \begin{code}
 534 getLiveStackSlots :: FCode [VirtualSpOffset]
 535 -- Return the offsets of slots in stack containig live pointers
 536 getLiveStackSlots
 537   = do  { binds <- getBinds
 538         ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
 539                                    cg_rep = rep } <- varEnvElts binds,
 540                         isFollowableArg rep] }
 541 \end{code}
 542
 543 \begin{code}
 544 getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
 545 getLiveStackBindings
 546   = do { binds <- getBinds
 547        ; return [(off, bind) |
 548                  bind <- varEnvElts binds,
 549                  CgIdInfo { cg_stb = VirStkLoc off,
 550                             cg_rep = rep} <- [bind],
 551                  isFollowableArg rep] }
 552 \end{code}