[commit: ghc] master: Implement shortcuts for slow calls (#6084) (4d1ea48)
git at git.haskell.org
git at git.haskell.org
Thu Nov 28 12:52:33 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/4d1ea482885481073d2fee0ea0355848b9d853a1/ghc
>---------------------------------------------------------------
commit 4d1ea482885481073d2fee0ea0355848b9d853a1
Author: Simon Marlow <marlowsd at gmail.com>
Date: Thu Nov 28 09:43:58 2013 +0000
Implement shortcuts for slow calls (#6084)
>---------------------------------------------------------------
4d1ea482885481073d2fee0ea0355848b9d853a1
compiler/cmm/CmmInfo.hs | 17 ++++++++++
compiler/cmm/CmmUtils.hs | 9 ++++++
compiler/codeGen/StgCmmLayout.hs | 50 +++++++++++++++++++++++++-----
utils/deriveConstants/DeriveConstants.hs | 4 +--
4 files changed, 71 insertions(+), 9 deletions(-)
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 2851a47..641f29b 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -23,6 +23,7 @@ module CmmInfo (
infoTablePtrs,
infoTableNonPtrs,
funInfoTable,
+ funInfoArity,
-- info table sizes and offsets
stdInfoTableSizeW,
@@ -492,6 +493,22 @@ funInfoTable dflags info_ptr
= cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
-- 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
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index a5acffb..f6d1ddd 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -31,6 +31,7 @@ module CmmUtils(
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
+ cmmToWord,
isTrivialCmmExpr, hasNoGlobalRegs,
@@ -331,6 +332,14 @@ cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dfl
blankWord :: DynFlags -> CmmStatic
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
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 08f4e29..9a73491 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -176,16 +176,52 @@ directCall conv lbl arity stg_args
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
-- (slowCall fun args) applies fun to args, returning the results to Sequel
slowCall fun stg_args
- = do { dflags <- getDynFlags
- ; argsreps <- getArgRepsAmodes stg_args
- ; let (rts_fun, arity) = slowCallPattern (map fst argsreps)
- ; r <- direct_call "slow_call" NativeNodeCall
+ = do dflags <- getDynFlags
+ argsreps <- getArgRepsAmodes stg_args
+ let (rts_fun, arity) = slowCallPattern (map fst argsreps)
+
+ (r, slow_code) <- getCodeR $ do
+ r <- direct_call "slow_call" NativeNodeCall
(mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
- ; emitComment $ mkFastString ("slow_call for " ++
+ emitComment $ mkFastString ("slow_call for " ++
showSDoc dflags (ppr 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
--------------
diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs
index 5b9b7c0..10df61c 100644
--- a/utils/deriveConstants/DeriveConstants.hs
+++ b/utils/deriveConstants/DeriveConstants.hs
@@ -538,13 +538,13 @@ wanteds = concat
,structSize C "StgFunInfoExtraFwd"
,structField C "StgFunInfoExtraFwd" "slow_apply"
,structField C "StgFunInfoExtraFwd" "fun_type"
- ,structField C "StgFunInfoExtraFwd" "arity"
+ ,structFieldH Both "StgFunInfoExtraFwd" "arity"
,structField_ C "StgFunInfoExtraFwd_bitmap" "StgFunInfoExtraFwd" "b.bitmap"
,structSize Both "StgFunInfoExtraRev"
,structField C "StgFunInfoExtraRev" "slow_apply_offset"
,structField C "StgFunInfoExtraRev" "fun_type"
- ,structField C "StgFunInfoExtraRev" "arity"
+ ,structFieldH Both "StgFunInfoExtraRev" "arity"
,structField_ C "StgFunInfoExtraRev_bitmap" "StgFunInfoExtraRev" "b.bitmap"
,structField C "StgLargeBitmap" "size"
More information about the ghc-commits
mailing list