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