--
-----------------------------------------------------------------------------
-{-# 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,
- emitClosureCodeAndInfoTable,
+ emitClosureProcAndInfoTable,
+ emitClosureAndInfoTable,
slowCall, directCall,
import StgCmmUtils
import StgCmmMonad
-import MkZipCfgCmm
+import MkGraph
import SMRep
+import CmmDecl
+import CmmExpr
import CmmUtils
-import Cmm
import CLabel
import StgSyn
+import DataCon
import Id
import Name
import TyCon ( PrimRep(..) )
import Bitmap
import Data.Bits
-import Maybes
import Constants
import Util
import Data.List
import Outputable
-import FastString ( 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;
- ; 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 ()
-- 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
; 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 (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)
-------------------------------------------------------------------------
| 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
-> [(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
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))
-------------------------------------------------------------------------
-------------------------------------------------------------------------
-- 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
= let
small_bits = case bits of
[] -> 0
- [b] -> fromIntegral b
+ [b] -> b
_ -> panic "livenessToAddrMode"
in
return (smallLiveness size small_bits)
-- 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
+ -> ((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
+ -- 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
+ 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 -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable cl_info conv args body
+ = do { info <- mkCmmInfo cl_info
+ ; blks <- getCode body
+ ; 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 { 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 (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.
- -- 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
projects / ghc-hetmet.git / blobdiff