%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.49 2002/06/18 13:58:23 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.57 2004/03/31 15:23:16 simonmar Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
-import AbsCUtils ( mkAbstractCs )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
+import CoreSyn ( AltCon(..) )
import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
nukeDeadBindings, addBindC, addBindsC )
-import CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre )
+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
+ tailCallPrimOp, ccallReturnUnboxedTuple
)
import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
mkApLFInfo, layOutDynConstr )
import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
-import Id ( idPrimRep, idType, Id )
+import Id ( idPrimRep, Id )
import VarSet
-import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
+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 )
(\ 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
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}
\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
\begin{code}
-cgExpr (StgLet (StgNonRec srt name rhs) expr)
- = cgRhs srt name rhs `thenFC` \ (name, info) ->
+cgExpr (StgLet (StgNonRec name rhs) expr)
+ = cgRhs name rhs `thenFC` \ (name, info) ->
addBindC name info `thenC`
cgExpr expr
-cgExpr (StgLet (StgRec srt pairs) expr)
+cgExpr (StgLet (StgRec pairs) expr)
= fixC (\ new_bindings -> addBindsC new_bindings `thenC`
- listFCs [ cgRhs srt b e | (b,e) <- pairs ]
+ listFCs [ cgRhs b e | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings `thenC`
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 ->
-- Save those variables right now!
absC save_assts `thenC`
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
-cgRhs srt name (StgRhsCon maybe_cc con args)
+cgRhs name (StgRhsCon maybe_cc con args)
= getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
returnFC (name, idinfo)
-cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
+cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
\end{code}
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
- (StgAlgAlts (Just tycon)
- [(con, params, use_mask,
- (StgApp selectee [{-no args-}]))]
- StgNoDefault))
+ (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
-- 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) = layOutDynConstr bogus_name con idPrimRep params
+ 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
- bogus_name = panic "mkRhsClosure"
\end{code}
Ap thunks
= 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
%********************************************************
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
- (StgNonRec srt binder rhs)
+ (StgNonRec binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive srt binder rhs
+ NonRecursive binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
- (StgRec srt pairs)
+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 Recursive srt b e
+ rhs_eob_info maybe_cc_slot Recursive b e
| (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
-> EndOfBlockInfo
-> Maybe VirtualSpOffset
-> RecFlag
- -> SRT
-> Id
-> StgRhs
-> FCode (Id, CgIdInfo)
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt 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
-- 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 srt binder
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
+ = 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)
\begin{code}
primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
- = getArgAmodes args `thenFC` \ arg_amodes ->
+ = 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 getArgPrimRep args
+ arg_reps = map getAmodeRep arg_amodes
arg_temps = zipWith CTemp arg_uniqs arg_reps
in
absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
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 []))
+ 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}
projects / ghc-hetmet.git / blobdiff