[project @ 2000-12-06 13:19:49 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         buildLivenessMask, 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 )
36 import CLabel           ( mkClosureLabel,
37                           mkBitmapLabel, pprCLabel )
38 import ClosureInfo      ( mkLFImported, mkLFArgument, LambdaFormInfo )
39 import BitSet           ( mkBS, emptyBS )
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 )
47 import Name             ( isLocalName, 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 info_down (MkCgState absC binds usage)
180   = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
181
182 addBindsC :: [(Id, CgIdInfo)] -> Code
183 addBindsC new_bindings info_down (MkCgState absC binds usage)
184   = MkCgState absC new_binds usage
185   where
186     new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
187                       binds
188                       new_bindings
189
190 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
191 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
192   = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
193
194 lookupBindC :: Id -> FCode CgIdInfo
195 lookupBindC name info_down@(MkCgInfoDown _ static_binds srt ticky _)
196                  state@(MkCgState absC local_binds usage)
197   = (val, state)
198   where
199     val = case (lookupVarEnv local_binds name) of
200             Nothing     -> try_static
201             Just this   -> this
202
203     try_static = 
204       case (lookupVarEnv static_binds name) of
205         Just this -> this
206         Nothing
207           -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
208
209 cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
210 cgPanic doc info_down@(MkCgInfoDown _ static_binds srt ticky _)
211             state@(MkCgState absC local_binds usage)
212   = pprPanic "cgPanic"
213              (vcat [doc,
214                 ptext SLIT("static binds for:"),
215                 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
216                 ptext SLIT("local binds for:"),
217                 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
218                 ptext SLIT("SRT label") <+> pprCLabel srt
219               ])
220 \end{code}
221
222 %************************************************************************
223 %*                                                                      *
224 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
225 %*                                                                      *
226 %************************************************************************
227
228 We sometimes want to nuke all the volatile bindings; we must be sure
229 we don't leave any (NoVolatile, NoStable) binds around...
230
231 \begin{code}
232 nukeVolatileBinds :: CgBindings -> CgBindings
233 nukeVolatileBinds binds
234   = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
235   where
236     keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
237     keep_if_stable (MkCgIdInfo i _ stable_loc  entry_info) acc
238       = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
239 \end{code}
240
241
242 %************************************************************************
243 %*                                                                      *
244 \subsection[lookup-interface]{Interface functions to looking up bindings}
245 %*                                                                      *
246 %************************************************************************
247
248 I {\em think} all looking-up is done through @getCAddrMode(s)@.
249
250 \begin{code}
251 getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
252
253 getCAddrModeAndInfo id
254   | not (isLocalName name)
255   = returnFC (id, global_amode, mkLFImported id)
256         -- deals with imported or locally defined but externally visible ids
257         -- (CoreTidy makes all these into global names).
258
259   | otherwise = -- *might* be a nested defn: in any case, it's something whose
260                 -- definition we will know about...
261     lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) ->
262     idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
263     returnFC (id', amode, lf_info)
264   where
265     name = getName id
266     global_amode = CLbl (mkClosureLabel name) kind
267     kind = idPrimRep id
268
269 getCAddrMode :: Id -> FCode CAddrMode
270 getCAddrMode name
271   = getCAddrModeAndInfo name `thenFC` \ (_, amode, _) ->
272     returnFC amode
273 \end{code}
274
275 \begin{code}
276 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
277 getCAddrModeIfVolatile name
278 --  | toplevelishId name = returnFC Nothing
279 --  | otherwise
280   = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
281     case stable_loc of
282         NoStableLoc ->  -- Aha!  So it is volatile!
283             idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
284             returnFC (Just amode)
285
286         a_stable_loc -> returnFC Nothing
287 \end{code}
288
289 @getVolatileRegs@ gets a set of live variables, and returns a list of
290 all registers on which these variables depend.  These are the regs
291 which must be saved and restored across any C calls.  If a variable is
292 both in a volatile location (depending on a register) {\em and} a
293 stable one (notably, on the stack), we modify the current bindings to
294 forget the volatile one.
295
296 \begin{code}
297 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
298
299 getVolatileRegs vars
300   = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
301     returnFC (catMaybes stuff)
302   where
303     snaffle_it var
304       = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
305         let
306             -- commoned-up code...
307             consider_reg reg
308               = if not (isVolatileReg reg) then
309                         -- Potentially dies across C calls
310                         -- For now, that's everything; we leave
311                         -- it to the save-macros to decide which
312                         -- regs *really* need to be saved.
313                     returnFC Nothing
314                 else
315                     case stable_loc of
316                       NoStableLoc -> returnFC (Just reg) -- got one!
317                       is_a_stable_loc ->
318                         -- has both volatile & stable locations;
319                         -- force it to rely on the stable location
320                         modifyBindC var nuke_vol_bind `thenC`
321                         returnFC Nothing
322         in
323         case volatile_loc of
324           RegLoc reg   -> consider_reg reg
325           VirHpLoc _   -> consider_reg Hp
326           VirNodeLoc _ -> consider_reg node
327           non_reg_loc  -> returnFC Nothing
328
329     nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
330       = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
331 \end{code}
332
333 \begin{code}
334 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
335 getArgAmodes [] = returnFC []
336 getArgAmodes (atom:atoms)
337   | isStgTypeArg atom 
338   = getArgAmodes atoms
339   | otherwise
340   = getArgAmode  atom  `thenFC` \ amode ->
341     getArgAmodes atoms `thenFC` \ amodes ->
342     returnFC ( amode : amodes )
343
344 getArgAmode :: StgArg -> FCode CAddrMode
345
346 getArgAmode (StgVarArg var) = getCAddrMode var          -- The common case
347 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
348 \end{code}
349
350 %************************************************************************
351 %*                                                                      *
352 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
353 %*                                                                      *
354 %************************************************************************
355
356 \begin{code}
357 bindNewToStack :: (Id, VirtualSpOffset) -> Code
358 bindNewToStack (name, offset)
359   = addBindC name info
360   where
361     info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
362
363 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
364 bindNewToNode name offset lf_info
365   = addBindC name info
366   where
367     info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
368
369 -- Create a new temporary whose unique is that in the id,
370 -- bind the id to it, and return the addressing mode for the
371 -- temporary.
372 bindNewToTemp :: Id -> FCode CAddrMode
373 bindNewToTemp name
374   = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
375                 -- This is used only for things we don't know
376                 -- anything about; values returned by a case statement,
377                 -- for example.
378     in
379     addBindC name id_info       `thenC`
380     returnFC temp_amode
381
382 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
383 bindNewToReg name magic_id lf_info
384   = addBindC name info
385   where
386     info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
387
388 bindArgsToRegs :: [Id] -> [MagicId] -> Code
389 bindArgsToRegs args regs
390   = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
391   where
392     arg `bind` reg = bindNewToReg arg reg mkLFArgument
393 \end{code}
394
395 @bindNewPrimToAmode@ works only for certain addressing modes.  Making
396 this work for stack offsets is non-trivial (virt vs. real stack offset
397 difficulties).
398
399 \begin{code}
400 bindNewPrimToAmode :: Id -> CAddrMode -> Code
401 bindNewPrimToAmode name (CReg reg) 
402   = bindNewToReg name reg (panic "bindNewPrimToAmode")
403
404 bindNewPrimToAmode name (CTemp uniq kind)
405   = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
406
407 #ifdef DEBUG
408 bindNewPrimToAmode name amode
409   = pprPanic "bindNew...:" (pprAmode amode)
410 #endif
411 \end{code}
412
413 \begin{code}
414 rebindToStack :: Id -> VirtualSpOffset -> Code
415 rebindToStack name offset
416   = modifyBindC name replace_stable_fn
417   where
418     replace_stable_fn (MkCgIdInfo i vol stab einfo)
419       = MkCgIdInfo i vol (VirStkLoc offset) einfo
420 \end{code}
421
422 %************************************************************************
423 %*                                                                      *
424 \subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
425 %*                                                                      *
426 %************************************************************************
427
428 ToDo: remove the dependency on 32-bit words.
429
430 There are four kinds of things on the stack:
431
432         - pointer variables (bound in the environment)
433         - non-pointer variables (boudn in the environment)
434         - free slots (recorded in the stack free list)
435         - non-pointer data slots (recorded in the stack free list)
436
437 We build up a bitmap of non-pointer slots by looking down the
438 environment for all the non-pointer variables, and merging this with
439 the slots recorded in the stack free list.
440
441 There's a bit of a hack here to do with update frames: since nothing
442 is recorded in either the environment or the stack free list for an
443 update frame, the code below defaults to assuming the slots taken up
444 by an update frame contain pointers.  Furthermore, update frames are
445 always in slots 0-2 at the bottom of the stack.  The bitmap will
446 therefore end at slot 3, which is what we want (the update frame info
447 pointer has its own bitmap to describe the update frame).
448
449 \begin{code}
450 buildLivenessMask 
451         :: Unique               -- unique for for large bitmap label
452         -> VirtualSpOffset      -- offset from which the bitmap should start
453         -> FCode Liveness       -- mask for free/unlifted slots
454
455 buildLivenessMask uniq sp info_down
456         state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
457   = ASSERT(all (>=0) rel_slots) 
458     livenessToAbsC uniq liveness_mask info_down state 
459   where
460         -- find all unboxed stack-resident ids
461         unboxed_slots =                    
462           [ (ofs, size) | 
463                      (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
464                 let rep = idPrimRep id; size = getPrimRepSize rep,
465                 not (isFollowableRep rep),
466                 size > 0
467           ]
468
469         -- flatten this list into a list of unboxed stack slots
470         flatten_slots = sortLt (<) 
471                 (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
472                       unboxed_slots)
473
474         -- merge in the free slots
475         all_slots = mergeSlots flatten_slots (map fst free) ++ 
476                     if vsp < sp then [vsp+1 .. sp] else []
477
478         -- recalibrate the list to be sp-relative
479         rel_slots = reverse (map (sp-) all_slots)
480
481         -- build the bitmap
482         liveness_mask = listToLivenessMask rel_slots
483
484 mergeSlots :: [Int] -> [Int] -> [Int]
485 mergeSlots cs [] = cs
486 mergeSlots [] ns = ns
487 mergeSlots (c:cs) (n:ns)
488  = if c < n then
489         c : mergeSlots cs (n:ns)
490    else if c > n then
491         n : mergeSlots (c:cs) ns
492    else
493         panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
494
495 listToLivenessMask :: [Int] -> LivenessMask
496 listToLivenessMask []    = []
497 listToLivenessMask slots = 
498    mkBS this : listToLivenessMask (map (\x -> x-32) rest)
499    where (this,rest) = span (<32) slots
500
501 livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
502 livenessToAbsC uniq []    = returnFC (LvSmall emptyBS)
503 livenessToAbsC uniq [one] = returnFC (LvSmall one)
504 livenessToAbsC uniq many  = 
505         absC (CBitmap lbl many) `thenC`
506         returnFC (LvLarge lbl)
507   where lbl = mkBitmapLabel uniq
508 \end{code}
509
510 In a continuation, we want a liveness mask that starts from just after
511 the return address, which is on the stack at realSp.
512
513 \begin{code}
514 buildContLivenessMask
515         :: Unique
516         -> FCode Liveness
517 buildContLivenessMask uniq
518   = getRealSp  `thenFC` \ realSp ->
519     buildLivenessMask uniq (realSp-1)
520 \end{code}
521
522 %************************************************************************
523 %*                                                                      *
524 \subsection[CgMonad-deadslots]{Finding dead stack slots}
525 %*                                                                      *
526 %************************************************************************
527
528 nukeDeadBindings does the following:
529
530       - Removes all bindings from the environment other than those
531         for variables in the argument to nukeDeadBindings.
532       - Collects any stack slots so freed, and returns them to the  stack free
533         list.
534       - Moves the virtual stack pointer to point to the topmost used
535         stack locations.
536
537 You can have multi-word slots on the stack (where a Double# used to
538 be, for instance); if dead, such a slot will be reported as *several*
539 offsets (one per word).
540
541 Probably *naughty* to look inside monad...
542
543 \begin{code}
544 nukeDeadBindings :: StgLiveVars  -- All the *live* variables
545                  -> Code
546
547 nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
548   = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
549   where
550     (dead_stk_slots, bs')
551       = dead_slots live_vars
552                    [] []
553                    [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
554
555     extra_free = sortLt (<) dead_stk_slots
556 \end{code}
557
558 Several boring auxiliary functions to do the dirty work.
559
560 \begin{code}
561 dead_slots :: StgLiveVars
562            -> [(Id,CgIdInfo)]
563            -> [VirtualSpOffset]
564            -> [(Id,CgIdInfo)]
565            -> ([VirtualSpOffset], [(Id,CgIdInfo)])
566
567 -- dead_slots carries accumulating parameters for
568 --      filtered bindings, dead slots
569 dead_slots live_vars fbs ds []
570   = (ds, reverse fbs) -- Finished; rm the dups, if any
571
572 dead_slots live_vars fbs ds ((v,i):bs)
573   | v `elementOfUniqSet` live_vars
574     = dead_slots live_vars ((v,i):fbs) ds bs
575           -- Live, so don't record it in dead slots
576           -- Instead keep it in the filtered bindings
577
578   | otherwise
579     = case i of
580         MkCgIdInfo _ _ stable_loc _
581          | is_stk_loc && size > 0 ->
582            dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
583          where
584           maybe_stk_loc = maybeStkLoc stable_loc
585           is_stk_loc    = maybeToBool maybe_stk_loc
586           (Just offset) = maybe_stk_loc
587
588         _ -> dead_slots live_vars fbs ds bs
589   where
590
591     size :: Int
592     size = (getPrimRepSize . typePrimRep . idType) v
593
594 \end{code}