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