%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[CgCon]{Code generation for constructors}
@CgClosure@, which deals with closures.
\begin{code}
-#include "HsVersions.h"
-
module CgCon (
- -- it's all exported, actually...
cgTopRhsCon, buildDynCon,
bindConArgs,
cgReturnDataCon
-
- -- and to make the interface self-sufficient...
) where
-import StgSyn
+#include "HsVersions.h"
+
import CgMonad
import AbsCSyn
+import StgSyn
-import Type ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
- TyCon, Class, Type
- )
-import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getArgAmodes, bindNewToNode,
+ bindArgsToRegs, newTempAmodeAndIdInfo,
+ idInfoToAmode, stableAmodeIdInfo,
+ heapIdInfo, CgIdInfo
)
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 Constants ( mAX_INTLIKE, mIN_INTLIKE )
+import CgHeapery ( allocDynClosure )
+import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabel ( 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 ( getIdPrimRep, getDataConTag, getDataConTyCon,
- isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
+ layOutStaticClosure
+ )
+import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre,
+ dontCareCostCentre, CostCentre
)
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import Util
+import Id ( idPrimRep, dataConTag, dataConTyCon,
+ isDataCon, DataCon,
+ emptyIdSet, Id
+ )
+import Literal ( Literal(..) )
+import Maybes ( maybeToBool )
+import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
+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
- -> [StgArg] -- Args
+ -> [StgArg] -- Args
-> Bool -- All zero-size args (see buildDynCon)
-> FCode (Id, CgIdInfo)
\end{code}
|| any isLitLitArg args
= cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
where
- body = StgCon con args emptyUniqSet{-emptyLiveVarSet-}
- lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
+ body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
+ lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant []
\end{code}
OK, so now we have the general case.
ASSERT(isDataCon con)
-- LAY IT OUT
- getAtomAmodes args `thenFC` \ amodes ->
+ getArgAmodes args `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
-- RETURN
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:
buildDynCon binder cc con args all_zero_size_args@True
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel con) PtrRep)
+ (CLbl (mkStaticClosureLabel con) PtrRep)
(mkConLFInfo con))
\end{code}
\begin{code}
buildDynCon binder cc con [arg_amode] all_zero_size_args@False
- | maybeToBool (maybeCharLikeTyCon tycon)
+ | maybeCharLikeCon con
= ASSERT(isDataCon con)
absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
returnFC temp_id_info
- | maybeToBool (maybeIntLikeTyCon tycon) && in_range_int_lit arg_amode
+ | maybeIntLikeCon con && in_range_int_lit arg_amode
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
- tycon = getDataConTyCon 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 (CLit (MachInt val _)) = val <= mAX_INTLIKE &&
+ val >= mIN_INTLIKE
in_range_int_lit other_amode = False
\end{code}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
= ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-
- case (dataReturnConvAlg isw_chkr con) of
+ case (dataReturnConvAlg con) of
ReturnInRegs rs -> bindArgsToRegs args rs
ReturnInHeap ->
let
- (_, args_w_offsets) = layOutDynCon con getIdPrimRep args
+ (_, args_w_offsets) = layOutDynCon con idPrimRep args
in
mapCs bind_arg args_w_offsets
where
cgReturnDataCon con amodes all_zero_size_args live_vars
= ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
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:
-- Ignore the sequel: we've already looked at it above
other_sequel -> -- The usual case
- case (dataReturnConvAlg isw_chkr con) of
+ case (dataReturnConvAlg con) of
ReturnInHeap ->
-- BUILD THE OBJECT IN THE HEAP
-- MAKE NODE POINT TO IT
let reg_assts = move_to_reg amode node
- info_lbl = mkInfoTableLabel con
+ info_lbl = mkConInfoTableLabel con
in
-- RETURN
ReturnInRegs regs ->
let
- reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs)
+ reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs)
info_lbl = mkPhantomInfoTableLabel con
in
profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
projects / ghc-hetmet.git / blobdiff