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