Commit 5f7c1a7d authored by Ian Lynagh's avatar Ian Lynagh

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents b1f40f14 0076786d
......@@ -26,7 +26,7 @@ types that
module BasicTypes(
Version, bumpVersion, initialVersion,
Arity,
Arity, RepArity,
Alignment,
......@@ -101,7 +101,18 @@ import Data.Function (on)
%************************************************************************
\begin{code}
-- | The number of value arguments that can be applied to a value before it does
-- "real work". So:
-- fib 100 has arity 0
-- \x -> fib x has arity 1
type Arity = Int
-- | The number of represented arguments that can be applied to a value before it does
-- "real work". So:
-- fib 100 has representation arity 0
-- \x -> fib x has representation arity 1
-- \(# x, y #) -> fib (x + y) has representation arity 2
type RepArity = Int
\end{code}
%************************************************************************
......
......@@ -31,7 +31,7 @@ module DataCon (
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
......@@ -692,9 +692,14 @@ dataConSourceArity dc = length (dcOrigArgTys dc)
-- | Gives the number of actual fields in the /representation/ of the
-- data constructor. This may be more than appear in the source code;
-- the extra ones are the existentially quantified dictionaries
dataConRepArity :: DataCon -> Int
dataConRepArity :: DataCon -> Arity
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
-- | The number of fields in the /representation/ of the constructor
-- AFTER taking into account the unpacking of any unboxed tuple fields
dataConRepRepArity :: DataCon -> RepArity
dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc)
-- | Return whether there are any argument types for this 'DataCon's original source type
isNullarySrcDataCon :: DataCon -> Bool
isNullarySrcDataCon dc = null (dcOrigArgTys dc)
......
......@@ -41,8 +41,8 @@ module Id (
mkWorkerId, mkWiredInIdName,
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
idPrimRep, recordSelectorFieldLabel,
idName, idType, idUnique, idInfo, idDetails, idRepArity,
recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
......@@ -158,9 +158,6 @@ idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
setIdName :: Id -> Name -> Id
setIdName = Var.setVarName
......@@ -462,6 +459,9 @@ idArity id = arityInfo (idInfo id)
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
idRepArity :: Id -> RepArity
idRepArity x = typeRepArity (idArity x) (idType x)
-- | Returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
......
......@@ -72,7 +72,7 @@ module CmmUtils(
#include "HsVersions.h"
import TyCon ( PrimRep(..) )
import Type ( Type, typePrimRep )
import Type ( UnaryType, typePrimRep )
import SMRep
import Cmm
......@@ -108,7 +108,7 @@ primRepCmmType AddrRep = bWord
primRepCmmType FloatRep = f32
primRepCmmType DoubleRep = f64
typeCmmType :: Type -> CmmType
typeCmmType :: UnaryType -> CmmType
typeCmmType ty = primRepCmmType (typePrimRep ty)
primRepForeignHint :: PrimRep -> ForeignHint
......@@ -122,7 +122,7 @@ primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
typeForeignHint :: Type -> ForeignHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep
---------------------------------------------------
......
......@@ -411,15 +411,12 @@ getArgAmode (StgLitArg lit)
= do { cmm_lit <- cgLit lit
; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
| isStgTypeArg atom = getArgAmodes atoms
| otherwise = do { amode <- getArgAmode atom
; amodes <- getArgAmodes atoms
; return ( amode : amodes ) }
= do { amode <- getArgAmode atom
; amodes <- getArgAmodes atoms
; return ( amode : amodes ) }
\end{code}
%************************************************************************
......
......@@ -72,7 +72,7 @@ cgTopRhsCon id con args
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags con args) ) return ()
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-- LAY IT OUT
; amodes <- getArgAmodes args
......@@ -324,7 +324,7 @@ cgReturnDataCon con amodes
-- for it to be marked as "used" for LDV profiling.
| opt_SccProfilingOn = build_it_then enter_it
| otherwise
= ASSERT( amodes `lengthIs` dataConRepArity con )
= ASSERT( amodes `lengthIs` dataConRepRepArity con )
do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
; case sequel of
CaseAlts _ (Just (alts, deflt_lbl)) bndr
......@@ -466,8 +466,8 @@ cgDataCon data_con
; ldvEnter (CmmReg nodeReg)
; body_code }
arg_reps :: [(CgRep, Type)]
arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
arg_reps :: [(CgRep, UnaryType)]
arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
body_code = do {
-- NB: We don't set CC when entering data (WDP 94/06)
......
......@@ -480,7 +480,7 @@ Little helper for primitives that return unboxed tuples.
newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
newUnboxedTupleRegs res_ty =
let
ty_args = tyConAppArgs (repType res_ty)
UbxTupleRep ty_args = repType res_ty
(reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
let rep = typeCgRep ty,
nonVoidArg rep ]
......
......@@ -311,4 +311,5 @@ shimForeignCallArg arg expr
| otherwise = expr
where
-- should be a tycon app, since this is a foreign call
tycon = tyConAppTyCon (repType (stgArgType arg))
UnaryRep rep_ty = repType (stgArgType arg)
tycon = tyConAppTyCon rep_ty
......@@ -20,6 +20,8 @@ the STG paper.
-- for details
module ClosureInfo (
idRepArity,
ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but
StandardFormInfo(..), -- mkCmmInfo looks inside
SMRep,
......@@ -157,7 +159,7 @@ ClosureInfo contains a LambdaFormInfo.
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
!Int -- Arity. Invariant: always > 0
!RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
......@@ -181,7 +183,7 @@ data LambdaFormInfo
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
!Int -- arity;
!RepArity -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-- of a CAF. We want the target of the update frame to
......@@ -212,7 +214,7 @@ data StandardFormInfo
-- The code for the thunk just pushes x2..xn on the stack and enters x1.
-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-- in the RTS to save space.
Int -- Arity, n
RepArity -- Arity, n
\end{code}
......@@ -289,7 +291,7 @@ idCgRep x = typeCgRep . idType $ x
tyConCgRep :: TyCon -> CgRep
tyConCgRep = primRepToCgRep . tyConPrimRep
typeCgRep :: Type -> CgRep
typeCgRep :: UnaryType -> CgRep
typeCgRep = primRepToCgRep . typePrimRep
\end{code}
......@@ -385,9 +387,12 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
= case tyConAppTyCon_maybe (repType ty) of
Just tc -> not (isDataTyCon tc)
Nothing -> True
| UnaryRep rep <- repType ty
, Just tc <- tyConAppTyCon_maybe rep
, isDataTyCon tc
= False
| otherwise
= True
\end{code}
@mkConLFInfo@ is similar, for constructors.
......@@ -405,7 +410,7 @@ mkSelectorLFInfo id offset updatable
= LFThunk NotTopLevel False updatable (SelectorThunk offset)
(might_be_a_function (idType id))
mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo
mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo
mkApLFInfo id upd_flag arity
= LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
(might_be_a_function (idType id))
......@@ -417,12 +422,12 @@ Miscellaneous LF-infos.
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id = LFUnknown (might_be_a_function (idType id))
mkLFLetNoEscape :: Int -> LambdaFormInfo
mkLFLetNoEscape :: RepArity -> LambdaFormInfo
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
= case idArity id of
= case idRepArity id of
n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0
_ -> mkLFArgument id -- Not sure of exact arity
\end{code}
......@@ -635,13 +640,13 @@ data CallMethod
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
RepArity -- Its arity
getCallMethod :: DynFlags
-> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> RepArity -- Number of available arguments
-> CallMethod
getCallMethod _ _ _ lf_info _
......@@ -912,11 +917,11 @@ isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon
isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
isConstrClosure_maybe _ = Nothing
closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
closureFunInfo _ = Nothing
lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
......@@ -936,7 +941,7 @@ funTagLFInfo lf
| otherwise
= 0
tagForArity :: Int -> Maybe Int
tagForArity :: RepArity -> Maybe Int
tagForArity i | i <= mAX_PTR_TAG = Just i
| otherwise = Nothing
......
......@@ -274,8 +274,8 @@ cgDataCon data_con
(tagForCon data_con)] }
-- The case continuation code expects a tagged pointer
arg_reps :: [(PrimRep, Type)]
arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
arg_reps :: [(PrimRep, UnaryType)]
arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
-- Dynamic closure code for non-nullary constructors only
; whenC (not (isNullaryRepDataCon data_con))
......
......@@ -21,8 +21,8 @@ module StgCmmClosure (
DynTag, tagForCon, isSmallFamily,
ConTagZ, dataConTagZ,
isVoidRep, isGcPtrRep, addIdReps, addArgReps,
argPrimRep,
idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
argPrimRep,
-- * LambdaFormInfo
LambdaFormInfo, -- Abstract
......@@ -98,6 +98,10 @@ import Util
-- Why are these here?
-- NB: this is reliable because by StgCmm no Ids have unboxed tuple type
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
addIdReps :: [Id] -> [(PrimRep, Id)]
addIdReps ids = [(idPrimRep id, id) | id <- ids]
......@@ -128,7 +132,7 @@ isGcPtrRep _ = False
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
!Int -- Arity. Invariant: always > 0
!RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should really be in ClosureInfo)
......@@ -189,7 +193,7 @@ data StandardFormInfo
-- The code for the thunk just pushes x2..xn on the stack and enters x1.
-- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
-- in the RTS to save space.
Int -- Arity, n
RepArity -- Arity, n
------------------------------------------------------
......@@ -232,9 +236,12 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
= case tyConAppTyCon_maybe (repType ty) of
Just tc -> not (isDataTyCon tc)
Nothing -> True
| UnaryRep rep <- repType ty
, Just tc <- tyConAppTyCon_maybe rep
, isDataTyCon tc
= False
| otherwise
= True
-------------
mkConLFInfo :: DataCon -> LambdaFormInfo
......@@ -267,7 +274,7 @@ mkLFImported id
| otherwise
= mkLFArgument id -- Not sure of exact arity
where
arity = idArity id
arity = idRepArity id
------------
mkLFBlackHole :: LambdaFormInfo
......@@ -310,7 +317,7 @@ tagForCon con
con_tag = dataConTagZ con
fam_size = tyConFamilySize (dataConTyCon con)
tagForArity :: Int -> DynTag
tagForArity :: RepArity -> DynTag
tagForArity arity | isSmallFamily arity = arity
| otherwise = 0
......@@ -459,13 +466,13 @@ data CallMethod
| DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
RepArity -- Its arity
getCallMethod :: DynFlags
-> Name -- Function being applied
-> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> RepArity -- Number of available arguments
-> CallMethod
getCallMethod _ _name _ lf_info _n_args
......@@ -745,10 +752,10 @@ closureReEntrant :: ClosureInfo -> Bool
closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
closureReEntrant _ = False
closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr)
lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
lfFunInfo _ = Nothing
......
......@@ -62,7 +62,7 @@ cgTopRhsCon id con args
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags con args) ) return ()
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-- LAY IT OUT
; let
......
......@@ -201,7 +201,6 @@ getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode (NonVoid (StgVarArg var)) =
do { info <- getCgIdInfo var; return (idInfoToAmode info) }
getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg"
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
......
......@@ -497,7 +497,7 @@ cgConApp con stg_args
; emitReturn arg_exprs }
| otherwise -- Boxed constructors; allocate and return
= ASSERT( stg_args `lengthIs` dataConRepArity con )
= ASSERT( stg_args `lengthIs` dataConRepRepArity con )
do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
-- The first "con" says that the name bound to this closure is
-- is "con", which is a bit of a fudge, but it only affects profiling
......
......@@ -304,5 +304,6 @@ add_shim arg_ty expr
| otherwise = expr
where
tycon = tyConAppTyCon (repType arg_ty)
UnaryRep rep_ty = repType arg_ty
tycon = tyConAppTyCon rep_ty
-- should be a tycon app, since this is a foreign call
......@@ -50,7 +50,7 @@ import StgSyn
import Id
import Name
import TyCon ( PrimRep(..) )
import BasicTypes ( Arity )
import BasicTypes ( RepArity )
import DynFlags
import StaticFlags
......@@ -128,7 +128,7 @@ adjustHpBackwards
-- Making calls: directCall and slowCall
-------------------------------------------------------------------------
directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
directCall :: CLabel -> RepArity -> [StgArg] -> FCode ()
-- (directCall f n args)
-- calls f(arg1, ..., argn), and applies the result to the remaining args
-- The function f has arity n, and there are guaranteed at least n args
......@@ -144,7 +144,7 @@ slowCall fun stg_args
; slow_call fun cmm_args (argsReps stg_args) }
--------------
direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [ArgRep] -> FCode ()
direct_call :: String -> CLabel -> RepArity -> [CmmExpr] -> [ArgRep] -> FCode ()
-- NB1: (length args) may be less than (length reps), because
-- the args exclude the void ones
-- NB2: 'arity' refers to the *reps*
......@@ -186,7 +186,7 @@ slow_call fun args reps
(rts_fun, arity) = slowCallPattern reps
-- These cases were found to cover about 99% of all slow calls:
slowCallPattern :: [ArgRep] -> (FastString, Arity)
slowCallPattern :: [ArgRep] -> (FastString, RepArity)
-- Returns the generic apply function and arity
slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5)
......
......@@ -197,7 +197,7 @@ registerTickyCtr ctr_lbl
(CmmLit (mkIntCLit 1)) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
tickyReturnOldCon arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
; bumpHistogram (fsLit "RET_OLD_hst") arity }
......@@ -205,7 +205,7 @@ tickyReturnNewCon arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
; bumpHistogram (fsLit "RET_NEW_hst") arity }
tickyUnboxedTupleReturn :: Int -> FCode ()
tickyUnboxedTupleReturn :: RepArity -> FCode ()
tickyUnboxedTupleReturn arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
......@@ -219,7 +219,7 @@ tickyVectoredReturn family_size
-- Ticky calls
-- Ticks at a *call site*:
tickyDirectCall :: Arity -> [StgArg] -> FCode ()
tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
tickyDirectCall arity args
| arity == length args = tickyKnownCallExact
| otherwise = do tickyKnownCallExtraArgs
......
......@@ -458,7 +458,7 @@ newUnboxedTupleRegs res_ty
; ASSERT( regs `equalLength` reps )
return (regs, map primRepForeignHint reps) }
where
ty_args = tyConAppArgs (repType res_ty)
UbxTupleRep ty_args = repType res_ty
reps = [ rep
| ty <- ty_args
, let rep = typePrimRep ty
......
......@@ -352,17 +352,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
; subst <- getTvSubst
; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
-- If the binder is an unboxed tuple type, don't put it in scope
; let scope = if (isUnboxedTupleType (idType var)) then
pass_var
else lintAndScopeId var
; scope $ \_ ->
; lintAndScopeId var $ \_ ->
do { -- Check the alternatives
mapM_ (lintCoreAlt scrut_ty alt_ty) alts
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
pass_var f = f var
lintCoreExpr (Type ty)
= do { ty' <- lintInTy ty
......@@ -598,10 +592,7 @@ lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
-- ToDo: lint its rules
lintIdBndr id linterF
= do { checkL (not (isUnboxedTupleType (idType id)))
(mkUnboxedTupleMsg id)
-- No variable can be bound to an unboxed tuple.
; lintAndScopeId id $ \id' -> linterF id' }
= do { lintAndScopeId id $ \id' -> linterF id' }
lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
lintAndScopeIds ids linterF
......@@ -1257,11 +1248,6 @@ mkArityMsg binder
]
where (StrictSig dmd_ty) = idStrictness binder
mkUnboxedTupleMsg :: Id -> MsgDoc
mkUnboxedTupleMsg binder
= vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
mkCastErr expr co from_ty expr_ty
= vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
......
......@@ -155,7 +155,7 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
eqn_rhs = cantFailMatchResult body }
; var <- selectMatchVar upat
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (scrungleMatch var rhs result) }
; return (bindNonRec var rhs result) }
dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
......@@ -164,38 +164,13 @@ strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds })
= anyBag (strictMatchOnly . unLoc) binds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
= isUnboxedTupleType ty
= isUnLiftedType ty
|| isBangLPat lpat
|| any (isUnLiftedType . idType) (collectPatBinders lpat)
strictMatchOnly (FunBind { fun_id = L _ id })
= isUnLiftedType (idType id)
strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- Returns something like (let var = scrut in body)
-- but if var is an unboxed-tuple type, it inlines it in a fragile way
-- Special case to handle unboxed tuple patterns; they can't appear nested
-- The idea is that
-- case e of (# p1, p2 #) -> rhs
-- should desugar to
-- case e of (# x1, x2 #) -> ... match p1, p2 ...
-- NOT
-- let x = e in case x of ....
--
-- But there may be a big
-- let fail = ... in case e of ...
-- wrapping the whole case, which complicates matters slightly
-- It all seems a bit fragile. Test is dsrun013.
scrungleMatch var scrut body
| isUnboxedTupleType (idType var) = scrungle body
| otherwise = bindNonRec var scrut body
where
scrungle (Case (Var x) bndr ty alts)
| x == var = Case scrut bndr ty alts
scrungle (Let binds body) = Let binds (scrungle body)
scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
\end{code}
%************************************************************************
......@@ -327,7 +302,7 @@ dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
| otherwise
= do { core_discrim <- dsLExpr discrim
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return (scrungleMatch discrim_var core_discrim matching_code) }
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
......
......@@ -709,9 +709,12 @@ toCType = f False
= pprPanic "toCType" (ppr t)
typeTyCon :: Type -> TyCon
typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
Just (tc,_) -> tc
Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty)
typeTyCon ty
| UnaryRep rep_ty <- repType ty
, Just (tc, _) <- tcSplitTyConApp_maybe rep_ty
= tc
| otherwise
= pprPanic "DsForeign.typeTyCon" (ppr ty)
insertRetAddr :: DynFlags -> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
......@@ -754,7 +757,7 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined,
-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#).
getPrimTyOf :: Type -> Type
getPrimTyOf :: Type -> UnaryType
getPrimTyOf ty
| isBoolTy rep_ty = intPrimTy
-- Except for Bool, the types we are interested in have a single constructor
......@@ -767,7 +770,7 @@ getPrimTyOf ty
prim_ty
_other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
where
rep_ty = repType ty
UnaryRep rep_ty = repType ty
-- represent a primitive type as a Char, for building a string that
-- described the foreign function type. The types are size-dependent,
......
......@@ -360,6 +360,7 @@ Library
SRT
SimplStg
StgStats
UnariseStg
Rules
SpecConstr
Specialise
......
......@@ -271,8 +271,12 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
collect (_, e) = go [] e
where
go xs e | Just e' <- bcView e = go xs e'
go xs (AnnLam x (_,e)) = go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
go xs (AnnLam x (_,e))
| UbxTupleRep _ <- repType (idType x)
= unboxedTupleException
| otherwise
= go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
......@@ -486,7 +490,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-- no alts: scrut is guaranteed to diverge
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
| isUnboxedTupleCon dc, UnaryRep rep_ty <- repType (idType bind1), VoidRep <- typePrimRep rep_ty
-- Convert
-- case .... of x { (# VoidArg'd-thing, a #) -> ... }
-- to
......@@ -499,12 +503,12 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
= --trace "automagic mashing of case alts (# VoidArg, a #)" $
doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
| isUnboxedTupleCon dc, UnaryRep rep_ty <- repType (idType bind2), VoidRep <- typePrimRep rep_ty
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
| isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
-- Similarly, convert
-- case .... of x { (# a #) -> ... }
-- to
......@@ -603,7 +607,8 @@ schemeT d s p app
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call
= let extract_constr_Names ty
| Just tyc <- tyConAppTyCon_maybe (repType ty),
| UnaryRep rep_ty <- repType ty
, Just tyc <- tyConAppTyCon_maybe rep_ty,
isDataTyCon tyc
= map (getName . dataConWorkId) (tyConDataCons tyc)
-- NOTE: use the worker name, not the source name of
......@@ -746,6 +751,9 @@ doCase :: Word -> Sequel -> BCEnv
-> Bool -- True <=> is an unboxed tuple case, don't enter the result
-> BcM BCInstrList
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| UbxTupleRep _ <- repType (idType bndr)
= unboxedTupleException
| otherwise
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
......@@ -785,6 +793,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
| any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
= unboxedTupleException
-- algebraic alt with some binders
| otherwise =
let
......@@ -903,7 +913,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
pargs _ [] = return []
pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))