X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgExpr.lhs;h=459f2c011ff4c6661552309a50893860909c9a74;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=a57ee94f42625152136c602966476efd35ff5fa3;hpb=6281224046c9fc2bba358d42c7688a8314dc5bb6;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index a57ee94..459f2c0 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.26 1999/06/08 15:56:47 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.61 2004/11/26 16:20:07 simonmar Exp $ % %******************************************************** %* * @@ -17,40 +17,40 @@ module CgExpr ( cgExpr ) where import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE ) import StgSyn import CgMonad -import AbsCSyn -import AbsCUtils ( mkAbstractCs ) -import CLabel ( mkClosureTblLabel ) - -import SMRep ( fixedHdrSize ) -import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings) -import CgCase ( cgCase, saveVolatileVarsAndRegs, - restoreCurrentCostCentre ) + +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 CgRetConv ( dataReturnConvPrim ) -import CgTailCall ( cgTailCall, performReturn, performPrimReturn, - mkDynamicAlgReturnCode, mkPrimReturnCode, - tailCallPrimOp, returnUnboxedTuple - ) -import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, - mkApLFInfo, layOutDynCon ) -import CostCentre ( sccAbleCostCentre, isSccCountCostCentre ) -import Id ( idPrimRep, idType, Id ) +import CgCallConv ( dataReturnConvPrim ) +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 VarSet -import DataCon ( DataCon, dataConTyCon ) -import Const ( Con(..) ) -import IdInfo ( ArityInfo(..) ) -import PrimOp ( primOpOutOfLine, - getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) - ) -import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) -import TyCon ( maybeTyConSingleCon, - isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe ) -import Maybes ( assocMaybe, maybeToBool ) -import Unique ( mkBuiltinUnique ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) +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 Outputable \end{code} @@ -84,11 +84,9 @@ cgExpr (StgApp fun args) = cgTailCall fun args %******************************************************** \begin{code} -cgExpr (StgCon (DataCon con) args res_ty) - = getArgAmodes args `thenFC` \ amodes -> - cgReturnDataCon con amodes (all zero_size args) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 +cgExpr (StgConApp con args) + = do { amodes <- getArgAmodes args + ; cgReturnDataCon con amodes } \end{code} Literals are similar to constructors; they return by putting @@ -96,90 +94,103 @@ themselves in an appropriate register and returning to the address on top of the stack. \begin{code} -cgExpr (StgCon (Literal lit) args res_ty) - = ASSERT( null args ) - performPrimReturn (text "literal" <+> ppr lit) (CLit lit) +cgExpr (StgLit lit) + = do { cmm_lit <- cgLit lit + ; performPrimReturn rep (CmmLit cmm_lit) } + where + rep = typeCgRep (literalType lit) \end{code} %******************************************************** %* * -%* STG PrimApps (unboxed primitive ops) * +%* PrimOps and foreign calls. %* * %******************************************************** -Here is where we insert real live machine instructions. +NOTE about "safe" foreign calls: a safe foreign call is never compiled +inline in a case expression. When we see -NOTE about _ccall_GC_: + case (ccall ...) of { ... } -A _ccall_GC_ is treated as an out-of-line primop for the case -expression code, because we want a proper stack frame on the stack -when we perform it. When we get here, however, we need to actually -perform the call, so we treat it as an inline primop. +We generate a proper return address for the alternatives and push the +stack frame before doing the call, so that in the event that the call +re-enters the RTS the stack is in a sane state. \begin{code} -cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty) - = primRetUnboxedTuple op args res_ty - +cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do + {- + First, copy the args into temporaries. We're going to push + a return address right before doing the call, so the args + must be out of the way. + -} + reps_n_amodes <- getArgAmodes stg_args + let + -- Get the *non-void* args, and jiggle them with shimForeignCall + arg_exprs = [ shimForeignCallArg stg_arg expr + | (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 + {- + 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 + arg_hints emptyVarSet{-no live vars-} + -- tagToEnum# is special: we need to pull the constructor out of the table, -- and perform an appropriate return. -cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty) +cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) - getArgAmode arg `thenFC` \amode -> - -- save the tag in a temporary in case amode overlaps - -- with node. - absC (CAssign dyn_tag amode) `thenC` - performReturn ( - CAssign (CReg node) - (CTableEntry - (CLbl (mkClosureTblLabel tycon) PtrRep) - dyn_tag PtrRep)) - (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel) + do { (_,amode) <- getArgAmode arg + ; amode' <- assignTemp amode -- We're going to use it twice, + -- so save in a temp if non-trivial + ; dflags <- getDynFlags + ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode')) + ; performReturn (emitAlgReturnCode tycon amode') } where - dyn_tag = CTemp (mkBuiltinUnique 0) IntRep - (Just (tycon,_)) = splitTyConApp_maybe res_ty - - -cgExpr x@(StgCon (PrimOp op) args res_ty) - | primOpOutOfLine op = tailCallPrimOp op args - | otherwise - = ASSERT(op /= SeqOp) -- can't handle SeqOp - - getArgAmodes args `thenFC` \ arg_amodes -> - - case (getPrimOpResultInfo op) of - - ReturnsPrim kind -> - let result_amode = CReg (dataReturnConvPrim kind) in - performReturn - (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}]) - (mkPrimReturnCode (text "primapp)" <+> ppr x)) - - -- otherwise, must be returning an enumerated type (eg. Bool). - -- we've only got the tag in R2, so we have to load the constructor - -- itself into R1. - - ReturnsAlg tycon - | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty - - | isEnumerationTyCon tycon -> - performReturn - (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}]) - (\ sequel -> - absC (CAssign (CReg node) closure_lbl) `thenC` - mkDynamicAlgReturnCode tycon dyn_tag sequel) - - where - -- Pull a unique out of thin air to put the tag in. - -- It shouldn't matter if this overlaps with anything - we're - -- about to return anyway. - dyn_tag = CTemp (mkBuiltinUnique 0) IntRep - - closure_lbl = CTableEntry - (CLbl (mkClosureTblLabel tycon) PtrRep) - dyn_tag PtrRep - + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + tycon = tyConAppTyCon res_ty + + +cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) + | primOpOutOfLine primop + = tailCallPrimOp primop args + + | ReturnsPrim VoidRep <- result_info + = do cgPrimOp [] primop args emptyVarSet + performReturn emitDirectReturnInstr + + | ReturnsPrim rep <- result_info + = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)] + primop args emptyVarSet + performReturn emitDirectReturnInstr + + | 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)) + + | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon + -- c.f. cgExpr (...TagToEnumOp...) + = do tag_reg <- newTemp wordRep + dflags <- getDynFlags + cgPrimOp [tag_reg] primop args emptyVarSet + stmtC (CmmAssign nodeReg (tagToClosure dflags tycon (CmmReg tag_reg))) + performReturn (emitAlgReturnCode tycon (CmmReg tag_reg)) + where + result_info = getPrimOpResultInfo primop \end{code} %******************************************************** @@ -191,8 +202,8 @@ Case-expression conversion is complicated enough to have its own module, @CgCase@. \begin{code} -cgExpr (StgCase expr live_vars save_vars bndr srt alts) - = cgCase expr live_vars save_vars bndr srt alts +cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts) + = cgCase expr live_vars save_vars bndr srt alt_type alts \end{code} @@ -220,22 +231,21 @@ cgExpr (StgLet (StgRec pairs) expr) \begin{code} cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) - = -- Figure out what volatile variables to save - nukeDeadBindings live_in_whole_let `thenC` - saveVolatileVarsAndRegs live_in_rhss - `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) -> - -- ToDo: cost centre??? - restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc -> + = do { -- Figure out what volatile variables to save + ; nukeDeadBindings live_in_whole_let + ; (save_assts, rhs_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_rhss -- Save those variables right now! - absC save_assts `thenC` + ; emitStmts save_assts -- Produce code for the rhss -- and add suitable bindings to the environment - cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC` + ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info + maybe_cc_slot bindings -- Do the body - setEndOfBlockInfo rhs_eob_info (cgExpr body) + ; setEndOfBlockInfo rhs_eob_info (cgExpr body) } \end{code} @@ -247,18 +257,11 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) SCC expressions are treated specially. They set the current cost centre. + \begin{code} -cgExpr (StgSCC cc expr) - = ASSERT(sccAbleCostCentre cc) - costCentresC - SLIT("SET_CCC") - [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)] - `thenC` - cgExpr expr +cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr \end{code} -ToDo: counting of dict sccs ... - %******************************************************** %* * %* Non-top-level bindings * @@ -274,17 +277,13 @@ cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along so a binding can be set up cgRhs name (StgRhsCon maybe_cc con args) - = getArgAmodes args `thenFC` \ amodes -> - buildDynCon name maybe_cc con amodes (all zero_size args) - `thenFC` \ idinfo -> - returnFC (name, idinfo) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 + = do { amodes <- getArgAmodes args + ; idinfo <- buildDynCon name maybe_cc con amodes + ; returnFC (name, idinfo) } -cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body) - = mkRhsClosure name cc bi srt fvs upd_flag args body -cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body) - = mkRhsClosure name cc bi srt fvs upd_flag args body +cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) + = do dflags <- getDynFlags + mkRhsClosure dflags name cc bi srt fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -307,33 +306,35 @@ form: \begin{code} -mkRhsClosure bndr cc bi srt +mkRhsClosure dflags bndr cc bi srt [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk body@(StgCase (StgApp scrutinee [{-no args-}]) _ _ _ _ -- ignore uniq, etc. - (StgAlgAlts case_ty - [(con, params, use_mask, - (StgApp selectee [{-no args-}]))] - StgNoDefault)) - | the_fv == scrutinee -- Scrutinee is the only free variable - && maybeToBool maybe_offset -- Selectee is a component of the tuple + (AlgAlt tycon) + [(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 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough - = ASSERT(is_single_constructor) + = -- NOT TRUE: ASSERT(is_single_constructor) + -- The simplifier may have statically determined that the single alternative + -- is the only possible case and eliminated the others, even if there are + -- 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] where - lf_info = mkSelectorLFInfo (idType bndr) offset_into_int - (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynCon con idPrimRep params + lf_info = mkSelectorLFInfo bndr offset_into_int + (isUpdatable upd_flag) + (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params) + -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize - is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) - tycon = dataConTyCon con \end{code} - Ap thunks ~~~~~~~~~ @@ -351,14 +352,14 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure bndr cc bi srt +mkRhsClosure dflags bndr cc bi srt fvs upd_flag [] -- No args; a thunk body@(StgApp fun_id args) - | length args + 1 == arity - && all isFollowableRep (map idPrimRep fvs) + | args `lengthIs` (arity-1) + && all isFollowableArg (map idCgRep fvs) && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE @@ -366,22 +367,18 @@ mkRhsClosure bndr cc bi srt = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload where - lf_info = mkApLFInfo (idType bndr) upd_flag arity + lf_info = mkApLFInfo bndr upd_flag arity -- the payload has to be in the correct order, hence we can't -- just use the fvs. - payload = StgVarArg fun_id : args - arity = length fvs + payload = StgVarArg fun_id : args + arity = length fvs \end{code} The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure bndr cc bi srt fvs upd_flag args body - = getSRTLabel `thenFC` \ srt_label -> - let lf_info = - mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt - in - cgRhsClosure bndr cc bi fvs args body lf_info +mkRhsClosure dflags bndr cc bi srt fvs upd_flag args body + = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} @@ -391,21 +388,21 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body %* * %******************************************************** \begin{code} -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) - = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot - NonRecursive binder rhs - `thenFC` \ (binder, info) -> - addBindC binder info +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot + (StgNonRec binder rhs) + = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info + maybe_cc_slot + NonRecursive binder rhs + ; addBindC binder info } cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) - = fixC (\ new_bindings -> - addBindsC new_bindings `thenC` - listFCs [ cgLetNoEscapeRhs full_live_in_rhss + = do { new_bindings <- fixC (\ new_bindings -> do + { addBindsC new_bindings + ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot Recursive b e - | (b,e) <- pairs ] - ) `thenFC` \ new_bindings -> + | (b,e) <- pairs ] }) - addBindsC new_bindings + ; addBindsC new_bindings } 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! @@ -421,53 +418,37 @@ cgLetNoEscapeRhs -> FCode (Id, CgIdInfo) cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder - (StgRhsClosure cc bi srt _ upd_flag 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 maybe_cc_slot rec args body + cgLetNoEscapeClosure binder cc bi srt 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 -- can be jumped to from many places, which will return the constructor. -- 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 stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec + = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT + full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function - (StgCon (DataCon con) args (idType binder)) + (StgConApp con args) \end{code} Little helper for primitives that return unboxed tuples. - \begin{code} -primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code -primRetUnboxedTuple op args res_ty - = getArgAmodes args `thenFC` \ arg_amodes -> - {- - put all the arguments in temporaries so they don't get stomped when - we push the return address. - -} - let - n_args = length args - arg_uniqs = map mkBuiltinUnique [0 .. n_args-1] - arg_reps = map getArgPrimRep args - arg_temps = zipWith CTemp arg_uniqs arg_reps - in - absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC` - {- - allocate some temporaries for the return values. - -} - let - (tc,ty_args) = case splitRepTyConApp_maybe res_ty of - Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty) - Just pr -> pr - prim_reps = map typePrimRep ty_args - temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1] - temp_amodes = zipWith CTemp temp_uniqs prim_reps - in - returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps [])) - +newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint]) +newUnboxedTupleRegs res_ty = + let + ty_args = tyConAppArgs (repType res_ty) + (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, + let rep = typeCgRep ty, + nonVoidArg rep ] + in do + regs <- mapM (newTemp . argMachRep) reps + return (reps,regs,hints) \end{code}