import AbsCUtils ( getAmodeRep )
import CgBindery ( getArgAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo,
+ bindArgsToRegs,
idInfoToAmode, stableAmodeIdInfo,
heapIdInfo, CgIdInfo, bindNewToStack
)
-import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots,
- updateFrameSize
- )
+import CgStackery ( mkVirtStkOffsets, freeStackSlots, updateFrameSize )
import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp,
getSpRelOffset )
-import CgClosure ( cgTopRhsClosure )
import CgRetConv ( assignRegs )
-import Constants ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
-import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure )
-import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall,
- mkUnboxedTupleReturnCode )
+import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
+ mIN_UPD_SIZE )
+import CgHeapery ( allocDynClosure )
+import CgTailCall ( performReturn, mkStaticAlgReturnCode,
+ returnUnboxedTuple )
import CLabel ( mkClosureLabel )
-import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
- layOutDynCon, layOutDynClosure,
- layOutStaticClosure, closureSize
+import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr,
+ layOutStaticConstr, closureSize, mkStaticClosure
)
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
-import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon,
- isUnboxedTupleCon, isNullaryDataCon, dataConId, dataConWrapId
+import DataCon ( DataCon, dataConTag,
+ isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
+ dataConName, dataConRepArity
)
-import Id ( Id, idName, idType, idPrimRep )
-import Name ( nameModule, isLocallyDefinedName )
+import Id ( Id, idName, idPrimRep, isDeadBinder )
import Literal ( Literal(..) )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Uniquable(..) )
import Util
-import Panic ( assertPanic, trace )
+import Outputable
+
+import List ( partition )
\end{code}
%************************************************************************
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
- = ASSERT(not dynamic_con_or_args) -- checks for litlit args too
- (
+ = ASSERT( not (isDllConApp con args) ) -- checks for litlit args too
+ ASSERT( args `lengthIs` dataConRepArity con )
+
-- LAY IT OUT
getArgAmodes args `thenFC` \ amodes ->
let
- (closure_info, amodes_w_offsets)
- = layOutStaticClosure name getAmodeRep amodes lf_info
+ name = idName id
+ lf_info = mkConLFInfo con
+ closure_label = mkClosureLabel name
+ (closure_info, amodes_w_offsets)
+ = layOutStaticConstr con getAmodeRep amodes
+ caffy = any stgArgHasCafRefs args
in
-- BUILD THE OBJECT
- absC (CStaticClosure
- 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
-
- ) `thenC`
+ absC (mkStaticClosure
+ closure_label
+ closure_info
+ dontCareCCS -- because it's static data
+ (map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs
+ caffy -- has CAF refs
+ ) `thenC`
+ -- NOTE: can't use idCafInfo instead of nonEmptySRT above,
+ -- because top-level constructors that were floated by
+ -- CorePrep don't have CafInfo attached. The SRT is more
+ -- reliable.
-- RETURN
returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
- where
- con_tycon = dataConTyCon con
- lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
- name = idName id
-
- top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
-
- -- stuff needed by the assert pred only.
- dynamic_con_or_args = isDllConApp con args
\end{code}
%************************************************************************
\begin{code}
buildDynCon binder cc con []
= returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep)
+ (CLbl (mkClosureLabel (dataConName con)) PtrRep)
(mkConLFInfo con))
\end{code}
+The following three paragraphs about @Char@-like and @Int@-like
+closures are obsolete, but I don't understand the details well enough
+to properly word them, sorry. I've changed the treatment of @Char@s to
+be analogous to @Int@s: only a subset is preallocated, because @Char@
+has now 31 bits. Only literals are handled here. -- Qrczak
+
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,
\begin{code}
buildDynCon binder cc con [arg_amode]
-
- | maybeCharLikeCon con
- = absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
- returnFC temp_id_info
-
| maybeIntLikeCon con && in_range_int_lit arg_amode
= returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
- (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 _other_amode = False
- tycon = dataConTyCon con
+buildDynCon binder cc con [arg_amode]
+ | maybeCharLikeCon con && in_range_char_lit arg_amode
+ = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
+ where
+ in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
+ in_range_char_lit _other_amode = False
\end{code}
Now the general case.
= 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 (idName binder) getAmodeRep args lf_info
lf_info = mkConLFInfo con
+ (closure_info, amodes_w_offsets) = layOutDynConstr con getAmodeRep args
+
use_cc -- cost-centre to stick in the object
= if currentOrSubsumedCCS ccs
then CReg CurCostCentre
= 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
+ bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
+ (_, args_w_offsets) = layOutDynConstr con idPrimRep args
\end{code}
Unboxed tuples are handled slightly differently - the object is
\begin{code}
bindUnboxedTupleComponents
- :: [Id] -- args
- -> FCode ([MagicId], -- regs assigned
- [(VirtualSpOffset,Int)], -- tag 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
- let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
- (reg_args, stk_args) = splitAt (length arg_regs) args
- in
+ = -- Assign as many components as possible to registers
+ let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
+ (reg_args, stk_args) = splitAtList arg_regs args
- -- Allocate the rest on the stack (ToDo: separate out pointers)
+ -- separate the rest of the args into pointers and non-pointers
+ (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 (top_sp, stk_offsets, tags) =
- mkTaggedVirtStkOffsets rsp idPrimRep stk_args
+ 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 top_sp `thenC`
+ 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 stk_offsets `thenC`
- returnFC (arg_regs,tags, not (null stk_offsets))
+ mapCs bindNewToStack ptr_offsets `thenC`
+ mapCs bindNewToStack nptr_offsets `thenC`
+
+ returnFC (arg_regs, ptrs, nptrs, rsp)
\end{code}
%************************************************************************
cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
cgReturnDataCon con amodes
- = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
+ = ASSERT( amodes `lengthIs` dataConRepArity con )
+ getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
case sequel of
- CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl))))
+ 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 (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
-
- profCtrC SLIT("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`
-
- -- 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)
+ | isUnboxedTupleCon con -> returnUnboxedTuple amodes
+ | otherwise -> build_it_then (mkStaticAlgReturnCode con)
where
- con_name = dataConName con
-
move_to_reg :: CAddrMode -> MagicId -> AbstractC
move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
-- temporary variable, if the closure is a CHARLIKE.
-- funnily enough, this makes the unique always come
-- out as '54' :-)
- buildDynCon (dataConId con) currentCCS con amodes `thenFC` \ idinfo ->
+ buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo ->
idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
-- RETURN
- profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
+ profCtrC FSLIT("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