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 IMPORT_DELOOPER(CgLoop1)                -- here for paranoia-checking
  31
  32 import AbsCSyn
  33 import CgMonad
  34
  35 import CgUsages         ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
  36 import CLabel           ( mkStaticClosureLabel, mkClosureLabel )
  37 import ClosureInfo      ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
  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, isWiredInName, 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) || isWiredInName name
 199     {- Why the "isWiredInName"?
 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 (StgConArg var)
 295      {- Why does this case differ from StgVarArg?
 296         Because the program might look like this:
 297                 data Foo a = Empty | Baz a
 298                 f a x = let c = Empty! a
 299                         in h c
 300         Now, when we go Core->Stg, we drop the type applications,
 301         so we can inline c, giving
 302                 f x = h Empty
 303         Now we are referring to Empty as an argument (rather than in an STGCon),
 304         so we'll look it up with getCAddrMode.  We want to return an amode for
 305         the static closure that we make for nullary constructors.  But if we blindly
 306         go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
 307
 308         This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
 309         Consider:
 310                 f a x = Baz a x
 311         If the constructor Baz isn't inlined we simply want to treat it like any other
 312         identifier, with a top level definition.  We don't want to spot that it's a constructor.
 313
 314         In short
 315                 StgApp con args
 316         and
 317                 StgCon con args
 318         are treated differently; the former is a call to a bog standard function while the
 319         latter uses the specially-labelled, pre-defined info tables etc for the constructor.
 320
 321         The way to think of this case in getArgAmode is that
 322                 SApp f Empty
 323         is really
 324                 App f (StgCon Empty [])
 325      -}
 326   = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var))
 327
 328 getArgAmode (StgVarArg var) = getCAddrMode var          -- The common case
 329
 330 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 \begin{code}
 340 bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
 341 bindNewToAStack (name, offset)
 342   = addBindC name info
 343   where
 344     info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
 345
 346 bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
 347 bindNewToBStack (name, offset)
 348   = addBindC name info
 349   where
 350     info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
 351            -- B-stack things shouldn't need lambda-form info!
 352
 353 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
 354 bindNewToNode name offset lf_info
 355   = addBindC name info
 356   where
 357     info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
 358
 359 -- Create a new temporary whose unique is that in the id,
 360 -- bind the id to it, and return the addressing mode for the
 361 -- temporary.
 362 bindNewToTemp :: Id -> FCode CAddrMode
 363 bindNewToTemp name
 364   = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
 365                 -- This is used only for things we don't know
 366                 -- anything about; values returned by a case statement,
 367                 -- for example.
 368     in
 369     addBindC name id_info       `thenC`
 370     returnFC temp_amode
 371
 372 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
 373 bindNewToReg name magic_id lf_info
 374   = addBindC name info
 375   where
 376     info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
 377
 378 bindNewToLit name lit
 379   = addBindC name info
 380   where
 381     info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
 382
 383 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 384 bindArgsToRegs args regs
 385   = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
 386   where
 387     arg `bind` reg = bindNewToReg arg reg mkLFArgument
 388 \end{code}
 389
 390 @bindNewPrimToAmode@ works only for certain addressing modes, because
 391 those are the only ones we've needed so far!
 392
 393 \begin{code}
 394 bindNewPrimToAmode :: Id -> CAddrMode -> Code
 395 bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
 396                                                 -- was: mkLFArgument
 397                                                 -- LFinfo is irrelevant for primitives
 398 bindNewPrimToAmode name (CTemp uniq kind)
 399   = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
 400         -- LFinfo is irrelevant for primitives
 401
 402 bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
 403
 404 bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
 405   = bindNewToBStack (name, offset)
 406
 407 bindNewPrimToAmode name (CVal (NodeRel offset) _)
 408   = bindNewToNode name offset (panic "bindNewPrimToAmode node")
 409   -- See comment on idInfoPiecesToAmode for VirNodeLoc
 410
 411 #ifdef DEBUG
 412 bindNewPrimToAmode name amode
 413   = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug  amode)))
 414 #endif
 415 \end{code}
 416
 417 \begin{code}
 418 rebindToAStack :: Id -> VirtualSpAOffset -> Code
 419 rebindToAStack name offset
 420   = modifyBindC name replace_stable_fn
 421   where
 422     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 423       = MkCgIdInfo i vol (VirAStkLoc offset) einfo
 424
 425 rebindToBStack :: Id -> VirtualSpBOffset -> Code
 426 rebindToBStack name offset
 427   = modifyBindC name replace_stable_fn
 428   where
 429     replace_stable_fn (MkCgIdInfo i vol stab einfo)
 430       = MkCgIdInfo i vol (VirBStkLoc offset) einfo
 431 \end{code}
 432