%
-% (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 $
%
%********************************************************
%* *
%********************************************************
\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
@(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}
%********************************************************
%********************************************************
\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}
%********************************************************
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}
\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}
%* 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 *
-- 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}
%* *
%********************************************************
\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}
-
-
projects / ghc-hetmet.git / blobdiff