%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.18 1998/12/02 13:17:46 simonm Exp $
+% $Id: CgCase.lhs,v 1.33 1999/06/24 13:04:16 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,
- splitAlgTyConAppThroughNewTypes ) where
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
+ ) where
#include "HsVersions.h"
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
getAmodeRep, nonemptyAbsC
)
-import CoreSyn ( isDeadBinder )
import CgUpdate ( reserveSeqFrame )
-import CgBindery ( getVolatileRegs, getArgAmodes,
+import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode,
bindNewToReg, bindNewToTemp,
bindNewPrimToAmode,
rebindToStack, getCAddrMode,
getCAddrModeAndInfo, getCAddrModeIfVolatile,
- buildContLivenessMask, nukeDeadBindings
+ buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
import CgHeapery ( altHeapCheck, yield )
CtrlReturnConvention(..)
)
import CgStackery ( allocPrimStack, allocStackTop,
- deAllocStackTop, freeStackSlots
+ deAllocStackTop, freeStackSlots, dataStackSlots
)
import CgTailCall ( tailCallFun )
import CgUsages ( getSpRelOffset, getRealSp )
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( CostCentre )
+import CoreSyn ( isDeadBinder )
import Id ( Id, idPrimRep )
import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
isUnboxedTupleCon, dataConType )
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
- isNewTyCon, isAlgTyCon,
+ isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
tyConDataCons, tyConFamilySize )
-import Type ( GenType(..), typePrimRep, splitAlgTyConApp, Type,
- splitFunTys, applyTys )
-import Unique ( Unique, Uniquable(..) )
+import Type ( Type, typePrimRep, splitAlgTyConApp,
+ splitTyConApp_maybe, splitRepTyConApp_maybe )
+import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
import Maybes ( maybeToBool )
+import Util
import Outputable
\end{code}
This never hurts us if there is only one alternative.
-
-*** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
-to take account of what is live, and that includes all live volatile
-variables, even if they also have stable analogues. Furthermore, the
-stack pointers must be lined up properly so that GC sees tidy stacks.
-If these things are done, then the heap checks can be done at \tr{!B!} and
-\tr{!C!} without a full save-volatile-vars sequence.
-
\begin{code}
cgCase :: StgExpr
-> StgLiveVars
-> Code
\end{code}
-Several special cases for inline primitive operations.
+Special case #1: PrimOps returning enumeration types.
+
+For enumeration types, we invent a temporary (builtin-unique 1) to
+hold the tag, and cross our fingers that this doesn't clash with
+anything else. Builtin-unique 0 is used for a similar reason when
+compiling enumerated-type primops in CgExpr.lhs. We can't use the
+unique from the case binder, because this is used to hold the actual
+closure (when the case binder is live, that is).
+
+There is an extra special case for
+
+ case tagToEnum# x of
+ ...
+
+which generates no code for the primop, unless x is used in the
+alternatives (in which case we lookup the tag in the relevant closure
+table to get the closure).
\begin{code}
-cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt alts
+cgCase (StgCon (PrimOp op) args res_ty)
+ live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
+ | isEnumerationTyCon tycon
+ = getArgAmodes args `thenFC` \ arg_amodes ->
+
+ let tag_amode = case op of
+ TagToEnumOp -> only arg_amodes
+ _ -> CTemp (mkBuiltinUnique 1) IntRep
+
+ closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
+ in
+
+ case op of {
+ TagToEnumOp -> nopC; -- no code!
+
+ _ -> -- Perform the operation
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
+
+ absC (COpStmt [tag_amode] op
+ arg_amodes -- note: no liveness arg
+ vol_regs)
+ } `thenC`
+
+ -- bind the default binder if necessary
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToTemp bndr `thenFC` \ bndr_amode ->
+ absC (CAssign bndr_amode closure))
+ `thenC`
+
+ -- compile the alts
+ cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
+ False{-not poly case-} alts deflt
+ False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
+
+ -- Do the switch
+ absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
+
+ where
+ (Just (tycon,_)) = splitTyConApp_maybe res_ty
+ uniq = getUnique bndr
+\end{code}
+
+Special case #2: inline PrimOps.
+
+\begin{code}
+cgCase (StgCon (PrimOp op) args res_ty)
+ live_in_whole_case live_in_alts bndr srt alts
| not (primOpOutOfLine op)
=
-- Get amodes for the arguments and results
cgInlineAlts bndr alts
\end{code}
+TODO: Case-of-case of primop can probably be done inline too (but
+maybe better to translate it out beforehand). See
+ghc/lib/misc/PackedString.lhs for examples where this crops up (with
+4.02).
+
Another special case: scrutinising a primitive-typed variable. No
evaluation required. We don't save volatile variables, nor do we do a
heap-check in the alternatives. Instead, the heap usage of the
two bindings pointing at the same stack locn doesn't work (it
confuses nukeDeadBindings). Hence, use a new temp.
-}
- (if (isDeadBinder bndr)
- then nopC
- else bindNewToTemp bndr `thenFC` \deflt_amode ->
- absC (CAssign deflt_amode amode)) `thenC`
+ bindNewToTemp bndr `thenFC` \deflt_amode ->
+ absC (CAssign deflt_amode amode) `thenC`
cgPrimAlts NoGC amode alts deflt []
\end{code}
:: Unique
-> StgCaseAlts
-> [CAddrMode]
-\end{code}
-
-\begin{code}
--- If there's an StgBindDefault which does use the bound
--- variable, then we can only handle it if the type involved is
--- an enumeration type. That's important in the case
--- of comparisions:
---
--- case x ># y of
--- r -> f r
---
--- The only reason for the restriction to *enumeration* types is our
--- inability to invent suitable temporaries to hold the results;
--- Elaborating the CTemp addr mode to have a second uniq field
--- (which would simply count from 1) would solve the problem.
--- Anyway, cgInlineAlts is now capable of handling all cases;
--- it's only this function which is being wimpish.
-
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts
- (StgBindDefault rhs))
- | isEnumerationTyCon spec_tycon = [tag_amode]
- | otherwise = pprPanic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" (ppr uniq <+> ppr rhs)
- where
- -- A temporary variable to hold the tag; this is unaffected by GC because
- -- the heap-checks in the branches occur after the switch
- tag_amode = CTemp uniq IntRep
- (spec_tycon, _, _) = splitAlgTyConApp ty
-\end{code}
-
-If we don't have a default case, we could be scrutinising an unboxed
-tuple, or an enumeration type...
-\begin{code}
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
- -- Default is either StgNoDefault or StgBindDefault with unused binder
-
- | isEnumerationTyCon tycon = [CTemp uniq IntRep]
+getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
| isUnboxedTupleTyCon tycon =
case alts of
| otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
where (tycon, _, _) = splitAlgTyConApp ty
-\end{code}
-The situation is simpler for primitive results, because there is only
-one!
+-- The situation is simpler for primitive results, because there is only
+-- one!
-\begin{code}
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
= [CTemp uniq (typePrimRep ty)]
\end{code}
=
let uniq = getUnique bndr in
- -- Generate the instruction to restore cost centre, if any
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-
- -- get the stack liveness for the info table (after the CC slot has
- -- been freed - this is important).
buildContLivenessMask uniq `thenFC` \ liveness_mask ->
case alts of
(StgAlgAlts ty alts deflt) ->
-- bind the default binder (it covers all the alternatives)
- (if (isDeadBinder bndr)
- then nopC
- else bindNewToReg bndr node mkLFArgument) `thenC`
+ bindNewToReg bndr node mkLFArgument `thenC`
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
if is_alg && isUnboxedTupleTyCon spec_tycon then
case alts of
[alt] -> let lbl = mkReturnInfoLabel uniq in
- cgUnboxedTupleAlt lbl cc_restore True alt
+ cgUnboxedTupleAlt uniq cc_slot True alt
`thenFC` \ abs_c ->
getSRTLabel `thenFC` \srt_label ->
absC (CRetDirect uniq abs_c (srt_label, srt)
Nothing -- no semi-tagging info
in
- cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts (not is_alg)
+ cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
-- primitive alts...
(StgPrimAlts ty alts deflt) ->
+ -- Restore the cost centre
+ restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+
-- Generate the switch
getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
(srt_label,srt) liveness_mask) `thenC`
-- Return an amode for the block
- returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)
+ returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
\end{code}
= panic "cgInlineAlts: single alternative, not an unboxed tuple"
\end{code}
-Hack: to deal with
-
- case <# x y of z {
- DEFAULT -> ...
- }
-
-\begin{code}
-cgInlineAlts bndr (StgAlgAlts ty [] (StgBindDefault rhs))
- = bindNewToTemp bndr `thenFC` \amode ->
- let
- (tycon, _, _) = splitAlgTyConApp ty
- closure_lbl = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) amode PtrRep
- in
- absC (CAssign amode closure_lbl) `thenC`
- cgExpr rhs
-\end{code}
-
-Second case: algebraic case, several alternatives.
-Tag is held in a temporary.
-
-\begin{code}
-cgInlineAlts bndr (StgAlgAlts ty alts deflt)
- = cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
- False{-not poly case-} alts deflt
- False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-
- -- Do the switch
- absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
- where
- -- A temporary variable to hold the tag; this is unaffected by GC because
- -- the heap-checks in the branches occur after the switch
- tag_amode = CTemp uniq IntRep
- uniq = getUnique bndr
-\end{code}
-
Third (real) case: primitive result type.
\begin{code}
= cgPrimInlineAlts bndr ty alts deflt
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
\begin{code}
cgAlgAlts :: GCFlag
-> Unique
- -> AbstractC -- Restore-cost-centre instruction
+ -> Maybe VirtualSpOffset
-> Bool -- True <=> branches must be labelled
-> Bool -- True <=> polymorphic case
-> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
\begin{code}
cgAlgDefault :: GCFlag
-> Bool -- could be a function-typed result?
- -> Unique -> AbstractC -> Bool -- turgid state...
+ -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
-> StgCaseDefault -- input
-> Bool
-> FCode AbstractC -- output
-cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _
+cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
= returnFC AbsCNop
-cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch
+cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
(StgBindDefault rhs)
emit_yield{-should a yield macro be emitted?-}
= -- We have arranged that Node points to the thing
+ restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
getAbsC (absC restore_cc `thenC`
(if opt_GranMacros && emit_yield
then yield [node] False
-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
cgAlgAlt :: GCFlag
- -> Unique -> AbstractC -> Bool -- turgid state
+ -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
-> Bool -- Context switch at alts?
-> (DataCon, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
-cgAlgAlt gc_flag uniq restore_cc must_label_branch
+cgAlgAlt gc_flag uniq cc_slot must_label_branch
emit_yield{-should a yield macro be emitted?-}
(con, args, use_mask, rhs)
- = getAbsC (absC restore_cc `thenC`
+ =
+ restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
+ getAbsC (absC restore_cc `thenC`
(if opt_GranMacros && emit_yield
then yield [node] True -- XXX live regs wrong
else absC AbsCNop) `thenC`
lbl = mkAltLabel uniq tag
cgUnboxedTupleAlt
- :: CLabel -- label of the alternative
- -> AbstractC -- junk
+ :: Unique -- unique for label of the alternative
+ -> Maybe VirtualSpOffset -- Restore cost centre
-> Bool -- ctxt switch
-> (DataCon, [Id], [Bool], StgExpr) -- alternative
-> FCode AbstractC
-cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs)
+cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
= getAbsC (
- absC restore_cc `thenC`
-
bindUnboxedTupleComponents args
`thenFC` \ (live_regs,tags,stack_res) ->
+
+ restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
+ absC restore_cc `thenC`
+
(if opt_GranMacros && emit_yield
then yield live_regs True -- XXX live regs wrong?
else absC AbsCNop) `thenC`
cgPrimEvalAlts bndr ty alts deflt
= cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
where
- reg = dataReturnConvPrim kind
+ reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
+ dataReturnConvPrim kind
kind = typePrimRep ty
cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
= -- first bind the default if necessary
- (if isDeadBinder bndr
- then nopC
- else bindNewPrimToAmode bndr scrutinee) `thenC`
+ bindNewPrimToAmode bndr scrutinee `thenC`
cgPrimAlts gc_flag scrutinee alts deflt regs
cgPrimAlts gc_flag scrutinee alts deflt regs
= if not opt_SccProfilingOn then
returnFC (Nothing, AbsCNop)
else
- allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+ allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+ dataStackSlots [slot] `thenC`
getSpRelOffset slot `thenFC` \ sp_rel ->
returnFC (Just slot,
CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
-
-restoreCurrentCostCentre Nothing
- = returnFC AbsCNop
+restoreCurrentCostCentre Nothing = returnFC AbsCNop
restoreCurrentCostCentre (Just slot)
= getSpRelOffset slot `thenFC` \ sp_rel ->
freeStackSlots [slot] `thenC`
-> Bool -- True <=> algebraic case
-> [MagicId] -- live registers
-> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> Maybe CLabel -- return address
+ -> Maybe Unique -- return address unique
-> Code -- continuation
-> Code
= code
\end{code}
-splitTyConAppThroughNewTypes is like splitAlgTyConApp_maybe except
-that it looks through newtypes in addition to synonyms. It's
-useful in the back end where we're not interested in newtypes
-anymore.
-
-Sometimes, we've thrown away the constructors during pruning in the
-renamer. In these cases, we emit a warning and fall back to using a
-SEQ_FRAME to evaluate the case scrutinee.
-
\begin{code}
getScrutineeTyCon :: Type -> Maybe TyCon
getScrutineeTyCon ty =
- case (splitAlgTyConAppThroughNewTypes ty) of
+ case splitRepTyConApp_maybe ty of
Nothing -> Nothing
Just (tc,_) ->
- if not (isAlgTyCon tc) then Just tc else
- case (tyConFamilySize tc) of
- 0 -> pprTrace "Warning" (hcat [
- text "constructors for ",
- ppr tc,
- text " not available.\n\tUse -fno-prune-tydecls to fix."
- ]) Nothing
- _ -> Just tc
-
-splitAlgTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type])
-splitAlgTyConAppThroughNewTypes (TyConApp tc tys)
- | isNewTyCon tc =
- case (tyConDataCons tc) of
- [con] -> let ([ty], _) = splitFunTys
- (applyTys (dataConType con) tys)
- in splitAlgTyConAppThroughNewTypes ty
- _ -> Nothing
- | otherwise = Just (tc, tys)
-
-splitAlgTyConAppThroughNewTypes (NoteTy _ ty) =
- splitAlgTyConAppThroughNewTypes ty
-splitAlgTyConAppThroughNewTypes other = Nothing
+ if isFunTyCon tc then Nothing else -- not interested in funs
+ if isPrimTyCon tc then Just tc else -- return primitive tycons
+ -- otherwise (algebraic tycons) check the no. of constructors
+ Just tc
\end{code}
projects / ghc-hetmet.git / blobdiff