X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=0e98e148ae5b50d09f8e8fe8fa602583215bb8e7;hb=984a288119983912d40a80845c674ee4b83a19ce;hp=dbc97d49d828743a989542da7743d7f7dddda8f8;hpb=31a9d04804d9cacda35695c5397590516b964964;p=ghc-hetmet.git diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index dbc97d4..0e98e14 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -59,12 +59,11 @@ import StaticFlags 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 @@ -90,17 +89,17 @@ emitReturn results ; 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: " ++ show sequel) ; case sequel of - Return _ -> emit (mkForeignJump conv fun args updfr_off) - AssignTo res_regs _ -> 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 () @@ -161,13 +160,13 @@ direct_call caller lbl arity args reps <+> 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 ; withSequel (AssignTo [pap_id] True) - (emitCall Native target fast_args) + (emitCall (NativeDirectCall, NativeReturn) target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where @@ -181,29 +180,29 @@ 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 (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) ------------------------------------------------------------------------- @@ -314,7 +313,7 @@ mkVirtHeapOffsets is_thunk things ------------------------------------------------------------------------- -- bring in ARG_P, ARG_N, etc. -#include "../includes/StgFun.h" +#include "../includes/rts/storage/FunTypes.h" ------------------------- -- argDescrType :: ArgDescr -> StgHalfWord @@ -350,7 +349,7 @@ stdPattern reps = 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 @@ -467,13 +466,15 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> 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 + ; let node_points = nodeMustPointToIt lf_info ; arg_regs <- bindArgsToRegs args - ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs) + ; let args' = if node_points then (node : arg_regs) else arg_regs + ; emitClosureAndInfoTable cl_info args' $ body (node, arg_regs) } -- Data constructors need closures, but not with all the argument handling @@ -482,7 +483,9 @@ emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode () emitClosureAndInfoTable cl_info args body = do { info <- mkCmmInfo cl_info ; blks <- getCode body - ; emitProc info (infoLblToEntryLbl info_lbl) args blks + ; let conv = if nodeMustPointToIt (closureLFInfo cl_info) then NativeNodeCall + else NativeDirectCall + ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks } where info_lbl = infoTableLabelFromCI cl_info