X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCon.lhs;h=324c5ccf36ea072a3cfd6013bbeca656f7694eb3;hb=9a1114e3e6d90308c66b68f59f2e25e7912c0127;hp=aa2aec31625f4b348e51e8d5be38108fdb29cdb1;hpb=a5ded1f8e90fd3dfc0cb05767923bcb0dd7392af;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index aa2aec3..324c5cc 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -26,27 +26,24 @@ import CgBindery ( getArgAmodes, bindNewToNode, idInfoToAmode, stableAmodeIdInfo, heapIdInfo, CgIdInfo, bindNewToStack ) -import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots, - updateFrameSize - ) +import CgStackery ( mkVirtStkOffsets, freeStackSlots, updateFrameSize ) import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp, getSpRelOffset ) import CgRetConv ( assignRegs ) import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE, mIN_UPD_SIZE ) import CgHeapery ( allocDynClosure, inPlaceAllocDynClosure ) -import CgTailCall ( performReturn, mkStaticAlgReturnCode, doTailCall, - mkUnboxedTupleReturnCode ) +import CgTailCall ( performReturn, mkStaticAlgReturnCode, + returnUnboxedTuple ) import CLabel ( mkClosureLabel ) -import ClosureInfo ( 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, - isUnboxedTupleCon, isNullaryDataCon, dataConId, - dataConWrapId, dataConRepArity +import DataCon ( DataCon, dataConTag, + isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + dataConName, dataConRepArity ) import Id ( Id, idName, idPrimRep ) import Literal ( Literal(..) ) @@ -55,6 +52,8 @@ import PrimRep ( PrimRep(..), isFollowableRep ) import Unique ( Uniquable(..) ) import Util import Outputable + +import List ( partition ) \end{code} %************************************************************************ @@ -67,33 +66,35 @@ import Outputable cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args + -> SRT -> FCode (Id, CgIdInfo) -cgTopRhsCon id con args - = ASSERT(not (isDllConApp con args)) -- checks for litlit args too - ASSERT(length args == dataConRepArity con) - let - name = idName id - closure_label = mkClosureLabel name - lf_info = mkConLFInfo con - in +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 = mkConLFInfo con + closure_label = mkClosureLabel name + (closure_info, amodes_w_offsets) + = layOutStaticConstr con getAmodeRep amodes in -- BUILD THE OBJECT - absC (CStaticClosure - closure_label -- Labelled with the name on lhs of defn - closure_info -- Closure is static - (mkCCostCentreStack dontCareCCS) -- because it's static data - (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 + (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) @@ -137,7 +138,7 @@ at all. \begin{code} buildDynCon binder cc con [] = returnFC (stableAmodeIdInfo binder - (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep) + (CLbl (mkClosureLabel (dataConName con)) PtrRep) (mkConLFInfo con)) \end{code} @@ -185,10 +186,10 @@ 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 @@ -219,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 @@ -228,33 +229,44 @@ 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] -- args + -> FCode ([MagicId], -- regs assigned + Int, -- number of pointer stack slots + Int, -- number of non-pointer stack 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 + 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 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 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` 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, + ptr_sp - rsp, nptr_sp - ptr_sp, + notNull ptr_offsets || notNull ptr_offsets + ) \end{code} %************************************************************************ @@ -270,12 +282,12 @@ sure the @amodes@ passed don't conflict with each other. cgReturnDataCon :: DataCon -> [CAddrMode] -> Code cgReturnDataCon con amodes - = ASSERT(length amodes == dataConRepArity con) + = 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 (maybe_deflt, (_,deflt_lbl)))) False | not (dataConTag con `is_elem` map fst alts) -> -- Special case! We're returning a constructor to the default case @@ -313,7 +325,7 @@ cgReturnDataCon con amodes temp = CTemp uniq PtrRep in - profCtrC SLIT("TICK_UPD_CON_IN_PLACE") + profCtrC FSLIT("TICK_UPD_CON_IN_PLACE") [mkIntCLit (length amodes)] `thenC` getSpRelOffset args_sp `thenFC` \ sp_rel -> @@ -325,9 +337,6 @@ cgReturnDataCon con amodes 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` @@ -338,31 +347,12 @@ cgReturnDataCon con amodes 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_it_then (mkStaticAlgReturnCode con) + | isUnboxedTupleCon con -> returnUnboxedTuple amodes + | otherwise -> build_it_then (mkStaticAlgReturnCode con) where move_to_reg :: CAddrMode -> MagicId -> AbstractC @@ -378,12 +368,12 @@ cgReturnDataCon con amodes -- 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}