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         CgBindings(..), CgIdInfo(..){-dubiously concrete-},
  11         StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-},
  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         getAtomAmode, getAtomAmodes,
  24         getCAddrModeAndInfo, getCAddrMode,
  25         getCAddrModeIfVolatile, getVolatileRegs,
  26         rebindToAStack, rebindToBStack
  27
  28         -- and to make a self-sufficient interface...
  29     ) where
  30
  31 import AbsCSyn
  32 import CgMonad
  33
  34 import CgUsages         ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
  35 import CLabel   ( mkClosureLabel, CLabel )
  36 import ClosureInfo
  37 import Id               ( getIdPrimRep, toplevelishId, isDataCon, Id )
  38 import Maybes           ( catMaybes, Maybe(..) )
  39 import UniqSet          -- ( setToList )
  40 import StgSyn
  41 import Util
  42 \end{code}
  43
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection[Bindery-datatypes]{Data types}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 @(CgBinding a b)@ is a type of finite maps from a to b.
  52
  53 The assumption used to be that @lookupCgBind@ must get exactly one
  54 match.  This is {\em completely wrong} in the case of compiling
  55 letrecs (where knot-tying is used).  An initial binding is fed in (and
  56 never evaluated); eventually, a correct binding is put into the
  57 environment.  So there can be two bindings for a given name.
  58
  59 \begin{code}
  60 type CgBindings = IdEnv CgIdInfo
  61
  62 data CgIdInfo
  63   = MkCgIdInfo  Id      -- Id that this is the info for
  64                 VolatileLoc
  65                 StableLoc
  66                 LambdaFormInfo
  67
  68 data VolatileLoc
  69   = NoVolatileLoc
  70   | TempVarLoc  Unique
  71
  72   | RegLoc      MagicId                 -- in one of the magic registers
  73                                         -- (probably {Int,Float,Char,etc}Reg
  74
  75   | VirHpLoc    VirtualHeapOffset       -- Hp+offset (address of closure)
  76
  77   | VirNodeLoc  VirtualHeapOffset       -- Cts of offset indirect from Node
  78                                         -- ie *(Node+offset)
  79
  80 data StableLoc
  81   = NoStableLoc
  82   | VirAStkLoc          VirtualSpAOffset
  83   | VirBStkLoc          VirtualSpBOffset
  84   | LitLoc              Literal
  85   | StableAmodeLoc      CAddrMode
  86
  87 -- these are so StableLoc can be abstract:
  88
  89 maybeAStkLoc (VirAStkLoc offset) = Just offset
  90 maybeAStkLoc _                   = Nothing
  91
  92 maybeBStkLoc (VirBStkLoc offset) = Just offset
  93 maybeBStkLoc _                   = Nothing
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection[Bindery-idInfo]{Manipulating IdInfo}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
 104 heapIdInfo i offset       lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
 105 tempIdInfo i uniq         lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
 106
 107 letNoEscapeIdInfo i spa spb lf_info
 108   = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info
 109
 110 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
 111
 112 newTempAmodeAndIdInfo name lf_info
 113   = (temp_amode, temp_idinfo)
 114   where
 115     uniq        = getItsUnique name
 116     temp_amode  = CTemp uniq (getIdPrimRep name)
 117     temp_idinfo = tempIdInfo name uniq lf_info
 118
 119 idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode
 120 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
 121
 122 idInfoPiecesToAmode :: PrimKind -> VolatileLoc -> StableLoc -> FCode CAddrMode
 123
 124 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc   = returnFC (CTemp uniq kind)
 125 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc   = returnFC (CReg magic_id)
 126
 127 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit)           = returnFC (CLit lit)
 128 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
 129
 130 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
 131   = returnFC (CVal (NodeRel nd_off) kind)
 132     -- Virtual offsets from Node increase into the closures,
 133     -- and so do Node-relative offsets (which we want in the CVal),
 134     -- so there is no mucking about to do to the offset.
 135
 136 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
 137   = getHpRelOffset hp_off `thenFC` \ rel_hp ->
 138     returnFC (CAddr rel_hp)
 139
 140 idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
 141   = getSpARelOffset i `thenFC` \ rel_spA ->
 142     returnFC (CVal rel_spA kind)
 143
 144 idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
 145   = getSpBRelOffset i `thenFC` \ rel_spB ->
 146     returnFC (CVal rel_spB kind)
 147
 148 #ifdef DEBUG
 149 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
 150 #endif
 151 \end{code}
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 We sometimes want to nuke all the volatile bindings; we must be sure
 160 we don't leave any (NoVolatile, NoStable) binds around...
 161
 162 \begin{code}
 163 nukeVolatileBinds :: CgBindings -> CgBindings
 164 nukeVolatileBinds binds
 165   = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
 166   where
 167     keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
 168     keep_if_stable (MkCgIdInfo i _ stable_loc  entry_info) acc
 169       = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection[lookup-interface]{Interface functions to looking up bindings}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 I {\em think} all looking-up is done through @getCAddrMode(s)@.
 180
 181 \begin{code}
 182 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
 183
 184 getCAddrModeAndInfo name
 185   | not (isLocallyDefined name)
 186   = returnFC (global_amode, mkLFImported name)
 187
 188   | isDataCon name
 189   = returnFC (global_amode, mkConLFInfo name)
 190
 191   | otherwise = -- *might* be a nested defn: in any case, it's something whose
 192                 -- definition we will know about...
 193     lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
 194     idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
 195     returnFC (amode, lf_info)
 196   where
 197     global_amode = CLbl (mkClosureLabel name) kind
 198     kind = getIdPrimRep name
 199
 200 getCAddrMode :: Id -> FCode CAddrMode
 201 getCAddrMode name
 202   = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
 203     returnFC amode
 204 \end{code}
 205
 206 \begin{code}
 207 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
 208 getCAddrModeIfVolatile name
 209   | toplevelishId name = returnFC Nothing
 210   | otherwise
 211   = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
 212     case stable_loc of
 213         NoStableLoc ->  -- Aha!  So it is volatile!
 214             idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
 215             returnFC (Just amode)
 216
 217         a_stable_loc -> returnFC Nothing
 218 \end{code}
 219
 220 @getVolatileRegs@ gets a set of live variables, and returns a list of
 221 all registers on which these variables depend.  These are the regs
 222 which must be saved and restored across any C calls.  If a variable is
 223 both in a volatile location (depending on a register) {\em and} a
 224 stable one (notably, on the stack), we modify the current bindings to
 225 forget the volatile one.
 226
 227 \begin{code}
 228 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
 229
 230 getVolatileRegs vars
 231   = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff ->
 232     returnFC (catMaybes stuff)
 233   where
 234     snaffle_it var
 235       = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
 236         let
 237             -- commoned-up code...
 238             consider_reg reg
 239               = if not (isVolatileReg reg) then
 240                         -- Potentially dies across C calls
 241                         -- For now, that's everything; we leave
 242                         -- it to the save-macros to decide which
 243                         -- regs *really* need to be saved.
 244                     returnFC Nothing
 245                 else
 246                     case stable_loc of
 247                       NoStableLoc -> returnFC (Just reg) -- got one!
 248                       is_a_stable_loc ->
 249                         -- has both volatile & stable locations;
 250                         -- force it to rely on the stable location
 251                         modifyBindC var nuke_vol_bind `thenC`
 252                         returnFC Nothing
 253         in
 254         case volatile_loc of
 255           RegLoc reg   -> consider_reg reg
 256           VirHpLoc _   -> consider_reg Hp
 257           VirNodeLoc _ -> consider_reg node
 258           non_reg_loc  -> returnFC Nothing
 259
 260     nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
 261       = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
 262 \end{code}
 263
 264 \begin{code}
 265 getAtomAmodes :: [StgArg] -> FCode [CAddrMode]
 266 getAtomAmodes [] = returnFC []
 267 getAtomAmodes (atom:atoms)
 268   = getAtomAmode  atom  `thenFC` \ amode ->
 269     getAtomAmodes atoms `thenFC` \ amodes ->
 270     returnFC ( amode : amodes )
 271
 272 getAtomAmode :: StgArg -> FCode CAddrMode
 273
 274 getAtomAmode (StgVarArg var) = getCAddrMode var
 275 getAtomAmode (StgLitArg lit) = returnFC (CLit lit)
 276 \end{code}
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 \begin{code}
 285 bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
 286 bindNewToAStack (name, offset)
 287   = addBindC name info
 288   where
 289     info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
 290
 291 bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
 292 bindNewToBStack (name, offset)
 293   = addBindC name info
 294   where
 295     info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
 296            -- B-stack things shouldn't need lambda-form info!
 297
 298 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
 299 bindNewToNode name offset lf_info
 300   = addBindC name info
 301   where
 302     info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
 303
 304 -- Create a new temporary whose unique is that in the id,
 305 -- bind the id to it, and return the addressing mode for the
 306 -- temporary.
 307 bindNewToTemp :: Id -> FCode CAddrMode
 308 bindNewToTemp name
 309   = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
 310                 -- This is used only for things we don't know
 311                 -- anything about; values returned by a case statement,
 312                 -- for example.
 313     in
 314     addBindC name id_info       `thenC`
 315     returnFC temp_amode
 316
 317 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
 318 bindNewToReg name magic_id lf_info
 319   = addBindC name info
 320   where
 321     info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
 322
 323 bindNewToLit name lit
 324   = addBindC name info
 325   where
 326     info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
 327
 328 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 329 bindArgsToRegs args regs
 330   = listCs (zipWithEqual bind args regs)
 331   where
 332     arg `bind` reg = bindNewToReg arg reg mkLFArgument
 333 \end{code}
 334
 335 @bindNewPrimToAmode@ works only for certain addressing modes, because
 336 those are the only ones we've needed so far!
 337
 338 \begin{code}
 339 bindNewPrimToAmode :: Id -> CAddrMode -> Code
 340 bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
 341                                                 -- was: mkLFArgument
 342                                                 -- LFinfo is irrelevant for primitives
 343 bindNewPrimToAmode name (CTemp uniq kind)
 344   = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
 345         -- LFinfo is irrelevant for primitives
 346
 347 bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
 348
 349 bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
 350   = bindNewToBStack (name, offset)
 351
 352 bindNewPrimToAmode name (CVal (NodeRel offset) _)
 353   = bindNewToNode name offset (panic "bindNewPrimToAmode node")
 354   -- See comment on idInfoPiecesToAmode for VirNodeLoc
 355
 356 #ifdef DEBUG
 357 bindNewPrimToAmode name amode
 358   = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug  amode)))
 359 #endif
 360 \end{code}
 361
 362 \begin{code}
 363 rebindToAStack :: Id -> VirtualSpAOffset -> Code
 364 rebindToAStack name offset
 365   = modifyBindC name replace_stable_fn
 366   where
 367     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 368       = MkCgIdInfo i vol (VirAStkLoc offset) einfo
 369
 370 rebindToBStack :: Id -> VirtualSpBOffset -> Code
 371 rebindToBStack name offset
 372   = modifyBindC name replace_stable_fn
 373   where
 374     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 375       = MkCgIdInfo i vol (VirBStkLoc offset) einfo
 376 \end{code}
 377