%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgExpr.lhs,v 1.57 2004/03/31 15:23:16 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
-
-module CgExpr (
- cgExpr, cgSccExpr, getPrimOpArgAmodes,
-
- -- and to make the interface self-sufficient...
- StgExpr, Id, CgState
- ) where
+module CgExpr ( cgExpr ) where
-IMPORT_Trace -- NB: not just for debugging
-import Outputable -- ToDo: rm (just for debugging)
-import Pretty -- ToDo: rm (just for debugging)
+#include "HsVersions.h"
+import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
import StgSyn
import CgMonad
import AbsCSyn
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CLabel ( mkClosureTblLabel )
-import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
- primOpHeapReq, getPrimOpResultInfo, PrimKind,
- primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( isPrimType, getTyConDataCons )
-import CLabelInfo ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CgBindery ( getAtomAmodes )
+import SMRep ( fixedHdrSize )
+import CoreSyn ( AltCon(..) )
+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 -- various things...
-import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode,
- mkPrimReturnCode
- )
-import CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre )
-import Maybes ( Maybe(..) )
-import PrimKind ( getKindSize )
-import UniqSet
-import Util
+import CgRetConv ( dataReturnConvPrim )
+import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
+ mkDynamicAlgReturnCode, mkPrimReturnCode,
+ tailCallPrimOp, ccallReturnUnboxedTuple
+ )
+import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
+ mkApLFInfo, layOutDynConstr )
+import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
+import Id ( idPrimRep, Id )
+import VarSet
+import PrimOp ( primOpOutOfLine, getPrimOpResultInfo,
+ PrimOp(..), PrimOpResultInfo(..) )
+import TysPrim ( foreignObjPrimTyCon, arrayPrimTyCon,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+ mutableArrayPrimTyCon )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import TyCon ( isUnboxedTupleTyCon, isEnumerationTyCon )
+import Type ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
+import Maybes ( maybeToBool )
+import ListSetOps ( assocMaybe )
+import Unique ( mkBuiltinUnique )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import Util ( lengthIs )
+import Outputable
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
with closures, and @CgCon@, which deals with constructors.
\begin{code}
-cgExpr :: PlainStgExpr -- input
+cgExpr :: StgExpr -- input
-> Code -- output
\end{code}
``Applications'' mean {\em tail calls}, a service provided by module
@CgTailCall@. This includes literals, which show up as
-@(STGApp (StgLitAtom 42) [])@.
+@(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 (StgConApp con args live_vars)
- = getAtomAmodes args `thenFC` \ amodes ->
- cgReturnDataCon con amodes (all zero_size args) live_vars
- where
- zero_size atom = getKindSize (getAtomKind atom) == 0
+cgExpr (StgConApp con args)
+ = getArgAmodes args `thenFC` \ amodes ->
+ 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)
+ = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
+\end{code}
+
+
%********************************************************
%* *
%* STG PrimApps (unboxed primitive ops) *
Here is where we insert real live machine instructions.
+NOTE about _ccall_GC_:
+
+A _ccall_GC_ is treated as an out-of-line primop (returns True
+for primOpOutOfLine) so that when we see the call in case context
+ case (ccall ...) of { ... }
+we get a proper stack frame on the stack when we perform it. When we
+get in a tail-call position, however, we need to actually perform the
+call, so we treat it as an inline primop.
+
\begin{code}
-cgExpr x@(StgPrimApp op args live_vars)
- = -- trace ("cgExpr:PrimApp:"++(ppShow 80 (ppr PprDebug x))) (
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
- 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,
- mkAbstractCs [
- spat_prim_macro,
- COpStmt result_amodes op
- (pin_liveness op liveness_arg arg_robust_amodes)
- liveness_mask
- [{-no vol_regs-}],
- spat_prim_stop_macro ]
- )
- else
- -- Use args from their current amodes.
- let
- liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
- in
- returnFC (
--- DO NOT want CCallProfMacros in CSimultaneous stuff. Yurgh. (WDP 95/01)
--- Arises in compiling PreludeGlaST (and elsewhere??)
--- mkAbstractCs [
--- spat_prim_macro,
- COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
--- spat_prim_stop_macro ],
- AbsCNop
- )
- ) `thenFC` \ (do_before_stack_cleanup,
- do_just_before_jump) ->
-
- case (getPrimOpResultInfo op) of
+cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
+ = primRetUnboxedTuple op args res_ty
+
+-- 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)
+ 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)
+ (CVal (CIndex
+ (CLbl (mkClosureTblLabel tycon) PtrRep)
+ dyn_tag PtrRep) PtrRep))
+ (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
+ where
+ dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
+ -- The '0' is just to get a random spare temp
+ --
+ -- 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
+
+ | otherwise
+ = getArgAmodes args `thenFC` \ arg_amodes ->
+
+ case (getPrimOpResultInfo primop) 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 ->
---OLD: evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
- profCtrC SLIT("RET_NEW_IN_REGS") [] `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
- = -- OLD: pprTrace "ctrlReturn7:" (ppr PprDebug tycon) (
- case (ctrlReturnConvAlg tycon) of
- VectoredReturn _ -> vec_lbl
- UnvectoredReturn _ -> dir_lbl
- -- )
-
- vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrKind)
- dyn_tag DataPtrKind
-
- data_con = head (getTyConDataCons tycon)
- dir_lbl = case dataReturnConvAlg data_con of
- ReturnInRegs _ -> CLbl (mkPhantomInfoTableLabel data_con)
- DataPtrKind
- ReturnInHeap -> panic "CgExpr: can't return prim in heap"
- -- Never used, and no point in generating
- -- the code for it!
- 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)
-
- spat_prim_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]
- spat_prim_stop_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]
+ 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 = CVal (CIndex
+ (CLbl (mkClosureTblLabel tycon) PtrRep)
+ dyn_tag PtrRep) PtrRep
\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}
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
+ saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
- -- ToDo: cost centre???
-
- -- Save those variables right now!
+ -- Save those variables right now!
absC save_assts `thenC`
-- Produce code for the rhss
%* SCC Expressions *
%* *
%********************************************************
-\subsection[scc-codegen]{Converting StgSCC}
SCC expressions are treated specially. They set the current cost
centre.
-
-For evaluation scoping we also need to save the cost centre in an
-``restore CC frame''. We only need to do this once before setting all
-nested SCCs.
-
\begin{code}
-cgExpr scc_expr@(StgSCC ty cc expr)
---OLD:WDP:94/06 = evalPushRCCFrame (isPrimType ty) (cgSccExpr scc_expr)
- = cgSccExpr scc_expr
+cgExpr (StgSCC cc expr)
+ = ASSERT(sccAbleCostCentre cc)
+ costCentresC
+ FSLIT("SET_CCC")
+ [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
+ `thenC`
+ cgExpr expr
\end{code}
-@cgSccExpr@ (also used in \tr{CgClosure}):
-We *don't* set the cost centre for CAF/Dict cost centres
-[Likewise Subsumed and NoCostCentre, but they probably
-don't exist in an StgSCC expression.]
-\begin{code}
-cgSccExpr (StgSCC ty cc expr)
- = (if setToAbleCostCentre cc then
- costCentresC SLIT("SET_CCC")
- [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)]
- else
- nopC) `thenC`
- cgSccExpr expr
-cgSccExpr other
- = cgExpr other
-\end{code}
+ToDo: counting of dict sccs ...
%********************************************************
%* *
%********************************************************
\subsection[non-top-level-bindings]{Converting non-top-level bindings}
-@cgBinding@ is only used for let/letrec, not for unboxed bindings.
-So the kind should always be @PtrKind@.
-
We rely on the support code in @CgCon@ (to do constructors) and
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
+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)
- = getAtomAmodes args `thenFC` \ amodes ->
- buildDynCon name maybe_cc con amodes (all zero_size args)
- `thenFC` \ idinfo ->
+ = getArgAmodes args `thenFC` \ amodes ->
+ buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
returnFC (name, idinfo)
+
+cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
+ = mkRhsClosure name cc bi srt fvs upd_flag args body
+\end{code}
+
+mkRhsClosure looks for two special forms of the right-hand side:
+ a) selector thunks.
+ b) AP thunks
+
+If neither happens, it just calls mkClosureLFInfo. You might think
+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:
+
+... = [the_fv] \ u [] ->
+ case the_fv of
+ con a_1 ... a_n -> a_i
+
+
+\begin{code}
+mkRhsClosure 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.
+ (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
+ = -- 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
- zero_size atom = getKindSize (getAtomKind atom) == 0
+ lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr con idPrimRep params
+ -- Just want the layout
+ maybe_offset = assocMaybe params_w_offsets selectee
+ Just the_offset = maybe_offset
+ offset_into_int = the_offset - fixedHdrSize
+\end{code}
+
+Ap thunks
+~~~~~~~~~
+
+A more generic AP thunk of the form
+
+ x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
-cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
- = cgRhsClosure name cc bi fvs args body lf_info
+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}
+mkRhsClosure bndr cc bi srt
+ fvs
+ upd_flag
+ [] -- No args; a thunk
+ body@(StgApp fun_id args)
+
+ | args `lengthIs` (arity-1)
+ && all isFollowableRep (map idPrimRep 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}
+mkRhsClosure bndr cc bi srt fvs upd_flag args body
+ = cgRhsClosure bndr cc bi srt fvs args body lf_info
where
- lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
+ lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
\end{code}
+
+%********************************************************
+%* *
+%* Let-no-escape bindings
+%* *
+%********************************************************
\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
+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 (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 ]
+ listFCs [ cgLetNoEscapeRhs full_live_in_rhss
+ rhs_eob_info maybe_cc_slot Recursive b e
+ | (b,e) <- pairs ]
) `thenFC` \ 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 `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
+ full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
-cgLetNoEscapeRhs
- :: PlainStgLiveVars -- Live in rhss
- -> EndOfBlockInfo
- -> Maybe VirtualSpBOffset
+cgLetNoEscapeRhs
+ :: StgLiveVars -- Live in rhss
+ -> EndOfBlockInfo
+ -> Maybe VirtualSpOffset
+ -> RecFlag
-> Id
- -> PlainStgRhs
+ -> 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
+-- 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
- (StgConApp 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.
+Little helper for primitives that return unboxed tuples.
-Main current use: allocating SynchVars.
\begin{code}
-getPrimOpArgAmodes op args
- = getAtomAmodes args `thenFC` \ arg_amodes ->
-
- case primOpHeapReq op of
-
- FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
- returnFC (amode : arg_amodes)
-
- _ -> returnFC arg_amodes
+primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
+primRetUnboxedTuple op args res_ty
+ = getArgAmodes args `thenFC` \ arg_amodes1 ->
+ {-
+ For a foreign call, we might need to fiddle with some of the args:
+ for example, when passing a ByteArray#, we pass a ptr to the goods
+ rather than the heap object.
+ -}
+ let
+ arg_amodes
+ | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
+ | otherwise = arg_amodes1
+ in
+ {-
+ 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 getAmodeRep arg_amodes
+ 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
+ ty_args = tyConAppArgs (repType res_ty)
+ 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
+ ccallReturnUnboxedTuple temp_amodes
+ (absC (COpStmt temp_amodes op arg_temps []))
+
+
+shimFCallArg arg amode
+ | tycon == foreignObjPrimTyCon
+ = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
+ | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+ = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
+ | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+ = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
+ | otherwise = amode
+ where
+ -- should be a tycon app, since this is a foreign call
+ tycon = tyConAppTyCon (repType (stgArgType arg))
\end{code}
-
-