import AbsCUtils ( getAmodeRep )
import CgBindery ( getArgAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo,
+ bindArgsToRegs,
idInfoToAmode, stableAmodeIdInfo,
heapIdInfo, CgIdInfo, bindNewToStack
)
)
import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp,
getSpRelOffset )
-import CgClosure ( cgTopRhsClosure )
import CgRetConv ( assignRegs )
-import Constants ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
+import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
+ 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, closureSize
+import CLabel ( mkClosureLabel )
+import ClosureInfo ( mkConLFInfo, mkLFArgument, closureLFInfo,
+ layOutDynConstr, layOutDynClosure,
+ layOutStaticConstr, closureSize, mkStaticClosure
)
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 DataCon ( DataCon, dataConName, dataConTag,
+ isUnboxedTupleCon, isNullaryDataCon, dataConId,
+ dataConWrapId, dataConRepArity
+ )
+import Id ( Id, idName, idPrimRep )
+import Literal ( Literal(..) )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Uniquable(..) )
import Util
-import Panic ( assertPanic, trace )
+import Outputable
\end{code}
%************************************************************************
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
-> [StgArg] -- Args
- -> Bool -- All zero-size args (see buildDynCon)
+ -> SRT
-> FCode (Id, CgIdInfo)
-cgTopRhsCon id con args all_zero_size_args
- = ASSERT(not (any_litlit_args || dynamic_con_or_args))
- (
+cgTopRhsCon id con args srt
+ = 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 = closureLFInfo closure_info
+ closure_label = mkClosureLabel name
+ (closure_info, amodes_w_offsets)
+ = layOutStaticConstr name con getAmodeRep amodes
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_info
+ dontCareCCS -- because it's static data
+ (map fst amodes_w_offsets) -- Sorted into ptrs first, then nonptrs
+ (nonEmptySRT srt) -- 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.
- 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)
-
- {-
- 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}
%************************************************************************
-- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [CAddrMode] -- Its args
- -> Bool -- True <=> all args (if any) are
- -- 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
- -- the compiler to black-hole!
-> FCode CgIdInfo -- Return details about how to find it
+
+-- We used to pass a boolean indicating whether all the
+-- args were of size zero, so we could use a static
+-- construtor; but I concluded that it just isn't worth it.
+-- Now I/O uses unboxed tuples there just aren't any constructors
+-- with all size-zero args.
+--
+-- The reason for having a separate argument, rather than looking at
+-- the addr modes of the args is that we may be in a "knot", and
+-- premature looking at the args will cause the compiler to black-hole!
\end{code}
First we deal with the case of zero-arity constructors. Now, they
at all.
\begin{code}
-buildDynCon binder cc con args all_zero_size_args@True
+buildDynCon binder cc con []
= returnFC (stableAmodeIdInfo binder
- (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep)
+ (CLbl (mkClosureLabel (idName (dataConWrapId 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,
Because of this, we use can safely return an addressing mode.
\begin{code}
-buildDynCon binder cc con [arg_amode] all_zero_size_args@False
-
- | maybeCharLikeCon con
- = absC (CAssign temp_amode (CCharLike arg_amode)) `thenC`
- returnFC temp_id_info
-
+buildDynCon binder cc con [arg_amode]
| 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 (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
- 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.
\begin{code}
-buildDynCon binder ccs con args all_zero_size_args@False
+buildDynCon binder ccs con args
= 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
+ = layOutDynClosure (idName binder) getAmodeRep args lf_info NoC_SRT
lf_info = mkConLFInfo con
use_cc -- cost-centre to stick in the object
mapCs bind_arg args_w_offsets
where
bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
- (_, args_w_offsets) = layOutDynCon con idPrimRep args
+ (_, args_w_offsets) = layOutDynConstr bogus_name con idPrimRep args
+
+bogus_name = panic "bindConArgs"
\end{code}
Unboxed tuples are handled slightly differently - the object is
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
+ let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
+ (reg_args, stk_args) = splitAtList arg_regs args
in
-- Allocate the rest on the stack (ToDo: separate out pointers)
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 -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
-cgReturnDataCon con amodes all_zero_size_args
- = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
+cgReturnDataCon con amodes
+ = ASSERT( amodes `lengthIs` dataConRepArity con )
+ getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
case sequel of
-- 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 (isNullaryDataCon con) -- no nullary constructors, please
&& not (any isFollowableRep (map getAmodeRep amodes))
-- no ptrs please (generational gc...)
&& closureSize closure_info <= mIN_UPD_SIZE
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]))
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
+ where
+ (closure_info, stuff)
+ = layOutDynConstr (dataConName con) con getAmodeRep amodes
other_sequel -- The usual case
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
-- 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
+ -- funnily 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 ->
+ buildDynCon (dataConId con) currentCCS con amodes `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