CgBindery.lhs 14.9 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6 7
%
\section[CgBindery]{Utility functions related to doing @CgBindings@}

\begin{code}
module CgBindery (
8
	CgBindings, CgIdInfo,
9
	StableLoc, VolatileLoc,
10

11 12 13
	cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,

	stableIdInfo, heapIdInfo, 
14 15
	letNoEscapeIdInfo, idInfoToAmode,

16 17
	addBindC, addBindsC,

18
	nukeVolatileBinds,
19
	nukeDeadBindings,
20
	getLiveStackSlots,
21

22
	bindArgsToStack,  rebindToStack,
23
	bindNewToNode, bindNewToReg, bindArgsToRegs,
24
	bindNewToTemp, 
25 26
	getArgAmode, getArgAmodes, 
	getCgIdInfo, 
27
	getCAddrModeIfVolatile, getVolatileRegs,
28
	maybeLetNoEscape, 
29 30
    ) where

31
#include "HsVersions.h"
32

33
import CgMonad
34 35 36 37
import CgHeapery	( getHpRelOffset )
import CgStackery	( freeStackSlots, getSpRelOffset )
import CgUtils		( cgLit, cmmOffsetW )
import CLabel		( mkClosureLabel, pprCLabel )
38
import ClosureInfo	( mkLFImported, mkLFArgument, LambdaFormInfo )
39 40 41 42 43 44 45

import Cmm
import PprCmm		( {- instance Outputable -} )
import SMRep		( CgRep(..), WordOff, isFollowableArg, 
			  isVoidArg, cgRepSizeW, argMachRep, 
			  idCgRep, typeCgRep )
import Id		( Id, idName )
46 47
import VarEnv
import VarSet		( varSetElems )
48 49 50
import Literal		( literalType )
import Maybes		( catMaybes )
import Name		( isExternalName )
51
import StgSyn		( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
52
import Unique           ( Uniquable(..) )
53
import UniqSet		( elementOfUniqSet )
54
import Outputable
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
\end{code}


%************************************************************************
%*									*
\subsection[Bindery-datatypes]{Data types}
%*									*
%************************************************************************

@(CgBinding a b)@ is a type of finite maps from a to b.

The assumption used to be that @lookupCgBind@ must get exactly one
match.  This is {\em completely wrong} in the case of compiling
letrecs (where knot-tying is used).  An initial binding is fed in (and
never evaluated); eventually, a correct binding is put into the
environment.  So there can be two bindings for a given name.

\begin{code}
type CgBindings = IdEnv CgIdInfo

data CgIdInfo
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
  = CgIdInfo	
	{ cg_id :: Id	-- Id that this is the info for
			-- Can differ from the Id at occurrence sites by 
			-- virtue of being externalised, for splittable C
	, cg_rep :: CgRep
	, cg_vol :: VolatileLoc
	, cg_stb :: StableLoc
	, cg_lf  :: LambdaFormInfo }

mkCgIdInfo id vol stb lf
  = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, 
	       cg_lf = lf, cg_rep = idCgRep id }

voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
			 , cg_stb = VoidLoc, cg_lf = mkLFArgument id
			 , cg_rep = VoidArg }
	-- Used just for VoidRep things
93 94 95

data VolatileLoc
  = NoVolatileLoc
96 97 98 99
  | RegLoc	CmmReg		   -- In one of the registers (global or local)
  | VirHpLoc	VirtualHpOffset  -- Hp+offset (address of closure)
  | VirNodeLoc	VirtualHpOffset  -- Cts of offset indirect from Node
				   -- ie *(Node+offset)
100 101 102 103 104 105 106 107 108
\end{code}

@StableLoc@ encodes where an Id can be found, used by
the @CgBindings@ environment in @CgBindery@.

\begin{code}
data StableLoc
  = NoStableLoc

109 110
  | VirStkLoc	VirtualSpOffset		-- The thing is held in this
					-- stack slot
111

112 113 114 115 116 117 118 119
  | VirStkLNE	VirtualSpOffset		-- A let-no-escape thing; the
					-- value is this stack pointer
					-- (as opposed to the contents of the slot)

  | StableLoc	CmmExpr
  | VoidLoc	-- Used only for VoidRep variables.  They never need to
		-- be saved, so it makes sense to treat treat them as
		-- having a stable location
120 121
\end{code}

122 123
\begin{code}
instance Outputable CgIdInfo where
124
  ppr (CgIdInfo id rep vol stb lf)
125 126 127 128
    = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]

instance Outputable VolatileLoc where
  ppr NoVolatileLoc = empty
129 130 131
  ppr (RegLoc r)     = ptext SLIT("reg") <+> ppr r
  ppr (VirHpLoc v)   = ptext SLIT("vh")  <+> ppr v
  ppr (VirNodeLoc v) = ptext SLIT("vn")  <+> ppr v
132 133

instance Outputable StableLoc where
134 135 136 137 138
  ppr NoStableLoc   = empty
  ppr VoidLoc       = ptext SLIT("void")
  ppr (VirStkLoc v) = ptext SLIT("vs")    <+> ppr v
  ppr (VirStkLNE v) = ptext SLIT("lne")    <+> ppr v
  ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
139 140
\end{code}

141 142 143 144 145 146 147
%************************************************************************
%*									*
\subsection[Bindery-idInfo]{Manipulating IdInfo}
%*									*
%************************************************************************

\begin{code}
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
stableIdInfo id amode   lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
heapIdInfo id offset    lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
stackIdInfo id sp	lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
nodeIdInfo id offset    lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
regIdInfo id reg        lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info

idInfoToAmode :: CgIdInfo -> FCode CmmExpr
idInfoToAmode info
  = case cg_vol info of {
      RegLoc reg 	-> returnFC (CmmReg reg) ;
      VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
      VirHpLoc hp_off   -> getHpRelOffset hp_off ;
      NoVolatileLoc -> 

    case cg_stb info of
      StableLoc amode  -> returnFC amode
      VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
			     ; return (CmmLoad sp_rel mach_rep) }

      VirStkLNE sp_off -> getSpRelOffset sp_off ;

      VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
		-- We return a 'bottom' amode, rather than panicing now
		-- In this way getArgAmode returns a pair of (VoidArg, bottom)
		-- and that's exactly what we want

      NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
    }
  where
    mach_rep = argMachRep (cg_rep info)
179

180 181
cgIdInfoId :: CgIdInfo -> Id
cgIdInfoId = cg_id 
182

183 184
cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
cgIdInfoLF = cg_lf
185

186 187
cgIdInfoArgRep :: CgIdInfo -> CgRep
cgIdInfoArgRep = cg_rep
188

189 190
maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
maybeLetNoEscape other   				  = Nothing
191 192
\end{code}

193 194 195 196 197 198
%************************************************************************
%*									*
\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
%*									*
%************************************************************************

199 200
.There are three basic routines, for adding (@addBindC@), modifying
(@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
201 202 203 204 205 206

A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
The name should not already be bound. (nice ASSERT, eh?)

\begin{code}
addBindC :: Id -> CgIdInfo -> Code
rje's avatar
rje committed
207 208 209
addBindC name stuff_to_bind = do
	binds <- getBinds
	setBinds $ extendVarEnv binds name stuff_to_bind
210 211

addBindsC :: [(Id, CgIdInfo)] -> Code
rje's avatar
rje committed
212 213 214
addBindsC new_bindings = do
	binds <- getBinds
	let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
215 216
			      binds
			      new_bindings
rje's avatar
rje committed
217
	setBinds new_binds
218 219

modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
rje's avatar
rje committed
220 221 222
modifyBindC name mangle_fn = do
	binds <- getBinds
	setBinds $ modifyVarEnv mangle_fn binds name
223

224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo id
  = do	{ 	-- Try local bindings first
	; local_binds  <- getBinds
	; case lookupVarEnv local_binds id of {
	    Just info -> return info ;
	    Nothing   -> do

	{ 	-- Try top-level bindings
	  static_binds <- getStaticBinds
	; case lookupVarEnv static_binds id of {
	    Just info -> return info ;
	    Nothing   ->

		-- Should be imported; make up a CgIdInfo for it
	if isExternalName name then
	    return (stableIdInfo id ext_lbl (mkLFImported id))
	else
	if isVoidArg (idCgRep id) then
		-- Void things are never in the environment
	    return (voidIdInfo id)
	else
	-- Bug	
	cgLookupPanic id
	}}}}
  where
    name    = idName id
    ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
rje's avatar
rje committed
252
			
253 254 255
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
  = do	static_binds <- getStaticBinds
rje's avatar
rje committed
256 257 258
	local_binds <- getBinds
	srt <- getSRTLabel
	pprPanic "cgPanic"
259
		(vcat [ppr id,
260
		ptext SLIT("static binds for:"),
261
		vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ],
262
		ptext SLIT("local binds for:"),
263
		vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ],
264 265 266 267
	        ptext SLIT("SRT label") <+> pprCLabel srt
	      ])
\end{code}

268 269 270 271 272 273 274 275 276 277 278 279
%************************************************************************
%*									*
\subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
%*									*
%************************************************************************

We sometimes want to nuke all the volatile bindings; we must be sure
we don't leave any (NoVolatile, NoStable) binds around...

\begin{code}
nukeVolatileBinds :: CgBindings -> CgBindings
nukeVolatileBinds binds
280
  = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
281
  where
282 283 284
    keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
    keep_if_stable info acc
      = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
285 286 287 288 289 290 291 292 293 294
\end{code}


%************************************************************************
%*									*
\subsection[lookup-interface]{Interface functions to looking up bindings}
%*									*
%************************************************************************

\begin{code}
295 296 297 298
getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
getCAddrModeIfVolatile id
  = do	{ info <- getCgIdInfo id
	; case cg_stb info of
rje's avatar
rje committed
299
		NoStableLoc -> do -- Aha!  So it is volatile!
300
			amode <- idInfoToAmode info
rje's avatar
rje committed
301
			return $ Just amode
302
		a_stable_loc -> return Nothing }
303 304 305 306 307 308 309 310 311 312
\end{code}

@getVolatileRegs@ gets a set of live variables, and returns a list of
all registers on which these variables depend.  These are the regs
which must be saved and restored across any C calls.  If a variable is
both in a volatile location (depending on a register) {\em and} a
stable one (notably, on the stack), we modify the current bindings to
forget the volatile one.

\begin{code}
313
getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
314

rje's avatar
rje committed
315
getVolatileRegs vars = do
316 317 318 319 320 321
  do 	{ stuff <- mapFCs snaffle_it (varSetElems vars)
	; returnFC $ catMaybes stuff }
  where
    snaffle_it var = do
	{ info <- getCgIdInfo var 
	; let
rje's avatar
rje committed
322
		-- commoned-up code...
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
	     consider_reg reg
		=	-- We assume that all regs can die across C calls
			-- We leave it to the save-macros to decide which
			-- regs *really* need to be saved.
		  case cg_stb info of
			NoStableLoc     -> returnFC (Just reg) -- got one!
			is_a_stable_loc -> do
				{ -- has both volatile & stable locations;
				  -- force it to rely on the stable location
				  modifyBindC var nuke_vol_bind 
				; return Nothing }

	; case cg_vol info of
	    RegLoc (CmmGlobal reg) -> consider_reg reg
	    VirNodeLoc _ 	   -> consider_reg node
	    other_loc 	 	   -> returnFC Nothing	-- Local registers
	}

    nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
342 343 344
\end{code}

\begin{code}
345 346 347 348 349
getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
getArgAmode (StgVarArg var) 
  = do	{ info <- getCgIdInfo var
	; amode <- idInfoToAmode info
	; return (cgIdInfoArgRep info, amode ) }
350

351 352 353
getArgAmode (StgLitArg lit) 
  = do	{ cmm_lit <- cgLit lit
	; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
354

355 356 357 358 359 360 361 362 363
getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"

getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
  | isStgTypeArg atom = getArgAmodes atoms
  | otherwise 	      = do { amode  <- getArgAmode  atom 
	 		   ; amodes <- getArgAmodes atoms
	 		   ; return ( amode : amodes ) }
364 365 366 367 368 369 370 371 372
\end{code}

%************************************************************************
%*									*
\subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
%*									*
%************************************************************************

\begin{code}
373 374 375
bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
bindArgsToStack args
  = mapCs bind args
376
  where
377
    bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
378

379 380 381
bindArgsToRegs :: [(Id, GlobalReg)] -> Code
bindArgsToRegs args
  = mapCs bind args
382
  where
383 384 385 386 387
    bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)

bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
bindNewToNode id offset lf_info
  = addBindC id (nodeIdInfo id offset lf_info)
388 389 390 391

-- Create a new temporary whose unique is that in the id,
-- bind the id to it, and return the addressing mode for the
-- temporary.
392
bindNewToTemp :: Id -> FCode CmmReg
393
bindNewToTemp id
394 395
  = do	addBindC id (regIdInfo id temp_reg lf_info)
	return temp_reg
396
  where
397 398 399 400
    uniq     = getUnique id
    temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
    lf_info  = mkLFArgument id	-- Always used of things we
				-- know nothing about
401

402 403 404
bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
bindNewToReg name reg lf_info
  = addBindC name info
405
  where
406
    info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
407 408 409
\end{code}

\begin{code}
410 411
rebindToStack :: Id -> VirtualSpOffset -> Code
rebindToStack name offset
412 413
  = modifyBindC name replace_stable_fn
  where
414
    replace_stable_fn info = info { cg_stb = VirStkLoc offset }
415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440
\end{code}

%************************************************************************
%*									*
\subsection[CgMonad-deadslots]{Finding dead stack slots}
%*									*
%************************************************************************

nukeDeadBindings does the following:

      -	Removes all bindings from the environment other than those
	for variables in the argument to nukeDeadBindings.
      -	Collects any stack slots so freed, and returns them to the  stack free
	list.
      -	Moves the virtual stack pointer to point to the topmost used
	stack locations.

You can have multi-word slots on the stack (where a Double# used to
be, for instance); if dead, such a slot will be reported as *several*
offsets (one per word).

Probably *naughty* to look inside monad...

\begin{code}
nukeDeadBindings :: StgLiveVars  -- All the *live* variables
		 -> Code
rje's avatar
rje committed
441 442 443 444 445
nukeDeadBindings live_vars = do
	binds <- getBinds
	let (dead_stk_slots, bs') =
		dead_slots live_vars 
			[] []
446
			[ (cg_id b, b) | b <- rngVarEnv binds ]
rje's avatar
rje committed
447
	setBinds $ mkVarEnv bs'
448
	freeStackSlots dead_stk_slots
449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
\end{code}

Several boring auxiliary functions to do the dirty work.

\begin{code}
dead_slots :: StgLiveVars
	   -> [(Id,CgIdInfo)]
	   -> [VirtualSpOffset]
	   -> [(Id,CgIdInfo)]
	   -> ([VirtualSpOffset], [(Id,CgIdInfo)])

-- dead_slots carries accumulating parameters for
--	filtered bindings, dead slots
dead_slots live_vars fbs ds []
  = (ds, reverse fbs) -- Finished; rm the dups, if any

dead_slots live_vars fbs ds ((v,i):bs)
  | v `elementOfUniqSet` live_vars
    = dead_slots live_vars ((v,i):fbs) ds bs
	  -- Live, so don't record it in dead slots
	  -- Instead keep it in the filtered bindings

  | otherwise
472 473 474 475
    = case cg_stb i of
	VirStkLoc offset
	 | size > 0
	 -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
476 477 478

	_ -> dead_slots live_vars fbs ds bs
  where
479 480 481
    size :: WordOff
    size = cgRepSizeW (cg_rep i)
\end{code}
482

483 484 485 486 487 488 489 490
\begin{code}
getLiveStackSlots :: FCode [VirtualSpOffset]
-- Return the offsets of slots in stack containig live pointers
getLiveStackSlots 
  = do 	{ binds <- getBinds
	; return [off | CgIdInfo { cg_stb = VirStkLoc off, 
				   cg_rep = rep } <- rngVarEnv binds, 
		        isFollowableArg rep] }
491
\end{code}