X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=eddf257e5fb100922ab5f88db81d3fd7e2e0cd06;hp=47df62162200725101af8aa6b2aa2c49ca307cbd;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=5d1c70a506f366eca47464f2a354de8cc0d9a795 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 47df621..eddf257 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module StgCmmLayout ( mkArgDescr, emitCall, emitReturn, @@ -42,10 +35,11 @@ import StgCmmTicky import StgCmmUtils import StgCmmMonad -import MkZipCfgCmm +import MkGraph import SMRep +import CmmDecl +import CmmExpr import CmmUtils -import Cmm import CLabel import StgSyn import DataCon @@ -59,12 +53,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 @@ -161,13 +154,13 @@ direct_call caller lbl arity args reps <+> ppr args <+> ppr reps ) | null rest_reps -- Precisely the right number of arguments - = emitCall (NativeCall, NativeReturn) 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 (NativeCall, NativeReturn) target fast_args) + (emitCall (NativeDirectCall, NativeReturn) target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where @@ -181,29 +174,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 +307,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 +343,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 @@ -401,7 +394,7 @@ mkLiveness name size bits = let small_bits = case bits of [] -> 0 - [b] -> fromIntegral b + [b] -> b _ -> panic "livenessToAddrMode" in return (smallLiveness size small_bits) @@ -463,33 +456,39 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> Id -- name of the closure -> ClosureInfo -- lots of info abt the closure -> [NonVoid Id] -- incoming arguments - -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body + -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> 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 + conv = if nodeMustPointToIt lf_info then NativeNodeCall + else NativeDirectCall + (offset, _) = mkCallEntry conv args' + ; emitClosureAndInfoTable cl_info conv args' $ body (offset, 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 --- Convert from 'ClosureInfo' to 'CmmInfo'. +-- Convert from 'ClosureInfo' to 'CmmInfoTable'. -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) -mkCmmInfo :: ClosureInfo -> FCode CmmInfo +mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable mkCmmInfo cl_info = do { info <- closureTypeInfo cl_info k_with_con_name return ; prof <- if opt_SccProfilingOn then @@ -497,25 +496,13 @@ mkCmmInfo cl_info ad_lit <- mkStringCLit (closureValDescr cl_info) return $ ProfilingInfo fd_lit ad_lit else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - ; return (CmmInfo gc_target Nothing - (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) } + ; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) } where k_with_con_name con_info con info_lbl = do cstr <- mkByteStringCLit $ dataConIdentity con return $ con_info $ makeRelativeRefTo info_lbl cstr cl_type = smRepClosureTypeInt (closureSMRep cl_info) - -- The gc_target is to inform the CPS pass when it inserts a stack check. - -- Since that pass isn't used yet we'll punt for now. - -- When the CPS pass is fully integrated, this should - -- be replaced by the label that any heap check jumped to, - -- so that branch can be shared by both the heap (from codeGen) - -- and stack checks (from the CPS pass). - -- JD: Actually, we've decided to go a different route here: - -- the code generator is now responsible for producing the - -- stack limit check explicitly, so this field is now obsolete. - gc_target = Nothing - ----------------------------------------------------------------------------- -- -- Info table offsets