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