Commit 0a4e3ee6 authored by simonm's avatar simonm
Browse files

[project @ 1999-04-27 12:34:49 by simonm]

- Fix the tagToEnum# support in the code generator

- Make isDeadBinder work on case binders

- Fix compiling of

	case x `op` y of z {
		True  -> ... z ...
		False -> ... z ...

- Clean up CgCase a little.

- Don't generate specialised tag2con functions for derived Enum/Ix
  instances; use tagToEnum# instead.
parent 68d47df3
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CLabel.lhs,v 1.24 1999/03/02 16:44:26 sof Exp $
% $Id: CLabel.lhs,v 1.25 1999/04/27 12:34:49 simonm Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
......@@ -173,6 +173,7 @@ data CLabelType
= InfoTblType
| ClosureType
| VecTblType
| ClosureTblType
| CodeType
| DataType
\end{code}
......@@ -248,9 +249,9 @@ needsCDecl (IdLabel _ _) = True
needsCDecl (CaseLabel _ CaseReturnPt) = True
needsCDecl (DataConLabel _ _) = True
needsCDecl (CaseLabel _ _) = False
needsCDecl (TyConLabel _) = True
needsCDecl (AsmTempLabel _) = False
needsCDecl (TyConLabel _) = False
needsCDecl (RtsLabel _) = False
needsCDecl (CC_Label _) = False
needsCDecl (CCS_Label _) = False
......@@ -304,6 +305,7 @@ labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
labelType (CaseLabel _ CaseReturnPt) = CodeType
labelType (CaseLabel _ CaseVecTbl) = VecTblType
labelType (TyConLabel _) = ClosureTblType
labelType (IdLabel _ info) =
case info of
......
......@@ -227,15 +227,15 @@ pprAbsC stmt@(COpStmt results op args vol_regs) _
the_op = ppr_op_call non_void_results non_void_args
-- liveness mask is *in* the non_void_args
in
case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
vcat [ pp_saves,
the_op,
pp_restores
]
}
else
the_op
}
where
ppr_op_call results args
= hcat [ pprPrimOp op, lparen,
......@@ -555,10 +555,11 @@ ppLocalnessMacro include_dyn_prefix clabel =
visiblity_prefix,
dyn_prefix,
case label_type of
ClosureType -> ptext SLIT("C_")
CodeType -> ptext SLIT("F_")
InfoTblType -> ptext SLIT("I_")
DataType -> ptext SLIT("D_") <>
ClosureType -> ptext SLIT("C_")
CodeType -> ptext SLIT("F_")
InfoTblType -> ptext SLIT("I_")
ClosureTblType -> ptext SLIT("CP_")
DataType -> ptext SLIT("D_") <>
if isReadOnly clabel
then ptext SLIT("RO_")
else empty
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.26 1999/04/23 13:53:28 simonm Exp $
% $Id: CgCase.lhs,v 1.27 1999/04/27 12:34:52 simonm Exp $
%
%********************************************************
%* *
......@@ -65,8 +65,9 @@ import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
import Type ( Type, typePrimRep, splitAlgTyConApp,
splitTyConApp_maybe,
splitFunTys, applyTys )
import Unique ( Unique, Uniquable(..) )
import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
import Maybes ( maybeToBool )
import Util
import Outputable
\end{code}
......@@ -127,27 +128,71 @@ cgCase :: StgExpr
-> Code
\end{code}
Several special cases for inline primitive operations.
Special case #1: PrimOps returning enumeration types.
For enumeration types, we invent a temporary (builtin-unique 1) to
hold the tag, and cross our fingers that this doesn't clash with
anything else. Builtin-unique 0 is used for a similar reason when
compiling enumerated-type primops in CgExpr.lhs. We can't use the
unique from the case binder, because this is used to hold the actual
closure (when the case binder is live, that is).
There is an extra special case for
case tagToEnum# x of
...
which generates no code for the primop, unless x is used in the
alternatives (in which case we lookup the tag in the relevant closure
table to get the closure).
\begin{code}
cgCase (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
live_in_whole_case live_in_alts bndr srt alts
cgCase (StgCon (PrimOp op) args res_ty)
live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
| isEnumerationTyCon tycon
= getArgAmode arg `thenFC` \amode ->
let
[res] = getPrimAppResultAmodes (getUnique bndr) alts
= getArgAmodes args `thenFC` \ arg_amodes ->
let tag_amode = case op of
TagToEnumOp -> only arg_amodes
_ -> CTemp (mkBuiltinUnique 1) IntRep
closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep
in
absC (CAssign res (CTableEntry
(CLbl (mkClosureTblLabel tycon) PtrRep)
amode PtrRep)) `thenC`
-- Scrutinise the result
cgInlineAlts bndr alts
case op of {
TagToEnumOp -> nopC; -- no code!
_ -> -- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
absC (COpStmt [tag_amode] op
arg_amodes -- note: no liveness arg
vol_regs)
} `thenC`
-- bind the default binder if necessary
(if (isDeadBinder bndr)
then nopC
else bindNewToTemp bndr `thenFC` \ bndr_amode ->
absC (CAssign bndr_amode closure))
`thenC`
-- compile the alts
cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
False{-not poly case-} alts deflt
False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
| otherwise = panic "cgCase: tagToEnum# of non-enumerated type"
where
(Just (tycon,_)) = splitTyConApp_maybe res_ty
uniq = getUnique bndr
\end{code}
Special case #2: inline PrimOps.
\begin{code}
cgCase (StgCon (PrimOp op) args res_ty)
live_in_whole_case live_in_alts bndr srt alts
| not (primOpOutOfLine op)
......@@ -348,43 +393,8 @@ getPrimAppResultAmodes
:: Unique
-> StgCaseAlts
-> [CAddrMode]
\end{code}
If there's an StgBindDefault which does use the bound
variable, then we can only handle it if the type involved is
an enumeration type. That's important in the case
of comparisions:
case x ># y of
r -> f r
The only reason for the restriction to *enumeration* types is our
inability to invent suitable temporaries to hold the results;
Elaborating the CTemp addr mode to have a second uniq field
(which would simply count from 1) would solve the problem.
Anyway, cgInlineAlts is now capable of handling all cases;
it's only this function which is being wimpish.
\begin{code}
getPrimAppResultAmodes uniq (StgAlgAlts ty alts
(StgBindDefault rhs))
| isEnumerationTyCon spec_tycon = [tag_amode]
| otherwise = pprPanic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" (ppr uniq <+> ppr rhs)
where
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
tag_amode = CTemp uniq IntRep
(spec_tycon, _, _) = splitAlgTyConApp ty
\end{code}
If we don't have a default case, we could be scrutinising an unboxed
tuple, or an enumeration type...
\begin{code}
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Default is either StgNoDefault or StgBindDefault with unused binder
| isEnumerationTyCon tycon = [CTemp uniq IntRep]
getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
| isUnboxedTupleTyCon tycon =
case alts of
......@@ -395,12 +405,10 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
| otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
where (tycon, _, _) = splitAlgTyConApp ty
\end{code}
The situation is simpler for primitive results, because there is only
one!
-- The situation is simpler for primitive results, because there is only
-- one!
\begin{code}
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
= [CTemp uniq (typePrimRep ty)]
\end{code}
......@@ -536,49 +544,6 @@ cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
= panic "cgInlineAlts: single alternative, not an unboxed tuple"
\end{code}
Hack: to deal with
case <# x y of z {
DEFAULT -> ...
}
\begin{code}
cgInlineAlts bndr (StgAlgAlts ty [] (StgBindDefault rhs))
= bindNewToTemp bndr `thenFC` \amode ->
let
(tycon, _, _) = splitAlgTyConApp ty
closure_lbl = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) amode PtrRep
in
absC (CAssign amode closure_lbl) `thenC`
cgExpr rhs
\end{code}
Second case: algebraic case, several alternatives.
Tag is held in a temporary.
\begin{code}
cgInlineAlts bndr (StgAlgAlts ty alts deflt)
= -- bind the default binder (it covers all the alternatives)
-- ToDo: BUG! bndr isn't bound in the alternatives
-- Shows up when compiling Word.lhs
-- case cmp# a b of r {
-- True -> f1 r
-- False -> f2 r
cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
False{-not poly case-} alts deflt
False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
where
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
tag_amode = CTemp uniq IntRep
uniq = getUnique bndr
\end{code}
Third (real) case: primitive result type.
\begin{code}
......@@ -586,7 +551,6 @@ cgInlineAlts bndr (StgPrimAlts ty alts deflt)
= cgPrimInlineAlts bndr ty alts deflt
\end{code}
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
......
......@@ -51,7 +51,7 @@ module PrelInfo (
ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR,
ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
error_RDR, assertErr_RDR, getTag_RDR,
error_RDR, assertErr_RDR, getTag_RDR, tagToEnumH_RDR,
showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
......@@ -567,6 +567,7 @@ ltH_Int_RDR = prelude_primop IntLtOp
geH_RDR = prelude_primop IntGeOp
leH_RDR = prelude_primop IntLeOp
minusH_RDR = prelude_primop IntSubOp
tagToEnumH_RDR = prelude_primop TagToEnumOp
getTag_RDR = varQual pREL_GHC SLIT("getTag#")
\end{code}
......
......@@ -16,7 +16,9 @@ import StgSyn
import Id ( setIdArity, getIdArity, Id )
import VarSet
import VarEnv
import IdInfo ( ArityInfo(..) )
import Var
import IdInfo ( ArityInfo(..), InlinePragInfo(..),
setInlinePragInfo )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined )
import BasicTypes ( Arity )
......@@ -287,6 +289,11 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
let
-- determine whether the default binder is dead or not
bndr'= if (bndr `elementOfFVInfo` alts_fvs)
then bndr `modifyIdInfo` (setInlinePragInfo NoInlinePragInfo)
else bndr `modifyIdInfo` (setInlinePragInfo IAmDead)
-- don't consider the default binder as being 'live in alts',
-- since this is from the point of view of the case expr, where
-- the default binder is not free.
......@@ -303,7 +310,7 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
in
returnLne (
StgCase scrut2 live_in_whole_case live_in_alts bndr srt alts2,
StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
(scrut_fvs `unionFVInfo` alts_fvs)
`minusFVBinders` [bndr],
(alts_escs `unionVarSet` (getFVSet scrut_fvs))
......
......@@ -21,8 +21,10 @@ import CoreUtils ( coreExprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
import Id ( Id, mkSysLocal, idType,
externallyVisibleId, setIdUnique, idName
externallyVisibleId, setIdUnique, idName, getIdDemandInfo
)
import Var ( modifyIdInfo )
import IdInfo ( setDemandInfo )
import DataCon ( DataCon, dataConName, dataConId )
import Name ( Name, nameModule, isLocallyDefinedName )
import Module ( isDynamicModule )
......@@ -32,6 +34,7 @@ import Const ( Con(..), isWHNFCon, Literal(..) )
import PrimOp ( PrimOp(..) )
import Type ( isUnLiftedType, isUnboxedTupleType, Type )
import TysPrim ( intPrimTy )
import Demand
import Unique ( Unique, Uniquable(..) )
import UniqSupply -- all of it, really
import Outputable
......@@ -451,7 +454,7 @@ coreExprToStgFloat env expr@(Con con args)
\begin{code}
coreExprToStgFloat env expr@(Case scrut bndr alts)
= coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
newLocalId env bndr `thenUs` \ (env', bndr') ->
newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
returnUs (binds, mkStgCase scrut' bndr' alts')
where
......@@ -534,6 +537,18 @@ newLocalId env id
in
returnUs (new_env, id')
-- we overload the demandInfo field of an Id to indicate whether the Id is definitely
-- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
-- some redundant cases (c.f. dataToTag# above).
newEvaldLocalId env id
= getUniqueUs `thenUs` \ uniq ->
let
id' = setIdUnique id uniq `modifyIdInfo` setDemandInfo wwStrict
new_env = extendVarEnv env id id'
in
returnUs (new_env, id')
newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
newLocalIds env []
= returnUs (env, [])
......
......@@ -211,7 +211,7 @@ tcDeriving modname fixs rn_name_supply inst_decl_infos_in
-- Now augment the InstInfos, adding in the rather boring
-- actual-code-to-do-the-methods binds. We may also need to
-- generate extra not-one-inst-decl-specific binds, notably
-- "con2tag" and/or "tag2con" functions. We do these
-- the "con2tag" function. We do these
-- separately.
gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
......@@ -539,10 +539,6 @@ these is around is given by @hasCon2TagFun@.
The examples under the different sections below will make this
clearer.
\item
Much less often (really just for deriving @Ix@), we use a
@_tag2con_<tycon>@ function. See the examples.
\item
We use the renamer!!! Reason: we're supposed to be
producing @RenamedMonoBinds@ for the methods, but that means
......@@ -605,7 +601,7 @@ gen_inst_info modname
%************************************************************************
%* *
\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
\subsection[TcDeriv-taggery-Names]{What con2tag functions are available?}
%* *
%************************************************************************
......@@ -613,7 +609,6 @@ gen_inst_info modname
data Foo ... = ...
con2tag_Foo :: Foo ... -> Int#
tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
maxtag_Foo :: Int -- ditto (NB: not unboxed)
......@@ -627,14 +622,6 @@ Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
(enum type only????)
\end{itemize}
We have a @tag2con@ function for a tycon if:
\begin{itemize}
\item
We're deriving @Enum@, or @Ix@ (enum type only???)
\end{itemize}
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
gen_taggery_Names :: [InstInfo]
-> TcM s [(RdrName, -- for an assoc list
......@@ -644,7 +631,7 @@ gen_taggery_Names :: [InstInfo]
gen_taggery_Names inst_infos
= --pprTrace "gen_taggery:\n" (vcat [hsep [ppr c, ppr t] | (c,t) <- all_CTs]) $
foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
foldlTc do_tag2con names_so_far tycons_of_interest
foldlTc do_maxtag names_so_far tycons_of_interest
where
all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _) <- inst_infos ]
......@@ -667,12 +654,11 @@ gen_taggery_Names inst_infos
| otherwise
= returnTc acc_Names
do_tag2con acc_Names tycon
do_maxtag acc_Names tycon
| isDataTyCon tycon &&
(we_are_deriving enumClassKey tycon ||
we_are_deriving ixClassKey tycon)
= returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
: (maxtag_RDR tycon, tycon, GenMaxTag)
= returnTc ( (maxtag_RDR tycon, tycon, GenMaxTag)
: acc_Names)
| otherwise
= returnTc acc_Names
......
......@@ -1081,17 +1081,9 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
var_RDR = qual_orig_name var
gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
= mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
[([WildPatIn], impossible_Expr)])
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
mk_stuff var = ([lit_pat], HsVar var_RDR)
where
lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
var_RDR = qual_orig_name var
= mk_FunMonoBind (getSrcLoc tycon) rdr_name
([([VarPatIn a_RDR], HsApp tagToEnum_Expr a_Expr)])
gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
= mk_easy_FunMonoBind (getSrcLoc tycon)
......@@ -1362,6 +1354,7 @@ false_Expr = HsVar false_RDR
true_Expr = HsVar true_RDR
getTag_Expr = HsVar getTag_RDR
tagToEnum_Expr = HsVar tagToEnumH_RDR
con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
a_Pat = VarPatIn a_RDR
......@@ -1369,7 +1362,7 @@ b_Pat = VarPatIn b_RDR
c_Pat = VarPatIn c_RDR
d_Pat = VarPatIn d_RDR
tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
......
......@@ -15,7 +15,7 @@ module Util (
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipEqual,
mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
nOfThem, lengthExceeds, isSingleton, only,
snocView,
isIn, isn'tIn,
......@@ -188,6 +188,13 @@ isSingleton :: [a] -> Bool
isSingleton [x] = True
isSingleton _ = False
only :: [a] -> a
#ifdef DEBUG
only [a] = a
#else
only (a:_) = a
#endif
\end{code}
\begin{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment