X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgExpr.lhs;h=bc91bef364e61e981c96e0a9d116a95ef19f7f0f;hp=fe095a3932358824d93afab9af64ca3c4d1896dd;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=604121dfc02eaf2ba60d018bbc7f4c7b3e0698dd diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index fe095a3..bc91bef 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -4,6 +4,13 @@ % \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CgExpr ( cgExpr ) where #include "HsVersions.h" @@ -117,17 +124,21 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do reps_n_amodes <- getArgAmodes stg_args let -- Get the *non-void* args, and jiggle them with shimForeignCall - arg_exprs = [ shimForeignCallArg stg_arg expr + arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg) | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, nonVoidArg rep] - arg_tmps <- mapM assignTemp arg_exprs + arg_tmps <- sequence [ + if isFollowableArg (typeCgRep (stgArgType stg_arg)) + then assignPtrTemp arg + else assignNonPtrTemp arg + | (arg, stg_arg) <- arg_exprs] let arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args) {- Now, allocate some result regs. -} (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty - ccallReturnUnboxedTuple (zip res_reps (map CmmReg res_regs)) $ + ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $ emitForeignCall (zip res_regs res_hints) fcall arg_hints emptyVarSet{-no live vars-} @@ -136,12 +147,14 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) - do { (_,amode) <- getArgAmode arg - ; amode' <- assignTemp amode -- We're going to use it twice, + do { (rep,amode) <- getArgAmode arg + ; amode' <- if isFollowableArg rep + then assignPtrTemp amode + else assignNonPtrTemp amode + -- We're going to use it twice, -- so save in a temp if non-trivial - ; this_pkg <- getThisPackage - ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode')) - ; performReturn (emitAlgReturnCode tycon amode') } + ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) + ; performReturn emitReturnInstr } where -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because @@ -157,25 +170,30 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args emptyVarSet - performReturn emitDirectReturnInstr + performReturn emitReturnInstr | ReturnsPrim rep <- result_info - = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)] - primop args emptyVarSet - performReturn emitDirectReturnInstr + = do res <- if isFollowableArg (typeCgRep res_ty) + then newPtrTemp (argMachRep (typeCgRep res_ty)) + else newNonPtrTemp (argMachRep (typeCgRep res_ty)) + cgPrimOp [res] primop args emptyVarSet + performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res)) | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty cgPrimOp regs primop args emptyVarSet{-no live vars-} - returnUnboxedTuple (zip reps (map CmmReg regs)) + returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs)) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) - = do tag_reg <- newTemp wordRep - this_pkg <- getThisPackage + = do tag_reg <- if isFollowableArg (typeCgRep res_ty) + then newPtrTemp wordRep + else newNonPtrTemp wordRep cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon (CmmReg tag_reg))) - performReturn (emitAlgReturnCode tycon (CmmReg tag_reg)) + stmtC (CmmAssign nodeReg + (tagToClosure tycon + (CmmReg (CmmLocal tag_reg)))) + performReturn emitReturnInstr where result_info = getPrimOpResultInfo primop \end{code} @@ -190,7 +208,7 @@ module, @CgCase@. \begin{code} cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts) - = cgCase expr live_vars save_vars bndr srt alt_type alts + = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts \end{code} @@ -279,8 +297,7 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do this_pkg <- getThisPackage - mkRhsClosure this_pkg name cc bi srt fvs upd_flag args body + = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -303,12 +320,12 @@ form: \begin{code} -mkRhsClosure this_pkg bndr cc bi srt +mkRhsClosure bndr cc bi [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk body@(StgCase (StgApp scrutinee [{-no args-}]) - _ _ _ _ -- ignore uniq, etc. + _ _ _ srt -- ignore uniq, etc. (AlgAlt tycon) [(DataAlt con, params, use_mask, (StgApp selectee [{-no args-}]))]) @@ -321,11 +338,11 @@ mkRhsClosure this_pkg bndr cc bi srt -- other constructors in the datatype. It's still ok to make a selector -- thunk in this case, because we *know* which constructor the scrutinee -- will evaluate to. - cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] + setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset @@ -349,7 +366,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure this_pkg bndr cc bi srt +mkRhsClosure bndr cc bi fvs upd_flag [] -- No args; a thunk @@ -374,8 +391,8 @@ mkRhsClosure this_pkg bndr cc bi srt The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body - = cgRhsClosure bndr cc bi srt fvs upd_flag args body +mkRhsClosure bndr cc bi fvs upd_flag args body + = cgRhsClosure bndr cc bi fvs upd_flag args body \end{code} @@ -421,7 +438,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder -- case upd_flag of -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update! -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body - cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info + setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body -- For a constructor RHS we want to generate a single chunk of code which @@ -429,7 +446,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder (StgRhsCon cc con args) - = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT + = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function (StgConApp con args) @@ -438,14 +455,17 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder Little helper for primitives that return unboxed tuples. \begin{code} -newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint]) +newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [MachHint]) newUnboxedTupleRegs res_ty = let ty_args = tyConAppArgs (repType res_ty) - (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, + (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] + make_new_temp rep = if isFollowableArg rep + then newPtrTemp (argMachRep rep) + else newNonPtrTemp (argMachRep rep) in do - regs <- mapM (newTemp . argMachRep) reps + regs <- mapM make_new_temp reps return (reps,regs,hints) \end{code}