\begin{code}
#include "HsVersions.h"
-module CgExpr (
- cgExpr, cgSccExpr, getPrimOpArgAmodes,
+module CgExpr ( cgExpr, getPrimOpArgAmodes ) where
- -- and to make the interface self-sufficient...
- StgExpr, Id, CgState
- ) where
-
-IMPORT_Trace -- NB: not just for debugging
-import Outputable -- ToDo: rm (just for debugging)
-import Pretty -- ToDo: rm (just for debugging)
+IMP_Ubiq(){-uitous-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking
+#endif
+import Constants ( mAX_SPEC_SELECTEE_SIZE )
import StgSyn
import CgMonad
import AbsCSyn
-import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
- primOpHeapReq, getPrimOpResultInfo, PrimKind,
- primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( isPrimType, getTyConDataCons )
-import CLabelInfo ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CgBindery ( getAtomAmodes )
+import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
+import CgBindery ( getArgAmodes, getCAddrModeAndInfo, CgIdInfo )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgHeapery ( allocHeap )
import CgLetNoEscape ( cgLetNoEscapeClosure )
-import CgRetConv -- various things...
-import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode,
- mkPrimReturnCode
- )
-import CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre )
-import Maybes ( Maybe(..) )
-import PrimKind ( getKindSize )
-import UniqSet
-import Util
+import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
+ DataReturnConvention(..), CtrlReturnConvention(..),
+ assignPrimOpResultRegs, makePrimOpArgsRobust
+ )
+import CgTailCall ( cgTailCall, performReturn,
+ mkDynamicAlgReturnCode, mkPrimReturnCode
+ )
+import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
+import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo,
+ layOutDynCon )
+import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
+import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods )
+import Id ( dataConTyCon, idPrimRep, getIdArity,
+ mkIdSet, unionIdSets, GenId{-instance Outputable-},
+ SYN_IE(Id)
+ )
+import IdInfo ( ArityInfo(..) )
+import Name ( isLocallyDefined )
+import Outputable ( PprStyle(..), Outputable(..) )
+import Pretty ( Doc )
+import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
+ getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
+ )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import TyCon ( tyConDataCons, maybeTyConSingleCon )
+import Maybes ( assocMaybe, maybeToBool )
+import Util ( panic, isIn, pprPanic, assertPanic )
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
with closures, and @CgCon@, which deals with constructors.
\begin{code}
-cgExpr :: PlainStgExpr -- input
+cgExpr :: StgExpr -- input
-> Code -- output
\end{code}
``Applications'' mean {\em tail calls}, a service provided by module
@CgTailCall@. This includes literals, which show up as
-@(STGApp (StgLitAtom 42) [])@.
+@(STGApp (StgLitArg 42) [])@.
\begin{code}
cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
%********************************************************
\begin{code}
-cgExpr (StgConApp con args live_vars)
- = getAtomAmodes args `thenFC` \ amodes ->
+cgExpr (StgCon con args live_vars)
+ = getArgAmodes args `thenFC` \ amodes ->
cgReturnDataCon con amodes (all zero_size args) live_vars
where
- zero_size atom = getKindSize (getAtomKind atom) == 0
+ zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
\end{code}
%********************************************************
Here is where we insert real live machine instructions.
\begin{code}
-cgExpr x@(StgPrimApp op args live_vars)
- = -- trace ("cgExpr:PrimApp:"++(ppShow 80 (ppr PprDebug x))) (
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+cgExpr x@(StgPrim op args live_vars)
+ = ASSERT(op /= SeqOp) -- can't handle SeqOp
+ getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
result_regs = assignPrimOpResultRegs op
result_amodes = map CReg result_regs
-- Use registers for args, and assign args to the regs
-- (Can-trigger-gc primops guarantee to have their args in regs)
let
- (arg_robust_amodes, liveness_mask, arg_assts)
+ (arg_robust_amodes, liveness_mask, arg_assts)
= makePrimOpArgsRobust op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
returnFC (
arg_assts,
- mkAbstractCs [
- spat_prim_macro,
- COpStmt result_amodes op
- (pin_liveness op liveness_arg arg_robust_amodes)
- liveness_mask
- [{-no vol_regs-}],
- spat_prim_stop_macro ]
+ COpStmt result_amodes op
+ (pin_liveness op liveness_arg arg_robust_amodes)
+ liveness_mask
+ [{-no vol_regs-}]
)
else
-- Use args from their current amodes.
liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
in
returnFC (
--- DO NOT want CCallProfMacros in CSimultaneous stuff. Yurgh. (WDP 95/01)
--- Arises in compiling PreludeGlaST (and elsewhere??)
--- mkAbstractCs [
--- spat_prim_macro,
COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
--- spat_prim_stop_macro ],
- AbsCNop
+ AbsCNop
)
) `thenFC` \ (do_before_stack_cleanup,
do_just_before_jump) ->
ReturnsPrim kind ->
performReturn do_before_stack_cleanup
- (\ sequel -> robustifySequel may_gc sequel
+ (\ sequel -> robustifySequel may_gc sequel
`thenFC` \ (ret_asst, sequel') ->
absC (ret_asst `mkAbsCStmts` do_just_before_jump)
`thenC`
live_vars
ReturnsAlg tycon ->
---OLD: evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
- profCtrC SLIT("RET_NEW_IN_REGS") [] `thenC`
+ profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields] `thenC`
performReturn do_before_stack_cleanup
(\ sequel -> robustifySequel may_gc sequel
`thenFC` \ (ret_asst, sequel') ->
- absC (mkAbstractCs [ret_asst,
- do_just_before_jump,
+ absC (mkAbstractCs [ret_asst,
+ do_just_before_jump,
info_ptr_assign])
-- Must load info ptr here, not in do_just_before_stack_cleanup,
-- because the info-ptr reg clashes with argument registers
info_ptr_assign = CAssign (CReg infoptr) info_lbl
info_lbl
- = -- OLD: pprTrace "ctrlReturn7:" (ppr PprDebug tycon) (
- case (ctrlReturnConvAlg tycon) of
- VectoredReturn _ -> vec_lbl
+ = case (ctrlReturnConvAlg tycon) of
+ VectoredReturn _ -> vec_lbl
UnvectoredReturn _ -> dir_lbl
- -- )
-
- vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrKind)
- dyn_tag DataPtrKind
-
- data_con = head (getTyConDataCons tycon)
- dir_lbl = case dataReturnConvAlg data_con of
- ReturnInRegs _ -> CLbl (mkPhantomInfoTableLabel data_con)
- DataPtrKind
- ReturnInHeap -> panic "CgExpr: can't return prim in heap"
- -- Never used, and no point in generating
- -- the code for it!
+
+ vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
+ dyn_tag DataPtrRep
+
+ data_con = head (tyConDataCons tycon)
+
+ (dir_lbl, num_of_fields)
+ = case (dataReturnConvAlg data_con) of
+ ReturnInRegs rs
+ -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
+ mkIntCLit (length rs)) -- for ticky-ticky only
+
+ ReturnInHeap
+ -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con)
+ -- Never used, and no point in generating
+ -- the code for it!
where
-- for all PrimOps except ccalls, we pin the liveness info
-- on as the first "argument"
-- sequel is OnStack. If that's the case, arrange to pull the
-- sequel out into RetReg before performing the primOp.
- robustifySequel True sequel@(OnStack _) =
+ robustifySequel True sequel@(OnStack _) =
sequelToAmode sequel `thenFC` \ amode ->
returnFC (CAssign (CReg RetReg) amode, InRetReg)
robustifySequel _ sequel = returnFC (AbsCNop, sequel)
-
- spat_prim_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]
- spat_prim_stop_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]
-
\end{code}
%********************************************************
cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
= -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_let `thenC`
- saveVolatileVarsAndRegs live_in_rhss
+ saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
-- ToDo: cost centre???
- -- Save those variables right now!
+ -- Save those variables right now!
absC save_assts `thenC`
-- Produce code for the rhss
SCC expressions are treated specially. They set the current cost
centre.
-
-For evaluation scoping we also need to save the cost centre in an
-``restore CC frame''. We only need to do this once before setting all
-nested SCCs.
-
\begin{code}
-cgExpr scc_expr@(StgSCC ty cc expr)
---OLD:WDP:94/06 = evalPushRCCFrame (isPrimType ty) (cgSccExpr scc_expr)
- = cgSccExpr scc_expr
+cgExpr (StgSCC ty cc expr)
+ = ASSERT(sccAbleCostCentre cc)
+ costCentresC
+ (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
+ [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
+ `thenC`
+ cgExpr expr
\end{code}
-@cgSccExpr@ (also used in \tr{CgClosure}):
-We *don't* set the cost centre for CAF/Dict cost centres
-[Likewise Subsumed and NoCostCentre, but they probably
-don't exist in an StgSCC expression.]
-\begin{code}
-cgSccExpr (StgSCC ty cc expr)
- = (if setToAbleCostCentre cc then
- costCentresC SLIT("SET_CCC")
- [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)]
- else
- nopC) `thenC`
- cgSccExpr expr
-cgSccExpr other
- = cgExpr other
-\end{code}
+ToDo: counting of dict sccs ...
%********************************************************
%* *
%********************************************************
\subsection[non-top-level-bindings]{Converting non-top-level bindings}
-@cgBinding@ is only used for let/letrec, not for unboxed bindings.
-So the kind should always be @PtrKind@.
-
We rely on the support code in @CgCon@ (to do constructors) and
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
cgRhs name (StgRhsCon maybe_cc con args)
- = getAtomAmodes args `thenFC` \ amodes ->
+ = getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes (all zero_size args)
`thenFC` \ idinfo ->
returnFC (name, idinfo)
where
- zero_size atom = getKindSize (getAtomKind atom) == 0
+ zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
= cgRhsClosure name cc bi fvs args body lf_info
where
- lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
+ lf_info = mkRhsLFInfo fvs upd_flag args body
+
+\end{code}
+
+mkRhsLFInfo looks for two special forms of the right-hand side:
+ a) selector thunks.
+ b) VAP thunks
+
+If neither happens, it just calls mkClosureLFInfo. You might think
+that mkClosureLFInfo should do all this, but
+
+ (a) it seems wrong for the latter to look at the structure
+ of an expression
+
+ [March 97: item (b) is no longer true, but I've left mkRhsLFInfo here
+ anyway because of (a).]
+
+ (b) mkRhsLFInfo has to be in the monad since it looks up in
+ the environment, and it's very tiresome for mkClosureLFInfo to
+ be. Apart from anything else it would make a loop between
+ CgBindery and ClosureInfo.
+
+Selectors
+~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep. We are looking for a closure of {\em exactly} the
+form:
+\begin{verbatim}
+... = [the_fv] \ u [] ->
+ case the_fv of
+ con a_1 ... a_n -> a_i
+\end{verbatim}
+
+\begin{code}
+mkRhsLFInfo [the_fv] -- Just one free var
+ Updatable -- Updatable thunk
+ [] -- A thunk
+ (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
+ _ _ _ -- ignore live vars and uniq...
+ (StgAlgAlts case_ty
+ [(con, params, use_mask,
+ (StgApp (StgVarArg selectee) [{-no args-}] _))]
+ StgNoDefault))
+ | the_fv == scrutinee -- Scrutinee is the only free variable
+ && maybeToBool maybe_offset -- Selectee is a component of the tuple
+ && maybeToBool offset_into_int_maybe
+ && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
+ = -- ASSERT(is_single_constructor) -- Should be true, but causes error for SpecTyCon
+ mkSelectorLFInfo scrutinee con offset_into_int
+ where
+ (_, params_w_offsets) = layOutDynCon con idPrimRep params
+ maybe_offset = assocMaybe params_w_offsets selectee
+ Just the_offset = maybe_offset
+ offset_into_int_maybe = intOffsetIntoGoods the_offset
+ Just offset_into_int = offset_into_int_maybe
+ is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+ tycon = dataConTyCon con
\end{code}
+
+Vap thunks
+~~~~~~~~~~
+Same kind of thing, looking for vector-apply thunks, of the form:
+
+ x = [...] \ .. [] -> f a1 .. an
+
+where f has arity n. We rely on the arity info inside the Id being correct.
+
+\begin{code}
+mkRhsLFInfo fvs
+ upd_flag
+ [] -- No args; a thunk
+ (StgApp (StgVarArg fun_id) args _)
+ | isLocallyDefined fun_id -- Must be defined in this module
+ = -- Get the arity of the fun_id. It's guaranteed to be correct (by setStgVarInfo).
+ let
+ arity_maybe = case getIdArity fun_id of
+ ArityExactly n -> Just n
+ other -> Nothing
+ in
+ case arity_maybe of
+ Just arity
+ | arity > 0 && -- It'd better be a function!
+ arity == length args -- Saturated application
+ -> -- Ha! A VAP thunk
+ mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap
+
+ other -> mkClosureLFInfo False{-not top level-} fvs upd_flag []
+ where
+ -- If the function is a free variable then it must be stored
+ -- in the thunk too; if it isn't a free variable it must be
+ -- because it's constant, so it doesn't need to be stored in the thunk
+ store_fun_in_vap = fun_id `is_elem` fvs
+ is_elem = isIn "mkClosureLFInfo"
+\end{code}
+
+The default case
+~~~~~~~~~~~~~~~~
+\begin{code}
+mkRhsLFInfo fvs upd_flag args body
+ = mkClosureLFInfo False{-not top level-} fvs upd_flag args
+\end{code}
+
+
+%********************************************************
+%* *
+%* Let-no-escape bindings
+%* *
+%********************************************************
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
- = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
+ = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
= fixC (\ new_bindings ->
addBindsC new_bindings `thenC`
- listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
- maybe_cc_slot b e | (b,e) <- pairs ]
+ listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
+ maybe_cc_slot b e | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings
where
-- We add the binders to the live-in-rhss set so that we don't
-- delete the bindings for the binder from the environment!
- full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
+ full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs])
-cgLetNoEscapeRhs
- :: PlainStgLiveVars -- Live in rhss
- -> EndOfBlockInfo
+cgLetNoEscapeRhs
+ :: StgLiveVars -- Live in rhss
+ -> EndOfBlockInfo
-> Maybe VirtualSpBOffset
-> Id
- -> PlainStgRhs
+ -> StgRhs
-> FCode (Id, CgIdInfo)
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
--- For a constructor RHS we want to generate a single chunk of code which
+-- For a constructor RHS we want to generate a single chunk of code which
-- can be jumped to from many places, which will return the constructor.
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
(StgRhsCon cc con args)
= cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
[] --No args; the binder is data structure, not a function
- (StgConApp con args full_live_in_rhss)
+ (StgCon con args full_live_in_rhss)
\end{code}
Some PrimOps require a {\em fixed} amount of heap allocation. Rather
\begin{code}
getPrimOpArgAmodes op args
- = getAtomAmodes args `thenFC` \ arg_amodes ->
+ = getArgAmodes args `thenFC` \ arg_amodes ->
case primOpHeapReq op of
-
FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
returnFC (amode : arg_amodes)
- _ -> returnFC arg_amodes
+ _ -> returnFC arg_amodes
\end{code}
projects / ghc-hetmet.git / blobdiff