X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCase.lhs;h=7f440c11f2dbefd0d677b1fad4af536b1b92acb4;hb=7f1bc015a4094a8282ad4090768d780fd4d6122d;hp=7b4861a11d21a8725e75f60fedc45b2f2dce6fea;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 7b4861a..7f440c1 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -1,13 +1,7 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.75 2005/06/21 10:44:41 simonmar Exp $ -% -%******************************************************** -%* * -\section[CgCase]{Converting @StgCase@ expressions} -%* * -%******************************************************** \begin{code} module CgCase ( cgCase, saveVolatileVarsAndRegs, @@ -15,48 +9,40 @@ module CgCase ( cgCase, saveVolatileVarsAndRegs, ) where #include "HsVersions.h" +#include "../includes/ClosureTypes.h" import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad -import StgSyn -import CgBindery ( getArgAmodes, - bindNewToReg, bindNewToTemp, - getCgIdInfo, getArgAmode, - rebindToStack, getCAddrModeIfVolatile, - nukeDeadBindings, idInfoToAmode - ) -import CgCon ( bindConArgs, bindUnboxedTupleComponents ) -import CgHeapery ( altHeapCheck, unbxTupleHeapCheck ) -import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg, - CtrlReturnConvention(..) - ) -import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset, - deAllocStackTop, freeStackSlots - ) -import CgTailCall ( performTailCall ) -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 CgBindery +import CgCon +import CgHeapery +import CgCallConv +import CgStackery +import CgTailCall +import CgPrimOp +import CgForeignCall +import CgUtils +import CgProf +import CgInfoTbls + +import ClosureInfo +import SMRep +import CmmUtils import Cmm -import MachOp ( wordRep ) -import ClosureInfo ( mkLFArgument ) -import StaticFlags ( opt_SccProfilingOn ) -import Id ( Id, idName, isDeadBinder, idType ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe ) -import VarSet ( varSetElems ) -import CoreSyn ( AltCon(..) ) -import PrimOp ( PrimOp(..), primOpOutOfLine ) -import TyCon ( isEnumerationTyCon, tyConFamilySize ) -import Util ( isSingleton ) +import MachOp + +import StgSyn +import StaticFlags +import Id +import ForeignCall +import VarSet +import CoreSyn +import PrimOp +import TyCon +import Util import Outputable +import Constants \end{code} \begin{code} @@ -187,9 +173,54 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _) _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). +Special case: scrutinising a non-primitive variable. This is where we +want to do semi-tagging. The code generated will be something like this: + + save volatile vars + R1 = fun + jump c99_ret + + +c99_ret: + infoptr = R1[0] + type = infoptr[-4] // or something + if (type > 8) goto no_cons + tag = infoptr[-6] + if (tag == 1) ... etc. +no_cons + jump infoptr + +\begin{code} +cgCase (StgApp fun []) + live_in_whole_case live_in_alts bndr srt (AlgAlt tycon) alts + = do { fun_info <- getCgIdInfo fun + ; fun_amode <- idInfoToAmode fun_info + + ; 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 + ; cgEvalAltsSemiTag maybe_cc_slot bndr srt + tycon alts }) + + -- jump to the continuation immediately + ; case scrut_eob_info of + EndOfBlockInfo sp (CaseAlts lbl _ _ _) -> do + let node_asst = oneStmt (CmmAssign nodeReg fun_amode) + emitSimultaneously (node_asst `plusStmts` save_assts) + let jmp = stmtC (CmmJump (CmmLit (CmmLabel lbl)) []) + setEndOfBlockInfo scrut_eob_info $ + doFinalJump sp False jmp + } +\end{code} + +Special case: scrutinising a non-primitive application. This can be +done a little better than the general case, because we can reuse/trim +the stack slot holding the variables involved in the application. \begin{code} cgCase (StgApp fun args) @@ -426,15 +457,6 @@ cgEvalAlts cc_slot bndr srt alt_type alts 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. - -- Reason: if not, then it costs extra to label the - -- alternatives, because we'd get return code like: - -- - -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc } - -- - -- which is worse than having the alt code in the switch statement - ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) @@ -445,6 +467,43 @@ cgEvalAlts cc_slot bndr srt alt_type alts ret_conv = case alt_type of AlgAlt tc -> ctrlReturnConvAlg tc PolyAlt -> UnvectoredReturn 0 + + +-- Alternatives for a semi-tagging case expression +cgEvalAltsSemiTag cc_slot bndr srt tycon alts + = do -- Bind the default binder + bindNewToReg bndr nodeReg (mkLFArgument bndr) + + blks <- getCgStmts $ cgEvalAltsSemiTag' cc_slot tycon alts + lbl <- emitDirectReturnTarget (idName bndr) blks srt + return (CaseAlts lbl Nothing bndr False) + +cgEvalAltsSemiTag' cc_slot tycon alts + = do + (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot (AlgAlt tycon) alts + + iptr <- newTemp wordRep + stmtC (CmmAssign iptr (closureInfoPtr (CmmReg nodeReg))) + -- share the iptr between ctype and tag, below + + -- we don't have a 1-indexed tag field, we have to use the type + -- field first to find out whether the closure is a constructor + not_constr <- newLabelC + + let highCons = CmmLit (CmmInt CONSTR_NOCAF_STATIC halfWordRep) + stmtC (CmmCondBranch (CmmMachOp (MO_U_Gt halfWordRep) + [infoTableClosureType (infoTable (CmmReg iptr)), + highCons]) + not_constr) + + let tag_expr = CmmMachOp (MO_U_Conv halfWordRep wordRep) + [infoTableConstrTag (infoTable (CmmReg iptr))] + + let family_size = tyConFamilySize tycon + emitSwitch tag_expr alts mb_deflt 0 (family_size - 1) + + labelC not_constr + stmtC (CmmJump (entryCode (CmmReg iptr)) []) \end{code}