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