1 -----------------------------------------------------------------------------
5 -- The datatypes and functions here encapsulate the
6 -- calling and return conventions used by the code generator.
8 -- (c) The University of Glasgow 2004
10 -----------------------------------------------------------------------------
14 -- Argument descriptors
15 mkArgDescr, argDescrType,
18 isBigLiveness, buildContLiveness, mkRegLiveness,
19 smallLiveness, mkLivenessCLit,
21 -- Register assignment
22 assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
25 constructSlowCall, slowArgs, slowCallPattern,
28 CtrlReturnConvention(..),
34 #include "HsVersions.h"
36 import CgUtils ( emitRODataLits, mkWordCLit )
39 import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
40 mAX_Vanilla_REG, mAX_Float_REG,
41 mAX_Double_REG, mAX_Long_REG,
42 mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
43 mAX_Real_Double_REG, mAX_Real_Long_REG,
47 import ClosureInfo ( ArgDescr(..), Liveness(..) )
48 import CgStackery ( getSpRelOffset )
50 import MachOp ( wordRep )
51 import Cmm ( CmmExpr(..), GlobalReg(..), CmmLit(..), CmmReg(..), node )
52 import CmmUtils ( mkLblExpr )
54 import Maybes ( mapCatMaybes )
57 import TyCon ( TyCon, tyConFamilySize )
58 import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE,
59 mkBitmap, intsToReverseBitmap )
60 import Util ( isn'tIn, sortLe )
61 import StaticFlags ( opt_Unregisterised )
62 import FastString ( LitString )
67 -------------------------------------------------------------------------
69 -- Making argument descriptors
71 -- An argument descriptor describes the layout of args on the stack,
72 -- both for * GC (stack-layout) purposes, and
73 -- * saving/restoring registers when a heap-check fails
75 -- Void arguments aren't important, therefore (contrast constructSlowCall)
77 -------------------------------------------------------------------------
79 -- bring in ARG_P, ARG_N, etc.
80 #include "../includes/StgFun.h"
82 -------------------------
83 argDescrType :: ArgDescr -> Int
84 -- The "argument type" RTS field type
85 argDescrType (ArgSpec n) = n
86 argDescrType (ArgGen liveness)
87 | isBigLiveness liveness = ARG_GEN_BIG
91 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
93 = case stdPattern arg_reps of
94 Just spec_id -> return (ArgSpec spec_id)
95 Nothing -> do { liveness <- mkLiveness nm size bitmap
96 ; return (ArgGen liveness) }
98 arg_reps = filter nonVoidArg (map idCgRep args)
99 -- Getting rid of voids eases matching of standard patterns
101 bitmap = mkBitmap arg_bits
102 arg_bits = argBits arg_reps
103 size = length arg_bits
105 argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr
107 argBits (PtrArg : args) = False : argBits args
108 argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
110 stdPattern :: [CgRep] -> Maybe Int
111 stdPattern [] = Just ARG_NONE -- just void args, probably
113 stdPattern [PtrArg] = Just ARG_P
114 stdPattern [FloatArg] = Just ARG_F
115 stdPattern [DoubleArg] = Just ARG_D
116 stdPattern [LongArg] = Just ARG_L
117 stdPattern [NonPtrArg] = Just ARG_N
119 stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
120 stdPattern [NonPtrArg,PtrArg] = Just ARG_NP
121 stdPattern [PtrArg,NonPtrArg] = Just ARG_PN
122 stdPattern [PtrArg,PtrArg] = Just ARG_PP
124 stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
125 stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP
126 stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN
127 stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP
128 stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN
129 stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP
130 stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN
131 stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP
133 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP
134 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP
135 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
136 stdPattern other = Nothing
139 -------------------------------------------------------------------------
143 -------------------------------------------------------------------------
145 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
146 mkLiveness name size bits
147 | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
148 = do { let lbl = mkBitmapLabel name
149 ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
150 : map mkWordCLit bits)
151 ; return (BigLiveness lbl) }
153 | otherwise -- Bitmap fits in one word
155 small_bits = case bits of
157 [b] -> fromIntegral b
158 _ -> panic "livenessToAddrMode"
160 return (smallLiveness size small_bits)
162 smallLiveness :: Int -> StgWord -> Liveness
163 smallLiveness size small_bits = SmallLiveness bits
164 where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
167 isBigLiveness :: Liveness -> Bool
168 isBigLiveness (BigLiveness _) = True
169 isBigLiveness (SmallLiveness _) = False
172 mkLivenessCLit :: Liveness -> CmmLit
173 mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl
174 mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
177 -------------------------------------------------------------------------
179 -- Bitmap describing register liveness
180 -- across GC when doing a "generic" heap check
181 -- (a RET_DYN stack frame).
183 -- NB. Must agree with these macros (currently in StgMacros.h):
184 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
185 -------------------------------------------------------------------------
187 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
188 mkRegLiveness regs ptrs nptrs
189 = (fromIntegral nptrs `shiftL` 16) .|.
190 (fromIntegral ptrs `shiftL` 24) .|.
191 all_non_ptrs `xor` reg_bits regs
196 reg_bits ((id, VanillaReg i) : regs) | isFollowableArg (idCgRep id)
197 = (1 `shiftL` (i - 1)) .|. reg_bits regs
201 -------------------------------------------------------------------------
203 -- Pushing the arguments for a slow call
205 -------------------------------------------------------------------------
207 -- For a slow call, we must take a bunch of arguments and intersperse
208 -- some stg_ap_<pattern>_ret_info return addresses.
209 constructSlowCall :: [(CgRep,CmmExpr)] -> (CLabel, [(CgRep,CmmExpr)])
210 -- don't forget the zero case
214 stg_ap_0 = enterRtsRetLabel SLIT("stg_ap_0")
216 constructSlowCall amodes
217 = (stg_ap_pat, these ++ slowArgs rest)
219 stg_ap_pat = enterRtsRetLabel arg_pat
220 (arg_pat, these, rest) = matchSlowPattern amodes
222 enterRtsRetLabel arg_pat
223 | tablesNextToCode = mkRtsRetInfoLabel arg_pat
224 | otherwise = mkRtsRetLabel arg_pat
226 -- | 'slowArgs' takes a list of function arguments and prepares them for
227 -- pushing on the stack for "extra" arguments to a function which requires
228 -- fewer arguments than we currently have.
229 slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
231 slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
232 where (arg_pat, args, rest) = matchSlowPattern amodes
233 stg_ap_pat = mkRtsRetInfoLabel arg_pat
235 matchSlowPattern :: [(CgRep,CmmExpr)]
236 -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
237 matchSlowPattern amodes = (arg_pat, these, rest)
238 where (arg_pat, n) = slowCallPattern (map fst amodes)
239 (these, rest) = splitAt n amodes
241 -- These cases were found to cover about 99% of all slow calls:
242 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
243 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppppp"), 5)
244 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppp"), 4)
245 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_pppv"), 4)
246 slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppp"), 3)
247 slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_ppv"), 3)
248 slowCallPattern (PtrArg: PtrArg: _) = (SLIT("stg_ap_pp"), 2)
249 slowCallPattern (PtrArg: VoidArg: _) = (SLIT("stg_ap_pv"), 2)
250 slowCallPattern (PtrArg: _) = (SLIT("stg_ap_p"), 1)
251 slowCallPattern (VoidArg: _) = (SLIT("stg_ap_v"), 1)
252 slowCallPattern (NonPtrArg: _) = (SLIT("stg_ap_n"), 1)
253 slowCallPattern (FloatArg: _) = (SLIT("stg_ap_f"), 1)
254 slowCallPattern (DoubleArg: _) = (SLIT("stg_ap_d"), 1)
255 slowCallPattern (LongArg: _) = (SLIT("stg_ap_l"), 1)
256 slowCallPattern _ = panic "CgStackery.slowCallPattern"
258 -------------------------------------------------------------------------
260 -- Return conventions
262 -------------------------------------------------------------------------
264 -- A @CtrlReturnConvention@ says how {\em control} is returned.
266 data CtrlReturnConvention
267 = VectoredReturn Int -- size of the vector table (family size)
268 | UnvectoredReturn Int -- family size
270 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
271 ctrlReturnConvAlg tycon
272 = case (tyConFamilySize tycon) of
273 size -> -- we're supposed to know...
274 if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
277 UnvectoredReturn size
278 -- NB: unvectored returns Include size 0 (no constructors), so that
279 -- the following perverse code compiles (it crashed GHC in 5.02)
281 -- data T2 = T2 !T1 Int
282 -- The only value of type T1 is bottom, which never returns anyway.
284 dataReturnConvPrim :: CgRep -> CmmReg
285 dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1)
286 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
287 dataReturnConvPrim LongArg = CmmGlobal (LongReg 1)
288 dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1)
289 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
290 dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
293 -- getSequelAmode returns an amode which refers to an info table. The info
294 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
295 -- not to handle real code pointers, just in case we're compiling for
296 -- an unregisterised/untailcallish architecture, where info pointers and
297 -- code pointers aren't the same.
299 -- The OnStack case of sequelToAmode delivers an Amode which is only
300 -- valid just before the final control transfer, because it assumes
301 -- that Sp is pointing to the top word of the return address. This
302 -- seems unclean but there you go.
304 getSequelAmode :: FCode CmmExpr
306 = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
308 OnStack -> do { sp_rel <- getSpRelOffset virt_sp
309 ; returnFC (CmmLoad sp_rel wordRep) }
311 UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
312 CaseAlts lbl _ _ True -> returnFC (CmmLit (CmmLabel mkSeqInfoLabel))
313 CaseAlts lbl _ _ False -> returnFC (CmmLit (CmmLabel lbl))
316 -------------------------------------------------------------------------
318 -- Build a liveness mask for the current stack
320 -------------------------------------------------------------------------
322 -- There are four kinds of things on the stack:
324 -- - pointer variables (bound in the environment)
325 -- - non-pointer variables (boudn in the environment)
326 -- - free slots (recorded in the stack free list)
327 -- - non-pointer data slots (recorded in the stack free list)
329 -- We build up a bitmap of non-pointer slots by searching the environment
330 -- for all the pointer variables, and subtracting these from a bitmap
331 -- with initially all bits set (up to the size of the stack frame).
333 buildContLiveness :: Name -- Basis for label (only)
334 -> [VirtualSpOffset] -- Live stack slots
336 buildContLiveness name live_slots
337 = do { stk_usg <- getStkUsage
338 ; let StackUsage { realSp = real_sp,
339 frameSp = frame_sp } = stk_usg
341 start_sp :: VirtualSpOffset
342 start_sp = real_sp - retAddrSizeW
343 -- In a continuation, we want a liveness mask that
344 -- starts from just after the return address, which is
345 -- on the stack at real_sp.
347 frame_size :: WordOff
348 frame_size = start_sp - frame_sp
349 -- real_sp points to the frame-header for the current
350 -- stack frame, and the end of this frame is frame_sp.
351 -- The size is therefore real_sp - frame_sp - retAddrSizeW
352 -- (subtract one for the frame-header = return address).
354 rel_slots :: [WordOff]
355 rel_slots = sortLe (<=)
356 [ start_sp - ofs -- Get slots relative to top of frame
357 | ofs <- live_slots ]
359 bitmap = intsToReverseBitmap frame_size rel_slots
361 ; WARN( not (all (>=0) rel_slots),
362 ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
363 mkLiveness name frame_size bitmap }
366 -------------------------------------------------------------------------
368 -- Register assignment
370 -------------------------------------------------------------------------
372 -- How to assign registers for
374 -- 1) Calling a fast entry point.
375 -- 2) Returning an unboxed tuple.
376 -- 3) Invoking an out-of-line PrimOp.
378 -- Registers are assigned in order.
380 -- If we run out, we don't attempt to assign any further registers (even
381 -- though we might have run out of only one kind of register); we just
382 -- return immediately with the left-overs specified.
384 -- The alternative version @assignAllRegs@ uses the complete set of
385 -- registers, including those that aren't mapped to real machine
386 -- registers. This is used for calling special RTS functions and PrimOps
387 -- which expect their arguments to always be in the same registers.
389 assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
390 :: [(CgRep,a)] -- Arg or result values to assign
391 -> ([(a, GlobalReg)], -- Register assignment in same order
392 -- for *initial segment of* input list
393 -- (but reversed; doesn't matter)
394 -- VoidRep args do not appear here
395 [(CgRep,a)]) -- Leftover arg or result values
398 = assign_regs args (mkRegTbl [node])
399 -- The entry convention for a function closure
400 -- never uses Node for argument passing; instead
401 -- Node points to the function closure itself
403 assignPrimOpCallRegs args
404 = assign_regs args (mkRegTbl_allRegs [])
405 -- For primops, *all* arguments must be passed in registers
407 assignReturnRegs args
408 = assign_regs args (mkRegTbl [])
409 -- For returning unboxed tuples etc,
412 assign_regs :: [(CgRep,a)] -- Arg or result values to assign
413 -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
414 -> ([(a, GlobalReg)], [(CgRep, a)])
415 assign_regs args supply
418 go [] acc supply = (acc, []) -- Return the results reversed (doesn't matter)
419 go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and
420 = go args acc supply -- there's nothign to bind them to
421 go ((rep,arg) : args) acc supply
422 = case assign_reg rep supply of
423 Just (reg, supply') -> go args ((arg,reg):acc) supply'
424 Nothing -> (acc, (rep,arg):args) -- No more regs
426 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
427 assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls))
428 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls))
429 assign_reg LongArg (vs, fs, ds, l:ls) = Just (LongReg l, (vs, fs, ds, ls))
430 assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
431 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
432 -- PtrArg and NonPtrArg both go in a vanilla register
433 assign_reg other not_enough_regs = Nothing
436 -------------------------------------------------------------------------
440 -------------------------------------------------------------------------
442 -- Vanilla registers can contain pointers, Ints, Chars.
443 -- Floats and doubles have separate register supplies.
445 -- We take these register supplies from the *real* registers, i.e. those
446 -- that are guaranteed to map to machine registers.
448 useVanillaRegs | opt_Unregisterised = 0
449 | otherwise = mAX_Real_Vanilla_REG
450 useFloatRegs | opt_Unregisterised = 0
451 | otherwise = mAX_Real_Float_REG
452 useDoubleRegs | opt_Unregisterised = 0
453 | otherwise = mAX_Real_Double_REG
454 useLongRegs | opt_Unregisterised = 0
455 | otherwise = mAX_Real_Long_REG
457 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
458 vanillaRegNos = regList useVanillaRegs
459 floatRegNos = regList useFloatRegs
460 doubleRegNos = regList useDoubleRegs
461 longRegNos = regList useLongRegs
463 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
464 allVanillaRegNos = regList mAX_Vanilla_REG
465 allFloatRegNos = regList mAX_Float_REG
466 allDoubleRegNos = regList mAX_Double_REG
467 allLongRegNos = regList mAX_Long_REG
472 type AvailRegs = ( [Int] -- available vanilla regs.
475 , [Int] -- longs (int64 and word64)
478 mkRegTbl :: [GlobalReg] -> AvailRegs
480 = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
482 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
483 mkRegTbl_allRegs regs_in_use
484 = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
486 mkRegTbl' regs_in_use vanillas floats doubles longs
487 = (ok_vanilla, ok_float, ok_double, ok_long)
489 ok_vanilla = mapCatMaybes (select VanillaReg) vanillas
490 ok_float = mapCatMaybes (select FloatReg) floats
491 ok_double = mapCatMaybes (select DoubleReg) doubles
492 ok_long = mapCatMaybes (select LongReg) longs
493 -- rep isn't looked at, hence we can use any old rep.
495 select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
496 -- one we've unboxed the Int, we make a GlobalReg
497 -- and see if it is already in use; if not, return its number.
499 select mk_reg_fun cand
501 reg = mk_reg_fun cand
503 if reg `not_elem` regs_in_use
507 not_elem = isn'tIn "mkRegTbl"