From 699e9f229be993270e49ff7fcdd155508502c6ea Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Fri, 23 Apr 1999 13:53:35 +0000
Subject: [PATCH] [project @ 1999-04-23 13:53:28 by simonm] Support for
dataToTag# :: a -> Int# (if a is a data type)
and (partial) support for
tagToEnum# :: Int# -> a (if a is an enumerated type)
The con2tag functions generated by derived Eq,Ord and Enum instances
are now replaced by dataToTag# for data types with a large number of
constructors.
---
ghc/compiler/codeGen/CgCase.lhs | 70 ++++++++++++++++-----------
ghc/compiler/codeGen/CgConTbls.lhs | 4 +-
ghc/compiler/codeGen/CgExpr.lhs | 27 +++++++++--
ghc/compiler/prelude/PrelInfo.lhs | 3 +-
ghc/compiler/prelude/PrimOp.lhs | 50 +++++++++++++++++--
ghc/compiler/simplCore/ConFold.lhs | 16 ++++++
ghc/compiler/stgSyn/CoreToStg.lhs | 44 ++++++++++++-----
ghc/compiler/typecheck/TcGenDeriv.lhs | 17 +++++--
8 files changed, 175 insertions(+), 56 deletions(-)
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 99eb1ab89ec9..2182c17b8d8b 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.25 1999/03/22 16:57:10 simonm Exp $
+% $Id: CgCase.lhs,v 1.26 1999/04/23 13:53:28 simonm Exp $
%
%********************************************************
%* *
@@ -27,12 +27,12 @@ import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
)
import CoreSyn ( isDeadBinder )
import CgUpdate ( reserveSeqFrame )
-import CgBindery ( getVolatileRegs, getArgAmodes,
+import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode,
bindNewToReg, bindNewToTemp,
bindNewPrimToAmode,
rebindToStack, getCAddrMode,
getCAddrModeAndInfo, getCAddrModeIfVolatile,
- buildContLivenessMask, nukeDeadBindings
+ buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
import CgHeapery ( altHeapCheck, yield )
@@ -62,8 +62,9 @@ import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
tyConDataCons, tyConFamilySize )
-import Type ( Type, typePrimRep, splitAlgTyConApp, splitTyConApp_maybe,
- splitFunTys, applyTys )
+import Type ( Type, typePrimRep, splitAlgTyConApp,
+ splitTyConApp_maybe,
+ splitFunTys, applyTys )
import Unique ( Unique, Uniquable(..) )
import Maybes ( maybeToBool )
import Outputable
@@ -116,14 +117,6 @@ Against:
This never hurts us if there is only one alternative.
-
-*** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
-to take account of what is live, and that includes all live volatile
-variables, even if they also have stable analogues. Furthermore, the
-stack pointers must be lined up properly so that GC sees tidy stacks.
-If these things are done, then the heap checks can be done at \tr{!B!} and
-\tr{!C!} without a full save-volatile-vars sequence.
-
\begin{code}
cgCase :: StgExpr
-> StgLiveVars
@@ -137,7 +130,26 @@ cgCase :: StgExpr
Several special cases for inline primitive operations.
\begin{code}
-cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt alts
+cgCase (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
+ live_in_whole_case live_in_alts bndr srt alts
+ | isEnumerationTyCon tycon
+ = getArgAmode arg `thenFC` \amode ->
+ let
+ [res] = getPrimAppResultAmodes (getUnique bndr) alts
+ in
+ absC (CAssign res (CTableEntry
+ (CLbl (mkClosureTblLabel tycon) PtrRep)
+ amode PtrRep)) `thenC`
+
+ -- Scrutinise the result
+ cgInlineAlts bndr alts
+
+ | otherwise = panic "cgCase: tagToEnum# of non-enumerated type"
+ where
+ (Just (tycon,_)) = splitTyConApp_maybe res_ty
+
+cgCase (StgCon (PrimOp op) args res_ty)
+ live_in_whole_case live_in_alts bndr srt alts
| not (primOpOutOfLine op)
=
-- Get amodes for the arguments and results
@@ -338,22 +350,22 @@ getPrimAppResultAmodes
-> [CAddrMode]
\end{code}
-\begin{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.
+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]
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 6e4a1493c1a4..12c50649ffb4 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -20,7 +20,7 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon,
)
import CostCentre ( dontCareCCS )
import FiniteMap ( fmToList, FiniteMap )
-import DataCon ( DataCon, dataConTag, dataConName, dataConRawArgTys )
+import DataCon ( DataCon, dataConName, dataConRawArgTys )
import Const ( Con(..) )
import Name ( getOccString )
import PrimRep ( getPrimRepSize, PrimRep(..) )
@@ -142,8 +142,6 @@ genConInfo comp_info tycon data_con
static_code = CClosureInfoAndCode static_ci body Nothing con_descr
- tag = dataConTag data_con
-
cost_centre = mkCCostCentreStack dontCareCCS -- not worried about static data costs
-- For zero-arity data constructors, or, more accurately,
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 6e02c259f037..7b11429f4eaf 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.22 1999/03/25 13:13:51 simonm Exp $
+% $Id: CgExpr.lhs,v 1.23 1999/04/23 13:53:29 simonm Exp $
%
%********************************************************
%* *
@@ -22,7 +22,7 @@ import AbsCUtils ( mkAbstractCs )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
-import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings )
+import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings)
import CgCase ( cgCase, saveVolatileVarsAndRegs,
restoreCurrentCostCentre, freeCostCentreSlot,
splitTyConAppThroughNewTypes )
@@ -48,7 +48,7 @@ import PrimOp ( primOpOutOfLine,
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, typePrimRep )
+import Type ( Type, typePrimRep, splitTyConApp_maybe )
import Maybes ( assocMaybe, maybeToBool )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
@@ -116,12 +116,30 @@ NOTE about _ccall_GC_:
A _ccall_GC_ is treated as an out-of-line primop for the case
expression code, because we want a proper stack frame on the stack
when we perform it. When we get here, however, we need to actually
-perform the call, so we treat it an an inline primop.
+perform the call, so we treat it as an inline primop.
\begin{code}
cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
= primRetUnboxedTuple op args res_ty
+-- tagToEnum# is special: we need to pull the constructor out of the table,
+-- and perform an appropriate return.
+
+cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
+ | isEnumerationTyCon tycon =
+ getArgAmode arg `thenFC` \amode ->
+ performReturn (CAssign (CReg node)
+ (CTableEntry
+ (CLbl (mkClosureTblLabel tycon) PtrRep)
+ amode PtrRep))
+ (\ sequel -> mkDynamicAlgReturnCode tycon amode sequel)
+
+ | otherwise = panic "cgExpr: tagToEnum# of non-enumerated type"
+
+ where
+ (Just (tycon,_)) = splitTyConApp_maybe res_ty
+
+
cgExpr x@(StgCon (PrimOp op) args res_ty)
| primOpOutOfLine op = tailCallPrimOp op args
| otherwise
@@ -144,7 +162,6 @@ cgExpr x@(StgCon (PrimOp op) args res_ty)
ReturnsAlg tycon
| isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
-
| isEnumerationTyCon tycon ->
performReturn
(COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 487708644fe6..de18e05b9661 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -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,
+ error_RDR, assertErr_RDR, dataToTagH_RDR,
showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
@@ -566,6 +566,7 @@ ltH_Int_RDR = prelude_primop IntLtOp
geH_RDR = prelude_primop IntGeOp
leH_RDR = prelude_primop IntLeOp
minusH_RDR = prelude_primop IntSubOp
+dataToTagH_RDR = prelude_primop DataToTagOp
\end{code}
\begin{code}
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index e92b6ec8ad9c..d43d498bb380 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -172,17 +172,21 @@ data PrimOp
| CatchOp
| RaiseOp
+ -- foreign objects
| MakeForeignObjOp
| WriteForeignObjOp
+ -- weak pointers
| MkWeakOp
| DeRefWeakOp
| FinalizeWeakOp
+ -- stable names
| MakeStableNameOp
| EqStableNameOp
| StableNameToIntOp
+ -- stable pointers
| MakeStablePtrOp
| DeRefStablePtrOp
| EqStablePtrOp
@@ -280,6 +284,7 @@ about using it this way?? ADR)
| WaitReadOp
| WaitWriteOp
+ -- more parallel stuff
| ParGlobalOp -- named global par
| ParLocalOp -- named local par
| ParAtOp -- specifies destination of local par
@@ -288,6 +293,10 @@ about using it this way?? ADR)
| ParAtForNowOp -- specifies initial destination of global par
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
+
+ -- tag-related
+ | DataToTagOp
+ | TagToEnumOp
\end{code}
Used for the Ord instance
@@ -546,6 +555,8 @@ tagOf_PrimOp WriteMutVarOp = ILIT(239)
tagOf_PrimOp SameMutVarOp = ILIT(240)
tagOf_PrimOp CatchOp = ILIT(241)
tagOf_PrimOp RaiseOp = ILIT(242)
+tagOf_PrimOp DataToTagOp = ILIT(243)
+tagOf_PrimOp TagToEnumOp = ILIT(244)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
--panic# "tagOf_PrimOp: pattern-match"
@@ -810,7 +821,9 @@ allThePrimOps
MyThreadIdOp,
DelayOp,
WaitReadOp,
- WaitWriteOp
+ WaitWriteOp,
+ DataToTagOp,
+ TagToEnumOp
]
\end{code}
@@ -909,6 +922,8 @@ primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False)
primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False)
primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False)
+primOpStrictness DataToTagOp = ([wwLazy], False)
+
-- The rest all have primitive-typed arguments
primOpStrictness other = (repeat wwPrim, False)
\end{code}
@@ -1837,11 +1852,40 @@ primOpInfo (CCallOp _ _ _ _ arg_tys result_ty)
where
(result_tycon, tys_applied, _) = splitAlgTyConApp result_ty
-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[PrimOp-tag]{PrimOpInfo for @dataToTag#@ and @tagToEnum#@}
+%* *
+%************************************************************************
+
+These primops are pretty wierd.
+
+ dataToTag# :: a -> Int (arg must be an evaluated data type)
+ tagToEnum# :: Int -> a (result type must be an enumerated type)
+
+The constraints aren't currently checked by the front end, but the
+code generator will fall over if they aren't satisfied.
+
+\begin{code}
+primOpInfo DataToTagOp
+ = mkGenPrimOp SLIT("dataToTag#") [alphaTyVar] [alphaTy] intPrimTy
+
+primOpInfo TagToEnumOp
+ = mkGenPrimOp SLIT("tagToEnum#") [alphaTyVar] [intPrimTy] alphaTy
+
#ifdef DEBUG
primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
#endif
\end{code}
+%************************************************************************
+%* *
+\subsubsection[PrimOp-ool]{Which PrimOps are out-of-line}
+%* *
+%************************************************************************
+
Some PrimOps need to be called out-of-line because they either need to
perform a heap check or they block.
@@ -2066,12 +2110,11 @@ data PrimOpResultInfo
-- be out of line, or the code generator won't work.
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-
getPrimOpResultInfo op
= case (primOpInfo op) of
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
- Compare _ ty -> ReturnsAlg boolTyCon
+ Compare _ ty -> ReturnsAlg boolTyCon
GenPrimOp _ _ _ ty ->
let rep = typePrimRep ty in
case rep of
@@ -2081,7 +2124,6 @@ getPrimOpResultInfo op
other -> ReturnsPrim other
isCompareOp :: PrimOp -> Bool
-
isCompareOp op
= case primOpInfo op of
Compare _ _ -> True
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 8d74489c3b97..07c1cbaa04d2 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -18,6 +18,9 @@ import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) )
import PrimOp ( PrimOp(..) )
import SimplMonad
import TysWiredIn ( trueDataCon, falseDataCon )
+import TyCon ( tyConDataCons, isEnumerationTyCon )
+import DataCon ( dataConTag, fIRST_TAG )
+import Type ( splitTyConApp_maybe )
import Char ( ord, chr )
import Outputable
@@ -93,6 +96,19 @@ tryPrimOp SeqOp args@[Type ty, Var var]
| otherwise = Nothing -- var not eval'd
\end{code}
+\begin{code}
+tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
+ | isEnumerationTyCon tycon = Just (Con (DataCon dc) [])
+ | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type"
+ where tag = fromInteger i
+ constrs = tyConDataCons tycon
+ (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc ]
+ (Just (tycon,_)) = splitTyConApp_maybe ty
+
+tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
+ = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+\end{code}
+
\begin{code}
tryPrimOp op args
= case args of
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 199a9a0abad8..f97ea1b6aa36 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -31,6 +31,7 @@ import VarEnv
import Const ( Con(..), isWHNFCon, Literal(..) )
import PrimOp ( PrimOp(..) )
import Type ( isUnLiftedType, isUnboxedTupleType, Type )
+import TysPrim ( intPrimTy )
import Unique ( Unique, Uniquable(..) )
import UniqSupply -- all of it, really
import Outputable
@@ -72,6 +73,10 @@ invariant any longer.)
\begin{code}
type StgEnv = IdEnv Id
+
+data StgFloatBind
+ = LetBind Id StgExpr
+ | CaseBind Id StgExpr
\end{code}
No free/live variable information is pinned on in this pass; it's added
@@ -229,8 +234,7 @@ isDynName nm =
%************************************************************************
\begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg]
- -> UniqSM ([(Id,StgExpr)], [StgArg])
+coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([StgFloatBind], [StgArg])
coreArgsToStg env []
= returnUs ([], [])
@@ -245,7 +249,7 @@ coreArgsToStg env (a:as)
-- This is where we arrange that a non-trivial argument is let-bound
-coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([(Id,StgExpr)], StgArg)
+coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([StgFloatBind], StgArg)
coreArgToStg env arg
= coreExprToStgFloat env arg `thenUs` \ (binds, arg') ->
@@ -254,7 +258,7 @@ coreArgToStg env arg
([], StgApp v []) -> returnUs ([], StgVarArg v)
-- A non-trivial argument: we must let (or case-bind)
- -- We don't do the case part here... we leave that to mkStgLets
+ -- We don't do the case part here... we leave that to mkStgBinds
-- Further complication: if we're converting this binding into
-- a case, then try to avoid generating any case-of-case
@@ -262,8 +266,8 @@ coreArgToStg env arg
(_, other) ->
newStgVar ty `thenUs` \ v ->
if isUnLiftedType ty
- then returnUs (binds ++ [(v,arg')], StgVarArg v)
- else returnUs ([(v, mkStgLets binds arg')], StgVarArg v)
+ then returnUs (binds ++ [CaseBind v arg'], StgVarArg v)
+ else returnUs ([LetBind v (mkStgBinds binds arg')], StgVarArg v)
where
ty = coreExprType arg
@@ -369,7 +373,7 @@ The rest are handled by coreExprStgFloat.
\begin{code}
coreExprToStg env expr
= coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
- returnUs (mkStgLets binds stg_expr)
+ returnUs (mkStgBinds binds stg_expr)
\end{code}
%************************************************************************
@@ -433,6 +437,16 @@ coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args)
let con' = PrimOp (CCallOp (Right u) a b c) in
returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
+-- for dataToTag#, we need to make sure the argument is evaluated first.
+coreExprToStgFloat env expr@(Con op@(PrimOp DataToTagOp) [Type ty, a])
+ = newStgVar ty `thenUs` \ v ->
+ coreArgToStg env a `thenUs` \ (binds, arg) ->
+ let e = case arg of
+ StgVarArg v -> StgApp v []
+ StgConArg c -> StgCon c [] (coreExprType a)
+ in
+ returnUs (binds ++ [CaseBind v e], StgCon op [StgVarArg v] (coreExprType expr))
+
coreExprToStgFloat env expr@(Con con args)
= coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
returnUs (binds, StgCon con stg_atoms (coreExprType expr))
@@ -541,12 +555,20 @@ newLocalIds env (b:bs)
\begin{code}
-mkStgLets :: [(Id,StgExpr)] -> StgExpr -> StgExpr
-mkStgLets binds body = foldr mkStgLet body binds
+mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr
+mkStgBinds binds body = foldr mkStgBind body binds
+
+mkStgBind (CaseBind bndr rhs) body
+ | isUnLiftedType bndr_ty
+ = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
+ | otherwise
+ = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
+ where
+ bndr_ty = idType bndr
-mkStgLet (bndr, rhs) body
+mkStgBind (LetBind bndr rhs) body
| isUnboxedTupleType bndr_ty
- = panic "mkStgLets: unboxed tuple"
+ = panic "mkStgBinds: unboxed tuple"
| isUnLiftedType bndr_ty
= mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index cdad85935fcc..884817e258db 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -49,7 +49,7 @@ import PrimOp ( PrimOp(..) )
import PrelInfo -- Lots of RdrNames
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
- maybeTyConSingleCon
+ maybeTyConSingleCon, tyConFamilySize
)
import Type ( isUnLiftedType, isUnboxedType, Type )
import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
@@ -59,6 +59,7 @@ import Util ( mapAccumL, zipEqual, zipWithEqual,
zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
import Maybes ( maybeToBool, assocMaybe )
+import Constants
import List ( partition, intersperse )
\end{code}
@@ -1063,16 +1064,25 @@ gen_tag_n_con_monobind
-> RdrNameMonoBinds
gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
+ | lots_of_constructors
+ = mk_FunMonoBind (getSrcLoc tycon) rdr_name
+ [([VarPatIn a_RDR], HsApp dataToTag_Expr a_Expr)]
+
+ | otherwise
= mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
+
where
- mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
+ lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+ mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
mk_stuff var
= ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
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)])
@@ -1351,6 +1361,7 @@ gtTag_Expr = HsVar gtTag_RDR
false_Expr = HsVar false_RDR
true_Expr = HsVar true_RDR
+dataToTag_Expr = HsVar dataToTagH_RDR
con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
a_Pat = VarPatIn a_RDR
@@ -1358,7 +1369,7 @@ b_Pat = VarPatIn b_RDR
c_Pat = VarPatIn c_RDR
d_Pat = VarPatIn d_RDR
-con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
+tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
--
GitLab