Implement shortcuts for slow calls that would require PAPs (#6084)

4 files changed, 71 insertions, 9 deletions

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 2851a471b4..641f29b880 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 a5acffb2f7..f6d1ddde58 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 84ff21b3d0..84736429bc 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 5b9b7c0bd9..10df61ca7d 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"