%
% (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 $
%
%********************************************************
%* *
)
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 )
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
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
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
-> [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]
)
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(..) )
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,
%
% (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 $
%
%********************************************************
%* *
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
-import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings )
+import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings)
import CgCase ( cgCase, saveVolatileVarsAndRegs,
restoreCurrentCostCentre, freeCostCentreSlot,
splitTyConAppThroughNewTypes )
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(..) )
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
ReturnsAlg tycon
| isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
-
| isEnumerationTyCon tycon ->
performReturn
(COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
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,
geH_RDR = prelude_primop IntGeOp
leH_RDR = prelude_primop IntLeOp
minusH_RDR = prelude_primop IntSubOp
+dataToTagH_RDR = prelude_primop DataToTagOp
\end{code}
\begin{code}
| CatchOp
| RaiseOp
+ -- foreign objects
| MakeForeignObjOp
| WriteForeignObjOp
+ -- weak pointers
| MkWeakOp
| DeRefWeakOp
| FinalizeWeakOp
+ -- stable names
| MakeStableNameOp
| EqStableNameOp
| StableNameToIntOp
+ -- stable pointers
| MakeStablePtrOp
| DeRefStablePtrOp
| EqStablePtrOp
| WaitReadOp
| WaitWriteOp
+ -- more parallel stuff
| ParGlobalOp -- named global par
| ParLocalOp -- named local par
| ParAtOp -- specifies destination of local par
| 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
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"
MyThreadIdOp,
DelayOp,
WaitReadOp,
- WaitWriteOp
+ WaitWriteOp,
+ DataToTagOp,
+ TagToEnumOp
]
\end{code}
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}
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.
-- 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
other -> ReturnsPrim other
isCompareOp :: PrimOp -> Bool
-
isCompareOp op
= case primOpInfo op of
Compare _ _ -> True
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
\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
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
\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
%************************************************************************
\begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg]
- -> UniqSM ([(Id,StgExpr)], [StgArg])
+coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([StgFloatBind], [StgArg])
coreArgsToStg env []
= returnUs ([], [])
-- 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') ->
([], 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
(_, 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
\begin{code}
coreExprToStg env expr
= coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
- returnUs (mkStgLets binds stg_expr)
+ returnUs (mkStgBinds binds stg_expr)
\end{code}
%************************************************************************
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))
\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))
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,
zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
import Maybes ( maybeToBool, assocMaybe )
+import Constants
import List ( partition, intersperse )
\end{code}
-> 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)])
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
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) ++ "#"))
projects / ghc-hetmet.git / commitdiff