2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[CgBindery]{Utility functions related to doing @CgBindings@}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 StableLoc, VolatileLoc,
19 cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
21 stableIdInfo, heapIdInfo,
22 taggedStableIdInfo, taggedHeapIdInfo,
23 letNoEscapeIdInfo, idInfoToAmode,
32 bindArgsToStack, rebindToStack,
33 bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs,
35 getArgAmode, getArgAmodes,
37 getCAddrModeIfVolatile, getVolatileRegs,
41 #include "HsVersions.h"
52 import PprCmm ( {- instance Outputable -} )
70 %************************************************************************
72 \subsection[Bindery-datatypes]{Data types}
74 %************************************************************************
76 @(CgBinding a b)@ is a type of finite maps from a to b.
78 The assumption used to be that @lookupCgBind@ must get exactly one
79 match. This is {\em completely wrong} in the case of compiling
80 letrecs (where knot-tying is used). An initial binding is fed in (and
81 never evaluated); eventually, a correct binding is put into the
82 environment. So there can be two bindings for a given name.
85 type CgBindings = IdEnv CgIdInfo
89 { cg_id :: Id -- Id that this is the info for
90 -- Can differ from the Id at occurrence sites by
91 -- virtue of being externalised, for splittable C
93 , cg_vol :: VolatileLoc
95 , cg_lf :: LambdaFormInfo
96 , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode
99 mkCgIdInfo id vol stb lf
100 = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
101 cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
104 | Just con <- isDataConWorkId_maybe id,
105 {- Is this an identifier for a static constructor closure? -}
106 isNullaryRepDataCon con
107 {- If yes, is this a nullary constructor?
108 If yes, we assume that the constructor is evaluated and can
116 voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
117 , cg_stb = VoidLoc, cg_lf = mkLFArgument id
118 , cg_rep = VoidArg, cg_tag = 0 }
119 -- Used just for VoidRep things
121 data VolatileLoc -- These locations die across a call
123 | RegLoc CmmReg -- In one of the registers (global or local)
124 | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure)
125 | VirNodeLoc ByteOff -- Cts of offset indirect from Node
126 -- ie *(Node+offset).
127 -- NB. Byte offset, because we subtract R1's
128 -- tag from the offset.
130 mkTaggedCgIdInfo id vol stb lf con
131 = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
132 cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con }
135 @StableLoc@ encodes where an Id can be found, used by
136 the @CgBindings@ environment in @CgBindery@.
142 | VirStkLoc VirtualSpOffset -- The thing is held in this
145 | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the
146 -- value is this stack pointer
147 -- (as opposed to the contents of the slot)
150 | VoidLoc -- Used only for VoidRep variables. They never need to
151 -- be saved, so it makes sense to treat treat them as
152 -- having a stable location
156 instance Outputable CgIdInfo where
157 ppr (CgIdInfo id rep vol stb lf _) -- TODO, pretty pring the tag info
158 = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
160 instance Outputable VolatileLoc where
161 ppr NoVolatileLoc = empty
162 ppr (RegLoc r) = ptext SLIT("reg") <+> ppr r
163 ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
164 ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
166 instance Outputable StableLoc where
167 ppr NoStableLoc = empty
168 ppr VoidLoc = ptext SLIT("void")
169 ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
170 ppr (VirStkLNE v) = ptext SLIT("lne") <+> ppr v
171 ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
174 %************************************************************************
176 \subsection[Bindery-idInfo]{Manipulating IdInfo}
178 %************************************************************************
181 stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
182 heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
183 letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
184 stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
185 nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info
186 regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
188 taggedStableIdInfo id amode lf_info con
189 = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con
190 taggedHeapIdInfo id offset lf_info con
191 = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con
192 untagNodeIdInfo id offset lf_info tag
193 = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info
196 idInfoToAmode :: CgIdInfo -> FCode CmmExpr
198 = case cg_vol info of {
199 RegLoc reg -> returnFC (CmmReg reg) ;
200 VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off)
202 VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off
203 ; return $! maybeTag off };
207 StableLoc amode -> returnFC $! maybeTag amode
208 VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
209 ; return (CmmLoad sp_rel mach_rep) }
211 VirStkLNE sp_off -> getSpRelOffset sp_off
213 VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
214 -- We return a 'bottom' amode, rather than panicing now
215 -- In this way getArgAmode returns a pair of (VoidArg, bottom)
216 -- and that's exactly what we want
218 NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
221 mach_rep = argMachRep (cg_rep info)
223 maybeTag amode -- add the tag, if we have one
225 | otherwise = cmmOffsetB amode tag
226 where tag = cg_tag info
228 cgIdInfoId :: CgIdInfo -> Id
231 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
234 cgIdInfoArgRep :: CgIdInfo -> CgRep
235 cgIdInfoArgRep = cg_rep
237 maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
238 maybeLetNoEscape other = Nothing
241 %************************************************************************
243 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
245 %************************************************************************
247 .There are three basic routines, for adding (@addBindC@), modifying
248 (@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
250 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
251 The name should not already be bound. (nice ASSERT, eh?)
254 addBindC :: Id -> CgIdInfo -> Code
255 addBindC name stuff_to_bind = do
257 setBinds $ extendVarEnv binds name stuff_to_bind
259 addBindsC :: [(Id, CgIdInfo)] -> Code
260 addBindsC new_bindings = do
262 let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
267 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
268 modifyBindC name mangle_fn = do
270 setBinds $ modifyVarEnv mangle_fn binds name
272 getCgIdInfo :: Id -> FCode CgIdInfo
274 = do { -- Try local bindings first
275 ; local_binds <- getBinds
276 ; case lookupVarEnv local_binds id of {
277 Just info -> return info ;
280 { -- Try top-level bindings
281 static_binds <- getStaticBinds
282 ; case lookupVarEnv static_binds id of {
283 Just info -> return info ;
286 -- Should be imported; make up a CgIdInfo for it
290 if isExternalName name then do
291 let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
292 return (stableIdInfo id ext_lbl (mkLFImported id))
294 if isVoidArg (idCgRep id) then
295 -- Void things are never in the environment
296 return (voidIdInfo id)
303 cgLookupPanic :: Id -> FCode a
305 = do static_binds <- getStaticBinds
306 local_binds <- getBinds
310 ptext SLIT("static binds for:"),
311 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
312 ptext SLIT("local binds for:"),
313 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
314 ptext SLIT("SRT label") <+> pprCLabel srt
318 %************************************************************************
320 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
322 %************************************************************************
324 We sometimes want to nuke all the volatile bindings; we must be sure
325 we don't leave any (NoVolatile, NoStable) binds around...
328 nukeVolatileBinds :: CgBindings -> CgBindings
329 nukeVolatileBinds binds
330 = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
332 keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
333 keep_if_stable info acc
334 = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
338 %************************************************************************
340 \subsection[lookup-interface]{Interface functions to looking up bindings}
342 %************************************************************************
345 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
346 getCAddrModeIfVolatile id
347 = do { info <- getCgIdInfo id
348 ; case cg_stb info of
349 NoStableLoc -> do -- Aha! So it is volatile!
350 amode <- idInfoToAmode info
352 a_stable_loc -> return Nothing }
355 @getVolatileRegs@ gets a set of live variables, and returns a list of
356 all registers on which these variables depend. These are the regs
357 which must be saved and restored across any C calls. If a variable is
358 both in a volatile location (depending on a register) {\em and} a
359 stable one (notably, on the stack), we modify the current bindings to
360 forget the volatile one.
363 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
365 getVolatileRegs vars = do
366 do { stuff <- mapFCs snaffle_it (varSetElems vars)
367 ; returnFC $ catMaybes stuff }
370 { info <- getCgIdInfo var
372 -- commoned-up code...
374 = -- We assume that all regs can die across C calls
375 -- We leave it to the save-macros to decide which
376 -- regs *really* need to be saved.
378 NoStableLoc -> returnFC (Just reg) -- got one!
379 is_a_stable_loc -> do
380 { -- has both volatile & stable locations;
381 -- force it to rely on the stable location
382 modifyBindC var nuke_vol_bind
385 ; case cg_vol info of
386 RegLoc (CmmGlobal reg) -> consider_reg reg
387 VirNodeLoc _ -> consider_reg node
388 other_loc -> returnFC Nothing -- Local registers
391 nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
395 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
396 getArgAmode (StgVarArg var)
397 = do { info <- getCgIdInfo var
398 ; amode <- idInfoToAmode info
399 ; return (cgIdInfoArgRep info, amode ) }
401 getArgAmode (StgLitArg lit)
402 = do { cmm_lit <- cgLit lit
403 ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
405 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
407 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
408 getArgAmodes [] = returnFC []
409 getArgAmodes (atom:atoms)
410 | isStgTypeArg atom = getArgAmodes atoms
411 | otherwise = do { amode <- getArgAmode atom
412 ; amodes <- getArgAmodes atoms
413 ; return ( amode : amodes ) }
416 %************************************************************************
418 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
420 %************************************************************************
423 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
427 bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
429 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
433 bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
435 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
436 bindNewToNode id offset lf_info
437 = addBindC id (nodeIdInfo id offset lf_info)
439 bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
440 bindNewToUntagNode id offset lf_info tag
441 = addBindC id (untagNodeIdInfo id offset lf_info tag)
443 -- Create a new temporary whose unique is that in the id,
444 -- bind the id to it, and return the addressing mode for the
446 bindNewToTemp :: Id -> FCode LocalReg
448 = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
452 temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
453 kind = if isFollowableArg (idCgRep id)
456 lf_info = mkLFArgument id -- Always used of things we
457 -- know nothing about
459 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
460 bindNewToReg name reg lf_info
463 info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
467 rebindToStack :: Id -> VirtualSpOffset -> Code
468 rebindToStack name offset
469 = modifyBindC name replace_stable_fn
471 replace_stable_fn info = info { cg_stb = VirStkLoc offset }
474 %************************************************************************
476 \subsection[CgMonad-deadslots]{Finding dead stack slots}
478 %************************************************************************
480 nukeDeadBindings does the following:
482 - Removes all bindings from the environment other than those
483 for variables in the argument to nukeDeadBindings.
484 - Collects any stack slots so freed, and returns them to the stack free
486 - Moves the virtual stack pointer to point to the topmost used
489 You can have multi-word slots on the stack (where a Double# used to
490 be, for instance); if dead, such a slot will be reported as *several*
491 offsets (one per word).
493 Probably *naughty* to look inside monad...
496 nukeDeadBindings :: StgLiveVars -- All the *live* variables
498 nukeDeadBindings live_vars = do
500 let (dead_stk_slots, bs') =
503 [ (cg_id b, b) | b <- varEnvElts binds ]
504 setBinds $ mkVarEnv bs'
505 freeStackSlots dead_stk_slots
508 Several boring auxiliary functions to do the dirty work.
511 dead_slots :: StgLiveVars
515 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
517 -- dead_slots carries accumulating parameters for
518 -- filtered bindings, dead slots
519 dead_slots live_vars fbs ds []
520 = (ds, reverse fbs) -- Finished; rm the dups, if any
522 dead_slots live_vars fbs ds ((v,i):bs)
523 | v `elementOfUniqSet` live_vars
524 = dead_slots live_vars ((v,i):fbs) ds bs
525 -- Live, so don't record it in dead slots
526 -- Instead keep it in the filtered bindings
532 -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
534 _ -> dead_slots live_vars fbs ds bs
537 size = cgRepSizeW (cg_rep i)
541 getLiveStackSlots :: FCode [VirtualSpOffset]
542 -- Return the offsets of slots in stack containig live pointers
544 = do { binds <- getBinds
545 ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
546 cg_rep = rep } <- varEnvElts binds,
547 isFollowableArg rep] }
551 getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
553 = do { binds <- getBinds
554 ; return [(off, bind) |
555 bind <- varEnvElts binds,
556 CgIdInfo { cg_stb = VirStkLoc off,
557 cg_rep = rep} <- [bind],
558 isFollowableArg rep] }