[project @ 2002-12-11 15:36:20 by simonmar]
[ghc-hetmet.git] / ghc / compiler / codeGen / CgBindery.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[CgBindery]{Utility functions related to doing @CgBindings@}
5
6 \begin{code}
7 module CgBindery (
8         CgBindings, CgIdInfo,
9         StableLoc, VolatileLoc,
10
11         stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
12         letNoEscapeIdInfo, idInfoToAmode,
13
14         addBindC, addBindsC,
15
16         nukeVolatileBinds,
17         nukeDeadBindings,
18
19         bindNewToStack,  rebindToStack,
20         bindNewToNode, bindNewToReg, bindArgsToRegs,
21         bindNewToTemp, bindNewPrimToAmode,
22         getArgAmode, getArgAmodes,
23         getCAddrModeAndInfo, getCAddrMode,
24         getCAddrModeIfVolatile, getVolatileRegs,
25
26         buildContLivenessMask
27     ) where
28
29 #include "HsVersions.h"
30
31 import AbsCSyn
32 import CgMonad
33
34 import CgUsages         ( getHpRelOffset, getSpRelOffset, getRealSp )
35 import CgStackery       ( freeStackSlots, getStackFrame )
36 import CLabel           ( mkClosureLabel,
37                           mkBitmapLabel, pprCLabel )
38 import ClosureInfo      ( mkLFImported, mkLFArgument, LambdaFormInfo )
39 import BitSet
40 import PrimRep          ( isFollowableRep, getPrimRepSize )
41 import Id               ( Id, idPrimRep, idType )
42 import Type             ( typePrimRep )
43 import VarEnv
44 import VarSet           ( varSetElems )
45 import Literal          ( Literal )
46 import Maybes           ( catMaybes, maybeToBool, seqMaybe )
47 import Name             ( Name, isInternalName, NamedThing(..) )
48 #ifdef DEBUG
49 import PprAbsC          ( pprAmode )
50 #endif
51 import PrimRep          ( PrimRep(..) )
52 import StgSyn           ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
53 import Unique           ( Unique, Uniquable(..) )
54 import UniqSet          ( elementOfUniqSet )
55 import Util             ( zipWithEqual, sortLt )
56 import Outputable
57 \end{code}
58
59
60 %************************************************************************
61 %*                                                                      *
62 \subsection[Bindery-datatypes]{Data types}
63 %*                                                                      *
64 %************************************************************************
65
66 @(CgBinding a b)@ is a type of finite maps from a to b.
67
68 The assumption used to be that @lookupCgBind@ must get exactly one
69 match.  This is {\em completely wrong} in the case of compiling
70 letrecs (where knot-tying is used).  An initial binding is fed in (and
71 never evaluated); eventually, a correct binding is put into the
72 environment.  So there can be two bindings for a given name.
73
74 \begin{code}
75 type CgBindings = IdEnv CgIdInfo
76
77 data CgIdInfo
78   = MkCgIdInfo  Id      -- Id that this is the info for
79                 VolatileLoc
80                 StableLoc
81                 LambdaFormInfo
82
83 data VolatileLoc
84   = NoVolatileLoc
85   | TempVarLoc  Unique
86
87   | RegLoc      MagicId                 -- in one of the magic registers
88                                         -- (probably {Int,Float,Char,etc}Reg)
89
90   | VirHpLoc    VirtualHeapOffset       -- Hp+offset (address of closure)
91
92   | VirNodeLoc  VirtualHeapOffset       -- Cts of offset indirect from Node
93                                         -- ie *(Node+offset)
94 \end{code}
95
96 @StableLoc@ encodes where an Id can be found, used by
97 the @CgBindings@ environment in @CgBindery@.
98
99 \begin{code}
100 data StableLoc
101   = NoStableLoc
102   | VirStkLoc           VirtualSpOffset
103   | LitLoc              Literal
104   | StableAmodeLoc      CAddrMode
105
106 -- these are so StableLoc can be abstract:
107
108 maybeStkLoc (VirStkLoc offset) = Just offset
109 maybeStkLoc _                  = Nothing
110 \end{code}
111
112 %************************************************************************
113 %*                                                                      *
114 \subsection[Bindery-idInfo]{Manipulating IdInfo}
115 %*                                                                      *
116 %************************************************************************
117
118 \begin{code}
119 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
120 heapIdInfo i offset       lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
121 tempIdInfo i uniq         lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
122
123 letNoEscapeIdInfo i sp lf_info
124   = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
125
126 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
127
128 newTempAmodeAndIdInfo name lf_info
129   = (temp_amode, temp_idinfo)
130   where
131     uniq        = getUnique name
132     temp_amode  = CTemp uniq (idPrimRep name)
133     temp_idinfo = tempIdInfo name uniq lf_info
134
135 idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
136 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
137
138 idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
139
140 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc   = returnFC (CTemp uniq kind)
141 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc   = returnFC (CReg magic_id)
142
143 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit)           = returnFC (CLit lit)
144 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
145
146 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
147   = returnFC (CVal (nodeRel nd_off) kind)
148     -- Virtual offsets from Node increase into the closures,
149     -- and so do Node-relative offsets (which we want in the CVal),
150     -- so there is no mucking about to do to the offset.
151
152 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
153   = getHpRelOffset hp_off `thenFC` \ rel_hp ->
154     returnFC (CAddr rel_hp)
155
156 idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
157   = getSpRelOffset i `thenFC` \ rel_sp ->
158     returnFC (CVal rel_sp kind)
159
160 #ifdef DEBUG
161 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
162 #endif
163 \end{code}
164
165 %************************************************************************
166 %*                                                                      *
167 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
168 %*                                                                      *
169 %************************************************************************
170
171 There are three basic routines, for adding (@addBindC@), modifying
172 (@modifyBindC@) and looking up (@lookupBindC@) bindings.
173
174 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
175 The name should not already be bound. (nice ASSERT, eh?)
176
177 \begin{code}
178 addBindC :: Id -> CgIdInfo -> Code
179 addBindC name stuff_to_bind = do
180         binds <- getBinds
181         setBinds $ extendVarEnv binds name stuff_to_bind
182
183 addBindsC :: [(Id, CgIdInfo)] -> Code
184 addBindsC new_bindings = do
185         binds <- getBinds
186         let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
187                 binds
188                 new_bindings
189         setBinds new_binds
190
191 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
192 modifyBindC name mangle_fn = do
193         binds <- getBinds
194         setBinds $ modifyVarEnv mangle_fn binds name
195
196 lookupBindC :: Id -> FCode CgIdInfo
197 lookupBindC id = do maybe_info <- lookupBindC_maybe id
198                     case maybe_info of
199                       Just info -> return info
200                       Nothing   -> cgLookupPanic id
201
202 lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo)
203 lookupBindC_maybe id
204   = do  static_binds <- getStaticBinds
205         local_binds  <- getBinds
206         return (lookupVarEnv local_binds id
207                         `seqMaybe`
208                 lookupVarEnv static_binds id)
209                         
210 cgLookupPanic :: Id -> FCode a
211 cgLookupPanic id
212   = do  static_binds <- getStaticBinds
213         local_binds <- getBinds
214         srt <- getSRTLabel
215         pprPanic "cgPanic"
216                 (vcat [ppr id,
217                 ptext SLIT("static binds for:"),
218                 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
219                 ptext SLIT("local binds for:"),
220                 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
221                 ptext SLIT("SRT label") <+> pprCLabel srt
222               ])
223 \end{code}
224
225 %************************************************************************
226 %*                                                                      *
227 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
228 %*                                                                      *
229 %************************************************************************
230
231 We sometimes want to nuke all the volatile bindings; we must be sure
232 we don't leave any (NoVolatile, NoStable) binds around...
233
234 \begin{code}
235 nukeVolatileBinds :: CgBindings -> CgBindings
236 nukeVolatileBinds binds
237   = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
238   where
239     keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
240     keep_if_stable (MkCgIdInfo i _ stable_loc  entry_info) acc
241       = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
242 \end{code}
243
244
245 %************************************************************************
246 %*                                                                      *
247 \subsection[lookup-interface]{Interface functions to looking up bindings}
248 %*                                                                      *
249 %************************************************************************
250
251 I {\em think} all looking-up is done through @getCAddrMode(s)@.
252
253 \begin{code}
254 getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
255
256 getCAddrModeAndInfo id
257   = do
258         maybe_cg_id_info <- lookupBindC_maybe id
259         case maybe_cg_id_info of
260
261                 -- Nothing => not in the environment, so should be imported
262           Nothing | isInternalName name -> cgLookupPanic id
263                   | otherwise        -> returnFC (id, global_amode, mkLFImported id)
264
265           Just (MkCgIdInfo id' volatile_loc stable_loc lf_info)
266                   -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
267                         return (id', amode, lf_info)
268   where
269     name = getName id
270     global_amode = CLbl (mkClosureLabel name) kind
271     kind = idPrimRep id
272
273 getCAddrMode :: Id -> FCode CAddrMode
274 getCAddrMode name = do
275         (_, amode, _) <- getCAddrModeAndInfo name
276         return amode
277 \end{code}
278
279 \begin{code}
280 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
281 getCAddrModeIfVolatile name
282 --  | toplevelishId name = returnFC Nothing
283 --  | otherwise
284         = do
285         (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
286         case stable_loc of
287                 NoStableLoc -> do -- Aha!  So it is volatile!
288                         amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
289                         return $ Just amode
290                 a_stable_loc -> return Nothing
291 \end{code}
292
293 @getVolatileRegs@ gets a set of live variables, and returns a list of
294 all registers on which these variables depend.  These are the regs
295 which must be saved and restored across any C calls.  If a variable is
296 both in a volatile location (depending on a register) {\em and} a
297 stable one (notably, on the stack), we modify the current bindings to
298 forget the volatile one.
299
300 \begin{code}
301 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
302
303 getVolatileRegs vars = do
304         stuff <- mapFCs snaffle_it (varSetElems vars)
305         returnFC $ catMaybes stuff
306         where
307         snaffle_it var = do
308                 (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var 
309                 let
310                 -- commoned-up code...
311                         consider_reg reg =
312                                 if not (isVolatileReg reg) then
313                                 -- Potentially dies across C calls
314                                 -- For now, that's everything; we leave
315                                 -- it to the save-macros to decide which
316                                 -- regs *really* need to be saved.
317                                         returnFC Nothing
318                                 else
319                                         case stable_loc of
320                                                 NoStableLoc -> returnFC (Just reg) -- got one!
321                                                 is_a_stable_loc -> do
322                                                         -- has both volatile & stable locations;
323                                                         -- force it to rely on the stable location
324                                                         modifyBindC var nuke_vol_bind 
325                                                         return Nothing
326                         in
327                         case volatile_loc of
328                                 RegLoc reg   -> consider_reg reg
329                                 VirNodeLoc _ -> consider_reg node
330                                 non_reg_loc  -> returnFC Nothing
331
332         nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
333                 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
334 \end{code}
335
336 \begin{code}
337 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
338 getArgAmodes [] = returnFC []
339 getArgAmodes (atom:atoms)
340         | isStgTypeArg atom 
341         = getArgAmodes atoms
342         | otherwise = do
343                 amode <- getArgAmode  atom 
344                 amodes <- getArgAmodes atoms
345                 return ( amode : amodes )
346
347 getArgAmode :: StgArg -> FCode CAddrMode
348
349 getArgAmode (StgVarArg var) = getCAddrMode var          -- The common case
350 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
351 \end{code}
352
353 %************************************************************************
354 %*                                                                      *
355 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
356 %*                                                                      *
357 %************************************************************************
358
359 \begin{code}
360 bindNewToStack :: (Id, VirtualSpOffset) -> Code
361 bindNewToStack (name, offset)
362   = addBindC name info
363   where
364     info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name)
365
366 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
367 bindNewToNode name offset lf_info
368   = addBindC name info
369   where
370     info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
371
372 -- Create a new temporary whose unique is that in the id,
373 -- bind the id to it, and return the addressing mode for the
374 -- temporary.
375 bindNewToTemp :: Id -> FCode CAddrMode
376 bindNewToTemp name
377   = let (temp_amode, id_info) = newTempAmodeAndIdInfo name (mkLFArgument name)
378                 -- This is used only for things we don't know
379                 -- anything about; values returned by a case statement,
380                 -- for example.
381     in do
382                 addBindC name id_info
383                 return temp_amode
384
385 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
386 bindNewToReg name magic_id lf_info
387   = addBindC name info
388   where
389     info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
390
391 bindArgsToRegs :: [Id] -> [MagicId] -> Code
392 bindArgsToRegs args regs
393   = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
394   where
395     arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
396 \end{code}
397
398 @bindNewPrimToAmode@ works only for certain addressing modes.  Making
399 this work for stack offsets is non-trivial (virt vs. real stack offset
400 difficulties).
401
402 \begin{code}
403 bindNewPrimToAmode :: Id -> CAddrMode -> Code
404 bindNewPrimToAmode name (CReg reg) 
405   = bindNewToReg name reg (panic "bindNewPrimToAmode")
406
407 bindNewPrimToAmode name (CTemp uniq kind)
408   = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
409
410 #ifdef DEBUG
411 bindNewPrimToAmode name amode
412   = pprPanic "bindNew...:" (pprAmode amode)
413 #endif
414 \end{code}
415
416 \begin{code}
417 rebindToStack :: Id -> VirtualSpOffset -> Code
418 rebindToStack name offset
419   = modifyBindC name replace_stable_fn
420   where
421     replace_stable_fn (MkCgIdInfo i vol stab einfo)
422       = MkCgIdInfo i vol (VirStkLoc offset) einfo
423 \end{code}
424
425 %************************************************************************
426 %*                                                                      *
427 \subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
428 %*                                                                      *
429 %************************************************************************
430
431 There are four kinds of things on the stack:
432
433         - pointer variables (bound in the environment)
434         - non-pointer variables (boudn in the environment)
435         - free slots (recorded in the stack free list)
436         - non-pointer data slots (recorded in the stack free list)
437
438 We build up a bitmap of non-pointer slots by looking down the
439 environment for all the non-pointer variables, and merging this with
440 the slots recorded in the stack free list.
441
442 There's a bit of a hack here to do with update frames: since nothing
443 is recorded in either the environment or the stack free list for an
444 update frame, the code below defaults to assuming the slots taken up
445 by an update frame contain pointers.  Furthermore, update frames are
446 always in slots 0-2 at the bottom of the stack.  The bitmap will
447 therefore end at slot 3, which is what we want (the update frame info
448 pointer has its own bitmap to describe the update frame).
449
450 \begin{code}
451 buildLivenessMask 
452         :: VirtualSpOffset      -- offset from which the bitmap should start
453         -> FCode LivenessMask   -- mask for free/unlifted slots
454
455 buildLivenessMask sp = do {
456
457     -- find all unboxed stack-resident ids
458     binds <- getBinds;
459     ((vsp, _, free, _, _), heap_usage) <- getUsage;
460     
461     let { 
462         unboxed_slots = 
463             [ (ofs, size) | 
464             (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
465             let rep = idPrimRep id; size = getPrimRepSize rep,
466             not (isFollowableRep rep),
467             size > 0
468             ];
469       
470     -- flatten this list into a list of unboxed stack slots
471         flatten_slots = sortLt (<) 
472             (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
473                   unboxed_slots);
474     
475     -- merge in the free slots
476         all_slots = mergeSlots flatten_slots (map fst free) ++ 
477                     if vsp < sp then [vsp+1 .. sp] else [];
478
479     -- recalibrate the list to be sp-relative
480         rel_slots = reverse (map (sp-) all_slots);
481     };
482
483     ASSERT(all (>=0) rel_slots && rel_slots == sortLt (<) rel_slots)
484      return (listToLivenessMask rel_slots)
485   }
486
487
488 mergeSlots :: [Int] -> [Int] -> [Int]
489 mergeSlots cs [] = cs
490 mergeSlots [] ns = ns
491 mergeSlots (c:cs) (n:ns)
492  = if c < n then
493         c : mergeSlots cs (n:ns)
494    else if c > n then
495         n : mergeSlots (c:cs) ns
496    else
497         panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
498
499 listToLivenessMask :: [Int] -> LivenessMask
500 listToLivenessMask []    = []
501 listToLivenessMask slots = 
502    mkBS this : listToLivenessMask (map (\x -> x-32) rest)
503    where (this,rest) = span (<32) slots
504 \end{code}
505
506 In a continuation, we want a liveness mask that starts from just after
507 the return address, which is on the stack at realSp.
508
509 \begin{code}
510 buildContLivenessMask :: Name -> FCode Liveness
511 buildContLivenessMask name = do
512         realSp <- getRealSp
513         mask <- buildLivenessMask (realSp-1)
514
515         let lbl = mkBitmapLabel name
516
517         -- realSp points to the frame-header for the current stack frame,
518         -- and the end of this frame is frame_sp.  The size is therefore
519         -- realSp - frame_sp - 1 (subtract one for the frame-header).
520         frame_sp <- getStackFrame
521         let liveness = Liveness lbl (realSp-1-frame_sp) mask
522
523         absC (CBitmap liveness)
524         return liveness
525 \end{code}
526
527 %************************************************************************
528 %*                                                                      *
529 \subsection[CgMonad-deadslots]{Finding dead stack slots}
530 %*                                                                      *
531 %************************************************************************
532
533 nukeDeadBindings does the following:
534
535       - Removes all bindings from the environment other than those
536         for variables in the argument to nukeDeadBindings.
537       - Collects any stack slots so freed, and returns them to the  stack free
538         list.
539       - Moves the virtual stack pointer to point to the topmost used
540         stack locations.
541
542 You can have multi-word slots on the stack (where a Double# used to
543 be, for instance); if dead, such a slot will be reported as *several*
544 offsets (one per word).
545
546 Probably *naughty* to look inside monad...
547
548 \begin{code}
549 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
550                  -> Code
551 nukeDeadBindings live_vars = do
552         binds <- getBinds
553         let (dead_stk_slots, bs') =
554                 dead_slots live_vars 
555                         [] []
556                         [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
557         setBinds $ mkVarEnv bs'
558         freeStackSlots dead_stk_slots
559 \end{code}
560
561 Several boring auxiliary functions to do the dirty work.
562
563 \begin{code}
564 dead_slots :: StgLiveVars
565            -> [(Id,CgIdInfo)]
566            -> [VirtualSpOffset]
567            -> [(Id,CgIdInfo)]
568            -> ([VirtualSpOffset], [(Id,CgIdInfo)])
569
570 -- dead_slots carries accumulating parameters for
571 --      filtered bindings, dead slots
572 dead_slots live_vars fbs ds []
573   = (ds, reverse fbs) -- Finished; rm the dups, if any
574
575 dead_slots live_vars fbs ds ((v,i):bs)
576   | v `elementOfUniqSet` live_vars
577     = dead_slots live_vars ((v,i):fbs) ds bs
578           -- Live, so don't record it in dead slots
579           -- Instead keep it in the filtered bindings
580
581   | otherwise
582     = case i of
583         MkCgIdInfo _ _ stable_loc _
584          | is_stk_loc && size > 0 ->
585            dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
586          where
587           maybe_stk_loc = maybeStkLoc stable_loc
588           is_stk_loc    = maybeToBool maybe_stk_loc
589           (Just offset) = maybe_stk_loc
590
591         _ -> dead_slots live_vars fbs ds bs
592   where
593
594     size :: Int
595     size = (getPrimRepSize . typePrimRep . idType) v
596
597 \end{code}