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 -} )
69 %************************************************************************
71 \subsection[Bindery-datatypes]{Data types}
73 %************************************************************************
75 @(CgBinding a b)@ is a type of finite maps from a to b.
77 The assumption used to be that @lookupCgBind@ must get exactly one
78 match. This is {\em completely wrong} in the case of compiling
79 letrecs (where knot-tying is used). An initial binding is fed in (and
80 never evaluated); eventually, a correct binding is put into the
81 environment. So there can be two bindings for a given name.
84 type CgBindings = IdEnv CgIdInfo
88 { cg_id :: Id -- Id that this is the info for
89 -- Can differ from the Id at occurrence sites by
90 -- virtue of being externalised, for splittable C
92 , cg_vol :: VolatileLoc
94 , cg_lf :: LambdaFormInfo
95 , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode
98 mkCgIdInfo id vol stb lf
99 = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
100 cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
103 | Just con <- isDataConWorkId_maybe id,
104 {- Is this an identifier for a static constructor closure? -}
105 isNullaryRepDataCon con
106 {- If yes, is this a nullary constructor?
107 If yes, we assume that the constructor is evaluated and can
115 voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
116 , cg_stb = VoidLoc, cg_lf = mkLFArgument id
117 , cg_rep = VoidArg, cg_tag = 0 }
118 -- Used just for VoidRep things
120 data VolatileLoc -- These locations die across a call
122 | RegLoc CmmReg -- In one of the registers (global or local)
123 | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure)
124 | VirNodeLoc ByteOff -- Cts of offset indirect from Node
125 -- ie *(Node+offset).
126 -- NB. Byte offset, because we subtract R1's
127 -- tag from the offset.
129 mkTaggedCgIdInfo id vol stb lf con
130 = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
131 cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con }
134 @StableLoc@ encodes where an Id can be found, used by
135 the @CgBindings@ environment in @CgBindery@.
141 | VirStkLoc VirtualSpOffset -- The thing is held in this
144 | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the
145 -- value is this stack pointer
146 -- (as opposed to the contents of the slot)
149 | VoidLoc -- Used only for VoidRep variables. They never need to
150 -- be saved, so it makes sense to treat treat them as
151 -- having a stable location
155 instance Outputable CgIdInfo where
156 ppr (CgIdInfo id rep vol stb lf _) -- TODO, pretty pring the tag info
157 = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
159 instance Outputable VolatileLoc where
160 ppr NoVolatileLoc = empty
161 ppr (RegLoc r) = ptext SLIT("reg") <+> ppr r
162 ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
163 ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
165 instance Outputable StableLoc where
166 ppr NoStableLoc = empty
167 ppr VoidLoc = ptext SLIT("void")
168 ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
169 ppr (VirStkLNE v) = ptext SLIT("lne") <+> ppr v
170 ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
173 %************************************************************************
175 \subsection[Bindery-idInfo]{Manipulating IdInfo}
177 %************************************************************************
180 stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
181 heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
182 letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
183 stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
184 nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info
185 regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
187 taggedStableIdInfo id amode lf_info con
188 = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con
189 taggedHeapIdInfo id offset lf_info con
190 = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con
191 untagNodeIdInfo id offset lf_info tag
192 = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info
195 idInfoToAmode :: CgIdInfo -> FCode CmmExpr
197 = case cg_vol info of {
198 RegLoc reg -> returnFC (CmmReg reg) ;
199 VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off)
201 VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off
202 ; return $! maybeTag off };
206 StableLoc amode -> returnFC $! maybeTag amode
207 VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
208 ; return (CmmLoad sp_rel mach_rep) }
210 VirStkLNE sp_off -> getSpRelOffset sp_off
212 VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
213 -- We return a 'bottom' amode, rather than panicing now
214 -- In this way getArgAmode returns a pair of (VoidArg, bottom)
215 -- and that's exactly what we want
217 NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
220 mach_rep = argMachRep (cg_rep info)
222 maybeTag amode -- add the tag, if we have one
224 | otherwise = cmmOffsetB amode tag
225 where tag = cg_tag info
227 cgIdInfoId :: CgIdInfo -> Id
230 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
233 cgIdInfoArgRep :: CgIdInfo -> CgRep
234 cgIdInfoArgRep = cg_rep
236 maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
237 maybeLetNoEscape other = Nothing
240 %************************************************************************
242 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
244 %************************************************************************
246 .There are three basic routines, for adding (@addBindC@), modifying
247 (@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
249 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
250 The name should not already be bound. (nice ASSERT, eh?)
253 addBindC :: Id -> CgIdInfo -> Code
254 addBindC name stuff_to_bind = do
256 setBinds $ extendVarEnv binds name stuff_to_bind
258 addBindsC :: [(Id, CgIdInfo)] -> Code
259 addBindsC new_bindings = do
261 let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
266 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
267 modifyBindC name mangle_fn = do
269 setBinds $ modifyVarEnv mangle_fn binds name
271 getCgIdInfo :: Id -> FCode CgIdInfo
273 = do { -- Try local bindings first
274 ; local_binds <- getBinds
275 ; case lookupVarEnv local_binds id of {
276 Just info -> return info ;
279 { -- Try top-level bindings
280 static_binds <- getStaticBinds
281 ; case lookupVarEnv static_binds id of {
282 Just info -> return info ;
285 -- Should be imported; make up a CgIdInfo for it
289 if isExternalName name then do
290 let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
291 return (stableIdInfo id ext_lbl (mkLFImported id))
293 if isVoidArg (idCgRep id) then
294 -- Void things are never in the environment
295 return (voidIdInfo id)
302 cgLookupPanic :: Id -> FCode a
304 = do static_binds <- getStaticBinds
305 local_binds <- getBinds
309 ptext SLIT("static binds for:"),
310 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
311 ptext SLIT("local binds for:"),
312 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
313 ptext SLIT("SRT label") <+> pprCLabel srt
317 %************************************************************************
319 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
321 %************************************************************************
323 We sometimes want to nuke all the volatile bindings; we must be sure
324 we don't leave any (NoVolatile, NoStable) binds around...
327 nukeVolatileBinds :: CgBindings -> CgBindings
328 nukeVolatileBinds binds
329 = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
331 keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
332 keep_if_stable info acc
333 = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
337 %************************************************************************
339 \subsection[lookup-interface]{Interface functions to looking up bindings}
341 %************************************************************************
344 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
345 getCAddrModeIfVolatile id
346 = do { info <- getCgIdInfo id
347 ; case cg_stb info of
348 NoStableLoc -> do -- Aha! So it is volatile!
349 amode <- idInfoToAmode info
351 a_stable_loc -> return Nothing }
354 @getVolatileRegs@ gets a set of live variables, and returns a list of
355 all registers on which these variables depend. These are the regs
356 which must be saved and restored across any C calls. If a variable is
357 both in a volatile location (depending on a register) {\em and} a
358 stable one (notably, on the stack), we modify the current bindings to
359 forget the volatile one.
362 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
364 getVolatileRegs vars = do
365 do { stuff <- mapFCs snaffle_it (varSetElems vars)
366 ; returnFC $ catMaybes stuff }
369 { info <- getCgIdInfo var
371 -- commoned-up code...
373 = -- We assume that all regs can die across C calls
374 -- We leave it to the save-macros to decide which
375 -- regs *really* need to be saved.
377 NoStableLoc -> returnFC (Just reg) -- got one!
378 is_a_stable_loc -> do
379 { -- has both volatile & stable locations;
380 -- force it to rely on the stable location
381 modifyBindC var nuke_vol_bind
384 ; case cg_vol info of
385 RegLoc (CmmGlobal reg) -> consider_reg reg
386 VirNodeLoc _ -> consider_reg node
387 other_loc -> returnFC Nothing -- Local registers
390 nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
394 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
395 getArgAmode (StgVarArg var)
396 = do { info <- getCgIdInfo var
397 ; amode <- idInfoToAmode info
398 ; return (cgIdInfoArgRep info, amode ) }
400 getArgAmode (StgLitArg lit)
401 = do { cmm_lit <- cgLit lit
402 ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
404 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
406 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
407 getArgAmodes [] = returnFC []
408 getArgAmodes (atom:atoms)
409 | isStgTypeArg atom = getArgAmodes atoms
410 | otherwise = do { amode <- getArgAmode atom
411 ; amodes <- getArgAmodes atoms
412 ; return ( amode : amodes ) }
415 %************************************************************************
417 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
419 %************************************************************************
422 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
426 bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
428 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
432 bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
434 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
435 bindNewToNode id offset lf_info
436 = addBindC id (nodeIdInfo id offset lf_info)
438 bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
439 bindNewToUntagNode id offset lf_info tag
440 = addBindC id (untagNodeIdInfo id offset lf_info tag)
442 -- Create a new temporary whose unique is that in the id,
443 -- bind the id to it, and return the addressing mode for the
445 bindNewToTemp :: Id -> FCode LocalReg
447 = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
451 temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
452 kind = if isFollowableArg (idCgRep id)
455 lf_info = mkLFArgument id -- Always used of things we
456 -- know nothing about
458 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
459 bindNewToReg name reg lf_info
462 info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
466 rebindToStack :: Id -> VirtualSpOffset -> Code
467 rebindToStack name offset
468 = modifyBindC name replace_stable_fn
470 replace_stable_fn info = info { cg_stb = VirStkLoc offset }
473 %************************************************************************
475 \subsection[CgMonad-deadslots]{Finding dead stack slots}
477 %************************************************************************
479 nukeDeadBindings does the following:
481 - Removes all bindings from the environment other than those
482 for variables in the argument to nukeDeadBindings.
483 - Collects any stack slots so freed, and returns them to the stack free
485 - Moves the virtual stack pointer to point to the topmost used
488 You can have multi-word slots on the stack (where a Double# used to
489 be, for instance); if dead, such a slot will be reported as *several*
490 offsets (one per word).
492 Probably *naughty* to look inside monad...
495 nukeDeadBindings :: StgLiveVars -- All the *live* variables
497 nukeDeadBindings live_vars = do
499 let (dead_stk_slots, bs') =
502 [ (cg_id b, b) | b <- varEnvElts binds ]
503 setBinds $ mkVarEnv bs'
504 freeStackSlots dead_stk_slots
507 Several boring auxiliary functions to do the dirty work.
510 dead_slots :: StgLiveVars
514 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
516 -- dead_slots carries accumulating parameters for
517 -- filtered bindings, dead slots
518 dead_slots live_vars fbs ds []
519 = (ds, reverse fbs) -- Finished; rm the dups, if any
521 dead_slots live_vars fbs ds ((v,i):bs)
522 | v `elementOfUniqSet` live_vars
523 = dead_slots live_vars ((v,i):fbs) ds bs
524 -- Live, so don't record it in dead slots
525 -- Instead keep it in the filtered bindings
531 -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
533 _ -> dead_slots live_vars fbs ds bs
536 size = cgRepSizeW (cg_rep i)
540 getLiveStackSlots :: FCode [VirtualSpOffset]
541 -- Return the offsets of slots in stack containig live pointers
543 = do { binds <- getBinds
544 ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
545 cg_rep = rep } <- varEnvElts binds,
546 isFollowableArg rep] }
550 getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
552 = do { binds <- getBinds
553 ; return [(off, bind) |
554 bind <- varEnvElts binds,
555 CgIdInfo { cg_stb = VirStkLoc off,
556 cg_rep = rep} <- [bind],
557 isFollowableArg rep] }