2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 -----------------------------------------------------------------------------
10 -- (c) The University of Glasgow 2004-2006
14 -- The datatypes and functions here encapsulate the
15 -- calling and return conventions used by the code generator.
17 -----------------------------------------------------------------------------
20 -- Argument descriptors
21 mkArgDescr, argDescrType,
24 isBigLiveness, mkRegLiveness,
25 smallLiveness, mkLivenessCLit,
27 -- Register assignment
28 assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
31 constructSlowCall, slowArgs, slowCallPattern,
61 -------------------------------------------------------------------------
63 -- Making argument descriptors
65 -- An argument descriptor describes the layout of args on the stack,
66 -- both for * GC (stack-layout) purposes, and
67 -- * saving/restoring registers when a heap-check fails
69 -- Void arguments aren't important, therefore (contrast constructSlowCall)
71 -------------------------------------------------------------------------
73 -- bring in ARG_P, ARG_N, etc.
74 #include "../includes/StgFun.h"
76 -------------------------
77 argDescrType :: ArgDescr -> StgHalfWord
78 -- The "argument type" RTS field type
79 argDescrType (ArgSpec n) = n
80 argDescrType (ArgGen liveness)
81 | isBigLiveness liveness = ARG_GEN_BIG
85 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
87 = case stdPattern arg_reps of
88 Just spec_id -> return (ArgSpec spec_id)
89 Nothing -> do { liveness <- mkLiveness nm size bitmap
90 ; return (ArgGen liveness) }
92 arg_reps = filter nonVoidArg (map idCgRep args)
93 -- Getting rid of voids eases matching of standard patterns
95 bitmap = mkBitmap arg_bits
96 arg_bits = argBits arg_reps
97 size = length arg_bits
99 argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr
101 argBits (PtrArg : args) = False : argBits args
102 argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
104 stdPattern :: [CgRep] -> Maybe StgHalfWord
105 stdPattern [] = Just ARG_NONE -- just void args, probably
107 stdPattern [PtrArg] = Just ARG_P
108 stdPattern [FloatArg] = Just ARG_F
109 stdPattern [DoubleArg] = Just ARG_D
110 stdPattern [LongArg] = Just ARG_L
111 stdPattern [NonPtrArg] = Just ARG_N
113 stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
114 stdPattern [NonPtrArg,PtrArg] = Just ARG_NP
115 stdPattern [PtrArg,NonPtrArg] = Just ARG_PN
116 stdPattern [PtrArg,PtrArg] = Just ARG_PP
118 stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
119 stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP
120 stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN
121 stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP
122 stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN
123 stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP
124 stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN
125 stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP
127 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP
128 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP
129 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
130 stdPattern other = Nothing
133 -------------------------------------------------------------------------
137 -------------------------------------------------------------------------
139 -- TODO: This along with 'mkArgDescr' should be unified
140 -- with 'CmmInfo.mkLiveness'. However that would require
141 -- potentially invasive changes to the 'ClosureInfo' type.
142 -- For now, 'CmmInfo.mkLiveness' handles only continuations and
143 -- this one handles liveness everything else. Another distinction
144 -- between these two is that 'CmmInfo.mkLiveness' information
145 -- about the stack layout, and this one is information about
146 -- the heap layout of PAPs.
147 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
148 mkLiveness name size bits
149 | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
150 = do { let lbl = mkBitmapLabel (getUnique name)
151 ; emitRODataLits "mkLiveness" lbl ( mkWordCLit (fromIntegral size)
152 : map mkWordCLit bits)
153 ; return (BigLiveness lbl) }
155 | otherwise -- Bitmap fits in one word
157 small_bits = case bits of
159 [b] -> fromIntegral b
160 _ -> panic "livenessToAddrMode"
162 return (smallLiveness size small_bits)
164 smallLiveness :: Int -> StgWord -> Liveness
165 smallLiveness size small_bits = SmallLiveness bits
166 where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
169 isBigLiveness :: Liveness -> Bool
170 isBigLiveness (BigLiveness _) = True
171 isBigLiveness (SmallLiveness _) = False
174 mkLivenessCLit :: Liveness -> CmmLit
175 mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl
176 mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
179 -------------------------------------------------------------------------
181 -- Bitmap describing register liveness
182 -- across GC when doing a "generic" heap check
183 -- (a RET_DYN stack frame).
185 -- NB. Must agree with these macros (currently in StgMacros.h):
186 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
187 -------------------------------------------------------------------------
189 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
190 mkRegLiveness regs ptrs nptrs
191 = (fromIntegral nptrs `shiftL` 16) .|.
192 (fromIntegral ptrs `shiftL` 24) .|.
193 all_non_ptrs `xor` reg_bits regs
198 reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
199 = (1 `shiftL` (i - 1)) .|. reg_bits regs
203 -------------------------------------------------------------------------
205 -- Pushing the arguments for a slow call
207 -------------------------------------------------------------------------
209 -- For a slow call, we must take a bunch of arguments and intersperse
210 -- some stg_ap_<pattern>_ret_info return addresses.
213 -> (CLabel, -- RTS entry point for call
214 [(CgRep,CmmExpr)], -- args to pass to the entry point
215 [(CgRep,CmmExpr)]) -- stuff to save on the stack
217 -- don't forget the zero case
219 = (mkRtsApFastLabel (sLit "stg_ap_0"), [], [])
221 constructSlowCall amodes
222 = (stg_ap_pat, these, rest)
224 stg_ap_pat = mkRtsApFastLabel arg_pat
225 (arg_pat, these, rest) = matchSlowPattern amodes
227 -- | 'slowArgs' takes a list of function arguments and prepares them for
228 -- pushing on the stack for "extra" arguments to a function which requires
229 -- fewer arguments than we currently have.
230 slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
232 slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
233 where (arg_pat, args, rest) = matchSlowPattern amodes
234 stg_ap_pat = mkRtsRetInfoLabel arg_pat
236 matchSlowPattern :: [(CgRep,CmmExpr)]
237 -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
238 matchSlowPattern amodes = (arg_pat, these, rest)
239 where (arg_pat, n) = slowCallPattern (map fst amodes)
240 (these, rest) = splitAt n amodes
242 -- These cases were found to cover about 99% of all slow calls:
243 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppppp", 6)
244 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppppp", 5)
245 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppp", 4)
246 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_pppv", 4)
247 slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppp", 3)
248 slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_ppv", 3)
249 slowCallPattern (PtrArg: PtrArg: _) = (sLit "stg_ap_pp", 2)
250 slowCallPattern (PtrArg: VoidArg: _) = (sLit "stg_ap_pv", 2)
251 slowCallPattern (PtrArg: _) = (sLit "stg_ap_p", 1)
252 slowCallPattern (VoidArg: _) = (sLit "stg_ap_v", 1)
253 slowCallPattern (NonPtrArg: _) = (sLit "stg_ap_n", 1)
254 slowCallPattern (FloatArg: _) = (sLit "stg_ap_f", 1)
255 slowCallPattern (DoubleArg: _) = (sLit "stg_ap_d", 1)
256 slowCallPattern (LongArg: _) = (sLit "stg_ap_l", 1)
257 slowCallPattern _ = panic "CgStackery.slowCallPattern"
259 -------------------------------------------------------------------------
261 -- Return conventions
263 -------------------------------------------------------------------------
265 dataReturnConvPrim :: CgRep -> CmmReg
266 dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1 VGcPtr)
267 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
268 dataReturnConvPrim LongArg = CmmGlobal (LongReg 1)
269 dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1)
270 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
271 dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
274 -- getSequelAmode returns an amode which refers to an info table. The info
275 -- table will always be of the RET_(BIG|SMALL) kind. We're careful
276 -- not to handle real code pointers, just in case we're compiling for
277 -- an unregisterised/untailcallish architecture, where info pointers and
278 -- code pointers aren't the same.
280 -- The OnStack case of sequelToAmode delivers an Amode which is only
281 -- valid just before the final control transfer, because it assumes
282 -- that Sp is pointing to the top word of the return address. This
283 -- seems unclean but there you go.
285 getSequelAmode :: FCode CmmExpr
287 = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
289 OnStack -> do { sp_rel <- getSpRelOffset virt_sp
290 ; returnFC (CmmLoad sp_rel bWord) }
292 UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
293 CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl))
296 -------------------------------------------------------------------------
298 -- Register assignment
300 -------------------------------------------------------------------------
302 -- How to assign registers for
304 -- 1) Calling a fast entry point.
305 -- 2) Returning an unboxed tuple.
306 -- 3) Invoking an out-of-line PrimOp.
308 -- Registers are assigned in order.
310 -- If we run out, we don't attempt to assign any further registers (even
311 -- though we might have run out of only one kind of register); we just
312 -- return immediately with the left-overs specified.
314 -- The alternative version @assignAllRegs@ uses the complete set of
315 -- registers, including those that aren't mapped to real machine
316 -- registers. This is used for calling special RTS functions and PrimOps
317 -- which expect their arguments to always be in the same registers.
319 assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
320 :: [(CgRep,a)] -- Arg or result values to assign
321 -> ([(a, GlobalReg)], -- Register assignment in same order
322 -- for *initial segment of* input list
323 -- (but reversed; doesn't matter)
324 -- VoidRep args do not appear here
325 [(CgRep,a)]) -- Leftover arg or result values
328 = assign_regs args (mkRegTbl [node])
329 -- The entry convention for a function closure
330 -- never uses Node for argument passing; instead
331 -- Node points to the function closure itself
333 assignPrimOpCallRegs args
334 = assign_regs args (mkRegTbl_allRegs [])
335 -- For primops, *all* arguments must be passed in registers
337 assignReturnRegs args
338 -- when we have a single non-void component to return, use the normal
339 -- unpointed return convention. This make various things simpler: it
340 -- means we can assume a consistent convention for IO, which is useful
341 -- when writing code that relies on knowing the IO return convention in
342 -- the RTS (primops, especially exception-related primops).
343 -- Also, the bytecode compiler assumes this when compiling
344 -- case expressions and ccalls, so it only needs to know one set of
345 -- return conventions.
346 | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
349 = assign_regs args (mkRegTbl [])
350 -- For returning unboxed tuples etc,
353 non_void_args = filter ((/= VoidArg).fst) args
355 assign_regs :: [(CgRep,a)] -- Arg or result values to assign
356 -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
357 -> ([(a, GlobalReg)], [(CgRep, a)])
358 assign_regs args supply
361 go [] acc supply = (acc, []) -- Return the results reversed (doesn't matter)
362 go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and
363 = go args acc supply -- there's nothing to bind them to
364 go ((rep,arg) : args) acc supply
365 = case assign_reg rep supply of
366 Just (reg, supply') -> go args ((arg,reg):acc) supply'
367 Nothing -> (acc, (rep,arg):args) -- No more regs
369 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
370 assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls))
371 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls))
372 assign_reg LongArg (vs, fs, ds, l:ls) = pprTrace "longArg" (ppr l) $ Just (LongReg l, (vs, fs, ds, ls))
373 assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
374 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
375 -- PtrArg and NonPtrArg both go in a vanilla register
376 assign_reg other not_enough_regs = Nothing
379 -------------------------------------------------------------------------
383 -------------------------------------------------------------------------
385 -- Vanilla registers can contain pointers, Ints, Chars.
386 -- Floats and doubles have separate register supplies.
388 -- We take these register supplies from the *real* registers, i.e. those
389 -- that are guaranteed to map to machine registers.
391 useVanillaRegs | opt_Unregisterised = 0
392 | otherwise = mAX_Real_Vanilla_REG
393 useFloatRegs | opt_Unregisterised = 0
394 | otherwise = mAX_Real_Float_REG
395 useDoubleRegs | opt_Unregisterised = 0
396 | otherwise = mAX_Real_Double_REG
397 useLongRegs | opt_Unregisterised = 0
398 | otherwise = mAX_Real_Long_REG
400 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
401 vanillaRegNos = regList useVanillaRegs
402 floatRegNos = regList useFloatRegs
403 doubleRegNos = regList useDoubleRegs
404 longRegNos = regList useLongRegs
406 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
407 allVanillaRegNos = regList mAX_Vanilla_REG
408 allFloatRegNos = regList mAX_Float_REG
409 allDoubleRegNos = regList mAX_Double_REG
410 allLongRegNos = regList mAX_Long_REG
415 type AvailRegs = ( [Int] -- available vanilla regs.
418 , [Int] -- longs (int64 and word64)
421 mkRegTbl :: [GlobalReg] -> AvailRegs
423 = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
425 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
426 mkRegTbl_allRegs regs_in_use
427 = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
429 mkRegTbl' regs_in_use vanillas floats doubles longs
430 = (ok_vanilla, ok_float, ok_double, ok_long)
432 ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) vanillas
433 -- ptrhood isn't looked at, hence we can use any old rep.
434 ok_float = mapCatMaybes (select FloatReg) floats
435 ok_double = mapCatMaybes (select DoubleReg) doubles
436 ok_long = mapCatMaybes (select LongReg) longs
438 select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
439 -- one we've unboxed the Int, we make a GlobalReg
440 -- and see if it is already in use; if not, return its number.
442 select mk_reg_fun cand
444 reg = mk_reg_fun cand
446 if reg `not_elem` regs_in_use
450 not_elem = isn'tIn "mkRegTbl"