%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.51 2002/09/13 15:02:28 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.57 2004/03/31 15:23:16 simonmar Exp $
%
%********************************************************
%* *
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(..) )
(\ 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)
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
projects / ghc-hetmet.git / blobdiff