diff options
Diffstat (limited to 'ghc')
| -rw-r--r-- | ghc/compiler/codeGen/CgCase.lhs | 70 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgConTbls.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgExpr.lhs | 27 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelInfo.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrimOp.lhs | 50 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/ConFold.lhs | 16 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/CoreToStg.lhs | 44 | ||||
| -rw-r--r-- | 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 99eb1ab89e..2182c17b8d 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 6e4a1493c1..12c50649ff 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 6e02c259f0..7b11429f4e 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 487708644f..de18e05b96 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 e92b6ec8ad..d43d498bb3 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 8d74489c3b..07c1cbaa04 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 @@ -94,6 +97,19 @@ tryPrimOp SeqOp args@[Type ty, Var var] \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 [Con (Literal (MachChar char_lit)) _] -> oneCharLit op char_lit diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 199a9a0aba..f97ea1b6aa 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 cdad85935f..884817e258 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) ++ "#")) |