%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
+ ) where
-module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
+#include "HsVersions.h"
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
+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 CgUpdate ( reserveSeqFrame )
+import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
- bindNewPrimToAmode,
- rebindToAStack, rebindToBStack,
- getCAddrModeAndInfo, getCAddrModeIfVolatile,
- idInfoToAmode
- )
-import CgCon ( buildDynCon, bindConArgs )
-import CgHeapery ( heapCheck )
-import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
- ctrlReturnConvAlg,
- DataReturnConvention(..), CtrlReturnConvention(..),
- assignPrimOpResultRegs,
- makePrimOpArgsRobust
- )
-import CgStackery ( allocAStack, allocBStack )
-import CgTailCall ( tailCallBusiness, performReturn )
-import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
-import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel, mkClosureLabel
+ bindNewPrimToAmode, getCAddrModeAndInfo,
+ rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
+ buildContLivenessMask, nukeDeadBindings,
)
-import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts ( opt_SccProfilingOn )
-import CostCentre ( useCurrentCostCentre )
-import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
-import Id ( idPrimRep, toplevelishId,
- dataConTag, fIRST_TAG, ConTag(..),
- isDataCon, DataCon(..),
- idSetToList, GenId{-instance Uniquable,Eq-}
+import CgCon ( bindConArgs, bindUnboxedTupleComponents )
+import CgHeapery ( altHeapCheck )
+import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
+ CtrlReturnConvention(..)
)
-import Maybes ( catMaybes )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
-import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
- PrimRep(..)
+import CgStackery ( allocPrimStack, allocStackTop,
+ deAllocStackTop, freeStackSlots, dataStackSlots
)
-import TyCon ( isEnumerationTyCon )
-import Type ( typePrimRep,
- getDataSpecTyCon, getDataSpecTyCon_maybe,
- isEnumerationTyCon
+import CgTailCall ( tailCallFun )
+import CgUsages ( getSpRelOffset )
+import CLabel ( mkVecTblLabel, mkClosureTblLabel,
+ mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
)
-import Util ( sortLt, isIn, isn'tIn, zipEqual,
- pprError, panic, assertPanic
+import ClosureInfo ( mkLFArgument )
+import CmdLineOpts ( opt_SccProfilingOn )
+import Id ( Id, idPrimRep, isDeadBinder )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag )
+import VarSet ( varSetElems )
+import Literal ( Literal )
+import PrimOp ( primOpOutOfLine, PrimOp(..) )
+import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
-
-getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)"
-getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)"
+import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
+import Unique ( Unique, Uniquable(..), newTagUnique )
+import Maybes ( maybeToBool )
+import Util
+import Outputable
\end{code}
\begin{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
-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
-> StgLiveVars
- -> Unique
+ -> Id
+ -> SRT
-> StgCaseAlts
-> Code
\end{code}
-Several special cases for primitive operations.
-
-******* TO DO TO DO: fix what follows
-
-Special case for
-
- case (op x1 ... xn) of
- y -> e
-
-where the type of the case scrutinee is a multi-constuctor algebraic type.
-Then we simply compile code for
+Special case #1: PrimOps returning enumeration types.
- let y = op x1 ... xn
- in
- e
+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).
-In this case:
+There is an extra special case for
- case (op x1 ... xn) of
- C a b -> ...
- y -> e
+ case tagToEnum# x of
+ ...
-where the type of the case scrutinee is a multi-constuctor algebraic type.
-we just bomb out at the moment. It never happens in practice.
+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).
-**** END OF TO DO TO DO
+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.
\begin{code}
-cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
- (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
- = if not (null alts) then
- panic "cgCase: case on PrimOp with default *and* alts\n"
- -- For now, die if alts are non-empty
- else
-#if 0
- pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
- -- See above TO DO TO DO
-#endif
- cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
- where
- scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
- Updatable [] scrut
- scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
- -- Hack, hack
-\end{code}
+cgCase (StgPrimApp op args _)
+ live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
+ | isEnumerationTyCon tycon
+ = getArgAmodes args `thenFC` \ arg_amodes ->
+ let tag_amode = case op of
+ TagToEnumOp -> only arg_amodes
+ _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
-\begin{code}
-cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
- | not (primOpCanTriggerGC op)
- =
- -- Get amodes for the arguments and results
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
- let
- result_amodes = getPrimAppResultAmodes uniq alts
- liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
+ closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
in
- -- Perform the operation
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- absC (COpStmt result_amodes op
- arg_amodes -- note: no liveness arg
- liveness_mask 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
+ case op of {
+ TagToEnumOp -> nopC; -- no code!
- liveness_arg = mkIntCLit liveness_mask
- in
- -- Tidy up in case GC happens...
+ _ -> -- Perform the operation
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- -- 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 ->
-
- getEndOfBlockInfo `thenFC` \ eob_info ->
- forkEval eob_info 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?
+ absC (COpStmt [tag_amode] op
+ arg_amodes -- note: no liveness arg
+ vol_regs)
+ } `thenC`
+
+ -- bind the default binder if necessary
+ -- The deadness info is set by StgVarInfo
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToTemp bndr `thenFC` \ bndr_amode ->
+ absC (CAssign bndr_amode closure))
+ `thenC`
+
+ -- compile the alts
+ cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
+ False{-not poly case-} alts deflt
+ False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
- pin_liveness (CCallOp _ _ _ _ _) _ args = args
- pin_liveness other_op liveness_arg args
- = liveness_arg :args
+ -- Do the switch
+ absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
+\end{code}
- vtbl_label = mkVecTblLabel uniq
- return_label = mkReturnPtLabel uniq
+Special case #2: inline PrimOps.
+\begin{code}
+cgCase (StgPrimApp op args _)
+ live_in_whole_case live_in_alts bndr srt alts
+ | not (primOpOutOfLine op)
+ =
+ -- Get amodes for the arguments and results
+ getArgAmodes args `thenFC` \ arg_amodes ->
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
+
+ case alts of
+ StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
+ -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
+ op
+ arg_amodes -- note: no liveness arg
+ vol_regs) `thenC`
+ cgPrimInlineAlts bndr tycon alts deflt
+
+ StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
+ | isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
+ -> -- no heap check, no yield, just get in there and do it.
+ absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
+ op
+ arg_amodes -- note: no liveness arg
+ vol_regs) `thenC`
+ mapFCs bindNewToTemp args `thenFC` \ _ ->
+ cgExpr rhs
+
+ other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts 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
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 tycon 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.
+ -}
+ 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 _ _ _)
- =
- getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
+cgCase (StgApp fun args)
+ live_in_whole_case live_in_alts bndr srt alts
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
- -- Squish the environment
+ -- Squish the environment
nukeDeadBindings live_in_alts `thenC`
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 ->
+
+ setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ tailCallFun fun' fun_amode lf_info arg_amodes save_assts
\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 ->
-
- setEndOfBlockInfo scrut_eob_info (cgExpr expr)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-primops]{Primitive applications}
-%* *
-%************************************************************************
-
-Get result amodes for a primitive operation, in the case wher GC can't happen.
-The amodes are returned in canonical order, ready for the prim-op!
-
- Alg case: temporaries named as in the alternatives,
- plus (CTemp u) for the tag (if needed)
- Prim case: (CTemp u)
-
-This is all disgusting, because these amodes must be consistent with those
-invented by CgAlgAlts.
-
-\begin{code}
-getPrimAppResultAmodes
- :: 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 _ True {- used -} _))
- | isEnumerationTyCon spec_tycon = [tag_amode]
- | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
- 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, _, _) = getDataSpecTyCon ty
-
-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
-
- arg_amodes :: [CAddrMode]
-
- -- 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 ]
+ (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 ->
+
+ setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ cgExpr expr
\end{code}
-The situation is simpler for primitive
-results, because there is only one!
+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}
-getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq (typePrimRep ty)]
+-- We need to reserve a seq frame for a polymorphic case
+maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
+maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-alts]{Alternatives}
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 uniq (StgAlgAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+cgEvalAlts cc_slot bndr srt alts
+ =
+ let uniq = getUnique bndr in
+
+ buildContLivenessMask uniq `thenFC` \ liveness_mask ->
+
+ case alts of
+
+ -- algebraic alts ...
+ StgAlgAlts maybe_tycon alts deflt ->
+
+ -- bind the default binder (it covers all the alternatives)
+ bindNewToReg bndr node mkLFArgument `thenC`
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
--
-- which is worse than having the alt code in the switch statement
- let
- (spec_tycon, _, _) = getDataSpecTyCon 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
- `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
+ let is_alg = maybeToBool maybe_tycon
+ Just spec_tycon = maybe_tycon
+ in
- mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
+ -- deal with the unboxed tuple case
+ if is_alg && isUnboxedTupleTyCon spec_tycon then
+ case alts of
+ [alt] -> let lbl = mkReturnInfoLabel uniq in
+ cgUnboxedTupleAlt uniq cc_slot 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"
- returnFC (CaseAlts return_vec semi_tagged_stuff)
+ -- normal algebraic (or polymorphic) case alternatives
+ else let
+ ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
+ | otherwise = UnvectoredReturn 0
-cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+ use_labelled_alts = case ret_conv of
+ VectoredReturn _ -> True
+ _ -> False
- -- Generate the switch
- getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
+ semi_tagged_stuff
+ = if use_labelled_alts then
+ cgSemiTaggedAlts bndr alts deflt -- Just <something>
+ else
+ Nothing -- no semi-tagging info
- -- 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
-\end{code}
+ in
+ 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
+ ret_conv `thenFC` \ return_vec ->
-\begin{code}
-cgInlineAlts :: GCFlag -> Unique
- -> StgCaseAlts
- -> Code
-\end{code}
+ returnFC (CaseAlts return_vec semi_tagged_stuff)
-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.
+ -- primitive alts...
+ StgPrimAlts tycon alts deflt ->
-\begin{code}
-cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- = cgAlgAltRhs gc_flag con args use_mask rhs
-\end{code}
+ -- Restore the cost centre
+ restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-Second case: algebraic case, several alternatives.
-Tag is held in a temporary.
+ -- Generate the switch
+ getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-\begin{code}
-cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
- = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
- ty alts deflt `thenFC` \ (tagged_alts, deflt_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`
- -- 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
+ -- Return an amode for the block
+ returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
\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
-\end{code}
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
+we do an inlining of the case no separate functions for returning are
+created, so we don't have to generate a GRAN_YIELD in that case. This info
+must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
+emitted). Hence, the new Bool arg to cgAlgAltRhs.
%************************************************************************
%* *
In @cgAlgAlts@, none of the binders in the alternatives are
assumed to be yet bound.
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
+last arg of cgAlgAlts indicates if we want a context switch at the
+beginning of each alternative. Normally we want that. The only exception
+are inlined alternatives.
+
\begin{code}
cgAlgAlts :: GCFlag
-> Unique
- -> AbstractC -- Restore-cost-centre instruction
+ -> Maybe VirtualSpOffset
-> 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.
+cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
+ emit_yield{-should a yield macro be emitted?-}
-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-} _)
- = 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) alts)
- extra_branches
- (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
- where
-
- default_join_lbl = mkDefaultLabel uniq
- jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
-
- (spec_tycon, _, spec_cons) = getDataSpecTyCon 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
- closure_lbl = mkClosureLabel 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 -}
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
- [{- No "extra branches" -}]
- (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
+ = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
+ (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
\end{code}
\begin{code}
cgAlgDefault :: GCFlag
- -> Unique -> AbstractC -> Bool -- turgid state...
- -> StgCaseDefault -- input
- -> FCode AbstractC -- output
+ -> Bool -- could be a function-typed result?
+ -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
+ -> StgCaseDefault -- input
+ -> Bool
+ -> FCode AbstractC -- output
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault
+cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
= returnFC AbsCNop
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault _ False{-binder not used-} rhs)
-
- = getAbsC (absC restore_cc `thenC`
- 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 cc_slot 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
+ restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
getAbsC (absC restore_cc `thenC`
- possibleHeapCheck gc_flag [node] False (cgExpr rhs)
+ -- HWL: maybe need yield here
+ --(if emit_yield
+ -- then yield [node] True
+ -- else absC AbsCNop) `thenC`
+ 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
where
lbl = mkDefaultLabel uniq
+-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
cgAlgAlt :: GCFlag
- -> Unique -> AbstractC -> Bool -- turgid state
- -> (Id, [Id], [Bool], StgExpr)
+ -> 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 (con, args, use_mask, rhs)
- = getAbsC (absC restore_cc `thenC`
- cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
+cgAlgAlt gc_flag uniq cc_slot must_label_branch
+ emit_yield{-should a yield macro be emitted?-}
+ (con, args, use_mask, rhs)
+ =
+ restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
+ getAbsC (absC restore_cc `thenC`
+ -- HWL: maybe need yield here
+ -- (if 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 -> Code
-
-cgAlgAltRhs gc_flag con args use_mask rhs
- = let
- (live_regs, node_reqd)
- = case (dataReturnConvAlg con) of
- ReturnInHeap -> ([], True)
- ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` 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
- 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
+ :: Unique -- unique for label of the alternative
+ -> Maybe VirtualSpOffset -- Restore cost centre
+ -> Bool -- ctxt switch
+ -> (DataCon, [Id], [Bool], StgExpr) -- alternative
+ -> FCode AbstractC
+
+cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
+ = getAbsC (
+ bindUnboxedTupleComponents args
+ `thenFC` \ (live_regs,tags,stack_res) ->
+
+ restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
+ absC restore_cc `thenC`
+
+ -- HWL: maybe need yield here
+ -- (if 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)
-
- kind = typePrimRep ty
-
-
-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) ->
+cgPrimInlineAlts bndr tycon alts deflt
+ = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
+ where
+ uniq = getUnique bndr
+ kind = tyConPrimRep tycon
+
+cgPrimEvalAlts bndr tycon alts deflt
+ = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
+ where
+ reg = WARN( case kind of { PtrRep -> True; other -> False },
+ text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
+ dataReturnConvPrim kind
+ kind = tyConPrimRep tycon
+
+cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
+ = -- first bind the default if necessary
+ 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) ->
+
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))
-
-restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> 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
- -- assigning into CurCostCentre, in case RESTORE_CCC
+ 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 (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_CCCS
-- 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 spec_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
+ (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
- (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
- Just xx -> xx
- Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug 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 -> mkIntCLit 0 -- 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 GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
-possibleHeapCheck NoGC _ _ code = code
-\end{code}
-
-Select a restricted set of registers based on a usage mask.
+possibleHeapCheck
+ :: GCFlag
+ -> Bool -- True <=> algebraic case
+ -> [MagicId] -- live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> Maybe Unique -- return address unique
+ -> Code -- continuation
+ -> Code
-\begin{code}
-selectByMask [] [] = []
-selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
-selectByMask (False:ms) (x:xs) = selectByMask ms xs
+possibleHeapCheck GCMayHappen is_alg regs tags lbl code
+ = altHeapCheck is_alg regs tags AbsCNop lbl code
+possibleHeapCheck NoGC _ _ tags lbl code
+ = code
\end{code}