+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
-
module CgCallConv (
-- Argument descriptors
mkArgDescr, argDescrType,
-- Liveness
- isBigLiveness, buildContLiveness, mkRegLiveness,
+ isBigLiveness, mkRegLiveness,
smallLiveness, mkLivenessCLit,
-- Register assignment
getSequelAmode
) where
-#include "HsVersions.h"
-
import CgUtils
import CgMonad
import SMRep
#include "../includes/StgFun.h"
-------------------------
-argDescrType :: ArgDescr -> Int
+argDescrType :: ArgDescr -> StgHalfWord
-- The "argument type" RTS field type
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
argBits (PtrArg : args) = False : argBits args
argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
-stdPattern :: [CgRep] -> Maybe Int
+stdPattern :: [CgRep] -> Maybe StgHalfWord
stdPattern [] = Just ARG_NONE -- just void args, probably
stdPattern [PtrArg] = Just ARG_P
--
-------------------------------------------------------------------------
+-- 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.
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
-- don't forget the zero case
constructSlowCall []
- = (mkRtsApFastLabel SLIT("stg_ap_0"), [], [])
+ = (mkRtsApFastLabel (sLit "stg_ap_0"), [], [])
constructSlowCall amodes
= (stg_ap_pat, these, rest)
(these, rest) = splitAt n amodes
-- These cases were found to cover about 99% of all slow calls:
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppppp"), 5)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppp"), 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_pppv"), 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_ppp"), 3)
-slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (SLIT("stg_ap_ppv"), 3)
-slowCallPattern (PtrArg: PtrArg: _) = (SLIT("stg_ap_pp"), 2)
-slowCallPattern (PtrArg: VoidArg: _) = (SLIT("stg_ap_pv"), 2)
-slowCallPattern (PtrArg: _) = (SLIT("stg_ap_p"), 1)
-slowCallPattern (VoidArg: _) = (SLIT("stg_ap_v"), 1)
-slowCallPattern (NonPtrArg: _) = (SLIT("stg_ap_n"), 1)
-slowCallPattern (FloatArg: _) = (SLIT("stg_ap_f"), 1)
-slowCallPattern (DoubleArg: _) = (SLIT("stg_ap_d"), 1)
-slowCallPattern (LongArg: _) = (SLIT("stg_ap_l"), 1)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppppp", 6)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppppp", 5)
+slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppp", 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_pppv", 4)
+slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppp", 3)
+slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_ppv", 3)
+slowCallPattern (PtrArg: PtrArg: _) = (sLit "stg_ap_pp", 2)
+slowCallPattern (PtrArg: VoidArg: _) = (sLit "stg_ap_pv", 2)
+slowCallPattern (PtrArg: _) = (sLit "stg_ap_p", 1)
+slowCallPattern (VoidArg: _) = (sLit "stg_ap_v", 1)
+slowCallPattern (NonPtrArg: _) = (sLit "stg_ap_n", 1)
+slowCallPattern (FloatArg: _) = (sLit "stg_ap_f", 1)
+slowCallPattern (DoubleArg: _) = (sLit "stg_ap_d", 1)
+slowCallPattern (LongArg: _) = (sLit "stg_ap_l", 1)
slowCallPattern _ = panic "CgStackery.slowCallPattern"
-------------------------------------------------------------------------
-------------------------------------------------------------------------
--
--- Build a liveness mask for the current stack
---
--------------------------------------------------------------------------
-
--- There are four kinds of things on the stack:
---
--- - pointer variables (bound in the environment)
--- - non-pointer variables (bound in the environment)
--- - free slots (recorded in the stack free list)
--- - non-pointer data slots (recorded in the stack free list)
---
--- We build up a bitmap of non-pointer slots by searching the environment
--- for all the pointer variables, and subtracting these from a bitmap
--- with initially all bits set (up to the size of the stack frame).
-
-buildContLiveness :: Name -- Basis for label (only)
- -> [VirtualSpOffset] -- Live stack slots
- -> FCode Liveness
-buildContLiveness name live_slots
- = do { stk_usg <- getStkUsage
- ; let StackUsage { realSp = real_sp,
- frameSp = frame_sp } = stk_usg
-
- start_sp :: VirtualSpOffset
- start_sp = real_sp - retAddrSizeW
- -- In a continuation, we want a liveness mask that
- -- starts from just after the return address, which is
- -- on the stack at real_sp.
-
- frame_size :: WordOff
- frame_size = start_sp - frame_sp
- -- real_sp points to the frame-header for the current
- -- stack frame, and the end of this frame is frame_sp.
- -- The size is therefore real_sp - frame_sp - retAddrSizeW
- -- (subtract one for the frame-header = return address).
-
- rel_slots :: [WordOff]
- rel_slots = sortLe (<=)
- [ start_sp - ofs -- Get slots relative to top of frame
- | ofs <- live_slots ]
-
- bitmap = intsToReverseBitmap frame_size rel_slots
-
- ; WARN( not (all (>=0) rel_slots),
- ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
- mkLiveness name frame_size bitmap }
-
-
--------------------------------------------------------------------------
---
-- Register assignment
--
-------------------------------------------------------------------------
-- For primops, *all* arguments must be passed in registers
assignReturnRegs args
- = assign_regs args (mkRegTbl [])
+ -- 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 [])
-- For returning unboxed tuples etc,
-- we use all regs
+ where
+ non_void_args = filter ((/= VoidArg).fst) args
assign_regs :: [(CgRep,a)] -- Arg or result values to assign
-> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs
projects / ghc-hetmet.git / blobdiff