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

\begin{code}
#include "HsVersions.h"

module CgBindery (
10
	SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
11
	StableLoc, VolatileLoc,
12
13
14
15
16
17
18
19
20
21
22

	maybeAStkLoc, maybeBStkLoc,

	stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
	letNoEscapeIdInfo, idInfoToAmode,

	nukeVolatileBinds,

	bindNewToAStack, bindNewToBStack,
	bindNewToNode, bindNewToReg, bindArgsToRegs,
	bindNewToTemp, bindNewPrimToAmode,
23
	getArgAmode, getArgAmodes,
24
25
	getCAddrModeAndInfo, getCAddrMode,
	getCAddrModeIfVolatile, getVolatileRegs,
26
	rebindToAStack, rebindToBStack
27
28
    ) where

29
30
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(CgLoop1)		-- here for paranoia-checking
31

32
33
34
35
import AbsCSyn
import CgMonad

import CgUsages		( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
36
import CLabel		( mkClosureLabel )
37
import ClosureInfo	( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
38
39
import HeapOffs		( SYN_IE(VirtualHeapOffset),
			  SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
40
41
			)
import Id		( idPrimRep, toplevelishId, isDataCon,
42
			  mkIdEnv, rngIdEnv, SYN_IE(IdEnv),
43
44
45
46
			  idSetToList,
			  GenId{-instance NamedThing-}
			)
import Maybes		( catMaybes )
47
import Name		( isLocallyDefined, oddlyImportedName, 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
54
import Unpretty		( uppShow )
import Util		( zipWithEqual, panic )
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
\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
  = MkCgIdInfo	Id	-- Id that this is the info for
		VolatileLoc
		StableLoc
		LambdaFormInfo

data VolatileLoc
  = NoVolatileLoc
  | TempVarLoc	Unique

  | RegLoc	MagicId			-- in one of the magic registers
					-- (probably {Int,Float,Char,etc}Reg

  | VirHpLoc	VirtualHeapOffset	-- Hp+offset (address of closure)

  | VirNodeLoc	VirtualHeapOffset	-- Cts of offset indirect from Node
					-- ie *(Node+offset)

data StableLoc
  = NoStableLoc
  | VirAStkLoc		VirtualSpAOffset
  | VirBStkLoc		VirtualSpBOffset
97
  | LitLoc		Literal
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
  | StableAmodeLoc	CAddrMode

-- these are so StableLoc can be abstract:

maybeAStkLoc (VirAStkLoc offset) = Just offset
maybeAStkLoc _			 = Nothing

maybeBStkLoc (VirBStkLoc offset) = Just offset
maybeBStkLoc _			 = Nothing
\end{code}

%************************************************************************
%*									*
\subsection[Bindery-idInfo]{Manipulating IdInfo}
%*									*
%************************************************************************

\begin{code}
stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
heapIdInfo i offset       lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
tempIdInfo i uniq         lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info

letNoEscapeIdInfo i spa spb lf_info
  = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info

newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)

newTempAmodeAndIdInfo name lf_info
  = (temp_amode, temp_idinfo)
  where
128
    uniq       	= uniqueOf name
129
    temp_amode	= CTemp uniq (idPrimRep name)
130
131
    temp_idinfo = tempIdInfo name uniq lf_info

132
idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
133
134
idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab

135
idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc   = returnFC (CTemp uniq kind)
idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc   = returnFC (CReg magic_id)

idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit)           = returnFC (CLit lit)
idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode

idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
  = returnFC (CVal (NodeRel nd_off) kind)
    -- Virtual offsets from Node increase into the closures,
    -- and so do Node-relative offsets (which we want in the CVal),
    -- so there is no mucking about to do to the offset.

idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
  = getHpRelOffset hp_off `thenFC` \ rel_hp ->
    returnFC (CAddr rel_hp)

idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
  = getSpARelOffset i `thenFC` \ rel_spA ->
    returnFC (CVal rel_spA kind)

idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
  = getSpBRelOffset i `thenFC` \ rel_spB ->
    returnFC (CVal rel_spB kind)

161
#ifdef DEBUG
162
idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
163
#endif
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
\end{code}

%************************************************************************
%*									*
\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
  = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
  where
    keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
    keep_if_stable (MkCgIdInfo i _ stable_loc  entry_info) acc
      = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
\end{code}


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

I {\em think} all looking-up is done through @getCAddrMode(s)@.

\begin{code}
getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)

197
198
getCAddrModeAndInfo id
  | not (isLocallyDefined name) || oddlyImportedName name
199
200
201
202
203
204
205
206
207
    {- Why the "oddlyImported"?
	Imagine you are compiling GHCbase.hs (a module that
	supplies some of the wired-in values).  What can
	happen is that the compiler will inject calls to
	(e.g.) GHCbase.unpackPS, where-ever it likes -- it
	assumes those values are ubiquitously available.
	The main point is: it may inject calls to them earlier
	in GHCbase.hs than the actual definition...
    -}
208
  = returnFC (global_amode, mkLFImported id)
209
210
211

  | otherwise = -- *might* be a nested defn: in any case, it's something whose
		-- definition we will know about...
212
    lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
213
214
215
    idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
    returnFC (amode, lf_info)
  where
216
217
218
    name = getName id
    global_amode = CLbl (mkClosureLabel id) kind
    kind = idPrimRep id
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233

getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
  = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
    returnFC amode
\end{code}

\begin{code}
getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
getCAddrModeIfVolatile name
  | toplevelishId name = returnFC Nothing
  | otherwise
  = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
    case stable_loc of
	NoStableLoc ->	-- Aha!  So it is volatile!
234
	    idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
235
236
237
238
239
240
241
242
243
244
245
246
247
	    returnFC (Just amode)

	a_stable_loc -> returnFC Nothing
\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}
248
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
249
250

getVolatileRegs vars
251
  = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
252
253
254
255
256
257
258
    returnFC (catMaybes stuff)
  where
    snaffle_it var
      = lookupBindC var	`thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
	let
	    -- commoned-up code...
	    consider_reg reg
259
	      =	if not (isVolatileReg reg) then
260
261
262
263
264
265
266
267
			-- Potentially dies across C calls
			-- For now, that's everything; we leave
			-- it to the save-macros to decide which
			-- regs *really* need to be saved.
		    returnFC Nothing
		else
		    case stable_loc of
		      NoStableLoc -> returnFC (Just reg) -- got one!
268
		      is_a_stable_loc ->
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
			-- has both volatile & stable locations;
			-- force it to rely on the stable location
			modifyBindC var nuke_vol_bind `thenC`
			returnFC Nothing
	in
	case volatile_loc of
	  RegLoc reg   -> consider_reg reg
    	  VirHpLoc _   -> consider_reg Hp
	  VirNodeLoc _ -> consider_reg node
	  non_reg_loc  -> returnFC Nothing

    nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
      = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
\end{code}

\begin{code}
285
286
287
288
289
getArgAmodes :: [StgArg] -> FCode [CAddrMode]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
  = getArgAmode  atom  `thenFC` \ amode ->
    getArgAmodes atoms `thenFC` \ amodes ->
290
291
    returnFC ( amode : amodes )

292
getArgAmode :: StgArg -> FCode CAddrMode
293

294
295
getArgAmode (StgVarArg var) = getCAddrMode var
getArgAmode (StgLitArg lit) = returnFC (CLit lit)
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
\end{code}

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

\begin{code}
bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
bindNewToAStack (name, offset)
  = addBindC name info
  where
    info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument

bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
bindNewToBStack (name, offset)
  = addBindC name info
  where
    info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
	   -- B-stack things shouldn't need lambda-form info!

bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
bindNewToNode name offset lf_info
  = addBindC name info
  where
    info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info

-- Create a new temporary whose unique is that in the id,
-- bind the id to it, and return the addressing mode for the
-- temporary.
bindNewToTemp :: Id -> FCode CAddrMode
bindNewToTemp name
  = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
		-- This is used only for things we don't know
		-- anything about; values returned by a case statement,
		-- for example.
    in
    addBindC name id_info	`thenC`
    returnFC temp_amode

bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
bindNewToReg name magic_id lf_info
  = addBindC name info
  where
    info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info

bindNewToLit name lit
  = addBindC name info
  where
    info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")

bindArgsToRegs :: [Id] -> [MagicId] -> Code
bindArgsToRegs args regs
350
  = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
351
  where
352
    arg `bind` reg = bindNewToReg arg reg mkLFArgument
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
\end{code}

@bindNewPrimToAmode@ works only for certain addressing modes, because
those are the only ones we've needed so far!

\begin{code}
bindNewPrimToAmode :: Id -> CAddrMode -> Code
bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
						-- was: mkLFArgument
						-- LFinfo is irrelevant for primitives
bindNewPrimToAmode name (CTemp uniq kind)
  = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
	-- LFinfo is irrelevant for primitives

bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit

369
bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
370
371
  = bindNewToBStack (name, offset)

372
bindNewPrimToAmode name (CVal (NodeRel offset) _)
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
  = bindNewToNode name offset (panic "bindNewPrimToAmode node")
  -- See comment on idInfoPiecesToAmode for VirNodeLoc

#ifdef DEBUG
bindNewPrimToAmode name amode
  = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug  amode)))
#endif
\end{code}

\begin{code}
rebindToAStack :: Id -> VirtualSpAOffset -> Code
rebindToAStack name offset
  = modifyBindC name replace_stable_fn
  where
    replace_stable_fn (MkCgIdInfo i vol stab einfo)
      = MkCgIdInfo i vol (VirAStkLoc offset) einfo

rebindToBStack :: Id -> VirtualSpBOffset -> Code
rebindToBStack name offset
  = modifyBindC name replace_stable_fn
  where
    replace_stable_fn (MkCgIdInfo i vol stab einfo)
      = MkCgIdInfo i vol (VirBStkLoc offset) einfo
\end{code}