b0fab89f820ddba213c3dc9ea4d0c84c49f71a43
[ghc.git] / compiler / codeGen / CgCallConv.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2004-2006
4 --
5 -- CgCallConv
6 --
7 -- The datatypes and functions here encapsulate the
8 -- calling and return conventions used by the code generator.
9 --
10 -----------------------------------------------------------------------------
11
12
13 module CgCallConv (
14 -- Argument descriptors
15 mkArgDescr, argDescrType,
16
17 -- Liveness
18 isBigLiveness, buildContLiveness, mkRegLiveness,
19 smallLiveness, mkLivenessCLit,
20
21 -- Register assignment
22 assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
23
24 -- Calls
25 constructSlowCall, slowArgs, slowCallPattern,
26
27 -- Returns
28 dataReturnConvPrim,
29 getSequelAmode
30 ) where
31
32 #include "HsVersions.h"
33
34 import CgUtils
35 import CgMonad
36 import SMRep
37
38 import MachOp
39 import Cmm
40 import CLabel
41
42 import Constants
43 import ClosureInfo
44 import CgStackery
45 import CmmUtils
46 import Maybes
47 import Id
48 import Name
49 import Bitmap
50 import Util
51 import StaticFlags
52 import FastString
53 import Outputable
54 import Unique
55
56 import Data.Bits
57
58 -------------------------------------------------------------------------
59 --
60 -- Making argument descriptors
61 --
62 -- An argument descriptor describes the layout of args on the stack,
63 -- both for * GC (stack-layout) purposes, and
64 -- * saving/restoring registers when a heap-check fails
65 --
66 -- Void arguments aren't important, therefore (contrast constructSlowCall)
67 --
68 -------------------------------------------------------------------------
69
70 -- bring in ARG_P, ARG_N, etc.
71 #include "../includes/StgFun.h"
72
73 -------------------------
74 argDescrType :: ArgDescr -> Int
75 -- The "argument type" RTS field type
76 argDescrType (ArgSpec n) = n
77 argDescrType (ArgGen liveness)
78 | isBigLiveness liveness = ARG_GEN_BIG
79 | otherwise = ARG_GEN
80
81
82 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
83 mkArgDescr nm args
84 = case stdPattern arg_reps of
85 Just spec_id -> return (ArgSpec spec_id)
86 Nothing -> do { liveness <- mkLiveness nm size bitmap
87 ; return (ArgGen liveness) }
88 where
89 arg_reps = filter nonVoidArg (map idCgRep args)
90 -- Getting rid of voids eases matching of standard patterns
91
92 bitmap = mkBitmap arg_bits
93 arg_bits = argBits arg_reps
94 size = length arg_bits
95
96 argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr
97 argBits [] = []
98 argBits (PtrArg : args) = False : argBits args
99 argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
100
101 stdPattern :: [CgRep] -> Maybe Int
102 stdPattern [] = Just ARG_NONE -- just void args, probably
103
104 stdPattern [PtrArg] = Just ARG_P
105 stdPattern [FloatArg] = Just ARG_F
106 stdPattern [DoubleArg] = Just ARG_D
107 stdPattern [LongArg] = Just ARG_L
108 stdPattern [NonPtrArg] = Just ARG_N
109
110 stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
111 stdPattern [NonPtrArg,PtrArg] = Just ARG_NP
112 stdPattern [PtrArg,NonPtrArg] = Just ARG_PN
113 stdPattern [PtrArg,PtrArg] = Just ARG_PP
114
115 stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
116 stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP
117 stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN
118 stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP
119 stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN
120 stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP
121 stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN
122 stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP
123
124 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP
125 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP
126 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
127 stdPattern other = Nothing
128
129
130 -------------------------------------------------------------------------
131 --
132 -- Liveness info
133 --
134 -------------------------------------------------------------------------
135
136 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
137 mkLiveness name size bits
138 | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
139 = do { let lbl = mkBitmapLabel (getUnique name)
140 ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
141 : map mkWordCLit bits)
142 ; return (BigLiveness lbl) }
143
144 | otherwise -- Bitmap fits in one word
145 = let
146 small_bits = case bits of
147 [] -> 0
148 [b] -> fromIntegral b
149 _ -> panic "livenessToAddrMode"
150 in
151 return (smallLiveness size small_bits)
152
153 smallLiveness :: Int -> StgWord -> Liveness
154 smallLiveness size small_bits = SmallLiveness bits
155 where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
156
157 -------------------
158 isBigLiveness :: Liveness -> Bool
159 isBigLiveness (BigLiveness _) = True
160 isBigLiveness (SmallLiveness _) = False
161
162 -------------------
163 mkLivenessCLit :: Liveness -> CmmLit
164 mkLivenessCLit (BigLiveness lbl) = CmmLabel lbl
165 mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
166
167
168 -------------------------------------------------------------------------
169 --
170 -- Bitmap describing register liveness
171 -- across GC when doing a "generic" heap check
172 -- (a RET_DYN stack frame).
173 --
174 -- NB. Must agree with these macros (currently in StgMacros.h):
175 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
176 -------------------------------------------------------------------------
177
178 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
179 mkRegLiveness regs ptrs nptrs
180 = (fromIntegral nptrs `shiftL` 16) .|.
181 (fromIntegral ptrs `shiftL` 24) .|.
182 all_non_ptrs `xor` reg_bits regs
183 where
184 all_non_ptrs = 0xff
185
186 reg_bits [] = 0
187 reg_bits ((id, VanillaReg i) : regs) | isFollowableArg (idCgRep id)
188 = (1 `shiftL` (i - 1)) .|. reg_bits regs
189 reg_bits (_ : regs)
190 = reg_bits regs
191
192 -------------------------------------------------------------------------
193 --
194 -- Pushing the arguments for a slow call
195 --
196 -------------------------------------------------------------------------
197
198 -- For a slow call, we must take a bunch of arguments and intersperse
199 -- some stg_ap_<pattern>_ret_info return addresses.
200 constructSlowCall
201 :: [(CgRep,CmmExpr)]
202 -> (CLabel, -- RTS entry point for call
203 [(CgRep,CmmExpr)], -- args to pass to the entry point
204 [(CgRep,CmmExpr)]) -- stuff to save on the stack
205
206 -- don't forget the zero case
207 constructSlowCall []
208 = (mkRtsApFastLabel SLIT("stg_ap_0"), [], [])
209
210 constructSlowCall amodes
211 = (stg_ap_pat, these, rest)
212 where
213 stg_ap_pat = mkRtsApFastLabel arg_pat
214 (arg_pat, these, rest) = matchSlowPattern amodes
215
216 -- | 'slowArgs' takes a list of function arguments and prepares them for
217 -- pushing on the stack for "extra" arguments to a function which requires
218 -- fewer arguments than we currently have.
219 slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
220 slowArgs [] = []
221 slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
222 where (arg_pat, args, rest) = matchSlowPattern amodes
223 stg_ap_pat = mkRtsRetInfoLabel arg_pat
224
225 matchSlowPattern :: [(CgRep,CmmExpr)]
226 -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
227 matchSlowPattern amodes = (arg_pat, these, rest)
228 where (arg_pat, n) = slowCallPattern (map fst amodes)
229 (these, rest) = splitAt n amodes
230
231 -- These cases were found to cover about 99% of all slow calls:
232 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
233 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppppp"), 5)
234 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppp"), 4)
235 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_pppv"), 4)
236 slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppp"), 3)
237 slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_ppv"), 3)
238 slowCallPattern (PtrArg: PtrArg: _) = (SLIT("stg_ap_pp"), 2)
239 slowCallPattern (PtrArg: VoidArg: _) = (SLIT("stg_ap_pv"), 2)
240 slowCallPattern (PtrArg: _) = (SLIT("stg_ap_p"), 1)
241 slowCallPattern (VoidArg: _) = (SLIT("stg_ap_v"), 1)
242 slowCallPattern (NonPtrArg: _) = (SLIT("stg_ap_n"), 1)
243 slowCallPattern (FloatArg: _) = (SLIT("stg_ap_f"), 1)
244 slowCallPattern (DoubleArg: _) = (SLIT("stg_ap_d"), 1)
245 slowCallPattern (LongArg: _) = (SLIT("stg_ap_l"), 1)
246 slowCallPattern _ = panic "CgStackery.slowCallPattern"
247
248 -------------------------------------------------------------------------
249 --
250 -- Return conventions
251 --
252 -------------------------------------------------------------------------
253
254 dataReturnConvPrim :: CgRep -> CmmReg
255 dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1)
256 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
257 dataReturnConvPrim LongArg = CmmGlobal (LongReg 1)
258 dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1)
259 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
260 dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
261
262
263 -- getSequelAmode returns an amode which refers to an info table. The info
264 -- table will always be of the RET_(BIG|SMALL) kind. We're careful
265 -- not to handle real code pointers, just in case we're compiling for
266 -- an unregisterised/untailcallish architecture, where info pointers and
267 -- code pointers aren't the same.
268 -- DIRE WARNING.
269 -- The OnStack case of sequelToAmode delivers an Amode which is only
270 -- valid just before the final control transfer, because it assumes
271 -- that Sp is pointing to the top word of the return address. This
272 -- seems unclean but there you go.
273
274 getSequelAmode :: FCode CmmExpr
275 getSequelAmode
276 = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
277 ; case sequel of
278 OnStack -> do { sp_rel <- getSpRelOffset virt_sp
279 ; returnFC (CmmLoad sp_rel wordRep) }
280
281 UpdateCode -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
282 CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl))
283 }
284
285 -------------------------------------------------------------------------
286 --
287 -- Build a liveness mask for the current stack
288 --
289 -------------------------------------------------------------------------
290
291 -- There are four kinds of things on the stack:
292 --
293 -- - pointer variables (bound in the environment)
294 -- - non-pointer variables (bound in the environment)
295 -- - free slots (recorded in the stack free list)
296 -- - non-pointer data slots (recorded in the stack free list)
297 --
298 -- We build up a bitmap of non-pointer slots by searching the environment
299 -- for all the pointer variables, and subtracting these from a bitmap
300 -- with initially all bits set (up to the size of the stack frame).
301
302 buildContLiveness :: Name -- Basis for label (only)
303 -> [VirtualSpOffset] -- Live stack slots
304 -> FCode Liveness
305 buildContLiveness name live_slots
306 = do { stk_usg <- getStkUsage
307 ; let StackUsage { realSp = real_sp,
308 frameSp = frame_sp } = stk_usg
309
310 start_sp :: VirtualSpOffset
311 start_sp = real_sp - retAddrSizeW
312 -- In a continuation, we want a liveness mask that
313 -- starts from just after the return address, which is
314 -- on the stack at real_sp.
315
316 frame_size :: WordOff
317 frame_size = start_sp - frame_sp
318 -- real_sp points to the frame-header for the current
319 -- stack frame, and the end of this frame is frame_sp.
320 -- The size is therefore real_sp - frame_sp - retAddrSizeW
321 -- (subtract one for the frame-header = return address).
322
323 rel_slots :: [WordOff]
324 rel_slots = sortLe (<=)
325 [ start_sp - ofs -- Get slots relative to top of frame
326 | ofs <- live_slots ]
327
328 bitmap = intsToReverseBitmap frame_size rel_slots
329
330 ; WARN( not (all (>=0) rel_slots),
331 ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
332 mkLiveness name frame_size bitmap }
333
334
335 -------------------------------------------------------------------------
336 --
337 -- Register assignment
338 --
339 -------------------------------------------------------------------------
340
341 -- How to assign registers for
342 --
343 -- 1) Calling a fast entry point.
344 -- 2) Returning an unboxed tuple.
345 -- 3) Invoking an out-of-line PrimOp.
346 --
347 -- Registers are assigned in order.
348 --
349 -- If we run out, we don't attempt to assign any further registers (even
350 -- though we might have run out of only one kind of register); we just
351 -- return immediately with the left-overs specified.
352 --
353 -- The alternative version @assignAllRegs@ uses the complete set of
354 -- registers, including those that aren't mapped to real machine
355 -- registers. This is used for calling special RTS functions and PrimOps
356 -- which expect their arguments to always be in the same registers.
357
358 assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
359 :: [(CgRep,a)] -- Arg or result values to assign
360 -> ([(a, GlobalReg)], -- Register assignment in same order
361 -- for *initial segment of* input list
362 -- (but reversed; doesn't matter)
363 -- VoidRep args do not appear here
364 [(CgRep,a)]) -- Leftover arg or result values
365
366 assignCallRegs args
367 = assign_regs args (mkRegTbl [node])
368 -- The entry convention for a function closure
369 -- never uses Node for argument passing; instead
370 -- Node points to the function closure itself
371
372 assignPrimOpCallRegs args
373 = assign_regs args (mkRegTbl_allRegs [])
374 -- For primops, *all* arguments must be passed in registers
375
376 assignReturnRegs args
377 = assign_regs args (mkRegTbl [])
378 -- For returning unboxed tuples etc,
379 -- we use all regs
380
381 assign_regs :: [(CgRep,a)] -- Arg or result values to assign
382 -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
383 -> ([(a, GlobalReg)], [(CgRep, a)])
384 assign_regs args supply
385 = go args [] supply
386 where
387 go [] acc supply = (acc, []) -- Return the results reversed (doesn't matter)
388 go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and
389 = go args acc supply -- there's nothign to bind them to
390 go ((rep,arg) : args) acc supply
391 = case assign_reg rep supply of
392 Just (reg, supply') -> go args ((arg,reg):acc) supply'
393 Nothing -> (acc, (rep,arg):args) -- No more regs
394
395 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
396 assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls))
397 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls))
398 assign_reg LongArg (vs, fs, ds, l:ls) = Just (LongReg l, (vs, fs, ds, ls))
399 assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
400 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
401 -- PtrArg and NonPtrArg both go in a vanilla register
402 assign_reg other not_enough_regs = Nothing
403
404
405 -------------------------------------------------------------------------
406 --
407 -- Register supplies
408 --
409 -------------------------------------------------------------------------
410
411 -- Vanilla registers can contain pointers, Ints, Chars.
412 -- Floats and doubles have separate register supplies.
413 --
414 -- We take these register supplies from the *real* registers, i.e. those
415 -- that are guaranteed to map to machine registers.
416
417 useVanillaRegs | opt_Unregisterised = 0
418 | otherwise = mAX_Real_Vanilla_REG
419 useFloatRegs | opt_Unregisterised = 0
420 | otherwise = mAX_Real_Float_REG
421 useDoubleRegs | opt_Unregisterised = 0
422 | otherwise = mAX_Real_Double_REG
423 useLongRegs | opt_Unregisterised = 0
424 | otherwise = mAX_Real_Long_REG
425
426 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
427 vanillaRegNos = regList useVanillaRegs
428 floatRegNos = regList useFloatRegs
429 doubleRegNos = regList useDoubleRegs
430 longRegNos = regList useLongRegs
431
432 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
433 allVanillaRegNos = regList mAX_Vanilla_REG
434 allFloatRegNos = regList mAX_Float_REG
435 allDoubleRegNos = regList mAX_Double_REG
436 allLongRegNos = regList mAX_Long_REG
437
438 regList 0 = []
439 regList n = [1 .. n]
440
441 type AvailRegs = ( [Int] -- available vanilla regs.
442 , [Int] -- floats
443 , [Int] -- doubles
444 , [Int] -- longs (int64 and word64)
445 )
446
447 mkRegTbl :: [GlobalReg] -> AvailRegs
448 mkRegTbl regs_in_use
449 = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
450
451 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
452 mkRegTbl_allRegs regs_in_use
453 = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
454
455 mkRegTbl' regs_in_use vanillas floats doubles longs
456 = (ok_vanilla, ok_float, ok_double, ok_long)
457 where
458 ok_vanilla = mapCatMaybes (select VanillaReg) vanillas
459 ok_float = mapCatMaybes (select FloatReg) floats
460 ok_double = mapCatMaybes (select DoubleReg) doubles
461 ok_long = mapCatMaybes (select LongReg) longs
462 -- rep isn't looked at, hence we can use any old rep.
463
464 select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
465 -- one we've unboxed the Int, we make a GlobalReg
466 -- and see if it is already in use; if not, return its number.
467
468 select mk_reg_fun cand
469 = let
470 reg = mk_reg_fun cand
471 in
472 if reg `not_elem` regs_in_use
473 then Just cand
474 else Nothing
475 where
476 not_elem = isn'tIn "mkRegTbl"
477
478