%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgCase.lhs,v 1.18 1998/12/02 13:17:46 simonm Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,
+ splitAlgTyConAppThroughNewTypes ) where
#include "HsVersions.h"
-import {-# SOURCE #-} CgExpr
+import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
import StgSyn
import AbsCSyn
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- magicIdPrimRep, getAmodeRep
+ getAmodeRep, nonemptyAbsC
)
-import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
+import CoreSyn ( isDeadBinder )
+import CgUpdate ( reserveSeqFrame )
+import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
bindNewPrimToAmode,
- rebindToAStack, rebindToBStack,
+ rebindToStack, getCAddrMode,
getCAddrModeAndInfo, getCAddrModeIfVolatile,
- idInfoToAmode
- )
-import CgCon ( buildDynCon, bindConArgs )
-import CgHeapery ( heapCheck, yield )
-import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
- ctrlReturnConvAlg,
- DataReturnConvention(..), CtrlReturnConvention(..),
- assignPrimOpResultRegs,
- makePrimOpArgsRobust
+ buildContLivenessMask, nukeDeadBindings
)
-import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
-import CgTailCall ( tailCallBusiness, performReturn )
-import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
-import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel
+import CgCon ( bindConArgs, bindUnboxedTupleComponents )
+import CgHeapery ( altHeapCheck, yield )
+import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
+ CtrlReturnConvention(..)
)
-import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre ( useCurrentCostCentre, CostCentre )
-import HeapOffs ( VirtualSpBOffset, VirtualHeapOffset )
-import Id ( idPrimRep, dataConTag, fIRST_TAG, ConTag,
- isDataCon, DataCon,
- idSetToList, GenId{-instance Uniquable,Eq-}, Id
+import CgStackery ( allocPrimStack, allocStackTop,
+ deAllocStackTop, freeStackSlots
)
-import Literal ( Literal )
-import Maybes ( catMaybes )
-import PrimOp ( primOpCanTriggerGC, PrimOp(..),
- primOpStackRequired, StackRequirement(..)
+import CgTailCall ( tailCallFun )
+import CgUsages ( getSpRelOffset, getRealSp )
+import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel,
+ mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
+ mkErrorStdEntryLabel, mkClosureTblLabel
)
-import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
- PrimRep(..)
- )
-import TyCon ( isEnumerationTyCon )
-import Type ( typePrimRep,
- splitAlgTyConApp, splitAlgTyConApp_maybe,
- Type
+import ClosureInfo ( mkLFArgument )
+import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
+import CostCentre ( CostCentre )
+import Id ( Id, idPrimRep )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
+ isUnboxedTupleCon, dataConType )
+import VarSet ( varSetElems )
+import Const ( Con(..), Literal )
+import PrimOp ( primOpOutOfLine, PrimOp(..) )
+import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
+import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
+ isNewTyCon, isAlgTyCon,
+ tyConDataCons, tyConFamilySize )
+import Type ( GenType(..), typePrimRep, splitAlgTyConApp, Type,
+ splitFunTys, applyTys )
import Unique ( Unique, Uniquable(..) )
-import Util ( sortLt, isIn, isn'tIn, zipEqual )
+import Maybes ( maybeToBool )
import Outputable
\end{code}
A more interesting situation is this:
-\begin{verbatim}
+ \begin{verbatim}
!A!;
...A...
case x# of
0# -> !B!; ...B...
default -> !C!; ...C...
-\end{verbatim}
+ \end{verbatim}
where \tr{!x!} indicates a possible heap-check point. The heap checks
in the alternatives {\em can} be omitted, in which case the topmost
In favour of omitting \tr{!B!}, \tr{!C!}:
-\begin{itemize}
-\item
-{\em May} save a heap overflow test,
+ - {\em May} save a heap overflow test,
if ...A... allocates anything. The other advantage
of this is that we can use relative addressing
from a single Hp to get at all the closures so allocated.
-\item
- No need to save volatile vars etc across the case
-\end{itemize}
+
+ - No need to save volatile vars etc across the case
Against:
-\begin{itemize}
-\item
- May do more allocation than reqd. This sometimes bites us
+ - May do more allocation than reqd. This sometimes bites us
badly. For example, nfib (ha!) allocates about 30\% more space if the
worst-casing is done, because many many calls to nfib are leaf calls
which don't need to allocate anything.
This never hurts us if there is only one alternative.
-\end{itemize}
*** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
cgCase :: StgExpr
-> StgLiveVars
-> StgLiveVars
- -> Unique
+ -> Id
+ -> SRT
-> StgCaseAlts
-> Code
\end{code}
-Several special cases for primitive operations.
-
+Several special cases for inline primitive operations.
\begin{code}
-cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
- | not (primOpCanTriggerGC op)
+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
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
let
- result_amodes = getPrimAppResultAmodes uniq alts
- liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
+ result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
in
-- Perform the operation
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- -- seq cannot happen here => no additional B Stack alloc
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
absC (COpStmt result_amodes op
arg_amodes -- note: no liveness arg
- liveness_mask vol_regs) `thenC`
+ vol_regs) `thenC`
-- Scrutinise the result
- cgInlineAlts NoGC uniq alts
-
- | otherwise -- *Can* trigger GC
- = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
-
- -- Get amodes for the arguments and results, and assign to regs
- -- (Can-trigger-gc primops guarantee to have their (nonRobust)
- -- args in regs)
- let
- op_result_regs = assignPrimOpResultRegs op
-
- op_result_amodes = map CReg op_result_regs
-
- (op_arg_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust op arg_amodes
-
- liveness_arg = mkIntCLit liveness_mask
- in
- -- Tidy up in case GC happens...
-
- -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
- -- Reason: the arg_assts computed above may refer to some stack slots
- -- which are not live in the alts. So we mustn't use those slots
- -- to save volatile vars in!
- nukeDeadBindings live_in_whole_case `thenC`
- saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
-
- -- Allocate stack words for the prim-op itself,
- -- these are guaranteed to be ON TOP OF the stack.
- -- Currently this is used *only* by the seq# primitive op.
- let
- (a_req,b_req) = case (primOpStackRequired op) of
- NoStackRequired -> (0, 0)
- FixedStackRequired a b -> (a, b)
- VariableStackRequired -> (0, 0) -- i.e. don't care
- in
- allocAStackTop a_req `thenFC` \ a_slot ->
- allocBStackTop b_req `thenFC` \ b_slot ->
-
- getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
- -- a_req and b_req allocate stack space that is taken care of by the
- -- macros generated for the primops; thus, we there is no need to adjust
- -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
- -- currently all this is only used for SeqOp
- forkEval (if True {- a_req==0 && b_req==0 -}
- then eob_info
- else (EndOfBlockInfo (args_spa+a_req)
- (args_spb+b_req) sequel)) nopC
- (
- getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
- absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
- `thenC`
- returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
- Nothing{-no semi-tagging-}))
- `thenFC` \ new_eob_info ->
-
- -- Record the continuation info
- setEndOfBlockInfo new_eob_info (
-
- -- Now "return" to the inline alternatives; this will get
- -- compiled to a fall-through.
- let
- simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
-
- -- do_op_and_continue will be passed an amode for the continuation
- do_op_and_continue sequel
- = absC (COpStmt op_result_amodes
- op
- (pin_liveness op liveness_arg op_arg_amodes)
- liveness_mask
- [{-no vol_regs-}])
- `thenC`
-
- sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
-
- -- Note: we CJump even for algebraic data types,
- -- because cgInlineAlts always generates code, never a
- -- vector.
- in
- performReturn simultaneous_assts do_op_and_continue live_in_alts
- )
- 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
-
- vtbl_label = mkVecTblLabel uniq
- return_label = mkReturnPtLabel uniq
-
+ cgInlineAlts bndr alts
\end{code}
Another special case: scrutinising a primitive-typed variable. No
eliminate a heap check altogether.
\begin{code}
-cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
- = getArgAmode v `thenFC` \ amode ->
- cgPrimAltsGivenScrutinee NoGC amode alts deflt
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+ (StgPrimAlts ty alts deflt)
+
+ =
+ getCAddrMode v `thenFC` \amode ->
+
+ {-
+ Careful! we can't just bind the default binder to the same thing
+ as the scrutinee, since it might be a stack location, and having
+ 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`
+
+ cgPrimAlts NoGC amode alts deflt []
\end{code}
Special case: scrutinising a non-primitive variable.
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
-cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
- live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
+cgCase (StgApp fun args)
+ live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- forkEval alts_eob_info
- nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
- setEndOfBlockInfo scrut_eob_info (
- tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
- )
+ allocStackTop retPrimRepSize `thenFC` \_ ->
+
+ forkEval alts_eob_info nopC (
+ deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alts)
+ `thenFC` \ scrut_eob_info ->
+
+ let real_scrut_eob_info =
+ if not_con_ty
+ then reserveSeqFrame scrut_eob_info
+ else scrut_eob_info
+ in
+
+ setEndOfBlockInfo real_scrut_eob_info (
+ tailCallFun fun fun_amode lf_info arg_amodes save_assts
+ )
+ where
+ not_con_ty = case (getScrutineeTyCon ty) of
+ Just _ -> False
+ other -> True
\end{code}
+Note about return addresses: we *always* push a return address, even
+if because of an optimisation we end up jumping direct to the return
+code (not through the address itself). The alternatives always assume
+that the return address is on the stack. The return address is
+required in case the alternative performs a heap check, since it
+encodes the liveness of the slots in the activation record.
+
+On entry to the case alternative, we can re-use the slot containing
+the return address immediately after the heap check. That's what the
+deAllocStackTop call is doing above.
+
Finally, here is the general case.
\begin{code}
-cgCase expr live_in_whole_case live_in_alts uniq alts
+cgCase expr live_in_whole_case live_in_alts bndr srt alts
= -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_case `thenC`
+
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- -- Save those variables right now!
+ -- Save those variables right now!
absC save_assts `thenC`
+ -- generate code for the alts
forkEval alts_eob_info
- (nukeDeadBindings live_in_alts)
- (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
+ (
+ nukeDeadBindings live_in_alts `thenC`
+ allocStackTop retPrimRepSize -- space for retn address
+ `thenFC` \_ -> nopC
+ )
+ (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
+
+ let real_scrut_eob_info =
+ if not_con_ty
+ then reserveSeqFrame scrut_eob_info
+ else scrut_eob_info
+ in
+
+ setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
- setEndOfBlockInfo scrut_eob_info (cgExpr expr)
+ where
+ not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
+ Just _ -> False
+ other -> True
+\end{code}
+
+There's a lot of machinery going on behind the scenes to manage the
+stack pointer here. forkEval takes the virtual Sp and free list from
+the first argument, and turns that into the *real* Sp for the second
+argument. It also uses this virtual Sp as the args-Sp in the EOB info
+returned, so that the scrutinee will trim the real Sp back to the
+right place before doing whatever it does.
+ --SDM (who just spent an hour figuring this out, and didn't want to
+ forget it).
+
+Why don't we push the return address just before evaluating the
+scrutinee? Because the slot reserved for the return address might
+contain something useful, so we wait until performing a tail call or
+return before pushing the return address (see
+CgTailCall.pushReturnAddress).
+
+This also means that the environment doesn't need to know about the
+free stack slot for the return address (for generating bitmaps),
+because we don't reserve it until just before the eval.
+
+TODO!! Problem: however, we have to save the current cost centre
+stack somewhere, because at the eval point the current CCS might be
+different. So we pick a free stack slot and save CCCS in it. The
+problem with this is that this slot isn't recorded as free/unboxed in
+the environment, so a case expression in the scrutinee will have the
+wrong bitmap attached. Fortunately we don't ever seem to see
+case-of-case at the back end. One solution might be to shift the
+saved CCS to the correct place in the activation record just before
+the jump.
+ --SDM
+
+(one consequence of the above is that activation records on the stack
+don't follow the layout of closures when we're profiling. The CCS
+could be anywhere within the record).
+
+\begin{code}
+alts_ty (StgAlgAlts ty _ _) = ty
+alts_ty (StgPrimAlts ty _ _) = ty
\end{code}
%************************************************************************
-- Anyway, cgInlineAlts is now capable of handling all cases;
-- it's only this function which is being wimpish.
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
+getPrimAppResultAmodes uniq (StgAlgAlts ty alts
+ (StgBindDefault rhs))
| isEnumerationTyCon spec_tycon = [tag_amode]
- | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
+ | 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
- = case alts of
- [_] -> arg_amodes -- No need for a tag
- other -> tag_amode : arg_amodes
- 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
- -- Sort alternatives into canonical order; there must be a complete
- -- set because there's no default case.
- sorted_alts = sortLt lt alts
- (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
+ | isEnumerationTyCon tycon = [CTemp uniq IntRep]
- arg_amodes :: [CAddrMode]
+ | isUnboxedTupleTyCon tycon =
+ case alts of
+ [(con, args, use_mask, rhs)] ->
+ [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
+ _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
- -- Turn them into amodes
- arg_amodes = concat (map mk_amodes sorted_alts)
- mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
+ | 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 _ _)
is some evaluation to be done.
\begin{code}
-cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
- -> Unique
+cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
+ -> Id
+ -> SRT -- SRT for the continuation
-> StgCaseAlts
- -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
- -- so that we can duplicate it without risk of
- -- duplicating code
+ -> FCode Sequel -- Any addr modes inside are guaranteed
+ -- to be a label so that we can duplicate it
+ -- without risk of duplicating code
+
+cgEvalAlts cc_slot bndr srt alts
+ =
+ let uniq = getUnique bndr in
-cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
+ -- 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
+
+ -- algebraic alts ...
+ (StgAlgAlts ty alts deflt) ->
+
+ -- bind the default binder (it covers all the alternatives)
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToReg bndr node mkLFArgument) `thenC`
+
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
-- Reason: if not, then it costs extra to label the
--
-- which is worse than having the alt code in the switch statement
- let
- (spec_tycon, _, _) = splitAlgTyConApp ty
-
- use_labelled_alts
- = case ctrlReturnConvAlg spec_tycon of
- VectoredReturn _ -> True
- _ -> False
-
- semi_tagged_stuff
- = if not use_labelled_alts then
- Nothing -- no semi-tagging info
- else
- cgSemiTaggedAlts uniq alts deflt -- Just <something>
- in
- cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
- `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
-
- mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
-
- returnFC (CaseAlts return_vec semi_tagged_stuff)
-
-cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-
- -- Generate the switch
- getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
+ let tycon_info = getScrutineeTyCon ty
+ is_alg = maybeToBool tycon_info
+ Just spec_tycon = tycon_info
+ in
+
+ -- deal with the unboxed tuple case
+ if is_alg && isUnboxedTupleTyCon spec_tycon then
+ case alts of
+ [alt] -> let lbl = mkReturnInfoLabel uniq in
+ cgUnboxedTupleAlt lbl cc_restore True alt
+ `thenFC` \ abs_c ->
+ getSRTLabel `thenFC` \srt_label ->
+ absC (CRetDirect uniq abs_c (srt_label, srt)
+ liveness_mask) `thenC`
+ returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
+ _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
+
+ -- normal algebraic (or polymorphic) case alternatives
+ else let
+ ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
+ | otherwise = UnvectoredReturn 0
+
+ use_labelled_alts = case ret_conv of
+ VectoredReturn _ -> True
+ _ -> False
+
+ semi_tagged_stuff
+ = if use_labelled_alts then
+ cgSemiTaggedAlts bndr alts deflt -- Just <something>
+ else
+ Nothing -- no semi-tagging info
+
+ in
+ cgAlgAlts GCMayHappen uniq cc_restore 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
+ ret_conv `thenFC` \ return_vec ->
+
+ returnFC (CaseAlts return_vec semi_tagged_stuff)
+
+ -- primitive alts...
+ (StgPrimAlts ty alts deflt) ->
+
+ -- Generate the switch
+ getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
+
+ -- Generate the labelled block, starting with restore-cost-centre
+ getSRTLabel `thenFC` \srt_label ->
+ absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
+ (srt_label,srt) liveness_mask) `thenC`
- -- Generate the labelled block, starting with restore-cost-centre
- absC (CRetUnVector vtbl_label
- (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
- `thenC`
-- Return an amode for the block
- returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
- where
- vtbl_label = mkVecTblLabel uniq
- return_label = mkReturnPtLabel uniq
+ returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)
\end{code}
\begin{code}
-cgInlineAlts :: GCFlag -> Unique
+cgInlineAlts :: Id
-> StgCaseAlts
-> Code
\end{code}
must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
emitted). Hence, the new Bool arg to cgAlgAltRhs.
-First case: algebraic case, exactly one alternative, no default.
-In this case the primitive op will not have set a temporary to the
-tag, so we shouldn't generate a switch statment. Instead we just
-do the right thing.
+First case: primitive op returns an unboxed tuple.
+
+\begin{code}
+cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
+ | isUnboxedTupleCon con
+ = -- no heap check, no yield, just get in there and do it.
+ mapFCs bindNewToTemp args `thenFC` \ _ ->
+ cgExpr rhs
+
+ | otherwise
+ = panic "cgInlineAlts: single alternative, not an unboxed tuple"
+\end{code}
+
+Hack: to deal with
+
+ case <# x y of z {
+ DEFAULT -> ...
+ }
\begin{code}
-cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
+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 gc_flag uniq (StgAlgAlts ty alts deflt)
- = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
- ty alts deflt
- False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
+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)
-- 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}
-cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
- = cgPrimAlts gc_flag uniq ty alts deflt
+cgInlineAlts bndr (StgPrimAlts ty alts deflt)
+ = cgPrimInlineAlts bndr ty alts deflt
\end{code}
-> Unique
-> AbstractC -- Restore-cost-centre instruction
-> Bool -- True <=> branches must be labelled
- -> Type -- From the case statement
- -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
- -> StgCaseDefault -- The default
+ -> Bool -- True <=> polymorphic case
+ -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
+ -> StgCaseDefault -- The default
-> Bool -- Context switch at alts?
-> FCode ([(ConTag, AbstractC)], -- The branches
AbstractC -- The default case
)
-\end{code}
-The case with a default which has a binder is different. We need to
-pick all the constructors which aren't handled explicitly by an
-alternative, and which return their results in registers, allocate
-them explicitly in the heap, and jump to a join point for the default
-case.
-
-OLD: All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate.
-
-NEW (July 94): now false! It should work regardless of gc_flag,
-because of the extra_branches argument now added to forkAlts.
-
-We put a heap-check at the join point, for the benefit of constructors
-which don't need to do allocation. This means that ones which do need
-to allocate may end up doing two heap-checks; but that's just too bad.
-(We'd need two join labels otherwise. ToDo.)
-
-It's all pretty turgid anyway.
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc semi_tagging
- ty alts deflt@(StgBindDefault binder True{-used-} _)
- emit_yield{-should a yield macro be emitted?-}
- = let
- extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map mk_extra_branch default_cons)
-
- must_label_default = semi_tagging || not (null extra_branches)
- in
- forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
- extra_branches
- (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
- where
-
- default_join_lbl = mkDefaultLabel uniq
- jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
-
- (spec_tycon, _, spec_cons) = splitAlgTyConApp ty
-
- alt_cons = [ con | (con,_,_,_) <- alts ]
-
- default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
- spec_con `not_elem` alt_cons ] -- Not handled explicitly
- where
- not_elem = isn'tIn "cgAlgAlts"
-
- -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
- -- The "maybe" is because con may return in heap, in which case there is
- -- nothing to do. Otherwise, we have a special case for a nullary constructor,
- -- but in the general case we do an allocation and heap-check.
-
- mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
-
- mk_extra_branch con
- = ASSERT(isDataCon con)
- case dataReturnConvAlg con of
- ReturnInHeap -> Nothing
- ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
- returnFC (tag, abs_c)
- )
- where
- lf_info = mkConLFInfo con
- tag = dataConTag con
-
- -- alloc_code generates code to allocate constructor con, whose args are
- -- in the arguments to alloc_code, assigning the result to Node.
- alloc_code :: [MagicId] -> Code
-
- alloc_code regs
- = possibleHeapCheck gc_flag regs False (
- buildDynCon binder useCurrentCostCentre con
- (map CReg regs) (all zero_size regs)
- `thenFC` \ idinfo ->
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
-
- absC (CAssign (CReg node) amode) `thenC`
- absC jump_instruction
- )
- where
- zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
-\end{code}
-
-Now comes the general case
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
- {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
+cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
emit_yield{-should a yield macro be emitted?-}
= forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
- [{- No "extra branches" -}]
- (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
+ (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
\end{code}
\begin{code}
cgAlgDefault :: GCFlag
+ -> Bool -- could be a function-typed result?
-> Unique -> AbstractC -> Bool -- turgid state...
- -> StgCaseDefault -- input
+ -> StgCaseDefault -- input
-> Bool
- -> FCode AbstractC -- output
+ -> FCode AbstractC -- output
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault _
+cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _
= returnFC AbsCNop
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault _ False{-binder not used-} rhs)
- emit_yield{-should a yield macro be emitted?-}
-
- = getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield [] False
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
- let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
-
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault binder True{-binder used-} rhs)
+cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch
+ (StgBindDefault rhs)
emit_yield{-should a yield macro be emitted?-}
- = -- We have arranged that Node points to the thing, even
- -- even if we return in registers
- bindNewToReg binder node mkLFArgument `thenC`
+ = -- We have arranged that Node points to the thing
getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
+ (if opt_GranMacros && emit_yield
then yield [node] False
else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [node] False (cgExpr rhs)
+ possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
-- Node is live, but doesn't need to point at the thing itself;
-- it's ok for Node to point to an indirection or FETCH_ME
-- Hence no need to re-enter Node.
) `thenFC` \ abs_c ->
let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
+ final_abs_c | must_label_branch = CCodeBlock lbl abs_c
| otherwise = abs_c
in
returnFC final_abs_c
cgAlgAlt :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state
-> Bool -- Context switch at alts?
- -> (Id, [Id], [Bool], StgExpr)
+ -> (DataCon, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
cgAlgAlt gc_flag uniq restore_cc must_label_branch
emit_yield{-should a yield macro be emitted?-}
(con, args, use_mask, rhs)
= getAbsC (absC restore_cc `thenC`
- cgAlgAltRhs gc_flag con args use_mask rhs
- emit_yield
+ (if opt_GranMacros && emit_yield
+ then yield [node] True -- XXX live regs wrong
+ else absC AbsCNop) `thenC`
+ (case gc_flag of
+ NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
+ GCMayHappen -> bindConArgs con args
+ ) `thenC`
+ possibleHeapCheck gc_flag False [node] [] Nothing (
+ cgExpr rhs)
) `thenFC` \ abs_c ->
let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
+ final_abs_c | must_label_branch = CCodeBlock lbl abs_c
| otherwise = abs_c
in
returnFC (tag, final_abs_c)
tag = dataConTag con
lbl = mkAltLabel uniq tag
-cgAlgAltRhs :: GCFlag
- -> Id
- -> [Id]
- -> [Bool]
- -> StgExpr
- -> Bool -- context switch?
- -> Code
-cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
- = let
- (live_regs, node_reqd)
- = case (dataReturnConvAlg con) of
- ReturnInHeap -> ([], True)
- ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
- -- Pick the live registers using the use_mask
- -- Doing so is IMPORTANT, because with semi-tagging
- -- enabled only the live registers will have valid
- -- pointers in them.
- in
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield live_regs node_reqd
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag live_regs node_reqd (
- (case gc_flag of
- NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
- nopC
- GCMayHappen -> bindConArgs con args
- ) `thenC`
- cgExpr rhs
+cgUnboxedTupleAlt
+ :: CLabel -- label of the alternative
+ -> AbstractC -- junk
+ -> Bool -- ctxt switch
+ -> (DataCon, [Id], [Bool], StgExpr) -- alternative
+ -> FCode AbstractC
+
+cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs)
+ = getAbsC (
+ absC restore_cc `thenC`
+
+ bindUnboxedTupleComponents args
+ `thenFC` \ (live_regs,tags,stack_res) ->
+ (if opt_GranMacros && emit_yield
+ then yield live_regs True -- XXX live regs wrong?
+ else absC AbsCNop) `thenC`
+ let
+ -- ToDo: could maybe use Nothing here if stack_res is False
+ -- since the heap-check can just return to the top of the
+ -- stack.
+ ret_addr = Just lbl
+ in
+
+ -- free up stack slots containing tags,
+ freeStackSlots (map fst tags) `thenC`
+
+ -- generate a heap check if necessary
+ possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
+
+ -- and finally the code for the alternative
+ cgExpr rhs)
)
\end{code}
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: Unique
- -> [(Id, [Id], [Bool], StgExpr)]
+cgSemiTaggedAlts :: Id
+ -> [(DataCon, [Id], [Bool], StgExpr)]
-> GenStgCaseDefault Id Id
-> SemiTaggingStuff
-cgSemiTaggedAlts uniq alts deflt
+cgSemiTaggedAlts binder alts deflt
= Just (map st_alt alts, st_deflt deflt)
where
+ uniq = getUnique binder
+
st_deflt StgNoDefault = Nothing
- st_deflt (StgBindDefault binder binder_used _)
- = Just (if binder_used then Just binder else Nothing,
+ st_deflt (StgBindDefault _)
+ = Just (Just binder,
(CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
mkDefaultLabel uniq)
)
st_alt (con, args, use_mask, _)
- = case (dataReturnConvAlg con) of
-
- ReturnInHeap ->
- -- Ha! Nothing to do; Node already points to the thing
- (con_tag,
- (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
- [mkIntCLit (length args)], -- how big the thing in the heap is
+ = -- Ha! Nothing to do; Node already points to the thing
+ (con_tag,
+ (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+ [mkIntCLit (length args)], -- how big the thing in the heap is
join_label)
)
-
- ReturnInRegs regs ->
- -- We have to load the live registers from the constructor
- -- pointed to by Node.
- let
- (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
-
- used_regs = selectByMask use_mask regs
-
- used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
- reg `is_elem` used_regs]
-
- is_elem = isIn "cgSemiTaggedAlts"
- in
- (con_tag,
- (mkAbstractCs [
- CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
- [mkIntCLit (length regs_w_offsets),
- mkIntCLit (length used_regs_w_offsets)],
- CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
- join_label))
where
con_tag = dataConTag con
join_label = mkAltLabel uniq con_tag
-
- move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
- move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
%* *
%************************************************************************
-@cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
-alternatives of a primitive @case@, given an addressing mode for the
-thing to scrutinise. It also keeps track of the maximum stack depth
-encountered down any branch.
+@cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
+for dealing with the alternatives of a primitive @case@, given an
+addressing mode for the thing to scrutinise. It also keeps track of
+the maximum stack depth encountered down any branch.
As usual, no binders in the alternatives are yet bound.
\begin{code}
-cgPrimAlts :: GCFlag
- -> Unique
- -> Type
- -> [(Literal, StgExpr)] -- Alternatives
- -> StgCaseDefault -- Default
- -> Code
-
-cgPrimAlts gc_flag uniq ty alts deflt
- = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
- where
- -- A temporary variable, or standard register, to hold the result
- scrutinee = case gc_flag of
- NoGC -> CTemp uniq kind
- GCMayHappen -> CReg (dataReturnConvPrim kind)
+cgPrimInlineAlts bndr ty alts deflt
+ = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
+ where
+ uniq = getUnique bndr
+ kind = typePrimRep ty
- kind = typePrimRep ty
+cgPrimEvalAlts bndr ty alts deflt
+ = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
+ where
+ reg = 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`
+ cgPrimAlts gc_flag scrutinee alts deflt regs
+
+cgPrimAlts gc_flag scrutinee alts deflt regs
+ = forkAlts (map (cgPrimAlt gc_flag regs) alts)
+ (cgPrimDefault gc_flag regs deflt)
+ `thenFC` \ (alt_absCs, deflt_absC) ->
-cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
- = forkAlts (map (cgPrimAlt gc_flag) alts)
- [{- No "extra branches" -}]
- (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
absC (CSwitch scrutinee alt_absCs deflt_absC)
- -- CSwitch does sensible things with one or zero alternatives
+ -- CSwitch does sensible things with one or zero alternatives
cgPrimAlt :: GCFlag
- -> (Literal, StgExpr) -- The alternative
+ -> [MagicId] -- live registers
+ -> (Literal, StgExpr) -- The alternative
-> FCode (Literal, AbstractC) -- Its compiled form
-cgPrimAlt gc_flag (lit, rhs)
+cgPrimAlt gc_flag regs (lit, rhs)
= getAbsC rhs_code `thenFC` \ absC ->
returnFC (lit,absC)
where
- rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
+ rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
cgPrimDefault :: GCFlag
- -> CAddrMode -- Scrutinee
+ -> [MagicId] -- live registers
-> StgCaseDefault
-> FCode AbstractC
-cgPrimDefault gc_flag scrutinee StgNoDefault
+cgPrimDefault gc_flag regs StgNoDefault
= panic "cgPrimDefault: No default in prim case"
-cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
- = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
-
-cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
- = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
- where
- regs = if isFollowableRep (getAmodeRep scrutinee) then
- [node] else []
-
- rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
- cgExpr rhs
+cgPrimDefault gc_flag regs (StgBindDefault rhs)
+ = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
\end{code}
\begin{code}
saveVolatileVarsAndRegs
- :: StgLiveVars -- Vars which should be made safe
+ :: StgLiveVars -- Vars which should be made safe
-> FCode (AbstractC, -- Assignments to do the saves
- EndOfBlockInfo, -- New sequel, recording where the return
- -- address now is
- Maybe VirtualSpBOffset) -- Slot for current cost centre
+ EndOfBlockInfo, -- sequel for the alts
+ Maybe VirtualSpOffset) -- Slot for current cost centre
saveVolatileVarsAndRegs vars
- = saveVolatileVars vars `thenFC` \ var_saves ->
- saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
- saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
- returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
- new_eob_info,
+ = saveVolatileVars vars `thenFC` \ var_saves ->
+ saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
+ getEndOfBlockInfo `thenFC` \ eob_info ->
+ returnFC (mkAbstractCs [var_saves, cc_save],
+ eob_info,
maybe_cc_slot)
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
- = save_em (idSetToList vars)
+ = save_em (varSetElems vars)
where
save_em [] = returnFC AbsCNop
returnFC (abs_c `mkAbsCStmts` abs_cs)
save_var var vol_amode
- | isFollowableRep kind
- = allocAStack `thenFC` \ a_slot ->
- rebindToAStack var a_slot `thenC`
- getSpARelOffset a_slot `thenFC` \ spa_rel ->
- returnFC (CAssign (CVal spa_rel kind) vol_amode)
- | otherwise
- = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
- rebindToBStack var b_slot `thenC`
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (CAssign (CVal spb_rel kind) vol_amode)
+ = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
+ rebindToStack var slot `thenC`
+ getSpRelOffset slot `thenFC` \ sp_rel ->
+ returnFC (CAssign (CVal sp_rel kind) vol_amode)
where
kind = getAmodeRep vol_amode
-
-saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
-saveReturnAddress
- = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
-
- -- See if it is volatile
- case sequel of
- InRetReg -> -- Yes, it's volatile
- allocBStack retPrimRepSize `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
-
- returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
- CAssign (CVal spb_rel RetRep) (CReg RetReg))
-
- UpdateCode _ -> -- It's non-volatile all right, but we still need
- -- to allocate a B-stack slot for it, *solely* to make
- -- sure that update frames for different values do not
- -- appear adjacent on the B stack. This makes sure
- -- that B-stack squeezing works ok.
- -- See note below
- allocBStack retPrimRepSize `thenFC` \ b_slot ->
- returnFC (eob_info, AbsCNop)
-
- other -> -- No, it's non-volatile, so do nothing
- returnFC (eob_info, AbsCNop)
\end{code}
-Note about B-stack squeezing. Consider the following:`
-
- y = [...] \u [] -> ...
- x = [y] \u [] -> case y of (a,b) -> a
-
-The code for x will push an update frame, and then enter y. The code
-for y will push another update frame. If the B-stack-squeezer then
-wakes up, it will see two update frames right on top of each other,
-and will combine them. This is WRONG, of course, because x's value is
-not the same as y's.
-
-The fix implemented above makes sure that we allocate an (unused)
-B-stack slot before entering y. You can think of this as holding the
-saved value of RetAddr, which (after pushing x's update frame will be
-some update code ptr). The compiler is clever enough to load the
-static update code ptr into RetAddr before entering ~a~, but the slot
-is still there to separate the update frames.
+---------------------------------------------------------------------------
When we save the current cost centre (which is done for lexical
-scoping), we allocate a free B-stack location, and return (a)~the
+scoping), we allocate a free stack location, and return (a)~the
virtual offset of the location, to pass on to the alternatives, and
(b)~the assignment to do the save (just as for @saveVolatileVars@).
\begin{code}
saveCurrentCostCentre ::
- FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
- -- Nothing if not lexical CCs
+ FCode (Maybe VirtualSpOffset, -- Where we decide to store it
AbstractC) -- Assignment to save it
- -- AbsCNop if not lexical CCs
saveCurrentCostCentre
- = let
- doing_profiling = opt_SccProfilingOn
- in
- if not doing_profiling then
+ = if not opt_SccProfilingOn then
returnFC (Nothing, AbsCNop)
else
- allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (Just b_slot,
- CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
+ allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+ getSpRelOffset slot `thenFC` \ sp_rel ->
+ returnFC (Just slot,
+ CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
restoreCurrentCostCentre Nothing
= returnFC AbsCNop
-restoreCurrentCostCentre (Just b_slot)
- = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- freeBStkSlot b_slot `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
- -- we use the RESTORE_CCC macro, rather than just
+restoreCurrentCostCentre (Just slot)
+ = getSpRelOffset slot `thenFC` \ sp_rel ->
+ freeStackSlots [slot] `thenC`
+ returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+ -- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCC
-- has some sanity-checking in it.
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-return-vec]{Building a return vector}
\begin{code}
mkReturnVector :: Unique
- -> Type
-> [(ConTag, AbstractC)] -- Branch codes
-> AbstractC -- Default case
+ -> SRT -- continuation's SRT
+ -> Liveness -- stack liveness
+ -> CtrlReturnConvention
-> FCode CAddrMode
-mkReturnVector uniq ty tagged_alt_absCs deflt_absC
- = let
- (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg tycon) of {
-
- UnvectoredReturn _ ->
- (CUnVecLbl ret_label vtbl_label,
- absC (CRetUnVector vtbl_label
- (CLabelledCode ret_label
- (mkAlgAltsCSwitch (CReg TagReg)
- tagged_alt_absCs
- deflt_absC))));
+mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
+ = getSRTLabel `thenFC` \srt_label ->
+ let
+ srt_info = (srt_label, srt)
+
+ (return_vec_amode, vtbl_body) = case ret_conv of {
+
+ -- might be a polymorphic case...
+ UnvectoredReturn 0 ->
+ ASSERT(null tagged_alt_absCs)
+ (CLbl ret_label RetRep,
+ absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
+
+ UnvectoredReturn n ->
+ -- find the tag explicitly rather than using tag_reg for now.
+ -- on architectures with lots of regs the tag will be loaded
+ -- into tag_reg by the code doing the returning.
+ let
+ tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
+ in
+ (CLbl ret_label RetRep,
+ absC (CRetDirect uniq
+ (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
+ (srt_label, srt)
+ liveness));
+
VectoredReturn table_size ->
- (CLbl vtbl_label DataPtrRep,
- absC (CRetVector vtbl_label
- -- must restore cc before each alt, if required
- (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
- deflt_absC))
-
--- Leave nops and comments in for now; they are eliminated
--- lazily as it's printed.
--- (case (nonemptyAbsC deflt_absC) of
--- Nothing -> AbsCNop
--- Just def -> def)
+ let
+ (vector_table, alts_absC) =
+ unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
+
+ ret_vector = CRetVector vtbl_label
+ vector_table
+ (srt_label, srt) liveness
+ in
+ (CLbl vtbl_label DataPtrRep,
+ -- alts come first, because we don't want to declare all the symbols
+ absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
+ )
} in
vtbl_body `thenC`
-- )
where
- (tycon,_,_) = case splitAlgTyConApp_maybe ty of -- *must* be a real "data" type constructor
- Just xx -> xx
- Nothing -> pprPanic "ERROR: can't generate code for polymorphic case"
- (vcat [text "probably a mis-use of `seq' or `par';",
- text "the User's Guide has more details.",
- text "Offending type:" <+> ppr ty
- ])
-
vtbl_label = mkVecTblLabel uniq
- ret_label = mkReturnPtLabel uniq
+ ret_label = mkReturnInfoLabel uniq
+
+ deflt_lbl =
+ case nonemptyAbsC deflt_absC of
+ -- the simplifier might have eliminated a case
+ Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
+ Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
- mk_vector_entry :: ConTag -> Maybe CAddrMode
+ mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
mk_vector_entry tag
= case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> Nothing
- [absC] -> Just (CCode absC)
+ [] -> (deflt_lbl, AbsCNop)
+ [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
_ -> panic "mkReturnVector: too many"
\end{code}
%* *
%************************************************************************
-@possibleHeapCheck@ tests a flag passed in to decide whether to
-do a heap check or not.
+@possibleHeapCheck@ tests a flag passed in to decide whether to do a
+heap check or not. These heap checks are always in a case
+alternative, so we use altHeapCheck.
\begin{code}
-possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
+possibleHeapCheck
+ :: GCFlag
+ -> Bool -- True <=> algebraic case
+ -> [MagicId] -- live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> Maybe CLabel -- return address
+ -> Code -- continuation
+ -> Code
-possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
-possibleHeapCheck NoGC _ _ code = code
+possibleHeapCheck GCMayHappen is_alg regs tags lbl code
+ = altHeapCheck is_alg regs tags AbsCNop lbl code
+possibleHeapCheck NoGC _ _ tags lbl code
+ = code
\end{code}
-Select a restricted set of registers based on a usage mask.
+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}
-selectByMask [] [] = []
-selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
-selectByMask (False:ms) (x:xs) = selectByMask ms xs
+getScrutineeTyCon :: Type -> Maybe TyCon
+getScrutineeTyCon ty =
+ case (splitAlgTyConAppThroughNewTypes 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
\end{code}
projects / ghc-hetmet.git / blobdiff