X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmLayout.hs;h=11a32577327d2bbc836a24838e77c3a8f618fa71;hp=f8d39646d644db1056c0440b5ee11d8065391759;hb=a2a67cd520b9841114d69a87a423dabcb3b4368e;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index f8d3964..11a3257 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -17,7 +17,8 @@ module StgCmmLayout ( mkArgDescr, emitCall, emitReturn, - emitClosureCodeAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, slowCall, directCall, @@ -47,6 +48,7 @@ import CmmUtils import Cmm import CLabel import StgSyn +import DataCon import Id import Name import TyCon ( PrimRep(..) ) @@ -57,12 +59,11 @@ import StaticFlags import Bitmap import Data.Bits -import Maybes import Constants import Util import Data.List import Outputable -import FastString ( LitString, sLit ) +import FastString ( mkFastString, LitString, sLit ) ------------------------------------------------------------------------ -- Call and return sequences @@ -75,23 +76,30 @@ emitReturn :: [CmmExpr] -> FCode () -- return (x,y) -- If the sequel is AssignTo [p,q] -- p=x; q=y; -emitReturn results - = do { adjustHpBackwards - ; sequel <- getSequel; - ; case sequel of - Return _ -> emit (mkReturn results) - AssignTo regs _ -> emit (mkMultiAssign regs results) - } - -emitCall :: CmmExpr -> [CmmExpr] -> FCode () +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, 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 fun args +emitCall convs@(callConv, _) fun args = do { adjustHpBackwards - ; sequel <- getSequel; + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel) ; case sequel of - Return _ -> emit (mkJump fun args) - AssignTo res_regs srt -> emit (mkCmmCall fun res_regs args srt) + Return _ -> emit (mkForeignJump callConv fun args updfr_off) + AssignTo res_regs _ -> emit (mkCall fun convs res_regs args updfr_off) } adjustHpBackwards :: FCode () @@ -132,7 +140,7 @@ directCall :: CLabel -> Arity -> [StgArg] -> FCode () -- Both arity and args include void args directCall lbl arity stg_args = do { cmm_args <- getNonVoidArgAmodes stg_args - ; direct_call lbl arity cmm_args (argsLReps stg_args) } + ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) } slowCall :: CmmExpr -> [StgArg] -> FCode () -- (slowCall fun args) applies fun to args, returning the results to Sequel @@ -141,36 +149,39 @@ slowCall fun stg_args ; slow_call fun cmm_args (argsLReps stg_args) } -------------- -direct_call :: CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode () --- NB1: (length args) maybe less than (length reps), because +direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode () +-- NB1: (length args) may be less than (length reps), because -- the args exclude the void ones -- NB2: 'arity' refers to the *reps* -direct_call lbl arity args reps - | null rest_args - = ASSERT( arity == length args) - emitCall target args +direct_call caller lbl arity args reps + | debugIsOn && arity > length reps -- Too few args + = -- Caller should ensure that there enough args! + pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps) + <+> ppr args <+> ppr reps ) - | otherwise + | null rest_reps -- Precisely the right number of arguments + = 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 target args) + ; withSequel (AssignTo [pap_id] True) + (emitCall (NativeDirectCall, NativeReturn) target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where target = CmmLit (CmmLabel lbl) (initial_reps, rest_reps) = splitAt arity reps arg_arity = count isNonV initial_reps - (_, rest_args) = splitAt arg_arity args + (fast_args, rest_args) = splitAt arg_arity args -------------- slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode () slow_call fun args reps - = direct_call (mkRtsApFastLabel rts_fun) (arity+1) - (fun : args) (P : 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)) + emit (mkAssign nodeReg fun <*> call) where (rts_fun, arity) = slowCallPattern reps @@ -207,6 +218,13 @@ data LRep = P -- GC Ptr | V -- Void | F -- Float | D -- Double +instance Outputable LRep where + ppr P = text "P" + ppr N = text "N" + ppr L = text "L" + ppr V = text "V" + ppr F = text "F" + ppr D = text "D" toLRep :: PrimRep -> LRep toLRep VoidRep = V @@ -254,7 +272,7 @@ mkVirtHeapOffsets -> [(PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* - [(a, VirtualHpOffset)]) + [(NonVoid a, VirtualHpOffset)]) -- Things with their offsets from start of object in order of -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER @@ -279,7 +297,7 @@ mkVirtHeapOffsets is_thunk things computeOffset wds_so_far (rep, thing) = (wds_so_far + lRepSizeW (toLRep rep), - (thing, hdr_size + wds_so_far)) + (NonVoid thing, hdr_size + wds_so_far)) ------------------------------------------------------------------------- @@ -295,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 @@ -331,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 @@ -437,12 +455,38 @@ mkRegLiveness regs ptrs nptrs -- Here we make an info table of type 'CmmInfo'. The concrete -- representation as a list of 'CmmAddr' is handled later -- in the pipeline by 'cmmToRawCmm'. - -emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals - -> CmmAGraph -> FCode () -emitClosureCodeAndInfoTable cl_info args body - = do { info <- mkCmmInfo cl_info - ; emitProc info (infoLblToEntryLbl info_lbl) args body } +-- When loading the free variables, a function closure pointer may be tagged, +-- so we must take it into account. + +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 + -> 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 + -- 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 + ; 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 +-- needed for functions. The shared part goes here. +emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable cl_info 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 @@ -450,14 +494,18 @@ emitClosureCodeAndInfoTable cl_info args body -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) mkCmmInfo :: ClosureInfo -> FCode CmmInfo mkCmmInfo cl_info - = do { prof <- if opt_SccProfilingOn then + = do { info <- closureTypeInfo cl_info k_with_con_name return + ; prof <- if opt_SccProfilingOn then do fd_lit <- mkStringCLit (closureTypeDescr 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 prof cl_type info)) } + ; return (CmmInfo gc_target Nothing + (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) } where - info = closureTypeInfo cl_info + 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.