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