projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
SPARC NCG: Fix available regs for graph allocator
[ghc-hetmet.git]
/
compiler
/
codeGen
/
CgCase.lhs
diff --git
a/compiler/codeGen/CgCase.lhs
b/compiler/codeGen/CgCase.lhs
index
11a3c3e
..
f7bcf5a
100644
(file)
--- a/
compiler/codeGen/CgCase.lhs
+++ b/
compiler/codeGen/CgCase.lhs
@@
-29,7
+29,6
@@
import ClosureInfo
import SMRep
import CmmUtils
import Cmm
import SMRep
import CmmUtils
import Cmm
-import MachOp
import StgSyn
import StaticFlags
import StgSyn
import StaticFlags
@@
-103,8
+102,8
@@
cgCase :: StgExpr
Special case #1: case of literal.
\begin{code}
Special case #1: case of literal.
\begin{code}
-cgCase (StgLit lit) live_in_whole_case live_in_alts bndr
- 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 (CmmLocal tmp_reg) (CmmLit cm_lit))
= do { tmp_reg <- bindNewToTemp bndr
; cm_lit <- cgLit lit
; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
@@
-119,8
+118,8
@@
allocating more heap than strictly necessary, but it will sometimes
eliminate a heap check altogether.
\begin{code}
eliminate a heap check altogether.
\begin{code}
-cgCase (StgApp v []) live_in_whole_case live_in_alts bndr
- alt_type@(PrimAlt tycon) alts
+cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
+ alt_type@(PrimAlt _) 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
-- two bindings pointing at the same stack locn doesn't work (it
= 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
@@
-135,8
+134,8
@@
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr
Special case #3: inline PrimOps and foreign calls.
\begin{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 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}
| not (primOpOutOfLine primop)
= cgInlinePrimOp primop args bndr alt_type live_in_alts alts
\end{code}
@@
-150,15
+149,15
@@
Special case #4: inline foreign calls: an unsafe foreign call can be done
right here, just like an inline primop.
\begin{code}
right here, just like an inline primop.
\begin{code}
-cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
- live_in_whole_case live_in_alts bndr 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
| 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
; cgExpr rhs }
where
(_, res_ids, _, rhs) = head alts
@@
-176,7
+175,7
@@
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
\begin{code}
cgCase (StgApp fun args)
- live_in_whole_case live_in_alts bndr alt_type alts
+ _live_in_whole_case live_in_alts bndr alt_type alts
= do { fun_info <- getCgIdInfo fun
; arg_amodes <- getArgAmodes args
= do { fun_info <- getCgIdInfo fun
; arg_amodes <- getArgAmodes args
@@
-270,7
+269,10
@@
anywhere within the record).
%************************************************************************
\begin{code}
%************************************************************************
\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,
| isVoidArg (idCgRep bndr)
= ASSERT( con == DEFAULT && isSingleton alts && null bs )
do { -- VOID RESULT; just sequencing,
@@
-286,7
+288,7
@@
cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
; cgPrimOp [tmp_reg] primop args live_in_alts
; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }
; cgPrimOp [tmp_reg] primop args live_in_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.
= ASSERT( isSingleton alts )
do { -- UNBOXED TUPLE ALTS
-- No heap check, no yield, just get in there and do it.
@@
-311,12
+313,11
@@
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
-- 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
(CmmLocal tmp_reg)
; whenC (not (isDeadBinder bndr))
(do { tmp_reg <- bindNewToTemp bndr
; stmtC (CmmAssign
(CmmLocal tmp_reg)
- (tagToClosure this_pkg tycon tag_amode)) })
+ (tagToClosure tycon tag_amode)) })
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
@@
-333,11
+334,11
@@
cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
(_,e) <- getArgAmode arg
return e
do_enum_primop primop
(_,e) <- getArgAmode arg
return e
do_enum_primop primop
- = do tmp <- newNonPtrTemp wordRep
+ = do tmp <- newTemp bWord
cgPrimOp [tmp] primop args live_in_alts
returnFC (CmmReg (CmmLocal tmp))
cgPrimOp [tmp] primop args live_in_alts
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}
= pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
\end{code}
@@
-381,7
+382,7
@@
cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]
-- into case e of (# a,b #) -> e
-- There shouldn't be a
-- case e of DEFAULT -> e
-- 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 emitReturn call
text "cgEvalAlts: dodgy case of unboxed tuple type" )
do { -- forkAbsC for the RHS, so that the envt is
-- not changed for the emitReturn call
@@
-421,6
+422,8
@@
cgEvalAlts cc_slot bndr alt_type alts
fam_sz = case alt_type of
AlgAlt tc -> tyConFamilySize tc
PolyAlt -> 0
fam_sz = case alt_type of
AlgAlt tc -> tyConFamilySize tc
PolyAlt -> 0
+ PrimAlt _ -> panic "cgEvalAlts: PrimAlt"
+ UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt"
\end{code}
\end{code}
@@
-457,7
+460,7
@@
cgAlgAlts gc_flag cc_slot alt_type alts
let
mb_deflt = case alts of -- DEFAULT is always first, if present
((DEFAULT,blks) : _) -> Just blks
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]
branches = [(dataConTagZ con, blks)
| (DataAlt con, blks) <- alts]
@@
-471,15
+474,16
@@
cgAlgAlt :: GCFlag
-> StgAlt
-> FCode (AltCon, CgStmts)
-> 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
= 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 (DataAlt dc) args = bindConArgs dc args
+ bind_con_args (LitAlt _) _ = panic "cgAlgAlt: LitAlt"
\end{code}
\end{code}
@@
-520,9
+524,10
@@
cgPrimAlt :: GCFlag
-> FCode (AltCon, CgStmts) -- Its compiled form
cgPrimAlt gc_flag alt_type (con, [], [], rhs)
-> 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) }
do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))
; returnFC (con, abs_c) }
+cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists"
\end{code}
\end{code}
@@
-605,6
+610,6
@@
restoreCurrentCostCentre Nothing _freeit = nopC
restoreCurrentCostCentre (Just slot) freeit
= do { sp_rel <- getSpRelOffset slot
; whenC freeit (freeStackSlots [slot])
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}
\end{code}