X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCase.lhs;h=398441e30c67620cb936959dce8ff9f21c810c12;hp=e7c08940c5078eb9565b97f2d5e988cedbee25a4;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index e7c0894..398441e 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -1,15 +1,16 @@ % +% (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} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre ) where @@ -19,43 +20,33 @@ module CgCase ( cgCase, saveVolatileVarsAndRegs, 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 \end{code} @@ -111,7 +102,6 @@ cgCase :: StgExpr -> StgLiveVars -> StgLiveVars -> Id - -> SRT -> AltType -> [StgAlt] -> Code @@ -120,12 +110,12 @@ cgCase :: StgExpr Special case #1: case of literal. \begin{code} -cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt +cgCase (StgLit lit) live_in_whole_case live_in_alts bndr 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 } + ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit)) + ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } \end{code} Special case #2: scrutinising a primitive-typed variable. No @@ -136,7 +126,7 @@ allocating more heap than strictly necessary, but it will sometimes eliminate a heap check altogether. \begin{code} -cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt +cgCase (StgApp v []) live_in_whole_case live_in_alts bndr alt_type@(PrimAlt tycon) alts = 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 @@ -145,15 +135,15 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt v_info <- getCgIdInfo v ; amode <- idInfoToAmode v_info ; tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg amode) - ; cgPrimAlts NoGC alt_type tmp_reg alts } + ; stmtC (CmmAssign (CmmLocal tmp_reg) amode) + ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } \end{code} Special case #3: inline PrimOps and foreign calls. \begin{code} cgCase (StgOpApp op@(StgPrimOp primop) args _) - live_in_whole_case live_in_alts bndr srt alt_type alts + live_in_whole_case live_in_alts bndr alt_type alts | not (primOpOutOfLine primop) = cgInlinePrimOp primop args bndr alt_type live_in_alts alts \end{code} @@ -168,7 +158,7 @@ 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 + live_in_whole_case live_in_alts bndr alt_type alts | unsafe_foreign_call = ASSERT( isSingleton alts ) do -- *must* be an unboxed tuple alt. @@ -184,7 +174,7 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _) unsafe_foreign_call = case fcall of CCall (CCallSpec _ _ s) -> not (playSafe s) - _other -> False + _other -> False \end{code} Special case: scrutinising a non-primitive variable. @@ -193,7 +183,7 @@ 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 + live_in_whole_case live_in_alts bndr alt_type alts = do { fun_info <- getCgIdInfo fun ; arg_amodes <- getArgAmodes args @@ -211,9 +201,9 @@ cgCase (StgApp fun args) <- forkEval alts_eob_info (allocStackTop retAddrSizeW >> nopC) (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + ; setEndOfBlockInfo scrut_eob_info (performTailCall fun_info arg_amodes save_assts) } \end{code} @@ -231,7 +221,7 @@ deAllocStackTop call is doing above. Finally, here is the general case. \begin{code} -cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts +cgCase expr live_in_whole_case live_in_alts bndr alt_type alts = do { -- Figure out what volatile variables to save nukeDeadBindings live_in_whole_case @@ -248,10 +238,9 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts ; allocStackTop retAddrSizeW -- space for retn address ; nopC }) (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) - (cgExpr expr) + ; setEndOfBlockInfo scrut_eob_info (cgExpr expr) } \end{code} @@ -281,13 +270,6 @@ 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 bndr _)) - = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True) -maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info -\end{code} - - %************************************************************************ %* * Inline primops @@ -309,7 +291,7 @@ 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 } + ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts } cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts = ASSERT( isSingleton alts ) @@ -336,10 +318,12 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- Bind the default binder if necessary -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage ; whenC (not (isDeadBinder bndr)) (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg (tagToClosure hmods tycon tag_amode)) }) + ; stmtC (CmmAssign + (CmmLocal tmp_reg) + (tagToClosure tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} @@ -356,9 +340,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts (_,e) <- getArgAmode arg return e do_enum_primop primop - = do tmp <- newTemp wordRep + = do tmp <- newNonPtrTemp wordRep cgPrimOp [tmp] primop args live_in_alts - returnFC (CmmReg tmp) + returnFC (CmmReg (CmmLocal tmp)) cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr) @@ -377,14 +361,13 @@ is some evaluation to be done. \begin{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 alt_type@(PrimAlt tycon) alts +cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts = do { let rep = tyConCgRep tycon reg = dataReturnConvPrim rep -- Bottom for voidRep @@ -396,10 +379,10 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts ; restoreCurrentCostCentre cc_slot True ; cgPrimAlts GCMayHappen alt_type reg alts } - ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt - ; returnFC (CaseAlts lbl Nothing bndr False) } + ; lbl <- emitReturnTarget (idName bndr) abs_c + ; returnFC (CaseAlts lbl Nothing bndr) } -cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] +cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)] = -- Unboxed tuple case -- By now, the simplifier should have have turned it -- into case e of (# a,b #) -> e @@ -408,7 +391,7 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] ASSERT2( case con of { DataAlt _ -> True; other -> False }, text "cgEvalAlts: dodgy case of unboxed tuple type" ) do { -- forkAbsC for the RHS, so that the envt is - -- not changed for the emitDirectReturn call + -- not changed for the emitReturn call abs_c <- forkProc $ do { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args -- Restore the CC *after* binding the tuple components, @@ -418,10 +401,10 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] -- 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) } + ; lbl <- emitReturnTarget (idName bndr) abs_c + ; returnFC (CaseAlts lbl Nothing bndr) } -cgEvalAlts cc_slot bndr srt alt_type alts +cgEvalAlts cc_slot bndr alt_type alts = -- Algebraic and polymorphic case do { -- Bind the default binder bindNewToReg bndr nodeReg (mkLFArgument bndr) @@ -438,13 +421,13 @@ cgEvalAlts cc_slot bndr srt alt_type alts ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) - alts mb_deflt srt ret_conv + alts mb_deflt fam_sz - ; returnFC (CaseAlts lbl branches bndr False) } + ; returnFC (CaseAlts lbl branches bndr) } where - ret_conv = case alt_type of - AlgAlt tc -> ctrlReturnConvAlg tc - PolyAlt -> UnvectoredReturn 0 + fam_sz = case alt_type of + AlgAlt tc -> tyConFamilySize tc + PolyAlt -> 0 \end{code}