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