X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgExpr.lhs;h=71087ca7c59c3dece4d02e7fcc8c6ea8a76812e1;hp=33d72f16086ea7bf9cf49010cd74557c79a51dd8;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 33d72f1..71087ca 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -1,56 +1,46 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.62 2005/06/21 10:44:41 simonmar Exp $ -% -%******************************************************** -%* * -\section[CgExpr]{Converting @StgExpr@s} -%* * -%******************************************************** \begin{code} module CgExpr ( cgExpr ) where #include "HsVersions.h" -import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE ) +import Constants import StgSyn import CgMonad -import SMRep ( fixedHdrSize, isFollowableArg, CgRep(..), argMachRep, - nonVoidArg, idCgRep, typeCgRep, typeHint, - primRepToCgRep ) -import CoreSyn ( AltCon(..) ) -import CgProf ( emitSetCCC ) -import CgHeapery ( layOutDynConstr ) -import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, - nukeDeadBindings, addBindC, addBindsC ) -import CgCase ( cgCase, saveVolatileVarsAndRegs ) -import CgClosure ( cgRhsClosure, cgStdRhsClosure ) -import CgCon ( buildDynCon, cgReturnDataCon ) -import CgLetNoEscape ( cgLetNoEscapeClosure ) -import CgCallConv ( dataReturnConvPrim ) +import CostCentre +import SMRep +import CoreSyn +import CgProf +import CgHeapery +import CgBindery +import CgCase +import CgClosure +import CgCon +import CgLetNoEscape import CgTailCall -import CgInfoTbls ( emitDirectReturnInstr ) -import CgForeignCall ( emitForeignCall, shimForeignCallArg ) -import CgPrimOp ( cgPrimOp ) -import CgUtils ( addIdReps, newTemp, assignTemp, cgLit, tagToClosure ) -import ClosureInfo ( mkSelectorLFInfo, mkApLFInfo ) -import Cmm ( CmmExpr(..), CmmStmt(..), CmmReg, nodeReg ) -import MachOp ( wordRep, MachHint ) +import CgInfoTbls +import CgForeignCall +import CgPrimOp +import CgHpc +import CgUtils +import ClosureInfo +import Cmm +import CmmUtils import VarSet -import Literal ( literalType ) -import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, - PrimOp(..), PrimOpResultInfo(..) ) -import Id ( Id ) -import TyCon ( isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, tyConAppArgs, tyConAppTyCon, repType, - PrimRep(VoidRep) ) -import Maybes ( maybeToBool ) -import ListSetOps ( assocMaybe ) -import BasicTypes ( RecFlag(..) ) -import Util ( lengthIs ) +import Literal +import PrimOp +import Id +import TyCon +import Type +import Maybes +import ListSetOps +import BasicTypes +import Util import Outputable \end{code} @@ -98,7 +88,7 @@ cgExpr (StgLit lit) = do { cmm_lit <- cgLit lit ; performPrimReturn rep (CmmLit cmm_lit) } where - rep = typeCgRep (literalType lit) + rep = (typeCgRep) (literalType lit) \end{code} @@ -127,21 +117,19 @@ 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] - -- in - arg_tmps <- mapM assignTemp arg_exprs - let - arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args) - -- in + arg_tmps <- sequence [ assignTemp arg + | (arg, _) <- arg_exprs] + let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.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)) $ - emitForeignCall (zip res_regs res_hints) fcall + ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $ + emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall arg_hints emptyVarSet{-no live vars-} -- tagToEnum# is special: we need to pull the constructor out of the table, @@ -149,12 +137,11 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) - do { (_,amode) <- getArgAmode arg + do { (_rep,amode) <- getArgAmode arg ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; hmods <- getHomeModules - ; stmtC (CmmAssign nodeReg (tagToClosure hmods 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 @@ -164,33 +151,37 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) tycon = tyConAppTyCon res_ty -cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) +cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | primOpOutOfLine primop = tailCallPrimOp primop args | 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 <- newTemp (typeCmmType 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 - hmods <- getHomeModules + = do tag_reg <- newTemp bWord -- The tag is a word cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg (tagToClosure hmods 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 + +cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty) + = tailCallPrimCall primcall args \end{code} %******************************************************** @@ -203,7 +194,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} @@ -263,6 +254,26 @@ cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr \end{code} %******************************************************** +%* * +%* Hpc Tick Boxes * +%* * +%******************************************************** + +\begin{code} +cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr +\end{code} + +%******************************************************** +%* * +%* Anything else * +%* * +%******************************************************** + +\begin{code} +cgExpr _ = panic "cgExpr" +\end{code} + +%******************************************************** %* * %* Non-top-level bindings * %* * @@ -282,8 +293,7 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do hmods <- getHomeModules - mkRhsClosure hmods 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: @@ -306,14 +316,17 @@ form: \begin{code} -mkRhsClosure hmods bndr cc bi srt +mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo + -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id + -> FCode (Id, CgIdInfo) +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. - (AlgAlt tycon) - [(DataAlt con, params, use_mask, + _ _ _ srt -- ignore uniq, etc. + (AlgAlt _) + [(DataAlt con, params, _use_mask, (StgApp selectee [{-no args-}]))]) | the_fv == scrutinee -- Scrutinee is the only free variable && maybeToBool maybe_offset -- Selectee is a component of the tuple @@ -324,11 +337,11 @@ mkRhsClosure hmods 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 hmods 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 @@ -352,7 +365,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure hmods bndr cc bi srt +mkRhsClosure bndr cc bi fvs upd_flag [] -- No args; a thunk @@ -377,8 +390,8 @@ mkRhsClosure hmods bndr cc bi srt The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure hmods 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} @@ -388,6 +401,9 @@ mkRhsClosure hmods bndr cc bi srt fvs upd_flag args body %* * %******************************************************** \begin{code} +cgLetNoEscapeBindings :: StgLiveVars -> EndOfBlockInfo + -> Maybe VirtualSpOffset -> GenStgBinding Id Id + -> Code cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info @@ -406,7 +422,7 @@ cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) where -- We add the binders to the live-in-rhss set so that we don't -- delete the bindings for the binder from the environment! - full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs]) + full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,_) <- pairs]) cgLetNoEscapeRhs :: StgLiveVars -- Live in rhss @@ -418,13 +434,13 @@ cgLetNoEscapeRhs -> FCode (Id, CgIdInfo) cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder - (StgRhsClosure cc bi _ upd_flag srt args body) + (StgRhsClosure cc bi _ _upd_flag srt args body) = -- We could check the update flag, but currently we don't switch it off -- for let-no-escaped things, so we omit the check too! -- 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 @@ -432,7 +448,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) @@ -441,14 +457,15 @@ 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], [ForeignHint]) newUnboxedTupleRegs res_ty = let ty_args = tyConAppArgs (repType res_ty) - (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, + (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] + make_new_temp rep = newTemp (argMachRep rep) in do - regs <- mapM (newTemp . argMachRep) reps + regs <- mapM make_new_temp reps return (reps,regs,hints) \end{code}