%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
-
-module CgCase (
- cgCase,
- saveVolatileVarsAndRegs,
+module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
- -- and to make the interface self-sufficient...
- StgExpr, Id, StgCaseAlternatives, CgState
- ) where
+#include "HsVersions.h"
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
+import {-# SOURCE #-} CgExpr
-import StgSyn
import CgMonad
+import StgSyn
import AbsCSyn
-import AbsPrel ( PrimOp(..), primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
+ magicIdPrimRep, getAmodeRep
)
-import AbsUniType ( kindFromType, getTyConDataCons,
- getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
- isEnumerationTyCon,
- UniType
+import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
+ bindNewToReg, bindNewToTemp,
+ bindNewPrimToAmode,
+ rebindToAStack, rebindToBStack,
+ getCAddrModeAndInfo, getCAddrModeIfVolatile,
+ idInfoToAmode
)
-import CgBindery -- all of it
import CgCon ( buildDynCon, bindConArgs )
-import CgExpr ( cgExpr, getPrimOpArgAmodes )
-import CgHeapery ( heapCheck )
-import CgRetConv -- lots of stuff
-import CgStackery -- plenty
+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 -- and even more
-import CLabelInfo -- bunches of things...
-import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
- layOutDynCon
- )-}
-import CmdLineOpts ( GlobalSwitch(..) )
+import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
+import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
+ mkAltLabel
+ )
+import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
+import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, CostCentre )
-import BasicLit ( kindOfBasicLit )
-import Id ( getDataConTag, getIdKind, fIRST_TAG, isDataCon,
- toplevelishId, getInstantiatedDataConSig,
- ConTag(..), DataCon(..)
+import HeapOffs ( VirtualSpBOffset, VirtualHeapOffset )
+import Id ( idPrimRep, dataConTag, fIRST_TAG, ConTag,
+ isDataCon, DataCon,
+ idSetToList, GenId{-instance Uniquable,Eq-}, Id
+ )
+import Literal ( Literal )
+import Maybes ( catMaybes )
+import PrimOp ( primOpCanTriggerGC, PrimOp(..),
+ primOpStackRequired, StackRequirement(..)
+ )
+import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
+ PrimRep(..)
)
-import Maybes ( catMaybes, Maybe(..) )
-import PrimKind ( getKindSize, isFollowableKind, retKindSize, PrimKind(..) )
-import UniqSet -- ( uniqSetToList, UniqSet(..) )
-import Util
+import TyCon ( isEnumerationTyCon )
+import Type ( typePrimRep,
+ splitAlgTyConApp, splitAlgTyConApp_maybe,
+ Type
+ )
+import Unique ( Unique, Uniquable(..) )
+import Util ( sortLt, isIn, isn'tIn, zipEqual )
+import Outputable
\end{code}
\begin{code}
It is quite interesting to decide whether to put a heap-check
at the start of each alternative. Of course we certainly have
to do so if the case forces an evaluation, or if there is a primitive
-op which can trigger GC.
+op which can trigger GC.
A more interesting situation is this:
\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.
\end{itemize}
Against:
-
+
\begin{itemize}
\item
May do more allocation than reqd. This sometimes bites us
\tr{!C!} without a full save-volatile-vars sequence.
\begin{code}
-cgCase :: PlainStgExpr
- -> PlainStgLiveVars
- -> PlainStgLiveVars
+cgCase :: StgExpr
+ -> StgLiveVars
+ -> StgLiveVars
-> Unique
- -> PlainStgCaseAlternatives
+ -> 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
-
- 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@(StgPrimApp 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 | StgVarAtom fv <- args, not (toplevelishId fv) ]
- -- Hack, hack
-\end{code}
-
-
-\begin{code}
-cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
+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 ->
+ getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
result_amodes = getPrimAppResultAmodes uniq alts
liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
-- 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`
| otherwise -- *Can* trigger GC
= getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
---NO: getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- 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 {-NO:isw_chkr-} op
+ op_result_regs = assignPrimOpResultRegs op
op_result_amodes = map CReg op_result_regs
- (op_arg_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
+ (op_arg_amodes, liveness_mask, arg_assts)
+ = makePrimOpArgsRobust op arg_amodes
liveness_arg = mkIntCLit liveness_mask
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))
+ -- 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-}))
+ 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
+ -- 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
+ = 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)
+ 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
-- on as the first "argument"
-- ToDo: un-duplicate?
- pin_liveness (CCallOp _ _ _ _ _) _ args = args
+ pin_liveness (CCallOp _ _ _ _ _ _) _ args = args
pin_liveness other_op liveness_arg args
= liveness_arg :args
\begin{code}
cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
- = getAtomAmode v `thenFC` \ amode ->
+ = getArgAmode v `thenFC` \ amode ->
cgPrimAltsGivenScrutinee NoGC amode alts deflt
\end{code}
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
-cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-})
- live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
+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) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
-- Squish the environment
nukeDeadBindings live_in_alts `thenC`
- saveVolatileVarsAndRegs live_in_alts
+ saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
forkEval alts_eob_info
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`
- forkEval alts_eob_info
+ forkEval alts_eob_info
(nukeDeadBindings live_in_alts)
(cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
\begin{code}
getPrimAppResultAmodes
:: Unique
- -> PlainStgCaseAlternatives
+ -> StgCaseAlts
-> [CAddrMode]
\end{code}
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 IntKind
- (spec_tycon, _, _) = getUniDataSpecTyCon ty
+ tag_amode = CTemp uniq IntRep
+ (spec_tycon, _, _) = splitAlgTyConApp ty
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Default is either StgNoDefault or StgBindDefault with unused binder
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 IntKind
+ 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,_,_,_) = getDataConTag con1 < getDataConTag con2
+ (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 (getTheUnique arg) (getIdKind arg) | arg <- args ]
+ = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
\end{code}
The situation is simpler for primitive
\begin{code}
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq kind]
- where
- kind = kindFromType ty
+ = [CTemp uniq (typePrimRep ty)]
\end{code}
\begin{code}
cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
-> Unique
- -> PlainStgCaseAlternatives
+ -> 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 cc_slot uniq (StgAlgAlts ty alts deflt)
= -- Generate the instruction to restore cost centre, if any
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- 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, _, _) = getUniDataSpecTyCon ty
+ (spec_tycon, _, _) = splitAlgTyConApp ty
- use_labelled_alts
+ use_labelled_alts
= case ctrlReturnConvAlg spec_tycon of
VectoredReturn _ -> True
_ -> False
= if not use_labelled_alts then
Nothing -- no semi-tagging info
else
- cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just <something>
+ cgSemiTaggedAlts uniq alts deflt -- Just <something>
in
- cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
+ cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
- absC (CRetUnVector vtbl_label
- (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
+ 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-})
\begin{code}
cgInlineAlts :: GCFlag -> Unique
- -> PlainStgCaseAlternatives
+ -> 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
\begin{code}
cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- = cgAlgAltRhs gc_flag con args use_mask rhs
+ = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
\end{code}
Second case: algebraic case, several alternatives.
\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) ->
+ 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 IntKind
-\end{code}
-
-=========== OLD: we *can* now handle this case ================
-
-Next, a case we can't deal with: an algebraic case with no evaluation
-required (so it is in-line), and a default case as well. In this case
-we require all the alternatives written out, so that we can invent
-suitable binders to pass to the PrimOp. A default case defeats this.
-Could be fixed, but probably isn't worth it.
-
-\begin{code}
-{- ============= OLD
-cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default)
- = panic "cgInlineAlts: alg alts with default"
-================= END OF OLD -}
+ tag_amode = CTemp uniq IntRep
\end{code}
Third (real) case: primitive result type.
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
-> Bool -- True <=> branches must be labelled
- -> UniType -- From the case statement
- -> [(Id, [Id], [Bool], PlainStgExpr)] -- The alternatives
- -> PlainStgCaseDefault -- The default
+ -> 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
)
case.
OLD: All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate.
+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.
\begin{code}
cgAlgAlts gc_flag uniq restore_cc semi_tagging
ty alts deflt@(StgBindDefault binder True{-used-} _)
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
+ emit_yield{-should a yield macro be emitted?-}
+ = let
extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons)
+ 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)
+ 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)
+ (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 CodePtrKind)
+ jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
- (spec_tycon, _, spec_cons)
- = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
- -- ppr PprDebug uniq,
- -- ppr PprDebug ty,
- -- ppr PprShowAll binder
- -- ]))) (
- getUniDataSpecTyCon ty
- -- )
+ (spec_tycon, _, spec_cons) = splitAlgTyConApp ty
alt_cons = [ con | (con,_,_,_) <- alts ]
default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
- spec_con `not_elem` alt_cons ] -- Not handled explicitly
+ spec_con `not_elem` alt_cons ] -- Not handled explicitly
where
not_elem = isn'tIn "cgAlgAlts"
-- 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 :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC)))
+ mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
- mk_extra_branch isw_chkr con
+ mk_extra_branch con
= ASSERT(isDataCon con)
- case dataReturnConvAlg isw_chkr con of
+ 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 = getDataConTag con
- closure_lbl = mkClosureLabel 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.
buildDynCon binder useCurrentCostCentre con
(map CReg regs) (all zero_size regs)
`thenFC` \ idinfo ->
- idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
absC (CAssign (CReg node) amode) `thenC`
absC jump_instruction
)
where
- zero_size reg = getKindSize (kindFromMagicId reg) == 0
+ 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
+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)
+ 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)
+ (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
\end{code}
\begin{code}
cgAlgDefault :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state...
- -> PlainStgCaseDefault -- input
- -> FCode AbstractC -- output
+ -> StgCaseDefault -- input
+ -> Bool
+ -> FCode AbstractC -- output
cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault
+ 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)
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
where
lbl = mkDefaultLabel uniq
+-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
cgAlgAlt :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state
- -> (Id, [Id], [Bool], PlainStgExpr)
+ -> Bool -- Context switch at alts?
+ -> (Id, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
-cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
+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) `thenFC` \ abs_c ->
+ cgAlgAltRhs gc_flag con args use_mask rhs
+ emit_yield
+ ) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
| otherwise = abs_c
in
returnFC (tag, final_abs_c)
where
- tag = getDataConTag con
+ tag = dataConTag con
lbl = mkAltLabel uniq tag
-cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
-
-cgAlgAltRhs gc_flag con args use_mask rhs
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
+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 isw_chkr con) of
+ = case (dataReturnConvAlg con) of
ReturnInHeap -> ([], True)
- ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
+ 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` \ _ ->
+ NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
nopC
GCMayHappen -> bindConArgs con args
) `thenC`
- cgExpr rhs
+ cgExpr rhs
)
\end{code}
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: IntSwitchChecker
- -> Unique
- -> [(Id, [Id], [Bool], PlainStgExpr)]
- -> StgCaseDefault Id Id
+cgSemiTaggedAlts :: Unique
+ -> [(Id, [Id], [Bool], StgExpr)]
+ -> GenStgCaseDefault Id Id
-> SemiTaggingStuff
-cgSemiTaggedAlts isw_chkr uniq alts deflt
- = Just (map (st_alt isw_chkr) alts, st_deflt deflt)
+cgSemiTaggedAlts uniq alts deflt
+ = Just (map st_alt alts, st_deflt deflt)
where
st_deflt StgNoDefault = Nothing
mkDefaultLabel uniq)
)
- st_alt isw_chkr (con, args, use_mask, _)
- = case (dataReturnConvAlg isw_chkr con) of
+ st_alt (con, args, use_mask, _)
+ = case (dataReturnConvAlg con) of
ReturnInHeap ->
-- Ha! Nothing to do; Node already points to the thing
-- We have to load the live registers from the constructor
-- pointed to by Node.
let
- (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
+ (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
used_regs = selectByMask use_mask regs
- used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
+ used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
reg `is_elem` used_regs]
is_elem = isIn "cgSemiTaggedAlts"
CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
join_label))
where
- con_tag = getDataConTag con
+ 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) (kindFromMagicId reg))
+ = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
\begin{code}
cgPrimAlts :: GCFlag
-> Unique
- -> UniType
- -> [(BasicLit, PlainStgExpr)] -- Alternatives
- -> PlainStgCaseDefault -- Default
+ -> Type
+ -> [(Literal, StgExpr)] -- Alternatives
+ -> StgCaseDefault -- Default
-> Code
cgPrimAlts gc_flag uniq ty alts deflt
NoGC -> CTemp uniq kind
GCMayHappen -> CReg (dataReturnConvPrim kind)
- kind = kindFromType ty
+ kind = typePrimRep ty
cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
cgPrimAlt :: GCFlag
- -> (BasicLit, PlainStgExpr) -- The alternative
- -> FCode (BasicLit, AbstractC) -- Its compiled form
+ -> (Literal, StgExpr) -- The alternative
+ -> FCode (Literal, AbstractC) -- Its compiled form
cgPrimAlt gc_flag (lit, rhs)
= getAbsC rhs_code `thenFC` \ absC ->
cgPrimDefault :: GCFlag
-> CAddrMode -- Scrutinee
- -> PlainStgCaseDefault
+ -> StgCaseDefault
-> FCode AbstractC
cgPrimDefault gc_flag scrutinee StgNoDefault
cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
= getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
where
- regs = if isFollowableKind (getAmodeKind scrutinee) then
+ regs = if isFollowableRep (getAmodeRep scrutinee) then
[node] else []
rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
\begin{code}
saveVolatileVarsAndRegs
- :: PlainStgLiveVars -- 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
+ -- address now is
Maybe VirtualSpBOffset) -- Slot for current cost centre
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,
- maybe_cc_slot)
+ new_eob_info,
+ maybe_cc_slot)
-saveVolatileVars :: PlainStgLiveVars -- 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 (uniqSetToList vars)
+ = save_em (idSetToList vars)
where
save_em [] = returnFC AbsCNop
= getCAddrModeIfVolatile var `thenFC` \ v ->
case v of
Nothing -> save_em vars -- Non-volatile, so carry on
-
+
Just vol_amode -> -- Aha! It's volatile
save_var var vol_amode `thenFC` \ abs_c ->
returnFC (abs_c `mkAbsCStmts` abs_cs)
save_var var vol_amode
- | isFollowableKind kind
+ | 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 (getKindSize kind) `thenFC` \ b_slot ->
+ = 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)
where
- kind = getAmodeKind vol_amode
+ kind = getAmodeRep vol_amode
saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
-saveReturnAddress
+saveReturnAddress
= getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
-- See if it is volatile
case sequel of
InRetReg -> -- Yes, it's volatile
- allocBStack retKindSize `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
+ allocBStack retPrimRepSize `thenFC` \ b_slot ->
+ getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
- CAssign (CVal spb_rel RetKind) (CReg RetReg))
+ 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
-- appear adjacent on the B stack. This makes sure
-- that B-stack squeezing works ok.
-- See note below
- allocBStack retKindSize `thenFC` \ b_slot ->
- returnFC (eob_info, AbsCNop)
+ allocBStack retPrimRepSize `thenFC` \ b_slot ->
+ returnFC (eob_info, AbsCNop)
other -> -- No, it's non-volatile, so do nothing
- returnFC (eob_info, AbsCNop)
+ returnFC (eob_info, AbsCNop)
\end{code}
Note about B-stack squeezing. Consider the following:`
(b)~the assignment to do the save (just as for @saveVolatileVars@).
\begin{code}
-saveCurrentCostCentre ::
+saveCurrentCostCentre ::
FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
-- Nothing if not lexical CCs
AbstractC) -- Assignment to save it
-- AbsCNop if not lexical CCs
saveCurrentCostCentre
- = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling ->
+ = let
+ doing_profiling = opt_SccProfilingOn
+ in
if not doing_profiling then
returnFC (Nothing, AbsCNop)
else
- allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot ->
+ allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
getSpBRelOffset b_slot `thenFC` \ spb_rel ->
returnFC (Just b_slot,
- CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre))
+ CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
-restoreCurrentCostCentre Nothing
+restoreCurrentCostCentre Nothing
= returnFC AbsCNop
-restoreCurrentCostCentre (Just b_slot)
+restoreCurrentCostCentre (Just b_slot)
= getSpBRelOffset b_slot `thenFC` \ spb_rel ->
freeBStkSlot b_slot `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind])
+ 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
-- has some sanity-checking in it.
\begin{code}
mkReturnVector :: Unique
- -> UniType
+ -> 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 {
+ (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg tycon) of {
UnvectoredReturn _ ->
(CUnVecLbl ret_label vtbl_label,
absC (CRetUnVector vtbl_label
- (CLabelledCode ret_label
- (mkAlgAltsCSwitch (CReg TagReg)
- tagged_alt_absCs
- deflt_absC))));
+ (CLabelledCode ret_label
+ (mkAlgAltsCSwitch (CReg TagReg)
+ tagged_alt_absCs
+ deflt_absC))));
VectoredReturn table_size ->
- (CLbl vtbl_label DataPtrKind,
+ (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)])
+ (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
deflt_absC))
-- Leave nops and comments in for now; they are eliminated
-- )
where
- (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
+ (tycon,_,_) = case splitAlgTyConApp_maybe ty of -- *must* be a real "data" type constructor
Just xx -> xx
- Nothing -> error ("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: "++(ppShow 80 (ppr PprDebug ty)))
+ Nothing -> pprPanic "ERROR: can't generate code for polymorphic case"
+ (vcat [text "probably a mis-use of `seq' or `par';",
+ text "the User's Guide has more details.",
+ text "Offending type:" <+> ppr ty
+ ])
vtbl_label = mkVecTblLabel uniq
ret_label = mkReturnPtLabel uniq
projects / ghc-hetmet.git / blobdiff