X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=c7b03ef13a41ed78e37a34066438c972d1ef6132;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=c805aaa413316596f2343f2796a5d2d8636d8198;hpb=553e90d9a32ee1b1809430f260c401cc4169c6c7;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index c805aaa..c7b03ef 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.68 2004/08/10 09:02:38 simonmar Exp $ +% $Id: CgCase.lhs,v 1.69 2004/08/13 13:05:51 simonmar Exp $ % %******************************************************** %* * @@ -11,7 +11,7 @@ \begin{code} module CgCase ( cgCase, saveVolatileVarsAndRegs, - mkRetDirectTarget, restoreCurrentCostCentre + restoreCurrentCostCentre ) where #include "HsVersions.h" @@ -20,43 +20,42 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import StgSyn -import AbsCSyn - -import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, - getAmodeRep, shimFCallArg ) -import CgBindery ( getVolatileRegs, getArgAmodes, +import CgBindery ( getArgAmodes, bindNewToReg, bindNewToTemp, - getCAddrModeAndInfo, - rebindToStack, getCAddrMode, getCAddrModeIfVolatile, - buildContLivenessMask, nukeDeadBindings, + getCgIdInfo, getArgAmode, + rebindToStack, getCAddrModeIfVolatile, + nukeDeadBindings, idInfoToAmode ) import CgCon ( bindConArgs, bindUnboxedTupleComponents ) import CgHeapery ( altHeapCheck, unbxTupleHeapCheck ) -import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, +import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg, CtrlReturnConvention(..) ) -import CgStackery ( allocPrimStack, allocStackTop, - deAllocStackTop, freeStackSlots, dataStackSlots +import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset, + deAllocStackTop, freeStackSlots ) import CgTailCall ( performTailCall ) -import CgUsages ( getSpRelOffset ) -import CLabel ( mkVecTblLabel, mkClosureTblLabel, - mkDefaultLabel, mkAltLabel, mkReturnInfoLabel - ) +import CgPrimOp ( cgPrimOp ) +import CgForeignCall ( cgForeignCall ) +import CgUtils ( newTemp, cgLit, emitLitSwitch, emitSwitch, + tagToClosure ) +import CgProf ( curCCS, curCCSAddr ) +import CgInfoTbls ( emitDirectReturnTarget, emitAlgReturnTarget, + dataConTagZ ) +import SMRep ( CgRep(..), retAddrSizeW, nonVoidArg, isVoidArg, + idCgRep, tyConCgRep, typeHint ) +import CmmUtils ( CmmStmts, noStmts, oneStmt, plusStmts ) +import Cmm +import MachOp ( wordRep ) import ClosureInfo ( mkLFArgument ) import CmdLineOpts ( opt_SccProfilingOn ) -import Id ( Id, idName, isDeadBinder ) -import DataCon ( dataConTag, fIRST_TAG, ConTag ) +import Id ( Id, idName, isDeadBinder, idType ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe ) 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 ForeignCall -import Util ( only ) -import List ( sortBy ) +import PrimOp ( PrimOp(..), primOpOutOfLine ) +import TyCon ( isEnumerationTyCon, tyConFamilySize ) +import Util ( isSingleton ) import Outputable \end{code} @@ -122,10 +121,11 @@ Special case #1: case of literal. \begin{code} 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 + alt_type@(PrimAlt tycon) alts + = do { tmp_reg <- bindNewToTemp bndr + ; cm_lit <- cgLit lit + ; stmtC (CmmAssign tmp_reg (CmmLit cm_lit)) + ; cgPrimAlts NoGC alt_type tmp_reg alts } \end{code} Special case #2: scrutinising a primitive-typed variable. No @@ -138,15 +138,15 @@ eliminate a heap check altogether. \begin{code} 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 + = do { -- 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. + v_info <- getCgIdInfo v + ; amode <- idInfoToAmode v_info + ; tmp_reg <- bindNewToTemp bndr + ; stmtC (CmmAssign tmp_reg amode) + ; cgPrimAlts NoGC alt_type tmp_reg alts } \end{code} Special case #3: inline PrimOps and foreign calls. @@ -154,85 +154,8 @@ Special case #3: inline PrimOps and foreign calls. \begin{code} cgCase (StgOpApp op args _) live_in_whole_case live_in_alts bndr srt alt_type alts - | inline_primop - = -- Get amodes for the arguments and results - getArgAmodes args `thenFC` \ arg_amodes1 -> - let - arg_amodes - | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1 - | otherwise = arg_amodes1 - in - 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 - | StgPrimOp primop <- op - -> ASSERT( isEnumerationTyCon tycon ) - let - 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) - in - 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) - - other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type) - where - inline_primop = case op of - StgPrimOp primop -> not (primOpOutOfLine primop) - --StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True - -- unsafe foreign calls are "inline" - _otherwise -> False - + | not (primOpOutOfLine primop) + = cgInlinePrimOp primop args bndr alt_type live_in_alts alts \end{code} TODO: Case-of-case of primop can probably be done inline too (but @@ -240,6 +163,30 @@ maybe better to translate it out beforehand). See ghc/lib/misc/PackedString.lhs for examples where this crops up (with 4.02). +Special case #4: inline foreign calls: an unsafe foreign call can be done +right here, just like an inline primop. + +\begin{code} +cgCase (StgOpApp op@(StgFCallOp fcall _) args _) + live_in_whole_case live_in_alts bndr srt alt_type alts + | unsafe_foreign_call + = ASSERT( isSingleton alts ) + do -- *must* be an unboxed tuple alt. + -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. + { res_tmps <- mapFCs bindNewToTemp non_void_res_ids + ; let res_hints = map (typeHint.idType) non_void_res_ids + ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts + ; cgExpr rhs } + where + (_, res_ids, _, rhs) = head alts + non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids + + unsafe_foreign_call + = case fcall of + CCall (CCallSpec _ _ s) -> not (playSafe s) + _other -> False +\end{code} + 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). @@ -247,8 +194,8 @@ we can reuse/trim the stack slot holding the variable (if it is in one). \begin{code} 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 -> + = do { fun_info <- getCgIdInfo fun + ; arg_amodes <- getArgAmodes args -- Nuking dead bindings *before* calculating the saves is the -- value-add here. We might end up freeing up some slots currently @@ -256,19 +203,18 @@ cgCase (StgApp fun args) -- 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 - ( 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 + ; nukeDeadBindings live_in_alts + ; (save_assts, alts_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_alts + + ; scrut_eob_info + <- forkEval alts_eob_info + (allocStackTop retAddrSizeW >> nopC) + (do { deAllocStackTop retAddrSizeW + ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + + ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + (performTailCall fun_info arg_amodes save_assts) } \end{code} Note about return addresses: we *always* push a return address, even @@ -286,26 +232,27 @@ Finally, here is the general case. \begin{code} 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` + = do { -- Figure out what volatile variables to save + nukeDeadBindings live_in_whole_case - saveVolatileVarsAndRegs live_in_alts - `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> - - -- Save those variables right now! - absC save_assts `thenC` - - -- generate code for the alts - forkEval alts_eob_info - (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 + ; (save_assts, alts_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_alts + + -- Save those variables right now! + ; emitStmts save_assts + + -- generate code for the alts + ; scrut_eob_info + <- forkEval alts_eob_info + (do { nukeDeadBindings live_in_alts + ; allocStackTop retAddrSizeW -- space for retn address + ; nopC }) + (do { deAllocStackTop retAddrSizeW + ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + + ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + (cgExpr expr) + } \end{code} There's a lot of machinery going on behind the scenes to manage the @@ -329,25 +276,93 @@ 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). +different. So we pick a free stack slot and save CCCS in it. One +consequence of this 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} -maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _)) - = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True) +maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff bndr _)) + = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True) maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info \end{code} + +%************************************************************************ +%* * + Inline primops +%* * +%************************************************************************ + +\begin{code} +cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts + | isVoidArg (idCgRep bndr) + = ASSERT( con == DEFAULT && isSingleton alts && null bs ) + do { -- VOID RESULT; just sequencing, + -- so get in there and do it + cgPrimOp [] primop args live_in_alts + ; cgExpr rhs } + where + (con,bs,_,rhs) = head alts + +cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts + = do { -- PRIMITIVE ALTS, with non-void result + tmp_reg <- bindNewToTemp bndr + ; cgPrimOp [tmp_reg] primop args live_in_alts + ; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts } + +cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts + = ASSERT( isSingleton alts ) + do { -- 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 + + res_tmps <- mapFCs bindNewToTemp non_void_res_ids + ; cgPrimOp res_tmps primop args live_in_alts + ; cgExpr rhs } + where + (_, res_ids, _, rhs) = head alts + non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids + +cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts + = do { -- ENUMERATION TYPE RETURN + -- Typical: case a ># b of { True -> ..; False -> .. } + -- The primop itself returns an index into the table of + -- closures for the enumeration type. + tag_amode <- ASSERT( isEnumerationTyCon tycon ) + do_enum_primop primop + + -- Bind the default binder if necessary + -- (avoiding it avoids the assignment) + -- The deadness info is set by StgVarInfo + ; whenC (not (isDeadBinder bndr)) + (do { tmp_reg <- bindNewToTemp bndr + ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) }) + + -- Compile the alts + ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} + (AlgAlt tycon) alts + + -- Do the switch + ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1) + } + where + + do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result + do_enum_primop TagToEnumOp -- No code! + | [arg] <- args = do + (_,e) <- getArgAmode arg + return e + do_enum_primop primop + = do tmp <- newTemp wordRep + cgPrimOp [tmp] primop args live_in_alts + returnFC (CmmReg tmp) + +cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts + = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr) +\end{code} + %************************************************************************ %* * \subsection[CgCase-alts]{Alternatives} @@ -368,6 +383,21 @@ cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if -- to be a label so that we can duplicate it -- without risk of duplicating code +cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts + = do { let rep = tyConCgRep tycon + reg = dataReturnConvPrim rep -- Bottom for voidRep + + ; abs_c <- forkProc $ do + { -- Bind the case binder, except if it's void + -- (reg is bottom in that case) + whenC (nonVoidArg rep) $ + bindNewToReg bndr reg (mkLFArgument bndr) + ; restoreCurrentCostCentre cc_slot True + ; cgPrimAlts GCMayHappen alt_type reg alts } + + ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt + ; returnFC (CaseAlts lbl Nothing bndr False) } + cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] = -- Unboxed tuple case -- By now, the simplifier should have have turned it @@ -376,38 +406,24 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] -- 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 + do { -- forkAbsC for the RHS, so that the envt is + -- not changed for the emitDirectReturn call + abs_c <- forkProc $ do + { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args + -- Restore the CC *after* binding the tuple components, + -- so that we get the stack offset of the saved CC right. + ; restoreCurrentCostCentre cc_slot True + -- Generate a heap check if necessary + -- and finally the code for the alternative + ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts + (cgExpr rhs) } + ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt + ; returnFC (CaseAlts lbl Nothing bndr False) } cgEvalAlts cc_slot bndr srt alt_type alts = -- Algebraic and polymorphic case - -- Bind the default binder - bindNewToReg bndr node (mkLFArgument bndr) `thenC` + do { -- Bind the default binder + bindNewToReg bndr nodeReg (mkLFArgument bndr) -- Generate sequel info for use downstream -- At the moment, we only do it if the type is vector-returnable. @@ -418,25 +434,16 @@ cgEvalAlts cc_slot bndr srt alt_type alts -- -- which is worse than having the alt code in the switch statement - let ret_conv = case alt_type of - AlgAlt tc -> ctrlReturnConvAlg tc - PolyAlt -> UnvectoredReturn 0 - - use_labelled_alts = case ret_conv of - VectoredReturn _ -> True - _ -> False - - semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts - - in - cgAlgAlts GCMayHappen (getUnique bndr) - cc_slot use_labelled_alts - alt_type alts `thenFC` \ tagged_alt_absCs -> + ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts - mkRetVecTarget bndr tagged_alt_absCs - srt ret_conv `thenFC` \ return_vec -> + ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) + alts mb_deflt srt ret_conv - returnFC (CaseAlts return_vec semi_tagged_stuff False) + ; returnFC (CaseAlts lbl branches bndr False) } + where + ret_conv = case alt_type of + AlgAlt tc -> ctrlReturnConvAlg tc + PolyAlt -> UnvectoredReturn 0 \end{code} @@ -462,94 +469,42 @@ are inlined alternatives. \begin{code} cgAlgAlts :: GCFlag - -> 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 + -> AltType -- ** AlgAlt or PolyAlt only ** + -> [StgAlt] -- The alternatives + -> FCode ( [(ConTagZ, CgStmts)], -- The branches + Maybe CgStmts ) -- The default case + +cgAlgAlts gc_flag cc_slot alt_type alts + = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts] + let + mb_deflt = case alts of -- DEFAULT is always first, if present + ((DEFAULT,blks) : _) -> Just blks + other -> Nothing + + branches = [(dataConTagZ con, blks) + | (DataAlt con, blks) <- alts] + -- in + return (branches, mb_deflt) -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 -> Maybe VirtualSpOffset -> Bool -- turgid state - -> AltType -- ** AlgAlt or PolyAlt only ** + -> Maybe VirtualSpOffset -- 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 = CCodeBlock lbl abs_c - | otherwise = abs_c - in - returnFC (con, final_abs_c) + -> FCode (AltCon, CgStmts) + +cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs) + = do { abs_c <- getCgStmts $ do + { bind_con_args con args + ; restoreCurrentCostCentre cc_slot True + ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } + ; return (con, abs_c) } where - 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} -%************************************************************************ -%* * -\subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging} -%* * -%************************************************************************ - -Turgid-but-non-monadic code to conjure up the required info from -algebraic case alternatives for semi-tagging. - -\begin{code} -cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled - -> Id - -> [StgAlt] - -> SemiTaggingStuff - -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 - 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) - ) - where - con_tag = dataConTag con - join_label = mkAltLabel uniq con_tag - - -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} %************************************************************************ %* * @@ -566,29 +521,31 @@ As usual, no binders in the alternatives are yet bound. \begin{code} cgPrimAlts :: GCFlag - -> CAddrMode -- Scrutinee + -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck + -> CmmReg -- Scrutinee -> [StgAlt] -- Alternatives - -> AltType -> Code +-- NB: cgPrimAlts emits code that does the case analysis. +-- It's often used in inline situations, rather than to genearte +-- a labelled return point. That's why its interface is a little +-- different to cgAlgAlts +-- -- 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 +cgPrimAlts gc_flag alt_type scrutinee alts + = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts) + ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default + alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others] + ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC } cgPrimAlt :: GCFlag -> AltType - -> StgAlt -- The alternative - -> FCode (AltCon, AbstractC) -- Its compiled form + -> StgAlt -- The alternative + -> FCode (AltCon, CgStmts) -- 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) + do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) + ; returnFC (con, abs_c) } \end{code} @@ -605,52 +562,42 @@ maybeAltHeapCheck -> 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 +maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code saveVolatileVarsAndRegs :: StgLiveVars -- Vars which should be made safe - -> FCode (AbstractC, -- Assignments to do the saves + -> FCode (CmmStmts, -- Assignments to do the saves 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) -> - getEndOfBlockInfo `thenFC` \ eob_info -> - returnFC (mkAbstractCs [var_saves, cc_save], - eob_info, - maybe_cc_slot) + = do { var_saves <- saveVolatileVars vars + ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre + ; eob_info <- getEndOfBlockInfo + ; returnFC (var_saves `plusStmts` cc_save, + eob_info, + maybe_cc_slot) } saveVolatileVars :: StgLiveVars -- Vars which should be made safe - -> FCode AbstractC -- Assignments to to the saves + -> FCode CmmStmts -- Assignments to to the saves saveVolatileVars vars - = save_em (varSetElems vars) + = do { stmts_s <- mapFCs save_it (varSetElems vars) + ; return (foldr plusStmts noStmts stmts_s) } where - save_em [] = returnFC AbsCNop - - save_em (var:vars) - = 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 -> - save_em vars `thenFC` \ abs_cs -> - returnFC (abs_c `mkAbsCStmts` abs_cs) + save_it var + = do { v <- getCAddrModeIfVolatile var + ; case v of + Nothing -> return noStmts -- Non-volatile + Just vol_amode -> save_var var vol_amode -- Aha! It's volatile + } save_var var 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 + = do { slot <- allocPrimStack (idCgRep var) + ; rebindToStack var slot + ; sp_rel <- getSpRelOffset slot + ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) } \end{code} --------------------------------------------------------------------------- @@ -663,123 +610,24 @@ virtual offset of the location, to pass on to the alternatives, and \begin{code} saveCurrentCostCentre :: FCode (Maybe VirtualSpOffset, -- Where we decide to store it - AbstractC) -- Assignment to save it + CmmStmts) -- Assignment to save it saveCurrentCostCentre - = if not opt_SccProfilingOn then - returnFC (Nothing, AbsCNop) - else - allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot -> - dataStackSlots [slot] `thenC` - getSpRelOffset slot `thenFC` \ sp_rel -> - returnFC (Just slot, - CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre)) + | not opt_SccProfilingOn + = returnFC (Nothing, noStmts) + | otherwise + = do { slot <- allocPrimStack PtrArg + ; sp_rel <- getSpRelOffset slot + ; returnFC (Just slot, + oneStmt (CmmStore sp_rel curCCS)) } -- 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} -%* * -%************************************************************************ - -Build a return vector, and return a suitable label addressing -mode for it. - -\begin{code} -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 - name = idName bndr - uniq = getUnique name - lbl = CLbl (mkReturnInfoLabel uniq) RetRep + = do { sp_rel <- getSpRelOffset slot + ; whenC freeit (freeStackSlots [slot]) + ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) } \end{code} -\begin{code} -mkRetVecTarget :: Id -- Just for its unique - -> [(AltCon, AbstractC)] -- Branch codes - -> SRT -- Continuation's SRT - -> CtrlReturnConvention - -> FCode CAddrMode - -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 - -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 - - 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}