ghc/compiler/codeGen/CgBindery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CgBindery]{Utility functions related to doing @CgBindings@}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CgBindery (
  10         SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
  11         StableLoc, VolatileLoc,
  12
  13         maybeAStkLoc, maybeBStkLoc,
  14
  15         stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
  16         letNoEscapeIdInfo, idInfoToAmode,
  17
  18         nukeVolatileBinds,
  19
  20         bindNewToAStack, bindNewToBStack,
  21         bindNewToNode, bindNewToReg, bindArgsToRegs,
  22         bindNewToTemp, bindNewPrimToAmode,
  23         getArgAmode, getArgAmodes,
  24         getCAddrModeAndInfo, getCAddrMode,
  25         getCAddrModeIfVolatile, getVolatileRegs,
  26         rebindToAStack, rebindToBStack
  27     ) where
  28
  29 IMP_Ubiq(){-uitous-}
  30
  31 import AbsCSyn
  32 import CgMonad
  33
  34 import CgUsages         ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
  35 import CLabel           ( mkStaticClosureLabel, mkClosureLabel )
  36 import ClosureInfo      ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
  37 import HeapOffs         ( SYN_IE(VirtualHeapOffset),
  38                           SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
  39                         )
  40 import Id               ( idPrimRep, toplevelishId,
  41                           mkIdEnv, rngIdEnv, SYN_IE(IdEnv),
  42                           idSetToList,
  43                           GenId{-instance NamedThing-}, SYN_IE(Id)
  44                         )
  45 import Literal          ( Literal )
  46 import Maybes           ( catMaybes )
  47 import Name             ( isLocallyDefined, isWiredInName,
  48                           Name{-instance NamedThing-}, NamedThing(..) )
  49 #ifdef DEBUG
  50 import PprAbsC          ( pprAmode )
  51 #endif
  52 import Outputable       ( PprStyle(..) )
  53 import Pretty           ( Doc )
  54 import PrimRep          ( PrimRep )
  55 import StgSyn           ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) )
  56 import Unique           ( Unique )
  57 import UniqFM           ( Uniquable(..) )
  58 import Util             ( zipWithEqual, panic )
  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   = MkCgIdInfo  Id      -- Id that this is the info for
  81                 VolatileLoc
  82                 StableLoc
  83                 LambdaFormInfo
  84
  85 data VolatileLoc
  86   = NoVolatileLoc
  87   | TempVarLoc  Unique
  88
  89   | RegLoc      MagicId                 -- in one of the magic registers
  90                                         -- (probably {Int,Float,Char,etc}Reg
  91
  92   | VirHpLoc    VirtualHeapOffset       -- Hp+offset (address of closure)
  93
  94   | VirNodeLoc  VirtualHeapOffset       -- Cts of offset indirect from Node
  95                                         -- ie *(Node+offset)
  96
  97 data StableLoc
  98   = NoStableLoc
  99   | VirAStkLoc          VirtualSpAOffset
 100   | VirBStkLoc          VirtualSpBOffset
 101   | LitLoc              Literal
 102   | StableAmodeLoc      CAddrMode
 103
 104 -- these are so StableLoc can be abstract:
 105
 106 maybeAStkLoc (VirAStkLoc offset) = Just offset
 107 maybeAStkLoc _                   = Nothing
 108
 109 maybeBStkLoc (VirBStkLoc offset) = Just offset
 110 maybeBStkLoc _                   = Nothing
 111 \end{code}
 112
 113 %************************************************************************
 114 %*                                                                      *
 115 \subsection[Bindery-idInfo]{Manipulating IdInfo}
 116 %*                                                                      *
 117 %************************************************************************
 118
 119 \begin{code}
 120 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
 121 heapIdInfo i offset       lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
 122 tempIdInfo i uniq         lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
 123
 124 letNoEscapeIdInfo i spa spb lf_info
 125   = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info
 126
 127 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
 128
 129 newTempAmodeAndIdInfo name lf_info
 130   = (temp_amode, temp_idinfo)
 131   where
 132     uniq        = uniqueOf name
 133     temp_amode  = CTemp uniq (idPrimRep name)
 134     temp_idinfo = tempIdInfo name uniq lf_info
 135
 136 idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
 137 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
 138
 139 idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
 140
 141 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc   = returnFC (CTemp uniq kind)
 142 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc   = returnFC (CReg magic_id)
 143
 144 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit)           = returnFC (CLit lit)
 145 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
 146
 147 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
 148   = returnFC (CVal (NodeRel nd_off) kind)
 149     -- Virtual offsets from Node increase into the closures,
 150     -- and so do Node-relative offsets (which we want in the CVal),
 151     -- so there is no mucking about to do to the offset.
 152
 153 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
 154   = getHpRelOffset hp_off `thenFC` \ rel_hp ->
 155     returnFC (CAddr rel_hp)
 156
 157 idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
 158   = getSpARelOffset i `thenFC` \ rel_spA ->
 159     returnFC (CVal rel_spA kind)
 160
 161 idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
 162   = getSpBRelOffset i `thenFC` \ rel_spB ->
 163     returnFC (CVal rel_spB kind)
 164
 165 #ifdef DEBUG
 166 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
 167 #endif
 168 \end{code}
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 We sometimes want to nuke all the volatile bindings; we must be sure
 177 we don't leave any (NoVolatile, NoStable) binds around...
 178
 179 \begin{code}
 180 nukeVolatileBinds :: CgBindings -> CgBindings
 181 nukeVolatileBinds binds
 182   = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
 183   where
 184     keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
 185     keep_if_stable (MkCgIdInfo i _ stable_loc  entry_info) acc
 186       = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
 187 \end{code}
 188
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection[lookup-interface]{Interface functions to looking up bindings}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 I {\em think} all looking-up is done through @getCAddrMode(s)@.
 197
 198 \begin{code}
 199 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
 200
 201 getCAddrModeAndInfo id
 202   | not (isLocallyDefined name) || isWiredInName name
 203     {- Why the "isWiredInName"?
 204         Imagine you are compiling PrelBase.hs (a module that
 205         supplies some of the wired-in values).  What can
 206         happen is that the compiler will inject calls to
 207         (e.g.) GHCbase.unpackPS, where-ever it likes -- it
 208         assumes those values are ubiquitously available.
 209         The main point is: it may inject calls to them earlier
 210         in GHCbase.hs than the actual definition...
 211     -}
 212   = returnFC (global_amode, mkLFImported id)
 213
 214   | otherwise = -- *might* be a nested defn: in any case, it's something whose
 215                 -- definition we will know about...
 216     lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
 217     idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
 218     returnFC (amode, lf_info)
 219   where
 220     name = getName id
 221     global_amode = CLbl (mkClosureLabel id) kind
 222     kind = idPrimRep id
 223
 224 getCAddrMode :: Id -> FCode CAddrMode
 225 getCAddrMode name
 226   = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
 227     returnFC amode
 228 \end{code}
 229
 230 \begin{code}
 231 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
 232 getCAddrModeIfVolatile name
 233   | toplevelishId name = returnFC Nothing
 234   | otherwise
 235   = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
 236     case stable_loc of
 237         NoStableLoc ->  -- Aha!  So it is volatile!
 238             idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
 239             returnFC (Just amode)
 240
 241         a_stable_loc -> returnFC Nothing
 242 \end{code}
 243
 244 @getVolatileRegs@ gets a set of live variables, and returns a list of
 245 all registers on which these variables depend.  These are the regs
 246 which must be saved and restored across any C calls.  If a variable is
 247 both in a volatile location (depending on a register) {\em and} a
 248 stable one (notably, on the stack), we modify the current bindings to
 249 forget the volatile one.
 250
 251 \begin{code}
 252 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
 253
 254 getVolatileRegs vars
 255   = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
 256     returnFC (catMaybes stuff)
 257   where
 258     snaffle_it var
 259       = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
 260         let
 261             -- commoned-up code...
 262             consider_reg reg
 263               = if not (isVolatileReg reg) then
 264                         -- Potentially dies across C calls
 265                         -- For now, that's everything; we leave
 266                         -- it to the save-macros to decide which
 267                         -- regs *really* need to be saved.
 268                     returnFC Nothing
 269                 else
 270                     case stable_loc of
 271                       NoStableLoc -> returnFC (Just reg) -- got one!
 272                       is_a_stable_loc ->
 273                         -- has both volatile & stable locations;
 274                         -- force it to rely on the stable location
 275                         modifyBindC var nuke_vol_bind `thenC`
 276                         returnFC Nothing
 277         in
 278         case volatile_loc of
 279           RegLoc reg   -> consider_reg reg
 280           VirHpLoc _   -> consider_reg Hp
 281           VirNodeLoc _ -> consider_reg node
 282           non_reg_loc  -> returnFC Nothing
 283
 284     nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
 285       = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
 286 \end{code}
 287
 288 \begin{code}
 289 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
 290 getArgAmodes [] = returnFC []
 291 getArgAmodes (atom:atoms)
 292   = getArgAmode  atom  `thenFC` \ amode ->
 293     getArgAmodes atoms `thenFC` \ amodes ->
 294     returnFC ( amode : amodes )
 295
 296 getArgAmode :: StgArg -> FCode CAddrMode
 297
 298 getArgAmode (StgConArg var)
 299      {- Why does this case differ from StgVarArg?
 300         Because the program might look like this:
 301                 data Foo a = Empty | Baz a
 302                 f a x = let c = Empty! a
 303                         in h c
 304         Now, when we go Core->Stg, we drop the type applications,
 305         so we can inline c, giving
 306                 f x = h Empty
 307         Now we are referring to Empty as an argument (rather than in an STGCon),
 308         so we'll look it up with getCAddrMode.  We want to return an amode for
 309         the static closure that we make for nullary constructors.  But if we blindly
 310         go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
 311
 312         This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
 313         Consider:
 314                 f a x = Baz a x
 315         If the constructor Baz isn't inlined we simply want to treat it like any other
 316         identifier, with a top level definition.  We don't want to spot that it's a constructor.
 317
 318         In short
 319                 StgApp con args
 320         and
 321                 StgCon con args
 322         are treated differently; the former is a call to a bog standard function while the
 323         latter uses the specially-labelled, pre-defined info tables etc for the constructor.
 324
 325         The way to think of this case in getArgAmode is that
 326                 SApp f Empty
 327         is really
 328                 App f (StgCon Empty [])
 329      -}
 330   = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var))
 331
 332 getArgAmode (StgVarArg var) = getCAddrMode var          -- The common case
 333
 334 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
 335 \end{code}
 336
 337 %************************************************************************
 338 %*                                                                      *
 339 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
 340 %*                                                                      *
 341 %************************************************************************
 342
 343 \begin{code}
 344 bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
 345 bindNewToAStack (name, offset)
 346   = addBindC name info
 347   where
 348     info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
 349
 350 bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
 351 bindNewToBStack (name, offset)
 352   = addBindC name info
 353   where
 354     info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
 355            -- B-stack things shouldn't need lambda-form info!
 356
 357 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
 358 bindNewToNode name offset lf_info
 359   = addBindC name info
 360   where
 361     info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
 362
 363 -- Create a new temporary whose unique is that in the id,
 364 -- bind the id to it, and return the addressing mode for the
 365 -- temporary.
 366 bindNewToTemp :: Id -> FCode CAddrMode
 367 bindNewToTemp name
 368   = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
 369                 -- This is used only for things we don't know
 370                 -- anything about; values returned by a case statement,
 371                 -- for example.
 372     in
 373     addBindC name id_info       `thenC`
 374     returnFC temp_amode
 375
 376 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
 377 bindNewToReg name magic_id lf_info
 378   = addBindC name info
 379   where
 380     info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
 381
 382 bindNewToLit name lit
 383   = addBindC name info
 384   where
 385     info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
 386
 387 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 388 bindArgsToRegs args regs
 389   = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
 390   where
 391     arg `bind` reg = bindNewToReg arg reg mkLFArgument
 392 \end{code}
 393
 394 @bindNewPrimToAmode@ works only for certain addressing modes, because
 395 those are the only ones we've needed so far!
 396
 397 \begin{code}
 398 bindNewPrimToAmode :: Id -> CAddrMode -> Code
 399 bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
 400                                                 -- was: mkLFArgument
 401                                                 -- LFinfo is irrelevant for primitives
 402 bindNewPrimToAmode name (CTemp uniq kind)
 403   = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
 404         -- LFinfo is irrelevant for primitives
 405
 406 bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
 407
 408 bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
 409   = bindNewToBStack (name, offset)
 410
 411 bindNewPrimToAmode name (CVal (NodeRel offset) _)
 412   = bindNewToNode name offset (panic "bindNewPrimToAmode node")
 413   -- See comment on idInfoPiecesToAmode for VirNodeLoc
 414
 415 #ifdef DEBUG
 416 bindNewPrimToAmode name amode
 417   = panic ("bindNew...:"++(show (pprAmode PprDebug  amode)))
 418 #endif
 419 \end{code}
 420
 421 \begin{code}
 422 rebindToAStack :: Id -> VirtualSpAOffset -> Code
 423 rebindToAStack name offset
 424   = modifyBindC name replace_stable_fn
 425   where
 426     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 427       = MkCgIdInfo i vol (VirAStkLoc offset) einfo
 428
 429 rebindToBStack :: Id -> VirtualSpBOffset -> Code
 430 rebindToBStack name offset
 431   = modifyBindC name replace_stable_fn
 432   where
 433     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 434       = MkCgIdInfo i vol (VirBStkLoc offset) einfo
 435 \end{code}
 436