%
% (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}
= InfoTblType
| ClosureType
| VecTblType
+ | ClosureTblType
| CodeType
| DataType
\end{code}
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
labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
labelType (CaseLabel _ CaseReturnPt) = CodeType
labelType (CaseLabel _ CaseVecTbl) = VecTblType
+labelType (TyConLabel _) = ClosureTblType
labelType (IdLabel _ info) =
case info of
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,
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 $
%
%********************************************************
%* *
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}
-> 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)
:: 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
| 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}
= 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}
= cgPrimInlineAlts bndr ty alts deflt
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
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,
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}
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 )
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.
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))
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 )
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
\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
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, [])
-- 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 ->
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
producing correctly-uniquified code on the fly. This is entirely
%************************************************************************
%* *
-\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
+\subsection[TcDeriv-taggery-Names]{What con2tag functions are available?}
%* *
%************************************************************************
data Foo ... = ...
con2tag_Foo :: Foo ... -> Int#
-tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
maxtag_Foo :: Int -- ditto (NB: not unboxed)
(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
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 ]
| 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
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)
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
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) ++ "#"))
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipEqual,
mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton,
+ nOfThem, lengthExceeds, isSingleton, only,
snocView,
isIn, isn'tIn,
isSingleton [x] = True
isSingleton _ = False
+
+only :: [a] -> a
+#ifdef DEBUG
+only [a] = a
+#else
+only (a:_) = a
+#endif
\end{code}
\begin{code}
projects / ghc-hetmet.git / commitdiff