Commit 4d1ea482 authored by Simon Marlow's avatar Simon Marlow

Implement shortcuts for slow calls (#6084)

parent 1df2116c
...@@ -23,6 +23,7 @@ module CmmInfo ( ...@@ -23,6 +23,7 @@ module CmmInfo (
infoTablePtrs, infoTablePtrs,
infoTableNonPtrs, infoTableNonPtrs,
funInfoTable, funInfoTable,
funInfoArity,
-- info table sizes and offsets -- info table sizes and offsets
stdInfoTableSizeW, stdInfoTableSizeW,
...@@ -492,6 +493,22 @@ funInfoTable dflags info_ptr ...@@ -492,6 +493,22 @@ funInfoTable dflags info_ptr
= cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
-- Past the entry code pointer -- Past the entry code pointer
-- Takes the info pointer of a function, returns the function's arity
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
funInfoArity dflags iptr
= cmmToWord dflags (cmmLoadIndex dflags rep fun_info offset)
where
fun_info = funInfoTable dflags iptr
rep = cmmBits (widthFromBytes rep_bytes)
(rep_bytes, offset)
| tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraFwd_arity pc
, oFFSET_StgFunInfoExtraFwd_arity dflags )
| otherwise = ( pc_REP_StgFunInfoExtraRev_arity pc
, oFFSET_StgFunInfoExtraRev_arity dflags )
pc = sPlatformConstants (settings dflags)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
-- Info table sizes & offsets -- Info table sizes & offsets
......
...@@ -31,6 +31,7 @@ module CmmUtils( ...@@ -31,6 +31,7 @@ module CmmUtils(
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord, cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
cmmToWord,
isTrivialCmmExpr, hasNoGlobalRegs, isTrivialCmmExpr, hasNoGlobalRegs,
...@@ -331,6 +332,14 @@ cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dfl ...@@ -331,6 +332,14 @@ cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dfl
blankWord :: DynFlags -> CmmStatic blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags) blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
cmmToWord dflags e
| w == word = e
| otherwise = CmmMachOp (MO_UU_Conv w word) [e]
where
w = cmmExprWidth dflags e
word = wordWidth dflags
--------------------------------------------------- ---------------------------------------------------
-- --
-- CmmExpr predicates -- CmmExpr predicates
......
...@@ -176,16 +176,52 @@ directCall conv lbl arity stg_args ...@@ -176,16 +176,52 @@ directCall conv lbl arity stg_args
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
-- (slowCall fun args) applies fun to args, returning the results to Sequel -- (slowCall fun args) applies fun to args, returning the results to Sequel
slowCall fun stg_args slowCall fun stg_args
= do { dflags <- getDynFlags = do dflags <- getDynFlags
; argsreps <- getArgRepsAmodes stg_args argsreps <- getArgRepsAmodes stg_args
; let (rts_fun, arity) = slowCallPattern (map fst argsreps) let (rts_fun, arity) = slowCallPattern (map fst argsreps)
; r <- direct_call "slow_call" NativeNodeCall
(r, slow_code) <- getCodeR $ do
r <- direct_call "slow_call" NativeNodeCall
(mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
; emitComment $ mkFastString ("slow_call for " ++ emitComment $ mkFastString ("slow_call for " ++
showSDoc dflags (ppr fun) ++ showSDoc dflags (ppr fun) ++
" with pat " ++ unpackFS rts_fun) " with pat " ++ unpackFS rts_fun)
; return r return r
}
let n_args = length stg_args
if n_args > arity && optLevel dflags >= 2
then do
fast_code <- getCode $
emitCall (NativeNodeCall, NativeReturn)
(entryCode dflags (closureInfoPtr dflags fun))
(nonVArgs ((P,Just fun):argsreps))
slow_lbl <- newLabelC
fast_lbl <- newLabelC
is_tagged_lbl <- newLabelC
end_lbl <- newLabelC
funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
let correct_arity = cmmEqWord dflags (funInfoArity dflags funv)
(mkIntExpr dflags n_args)
pprTrace "fast call" (int n_args) $ return ()
emit (mkCbranch (cmmIsTagged dflags funv) is_tagged_lbl slow_lbl
<*> mkLabel is_tagged_lbl
<*> mkCbranch correct_arity fast_lbl slow_lbl
<*> mkLabel fast_lbl
<*> fast_code
<*> mkBranch end_lbl
<*> mkLabel slow_lbl
<*> slow_code
<*> mkLabel end_lbl)
return r
else do
emit slow_code
return r
-------------- --------------
......
...@@ -538,13 +538,13 @@ wanteds = concat ...@@ -538,13 +538,13 @@ wanteds = concat
,structSize C "StgFunInfoExtraFwd" ,structSize C "StgFunInfoExtraFwd"
,structField C "StgFunInfoExtraFwd" "slow_apply" ,structField C "StgFunInfoExtraFwd" "slow_apply"
,structField C "StgFunInfoExtraFwd" "fun_type" ,structField C "StgFunInfoExtraFwd" "fun_type"
,structField C "StgFunInfoExtraFwd" "arity" ,structFieldH Both "StgFunInfoExtraFwd" "arity"
,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap" ,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
,structSize Both "StgFunInfoExtraRev" ,structSize Both "StgFunInfoExtraRev"
,structField C "StgFunInfoExtraRev" "slow_apply_offset" ,structField C "StgFunInfoExtraRev" "slow_apply_offset"
,structField C "StgFunInfoExtraRev" "fun_type" ,structField C "StgFunInfoExtraRev" "fun_type"
,structField C "StgFunInfoExtraRev" "arity" ,structFieldH Both "StgFunInfoExtraRev" "arity"
,structField_ C "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap" ,structField_ C "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
,structField C "StgLargeBitmap" "size" ,structField C "StgLargeBitmap" "size"
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment