%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[CgCon]{Code generation for constructors}
#include "HsVersions.h"
module CgCon (
- -- it's all exported, actually...
cgTopRhsCon, buildDynCon,
bindConArgs,
- cgReturnDataCon,
-
- -- and to make the interface self-sufficient...
- Id, StgAtom, CgState, CAddrMode,
- PrimKind, PrimOp, MagicId
+ cgReturnDataCon
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
+IMP_Ubiq(){-uitous-}
-import StgSyn
import CgMonad
import AbsCSyn
+import StgSyn
-import AbsUniType ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
- TyCon, Class, UniType
- )
-import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getArgAmodes, bindNewToNode,
+ bindArgsToRegs, newTempAmodeAndIdInfo,
+ idInfoToAmode, stableAmodeIdInfo,
+ heapIdInfo
)
import CgClosure ( cgTopRhsClosure )
-import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , fetchAndReschedule -- HWL
-#endif {- GRAN -}
- )
import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
-
-import CgRetConv ( dataReturnConvAlg, mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
- )
+import CgHeapery ( allocDynClosure )
+import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabelInfo ( CLabel, mkClosureLabel, mkInfoTableLabel,
- mkPhantomInfoTableLabel,
- mkConEntryLabel, mkStdEntryLabel
+import CLabel ( mkClosureLabel, mkStaticClosureLabel,
+ mkConInfoTableLabel, mkPhantomInfoTableLabel
)
-import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
- {-( mkConLFInfo, mkLFArgument, closureLFInfo,
+import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
- layOutStaticClosure, UpdateFlag(..),
- mkClosureLFInfo, layOutStaticNoFVClosure
- )-}
-import Id ( getIdKind, getDataConTag, getDataConTyCon,
- isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
+ layOutStaticClosure
+ )
+import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre,
+ dontCareCostCentre
)
-import CmdLineOpts ( GlobalSwitch(..) )
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimKind ( PrimKind(..), isFloatingKind, getKindSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import Util
+import Id ( idPrimRep, dataConTag, dataConTyCon,
+ isDataCon, DataCon(..),
+ emptyIdSet
+ )
+import Literal ( Literal(..) )
+import Maybes ( maybeToBool )
+import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
+import PrimRep ( isFloatingRep, PrimRep(..) )
+import TyCon ( TyCon{-instance Uniquable-} )
+import Util ( isIn, zipWithEqual, panic, assertPanic )
\end{code}
%************************************************************************
\begin{code}
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
- -> [PlainStgAtom] -- Args
+ -> [StgArg] -- Args
-> Bool -- All zero-size args (see buildDynCon)
-> FCode (Id, CgIdInfo)
\end{code}
-Special Case:
+Special Case:
Constructors some of whose arguments are of \tr{Float#} or
\tr{Double#} type, {\em or} which are ``lit lits'' (which are given
\tr{Addr#} type).
STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double");
-- with its *own* entry code:
STGFUN(Main_x_entry) {
- P_ u1701;
+ P_ u1701;
RetDouble1=2.0;
u1701=(P_)*SpB;
SpB=SpB-1;
top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data
cgTopRhsCon name con args all_zero_size_args
- | any (isFloatingKind . getAtomKind) args
- || any isLitLitStgAtom args
+ | any (isFloatingRep . getArgPrimRep) args
+ || any isLitLitArg args
= cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
where
- body = StgConApp con args emptyUniqSet{-emptyLiveVarSet-}
+ body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
\end{code}
ASSERT(isDataCon con)
-- LAY IT OUT
- getAtomAmodes args `thenFC` \ amodes ->
+ getArgAmodes args `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
- = layOutStaticClosure name getAmodeKind amodes lf_info
+ = layOutStaticClosure name getAmodeRep amodes lf_info
in
-- HWL: In 0.22 there was a heap check in here that had to be changed.
-- CHECK if having no heap check is ok for GrAnSim here!!!
) `thenC`
-- RETURN
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
+ returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
where
- con_tycon = getDataConTyCon con
- lf_info = mkConLFInfo con
-
- closure_label = mkClosureLabel name
- info_label = mkInfoTableLabel con
- con_entry_label = mkConEntryLabel con
- entry_label = mkStdEntryLabel name
+ con_tycon = dataConTyCon con
+ lf_info = mkConLFInfo con
+ closure_label = mkClosureLabel name
\end{code}
The general case is:
will not have set it. Therefore, the whole point of \tr{x_entry} is
to set node (and then call the shared \tr{MkFoo} entry code).
-
-
Special Case:
For top-level Int/Char constants. We get entry-code fragments of the form:
}
\end{verbatim}
-This blob used to be in cgTopRhsCon, but I don't see how we can
-jump direct to the named code for a constructor; any external entries
-will be via Node. Generating all this extra code is a real waste
-for big static data structures. So I've nuked it. SLPJ Sept 94
-
-
-Further discourse on these entry-code fragments (NB this isn't done
-yet [ToDo]): They're really pretty pointless, except for {\em
-exported} top-level constants (the rare case). Consider:
-\begin{verbatim}
-y = p : ps -- y is not exported
-f a b = y
-g c = (y, c)
-\end{verbatim}
-Why have a \tr{y_entry} fragment at all? The code generator should
-``know enough'' about \tr{y} not to need it. For the first case
-above, with \tr{y} in ``head position,'' it should generate code just
-as for an \tr{StgRhsCon} (possibly because the STG simplification
-actually did the unfolding to make it so). At the least, it should
-load up \tr{Node} and call \tr{Cons}'s entry code---not some special
-\tr{y_entry} code.
-
-\begin{pseudocode}
- -- WE NEED AN ENTRY PT, IN CASE SOMEONE JUMPS DIRECT TO name
- -- FROM OUTSIDE. NB: this CCodeBlock precedes the
- -- CStaticClosure for the same reason (fewer forward refs) as
- -- we did in CgClosure.
-
- -- we either have ``in-line'' returning code (special case)
- -- or we set Node and jump to the constructor's entry code
-
- (if maybeToBool (maybeCharLikeTyCon con_tycon)
- || maybeToBool (maybeIntLikeTyCon con_tycon)
- then -- special case
- getAbsC (-- OLD: No, we don't fiddle cost-centres on
- -- entry to data values any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_D" [top_ccc]
- -- `thenC`
- cgReturnDataCon con amodes all_zero_size_args emptyUniqSet{-no live vars-})
- else -- boring case
- returnFC (
- mkAbstractCs [
- -- Node := this_closure
- CAssign (CReg node) (CLbl closure_label PtrKind),
- -- InfoPtr := info table for this_closure
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind),
- -- Jump to std code for this constructor
- CJump (CLbl con_entry_label CodePtrKind)
- ])
- ) `thenFC` \ ret_absC ->
-
- absC (CCodeBlock entry_label ret_absC) `thenC`
-\end{pseudocode}
-
-=========================== END OF OLD STUFF ==============================
-
+This blob used to be in cgTopRhsCon, but I don't see how we can jump
+direct to the named code for a constructor; any external entries will
+be via Node. Generating all this extra code is a real waste for big
+static data structures. So I've nuked it. SLPJ Sept 94
%************************************************************************
%* *
-> DataCon -- The data constructor
-> [CAddrMode] -- Its args
-> Bool -- True <=> all args (if any) are
- -- of "zero size" (i.e., VoidKind);
+ -- of "zero size" (i.e., VoidRep);
-- The reason we don't just look at the
-- args is that we may be in a "knot", and
-- premature looking at the args will cause
\end{code}
First we deal with the case of zero-arity constructors. Now, they
-will probably be unfolded, so we don't expect to see this case
-much, if at all, but it does no harm, and sets the scene for characters.
+will probably be unfolded, so we don't expect to see this case much,
+if at all, but it does no harm, and sets the scene for characters.
-In the case of zero-arity constructors, or, more accurately,
-those which have exclusively size-zero (VoidKind) args,
-we generate no code at all.
+In the case of zero-arity constructors, or, more accurately, those
+which have exclusively size-zero (VoidRep) args, we generate no code
+at all.
\begin{code}
buildDynCon binder cc con args all_zero_size_args@True
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel con) PtrKind)
+ (CLbl (mkStaticClosureLabel con) PtrRep)
(mkConLFInfo con))
\end{code}
Now for @Char@-like closures. We generate an assignment of the
address of the closure to a temporary. It would be possible simply to
-generate no code, and record the addressing mode in the environment, but
-we'd have to be careful if the argument wasn't a constant --- so for simplicity
-we just always asssign to a temporary.
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always asssign to a temporary.
-Last special case: @Int@-like closures. We only special-case the situation
-in which the argument is a literal in the range @mIN_INTLIKE@..@mAX_INTLILKE@.
-NB: for @Char@-like closures we can work with any old argument, but
-for @Int@-like ones the argument has to be a literal. Reason: @Char@ like
-closures have an argument type which is guaranteed in range.
+Last special case: @Int@-like closures. We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal. Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
Because of this, we use can safely return an addressing mode.
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
- in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE)
- in_range_int_lit other_amode = False
+ in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
+ in_range_int_lit other_amode = False
\end{code}
Now the general case.
returnFC (heapIdInfo binder hp_off (mkConLFInfo con))
where
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeKind args (mkConLFInfo con)
+ = layOutDynClosure binder getAmodeRep args (mkConLFInfo con)
use_cc -- cost-centre to stick in the object
= if currentOrSubsumedCosts cc
ReturnInRegs rs -> bindArgsToRegs args rs
ReturnInHeap ->
let
- (_, args_w_offsets) = layOutDynCon con getIdKind args
+ (_, args_w_offsets) = layOutDynCon con idPrimRep args
in
mapCs bind_arg args_w_offsets
where
Note: it's the responsibility of the @cgReturnDataCon@ caller to be
sure the @amodes@ passed don't conflict with each other.
\begin{code}
-cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> PlainStgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
cgReturnDataCon con amodes all_zero_size_args live_vars
= ASSERT(isDataCon con)
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+ getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
case sequel of
CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
- | not (getDataConTag con `is_elem` map fst alts)
- ->
+ | not (dataConTag con `is_elem` map fst alts)
+ ->
-- Special case! We're returning a constructor to the default case
-- of an enclosing case. For example:
--
-- D x -> ...
-- y -> ...<returning here!>...
--
- -- In this case,
+ -- In this case,
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
--
-- **regardless** of the return convention of the constructor C.
case maybe_deflt_binder of
- Just binder ->
+ Just binder ->
buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args
`thenFC` \ idinfo ->
- idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
performReturn (move_to_reg amode node) jump_to_join_point live_vars
Nothing ->
performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars
where
is_elem = isIn "cgReturnDataCon"
- jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrKind))
+ jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
-- Ignore the sequel: we've already looked at it above
other_sequel -> -- The usual case
- case dataReturnConvAlg con of
+ case (dataReturnConvAlg con) of
ReturnInHeap ->
-- BUILD THE OBJECT IN THE HEAP
-- affects profiling (ToDo?)
buildDynCon con useCurrentCostCentre con amodes all_zero_size_args
`thenFC` \ idinfo ->
- idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
-
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
+
-- MAKE NODE POINT TO IT
let reg_assts = move_to_reg amode node
- info_lbl = mkInfoTableLabel con
+ info_lbl = mkConInfoTableLabel con
in
-- RETURN
- profCtrC SLIT("RET_NEW_IN_HEAP") [] `thenC`
+ profCtrC SLIT("RET_NEW_IN_HEAP") [mkIntCLit (length amodes)] `thenC`
performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
ReturnInRegs regs ->
- let reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
+ let
+ reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs)
info_lbl = mkPhantomInfoTableLabel con
- in
---OLD:WDP:94/06 evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
- profCtrC SLIT("RET_NEW_IN_REGS") [] `thenC`
+ in
+ profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
where