module StgCmmLayout (
mkArgDescr,
emitCall, emitReturn,
emitClosureProcAndInfoTable,
emitClosureAndInfoTable,
slowCall, directCall,
mkVirtHeapOffsets, getHpRelOffset, hpRel,
stdInfoTableSizeB,
entryCode, closureInfoPtr,
getConstrTag,
cmmGetClosureType,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable, makeRelativeRefTo
) where
#include "HsVersions.h"
import StgCmmClosure
import StgCmmEnv
import StgCmmTicky
import StgCmmUtils
import StgCmmMonad
import MkZipCfgCmm
import SMRep
import CmmUtils
import Cmm
import CLabel
import StgSyn
import DataCon
import Id
import Name
import TyCon ( PrimRep(..) )
import Unique
import BasicTypes ( Arity )
import StaticFlags
import Bitmap
import Data.Bits
import Constants
import Util
import Data.List
import Outputable
import FastString ( mkFastString, FastString, fsLit )
emitReturn :: [CmmExpr] -> FCode ()
emitReturn results
= do { sequel <- getSequel;
; updfr_off <- getUpdFrameOff
; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
; case sequel of
Return _ ->
do { adjustHpBackwards
; emit (mkReturnSimple results updfr_off) }
AssignTo regs adjust ->
do { if adjust then adjustHpBackwards else return ()
; emit (mkMultiAssign regs results) }
}
emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ()
emitCall convs@(callConv, _) fun args
= do { adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
; case sequel of
Return _ -> emit (mkForeignJump callConv fun args updfr_off)
AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off)
}
adjustHpBackwards :: FCode ()
adjustHpBackwards
= do { hp_usg <- getHpUsage
; let rHp = realHp hp_usg
vHp = virtHp hp_usg
adjust_words = vHp rHp
; new_hp <- getHpRelOffset vHp
; emit (if adjust_words == 0
then mkNop
else mkAssign hpReg new_hp)
; tickyAllocHeap adjust_words
; setRealHp vHp
}
directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
directCall lbl arity stg_args
= do { cmm_args <- getNonVoidArgAmodes stg_args
; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) }
slowCall :: CmmExpr -> [StgArg] -> FCode ()
slowCall fun stg_args
= do { cmm_args <- getNonVoidArgAmodes stg_args
; slow_call fun cmm_args (argsLReps stg_args) }
direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
direct_call caller lbl arity args reps
| debugIsOn && arity > length reps
=
pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
<+> ppr args <+> ppr reps )
| null rest_reps
= emitCall (NativeDirectCall, NativeReturn) target args
| otherwise
= ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord
; withSequel (AssignTo [pap_id] True)
(emitCall (NativeDirectCall, NativeReturn) target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
where
target = CmmLit (CmmLabel lbl)
(initial_reps, rest_reps) = splitAt arity reps
arg_arity = count isNonV initial_reps
(fast_args, rest_args) = splitAt arg_arity args
slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode ()
slow_call fun args reps
= do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
" with pat " ++ showSDoc (ftext rts_fun))
emit (mkAssign nodeReg fun <*> call)
where
(rts_fun, arity) = slowCallPattern reps
slowCallPattern :: [LRep] -> (FastString, Arity)
slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4)
slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4)
slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3)
slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3)
slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2)
slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2)
slowCallPattern (P: _) = (fsLit "stg_ap_p", 1)
slowCallPattern (V: _) = (fsLit "stg_ap_v", 1)
slowCallPattern (N: _) = (fsLit "stg_ap_n", 1)
slowCallPattern (F: _) = (fsLit "stg_ap_f", 1)
slowCallPattern (D: _) = (fsLit "stg_ap_d", 1)
slowCallPattern (L: _) = (fsLit "stg_ap_l", 1)
slowCallPattern [] = (fsLit "stg_ap_0", 0)
data LRep = P
| N
| L
| V
| F
| D
instance Outputable LRep where
ppr P = text "P"
ppr N = text "N"
ppr L = text "L"
ppr V = text "V"
ppr F = text "F"
ppr D = text "D"
toLRep :: PrimRep -> LRep
toLRep VoidRep = V
toLRep PtrRep = P
toLRep IntRep = N
toLRep WordRep = N
toLRep AddrRep = N
toLRep Int64Rep = L
toLRep Word64Rep = L
toLRep FloatRep = F
toLRep DoubleRep = D
isNonV :: LRep -> Bool
isNonV V = False
isNonV _ = True
argsLReps :: [StgArg] -> [LRep]
argsLReps = map (toLRep . argPrimRep)
lRepSizeW :: LRep -> WordOff
lRepSizeW N = 1
lRepSizeW P = 1
lRepSizeW F = 1
lRepSizeW L = wORD64_SIZE `quot` wORD_SIZE
lRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE
lRepSizeW V = 0
hpRel :: VirtualHpOffset
-> VirtualHpOffset
-> WordOff
hpRel hp off = off hp
getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
getHpRelOffset virtual_offset
= do { hp_usg <- getHpUsage
; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
mkVirtHeapOffsets
:: Bool
-> [(PrimRep,a)]
-> (WordOff,
WordOff,
[(NonVoid a, VirtualHpOffset)])
mkVirtHeapOffsets is_thunk things
= let non_void_things = filterOut (isVoidRep . fst) things
(ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things
(wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
(tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
in
(tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
where
hdr_size | is_thunk = thunkHdrSize
| otherwise = fixedHdrSize
computeOffset wds_so_far (rep, thing)
= (wds_so_far + lRepSizeW (toLRep rep),
(NonVoid thing, hdr_size + wds_so_far))
#include "../includes/rts/storage/FunTypes.h"
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 isNonV (map (toLRep . idPrimRep) args)
bitmap = mkBitmap arg_bits
arg_bits = argBits arg_reps
size = length arg_bits
argBits :: [LRep] -> [Bool]
argBits [] = []
argBits (P : args) = False : argBits args
argBits (arg : args) = take (lRepSizeW arg) (repeat True) ++ argBits args
stdPattern :: [LRep] -> Maybe StgHalfWord
stdPattern reps
= case reps of
[] -> Just ARG_NONE
[N] -> Just ARG_N
[P] -> Just ARG_P
[F] -> Just ARG_F
[D] -> Just ARG_D
[L] -> Just ARG_L
[N,N] -> Just ARG_NN
[N,P] -> Just ARG_NP
[P,N] -> Just ARG_PN
[P,P] -> Just ARG_PP
[N,N,N] -> Just ARG_NNN
[N,N,P] -> Just ARG_NNP
[N,P,N] -> Just ARG_NPN
[N,P,P] -> Just ARG_NPP
[P,N,N] -> Just ARG_PNN
[P,N,P] -> Just ARG_PNP
[P,P,N] -> Just ARG_PPN
[P,P,P] -> Just ARG_PPP
[P,P,P,P] -> Just ARG_PPPP
[P,P,P,P,P] -> Just ARG_PPPPP
[P,P,P,P,P,P] -> Just ARG_PPPPPP
_ -> Nothing
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE
= do { let lbl = mkBitmapLabel (getUnique name)
; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
: map mkWordCLit bits)
; return (BigLiveness lbl) }
| otherwise
= let
small_bits = case bits of
[] -> 0
[b] -> fromIntegral b
_ -> 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)
emitClosureProcAndInfoTable :: Bool
-> Id
-> ClosureInfo
-> [NonVoid Id]
-> ((LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable top_lvl bndr cl_info args body
= do { let lf_info = closureLFInfo cl_info
; node <- if top_lvl then return $ idToReg (NonVoid bndr)
else bindToReg (NonVoid bndr) lf_info
; let node_points = nodeMustPointToIt lf_info
; arg_regs <- bindArgsToRegs args
; let args' = if node_points then (node : arg_regs) else arg_regs
conv = if nodeMustPointToIt lf_info
then NativeNodeCall else NativeDirectCall
; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs)
}
emitClosureAndInfoTable ::
ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable cl_info conv args body
= do { info <- mkCmmInfo cl_info
; blks <- getCode body
; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks
}
where
info_lbl = infoTableLabelFromCI cl_info
mkCmmInfo :: ClosureInfo -> FCode CmmInfo
mkCmmInfo cl_info
= do { info <- closureTypeInfo cl_info k_with_con_name return
; prof <- if opt_SccProfilingOn then
do fd_lit <- mkStringCLit (closureTypeDescr cl_info)
ad_lit <- mkStringCLit (closureValDescr cl_info)
return $ ProfilingInfo fd_lit ad_lit
else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
; return (CmmInfo gc_target Nothing
(CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) }
where
k_with_con_name con_info con info_lbl =
do cstr <- mkByteStringCLit $ dataConIdentity con
return $ con_info $ makeRelativeRefTo info_lbl cstr
cl_type = smRepClosureTypeInt (closureSMRep cl_info)
gc_target = Nothing
stdInfoTableSizeW :: WordOff
stdInfoTableSizeW
= size_fixed + size_prof
where
size_fixed = 2
size_prof | opt_SccProfilingOn = 2
| otherwise = 0
stdInfoTableSizeB :: ByteOff
stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
stdSrtBitmapOffset :: ByteOff
stdSrtBitmapOffset = stdInfoTableSizeB hALF_WORD_SIZE
stdClosureTypeOffset :: ByteOff
stdClosureTypeOffset = stdInfoTableSizeB wORD_SIZE
stdPtrsOffset, stdNonPtrsOffset :: ByteOff
stdPtrsOffset = stdInfoTableSizeB 2*wORD_SIZE
stdNonPtrsOffset = stdInfoTableSizeB 2*wORD_SIZE + hALF_WORD_SIZE
closureInfoPtr :: CmmExpr -> CmmExpr
closureInfoPtr e = CmmLoad e bWord
entryCode :: CmmExpr -> CmmExpr
entryCode e | tablesNextToCode = e
| otherwise = CmmLoad e bWord
getConstrTag :: CmmExpr -> CmmExpr
getConstrTag closure_ptr
= CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
where
info_table = infoTable (closureInfoPtr closure_ptr)
cmmGetClosureType :: CmmExpr -> CmmExpr
cmmGetClosureType closure_ptr
= CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
where
info_table = infoTable (closureInfoPtr closure_ptr)
infoTable :: CmmExpr -> CmmExpr
infoTable info_ptr
| tablesNextToCode = cmmOffsetB info_ptr ( stdInfoTableSizeB)
| otherwise = cmmOffsetW info_ptr 1
infoTableConstrTag :: CmmExpr -> CmmExpr
infoTableConstrTag = infoTableSrtBitmap
infoTableSrtBitmap :: CmmExpr -> CmmExpr
infoTableSrtBitmap info_tbl
= CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
infoTableClosureType :: CmmExpr -> CmmExpr
infoTableClosureType info_tbl
= CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
infoTablePtrs :: CmmExpr -> CmmExpr
infoTablePtrs info_tbl
= CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
infoTableNonPtrs :: CmmExpr -> CmmExpr
infoTableNonPtrs info_tbl
= CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
funInfoTable :: CmmExpr -> CmmExpr
funInfoTable info_ptr
| tablesNextToCode
= cmmOffsetB info_ptr ( stdInfoTableSizeB sIZEOF_StgFunInfoExtraRev)
| otherwise
= cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
makeRelativeRefTo info_lbl (CmmLabel lbl)
| tablesNextToCode
= CmmLabelDiffOff lbl info_lbl 0
makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
| tablesNextToCode
= CmmLabelDiffOff lbl info_lbl off
makeRelativeRefTo _ lit = lit