%
\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
#include "HsVersions.h"
-#include "../includes/ClosureTypes.h"
import {-# SOURCE #-} CgExpr ( cgExpr )
import TyCon
import Util
import Outputable
-import Constants
\end{code}
\begin{code}
-> StgLiveVars
-> StgLiveVars
-> Id
- -> SRT
-> AltType
-> [StgAlt]
-> Code
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
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
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}
\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.
unsafe_foreign_call
= case fcall of
CCall (CCallSpec _ _ s) -> not (playSafe s)
- _other -> False
-\end{code}
-
-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
-
- <info table goes here>
-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
- }
+ _other -> False
\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.
+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 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
<- 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}
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
; 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}
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
= 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 )
; this_pkg <- getThisPackage
; whenC (not (isDeadBinder bndr))
(do { tmp_reg <- bindNewToTemp bndr
- ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) })
+ ; stmtC (CmmAssign
+ (CmmLocal tmp_reg)
+ (tagToClosure tycon tag_amode)) })
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
(_,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)
\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
; 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
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,
-- 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)
+ -- 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)
- 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
-
-
--- 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)) [])
+ fam_sz = case alt_type of
+ AlgAlt tc -> tyConFamilySize tc
+ PolyAlt -> 0
\end{code}
projects / ghc-hetmet.git / blobdiff