import CgRetConv ( assignRegs )
import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
mIN_UPD_SIZE )
-import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure )
+import CgHeapery ( allocDynClosure )
import CgTailCall ( performReturn, mkStaticAlgReturnCode,
returnUnboxedTuple )
import CLabel ( mkClosureLabel )
currentCCS )
import DataCon ( DataCon, dataConTag,
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
- dataConWrapId, dataConRepArity
+ dataConName, dataConRepArity
)
-import Id ( Id, idName, idPrimRep )
+import Id ( Id, idName, idPrimRep, isDeadBinder )
import Literal ( Literal(..) )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..), isFollowableRep )
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
-> [StgArg] -- Args
- -> SRT
-> FCode (Id, CgIdInfo)
-cgTopRhsCon id con args srt
+cgTopRhsCon id con args
= ASSERT( not (isDllConApp con args) ) -- checks for litlit args too
ASSERT( args `lengthIs` dataConRepArity con )
closure_label = mkClosureLabel name
(closure_info, amodes_w_offsets)
= layOutStaticConstr con getAmodeRep amodes
+ caffy = any stgArgHasCafRefs args
in
-- BUILD THE OBJECT
closure_info
dontCareCCS -- because it's static data
(map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs
- (nonEmptySRT srt) -- has CAF refs
+ caffy -- has CAF refs
) `thenC`
-- NOTE: can't use idCafInfo instead of nonEmptySRT above,
-- because top-level constructors that were floated by
\begin{code}
buildDynCon binder cc con []
= returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep)
+ (CLbl (mkClosureLabel (dataConName con)) PtrRep)
(mkConLFInfo con))
\end{code}
\begin{code}
bindUnboxedTupleComponents
- :: [Id] -- args
- -> FCode ([MagicId], -- regs assigned
- Int, -- number of pointer stack slots
- Int, -- number of non-pointer stack slots
- Bool) -- any components on stack?
+ :: [Id] -- Aargs
+ -> FCode ([MagicId], -- Regs assigned
+ Int, -- Number of pointer stack slots
+ Int, -- Number of non-pointer stack slots
+ VirtualSpOffset) -- Offset of return address slot
+ -- (= realSP on entry)
bindUnboxedTupleComponents args
- = -- Assign as many components as possible to registers
+ = -- Assign as many components as possible to registers
let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
(reg_args, stk_args) = splitAtList arg_regs args
-- separate the rest of the args into pointers and non-pointers
- ( ptr_args, nptr_args ) =
+ (ptr_args, nptr_args) =
partition (isFollowableRep . idPrimRep) stk_args
in
-- Allocate the rest on the stack
+ -- The real SP points to the return address, above which any
+ -- leftover unboxed-tuple components will be allocated
getVirtSp `thenFC` \ vsp ->
getRealSp `thenFC` \ rsp ->
let
(ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp idPrimRep ptr_args
(nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
+ ptrs = ptr_sp - rsp
+ nptrs = nptr_sp - ptr_sp
in
-- The stack pointer points to the last stack-allocated component
setRealAndVirtualSp nptr_sp `thenC`
- -- need to explicitly free any empty slots we just jumped over
- (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
+ -- We have just allocated slots starting at real SP + 1, and set the new
+ -- virtual SP to the topmost allocated slot.
+ -- If the virtual SP started *below* the real SP, we've just jumped over
+ -- some slots that won't be in the free-list, so put them there
+ -- This commonly happens because we've freed the return-address slot
+ -- (trimming back the virtual SP), but the real SP still points to that slot
+ freeStackSlots [vsp+1,vsp+2 .. rsp] `thenC`
bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToStack ptr_offsets `thenC`
mapCs bindNewToStack nptr_offsets `thenC`
- returnFC (arg_regs,
- ptr_sp - rsp, nptr_sp - ptr_sp,
- notNull ptr_offsets || notNull ptr_offsets
- )
+ returnFC (arg_regs, ptrs, nptrs, rsp)
\end{code}
%************************************************************************
case sequel of
- CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl)))) False
+ CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False
| not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
- case maybe_deflt of
- Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
- Just _ -> build_it_then jump_to_join_point
+ if isDeadBinder deflt_bndr
+ then performReturn AbsCNop {- No reg assts -} jump_to_join_point
+ else 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
- -- If the sequel is an update frame, we might be able to
- -- do update in place...
- UpdateCode
- | not (isNullaryDataCon con) -- no nullary constructors, please
- && 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
-
- profCtrC FSLIT("TICK_UPD_CON_IN_PLACE")
- [mkIntCLit (length amodes)] `thenC`
-
- 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`
-
- -- 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) = layOutDynConstr con getAmodeRep amodes
-
other_sequel -- The usual case
| isUnboxedTupleCon con -> returnUnboxedTuple amodes
| otherwise -> build_it_then (mkStaticAlgReturnCode con)