CgCallConv.hs 15.9 KB
Newer Older
1 2
-----------------------------------------------------------------------------
--
Simon Marlow's avatar
Simon Marlow committed
3 4 5
-- (c) The University of Glasgow 2004-2006
--
-- CgCallConv
6 7 8 9 10 11 12 13 14 15 16
--
-- The datatypes and functions here encapsulate the 
-- calling and return conventions used by the code generator.
--
-----------------------------------------------------------------------------

module CgCallConv (
	-- Argument descriptors
	mkArgDescr, argDescrType,

	-- Liveness
17
	isBigLiveness, mkRegLiveness, 
18 19 20 21 22 23 24 25 26 27 28 29 30
	smallLiveness, mkLivenessCLit,

	-- Register assignment
	assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,

	-- Calls
	constructSlowCall, slowArgs, slowCallPattern,

	-- Returns
	dataReturnConvPrim,
	getSequelAmode
    ) where

Simon Marlow's avatar
Simon Marlow committed
31
import CgUtils
32 33
import CgMonad
import SMRep
Simon Marlow's avatar
Simon Marlow committed
34 35

import Cmm
36
import CLabel
Simon Marlow's avatar
Simon Marlow committed
37 38 39 40 41 42 43 44 45 46 47

import Constants
import ClosureInfo
import CgStackery
import CmmUtils
import Maybes
import Id
import Name
import Bitmap
import Util
import StaticFlags
48
import Module
Simon Marlow's avatar
Simon Marlow committed
49
import FastString
50
import Outputable
51
import Unique
52

Simon Marlow's avatar
Simon Marlow committed
53
import Data.Bits
54 55 56 57 58 59 60 61 62 63 64 65 66 67

-------------------------------------------------------------------------
--
--	Making argument descriptors
--
--  An argument descriptor describes the layout of args on the stack,
--  both for 	* GC (stack-layout) purposes, and 
--		* saving/restoring registers when a heap-check fails
--
-- Void arguments aren't important, therefore (contrast constructSlowCall)
--
-------------------------------------------------------------------------

-- bring in ARG_P, ARG_N, etc.
Simon Marlow's avatar
Simon Marlow committed
68
#include "../includes/rts/storage/FunTypes.h"
69 70

-------------------------
71
argDescrType :: ArgDescr -> StgHalfWord
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
-- The "argument type" RTS field type
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
  | isBigLiveness liveness = ARG_GEN_BIG
  | otherwise		   = ARG_GEN


mkArgDescr :: Name -> [Id] -> FCode ArgDescr
mkArgDescr nm args 
  = case stdPattern arg_reps of
	Just spec_id -> return (ArgSpec spec_id)
	Nothing      -> do { liveness <- mkLiveness nm size bitmap
			   ; return (ArgGen liveness) }
  where
    arg_reps = filter nonVoidArg (map idCgRep args)
	-- Getting rid of voids eases matching of standard patterns

    bitmap   = mkBitmap arg_bits
    arg_bits = argBits arg_reps
    size     = length arg_bits

argBits :: [CgRep] -> [Bool]	-- True for non-ptr, False for ptr
argBits [] 		= []
argBits (PtrArg : args) = False : argBits args
argBits (arg    : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args

98
stdPattern :: [CgRep] -> Maybe StgHalfWord
99 100
stdPattern []          = Just ARG_NONE	-- just void args, probably

101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
stdPattern [PtrArg]    = Just ARG_P
stdPattern [FloatArg]  = Just ARG_F
stdPattern [DoubleArg] = Just ARG_D
stdPattern [LongArg]   = Just ARG_L
stdPattern [NonPtrArg] = Just ARG_N
	 
stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
stdPattern [NonPtrArg,PtrArg]    = Just ARG_NP
stdPattern [PtrArg,NonPtrArg]    = Just ARG_PN
stdPattern [PtrArg,PtrArg]       = Just ARG_PP

stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
stdPattern [NonPtrArg,NonPtrArg,PtrArg]    = Just ARG_NNP
stdPattern [NonPtrArg,PtrArg,NonPtrArg]    = Just ARG_NPN
stdPattern [NonPtrArg,PtrArg,PtrArg]	   = Just ARG_NPP
stdPattern [PtrArg,NonPtrArg,NonPtrArg]    = Just ARG_PNN
stdPattern [PtrArg,NonPtrArg,PtrArg]	   = Just ARG_PNP
stdPattern [PtrArg,PtrArg,NonPtrArg]	   = Just ARG_PPN
stdPattern [PtrArg,PtrArg,PtrArg]	   = Just ARG_PPP
	 
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg]	       = Just ARG_PPPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg]        = Just ARG_PPPPP
stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
Ian Lynagh's avatar
Ian Lynagh committed
124
stdPattern _ = Nothing
125 126 127 128 129 130 131 132


-------------------------------------------------------------------------
--
--	Liveness info
--
-------------------------------------------------------------------------

133 134 135 136 137 138 139 140
-- TODO: This along with 'mkArgDescr' should be unified
-- with 'CmmInfo.mkLiveness'.  However that would require
-- potentially invasive changes to the 'ClosureInfo' type.
-- For now, 'CmmInfo.mkLiveness' handles only continuations and
-- this one handles liveness everything else.  Another distinction
-- between these two is that 'CmmInfo.mkLiveness' information
-- about the stack layout, and this one is information about
-- the heap layout of PAPs.
141 142 143
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
  | size > mAX_SMALL_BITMAP_SIZE		-- Bitmap does not fit in one word
144
  = do	{ let lbl = mkBitmapLabel (getUnique name)
145
	; emitRODataLits "mkLiveness" lbl ( mkWordCLit (fromIntegral size)
146 147 148 149 150 151 152
		             : map mkWordCLit bits)
	; return (BigLiveness lbl) }
  
  | otherwise		-- Bitmap fits in one word
  = let
        small_bits = case bits of 
			[]  -> 0
153
                        [b] -> b
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
			_   -> panic "livenessToAddrMode"
    in
    return (smallLiveness size small_bits)

smallLiveness :: Int -> StgWord -> Liveness
smallLiveness size small_bits = SmallLiveness bits
  where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)

-------------------
isBigLiveness :: Liveness -> Bool
isBigLiveness (BigLiveness _)   = True
isBigLiveness (SmallLiveness _) = False

-------------------
mkLivenessCLit :: Liveness -> CmmLit
mkLivenessCLit (BigLiveness lbl)    = CmmLabel lbl
mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits


-------------------------------------------------------------------------
--
--		Bitmap describing register liveness
--		across GC when doing a "generic" heap check
--		(a RET_DYN stack frame).
--
-- NB. Must agree with these macros (currently in StgMacros.h): 
-- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
-------------------------------------------------------------------------

mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
mkRegLiveness regs ptrs nptrs
  = (fromIntegral nptrs `shiftL` 16) .|. 
    (fromIntegral ptrs  `shiftL` 24) .|.
    all_non_ptrs `xor` reg_bits regs
  where
    all_non_ptrs = 0xff

    reg_bits [] = 0
192
    reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
193 194 195 196 197 198 199 200 201 202 203 204
  	= (1 `shiftL` (i - 1)) .|. reg_bits regs
    reg_bits (_ : regs)
	= reg_bits regs
  
-------------------------------------------------------------------------
--
--		Pushing the arguments for a slow call
--
-------------------------------------------------------------------------

-- For a slow call, we must take a bunch of arguments and intersperse
-- some stg_ap_<pattern>_ret_info return addresses.
205 206 207 208 209 210
constructSlowCall
	:: [(CgRep,CmmExpr)]
	-> (CLabel,		-- RTS entry point for call
	   [(CgRep,CmmExpr)],	-- args to pass to the entry point
	   [(CgRep,CmmExpr)])	-- stuff to save on the stack

211 212
   -- don't forget the zero case
constructSlowCall [] 
213
  = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
214 215

constructSlowCall amodes
216
  = (stg_ap_pat, these, rest)
217
  where 
218
    stg_ap_pat = mkRtsApFastLabel arg_pat
219 220 221 222 223 224 225 226 227
    (arg_pat, these, rest) = matchSlowPattern amodes

-- | 'slowArgs' takes a list of function arguments and prepares them for
-- pushing on the stack for "extra" arguments to a function which requires
-- fewer arguments than we currently have.
slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
slowArgs [] = []
slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
  where	(arg_pat, args, rest) = matchSlowPattern amodes
228
	stg_ap_pat 	= mkCmmRetInfoLabel rtsPackageId arg_pat
229 230
  
matchSlowPattern :: [(CgRep,CmmExpr)] 
231
		 -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
232 233 234 235 236
matchSlowPattern amodes = (arg_pat, these, rest)
  where (arg_pat, n)  = slowCallPattern (map fst amodes)
	(these, rest) = splitAt n amodes

-- These cases were found to cover about 99% of all slow calls:
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
slowCallPattern :: [CgRep] -> (FastString, Int)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) 	    = (fsLit "stg_ap_ppppp", 5)
slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) 	= (fsLit "stg_ap_pppp", 4)
slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) 	= (fsLit "stg_ap_pppv", 4)
slowCallPattern (PtrArg: PtrArg: PtrArg: _)       	= (fsLit "stg_ap_ppp", 3)
slowCallPattern (PtrArg: PtrArg: VoidArg: _)       	= (fsLit "stg_ap_ppv", 3)
slowCallPattern (PtrArg: PtrArg: _)			= (fsLit "stg_ap_pp", 2)
slowCallPattern (PtrArg: VoidArg: _)			= (fsLit "stg_ap_pv", 2)
slowCallPattern (PtrArg: _)				= (fsLit "stg_ap_p", 1)
slowCallPattern (VoidArg: _)				= (fsLit "stg_ap_v", 1)
slowCallPattern (NonPtrArg: _)				= (fsLit "stg_ap_n", 1)
slowCallPattern (FloatArg: _)				= (fsLit "stg_ap_f", 1)
slowCallPattern (DoubleArg: _)				= (fsLit "stg_ap_d", 1)
slowCallPattern (LongArg: _)				= (fsLit "stg_ap_l", 1)
slowCallPattern _ 					= panic "CgStackery.slowCallPattern"
253 254 255 256 257 258 259 260

-------------------------------------------------------------------------
--
--		Return conventions
--
-------------------------------------------------------------------------

dataReturnConvPrim :: CgRep -> CmmReg
261 262
dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1 VGcPtr)
dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
263 264 265 266 267 268 269
dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"


-- getSequelAmode returns an amode which refers to an info table.  The info
Simon Marlow's avatar
Simon Marlow committed
270
-- table will always be of the RET_(BIG|SMALL) kind.  We're careful
271 272 273 274 275 276 277 278 279 280 281 282 283 284
-- not to handle real code pointers, just in case we're compiling for 
-- an unregisterised/untailcallish architecture, where info pointers and
-- code pointers aren't the same.
-- DIRE WARNING.
-- The OnStack case of sequelToAmode delivers an Amode which is only
-- valid just before the final control transfer, because it assumes
-- that Sp is pointing to the top word of the return address.  This
-- seems unclean but there you go.

getSequelAmode :: FCode CmmExpr
getSequelAmode
  = do	{ EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
	; case sequel of
	    OnStack -> do { sp_rel <- getSpRelOffset virt_sp
285
			  ; returnFC (CmmLoad sp_rel bWord) }
286

Simon Marlow's avatar
Simon Marlow committed
287
	    CaseAlts lbl _ _  -> returnFC (CmmLit (CmmLabel lbl))
288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331
	}

-------------------------------------------------------------------------
--
--		Register assignment
--
-------------------------------------------------------------------------

--  How to assign registers for 
--
--	1) Calling a fast entry point.
--	2) Returning an unboxed tuple.
--	3) Invoking an out-of-line PrimOp.
--
-- Registers are assigned in order.
-- 
-- If we run out, we don't attempt to assign any further registers (even
-- though we might have run out of only one kind of register); we just
-- return immediately with the left-overs specified.
-- 
-- The alternative version @assignAllRegs@ uses the complete set of
-- registers, including those that aren't mapped to real machine
-- registers.  This is used for calling special RTS functions and PrimOps
-- which expect their arguments to always be in the same registers.

assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
	:: [(CgRep,a)]		-- Arg or result values to assign
	-> ([(a, GlobalReg)],	-- Register assignment in same order
				-- for *initial segment of* input list
				--   (but reversed; doesn't matter)
				-- VoidRep args do not appear here
	    [(CgRep,a)])	-- Leftover arg or result values

assignCallRegs args
  = assign_regs args (mkRegTbl [node])
	-- The entry convention for a function closure
	-- never uses Node for argument passing; instead
	-- Node points to the function closure itself

assignPrimOpCallRegs args
 = assign_regs args (mkRegTbl_allRegs [])
	-- For primops, *all* arguments must be passed in registers

assignReturnRegs args
332 333 334 335 336 337 338 339 340 341 342 343
 -- when we have a single non-void component to return, use the normal
 -- unpointed return convention.  This make various things simpler: it
 -- means we can assume a consistent convention for IO, which is useful
 -- when writing code that relies on knowing the IO return convention in 
 -- the RTS (primops, especially exception-related primops).
 -- Also, the bytecode compiler assumes this when compiling
 -- case expressions and ccalls, so it only needs to know one set of
 -- return conventions.
 | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
    = ([(arg, r)], [])
 | otherwise
    = assign_regs args (mkRegTbl [])
344 345
	-- For returning unboxed tuples etc, 
	-- we use all regs
346 347
 where 
       non_void_args = filter ((/= VoidArg).fst) args
348 349 350 351 352 353 354

assign_regs :: [(CgRep,a)]     	-- Arg or result values to assign
	    -> AvailRegs	-- Regs still avail: Vanilla, Float, Double, Longs
	    -> ([(a, GlobalReg)], [(CgRep, a)])
assign_regs args supply
  = go args [] supply
  where
Ian Lynagh's avatar
Ian Lynagh committed
355
    go [] acc _ = (acc, [])	-- Return the results reversed (doesn't matter)
356
    go ((VoidArg,_) : args) acc supply 	-- Skip void arguments; they aren't passed, and
357
	= go args acc supply		-- there's nothing to bind them to
358 359 360 361 362 363 364 365
    go ((rep,arg) : args) acc supply 
	= case assign_reg rep supply of
		Just (reg, supply') -> go args ((arg,reg):acc) supply'
		Nothing	   	    -> (acc, (rep,arg):args) 	-- No more regs

assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
366
assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
367 368
assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
369
    -- PtrArg and NonPtrArg both go in a vanilla register
Ian Lynagh's avatar
Ian Lynagh committed
370
assign_reg _         _                  = Nothing
371 372 373 374 375 376 377 378 379 380 381 382 383 384


-------------------------------------------------------------------------
--
--		Register supplies
--
-------------------------------------------------------------------------

-- Vanilla registers can contain pointers, Ints, Chars.
-- Floats and doubles have separate register supplies.
--
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.

Ian Lynagh's avatar
Ian Lynagh committed
385
useVanillaRegs :: Int
386 387
useVanillaRegs | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Vanilla_REG
Ian Lynagh's avatar
Ian Lynagh committed
388
useFloatRegs :: Int
389 390
useFloatRegs   | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Float_REG
Ian Lynagh's avatar
Ian Lynagh committed
391
useDoubleRegs :: Int
392 393
useDoubleRegs  | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Double_REG
Ian Lynagh's avatar
Ian Lynagh committed
394
useLongRegs :: Int
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409
useLongRegs    | opt_Unregisterised = 0
	       | otherwise          = mAX_Real_Long_REG

vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos	 = regList useVanillaRegs
floatRegNos	 = regList useFloatRegs
doubleRegNos	 = regList useDoubleRegs
longRegNos       = regList useLongRegs

allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG
allFloatRegNos	 = regList mAX_Float_REG
allDoubleRegNos	 = regList mAX_Double_REG
allLongRegNos	 = regList mAX_Long_REG

Ian Lynagh's avatar
Ian Lynagh committed
410
regList :: Int -> [Int]
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426
regList n = [1 .. n]

type AvailRegs = ( [Int]   -- available vanilla regs.
		 , [Int]   -- floats
		 , [Int]   -- doubles
		 , [Int]   -- longs (int64 and word64)
		 )

mkRegTbl :: [GlobalReg] -> AvailRegs
mkRegTbl regs_in_use
  = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos

mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
mkRegTbl_allRegs regs_in_use
  = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos

Ian Lynagh's avatar
Ian Lynagh committed
427 428
mkRegTbl' :: [GlobalReg] -> [Int] -> [Int] -> [Int] -> [Int]
          -> ([Int], [Int], [Int], [Int])
429 430 431
mkRegTbl' regs_in_use vanillas floats doubles longs
  = (ok_vanilla, ok_float, ok_double, ok_long)
  where
432 433
    ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) vanillas
		    -- ptrhood isn't looked at, hence we can use any old rep.
434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
    ok_float   = mapCatMaybes (select FloatReg)	  floats
    ok_double  = mapCatMaybes (select DoubleReg)  doubles
    ok_long    = mapCatMaybes (select LongReg)    longs   

    select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
	-- one we've unboxed the Int, we make a GlobalReg
	-- and see if it is already in use; if not, return its number.

    select mk_reg_fun cand
      = let
	    reg = mk_reg_fun cand
	in
	if reg `not_elem` regs_in_use
	then Just cand
	else Nothing
      where
	not_elem = isn'tIn "mkRegTbl"