%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\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,
+ bindConArgs, bindUnboxedTupleComponents,
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 AbsCUtils ( getAmodeRep )
+import CgBindery ( getArgAmodes, bindNewToNode,
+ bindArgsToRegs, newTempAmodeAndIdInfo,
+ idInfoToAmode, stableAmodeIdInfo,
+ heapIdInfo, CgIdInfo, bindNewToStack
)
-import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
+import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots,
+ updateFrameSize
)
+import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp,
+ getSpRelOffset )
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 CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabel ( CLabel, mkClosureLabel, mkInfoTableLabel,
- mkPhantomInfoTableLabel,
- mkConEntryLabel, mkStdEntryLabel
- )
-import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
- {-( mkConLFInfo, mkLFArgument, closureLFInfo,
+import CgRetConv ( assignRegs )
+import Constants ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
+import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure )
+import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
+ mkUnboxedTupleReturnCode )
+import CLabel ( mkClosureLabel, mkStaticClosureLabel )
+import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
- layOutStaticClosure, UpdateFlag(..),
- mkClosureLFInfo, layOutStaticNoFVClosure
- )-}
-import Id ( getIdPrimRep, getDataConTag, getDataConTyCon,
- isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
+ layOutStaticClosure, closureSize
)
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
+import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
+ currentCCS )
+import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon,
+ isUnboxedTupleCon )
+import MkId ( mkDataConId )
+import Id ( Id, idName, idType, idPrimRep )
+import Name ( nameModule, isLocallyDefinedName )
+import Module ( isDynamicModule )
+import Const ( Con(..), Literal(..), isLitLitLit )
+import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import Unique ( Uniquable(..) )
import Util
+import Panic ( assertPanic, trace )
\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}
-
-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).
-
-These ones have to be compiled as re-entrant thunks rather than closures,
-because we can't figure out a way to persuade C to allow us to initialise a
-static closure with Floats and Doubles!
-Thus, for \tr{x = 2.0} (defaults to Double), we get:
-
-\begin{verbatim}
--- The STG syntax:
- Main.x = MkDouble [2.0##]
-
--- C Code:
-
--- closure:
- SET_STATIC_HDR(Main_x_closure,Main_x_static,CC_DATA,,EXTDATA_RO)
- };
--- its *own* info table:
- STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double");
--- with its *own* entry code:
- STGFUN(Main_x_entry) {
- P_ u1701;
- RetDouble1=2.0;
- u1701=(P_)*SpB;
- SpB=SpB-1;
- JMP_(u1701[0]);
- }
-\end{verbatim}
-
-The above has the down side that each floating-point constant will end
-up with its own info table (rather than sharing the MkFloat/MkDouble
-ones). On the plus side, however, it does return a value (\tr{2.0})
-{\em straight away}.
-
-Here, then is the implementation: just pretend it's a non-updatable
-thunk. That is, instead of
-
- x = F# 3.455#
-
-pretend we've seen
-
- x = [] \n [] -> F# 3.455#
-
-\begin{code}
-top_cc = dontCareCostCentre -- out here to avoid a cgTopRhsCon CAF (sigh)
-top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data
-
-cgTopRhsCon name con args all_zero_size_args
- | any (isFloatingRep . getArgPrimRep) args
- || 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
-\end{code}
-
-OK, so now we have the general case.
-
-\begin{code}
-cgTopRhsCon name con args all_zero_size_args
- = (
- ASSERT(isDataCon con)
-
+cgTopRhsCon id con args all_zero_size_args
+ = ASSERT(not (any_litlit_args || dynamic_con_or_args))
+ (
-- LAY IT OUT
- getAtomAmodes args `thenFC` \ amodes ->
+ getArgAmodes args `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
= 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!!!
-- BUILD THE OBJECT
absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info -- Closure is static
+ closure_label -- Labelled with the name on lhs of defn
+ closure_info -- Closure is static
top_ccc
- (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
+ (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
) `thenC`
-- RETURN
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
+ returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
where
- con_tycon = getDataConTyCon con
- lf_info = mkConLFInfo con
+ con_tycon = dataConTyCon con
+ lf_info = mkConLFInfo con
+ closure_label = mkClosureLabel name
+ name = idName id
- closure_label = mkClosureLabel name
- info_label = mkInfoTableLabel con
- con_entry_label = mkConEntryLabel con
- entry_label = mkStdEntryLabel name
-\end{code}
+ top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
+
+ -- stuff needed by the assert pred only.
+ any_litlit_args = any isLitLitArg args
+ dynamic_con_or_args = dynamic_con || any (isDynamic) args
+
+ dynamic_con = isDynName (dataConName con)
+
+ isDynName nm =
+ not (isLocallyDefinedName nm) &&
+ isDynamicModule (nameModule nm)
-The general case is:
-\begin{verbatim}
--- code:
- data Foo = MkFoo
- x = MkFoo
-
--- STG code:
-STG syntax:
- Main.x = Main.MkFoo []
-
--- interesting parts of the C Code:
-
--- closure for "x":
- SET_STATIC_HDR(Main_x_closure,Main_MkFoo_static,CC_DATA,,EXTDATA_RO)
- };
--- entry code for "x":
- STGFUN(Main_x_entry) {
- Node=(W_)(Main_x_closure);
- STGJUMP(Main_MkFoo_entry);
- }
-\end{verbatim}
-
-Observe: (1)~We create a static closure for \tr{x}, {\em reusing} the
-regular \tr{MkFoo} info-table and entry code. (2)~However: the
-\tr{MkFoo} code expects Node to be set, but the caller of \tr{x_entry}
-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:
-
-\begin{verbatim}
--- code:
- y = 1
-
--- entry code for "y":
- STGFUN(Main_y_entry) {
- Node=(W_)(Main_y_closure);
- STGJUMP(I#_entry);
- }
-\end{verbatim}
-
-This is pretty tiresome: we {\em know} what the constant is---we'd
-rather just return it. We end up with something that's a hybrid
-between the Float/Double and general cases: (a)~like Floats/Doubles,
-the entry-code returns the value immediately; (b)~like the general
-case, we share the data-constructor's std info table. So, what we
-want is:
-\begin{verbatim}
--- code:
- z = 1
-
--- STG code:
-STG syntax:
- Main.z = I# [1#]
-
--- interesting parts of the C Code:
-
--- closure for "z" (shares I# info table):
- SET_STATIC_HDR(Main_z_closure,I#_static,CC_DATA,,EXTDATA_RO)
- };
--- entry code for "z" (do the business directly):
- STGFUN(Main_z_entry) {
- P_ u1702;
- Ret1=1;
- u1702=(P_)*SpB;
- SpB=SpB-1;
- JMP_(u1702[0]);
- }
-\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
+ {-
+ Do any of the arguments refer to something in a DLL?
+ -}
+ isDynamic (StgVarArg v) = isDynName (idName v)
+ isDynamic (StgConArg c) =
+ case c of
+ DataCon dc -> isDynName (dataConName dc)
+ Literal l -> isLitLitLit l -- all bets are off if it is.
+ _ -> False
+
+
+\end{code}
%************************************************************************
%* *
\begin{code}
buildDynCon :: Id -- Name of the thing to which this constr will
-- be bound
- -> CostCentre -- Where to grab cost centre from;
- -- current CC if currentOrSubsumedCosts
+ -> CostCentreStack -- Where to grab cost centre from;
+ -- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [CAddrMode] -- Its args
-> Bool -- True <=> all args (if any) are
\begin{code}
buildDynCon binder cc con args all_zero_size_args@True
- = ASSERT(isDataCon con)
- returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel con) PtrRep)
+ = returnFC (stableAmodeIdInfo binder
+ (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep)
(mkConLFInfo con))
\end{code}
\begin{code}
buildDynCon binder cc con [arg_amode] all_zero_size_args@False
- | maybeToBool (maybeCharLikeTyCon tycon)
- = ASSERT(isDataCon con)
- absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
+ | maybeCharLikeCon con
+ = absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
returnFC temp_id_info
- | maybeToBool (maybeIntLikeTyCon tycon) && in_range_int_lit arg_amode
- = ASSERT(isDataCon con)
- returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
+ | maybeIntLikeCon con && in_range_int_lit arg_amode
+ = 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
+
+ tycon = dataConTyCon con
\end{code}
Now the general case.
\begin{code}
-buildDynCon binder cc con args all_zero_size_args@False
- = ASSERT(isDataCon con)
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
- returnFC (heapIdInfo binder hp_off (mkConLFInfo con))
+buildDynCon binder ccs con args all_zero_size_args@False
+ = allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off ->
+ returnFC (heapIdInfo binder hp_off lf_info)
where
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeRep args (mkConLFInfo con)
+ = layOutDynClosure (idName binder) getAmodeRep args lf_info
+ lf_info = mkConLFInfo con
use_cc -- cost-centre to stick in the object
- = if currentOrSubsumedCosts cc
+ = if currentOrSubsumedCCS ccs
then CReg CurCostCentre
- else mkCCostCentre cc
+ else mkCCostCentreStack ccs
blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
\end{code}
found a $con$.
\begin{code}
-bindConArgs :: DataCon -> [Id] -> Code
+bindConArgs
+ :: DataCon -> [Id] -- Constructor and args
+ -> Code
+
bindConArgs con args
- = ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-
- case (dataReturnConvAlg isw_chkr con) of
- ReturnInRegs rs -> bindArgsToRegs args rs
- ReturnInHeap ->
- let
- (_, args_w_offsets) = layOutDynCon con getIdPrimRep args
- in
- mapCs bind_arg args_w_offsets
+ = ASSERT(not (isUnboxedTupleCon con))
+ mapCs bind_arg args_w_offsets
where
bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
+ (_, args_w_offsets) = layOutDynCon con idPrimRep args
\end{code}
+Unboxed tuples are handled slightly differently - the object is
+returned in registers and on the stack instead of the heap.
+
+\begin{code}
+bindUnboxedTupleComponents
+ :: [Id] -- args
+ -> FCode ([MagicId], -- regs assigned
+ [(VirtualSpOffset,Int)], -- tag slots
+ Bool) -- any components on stack?
+
+bindUnboxedTupleComponents args
+ = -- Assign as many components as possible to registers
+ let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
+ (reg_args, stk_args) = splitAt (length arg_regs) args
+ in
+
+ -- Allocate the rest on the stack (ToDo: separate out pointers)
+ getVirtSp `thenFC` \ vsp ->
+ getRealSp `thenFC` \ rsp ->
+ let (top_sp, stk_offsets, tags) =
+ mkTaggedVirtStkOffsets rsp idPrimRep stk_args
+ in
+
+ -- The stack pointer points to the last stack-allocated component
+ setRealAndVirtualSp top_sp `thenC`
+
+ -- need to explicitly free any empty slots we just jumped over
+ (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
+
+ bindArgsToRegs reg_args arg_regs `thenC`
+ mapCs bindNewToStack stk_offsets `thenC`
+ returnFC (arg_regs,tags, not (null stk_offsets))
+\end{code}
%************************************************************************
%* *
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 -> StgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> Code
-cgReturnDataCon con amodes all_zero_size_args live_vars
- = ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+cgReturnDataCon con amodes all_zero_size_args
+ = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
case sequel of
- CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
- | not (getDataConTag con `is_elem` map fst alts)
+ CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl))))
+ | 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:
-- 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;
- --
- -- if the default is a bind-default (ie does use y), we
- -- should return the constructor IN THE HEAP, pointed to by Node,
- -- **regardless** of the return convention of the constructor C.
-
- case maybe_deflt_binder of
- Just binder ->
- buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args
- `thenFC` \ idinfo ->
- 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
+
+ case maybe_deflt of
+ Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
+ Just _ -> build_it_then jump_to_join_point
where
is_elem = isIn "cgReturnDataCon"
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 isw_chkr con) of
-
- ReturnInHeap ->
- -- BUILD THE OBJECT IN THE HEAP
- -- The first "con" says that the name bound to this
- -- closure is "con", which is a bit of a fudge, but it only
- -- affects profiling (ToDo?)
- buildDynCon con useCurrentCostCentre con amodes all_zero_size_args
- `thenFC` \ idinfo ->
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
-
- -- MAKE NODE POINT TO IT
- let reg_assts = move_to_reg amode node
- info_lbl = mkInfoTableLabel con
+ -- If the sequel is an update frame, we might be able to
+ -- do update in place...
+ UpdateCode
+ | not all_zero_size_args -- no nullary constructors, please
+ && not (maybeCharLikeCon con) -- no chars please (these are all static)
+ && not (any isFollowableRep (map getAmodeRep amodes))
+ -- no ptrs please (generational gc...)
+ && closureSize closure_info <= mIN_UPD_SIZE
+ -- don't know the real size of the
+ -- thunk, so assume mIN_UPD_SIZE
+
+ -> -- get a new temporary and make it point to the updatee
+ let
+ uniq = getUnique con
+ temp = CTemp uniq PtrRep
+ in
+ getSpRelOffset args_sp `thenFC` \ sp_rel ->
+ absC (CAssign temp
+ (CMacroExpr PtrRep UPD_FRAME_UPDATEE [CAddr sp_rel]))
+ `thenC`
+
+ -- stomp all over it with the new constructor
+ inPlaceAllocDynClosure closure_info temp (CReg CurCostCentre) stuff
+ `thenC`
+
+ -- don't forget to update Su from the update frame
+ absC (CMacroStmt UPDATE_SU_FROM_UPD_FRAME [CAddr sp_rel]) `thenC`
+
+ -- set Node to point to the closure being returned
+ -- (can't be done earlier: node might conflict with amodes)
+ absC (CAssign (CReg node) temp) `thenC`
+
+ -- pop the update frame off the stack, and do the proper
+ -- return.
+ let new_sp = args_sp - updateFrameSize in
+ setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
+ performReturn (AbsCNop) (mkStaticAlgReturnCode con)
+
+ where (closure_info, stuff)
+ = layOutDynClosure (dataConName con)
+ getAmodeRep amodes lf_info
+
+ lf_info = mkConLFInfo con
+
+ other_sequel -- The usual case
+
+ | isUnboxedTupleCon con ->
+ -- Return unboxed tuple in registers
+ let (ret_regs, leftovers) =
+ assignRegs [] (map getAmodeRep amodes)
in
+ profCtrC SLIT("TICK_RET_UNBOXED_TUP")
+ [mkIntCLit (length amodes)] `thenC`
+
+ doTailCall amodes ret_regs
+ mkUnboxedTupleReturnCode
+ (length leftovers) {- fast args arity -}
+ AbsCNop {-no pending assigments-}
+ Nothing {-not a let-no-escape-}
+ False {-node doesn't point-}
+
+ | otherwise ->
+ build_it_then (mkStaticAlgReturnCode con)
- -- RETURN
- 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 (zipWithEqual move_to_reg amodes regs)
- info_lbl = mkPhantomInfoTableLabel con
- in
- profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
-
- performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
where
+ con_name = dataConName con
+
move_to_reg :: CAddrMode -> MagicId -> AbstractC
move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
+
+ build_it_then return =
+ -- BUILD THE OBJECT IN THE HEAP
+ -- The first "con" says that the name bound to this
+ -- closure is "con", which is a bit of a fudge, but it only
+ -- affects profiling
+
+ -- This Id is also used to get a unique for a
+ -- temporary variable, if the closure is a CHARLIKE.
+ -- funilly enough, this makes the unique always come
+ -- out as '54' :-)
+ buildDynCon (mkDataConId con) currentCCS
+ con amodes all_zero_size_args
+ `thenFC` \ idinfo ->
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
+
+
+ -- RETURN
+ profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
+ -- could use doTailCall here.
+ performReturn (move_to_reg amode node) return
+
\end{code}
projects / ghc-hetmet.git / blobdiff