import Bitmap
import Data.Bits
-import Maybes
import Constants
import Util
import Data.List
import Outputable
-import FastString ( mkFastString, LitString, sLit )
+import FastString ( mkFastString, FastString, fsLit )
------------------------------------------------------------------------
-- Call and return sequences
-- return (x,y)
-- If the sequel is AssignTo [p,q]
-- p=x; q=y;
-emitReturn results
- = do { adjustHpBackwards
- ; sequel <- getSequel;
- ; updfr_off <- getUpdFrameOff
- ; case sequel of
- Return _ -> emit (mkReturnSimple results updfr_off)
- AssignTo regs _ -> emit (mkMultiAssign regs results)
- }
+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 -> CmmExpr -> [CmmExpr] -> FCode ()
+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ()
-- (cgCall fun args) makes a call to the entry-code of 'fun',
-- passing 'args', and returning the results to the current sequel
-emitCall conv fun args
+emitCall convs@(callConv, _) fun args
= do { adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
- ; emit $ mkComment $ mkFastString "emitcall"
+ ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
; case sequel of
- Return _ -> emit (mkForeignJump conv fun args updfr_off)
- AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off)
+ Return _ -> emit (mkForeignJump callConv fun args updfr_off)
+ AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off)
}
adjustHpBackwards :: FCode ()
<+> ppr args <+> ppr reps )
| null rest_reps -- Precisely the right number of arguments
- = emitCall Native target args
+ = emitCall (NativeDirectCall, NativeReturn) target args
| otherwise -- Over-saturated call
= ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord
- ; let srt = pprTrace "Urk! SRT for over-sat call"
- (ppr lbl) NoC_SRT
- -- XXX: what if rest_args contains static refs?
- ; withSequel (AssignTo [pap_id] srt)
- (emitCall Native target fast_args)
+ ; withSequel (AssignTo [pap_id] True)
+ (emitCall (NativeDirectCall, NativeReturn) target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
where
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 (ptext rts_fun))
+ " with pat " ++ showSDoc (ftext rts_fun))
emit (mkAssign nodeReg fun <*> call)
where
(rts_fun, arity) = slowCallPattern reps
-- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [LRep] -> (LitString, Arity)
+slowCallPattern :: [LRep] -> (FastString, Arity)
-- Returns the generic apply function and arity
-slowCallPattern (P: P: P: P: P: P: _) = (sLit "stg_ap_pppppp", 6)
-slowCallPattern (P: P: P: P: P: _) = (sLit "stg_ap_ppppp", 5)
-slowCallPattern (P: P: P: P: _) = (sLit "stg_ap_pppp", 4)
-slowCallPattern (P: P: P: V: _) = (sLit "stg_ap_pppv", 4)
-slowCallPattern (P: P: P: _) = (sLit "stg_ap_ppp", 3)
-slowCallPattern (P: P: V: _) = (sLit "stg_ap_ppv", 3)
-slowCallPattern (P: P: _) = (sLit "stg_ap_pp", 2)
-slowCallPattern (P: V: _) = (sLit "stg_ap_pv", 2)
-slowCallPattern (P: _) = (sLit "stg_ap_p", 1)
-slowCallPattern (V: _) = (sLit "stg_ap_v", 1)
-slowCallPattern (N: _) = (sLit "stg_ap_n", 1)
-slowCallPattern (F: _) = (sLit "stg_ap_f", 1)
-slowCallPattern (D: _) = (sLit "stg_ap_d", 1)
-slowCallPattern (L: _) = (sLit "stg_ap_l", 1)
-slowCallPattern [] = (sLit "stg_ap_0", 0)
+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)
-------------------------------------------------------------------------
-------------------------------------------------------------------------
-- bring in ARG_P, ARG_N, etc.
-#include "../includes/StgFun.h"
+#include "../includes/rts/storage/FunTypes.h"
-------------------------
-- argDescrType :: ArgDescr -> StgHalfWord
= case reps of
[] -> Just ARG_NONE -- just void args, probably
[N] -> Just ARG_N
- [P] -> Just ARG_N
+ [P] -> Just ARG_P
[F] -> Just ARG_F
[D] -> Just ARG_D
[L] -> Just ARG_L
-> FCode ()
emitClosureProcAndInfoTable top_lvl bndr cl_info args body
= do { let lf_info = closureLFInfo cl_info
- -- Bind the binder itself, but only if it's not a top-level
+ -- Bind the binder itself, but only if it's not a top-level
-- binding. We need non-top let-bindings to refer to the
-- top-level binding, which this binding would incorrectly shadow.
; node <- if top_lvl then return $ idToReg (NonVoid bndr)
else bindToReg (NonVoid bndr) lf_info
- ; arg_regs <-
- pprTrace "bindArgsToRegs" (ppr args) $
- bindArgsToRegs args
- ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs)
+ ; 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)
}
-- Data constructors need closures, but not with all the argument handling
-- needed for functions. The shared part goes here.
-emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
-emitClosureAndInfoTable cl_info args body
+emitClosureAndInfoTable ::
+ ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable cl_info conv args body
= do { info <- mkCmmInfo cl_info
; blks <- getCode body
- ; emitProc info (infoLblToEntryLbl info_lbl) args blks
+ ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks
}
where
info_lbl = infoTableLabelFromCI cl_info