Implemented and fixed bugs in CmmInfo handling
[ghc.git] / compiler / codeGen / CgBindery.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[CgBindery]{Utility functions related to doing @CgBindings@}
6
7 \begin{code}
8 module CgBindery (
9         CgBindings, CgIdInfo,
10         StableLoc, VolatileLoc,
11
12         cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
13
14         stableIdInfo, heapIdInfo, 
15         letNoEscapeIdInfo, idInfoToAmode,
16
17         addBindC, addBindsC,
18
19         nukeVolatileBinds,
20         nukeDeadBindings,
21         getLiveStackSlots,
22         getLiveStackBindings,
23
24         bindArgsToStack,  rebindToStack,
25         bindNewToNode, bindNewToReg, bindArgsToRegs,
26         bindNewToTemp,
27         getArgAmode, getArgAmodes, 
28         getCgIdInfo, 
29         getCAddrModeIfVolatile, getVolatileRegs,
30         maybeLetNoEscape, 
31     ) where
32
33 #include "HsVersions.h"
34
35 import CgMonad
36 import CgHeapery
37 import CgStackery
38 import CgUtils
39 import CLabel
40 import ClosureInfo
41
42 import Cmm
43 import PprCmm           ( {- instance Outputable -} )
44 import SMRep
45 import Id
46 import VarEnv
47 import VarSet
48 import Literal
49 import Maybes
50 import Name
51 import StgSyn
52 import Unique
53 import UniqSet
54 import Outputable
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   = CgIdInfo    
77         { cg_id :: Id   -- Id that this is the info for
78                         -- Can differ from the Id at occurrence sites by 
79                         -- virtue of being externalised, for splittable C
80         , cg_rep :: CgRep
81         , cg_vol :: VolatileLoc
82         , cg_stb :: StableLoc
83         , cg_lf  :: LambdaFormInfo }
84
85 mkCgIdInfo id vol stb lf
86   = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, 
87                cg_lf = lf, cg_rep = idCgRep id }
88
89 voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
90                          , cg_stb = VoidLoc, cg_lf = mkLFArgument id
91                          , cg_rep = VoidArg }
92         -- Used just for VoidRep things
93
94 data VolatileLoc        -- These locations die across a call
95   = NoVolatileLoc
96   | RegLoc      CmmReg             -- In one of the registers (global or local)
97   | VirHpLoc    VirtualHpOffset  -- Hp+offset (address of closure)
98   | VirNodeLoc  VirtualHpOffset  -- Cts of offset indirect from Node
99                                    -- ie *(Node+offset)
100 \end{code}
101
102 @StableLoc@ encodes where an Id can be found, used by
103 the @CgBindings@ environment in @CgBindery@.
104
105 \begin{code}
106 data StableLoc
107   = NoStableLoc
108
109   | VirStkLoc   VirtualSpOffset         -- The thing is held in this
110                                         -- stack slot
111
112   | VirStkLNE   VirtualSpOffset         -- A let-no-escape thing; the
113                                         -- value is this stack pointer
114                                         -- (as opposed to the contents of the slot)
115
116   | StableLoc   CmmExpr
117   | VoidLoc     -- Used only for VoidRep variables.  They never need to
118                 -- be saved, so it makes sense to treat treat them as
119                 -- having a stable location
120 \end{code}
121
122 \begin{code}
123 instance Outputable CgIdInfo where
124   ppr (CgIdInfo id rep vol stb lf)
125     = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
126
127 instance Outputable VolatileLoc where
128   ppr NoVolatileLoc = empty
129   ppr (RegLoc r)     = ptext SLIT("reg") <+> ppr r
130   ppr (VirHpLoc v)   = ptext SLIT("vh")  <+> ppr v
131   ppr (VirNodeLoc v) = ptext SLIT("vn")  <+> ppr v
132
133 instance Outputable StableLoc where
134   ppr NoStableLoc   = empty
135   ppr VoidLoc       = ptext SLIT("void")
136   ppr (VirStkLoc v) = ptext SLIT("vs")    <+> ppr v
137   ppr (VirStkLNE v) = ptext SLIT("lne")    <+> ppr v
138   ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
139 \end{code}
140
141 %************************************************************************
142 %*                                                                      *
143 \subsection[Bindery-idInfo]{Manipulating IdInfo}
144 %*                                                                      *
145 %************************************************************************
146
147 \begin{code}
148 stableIdInfo id amode   lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
149 heapIdInfo id offset    lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
150 letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
151 stackIdInfo id sp       lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
152 nodeIdInfo id offset    lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
153 regIdInfo id reg        lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
154
155 idInfoToAmode :: CgIdInfo -> FCode CmmExpr
156 idInfoToAmode info
157   = case cg_vol info of {
158       RegLoc reg        -> returnFC (CmmReg reg) ;
159       VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
160       VirHpLoc hp_off   -> getHpRelOffset hp_off ;
161       NoVolatileLoc -> 
162
163     case cg_stb info of
164       StableLoc amode  -> returnFC amode
165       VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
166                              ; return (CmmLoad sp_rel mach_rep) }
167
168       VirStkLNE sp_off -> getSpRelOffset sp_off
169
170       VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
171                 -- We return a 'bottom' amode, rather than panicing now
172                 -- In this way getArgAmode returns a pair of (VoidArg, bottom)
173                 -- and that's exactly what we want
174
175       NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
176     }
177   where
178     mach_rep = argMachRep (cg_rep info)
179
180 cgIdInfoId :: CgIdInfo -> Id
181 cgIdInfoId = cg_id 
182
183 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
184 cgIdInfoLF = cg_lf
185
186 cgIdInfoArgRep :: CgIdInfo -> CgRep
187 cgIdInfoArgRep = cg_rep
188
189 maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
190 maybeLetNoEscape other                                    = Nothing
191 \end{code}
192
193 %************************************************************************
194 %*                                                                      *
195 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
196 %*                                                                      *
197 %************************************************************************
198
199 .There are three basic routines, for adding (@addBindC@), modifying
200 (@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
201
202 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
203 The name should not already be bound. (nice ASSERT, eh?)
204
205 \begin{code}
206 addBindC :: Id -> CgIdInfo -> Code
207 addBindC name stuff_to_bind = do
208         binds <- getBinds
209         setBinds $ extendVarEnv binds name stuff_to_bind
210
211 addBindsC :: [(Id, CgIdInfo)] -> Code
212 addBindsC new_bindings = do
213         binds <- getBinds
214         let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
215                               binds
216                               new_bindings
217         setBinds new_binds
218
219 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
220 modifyBindC name mangle_fn = do
221         binds <- getBinds
222         setBinds $ modifyVarEnv mangle_fn binds name
223
224 getCgIdInfo :: Id -> FCode CgIdInfo
225 getCgIdInfo id
226   = do  {       -- Try local bindings first
227         ; local_binds  <- getBinds
228         ; case lookupVarEnv local_binds id of {
229             Just info -> return info ;
230             Nothing   -> do
231
232         {       -- Try top-level bindings
233           static_binds <- getStaticBinds
234         ; case lookupVarEnv static_binds id of {
235             Just info -> return info ;
236             Nothing   ->
237
238                 -- Should be imported; make up a CgIdInfo for it
239         let 
240             name = idName id
241         in
242         if isExternalName name then do
243             this_pkg <- getThisPackage
244             let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name))
245             return (stableIdInfo id ext_lbl (mkLFImported id))
246         else
247         if isVoidArg (idCgRep id) then
248                 -- Void things are never in the environment
249             return (voidIdInfo id)
250         else
251         -- Bug  
252         cgLookupPanic id
253         }}}}
254     
255                         
256 cgLookupPanic :: Id -> FCode a
257 cgLookupPanic id
258   = do  static_binds <- getStaticBinds
259         local_binds <- getBinds
260         srt <- getSRTLabel
261         pprPanic "cgPanic"
262                 (vcat [ppr id,
263                 ptext SLIT("static binds for:"),
264                 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
265                 ptext SLIT("local binds for:"),
266                 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
267                 ptext SLIT("SRT label") <+> pprCLabel srt
268               ])
269 \end{code}
270
271 %************************************************************************
272 %*                                                                      *
273 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
274 %*                                                                      *
275 %************************************************************************
276
277 We sometimes want to nuke all the volatile bindings; we must be sure
278 we don't leave any (NoVolatile, NoStable) binds around...
279
280 \begin{code}
281 nukeVolatileBinds :: CgBindings -> CgBindings
282 nukeVolatileBinds binds
283   = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
284   where
285     keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
286     keep_if_stable info acc
287       = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
288 \end{code}
289
290
291 %************************************************************************
292 %*                                                                      *
293 \subsection[lookup-interface]{Interface functions to looking up bindings}
294 %*                                                                      *
295 %************************************************************************
296
297 \begin{code}
298 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
299 getCAddrModeIfVolatile id
300   = do  { info <- getCgIdInfo id
301         ; case cg_stb info of
302                 NoStableLoc -> do -- Aha!  So it is volatile!
303                         amode <- idInfoToAmode info
304                         return $ Just amode
305                 a_stable_loc -> return Nothing }
306 \end{code}
307
308 @getVolatileRegs@ gets a set of live variables, and returns a list of
309 all registers on which these variables depend.  These are the regs
310 which must be saved and restored across any C calls.  If a variable is
311 both in a volatile location (depending on a register) {\em and} a
312 stable one (notably, on the stack), we modify the current bindings to
313 forget the volatile one.
314
315 \begin{code}
316 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
317
318 getVolatileRegs vars = do
319   do    { stuff <- mapFCs snaffle_it (varSetElems vars)
320         ; returnFC $ catMaybes stuff }
321   where
322     snaffle_it var = do
323         { info <- getCgIdInfo var 
324         ; let
325                 -- commoned-up code...
326              consider_reg reg
327                 =       -- We assume that all regs can die across C calls
328                         -- We leave it to the save-macros to decide which
329                         -- regs *really* need to be saved.
330                   case cg_stb info of
331                         NoStableLoc     -> returnFC (Just reg) -- got one!
332                         is_a_stable_loc -> do
333                                 { -- has both volatile & stable locations;
334                                   -- force it to rely on the stable location
335                                   modifyBindC var nuke_vol_bind 
336                                 ; return Nothing }
337
338         ; case cg_vol info of
339             RegLoc (CmmGlobal reg) -> consider_reg reg
340             VirNodeLoc _           -> consider_reg node
341             other_loc              -> returnFC Nothing  -- Local registers
342         }
343
344     nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
345 \end{code}
346
347 \begin{code}
348 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
349 getArgAmode (StgVarArg var) 
350   = do  { info <- getCgIdInfo var
351         ; amode <- idInfoToAmode info
352         ; return (cgIdInfoArgRep info, amode ) }
353
354 getArgAmode (StgLitArg lit) 
355   = do  { cmm_lit <- cgLit lit
356         ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
357
358 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
359
360 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
361 getArgAmodes [] = returnFC []
362 getArgAmodes (atom:atoms)
363   | isStgTypeArg atom = getArgAmodes atoms
364   | otherwise         = do { amode  <- getArgAmode  atom 
365                            ; amodes <- getArgAmodes atoms
366                            ; return ( amode : amodes ) }
367 \end{code}
368
369 %************************************************************************
370 %*                                                                      *
371 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
372 %*                                                                      *
373 %************************************************************************
374
375 \begin{code}
376 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
377 bindArgsToStack args
378   = mapCs bind args
379   where
380     bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
381
382 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
383 bindArgsToRegs args
384   = mapCs bind args
385   where
386     bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
387
388 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
389 bindNewToNode id offset lf_info
390   = addBindC id (nodeIdInfo id offset lf_info)
391
392 -- Create a new temporary whose unique is that in the id,
393 -- bind the id to it, and return the addressing mode for the
394 -- temporary.
395 bindNewToTemp :: Id -> FCode LocalReg
396 bindNewToTemp id
397   = do  addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
398         return temp_reg
399   where
400     uniq     = getUnique id
401     temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
402     kind     = if isFollowableArg (idCgRep id)
403                then KindPtr
404                else KindNonPtr
405     lf_info  = mkLFArgument id  -- Always used of things we
406                                 -- know nothing about
407
408 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
409 bindNewToReg name reg lf_info
410   = addBindC name info
411   where
412     info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
413 \end{code}
414
415 \begin{code}
416 rebindToStack :: Id -> VirtualSpOffset -> Code
417 rebindToStack name offset
418   = modifyBindC name replace_stable_fn
419   where
420     replace_stable_fn info = info { cg_stb = VirStkLoc offset }
421 \end{code}
422
423 %************************************************************************
424 %*                                                                      *
425 \subsection[CgMonad-deadslots]{Finding dead stack slots}
426 %*                                                                      *
427 %************************************************************************
428
429 nukeDeadBindings does the following:
430
431       - Removes all bindings from the environment other than those
432         for variables in the argument to nukeDeadBindings.
433       - Collects any stack slots so freed, and returns them to the  stack free
434         list.
435       - Moves the virtual stack pointer to point to the topmost used
436         stack locations.
437
438 You can have multi-word slots on the stack (where a Double# used to
439 be, for instance); if dead, such a slot will be reported as *several*
440 offsets (one per word).
441
442 Probably *naughty* to look inside monad...
443
444 \begin{code}
445 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
446                  -> Code
447 nukeDeadBindings live_vars = do
448         binds <- getBinds
449         let (dead_stk_slots, bs') =
450                 dead_slots live_vars 
451                         [] []
452                         [ (cg_id b, b) | b <- varEnvElts binds ]
453         setBinds $ mkVarEnv bs'
454         freeStackSlots dead_stk_slots
455 \end{code}
456
457 Several boring auxiliary functions to do the dirty work.
458
459 \begin{code}
460 dead_slots :: StgLiveVars
461            -> [(Id,CgIdInfo)]
462            -> [VirtualSpOffset]
463            -> [(Id,CgIdInfo)]
464            -> ([VirtualSpOffset], [(Id,CgIdInfo)])
465
466 -- dead_slots carries accumulating parameters for
467 --      filtered bindings, dead slots
468 dead_slots live_vars fbs ds []
469   = (ds, reverse fbs) -- Finished; rm the dups, if any
470
471 dead_slots live_vars fbs ds ((v,i):bs)
472   | v `elementOfUniqSet` live_vars
473     = dead_slots live_vars ((v,i):fbs) ds bs
474           -- Live, so don't record it in dead slots
475           -- Instead keep it in the filtered bindings
476
477   | otherwise
478     = case cg_stb i of
479         VirStkLoc offset
480          | size > 0
481          -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
482
483         _ -> dead_slots live_vars fbs ds bs
484   where
485     size :: WordOff
486     size = cgRepSizeW (cg_rep i)
487 \end{code}
488
489 \begin{code}
490 getLiveStackSlots :: FCode [VirtualSpOffset]
491 -- Return the offsets of slots in stack containig live pointers
492 getLiveStackSlots 
493   = do  { binds <- getBinds
494         ; return [off | CgIdInfo { cg_stb = VirStkLoc off, 
495                                    cg_rep = rep } <- varEnvElts binds, 
496                         isFollowableArg rep] }
497 \end{code}
498
499 \begin{code}
500 getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
501 getLiveStackBindings
502   = do { binds <- getBinds
503        ; return [(off, bind) |
504                  bind <- varEnvElts binds,
505                  CgIdInfo { cg_stb = VirStkLoc off,
506                             cg_rep = rep} <- [bind],
507                  isFollowableArg rep] }
508 \end{code}