%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.64 2003/07/02 13:18:24 simonpj Exp $
+% $Id: CgCase.lhs,v 1.68 2004/08/10 09:02:38 simonmar Exp $
%
%********************************************************
%* *
import StgSyn
import AbsCSyn
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
+ getAmodeRep, shimFCallArg )
import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
getCAddrModeAndInfo,
)
import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
+import ForeignCall
import Util ( only )
import List ( sortBy )
import Outputable
bindNewToTemp bndr `thenFC` \ tmp_amode ->
absC (CAssign tmp_amode amode) `thenC`
cgPrimAlts NoGC tmp_amode alts alt_type
-\end{code}
+\end{code}
-Special case #3: inline PrimOps.
+Special case #3: inline PrimOps and foreign calls.
\begin{code}
-cgCase (StgOpApp op@(StgPrimOp primop) args _)
+cgCase (StgOpApp op args _)
live_in_whole_case live_in_alts bndr srt alt_type alts
- | not (primOpOutOfLine primop)
+ | inline_primop
= -- Get amodes for the arguments and results
- getArgAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes1 ->
+ let
+ arg_amodes
+ | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
+ | otherwise = arg_amodes1
+ in
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
case alt_type of
[(_, res_ids, _, rhs)] = alts
AlgAlt tycon -- ENUMERATION TYPE RETURN
+ | StgPrimOp primop <- op
-> ASSERT( isEnumerationTyCon tycon )
+ let
+ do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
+ do_enum_primop TagToEnumOp -- No code!
+ = returnFC (only arg_amodes)
+
+ do_enum_primop primop
+ = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+ returnFC tag_amode
+ where
+ tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+ -- Being a bit short of uniques for temporary
+ -- variables here, we use newTagUnique to
+ -- generate a new unique from the case binder.
+ -- The case binder's unique will presumably
+ -- have the 'c' tag (generated by CoreToStg),
+ -- so we just change its tag to 'C' (for
+ -- 'case') to ensure it doesn't clash with
+ -- anything else. We can't use the unique
+ -- from the case binder, becaus e this is used
+ -- to hold the actual result closure (via the
+ -- call to bindNewToTemp)
+ in
do_enum_primop primop `thenFC` \ tag_amode ->
-- Bind the default binder if necessary
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts)
- where
- do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
- do_enum_primop TagToEnumOp -- No code!
- = returnFC (only arg_amodes)
-
- do_enum_primop primop
- = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
- returnFC tag_amode
- where
- tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
- -- Being a bit short of uniques for temporary variables here,
- -- we use newTagUnique to generate a new unique from the case
- -- binder. The case binder's unique will presumably have
- -- the 'c' tag (generated by CoreToStg), so we just change
- -- its tag to 'C' (for 'case') to ensure it doesn't clash with
- -- anything else.
- -- We can't use the unique from the case binder, becaus e
- -- this is used to hold the actual result closure
- -- (via the call to bindNewToTemp)
other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
+ where
+ inline_primop = case op of
+ StgPrimOp primop -> not (primOpOutOfLine primop)
+ --StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
+ -- unsafe foreign calls are "inline"
+ _otherwise -> False
+
\end{code}
TODO: Case-of-case of primop can probably be done inline too (but
forkAbsC ( -- forkAbsC for the RHS, so that the envt is
-- not changed for the mkRetDirect call
- restoreCurrentCostCentre cc_slot `thenC`
bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
+ -- restore the CC *after* binding the tuple components, so that we
+ -- get the stack offset of the saved CC right.
+ restoreCurrentCostCentre cc_slot True `thenC`
-- Generate a heap check if necessary
- unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop $
+ unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop (
-- And finally the code for the alternative
cgExpr rhs
- ) `thenFC` \ abs_c ->
+ )) `thenFC` \ abs_c ->
mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
returnFC (CaseAlts lbl Nothing False)
cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
= forkAbsC ( -- forkAbsC for the RHS, so that the envt is
-- not changed for the mkRetDirect call
- restoreCurrentCostCentre cc_slot `thenC`
+ restoreCurrentCostCentre cc_slot True `thenC`
bindNewToReg bndr reg (mkLFArgument bndr) `thenC`
cgPrimAlts GCMayHappen (CReg reg) alts alt_type
) `thenFC` \ abs_c ->
cgAlgAlt gc_flag uniq cc_slot must_label_branch
alt_type (con, args, use_mask, rhs)
= getAbsC (bind_con_args con args `thenFC` \ _ ->
- restoreCurrentCostCentre cc_slot `thenC`
+ restoreCurrentCostCentre cc_slot True `thenC`
maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)
) `thenFC` \ abs_c ->
let
returnFC (Just slot,
CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Code
-restoreCurrentCostCentre Nothing = nopC
-restoreCurrentCostCentre (Just slot)
- = getSpRelOffset slot `thenFC` \ sp_rel ->
- freeStackSlots [slot] `thenC`
+-- Sometimes we don't free the slot containing the cost centre after restoring it
+-- (see CgLetNoEscape.cgLetNoEscapeBody).
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
+restoreCurrentCostCentre Nothing _freeit = nopC
+restoreCurrentCostCentre (Just slot) freeit
+ = getSpRelOffset slot `thenFC` \ sp_rel ->
+ (if freeit then freeStackSlots [slot] else nopC) `thenC`
absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
-- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCCS
projects / ghc-hetmet.git / blobdiff