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