X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=eddf257e5fb100922ab5f88db81d3fd7e2e0cd06;hp=84d4ef0362c1fa05ba3d9d1eab27fca1cfc07922;hb=cbd7463c986d54422de15cb3b56184de116ef7ba;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 84d4ef0..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 @@ -63,7 +57,7 @@ import Constants import Util import Data.List import Outputable -import FastString ( mkFastString, LitString, sLit ) +import FastString ( mkFastString, FastString, fsLit ) ------------------------------------------------------------------------ -- Call and return sequences @@ -180,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) ------------------------------------------------------------------------- @@ -313,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 @@ -400,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) @@ -462,7 +456,7 @@ 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 @@ -474,25 +468,27 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body ; let node_points = nodeMustPointToIt lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - ; emitClosureAndInfoTable cl_info args' $ body (node, 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 - ; 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 --- 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 @@ -500,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