%
+% (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,
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 StgSyn
+import StaticFlags
+import Id
+import ForeignCall
+import VarSet
+import CoreSyn
+import PrimOp
+import Type
+import TyCon
+import Util
import Outputable
+
+import Control.Monad (when)
\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
- alt_type@(PrimAlt tycon) alts
+cgCase (StgLit lit) _live_in_whole_case _live_in_alts bndr
+ alt_type@(PrimAlt _) 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
- alt_type@(PrimAlt tycon) alts
- = do { -- Careful! we can't just bind the default binder to the same thing
+cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
+ alt_type@(PrimAlt _) alts
+ -- Note [ticket #3132]: we might be looking at a case of a lifted Id
+ -- that was cast to an unlifted type. The Id will always be bottom,
+ -- but we don't want the code generator to fall over here. If we
+ -- just emit an assignment here, the assignment will be
+ -- type-incorrect Cmm. Hence we check that the types match, and if
+ -- they don't we'll fall through and emit the usual enter/return
+ -- code. Test case: codeGen/should_compile/3132.hs
+ | isUnLiftedType (idType v)
+
+ -- However, we also want to allow an assignment to be generated
+ -- in the case when the types are compatible, because this allows
+ -- some slightly-dodgy but occasionally-useful casts to be used,
+ -- such as in RtClosureInspect where we cast an HValue to a MutVar#
+ -- so we can print out the contents of the MutVar#. If we generate
+ -- code that enters the HValue, then we'll get a runtime panic, because
+ -- the HValue really is a MutVar#. The types are compatible though,
+ -- so we can just generate an assignment.
+ || reps_compatible
+ =
+ 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
+ when (not reps_compatible) $
+ panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+ ; 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 }
+ where
+ reps_compatible = idCgRep v == idCgRep bndr
\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
+cgCase (StgOpApp (StgPrimOp primop) args _)
+ _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}
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
+cgCase (StgOpApp (StgFCallOp fcall _) args _)
+ _live_in_whole_case live_in_alts _bndr _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
+ ; let res_hints = map (typeForeignHint.idType) non_void_res_ids
+ ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts
; cgExpr rhs }
where
(_, res_ids, _, rhs) = head alts
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.
\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
%************************************************************************
\begin{code}
-cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
+cgInlinePrimOp :: PrimOp -> [StgArg] -> Id -> AltType -> StgLiveVars
+ -> [(AltCon, [Id], [Bool], StgExpr)]
+ -> Code
+cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts
| isVoidArg (idCgRep bndr)
= ASSERT( con == DEFAULT && isSingleton alts && null bs )
do { -- VOID RESULT; just sequencing,
= 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
+cgInlinePrimOp primop args _ (UbxTupAlt _) live_in_alts alts
= ASSERT( isSingleton alts )
do { -- UNBOXED TUPLE ALTS
-- No heap check, no yield, just get in there and do it.
-- Bind the default binder if necessary
-- (avoiding it avoids the assignment)
-- The deadness info is set by StgVarInfo
- ; 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 <- newTemp bWord
cgPrimOp [tmp] primop args live_in_alts
- returnFC (CmmReg tmp)
+ returnFC (CmmReg (CmmLocal tmp))
-cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
+cgInlinePrimOp _ _ bndr _ _ _
= pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
\end{code}
\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
-- There shouldn't be a
-- case e of DEFAULT -> e
- ASSERT2( case con of { DataAlt _ -> True; other -> False },
+ ASSERT2( case con of { DataAlt _ -> True; _ -> 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)
; (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
+ PrimAlt _ -> panic "cgEvalAlts: PrimAlt"
+ UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt"
\end{code}
let
mb_deflt = case alts of -- DEFAULT is always first, if present
((DEFAULT,blks) : _) -> Just blks
- other -> Nothing
+ _ -> Nothing
branches = [(dataConTagZ con, blks)
| (DataAlt con, blks) <- alts]
-> StgAlt
-> FCode (AltCon, CgStmts)
-cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs)
+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
- bind_con_args DEFAULT args = nopC
+ bind_con_args DEFAULT _ = nopC
bind_con_args (DataAlt dc) args = bindConArgs dc args
+ bind_con_args (LitAlt _) _ = panic "cgAlgAlt: LitAlt"
\end{code}
-> FCode (AltCon, CgStmts) -- Its compiled form
cgPrimAlt gc_flag alt_type (con, [], [], rhs)
- = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
+ = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; _ -> False } )
do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))
; returnFC (con, abs_c) }
+cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists"
\end{code}
restoreCurrentCostCentre (Just slot) freeit
= do { sp_rel <- getSpRelOffset slot
; whenC freeit (freeStackSlots [slot])
- ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) }
+ ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel bWord)) }
\end{code}
projects / ghc-hetmet.git / blobdiff