%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgCase.lhs,v 1.66 2003/07/22 16:11:26 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
+module CgCase ( cgCase, saveVolatileVarsAndRegs,
+ mkRetDirectTarget, restoreCurrentCostCentre
+ ) where
-module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
+#include "HsVersions.h"
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes )
+import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
import StgSyn
import AbsCSyn
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- magicIdPrimRep, getAmodeRep
- )
-import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
+import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
- bindNewPrimToAmode,
- rebindToAStack, rebindToBStack,
- getCAddrModeAndInfo, getCAddrModeIfVolatile,
- idInfoToAmode
- )
-import CgCon ( buildDynCon, bindConArgs )
-import CgHeapery ( heapCheck, yield )
-import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
- ctrlReturnConvAlg,
- DataReturnConvention(..), CtrlReturnConvention(..),
- assignPrimOpResultRegs,
- makePrimOpArgsRobust
- )
-import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
-import CgTailCall ( tailCallBusiness, performReturn )
-import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
-import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel
+ getCAddrModeAndInfo,
+ rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
+ buildContLivenessMask, nukeDeadBindings,
)
-import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
-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, unbxTupleHeapCheck )
+import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
+ CtrlReturnConvention(..)
)
-import Maybes ( catMaybes )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import PrimOp ( primOpCanTriggerGC, PrimOp(..),
- primOpStackRequired, StackRequirement(..)
+import CgStackery ( allocPrimStack, allocStackTop,
+ deAllocStackTop, freeStackSlots, dataStackSlots
)
-import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
- PrimRep(..)
+import CgTailCall ( performTailCall )
+import CgUsages ( getSpRelOffset )
+import CLabel ( mkVecTblLabel, mkClosureTblLabel,
+ mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
)
-import TyCon ( isEnumerationTyCon )
-import Type ( typePrimRep,
- getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
- isEnumerationTyCon
- )
-import Util ( sortLt, isIn, isn'tIn, zipEqual,
- pprError, panic, assertPanic
+import ClosureInfo ( mkLFArgument )
+import CmdLineOpts ( opt_SccProfilingOn )
+import Id ( Id, idName, isDeadBinder )
+import DataCon ( dataConTag, fIRST_TAG, ConTag )
+import VarSet ( varSetElems )
+import CoreSyn ( AltCon(..) )
+import PrimOp ( primOpOutOfLine, PrimOp(..) )
+import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
+import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
+import Unique ( Unique, Uniquable(..), newTagUnique )
+import Util ( only )
+import List ( sortBy )
+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
- -> StgCaseAlts
+ -> Id
+ -> SRT
+ -> AltType
+ -> [StgAlt]
-> 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
-
- let y = op x1 ... xn
- in
- e
-
-In this case:
-
- case (op x1 ... xn) of
- C a b -> ...
- y -> e
-
-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.
-
-**** END OF TO DO TO DO
-
-\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
- 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}
-
+Special case #1: case of literal.
\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"
- in
- -- Perform the operation
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- -- seq cannot happen here => no additional B Stack alloc
-
- 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
-
- 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
-
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
+ alt_type@(PrimAlt tycon) alts
+ = bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode (CLit lit)) `thenC`
+ cgPrimAlts NoGC tmp_amode alts alt_type
\end{code}
-Another special case: scrutinising a primitive-typed variable. No
+Special case #2: 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
alternatives is worst-cased and passed upstream. This can result in
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
+ alt_type@(PrimAlt tycon) alts
+
+ = -- 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.
+ getCAddrMode v `thenFC` \ amode ->
+ bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode amode) `thenC`
+ cgPrimAlts NoGC tmp_amode alts alt_type
+\end{code}
+
+Special case #3: inline PrimOps.
+
+\begin{code}
+cgCase (StgOpApp op@(StgPrimOp primop) args _)
+ live_in_whole_case live_in_alts bndr srt alt_type alts
+ | not (primOpOutOfLine primop)
+ = -- Get amodes for the arguments and results
+ getArgAmodes args `thenFC` \ arg_amodes ->
+ getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
+
+ case alt_type of
+ PrimAlt tycon -- PRIMITIVE ALTS
+ -> bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (COpStmt [tmp_amode] op arg_amodes vol_regs) `thenC`
+ -- Note: no liveness arg
+ cgPrimAlts NoGC tmp_amode alts alt_type
+
+ UbxTupAlt tycon -- UNBOXED TUPLE ALTS
+ -> -- No heap check, no yield, just get in there and do it.
+ -- NB: the case binder isn't bound to anything;
+ -- it has a unboxed tuple type
+ mapFCs bindNewToTemp res_ids `thenFC` \ res_tmps ->
+ absC (COpStmt res_tmps op arg_amodes vol_regs) `thenC`
+ cgExpr rhs
+ where
+ [(_, res_ids, _, rhs)] = alts
+
+ AlgAlt tycon -- ENUMERATION TYPE RETURN
+ -> ASSERT( isEnumerationTyCon tycon )
+ do_enum_primop primop `thenFC` \ tag_amode ->
+
+ -- Bind the default binder if necessary
+ -- (avoiding it avoids the assignment)
+ -- The deadness info is set by StgVarInfo
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode (tagToClosure tycon tag_amode))
+ ) `thenC`
+
+ -- Compile the alts
+ cgAlgAlts NoGC (getUnique bndr)
+ Nothing{-cc_slot-} False{-no semi-tagging-}
+ (AlgAlt tycon) alts `thenFC` \ tagged_alts ->
+
+ -- Do the switch
+ absC (mkAlgAltsCSwitch tag_amode tagged_alts)
+ where
+ do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
+ do_enum_primop TagToEnumOp -- No code!
+ = returnFC (only arg_amodes)
+
+ do_enum_primop primop
+ = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+ returnFC tag_amode
+ where
+ tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+ -- Being a bit short of uniques for temporary variables here,
+ -- we use newTagUnique to generate a new unique from the case
+ -- binder. The case binder's unique will presumably have
+ -- the 'c' tag (generated by CoreToStg), so we just change
+ -- its tag to 'C' (for 'case') to ensure it doesn't clash with
+ -- anything else.
+ -- We can't use the unique from the case binder, becaus e
+ -- this is used to hold the actual result closure
+ -- (via the call to bindNewToTemp)
+
+ other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
\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).
+
Special case: scrutinising a non-primitive variable.
This can be done a little better than the general case, because
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) ->
+cgCase (StgApp fun args)
+ live_in_whole_case live_in_alts bndr srt alt_type alts
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
- -- Squish the environment
+ -- Nuking dead bindings *before* calculating the saves is the
+ -- value-add here. We might end up freeing up some slots currently
+ -- occupied by variables only required for the call.
+ -- NOTE: we need to look up the variables used in the call before
+ -- doing this, because some of them may not be in the environment
+ -- afterward.
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
- )
+ forkEval alts_eob_info
+ ( allocStackTop retPrimRepSize
+ `thenFC` \_ -> nopC )
+ ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
+ `thenFC` \ scrut_eob_info ->
+ setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
+ performTailCall 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 alt_type 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)
+ (nukeDeadBindings live_in_alts `thenC`
+ allocStackTop retPrimRepSize -- space for retn address
+ `thenFC` \_ -> nopC
+ )
+ (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
+
+ setEndOfBlockInfo (maybeReserveSeqFrame alt_type 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.
+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
- :: Unique
- -> StgCaseAlts
- -> [CAddrMode]
+maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
+ = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
+maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\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, _, _) = getAppSpecDataTyConExpandingDicts 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 ]
-\end{code}
-
-The situation is simpler for primitive
-results, because there is only one!
-
-\begin{code}
-getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq (typePrimRep ty)]
-\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
- -> StgCaseAlts
- -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
- -- so that we can duplicate it without risk of
- -- duplicating code
+cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
+ -> Id
+ -> SRT -- SRT for the continuation
+ -> AltType
+ -> [StgAlt]
+ -> 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 (UbxTupAlt _) [(con,args,_,rhs)]
+ = -- Unboxed tuple case
+ -- By now, the simplifier should have have turned it
+ -- into case e of (# a,b #) -> e
+ -- There shouldn't be a
+ -- case e of DEFAULT -> e
+ ASSERT2( case con of { DataAlt _ -> True; other -> False },
+ text "cgEvalAlts: dodgy case of unboxed tuple type" )
+
+ forkAbsC ( -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the mkRetDirect call
+ bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
+ -- restore the CC *after* binding the tuple components, so that we
+ -- get the stack offset of the saved CC right.
+ restoreCurrentCostCentre cc_slot True `thenC`
+ -- Generate a heap check if necessary
+ unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop (
+ -- And finally the code for the alternative
+ cgExpr rhs
+ )) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
+ returnFC (CaseAlts lbl Nothing False)
+
+cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+ = forkAbsC ( -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the mkRetDirect call
+ restoreCurrentCostCentre cc_slot True `thenC`
+ bindNewToReg bndr reg (mkLFArgument bndr) `thenC`
+ cgPrimAlts GCMayHappen (CReg reg) alts alt_type
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
+ returnFC (CaseAlts lbl Nothing False)
+ where
+ reg = dataReturnConvPrim kind
+ kind = tyConPrimRep tycon
-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 alt_type alts
+ = -- Algebraic and polymorphic case
+ -- Bind the default binder
+ bindNewToReg bndr node (mkLFArgument bndr) `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, _, _) = getAppSpecDataTyConExpandingDicts 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) ->
+ let ret_conv = case alt_type of
+ AlgAlt tc -> ctrlReturnConvAlg tc
+ PolyAlt -> UnvectoredReturn 0
- mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
+ use_labelled_alts = case ret_conv of
+ VectoredReturn _ -> True
+ _ -> False
- returnFC (CaseAlts return_vec semi_tagged_stuff)
+ semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts
-cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
- = -- Generate the instruction to restore cost centre, if any
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+ in
+ cgAlgAlts GCMayHappen (getUnique bndr)
+ cc_slot use_labelled_alts
+ alt_type alts `thenFC` \ tagged_alt_absCs ->
- -- Generate the switch
- getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
+ mkRetVecTarget bndr tagged_alt_absCs
+ srt ret_conv `thenFC` \ return_vec ->
- -- 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 return_vec semi_tagged_stuff False)
\end{code}
-\begin{code}
-cgInlineAlts :: GCFlag -> Unique
- -> StgCaseAlts
- -> Code
-\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.
-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.
-
-\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-}
-\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) ->
-
- -- 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
-\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}
-
-
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
\begin{code}
cgAlgAlts :: GCFlag
- -> 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 -- 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) = getAppSpecDataTyConExpandingDicts 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 -}
- 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)
-\end{code}
-
-\begin{code}
-cgAlgDefault :: GCFlag
- -> Unique -> AbstractC -> Bool -- turgid state...
- -> StgCaseDefault -- input
- -> Bool
- -> FCode AbstractC -- output
-
-cgAlgDefault gc_flag 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)
- 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`
- getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield [node] False
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [node] False (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)
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
--- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
+ -> Unique
+ -> Maybe VirtualSpOffset
+ -> Bool -- True <=> branches must be labelled
+ -- (used for semi-tagging)
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> [StgAlt] -- The alternatives
+ -> FCode [(AltCon, AbstractC)] -- The branches
+
+cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts
+ = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt
+ | alt <- alts]
cgAlgAlt :: GCFlag
- -> Unique -> AbstractC -> Bool -- turgid state
- -> Bool -- Context switch at alts?
- -> (Id, [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
- ) `thenFC` \ abs_c ->
+ -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> StgAlt
+ -> FCode (AltCon, AbstractC)
+
+cgAlgAlt gc_flag uniq cc_slot must_label_branch
+ alt_type (con, args, use_mask, rhs)
+ = getAbsC (bind_con_args con args `thenFC` \ _ ->
+ restoreCurrentCostCentre cc_slot True `thenC`
+ maybeAltHeapCheck gc_flag alt_type (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)
+ returnFC (con, final_abs_c)
where
- 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
- )
+ lbl = case con of
+ DataAlt dc -> mkAltLabel uniq (dataConTag dc)
+ DEFAULT -> mkDefaultLabel uniq
+ other -> pprPanic "cgAlgAlt" (ppr con)
+
+ bind_con_args DEFAULT args = nopC
+ bind_con_args (DataAlt dc) args = bindConArgs dc args
\end{code}
%************************************************************************
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: Unique
- -> [(Id, [Id], [Bool], StgExpr)]
- -> GenStgCaseDefault Id Id
+cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled
+ -> Id
+ -> [StgAlt]
-> SemiTaggingStuff
-cgSemiTaggedAlts uniq alts deflt
- = Just (map st_alt alts, st_deflt deflt)
+cgSemiTaggedAlts False binder alts
+ = Nothing
+cgSemiTaggedAlts True binder alts
+ = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts],
+ case head alts of
+ (DEFAULT, _, _, _) -> Just st_deflt
+ other -> Nothing)
where
- st_deflt StgNoDefault = Nothing
-
- st_deflt (StgBindDefault binder binder_used _)
- = Just (if binder_used then Just binder else Nothing,
- (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
+ uniq = getUnique binder
+
+ st_deflt = (binder,
+ (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
+ mkDefaultLabel uniq))
+
+ st_alt con args -- Ha! Nothing to do; Node already points to the thing
+ = (con_tag,
+ (CCallProfCtrMacro FSLIT("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
+ 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))
+tagToClosure :: TyCon -> CAddrMode -> CAddrMode
+-- Primops returning an enumeration type (notably Bool)
+-- actually return an index into
+-- the table of closures for the enumeration type
+tagToClosure tycon tag_amode
+ = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep
+ where
+ closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep
\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.
+@cgPrimAlts@ generates suitable a @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.
As usual, no binders in the alternatives are yet bound.
\begin{code}
cgPrimAlts :: GCFlag
- -> Unique
- -> Type
- -> [(Literal, StgExpr)] -- Alternatives
- -> StgCaseDefault -- Default
+ -> CAddrMode -- Scrutinee
+ -> [StgAlt] -- Alternatives
+ -> AltType
-> 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) ->
+-- INVARIANT: the default binder is already bound
+cgPrimAlts gc_flag scrutinee alts alt_type
+ = forkAlts (map (cgPrimAlt gc_flag alt_type) alts) `thenFC` \ tagged_absCs ->
+ let
+ ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
+ alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
+ in
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
- -> FCode (Literal, AbstractC) -- Its compiled form
-
-cgPrimAlt gc_flag (lit, rhs)
- = getAbsC rhs_code `thenFC` \ absC ->
- returnFC (lit,absC)
- where
- rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
-
-cgPrimDefault :: GCFlag
- -> CAddrMode -- Scrutinee
- -> StgCaseDefault
- -> FCode AbstractC
-
-cgPrimDefault gc_flag scrutinee 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
+ -> AltType
+ -> StgAlt -- The alternative
+ -> FCode (AltCon, AbstractC) -- Its compiled form
+
+cgPrimAlt gc_flag alt_type (con, [], [], rhs)
+ = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
+ getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) `thenFC` \ abs_c ->
+ returnFC (con, abs_c)
\end{code}
%************************************************************************
\begin{code}
+maybeAltHeapCheck
+ :: GCFlag
+ -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -> Code -- Continuation
+ -> Code
+maybeAltHeapCheck NoGC _ code = code
+maybeAltHeapCheck GCMayHappen alt_type code
+ = -- HWL: maybe need yield here
+ -- yield [node] True -- XXX live regs wrong
+ altHeapCheck alt_type 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)
-saveVolatileVars :: StgLiveVars -- Vars which should be made safe
+saveVolatileVars :: StgLiveVars -- Vars which should be made safe
-> 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))
+
+-- Sometimes we don't free the slot containing the cost centre after restoring it
+-- (see CgLetNoEscape.cgLetNoEscapeBody).
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
+restoreCurrentCostCentre Nothing _freeit = nopC
+restoreCurrentCostCentre (Just slot) freeit
+ = getSpRelOffset slot `thenFC` \ sp_rel ->
+ (if freeit then freeStackSlots [slot] else nopC) `thenC`
+ absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+ -- we use the RESTORE_CCCS macro, rather than just
+ -- assigning into CurCostCentre, in case RESTORE_CCCS
-- has some sanity-checking in it.
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-return-vec]{Building a return vector}
mode for it.
\begin{code}
-mkReturnVector :: Unique
- -> Type
- -> [(ConTag, AbstractC)] -- Branch codes
- -> AbstractC -- Default case
- -> 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))));
- 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)
-
- } in
- vtbl_body `thenC`
- returnFC return_vec_amode
- -- )
+mkRetDirectTarget :: Id -- Used for labelling only
+ -> AbstractC -- Return code
+ -> SRT -- Live CAFs in return code
+ -> FCode CAddrMode -- Emit the labelled return block,
+ -- and return its label
+mkRetDirectTarget bndr abs_c srt
+ = buildContLivenessMask bndr `thenFC` \ liveness ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
+ return lbl
where
-
- (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts 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
-
- mk_vector_entry :: ConTag -> Maybe CAddrMode
- mk_vector_entry tag
- = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> Nothing
- [absC] -> Just (CCode absC)
- _ -> panic "mkReturnVector: too many"
+ name = idName bndr
+ uniq = getUnique name
+ lbl = CLbl (mkReturnInfoLabel uniq) RetRep
\end{code}
-%************************************************************************
-%* *
-\subsection[CgCase-utils]{Utilities for handling case expressions}
-%* *
-%************************************************************************
-
-@possibleHeapCheck@ tests a flag passed in to decide whether to
-do a heap check or not.
-
\begin{code}
-possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
+mkRetVecTarget :: Id -- Just for its unique
+ -> [(AltCon, AbstractC)] -- Branch codes
+ -> SRT -- Continuation's SRT
+ -> CtrlReturnConvention
+ -> FCode CAddrMode
-possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
-possibleHeapCheck NoGC _ _ code = code
-\end{code}
+mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
+ = ASSERT( null other_alts )
+ mkRetDirectTarget bndr deflt_absC srt
+ where
+ ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
-Select a restricted set of registers based on a usage mask.
+mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
+ = mkRetDirectTarget bndr switch_absC srt
+ where
+ -- 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.
+ tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
+ switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
+
+
+mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
+ = buildContLivenessMask bndr `thenFC` \ liveness ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ let
+ ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
+ in
+ absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC`
+ -- Alts come first, because we don't want to declare all the symbols
-\begin{code}
-selectByMask [] [] = []
-selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
-selectByMask (False:ms) (x:xs) = selectByMask ms xs
+ return (CLbl vtbl_lbl DataPtrRep)
+ where
+ tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
+ vector_table = map mk_vector_entry tags
+ alts_absCs = map snd (sortBy cmp tagged_alt_absCs)
+ -- The sort is unnecessary; just there for now
+ -- to make the new order the same as the old
+ (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
+ (DEFAULT,_) `cmp` _ = GT
+ (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
+ (DataAlt d1,_) `cmp` (DEFAULT, _) = LT
+ -- Others impossible
+
+ name = idName bndr
+ uniq = getUnique name
+ vtbl_lbl = mkVecTblLabel uniq
+
+ deflt_lbl :: CAddrMode
+ deflt_lbl = case tagged_alt_absCs of
+ (DEFAULT, abs_c) : _ -> get_block_label abs_c
+ other -> mkIntCLit 0
+ -- 'other' case: the simplifier might have eliminated a case
+ -- so we may have e.g. case xs of
+ -- [] -> e
+ -- In that situation the default should never be taken,
+ -- so we just use '0' (=> seg fault if used)
+
+ mk_vector_entry :: ConTag -> CAddrMode
+ mk_vector_entry tag
+ = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
+ -- The comprehension neatly, and correctly, ignores the DEFAULT
+ [] -> deflt_lbl
+ [abs_c] -> get_block_label abs_c
+ _ -> panic "mkReturnVector: too many"
+
+ get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
\end{code}
projects / ghc-hetmet.git / blobdiff