X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgExpr.lhs;h=459f2c011ff4c6661552309a50893860909c9a74;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=d90f9886e4fe6ecb5f983bdf709351a9b251a701;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index d90f988..459f2c0 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,5 +1,7 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +% $Id: CgExpr.lhs,v 1.61 2004/11/26 16:20:07 simonmar Exp $ % %******************************************************** %* * @@ -8,55 +10,48 @@ %******************************************************** \begin{code} -#include "HsVersions.h" +module CgExpr ( cgExpr ) where -module CgExpr ( cgExpr, getPrimOpArgAmodes ) where - -IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking +#include "HsVersions.h" -import Constants ( mAX_SPEC_SELECTEE_SIZE ) +import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE ) import StgSyn import CgMonad -import AbsCSyn -import AbsCUtils ( mkAbsCStmts, mkAbstractCs ) -import CgBindery ( getArgAmodes, getCAddrModeAndInfo, CgIdInfo ) +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 ) +import CgClosure ( cgRhsClosure, cgStdRhsClosure ) import CgCon ( buildDynCon, cgReturnDataCon ) -import CgHeapery ( allocHeap ) import CgLetNoEscape ( cgLetNoEscapeClosure ) -import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg, - DataReturnConvention(..), CtrlReturnConvention(..), - assignPrimOpResultRegs, makePrimOpArgsRobust - ) -import CgTailCall ( cgTailCall, performReturn, - mkDynamicAlgReturnCode, mkPrimReturnCode - ) -import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) -import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, - layOutDynCon ) -import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre ) -import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods ) -import Id ( dataConTyCon, idPrimRep, getIdArity, - mkIdSet, unionIdSets, GenId{-instance Outputable-}, - SYN_IE(Id) - ) -import IdInfo ( ArityInfo(..) ) -import Name ( isLocallyDefined ) -import PprStyle ( PprStyle(..) ) -import Pretty ( Doc ) -import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), - getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) - ) -import PrimRep ( getPrimRepSize, PrimRep(..) ) -import TyCon ( tyConDataCons, maybeTyConSingleCon ) -import Maybes ( assocMaybe, maybeToBool ) -import Util ( panic, isIn, pprPanic, assertPanic ) -#if __GLASGOW_HASKELL__ >= 202 -import Outputable ( Outputable(..) ) -#endif +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 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} This module provides the support code for @StgToAbstractC@ to deal @@ -79,7 +74,7 @@ cgExpr :: StgExpr -- input @(STGApp (StgLitArg 42) [])@. \begin{code} -cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars +cgExpr (StgApp fun args) = cgTailCall fun args \end{code} %******************************************************** @@ -89,131 +84,113 @@ cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars %******************************************************** \begin{code} -cgExpr (StgCon con args live_vars) - = getArgAmodes args `thenFC` \ amodes -> - cgReturnDataCon con amodes (all zero_size args) live_vars +cgExpr (StgConApp con args) + = do { amodes <- getArgAmodes args + ; cgReturnDataCon con amodes } +\end{code} + +Literals are similar to constructors; they return by putting +themselves in an appropriate register and returning to the address on +top of the stack. + +\begin{code} +cgExpr (StgLit lit) + = do { cmm_lit <- cgLit lit + ; performPrimReturn rep (CmmLit cmm_lit) } where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 + 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 + + case (ccall ...) of { ... } + +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 x@(StgPrim op args live_vars) - = ASSERT(op /= SeqOp) -- can't handle SeqOp - getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> +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 - result_regs = assignPrimOpResultRegs op - result_amodes = map CReg result_regs - may_gc = primOpCanTriggerGC op - dyn_tag = head result_amodes - -- The tag from a primitive op returning an algebraic data type - -- is returned in the first result_reg_amode - in - (if may_gc then - -- Use registers for args, and assign args to the regs - -- (Can-trigger-gc primops guarantee to have their args in regs) - let - (arg_robust_amodes, liveness_mask, arg_assts) - = makePrimOpArgsRobust op arg_amodes - - liveness_arg = mkIntCLit liveness_mask - in - returnFC ( - arg_assts, - COpStmt result_amodes op - (pin_liveness op liveness_arg arg_robust_amodes) - liveness_mask - [{-no vol_regs-}] - ) - else - -- Use args from their current amodes. - let - liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n" - in - returnFC ( - COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}], - AbsCNop - ) - ) `thenFC` \ (do_before_stack_cleanup, - do_just_before_jump) -> - - case (getPrimOpResultInfo op) of - - ReturnsPrim kind -> - performReturn do_before_stack_cleanup - (\ sequel -> robustifySequel may_gc sequel - `thenFC` \ (ret_asst, sequel') -> - absC (ret_asst `mkAbsCStmts` do_just_before_jump) - `thenC` - mkPrimReturnCode sequel') - live_vars - - ReturnsAlg tycon -> - profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields] `thenC` - - performReturn do_before_stack_cleanup - (\ sequel -> robustifySequel may_gc sequel - `thenFC` \ (ret_asst, sequel') -> - absC (mkAbstractCs [ret_asst, - do_just_before_jump, - info_ptr_assign]) - -- Must load info ptr here, not in do_just_before_stack_cleanup, - -- because the info-ptr reg clashes with argument registers - -- for the primop - `thenC` - mkDynamicAlgReturnCode tycon dyn_tag sequel') - live_vars - where - - -- Here, the destination _can_ be an update frame, so we need to make sure that - -- infoptr (R2) is loaded with the constructor's info ptr. - - info_ptr_assign = CAssign (CReg infoptr) info_lbl - - info_lbl - = case (ctrlReturnConvAlg tycon) of - VectoredReturn _ -> vec_lbl - UnvectoredReturn _ -> dir_lbl - - vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep) - dyn_tag DataPtrRep - - data_con = head (tyConDataCons tycon) - - (dir_lbl, num_of_fields) - = case (dataReturnConvAlg data_con) of - ReturnInRegs rs - -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep, - mkIntCLit (length rs)) -- for ticky-ticky only - - ReturnInHeap - -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con) - -- Never used, and no point in generating - -- the code for it! + 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 (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) + = ASSERT(isEnumerationTyCon tycon) + 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 + -- 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 - -- for all PrimOps except ccalls, we pin the liveness info - -- on as the first "argument" - -- ToDo: un-duplicate? - - pin_liveness (CCallOp _ _ _ _ _) _ args = args - pin_liveness other_op liveness_arg args - = liveness_arg :args - - -- We only need to worry about the sequel when we may GC and the - -- sequel is OnStack. If that's the case, arrange to pull the - -- sequel out into RetReg before performing the primOp. - - robustifySequel True sequel@(OnStack _) = - sequelToAmode sequel `thenFC` \ amode -> - returnFC (CAssign (CReg RetReg) amode, InRetReg) - robustifySequel _ sequel = returnFC (AbsCNop, sequel) + result_info = getPrimOpResultInfo primop \end{code} %******************************************************** @@ -225,8 +202,8 @@ Case-expression conversion is complicated enough to have its own module, @CgCase@. \begin{code} -cgExpr (StgCase expr live_vars save_vars uniq alts) - = cgCase expr live_vars save_vars uniq 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} @@ -254,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??? + = 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} @@ -278,22 +254,14 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) %* SCC Expressions * %* * %******************************************************** -\subsection[scc-codegen]{Converting StgSCC} SCC expressions are treated specially. They set the current cost centre. + \begin{code} -cgExpr (StgSCC ty cc expr) - = ASSERT(sccAbleCostCentre cc) - costCentresC - (if isDictCC cc then SLIT("SET_DICT_CCC") else 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 * @@ -309,117 +277,108 @@ 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 fvs upd_flag args body) - = cgRhsClosure name cc bi fvs args body lf_info - where - lf_info = mkRhsLFInfo 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} -mkRhsLFInfo looks for two special forms of the right-hand side: +mkRhsClosure looks for two special forms of the right-hand side: a) selector thunks. - b) VAP thunks + b) AP thunks If neither happens, it just calls mkClosureLFInfo. You might think -that mkClosureLFInfo should do all this, but - - (a) it seems wrong for the latter to look at the structure - of an expression - - [March 97: item (b) is no longer true, but I've left mkRhsLFInfo here - anyway because of (a).] - - (b) mkRhsLFInfo has to be in the monad since it looks up in - the environment, and it's very tiresome for mkClosureLFInfo to - be. Apart from anything else it would make a loop between - CgBindery and ClosureInfo. +that mkClosureLFInfo should do all this, but it seems wrong for the +latter to look at the structure of an expression Selectors ~~~~~~~~~ We look at the body of the closure to see if it's a selector---turgid, but nothing deep. We are looking for a closure of {\em exactly} the form: -\begin{verbatim} + ... = [the_fv] \ u [] -> case the_fv of con a_1 ... a_n -> a_i -\end{verbatim} + \begin{code} -mkRhsLFInfo [the_fv] -- Just one free var - Updatable -- Updatable thunk +mkRhsClosure dflags bndr cc bi srt + [the_fv] -- Just one free var + upd_flag -- Updatable thunk [] -- A thunk - (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _) - _ _ _ -- ignore live vars and uniq... - (StgAlgAlts case_ty - [(con, params, use_mask, - (StgApp (StgVarArg selectee) [{-no args-}] _))] - StgNoDefault)) - | the_fv == scrutinee -- Scrutinee is the only free variable - && maybeToBool maybe_offset -- Selectee is a component of the tuple - && maybeToBool offset_into_int_maybe + body@(StgCase (StgApp scrutinee [{-no args-}]) + _ _ _ _ -- ignore uniq, etc. + (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) -- Should be true, but causes error for SpecTyCon - mkSelectorLFInfo scrutinee con offset_into_int + = -- 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 - (_, 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_maybe = intOffsetIntoGoods the_offset - Just offset_into_int = offset_into_int_maybe - is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) - tycon = dataConTyCon con + offset_into_int = the_offset - fixedHdrSize \end{code} +Ap thunks +~~~~~~~~~ -Vap thunks -~~~~~~~~~~ -Same kind of thing, looking for vector-apply thunks, of the form: +A more generic AP thunk of the form - x = [...] \ .. [] -> f a1 .. an + x = [ x_1...x_n ] \.. [] -> x_1 ... x_n -where f has arity n. We rely on the arity info inside the Id being correct. +A set of these is compiled statically into the RTS, so we just use +those. We could extend the idea to thunks where some of the x_i are +global ids (and hence not free variables), but this would entail +generating a larger thunk. It might be an option for non-optimising +compilation, though. + +We only generate an Ap thunk if all the free variables are pointers, +for semi-obvious reasons. \begin{code} -mkRhsLFInfo fvs +mkRhsClosure dflags bndr cc bi srt + fvs upd_flag [] -- No args; a thunk - (StgApp (StgVarArg fun_id) args _) - | isLocallyDefined fun_id -- Must be defined in this module - = -- Get the arity of the fun_id. It's guaranteed to be correct (by setStgVarInfo). - let - arity_maybe = case getIdArity fun_id of - ArityExactly n -> Just n - other -> Nothing - in - case arity_maybe of - Just arity - | arity > 0 && -- It'd better be a function! - arity == length args -- Saturated application - -> -- Ha! A VAP thunk - mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap - - other -> mkClosureLFInfo False{-not top level-} fvs upd_flag [] - where - -- If the function is a free variable then it must be stored - -- in the thunk too; if it isn't a free variable it must be - -- because it's constant, so it doesn't need to be stored in the thunk - store_fun_in_vap = fun_id `is_elem` fvs - is_elem = isIn "mkClosureLFInfo" + body@(StgApp fun_id args) + + | args `lengthIs` (arity-1) + && all isFollowableArg (map idCgRep fvs) + && isUpdatable upd_flag + && arity <= mAX_SPEC_AP_SIZE + + -- Ha! an Ap thunk + = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload + + where + 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 \end{code} The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsLFInfo fvs upd_flag args body - = mkClosureLFInfo False{-not top level-} fvs upd_flag args +mkRhsClosure dflags bndr cc bi srt fvs upd_flag args body + = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} @@ -429,71 +388,67 @@ mkRhsLFInfo 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 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 rhs_eob_info - maybe_cc_slot b e | (b,e) <- pairs ] - ) `thenFC` \ new_bindings -> + = 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 ] }) - 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! - full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs]) + full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs]) cgLetNoEscapeRhs :: StgLiveVars -- Live in rhss -> EndOfBlockInfo - -> Maybe VirtualSpBOffset + -> Maybe VirtualSpOffset + -> RecFlag -> Id -> StgRhs -> FCode (Id, CgIdInfo) -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder - (StgRhsClosure cc bi _ upd_flag args body) +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder + (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 full_live_in_rhss rhs_eob_info maybe_cc_slot 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 binder +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder (StgRhsCon cc con args) - = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot + = 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 con args full_live_in_rhss) + (StgConApp con args) \end{code} -Some PrimOps require a {\em fixed} amount of heap allocation. Rather -than tidy away ready for GC and do a full heap check, we simply -allocate a completely uninitialised block in-line, just like any other -thunk/constructor allocation, and pass it to the PrimOp as its first -argument. Remember! The PrimOp is entirely responsible for -initialising the object. In particular, the PrimOp had better not -trigger GC before it has filled it in, and even then it had better -make sure that the GC can find the object somehow. - -Main current use: allocating SynchVars. +Little helper for primitives that return unboxed tuples. \begin{code} -getPrimOpArgAmodes op args - = getArgAmodes args `thenFC` \ arg_amodes -> - - case primOpHeapReq op of - FixedHeapRequired size -> allocHeap size `thenFC` \ amode -> - returnFC (amode : arg_amodes) - - _ -> returnFC arg_amodes +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} - -