X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCon.lhs;h=57bfffe748730994ecc83b480d3cc920af6510d4;hb=3f5e4368fd4e87e116ce34be4cf9dd0f9f96726d;hp=84f6808be5f8a7e88420842910d6fe95a6b98839;hpb=a5f7799965947977599a777dae10f103f9b9fd1a;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 84f6808..57bfffe 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -22,40 +22,38 @@ import StgSyn 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 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 CgTailCall ( performReturn, mkStaticAlgReturnCode, + returnUnboxedTuple ) +import CLabel ( mkClosureLabel ) +import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr, + 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, dataConTag, + isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + dataConName, dataConRepArity + ) +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} %************************************************************************ @@ -68,59 +66,38 @@ import Panic ( assertPanic, trace ) cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> Bool -- All zero-size args (see buildDynCon) -> FCode (Id, CgIdInfo) -cgTopRhsCon id con args all_zero_size_args - = ASSERT(not (any_litlit_args || dynamic_con_or_args)) - ( +cgTopRhsCon id con args + = 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. - 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} %************************************************************************ @@ -137,13 +114,17 @@ buildDynCon :: Id -- Name of the thing to which this constr will -- 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 @@ -155,12 +136,18 @@ which have exclusively size-zero (VoidRep) args, we generate no code 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 (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, @@ -177,34 +164,32 @@ which is guaranteed in range. 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 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 @@ -235,8 +220,8 @@ bindConArgs con args = 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 @@ -244,33 +229,51 @@ 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? + :: [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} %************************************************************************ @@ -283,14 +286,15 @@ bindUnboxedTupleComponents args 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 - CaseAlts _ (Just (alts, Just (Nothing, (_,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 @@ -304,7 +308,9 @@ cgReturnDataCon con amodes all_zero_size_args -- if the default is a non-bind-default (ie does not use y), -- then we should simply jump to the default join point; - performReturn AbsCNop {- No reg assts -} 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)) @@ -313,8 +319,7 @@ cgReturnDataCon con amodes all_zero_size_args -- 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 @@ -326,6 +331,10 @@ cgReturnDataCon con amodes all_zero_size_args 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])) @@ -335,9 +344,6 @@ cgReturnDataCon con amodes all_zero_size_args 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` @@ -348,54 +354,33 @@ cgReturnDataCon con amodes all_zero_size_args 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 con getAmodeRep amodes 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 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) - (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 + + 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. + -- funnily enough, this makes the unique always come + -- out as '54' :-) + buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo -> + idInfoToAmode PtrRep idinfo `thenFC` \ amode -> + + + -- RETURN + profCtrC FSLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC` + -- could use doTailCall here. + performReturn (move_to_reg amode node) return \end{code}