Produce new-style Cmm from the Cmm parser
[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 module CgCallConv (
13 -- Argument descriptors
14 mkArgDescr,
15
16 -- Liveness
17 mkRegLiveness,
18
19 -- Register assignment
20 assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
21
22 -- Calls
23 constructSlowCall, slowArgs, slowCallPattern,
24
25 -- Returns
26 dataReturnConvPrim,
27 getSequelAmode
28 ) where
29
30 import CgMonad
31 import CgProf
32 import SMRep
33
34 import OldCmm
35 import CLabel
36
37 import CgStackery
38 import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg )
39 import OldCmmUtils
40 import Maybes
41 import Id
42 import Name
43 import Util
44 import DynFlags
45 import Module
46 import FastString
47 import Outputable
48 import Platform
49 import Data.Bits
50
51 -------------------------------------------------------------------------
52 --
53 -- Making argument descriptors
54 --
55 -- An argument descriptor describes the layout of args on the stack,
56 -- both for * GC (stack-layout) purposes, and
57 -- * saving/restoring registers when a heap-check fails
58 --
59 -- Void arguments aren't important, therefore (contrast constructSlowCall)
60 --
61 -------------------------------------------------------------------------
62
63 -- bring in ARG_P, ARG_N, etc.
64 #include "../includes/rts/storage/FunTypes.h"
65
66 -------------------------
67 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
68 mkArgDescr _nm args
69 = do dflags <- getDynFlags
70 let arg_bits = argBits dflags arg_reps
71 arg_reps = filter nonVoidArg (map idCgRep args)
72 -- Getting rid of voids eases matching of standard patterns
73 case stdPattern arg_reps of
74 Just spec_id -> return (ArgSpec spec_id)
75 Nothing -> return (ArgGen arg_bits)
76
77 argBits :: DynFlags -> [CgRep] -> [Bool] -- True for non-ptr, False for ptr
78 argBits _ [] = []
79 argBits dflags (PtrArg : args) = False : argBits dflags args
80 argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
81
82 stdPattern :: [CgRep] -> Maybe Int
83 stdPattern reps
84 = case reps of
85 [] -> Just ARG_NONE -- just void args, probably
86
87 [PtrArg] -> Just ARG_P
88 [FloatArg] -> Just ARG_F
89 [DoubleArg] -> Just ARG_D
90 [LongArg] -> Just ARG_L
91 [NonPtrArg] -> Just ARG_N
92
93 [NonPtrArg,NonPtrArg] -> Just ARG_NN
94 [NonPtrArg,PtrArg] -> Just ARG_NP
95 [PtrArg,NonPtrArg] -> Just ARG_PN
96 [PtrArg,PtrArg] -> Just ARG_PP
97
98 [NonPtrArg,NonPtrArg,NonPtrArg] -> Just ARG_NNN
99 [NonPtrArg,NonPtrArg,PtrArg] -> Just ARG_NNP
100 [NonPtrArg,PtrArg,NonPtrArg] -> Just ARG_NPN
101 [NonPtrArg,PtrArg,PtrArg] -> Just ARG_NPP
102 [PtrArg,NonPtrArg,NonPtrArg] -> Just ARG_PNN
103 [PtrArg,NonPtrArg,PtrArg] -> Just ARG_PNP
104 [PtrArg,PtrArg,NonPtrArg] -> Just ARG_PPN
105 [PtrArg,PtrArg,PtrArg] -> Just ARG_PPP
106
107 [PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPP
108 [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPP
109 [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPPP
110 _ -> Nothing
111
112
113 -------------------------------------------------------------------------
114 --
115 -- Bitmap describing register liveness
116 -- across GC when doing a "generic" heap check
117 -- (a RET_DYN stack frame).
118 --
119 -- NB. Must agree with these macros (currently in StgMacros.h):
120 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
121 -------------------------------------------------------------------------
122
123 mkRegLiveness :: DynFlags -> [(Id, GlobalReg)] -> Int -> Int -> StgWord
124 mkRegLiveness dflags regs ptrs nptrs
125 = (toStgWord dflags (toInteger nptrs) `shiftL` 16) .|.
126 (toStgWord dflags (toInteger ptrs) `shiftL` 24) .|.
127 all_non_ptrs `xor` toStgWord dflags (reg_bits regs)
128 where
129 all_non_ptrs = toStgWord dflags 0xff
130
131 reg_bits [] = 0
132 reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
133 = (1 `shiftL` (i - 1)) .|. reg_bits regs
134 reg_bits (_ : regs)
135 = reg_bits regs
136
137 -------------------------------------------------------------------------
138 --
139 -- Pushing the arguments for a slow call
140 --
141 -------------------------------------------------------------------------
142
143 -- For a slow call, we must take a bunch of arguments and intersperse
144 -- some stg_ap_<pattern>_ret_info return addresses.
145 constructSlowCall
146 :: [(CgRep,CmmExpr)]
147 -> (CLabel, -- RTS entry point for call
148 [(CgRep,CmmExpr)], -- args to pass to the entry point
149 [(CgRep,CmmExpr)]) -- stuff to save on the stack
150
151 -- don't forget the zero case
152 constructSlowCall []
153 = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
154
155 constructSlowCall amodes
156 = (stg_ap_pat, these, rest)
157 where
158 stg_ap_pat = mkRtsApFastLabel arg_pat
159 (arg_pat, these, rest) = matchSlowPattern amodes
160
161 -- | 'slowArgs' takes a list of function arguments and prepares them for
162 -- pushing on the stack for "extra" arguments to a function which requires
163 -- fewer arguments than we currently have.
164 slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
165 slowArgs _ [] = []
166 slowArgs dflags amodes
167 | dopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest
168 | otherwise = this_pat ++ slowArgs dflags rest
169 where
170 (arg_pat, args, rest) = matchSlowPattern amodes
171 stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
172 this_pat = (NonPtrArg, mkLblExpr stg_ap_pat) : args
173 save_cccs = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)]
174 save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")
175
176 matchSlowPattern :: [(CgRep,CmmExpr)]
177 -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
178 matchSlowPattern amodes = (arg_pat, these, rest)
179 where (arg_pat, n) = slowCallPattern (map fst amodes)
180 (these, rest) = splitAt n amodes
181
182 -- These cases were found to cover about 99% of all slow calls:
183 slowCallPattern :: [CgRep] -> (FastString, Int)
184 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
185 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5)
186 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4)
187 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4)
188 slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3)
189 slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3)
190 slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2)
191 slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2)
192 slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1)
193 slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1)
194 slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1)
195 slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1)
196 slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1)
197 slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1)
198 slowCallPattern _ = panic "CgStackery.slowCallPattern"
199
200 -------------------------------------------------------------------------
201 --
202 -- Return conventions
203 --
204 -------------------------------------------------------------------------
205
206 dataReturnConvPrim :: CgRep -> CmmReg
207 dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1 VGcPtr)
208 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
209 dataReturnConvPrim LongArg = CmmGlobal (LongReg 1)
210 dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1)
211 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
212 dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
213
214
215 -- getSequelAmode returns an amode which refers to an info table. The info
216 -- table will always be of the RET_(BIG|SMALL) kind. We're careful
217 -- not to handle real code pointers, just in case we're compiling for
218 -- an unregisterised/untailcallish architecture, where info pointers and
219 -- code pointers aren't the same.
220 -- DIRE WARNING.
221 -- The OnStack case of sequelToAmode delivers an Amode which is only
222 -- valid just before the final control transfer, because it assumes
223 -- that Sp is pointing to the top word of the return address. This
224 -- seems unclean but there you go.
225
226 getSequelAmode :: FCode CmmExpr
227 getSequelAmode
228 = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
229 ; case sequel of
230 OnStack -> do { dflags <- getDynFlags
231 ; sp_rel <- getSpRelOffset virt_sp
232 ; returnFC (CmmLoad sp_rel (bWord dflags)) }
233
234 CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl))
235 }
236
237 -------------------------------------------------------------------------
238 --
239 -- Register assignment
240 --
241 -------------------------------------------------------------------------
242
243 -- How to assign registers for
244 --
245 -- 1) Calling a fast entry point.
246 -- 2) Returning an unboxed tuple.
247 -- 3) Invoking an out-of-line PrimOp.
248 --
249 -- Registers are assigned in order.
250 --
251 -- If we run out, we don't attempt to assign any further registers (even
252 -- though we might have run out of only one kind of register); we just
253 -- return immediately with the left-overs specified.
254 --
255 -- The alternative version @assignAllRegs@ uses the complete set of
256 -- registers, including those that aren't mapped to real machine
257 -- registers. This is used for calling special RTS functions and PrimOps
258 -- which expect their arguments to always be in the same registers.
259
260 type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign
261 -> ([(a, GlobalReg)], -- Register assignment in same order
262 -- for *initial segment of* input list
263 -- (but reversed; doesn't matter)
264 -- VoidRep args do not appear here
265 [(CgRep,a)]) -- Leftover arg or result values
266
267 assignCallRegs :: DynFlags -> AssignRegs a
268 assignPrimOpCallRegs :: DynFlags -> AssignRegs a
269 assignReturnRegs :: DynFlags -> AssignRegs a
270
271 assignCallRegs dflags args
272 = assign_regs args (mkRegTbl dflags [node])
273 -- The entry convention for a function closure
274 -- never uses Node for argument passing; instead
275 -- Node points to the function closure itself
276
277 assignPrimOpCallRegs dflags args
278 = assign_regs args (mkRegTbl_allRegs dflags [])
279 -- For primops, *all* arguments must be passed in registers
280
281 assignReturnRegs dflags args
282 -- when we have a single non-void component to return, use the normal
283 -- unpointed return convention. This make various things simpler: it
284 -- means we can assume a consistent convention for IO, which is useful
285 -- when writing code that relies on knowing the IO return convention in
286 -- the RTS (primops, especially exception-related primops).
287 -- Also, the bytecode compiler assumes this when compiling
288 -- case expressions and ccalls, so it only needs to know one set of
289 -- return conventions.
290 | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
291 = ([(arg, r)], [])
292 | otherwise
293 = assign_regs args (mkRegTbl dflags [])
294 -- For returning unboxed tuples etc,
295 -- we use all regs
296 where
297 non_void_args = filter ((/= VoidArg).fst) args
298
299 assign_regs :: [(CgRep,a)] -- Arg or result values to assign
300 -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
301 -> ([(a, GlobalReg)], [(CgRep, a)])
302 assign_regs args supply
303 = go args [] supply
304 where
305 go [] acc _ = (acc, []) -- Return the results reversed (doesn't matter)
306 go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and
307 = go args acc supply -- there's nothing to bind them to
308 go ((rep,arg) : args) acc supply
309 = case assign_reg rep supply of
310 Just (reg, supply') -> go args ((arg,reg):acc) supply'
311 Nothing -> (acc, (rep,arg):args) -- No more regs
312
313 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
314 assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls))
315 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls))
316 assign_reg LongArg (vs, fs, ds, l:ls) = Just (LongReg l, (vs, fs, ds, ls))
317 assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
318 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
319 -- PtrArg and NonPtrArg both go in a vanilla register
320 assign_reg _ _ = Nothing
321
322
323 -------------------------------------------------------------------------
324 --
325 -- Register supplies
326 --
327 -------------------------------------------------------------------------
328
329 -- Vanilla registers can contain pointers, Ints, Chars.
330 -- Floats and doubles have separate register supplies.
331 --
332 -- We take these register supplies from the *real* registers, i.e. those
333 -- that are guaranteed to map to machine registers.
334
335 useVanillaRegs :: DynFlags -> Int
336 useVanillaRegs dflags
337 | platformUnregisterised (targetPlatform dflags) = 0
338 | otherwise = mAX_Real_Vanilla_REG dflags
339 useFloatRegs :: DynFlags -> Int
340 useFloatRegs dflags
341 | platformUnregisterised (targetPlatform dflags) = 0
342 | otherwise = mAX_Real_Float_REG dflags
343 useDoubleRegs :: DynFlags -> Int
344 useDoubleRegs dflags
345 | platformUnregisterised (targetPlatform dflags) = 0
346 | otherwise = mAX_Real_Double_REG dflags
347 useLongRegs :: DynFlags -> Int
348 useLongRegs dflags
349 | platformUnregisterised (targetPlatform dflags) = 0
350 | otherwise = mAX_Real_Long_REG dflags
351
352 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
353 vanillaRegNos dflags = regList $ useVanillaRegs dflags
354 floatRegNos dflags = regList $ useFloatRegs dflags
355 doubleRegNos dflags = regList $ useDoubleRegs dflags
356 longRegNos dflags = regList $ useLongRegs dflags
357
358 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos
359 :: DynFlags -> [Int]
360 allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags
361 allFloatRegNos dflags = regList $ mAX_Float_REG dflags
362 allDoubleRegNos dflags = regList $ mAX_Double_REG dflags
363 allLongRegNos dflags = regList $ mAX_Long_REG dflags
364
365 regList :: Int -> [Int]
366 regList n = [1 .. n]
367
368 type AvailRegs = ( [Int] -- available vanilla regs.
369 , [Int] -- floats
370 , [Int] -- doubles
371 , [Int] -- longs (int64 and word64)
372 )
373
374 mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
375 mkRegTbl dflags regs_in_use
376 = mkRegTbl' dflags regs_in_use
377 vanillaRegNos floatRegNos doubleRegNos longRegNos
378
379 mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs
380 mkRegTbl_allRegs dflags regs_in_use
381 = mkRegTbl' dflags regs_in_use
382 allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
383
384 mkRegTbl' :: DynFlags -> [GlobalReg]
385 -> (DynFlags -> [Int])
386 -> (DynFlags -> [Int])
387 -> (DynFlags -> [Int])
388 -> (DynFlags -> [Int])
389 -> ([Int], [Int], [Int], [Int])
390 mkRegTbl' dflags regs_in_use vanillas floats doubles longs
391 = (ok_vanilla, ok_float, ok_double, ok_long)
392 where
393 ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr))
394 (vanillas dflags)
395 -- ptrhood isn't looked at, hence we can use any old rep.
396 ok_float = mapCatMaybes (select FloatReg) (floats dflags)
397 ok_double = mapCatMaybes (select DoubleReg) (doubles dflags)
398 ok_long = mapCatMaybes (select LongReg) (longs dflags)
399
400 select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
401 -- one we've unboxed the Int, we make a GlobalReg
402 -- and see if it is already in use; if not, return its number.
403
404 select mk_reg_fun cand
405 = let
406 reg = mk_reg_fun cand
407 in
408 if reg `not_elem` regs_in_use
409 then Just cand
410 else Nothing
411 where
412 not_elem = isn'tIn "mkRegTbl"
413
414